Require Import UniMath.Foundations.Sets.
Require Import UniMath.MoreFoundations.PartA.

Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.Isos.

Require Import UniMath.CategoryTheory.DisplayedCats.Core.
Require Import UniMath.CategoryTheory.DisplayedCats.Isos.

Local Open Scope cat.

(** ** Functors over functors between bases *)

(** One could define these in terms of functor-liftings, as:

[[
Definition disp_functor {C C' : category} (F : functor C C')
    (D : disp_cat C) (D' : disp_cat C')
  := functor_lifting D' (functor_composite (pr1_category D) F).
]]

However, it seems like it may probably be cleaner to define these independently.

TODO: reassess this design decision after some experience using it! *)

Section Disp_Functor.

  Definition disp_functor_data {C' C : precategory_data} (F : functor_data C' C)
             (D' : disp_cat_data C') (D : disp_cat_data C)
    := ∑ (Fob : ∏ x, D' x -> D (F x)),
      ∏ x y (xx : D' x) (yy : D' y) (f : x --> y),
      (xx -->[f] yy) -> (Fob _ xx -->[ # F f ] Fob _ yy).

  Definition disp_functor_on_objects {C' C : precategory_data} {F : functor_data C' C}
             {D' : disp_cat_data C'} {D : disp_cat_data C}
             (FF : disp_functor_data F D' D) {x : C'} (xx : D' x)
    : D (F x)
    := pr1 FF x xx.

  Coercion disp_functor_on_objects : disp_functor_data >-> Funclass.

  (** Unfortunately, the coercion loses implicitness of the {x:C'} argument:
  we have to write [ FF _ xx ] instead of just [ FF xx ].

  If anyone knows a way to avoid this, we would be happy to hear it! *)

  Definition disp_functor_on_morphisms {C' C : precategory_data} {F : functor_data C' C}
             {D' : disp_cat_data C'} {D : disp_cat_data C}
             (FF : disp_functor_data F D' D)
             {x y : C'} {xx : D' x} {yy} {f : x --> y} (ff : xx -->[f] yy)
    : (FF _ xx) -->[ # F f ] (FF _ yy)
    := pr2 FF x y xx yy f ff.

  Local Open Scope mor_disp_scope.
  (* To input ♯ using agda-mode type \# or \sharp *)
  Notation "♯ F" := (disp_functor_on_morphisms F)
                      (at level 3) : mor_disp_scope.

  Definition disp_functor_axioms {C' C : category} {F : functor C' C}
             {D' : disp_cat C'} {D : disp_cat C} (FF : disp_functor_data F D' D)
    :=  (∏ x (xx : D' x),
          ♯ FF (id_disp xx) = transportb _ (functor_id F x) (id_disp (FF _ xx)))
          × (∏ x y z (xx : D' x) yy zz (f : x --> y) (g : y --> z)
               (ff : xx -->[f] yy) (gg : yy -->[g] zz),
              ♯ FF (ff ;; gg)
              = transportb _ (functor_comp F f g) (♯ FF ff ;; ♯ FF gg)).

  Lemma isaprop_disp_functor_axioms {C' C : category} {F : functor C' C}
        {D' : disp_cat C'} {D : disp_cat C} (FF : disp_functor_data F D' D)
    : isaprop (disp_functor_axioms FF).
  Proof.
    apply isapropdirprod;
      repeat (apply impred; intros);
      apply homsets_disp.
  Qed.

  Definition disp_functor {C' C : category} (F : functor C' C)
             (D' : disp_cat C') (D : disp_cat C)
    := ∑ FF : disp_functor_data F D' D, disp_functor_axioms FF.

  Definition disp_functor_data_from_disp_functor
             {C' C} {F} {D' : disp_cat C'} {D : disp_cat C}
             (FF : disp_functor F D' D)
    : disp_functor_data F D' D
    := pr1 FF.

  Coercion disp_functor_data_from_disp_functor
    : disp_functor >-> disp_functor_data.

  Definition disp_functor_id {C' C} {F} {D' : disp_cat C'} {D : disp_cat C}
             (FF : disp_functor F D' D)
             {x} (xx : D' x)
    : ♯ FF (id_disp xx) = transportb _ (functor_id F x) (id_disp (FF _ xx))
    := pr1 (pr2 FF) x xx.

  Definition disp_functor_comp {C' C} {F} {D' : disp_cat C'} {D : disp_cat C}
             (FF : disp_functor F D' D)
             {x y z} {xx : D' x} {yy} {zz} {f : x --> y} {g : y --> z}
             (ff : xx -->[f] yy) (gg : yy -->[g] zz)
    : ♯ FF (ff ;; gg)
      = transportb _ (functor_comp F f g) (♯ FF ff ;; ♯ FF gg)
    := pr2 (pr2 FF) _ _ _ _ _ _ _ _ ff gg.

  (** variant access function *)
  Definition disp_functor_comp_var {C' C} {F} {D' : disp_cat C'} {D : disp_cat C}
             (FF : disp_functor F D' D)
             {x y z} {xx : D' x} {yy} {zz} {f : x --> y} {g : y --> z}
             (ff : xx -->[f] yy) (gg : yy -->[g] zz)
    : transportf _ (functor_comp F f g) (♯ FF (ff ;; gg))
      = ♯ FF ff ;; ♯ FF gg.
  Proof.
    apply transportf_pathsinv0.
    apply pathsinv0, disp_functor_comp.
  Defined.

  (** Useful transport lemma for [disp_functor]. *)
  Lemma disp_functor_transportf {C' C : category}
        {D' : disp_cat C'} {D : disp_cat C}
        (F : functor C' C) (FF : disp_functor F D' D)
        (x' x : C') (f' f : x' --> x) (p : f' = f)
        (xx' : D' x') (xx : D' x)
        (ff : xx' -->[ f' ] xx)
    :
    ♯ FF (transportf _ p ff)
    =
      transportf _ (maponpaths (# F) p) (♯FF ff).
  Proof.
    induction p.
    apply idpath.
  Defined.

  (** ** Composite and identity functors. *)

  Definition disp_functor_composite_data
             {C C' C'' : category} {D} {D'} {D''}
             {F : functor C C'} {F' : functor C' C''}
             (FF : disp_functor F D D')
             (FF' : disp_functor F' D' D'')
    : disp_functor_data (functor_composite F F') D D''.
  Proof.
    use tpair.
    + intros x xx. exact (FF' _ (FF _ xx)).
    + intros x y xx yy f ff. exact (♯ FF' (♯ FF ff)).
  Defined.

  Lemma disp_functor_composite_axioms
        {C C' C'' : category} {D} {D'} {D''}
        {F : functor C C'} {F' : functor C' C''}
        (FF : disp_functor F D D')
        (FF' : disp_functor F' D' D'')
    : disp_functor_axioms (disp_functor_composite_data FF FF').
  Proof.
    split; simpl.
    + intros x xx.
      etrans. apply maponpaths. apply disp_functor_id.
      etrans. apply disp_functor_transportf.
      etrans. apply maponpaths. apply disp_functor_id.
      etrans. apply transport_f_f.
      unfold transportb.
      apply maponpaths_2, homset_property.
    + intros.
      etrans. apply maponpaths. apply disp_functor_comp.
      etrans. apply disp_functor_transportf.
      etrans. apply maponpaths. apply disp_functor_comp.
      etrans. apply transport_f_f.
      unfold transportb.
      apply maponpaths_2, homset_property.
  Qed.

  Definition disp_functor_composite
             {C C' C'' : category} {D} {D'} {D''}
             {F : functor C C'} {F' : functor C' C''}
             (FF : disp_functor F D D')
             (FF' : disp_functor F' D' D'')
    : disp_functor (functor_composite F F') D D''.
  Proof.
    use tpair.
    - apply (disp_functor_composite_data FF FF').
    - apply disp_functor_composite_axioms.
  Defined.

  Definition disp_functor_identity
             {C : category} (D : disp_cat C)
    : disp_functor (functor_identity _ ) D D.
  Proof.
    use tpair.
    - use tpair.
      + intros; assumption.
      + cbn. intros. assumption.
    - split; simpl.
      + intros; apply idpath.
      + intros; apply idpath.
  Defined.

  (** ** Action of functors on z_isos. *)
  Section Functors_on_z_isos.

    (* TODO: functor_on_inv_from_z_iso should have implicit arguments *)

    Lemma disp_functor_on_z_iso_disp_aux1 {C C'} {F}
          {D : disp_cat C} {D' : disp_cat C'}
          (FF : disp_functor F D D')
          {x y} {xx : D x} {yy} {f : z_iso x y}
          (ff : xx -->[f] yy)
          (Hff : is_z_iso_disp f ff)
      : transportf _ (functor_on_inv_from_z_iso F f)
                   (♯ FF (inv_mor_disp_from_z_iso Hff))
        ;; ♯ FF ff
        = transportb _ (z_iso_after_z_iso_inv _) (id_disp _).
    Proof.
      etrans. apply mor_disp_transportf_postwhisker.
      etrans. apply maponpaths, @pathsinv0, disp_functor_comp_var.
      etrans. apply transport_f_f.
      etrans. apply maponpaths, maponpaths, z_iso_disp_after_inv_mor.
      etrans. apply maponpaths, disp_functor_transportf.
      etrans. apply transport_f_f.
      etrans. apply maponpaths, disp_functor_id.
      etrans. apply transport_f_b.
      unfold transportb. apply maponpaths_2, homset_property.
    Qed.

    Lemma disp_functor_on_z_iso_disp_aux2 {C C'} {F}
          {D : disp_cat C} {D' : disp_cat C'}
          (FF : disp_functor F D D')
          {x y} {xx : D x} {yy} {f : z_iso x y}
          (ff : xx -->[f] yy)
          (Hff : is_z_iso_disp f ff)
      : ♯ FF ff
        ;; transportf _ (functor_on_inv_from_z_iso F f)
                      (♯ FF (inv_mor_disp_from_z_iso Hff))
        =
          transportb _ (z_iso_inv_after_z_iso (functor_on_z_iso _ _)) (id_disp (FF x xx)).
    Proof.
      etrans. apply mor_disp_transportf_prewhisker.
      etrans. apply maponpaths, @pathsinv0, disp_functor_comp_var.
      etrans. apply transport_f_f.
      etrans. apply maponpaths, maponpaths, inv_mor_after_z_iso_disp.
      etrans. apply maponpaths, disp_functor_transportf.
      etrans. apply transport_f_f.
      etrans. apply maponpaths, disp_functor_id.
      etrans. apply transport_f_f.
      unfold transportb. apply maponpaths_2, homset_property.
    Qed.

    (** Let's see how [disp_functor]s behave on [z_iso_disp]s *)
    (** TODO: consider naming *)
    (* Undelimit Scope transport. *)
    Definition disp_functor_on_is_z_iso_disp {C C'} {F}
               {D : disp_cat C} {D' : disp_cat C'}
               (FF : disp_functor F D D')
               {x y} {xx : D x} {yy} {f : z_iso x y}
               {ff : xx -->[f] yy} (Hff : is_z_iso_disp f ff)
      : is_z_iso_disp (functor_on_z_iso F f) (♯ FF ff).
    Proof.
      exists (transportf _ (functor_on_inv_from_z_iso F f)
                    (♯ FF (inv_mor_disp_from_z_iso Hff))); split.
      - apply disp_functor_on_z_iso_disp_aux1.
      - apply disp_functor_on_z_iso_disp_aux2.
    Defined.

    Definition disp_functor_on_z_iso_disp {C C'} {F}
               {D : disp_cat C} {D' : disp_cat C'}
               (FF : disp_functor F D D')
               {x y} {xx : D x} {yy} {f : z_iso x y}
               (ff : z_iso_disp f xx yy)
      : z_iso_disp (functor_on_z_iso F f) (FF _ xx) (FF _ yy)
      := (_ ,, disp_functor_on_is_z_iso_disp _ ff).

  End Functors_on_z_isos.

  (** ** Properties of functors *)

  Section Functor_Properties.

    Definition disp_functor_ff {C C'} {F}
               {D : disp_cat C} {D' : disp_cat C'} (FF : disp_functor F D D')
      :=
      ∏ x y (xx : D x) (yy : D y) (f : x --> y),
        isweq (fun ff : xx -->[f] yy => ♯ FF ff).

    Section ff_reflects_isos.

      (* TODO: Try making FF implicit, since it can be inferred from [FF_ff]. *)
      Context {C C' : category}
              {F : functor C C'}
              {D : disp_cat C}
              {D' : disp_cat C'}
              (FF : disp_functor F D D')
              (FF_ff : disp_functor_ff FF).

      Definition disp_functor_ff_weq {x y} xx yy f
        := make_weq _ (FF_ff x y xx yy f).
      Definition disp_functor_ff_inv {x y} {xx} {yy} {f : x --> y}
        := invmap (disp_functor_ff_weq xx yy f).

      (* TODO: add a general version [disp_functor_ff_inv_transportf], where the transportf on the LHS is arbitrary. *)
      Lemma disp_functor_ff_inv_transportf
            {x y : C} {f f' : x --> y} (e : f = f')
            {xx : D x} {yy : D y} (ff : FF _ xx -->[#F f] FF _ yy)
        : disp_functor_ff_inv (transportf _ (maponpaths (# F) e) ff)
          =
            transportf _ e (disp_functor_ff_inv ff).
      Proof.
        induction e.
        apply idpath.
      Qed.

      (* TODO: move the transport to the RHS. *)
      Lemma disp_functor_ff_inv_identity {x : C} (xx : D x)
        : disp_functor_ff_inv (transportb _ (functor_id F _ ) (id_disp (FF _ xx)))
          = id_disp xx.
      Proof.
        apply invmap_eq.
        apply pathsinv0.
        apply (disp_functor_id FF).
      Qed.

      (* TODO: move the transport to the RHS. *)
      Lemma disp_functor_ff_inv_compose {x y z : C} {f : x --> y} {g : y --> z}
            {xx} {yy} {zz}
            (ff : FF _ xx -->[#F f] FF _ yy) (gg : FF _ yy -->[#F g] FF _ zz)
        : disp_functor_ff_inv (transportb _ (functor_comp F _ _ ) (ff ;; gg))
          = disp_functor_ff_inv ff ;; disp_functor_ff_inv gg.
      Proof.
        apply invmap_eq. cbn.
        apply pathsinv0.
        etrans. apply (disp_functor_comp FF).
        apply maponpaths.
        etrans. apply maponpaths. exact (homotweqinvweq _ _).
        apply maponpaths_2. exact (homotweqinvweq _ _).
      Qed.

      Definition disp_functor_ff_reflects_isos
                 {x y} {xx : D x} {yy : D y} {f : z_iso x y}
                 (ff : xx -->[f] yy) (isiso: is_z_iso_disp (functor_on_z_iso F f) (♯ FF ff))
        : is_z_iso_disp _ ff.
      Proof.
        set (FFffinv := inv_mor_disp_from_z_iso isiso).
        set (FFffinv' := transportb _ (functor_on_inv_from_z_iso _ _ ) FFffinv).
        set (ffinv := disp_functor_ff_inv FFffinv').
        exists ffinv.
        split.
        - unfold ffinv. unfold FFffinv'.
          admit.
        - admit.
      Abort.

    End ff_reflects_isos.

    (** Given a base functor [F : C —> C'] and a displayed functor [FF : D' -> D] over it, there are two different “essential surjectivity” conditions one can put on [FF].

Given [c : C] and [d : D' (F c)], one can ask for a lift of [d] either in [D c] itself, or more generally in some fiber [D c'] with [c'] isomorphic to [c].

The second version is better-behaved in general; but the stricter first version is equivalent when [D] is an isofibration, and is simpler to work with.  So we call the second version “essentially split surjective”, [disp_functor_ess_split_surj], and the first “displayed ess. split surj.”, [disp_functor_disp_ess_split_surj].
     *)

    Definition disp_functor_ess_split_surj {C' C} {F}
               {D' : disp_cat C'} {D : disp_cat C} (FF : disp_functor F D D')
      : UU
      :=
      ∏ x (xx : D' (F x)),
        ∑ y : C,
          ∑ i : z_iso y x,
            ∑ yy : D y,
              z_iso_disp (functor_on_z_iso F i) (FF _ yy) xx.

    Definition disp_functor_disp_ess_split_surj {C' C} {F}
               {D' : disp_cat C'} {D : disp_cat C} (FF : disp_functor F D D')
      : UU
      :=
      ∏ x (xx : D' (F x)),
        ∑ (yy : D x),
        z_iso_disp (identity_z_iso _) (FF _ yy) xx.

    (* TODO: add access functions for these. *)

  End Functor_Properties.
End Disp_Functor.

(* Redeclare notations globally: *)

Local Open Scope mor_disp_scope.
Notation "♯ F" := (disp_functor_on_morphisms F)
                    (at level 3) : mor_disp_scope.

#[deprecated(note="Use '♯' (input: \# or \sharp) instead.")]
Notation "# F" := ♯ F (only parsing) : mor_disp_scope.

(** Operations on displayed functors/transformations over the identity *)
Section CompDispFunctorOverIdentity.
  Context {C : category}
          {D₁ D₂ D₃ : disp_cat C}
          (FF : disp_functor (functor_identity C) D₁ D₂)
          (GG : disp_functor (functor_identity C) D₂ D₃).

  Definition disp_functor_over_id_composite_data
    : disp_functor_data (functor_identity C) D₁ D₃.
  Proof.
    simple refine (_ ,, _).
    - exact (λ x xx, GG x (FF x xx)).
    - exact (λ x y xx yy f ff, (♯GG (♯FF ff))).
  Defined.

  Definition disp_functor_over_id_composite_axioms
    : disp_functor_axioms disp_functor_over_id_composite_data.
  Proof.
    split.
    - intros x xx ; cbn.
      rewrite (disp_functor_id FF) ; cbn.
      rewrite (disp_functor_id GG) ; cbn.
      apply idpath.
    - intros x y z xx yy zz f g ff gg ; cbn.
      etrans.
      {
        apply maponpaths.
        exact (disp_functor_comp FF ff gg).
      }
      cbn.
      exact (disp_functor_comp GG (♯ FF ff) (♯ FF gg)).
  Qed.

  Definition disp_functor_over_id_composite
    : disp_functor (functor_identity C) D₁ D₃.
  Proof.
    simple refine (_ ,, _).
    - exact disp_functor_over_id_composite_data.
    - exact disp_functor_over_id_composite_axioms.
  Defined.
End CompDispFunctorOverIdentity.


(** * Miscellaneous lemmas. *)

Require Import Reals QArith.
From Bignums Require Import BigQ.
Require Import Flocq.Core.Raux.
Require Import Psatz.

From mathcomp Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq.
From mathcomp Require Import fintype finfun ssralg matrix bigop tuple.
From mathcomp Require Import ssrnum ssrint rat.

Require Import mathcomp.analysis.Rstruct.

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

Open Scope ring_scope.
Open Scope R_scope.

Delimit Scope ring_scope with Ri.
Delimit Scope R_scope with Re.
Delimit Scope Q_scope with Qrat.

Import GRing.Theory.
Import Num.Theory.

Lemma INR_natmul n : INR n = (n%:R)%R.
Proof.
elim: n => [//|n IHn].
by rewrite -addn1 plus_INR IHn mulrnDr.
Qed.

(** As in the latest version of CoqEAL, all relations are in [Type],
we need to add some material, such as [ifft], which is similar to [iff] *)
Inductive ifft (A B : Type) : Type := Ifft of (A -> B) & (B -> A).
Infix "<=>" := ifft (at level 95) : type_scope.

Section ApplyIfft.

Variables P Q : Type.
Hypothesis eqPQ : P <=> Q.

Lemma ifft1 : P -> Q. Proof. by case: eqPQ. Qed.
Lemma ifft2 : Q -> P. Proof. by case: eqPQ. Qed.

End ApplyIfft.

Hint View for move/ ifft1|2 ifft2|2.
Hint View for apply/ ifft1|2 ifft2|2.

Lemma ifftW (P Q : Prop) : P <=> Q -> (P <-> Q).
Proof. by case. Qed.

(** ** Lemmas mostly about real numbers. *)
Section Misc.

Lemma inord0E n : inord 0 = ord0 :> 'I_n.+1.
Proof. by apply: ord_inj; rewrite inordK. Qed.

(** About [Rabs]. *)
Lemma Rge_opp_abs x : - Rabs x <= x.
Proof. split_Rabs; lra. Qed.

(** About [Rmax]. *)
Lemma Rle_max_compat x y z t : x <= y -> z <= t -> Rmax x z <= Rmax y t.
Proof.
move=> Hxy Hzt.
apply Rle_trans with (Rmax y z).
{ apply Rle_max_compat_r => //; apply Rle_max_compat_l. }
apply Rle_max_compat_l => //; apply Rle_max_compat_r.
Qed.

(** About square and square root. *)
Lemma sqr_ge_0 x : (0 <= x * x)%Re.
Proof. by replace (x * x)%Re with (x ^ 2)%Re; [apply pow2_ge_0|ring]. Qed.

Lemma sqrtx_le_x x : (1 <= x -> sqrt x <= x)%Re.
Proof.
move=> Hx.
rewrite -{2}(sqrt_Rsqr x); [|lra].
apply sqrt_le_1_alt; rewrite /Rsqr -{1}(Rmult_1_r x).
apply Rmult_le_compat_l; lra.
Qed.

Lemma sqrtx_le_xp1 x : (0 <= x -> sqrt x <= x + 1)%Re.
Proof.
move=> Hx.
rewrite -(sqrt_Rsqr (x + 1)); [|lra].
have Lx := Rle_0_sqr x; have L1 := Rle_0_sqr 1.
apply sqrt_le_1_alt; rewrite Rsqr_plus; lra.
Qed.

(** About [pow]. *)
Lemma pow_rexp r n : r ^ n = (r ^+ n)%Ri.
Proof.
elim: n => [//|n' IH].
by rewrite /= IH /GRing.exp /=; case n'=> //; rewrite Rmult_1_r.
Qed.

(** If the sum of two non negative is zero, they are both zero. *)
Lemma sum_pos_eq_0_l x y : (0 <= x -> 0 <= y -> x + y = 0 -> x = 0)%Re.
Proof. move => *; lra. Qed.

Lemma sum_pos_eq_0_r x y : (0 <= x -> 0 <= y -> x + y = 0 -> y = 0)%Re.
Proof. move => *; lra. Qed.

(** *** Lemmas about bigops. *)
Section Big_misc.

Ltac simpl_re := rewrite /GRing.add /GRing.zero /=.

(** If something exists for each item, we can build an array. *)
Lemma ffun_exists n d P :
  (forall i : 'I_n, exists e : d, P i e) ->
  exists ea : d ^ n, forall i, P i (ea i).
Proof.
move => H.
elim: n P H => /= [|n IH] P H.
{ by exists (Finfun (tcast (sym_eq (card_ord 0)) [tuple])) => [] [] //. }
have [i|y Hy] := (IH (P \o (lift ord0))).
{ by have [y ?] := (H (lift ord0 i)); exists y. }
have [x Hx] := H ord0.
exists [ffun i => if unlift ord0 i is Some j then y j else x] => i.
rewrite ffunE; case: unliftP => [j ->|-> //]; apply Hy.
Qed.

(** If something exists for each item, we can build an array. *)
Lemma big_exists R (idx : R) op d (d0 : d) n F F' :
  (forall i : 'I_n, exists e : d, F i = F' i e) ->
  exists ea : d ^ n, \big[op/idx]_i F i = \big[op/idx]_i F' i (ea i).
Proof.
move=> H.
suff [ea Hea] : exists ea : d^n, forall i, F i = F' i (ea i).
{ by exists ea; apply eq_bigr => i _; apply Hea. }
by apply (@ffun_exists n d (fun i e => F i = F' i e)).
Qed.

Lemma big_Rabs_pos_eq idx op n F : (forall i : 'I_n, 0 <= F i) ->
  \big[op/idx]_i Rabs (F i) = \big[op/idx]_i F i.
Proof. by move=> H; apply eq_bigr => i; rewrite Rabs_pos_eq //. Qed.

Lemma big_Rabs_ffunE idx op n F :
  \big[op/idx]_(i < n) Rabs ([ffun i => F i] i) = \big[op/idx]_i Rabs (F i).
Proof. by apply eq_bigr => i; rewrite ffunE. Qed.

Lemma big_sum_Ropp I (r : seq I) F :
  (- (\sum_(i <- r) F i) = \sum_(i <- r) (- F i)%Re)%Re.
Proof.
apply (big_rec2 (fun x y => (- x = y)%Re)); [by rewrite Ropp_0|].
by move=> i y1 y2 _ H; rewrite -H /GRing.add /= Ropp_plus_distr.
Qed.

Lemma big_sum_const_seq I (r : seq I) x : (\sum_(i <- r) x = INR (size r) * x)%Re.
Proof.
elim: r=> [|e r IHr].
{ by rewrite big_nil /= Rmult_0_l. }
by rewrite big_cons S_INR Rplus_comm Rmult_plus_distr_r Rmult_1_l IHr.
Qed.

Lemma big_sum_const n x : (\sum_(i < n) x = INR n * x)%Re.
Proof.
by rewrite big_sum_const_seq /= /index_enum /= -enumT size_enum_ord.
Qed.

Lemma big_sum_pred_const I (r : seq I) (P : pred I) (x : R) :
  \big[+%R/0]_(i <- r | P i) x = INR (size [seq i <- r | P i]) * x.
Proof.
rewrite -big_filter; set l := [seq x <- r | P x]; elim l => [|h t IH].
{ by rewrite big_nil /= Rmult_0_l. }
simpl size; rewrite big_cons S_INR IH /GRing.add /GRing.mul /=; ring.
Qed.

Lemma big_sum_pred_pos_pos I (P : pred I) (F : I -> R) r :
  ((forall i, P i -> 0 <= F i) -> 0 <= \sum_(i <- r | P i) F i)%Re.
Proof.
move=> HF. (* Check big_seq_cond. *)
apply: big_rec; [by right|] => i x HP Hx.
by apply: Rplus_le_le_0_compat; [apply HF|].
Qed.

Lemma big_sum_pos_pos I (F : I -> R) r :
  ((forall i, 0 <= F i) -> 0 <= \sum_(i <- r) F i)%Re.
Proof. move=> HF; apply big_sum_pred_pos_pos => *; exact: HF. Qed.

Lemma big_sum_Rabs_pos I (F : I -> R) r :
  (0 <= \sum_(i <- r) (Rabs (F i)))%Re.
Proof. by apply: big_sum_pos_pos => i; apply: Rabs_pos. Qed.

Lemma big_sum_sqr_pos I (F : I -> R) r :
  (0 <= \sum_(i <- r) (F i * F i))%Re.
Proof. by apply: big_sum_pos_pos => i; apply: sqr_ge_0. Qed.

(** If a sum of nonnegative values is zero, then all terms are zero. *)
Lemma big_sum_pos_eq_0 (I : finType) (F : I -> R) :
  ((forall i, 0 <= F i) -> \sum_i F i = 0 -> forall i, F i = 0)%Re.
Proof.
move=> Hpos H0 i.
have [R|//] := Rle_lt_or_eq_dec _ _ (Hpos i).
suff HH: (0 < \big[+%R/0]_j F j)%Re by move: H0 HH; simpl_re; lra.
rewrite (bigD1 i) //=.
set X := bigop _ _ _.
suff: (0 <= X)%Re by simpl_re; lra.
exact: big_sum_pred_pos_pos.
Qed.

Lemma big_Rabs_triang I (F : I -> R) r :
  (Rabs (\sum_(i <- r) (F i)) <= \sum_(i <- r) (Rabs (F i)))%Re.
Proof. elim/big_rec2: _ =>[|i y x _]; split_Rabs; simpl_re; lra. Qed.

Lemma Rle_big_compat I (F F' : I -> R) r :
  (forall i, F i <= F' i) -> \sum_(i <- r) F i <= \sum_(i <- r) F' i.
Proof.
move=> H; apply: big_rec2 =>[|i s1 s2 _ Hs12]; [by right|].
by rewrite /GRing.add /=; apply: Rplus_le_compat.
Qed.

End Big_misc.

(** *** A maximum on tuples. *)
Section Max_tuple.

(** Since R has no least element, the tuple has to be non-empty,
    hence the +1. *)
Fixpoint max_tuple n (a : R ^ n.+1) :=
  match n with
    | 0%N => a ord0
    | n'.+1 => Rmax (max_tuple [ffun i : 'I_n'.+1 => a (inord i)]) (a ord_max)
  end.

Lemma max_tuple_eq n (a1 : R ^ n.+1) (a2 : R ^ n.+1) :
  a1 =1 a2 -> max_tuple a1 = max_tuple a2.
Proof.
elim: n a1 a2 => [|n IHn] a1 a2 H12 //=.
apply f_equal2 => //; apply IHn => i; rewrite !ffunE //.
Qed.

Lemma max_tuple_monotone n (a1 : R ^ n.+1) (a2 : R ^ n.+1) :
  (forall i, a1 i <= a2 i) -> max_tuple a1 <= max_tuple a2.
Proof.
elim: n a1 a2 => [|n IHn] a1 a2 H12 //=; apply Rle_max_compat => //.
by apply IHn => i; rewrite !ffunE.
Qed.

Lemma max_tuple_i n (a : R ^ n.+1) (i : 'I_n.+1) : a i <= max_tuple a.
Proof.
elim: n a i => [|n IHn] a i /=; [by rewrite (ord1 i); right|].
case (unliftP ord_max i) => [j ->|->]; [|by apply Rmax_r].
replace (a _) with ([ffun i : 'I_n.+1 => a (inord i)] j).
{ apply (Rle_trans _ _ _ (IHn _ _)), Rmax_l. }
rewrite ffunE; apply f_equal, ord_inj; rewrite lift_max inordK //.
apply ltnW, leq_ord.
Qed.

Lemma max_tuple_lub_lt n (a : R ^ n.+1) (x : R) :
  (forall i, a i < x) -> max_tuple a < x.
Proof.
elim: n a x => [|n IHn] a x Hx //=.
apply Rmax_lub_lt; [|by apply Hx].
apply IHn => i; rewrite ffunE; apply Hx.
Qed.

Lemma max_tuple_Rmult n (a : R ^ n.+1) (c : R) : 0 <= c ->
  (max_tuple [ffun i => c * a i] = c * max_tuple a)%Re.
Proof.
elim: n a c => [|n IHn] a c Hc /=; [by rewrite ffunE|].
rewrite -RmaxRmult; [|by []]; apply f_equal2; [|by rewrite ffunE].
by rewrite -IHn; [|by []]; apply max_tuple_eq => i; rewrite !ffunE.
Qed.

Lemma max_tuple_prod n (a b : R ^ n.+1) :
  (forall i, 0 <= a i) -> (forall i, 0 <= b i) ->
  max_tuple [ffun i => a i * b i] <= max_tuple a * max_tuple b.
Proof.
move=> Ha Hb.
apply Rle_trans with (max_tuple [ffun i => max_tuple a * b i]).
{ apply max_tuple_monotone => i; rewrite !ffunE.
  apply Rmult_le_compat_r; [apply Hb|apply max_tuple_i]. }
right; apply max_tuple_Rmult; apply (Rle_trans _ _ _ (Ha ord0)), max_tuple_i.
Qed.

Lemma max_tuple_sum n (a : R ^ n.+1) : \sum_i a i <= INR n.+1 * max_tuple a.
Proof.
elim: n a => [|n IHn] a.
{ by rewrite zmodp.big_ord1 Rmult_1_l; right. }
rewrite big_ord_recr S_INR Rmult_plus_distr_r Rmult_1_l; apply Rplus_le_compat.
{ apply Rle_trans with (INR n.+1 * max_tuple [ffun i : 'I_n.+1 => a (inord i)]).
  { replace (_ : R) with (\sum_i [ffun i : 'I_n.+1 => a (inord i)] i);
      [by apply IHn|].
    apply eq_bigr => i _; rewrite ffunE.
    apply f_equal, ord_inj; rewrite inordK //; apply ltnW, leq_ord. }
  apply Rmult_le_compat_l; [apply pos_INR|apply Rmax_l]. }
apply Rmax_r.
Qed.

End Max_tuple.

End Misc.


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

(*i        $Id: DiscrR.v 14641 2011-11-06 11:59:10Z herbelin $       i*)

Require Import RIneq.
Require Import Omega.
Open Local Scope R_scope.

Lemma Rlt_R0_R2 : 0 < 2.
change 2 with (INR 2); apply lt_INR_0; apply lt_O_Sn.
Qed.

Notation Rplus_lt_pos := Rplus_lt_0_compat (only parsing).

Lemma IZR_eq : forall z1 z2:Z, z1 = z2 -> IZR z1 = IZR z2.
intros; rewrite H; reflexivity.
Qed.

Lemma IZR_neq : forall z1 z2:Z, z1 <> z2 -> IZR z1 <> IZR z2.
intros; red in |- *; intro; elim H; apply eq_IZR; assumption.
Qed.

Ltac discrR :=
  try
   match goal with
   |  |- (?X1 <> ?X2) =>
       change 2 with (IZR 2);
       change 1 with (IZR 1);
       change 0 with (IZR 0);
       repeat
         rewrite <- plus_IZR ||
           rewrite <- mult_IZR ||
           rewrite <- Ropp_Ropp_IZR || rewrite Z_R_minus;
       apply IZR_neq; try discriminate
   end.

Ltac prove_sup0 :=
  match goal with
  |  |- (0 < 1) => apply Rlt_0_1
  |  |- (0 < ?X1) =>
      repeat
       (apply Rmult_lt_0_compat || apply Rplus_lt_pos;
         try apply Rlt_0_1 || apply Rlt_R0_R2)
  |  |- (?X1 > 0) => change (0 < X1) in |- *; prove_sup0
  end.

Ltac omega_sup :=
  change 2 with (IZR 2);
  change 1 with (IZR 1);
  change 0 with (IZR 0);
  repeat
    rewrite <- plus_IZR ||
      rewrite <- mult_IZR || rewrite <- Ropp_Ropp_IZR || rewrite Z_R_minus;
  apply IZR_lt; omega.

Ltac prove_sup :=
  match goal with
  |  |- (?X1 > ?X2) => change (X2 < X1) in |- *; prove_sup
  |  |- (0 < ?X1) => prove_sup0
  |  |- (- ?X1 < 0) => rewrite <- Ropp_0; prove_sup
  |  |- (- ?X1 < - ?X2) => apply Ropp_lt_gt_contravar; prove_sup
  |  |- (- ?X1 < ?X2) => apply Rlt_trans with 0; prove_sup
  |  |- (?X1 < ?X2) => omega_sup
  | _ => idtac
  end.

Ltac Rcompute :=
  change 2 with (IZR 2);
  change 1 with (IZR 1);
  change 0 with (IZR 0);
  repeat
    rewrite <- plus_IZR ||
      rewrite <- mult_IZR || rewrite <- Ropp_Ropp_IZR || rewrite Z_R_minus;
  apply IZR_eq; try reflexivity.


From discprob.basic Require Import base order.
From discprob.prob Require Import prob countable finite stochastic_order.
From discprob.monad.finite Require Import monad.
From mathcomp Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq div choice fintype.
From mathcomp Require Import tuple finfun bigop prime binomial finset.
Require Import Reals Fourier Psatz Omega.

Definition output {A} (p: ldist A) := [seq i.2 | i <- outcomes p].

Definition mspec {A: eqType} (m: ldist A) (P: A → Prop) :=
  ∀ y, y \in output m → P y.

Lemma mspec_mret {A: eqType} (x: A) (P: A → Prop):
  P x → mspec (mret x) P.
Proof.
  intros HP y. rewrite /mret/dist_ret/output//= mem_seq1.
  move /eqP => -> //.
Qed.

Lemma mspec_conseq {A: eqType} (m: ldist A) (P Q: A → Prop):
  mspec m P → (∀ a, P a → Q a) → mspec m Q.
Proof.
  intros HP HPQ a Hin. apply HPQ; eauto.
Qed.

Lemma output_mbind_in {A B: eqType} b (m: ldist A) (f: A → ldist B):
  (b \in output (x ← m; f x)) →
  ∃ r a, ((r, a)) \in outcomes m ∧ (b \in output (f a)).
Proof.
  rewrite /mbind/output.
  move /mapP => [[r b' Hin]] => //= ->.
  eapply (in_ldist_bind _ r b' m) in Hin as (r'&r''&c'&Hin1&Hin2&Heq).
  exists r'', c'; split; auto. apply /mapP; eauto.
Qed.

Lemma mspec_mbind {A B: eqType} (f: A → ldist B) m (P: A → Prop) (Q: B → Prop):
  mspec m P →
  (∀ a, P a → mspec (f a) Q) →
  mspec (mbind f m) Q.
Proof.
  intros Hinput Hbody b Hin.
  edestruct (output_mbind_in b m f) as (r&?&Hin'&Hout); eauto.
  eapply Hbody; eauto. apply Hinput; eauto.
  apply /mapP; eauto.
Qed.

Tactic Notation "tbind" open_constr(P) :=
  match goal with
  | [ |- mspec (mbind ?f ?m) ?Q ] =>
    intros; eapply (@mspec_mbind _ _ f m P); auto
  end.

Lemma fun_to_mspec {A: eqType} (m: ldist A) (P: A → Prop):
  mspec m P → (∀ x, P ((rvar_of_ldist m) x)).
Proof.
  rewrite /mspec/output => Hspec /= x.
  apply /Hspec/mem_nth. rewrite size_map. inversion x. done.
Qed.

Lemma mspec_range_eq_dist {A: eqType} (m1 m2: ldist A) (P: pred A):
  mspec m1 P →
  mspec m2 P →
  (∀ a, P a → pr_eq (rvar_of_ldist m1) a = pr_eq (rvar_of_ldist m2) a) →
  eq_dist (rvar_of_ldist m1) (rvar_of_ldist m2).
Proof.
  intros Hm1 Hm2 Hin_eq a.
  specialize (Hm1 a). rewrite //= in Hm1.
  specialize (Hm2 a). rewrite //= in Hm2.
  specialize (Hin_eq a).
  case_eq (P a).
  - intros HP. apply Hin_eq. auto.
  - intros HnP. transitivity 0; last symmetry.
    * apply pr_img_nin. intros Hin. move /negP in HnP. apply HnP.
      apply Hm1. by rewrite /output -mem_undup -img_rvar_of_ldist'.
    * apply pr_img_nin. intros Hin. move /negP in HnP. apply HnP.
      apply Hm2. by rewrite /output -mem_undup -img_rvar_of_ldist'.
Qed.

Lemma mspec_eq_dist_ldist_bind_ext {A B: eqType} m P (f g: A → ldist B):
  mspec m P →
  (∀ a, P a → eq_dist (rvar_of_ldist (f a)) (rvar_of_ldist (g a))) →
  eq_dist (rvar_of_ldist (mbind f m)) (rvar_of_ldist (mbind g m)).
Proof.
  intros Hspec.
  rewrite /eq_dist => Heq b. rewrite ?pr_mbind_ldist1.
  eapply eq_bigr => a _. rewrite Heq; first done.
  apply Hspec. rewrite /output.
  rewrite -mem_undup -img_rvar_of_ldist'.
  destruct a as (x&Hin) => //=.
Qed.

Lemma Ex_bound {A : eqType} (X: ldist A) f r:
  mspec X (λ x, f x <= r) →
  Ex (rvar_comp (rvar_of_ldist X) f) <= r.
Proof.
  intros Hmspec. rewrite Ex_fin_comp.
  eapply Rle_trans.
  {
    eapply Rle_bigr => i _.
    apply Rmult_le_compat_l; last apply Hmspec.
    - apply Rge_le, ge_pr_0.
    - destruct i as (?&?) => //=. rewrite /output -mem_undup -img_rvar_of_ldist' //.
  }
  rewrite -big_distrl //= (pr_sum_all (rvar_of_ldist X)) Rmult_1_l. fourier.
Qed.


From mathcomp.ssreflect Require Import all_ssreflect seq.
From mathcomp Require Import finmap.

From Paco Require Import paco paco2.

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

Require Import MPST.Common.

Section Syntax.
Unset Elimination Schemes.
(**
 * Global Types
 *)
Inductive g_ty :=
| g_end
| g_var (VAR : nat)
| g_rec (GT : g_ty)
| g_msg (FROM TO : role) (CONT : seq (lbl * (mty * g_ty))).
Hint Constructors g_ty : mpst.
Set Elimination Schemes.

Lemma g_ty_ind :
  forall (P : g_ty -> Prop),
    P g_end ->
    (forall v, P (g_var v)) ->
    (forall G, P G -> P (g_rec G)) ->
    (forall p q Ks, (forall K, member K Ks -> P K.2.2) ->
                      P (g_msg p q Ks)) ->
    forall g : g_ty, P g.
Proof.
  move=> P P_end P_var P_rec P_msg; fix Ih 1; case.
  + by apply: P_end.
  + by apply: P_var.
  + by move=>G; apply: P_rec.
  + move=>p q Ks; apply: P_msg.
    by apply/forall_member; elim: Ks.
Qed.

Fixpoint depth (a : g_ty) :=
  match a with
  | g_end
  | g_var _ => 0
  | g_rec G => (depth G).+1
  | g_msg _ _ K => (foldr maxn 0 (map (fun x=> depth x.2.2) K)).+1
  end.

Fixpoint participants (G : g_ty) :=
  match G with
  | g_end
  | g_var _ => [::]
  | g_rec G => participants G
  | g_msg p q Ks => p::q::flatten [seq participants K.2.2 | K <- Ks]
  end.

Fixpoint eq_g_ty (a b : g_ty) :=
  match a, b with
  | g_end, g_end => true
  | g_var v1, g_var v2 => v1 == v2
  | g_rec G1, g_rec G2 => eq_g_ty G1 G2
  | g_msg p1 q1 Ks1, g_msg p2 q2 Ks2 =>
      (p1 == p2)
      && (q1 == q2)
      && (fix eqL Ks1 Ks2 :=
            match Ks1, Ks2 with
            | [::], [::] => true
            | K1::Ks1, K2::Ks2 => (K1.1 == K2.1)
                                    && (K1.2.1 == K2.2.1)
                                    && eq_g_ty K1.2.2 K2.2.2
                                    && eqL Ks1 Ks2
            | _, _ => false
            end) Ks1 Ks2
  | _, _ => false
  end.

Definition eq_alt (l r : lbl * (mty * g_ty)) :=
  (l.1 == r.1) && (l.2.1 == r.2.1) && eq_g_ty l.2.2 r.2.2.

Lemma eqgty_all p1 q1 (Ks1 : seq (lbl * (mty * g_ty))) p2 q2 Ks2 :
  eq_g_ty (g_msg p1 q1 Ks1) (g_msg p2 q2 Ks2) =
  (p1 == p2) && (q1 == q2) && all2 eq_alt Ks1 Ks2.
Proof.
  rewrite /=; do 2 (case: eqP=>///= _).
Qed.
Hint Rewrite eqgty_all : mpst.

Lemma g_ty_eqP : Equality.axiom eq_g_ty.
Proof.
  rewrite /Equality.axiom; fix Ih 1 => x y.
  case x =>[|vl| Gl |pl ql Ksl]; case y =>[|vr| Gr |pr qr Ksr];
    try (by constructor).
  + by rewrite /eq_g_ty; case: eqP=>[->|H];constructor=>//[[]].
  + by rewrite /=; case: Ih=>[->|H];constructor=>//[[]].
  + rewrite eqgty_all; do 2 (case: eqP=>[<-|H];[|constructor=>[[]]//] =>/=).
    elim: Ksl Ksr =>[|[ll [tl Gl]] Ksl IhKs].
    - case; try (by constructor).
    - move=>[|[lr [tr Gr] Ksr]/=]; first (by constructor).
      rewrite /eq_alt/=; do 2 (case: eqP=>[->|F];[|constructor=>[[/F]]//]).
      case: Ih=>[->|F]/=;[|constructor=>[[/F]]//].
      by case: IhKs=>[[]<-|F]; constructor=>//[[F']]; move: F' F=>->.
Qed.

Definition g_ty_eqMixin := EqMixin g_ty_eqP.
Canonical g_ty_eqType := Eval hnf in EqType g_ty g_ty_eqMixin.

Lemma alt_eqP : Equality.axiom eq_alt.
Proof.
  rewrite /Equality.axiom/eq_alt; move=>[l1  [t1 Ks1]] [l2 [t2 Ks2]]/=.
  do 2 (case: eqP=>[<-|H]; last (by apply: ReflectF => [[/H]])).
  case: g_ty_eqP=>[<-|H]; first by apply: ReflectT.
  by apply: ReflectF =>[[/H]].
Qed.

Lemma rec_gty G :
  (exists G', G = g_rec G') \/ (forall G', G != g_rec G').
Proof. by case:G; try (by right); move=> GT; left; exists GT. Qed.

Lemma matchGrec A G (f : g_ty -> A) g :
  (forall G', G != g_rec G') ->
  match G with
  | g_rec G' => f G'
  | _ => g
  end = g.
Proof. by case: G=>// GT /(_ GT)/eqP. Qed.

(**
 * Does not apply any "shift" to G2, and therefore G2 must always be closed
 *)
Fixpoint g_open (d : nat) (G2 : g_ty) (G1 : g_ty) :=
  match G1 with
  | g_end => G1
  | g_var v => if v == d then G2 else G1
  | g_rec G => g_rec (g_open d.+1 G2 G)
  | g_msg p q Ks =>
    g_msg p q [seq (K.1, (K.2.1, g_open d G2 K.2.2)) | K <- Ks]
  end.
Notation "{ k '~>' v } G":= (g_open k v G) (at level 30, right associativity).
Notation "G '^' v":= (g_open 0 (g_var v) G) (at level 30, right associativity).

Definition unroll G := g_open 0 (g_rec G) G.

Lemma g_open_msg_rw d G2 FROM TO CONT:
  g_open d G2 (g_msg FROM TO CONT)
  = g_msg FROM TO [seq (K.1, (K.2.1, g_open d G2 K.2.2)) | K <- CONT].
Proof. by []. Qed.

Lemma notin_part_g_open_strong d r G G': r \notin participants G ->
  r \notin participants G'-> r \notin participants (g_open d G' G).
Proof.
move=> h1 rnG'; move: h1; apply: contra; elim: G d.
+ rewrite //=.
+ rewrite //= => v d.
  by case: ifP=>[_ F|//]; rewrite F in rnG'.
+ rewrite //=. by move=> G ih d; apply ih.
+ move=>p q Ks ih d. rewrite /= !in_cons -map_comp/comp/=.
  move=>/orP-[->//|/orP-[->|]]; first by rewrite orbC.
  move=> H.
  do ! (apply/orP; right).
  move: H=>/flatten_mapP-[K inKs inK].
  apply/flatten_mapP.
  exists K=>//.
  by apply: (ih _ _ d); first by apply/memberP.
Qed.

Lemma same_notin_part_g_open d r G G': participants G' = participants G ->
  r \notin participants G -> r \notin participants (g_open d G' G).
Proof.
  move=>h1 h2; apply: notin_part_g_open_strong; by [apply h2 | rewrite h1].
Qed.

Lemma notin_part_g_open r G:
  r \notin participants G -> r \notin participants (g_open 0 (g_rec G) G).
Proof.
  by apply same_notin_part_g_open; rewrite //=.
Qed.

Fixpoint g_fidx (d : nat) (G : g_ty) : seq nat :=
  match G with
  | g_var v => if v >= d then [:: v - d] else [::]
  | g_rec G => g_fidx d.+1 G
  | g_msg p q Ks => flatten [seq g_fidx d K.2.2 | K <- Ks]
  | g_end => [::]
  end.
Definition g_closed (G : g_ty) := g_fidx 0 G == [::].

Lemma gfbvar_next n G :
  g_fidx n G == fset0 ->
  g_fidx n.+1 G = fset0.
Proof.
  elim: G n=>[//|v|G Ih|p q Ks Ih] n/=.
  - case: v=>//= m H; case: ifP=>// n_m; move: H.
    by move: (leq_trans (leqnSn n) n_m)=>->.
  - by apply: Ih.
  - rewrite flatten_eq_nil member_map=>H; apply/eqP.
    by rewrite flatten_eq_nil member_map=> K M; move: (Ih K M n (H K M))=>->.
Qed.

Fixpoint guarded d G :=
  match G with
  | g_end => true
  | g_var v => v >= d
  | g_rec G => guarded d.+1 G
  | g_msg _ _ Ks => all (fun K => guarded 0 K.2.2) Ks
  end.

Fixpoint g_binds n G :=
  match G with
  | g_var v => v == n
  | g_rec G => g_binds n.+1 G
  | _ => false
  end.

Fixpoint guarded' G :=
  match G with
  | g_end
  | g_var _ => true
  | g_rec G => ~~ g_binds 0 G && guarded' G
  | g_msg _ _ Ks => all (fun K => guarded' K.2.2) Ks
  end.

Lemma guarded_next n G : guarded n.+1 G = ~~ g_binds n G && guarded n G.
Proof. by elim: G n=>//= v n; rewrite ltn_neqAle eq_sym. Qed.

Lemma guarded_binds G : guarded 0 G = guarded' G.
Proof.
  elim: G=>[||G|_ _ Ks Ih]//=; first by move=><-;apply/guarded_next.
  elim: Ks Ih=>[//|K Ks Ih']/= Ih; rewrite Ih; last by left.
  by rewrite Ih' // => K' /or_intror/Ih.
Qed.

Lemma alt_eq p1 q1 Ks1 p2 q2 Ks2 :
  ((g_msg p1 q1 Ks1) == (g_msg p2 q2 Ks2)) =
  (p1 == p2) && (q1 == q2) && (Ks1 == Ks2).
Proof.
  rewrite eqE/=; do 2 case: eqP=>//=; move=> _ _ {p1 q1 p2 q2}.
  elim: Ks1=>[|K1 Ks1 Ih] in Ks2 *; case: Ks2=>[|K2 Ks2]//=.
  by rewrite Ih; do ! rewrite !eqE/=; rewrite -!eqE !andbA.
Qed.

Lemma gty_not_var A G (f : nat -> A) (k : A) :
  (forall v : nat, G != g_var v) ->
  match G with | g_var v => f v | _ => k end = k.
Proof. by case: G =>// v /(_ v)/eqP. Qed.

Fixpoint rec_depth G :=
  match G with
  | g_rec G => (rec_depth G).+1
  | _ => 0
  end.

Lemma rd_zero G :
  (forall G' : g_ty, G != g_rec G') ->
  rec_depth G = 0.
Proof. by case: G=>// GT /(_ GT)/eqP. Qed.

Fixpoint n_unroll d G :=
  match d with
  | 0 => G
  | d.+1 =>
    match G with
    | g_rec G' => n_unroll d (unroll G')
    | _ => G
    end
  end.

Lemma r_in_unroll r G n:
  r \in participants (n_unroll n G) -> r \in participants G.
Proof.
  apply: contraLR.
  elim: n => [rewrite //= | n ih] in G *; case G; rewrite //=.
  move=> G0 notinpart; apply ih.
  unfold unroll; apply notin_part_g_open; by [].
Qed.

Lemma r_in_unroll_rec_depth r G:
  r \in participants (n_unroll (rec_depth G) G) -> r \in participants G.
Proof. by apply r_in_unroll. Qed.

Lemma notin_nunroll r n G :
  r \notin participants G ->
  r \notin participants (n_unroll n G).
Proof.
  elim: n G=>//= n Ih G H.
  by case: G H=>//= GT; rewrite /unroll=>/notin_part_g_open/Ih.
Qed.

Lemma guarded_match d G :
  match G with
  | g_var v => d < v
  | _ => guarded d.+1 G
  end ->
  (exists v, (G == g_var v) && (d < v)) \/
  (forall v, (G != g_var v)) /\ guarded d.+1 G.
Proof.
  case: G=>[|[]||]//=; try by right.
  by move=> n d_n; left; exists n.+1; rewrite eq_refl.
Qed.

Lemma guarded_recdepth d G m :
  guarded d G ->
  m < d ->
  forall G', rec_depth G = rec_depth ({m ~> G'} G).
Proof.
  elim: G=>[|n|G Ih|p q Ks Ih]//= in d m *.
  - move=>dn md G; case: ifP=>[/eqP-E|ne//].
    by move: E dn md=>-> /leq_ltn_trans-H /H; rewrite ltnn.
  - by move=> GG md G'; rewrite (Ih _ m.+1 GG _ G').
Qed.

Lemma guarded_depth_gt n dG dG' G :
  n <= dG' ->
  guarded dG' G -> g_fidx n G == [::] -> guarded dG G.
Proof.
  elim: G =>[|m|G Ih|p q Ks Ih]// in n dG dG' *.
  - by move=> /leq_trans-H /= /H->.
  - by move=>/= LE; apply/Ih.
Qed.

Lemma gopen_closed G :
   g_closed (g_rec G) ->
   g_closed (g_open 0 (g_rec G) G).
 Proof.
   rewrite/g_closed/==>G_fbv; have: g_fidx 0 (g_rec G) == fset0 by [].
   move: (g_rec G) => G' G'0.
   elim: G 0 G'0 G_fbv=>[//|v|G Ih|p q Ks Ih] n G'0/=.
   - move=> H; case: ifP=>[//|/=]; case: ifP=>//; move: H.
     case: ifP=>//; rewrite ltn_neqAle =>/(rwP negPf).
     rewrite negb_and negbK eq_sym; by move=>/orP-[->//|/negPf->].
   - by apply: (Ih n.+1); rewrite gfbvar_next.
   - rewrite -map_comp/comp/=; move=>/flatten_eq_nil/member_map-H.
     by apply/flatten_eq_nil/member_map=>K M; apply: Ih=>//; apply: H.
 Qed.

Lemma closed_not_var G :
  g_closed G ->
  forall v, G != g_var v.
Proof.
  by rewrite /g_closed; case: G=>//= n; rewrite -cardfs_eq0 cardfs1.
Qed.

Lemma open_not_var d G G' :
  g_closed G ->
  (forall v, G' != g_var v) ->
  forall v, {d ~> G} G' != g_var v.
Proof. by case: G'=>// n _ /(_ n)/eqP. Qed.

Lemma guarded_open d1 d2 G G' :
  guarded 0 G' ->
  g_closed G' ->
  guarded d1 G ->
  guarded d1 ({d2 ~> G'} G).
Proof.
  elim: G=>[|n|G Ih|p q Ks Ih]//= in d1 d2 *.
  - by case: ifP=>// _ /(guarded_depth_gt d1 (leq0n 0))-H /H-{H}H.
  - by apply/Ih.
  - move=> GG' CG'; elim: Ks=>[|K Ks IhK]//= in Ih *.
    move=>/andP-[GK GKs].
    move: (Ih K (or_introl (erefl _)) 0 d2 GG' CG' GK)=>->//=.
    apply/IhK=>// K0 MK0; by apply/(Ih K0 (or_intror MK0)).
Qed.

Lemma guarded_gt d d' G :
  d >= d' ->
  guarded d G ->
  guarded d' G.
Proof.
  elim: G=>[|n|G Ih|p q Ks Ih]//= in d d' *.
  - by move=>/leq_trans-H /H.
  - by move=> H; apply/Ih.
Qed.

Lemma unroll_guarded G :
  g_closed G ->
  guarded 0 G ->
  forall G', n_unroll (rec_depth G) G != g_rec G'.
Proof.
  move: {-2}(rec_depth G) (eq_refl (rec_depth G)) => n.
  elim: n => [|n Ih]/= in G *; case: G=>// G n_rd CG GG; move: n_rd.
  rewrite eqE/=-eqE => n_rd.
  have/=GG': (guarded 0 (g_rec G)) by [].
  move: n_rd; rewrite (guarded_recdepth GG' (ltn0Sn 0) (g_rec G))=>n_rd.
  apply/Ih=>//; first by apply/gopen_closed.
  by apply/guarded_open=>//; apply/guarded_gt; last by apply/GG'.
Qed.

Fixpoint is_end g :=
  match g with
  | g_rec g => is_end g
  | g_end => true
  | _ => false
  end.

Lemma recdepth_unroll g :
  is_end g -> rec_depth g = rec_depth (unroll g).
Proof.
  move=>END; have: (is_end (g_rec g)) by [].
  rewrite /unroll; move: (g_rec g)=>g' END'.
  by elim: g 0 END=>// g Ih n /=/(Ih n.+1)->.
Qed.

Lemma isend_unroll g :
  is_end g -> is_end (unroll g).
Proof.
  move=>END; have: (is_end (g_rec g)) by [].
  rewrite /unroll; move: (g_rec g)=>g' END'.
  by elim: g 0 END=>// g Ih n /=/(Ih n.+1)->.
Qed.

Fixpoint non_empty_cont G :=
  match G with
  | g_msg _ _ Ks => ~~ nilp Ks && all id [seq non_empty_cont K.2.2 | K <- Ks]
  | g_rec G => non_empty_cont G
  | _ => true
  end.

Definition g_precond G :=
  g_closed G && guarded 0 G && non_empty_cont G.

Lemma ne_open n G G' :
  non_empty_cont G -> non_empty_cont G' -> non_empty_cont (g_open n G' G).
Proof.
  move=> NE1 NE2; move: NE1.
  elim: G n=>//.
  - by move=>v n; rewrite /unroll/=; case: ifP=>//.
  - by move=> G Ih n /=; apply/Ih.
  - move=> F T C Ih n /=; case: C Ih=>//= K Ks Ih /andP-[NE_K ALL].
    rewrite (Ih K (or_introl erefl) n NE_K) /= {NE_K}.
    move: Ih=>/(_ _ (or_intror _) n)=> Ih.
    move: ALL=>/forallbP/forall_member/member_map-ALL.
    apply/forallbP/forall_member/member_map/member_map=>/={}K M.
    by apply/(Ih _ M)/ALL.
Qed.

Lemma ne_unr n G : non_empty_cont G -> non_empty_cont (n_unroll n G).
Proof.
  elim: n G=>[//|n/=] Ih; case=>//= G NE.
  have: non_empty_cont (g_rec G) by [].
  by move=>/(ne_open 0 NE); apply/Ih.
Qed.

Lemma precond_parts g :
  g_precond g -> ~~ nilp (participants g) \/ is_end g.
Proof.
  move=>/andP-[/andP-[CG GG]  _]; move: CG GG; rewrite /g_closed.
  elim: g 0.
  - by move=> n _ _; right.
  - by move=>v n /= H E; move: E H=>->.
  - by move=> G Ih n /=; apply/Ih.
  - by move=> p q Ks _ n  _ _; left.
Qed.

End Syntax.


Add LoadPath "../..".
Require Export HybND_Shared.
Require Export PermutLib.

(*** Definitions ***)

(*
Terms in label-free IS5 system:
  * hypothesis
  * lambda expression
  * application
  * box expression
  * unpacking box (possibly in a different world)
  * diamond expression (possibly in a different world)
  * using diamond expression (possibly the diamond itself is from a
  different world)
*)
Inductive te_Hyb :=
| hyp_Hyb: vte -> te_Hyb
| lam_Hyb: ty -> te_Hyb -> te_Hyb
| appl_Hyb: te_Hyb -> te_Hyb -> te_Hyb
| box_Hyb: te_Hyb -> te_Hyb
| unbox_fetch_Hyb: vwo -> te_Hyb -> te_Hyb
.

(* Calculate set of free worlds used in term M *)
Fixpoint free_worlds_Hyb (M: te_Hyb) : fset var :=
match M with
| hyp_Hyb _ => \{}
| lam_Hyb _ M => free_worlds_Hyb M
| appl_Hyb M N => free_worlds_Hyb M \u free_worlds_Hyb N
| box_Hyb M => free_worlds_Hyb M
| unbox_fetch_Hyb (fwo w) M => \{w} \u free_worlds_Hyb M
| unbox_fetch_Hyb _ M => free_worlds_Hyb M
end.

(* Calculate set of free variables used in term M *)
Fixpoint free_vars_Hyb (M: te_Hyb) : fset var :=
match M with
| hyp_Hyb (fte v) => \{v}
| hyp_Hyb (bte _) => \{}
| lam_Hyb _ M => free_vars_Hyb M
| appl_Hyb M N => free_vars_Hyb M \u free_vars_Hyb N
| box_Hyb M => free_vars_Hyb M
| unbox_fetch_Hyb _ M => free_vars_Hyb M
end.

(*
Property: term is locally closed
 This means that there are no bound variables.
*)

Inductive lc_t_n_Hyb : nat -> te_Hyb -> Prop :=
 | lct_hyp_bte_Hyb: forall v n, n > v -> lc_t_n_Hyb n (hyp_Hyb (bte v))
 | lct_hyp_fte_Hyb: forall v n, lc_t_n_Hyb n (hyp_Hyb (fte v))
 | lct_lam_Hyb: forall M t n,
     lc_t_n_Hyb (S n) M ->
     lc_t_n_Hyb n (lam_Hyb t M)
 | lct_appl_Hyb: forall M N n,
     lc_t_n_Hyb n M -> lc_t_n_Hyb n N ->
     lc_t_n_Hyb n (appl_Hyb M N)
 | lct_box_Hyb: forall M n,
     lc_t_n_Hyb n M ->
     lc_t_n_Hyb n (box_Hyb M)
 | lct_unbox_fetch_Hyb: forall M w n,
     lc_t_n_Hyb n M ->
     lc_t_n_Hyb n (unbox_fetch_Hyb w M)
.

Definition lc_t_Hyb M := lc_t_n_Hyb 0 M.

Inductive lc_w_n_Hyb: nat -> te_Hyb -> Prop :=
| lcw_hyp_Hyb: forall v n, lc_w_n_Hyb n (hyp_Hyb v)
| lcw_lam_Hyb: forall t M n,
    lc_w_n_Hyb n M ->
    lc_w_n_Hyb n (lam_Hyb t M)
| lcw_appl_Hyb: forall M N n,
    lc_w_n_Hyb n M -> lc_w_n_Hyb n N ->
    lc_w_n_Hyb n (appl_Hyb M N)
| lcw_box_Hyb: forall M n,
    lc_w_n_Hyb (S n) M ->
    lc_w_n_Hyb n (box_Hyb M)
| lcw_unbox_fetch_fwo_Hyb: forall M w n,
    lc_w_n_Hyb n M ->
    lc_w_n_Hyb n (unbox_fetch_Hyb (fwo w) M)
| lcw_unbox_fetch_bwo_Hyb: forall M n m,
    lc_w_n_Hyb n M -> n > m ->
    lc_w_n_Hyb n (unbox_fetch_Hyb (bwo m) M)
.

Definition lc_w_Hyb M := lc_w_n_Hyb 0 M.

(*** Properties ***)

(* For each pair of contexts, they are either equivalent or not. *)
Theorem permut_context_Hyb_dec:
forall (c1 c2: ctx_Hyb),
    permut (snd c1) (snd c2) /\ (fst c1) = (fst c2) \/
   ~permut (snd c1) (snd c2) \/ (fst c1) <> (fst c2).
intros; destruct c1 as (w, a); destruct c2 as (w', a');
destruct (eq_var_dec w w'); subst; simpl;
destruct (permut_Dec (var * ty) a a'); simpl;
auto; intros;
repeat decide equality;
apply eq_var_dec.
Qed.

(* Propagation of lc_*_n_Hyb property *)

Lemma closed_w_succ:
forall M n,
  lc_w_n_Hyb n M -> lc_w_n_Hyb (S n) M.
intros; generalize dependent n;
induction M; intros; inversion H; subst;
eauto using lc_w_n_Hyb.
constructor; [ | omega]; eauto.
Qed.

Lemma closed_t_succ:
forall M n,
  lc_t_n_Hyb n M -> lc_t_n_Hyb (S n) M.
intros; generalize dependent n;
induction M; intros; inversion H; subst;
eauto using lc_t_n_Hyb.
Qed.

Lemma closed_w_addition:
forall M n m,
  lc_w_n_Hyb n M -> lc_w_n_Hyb (n + m) M.
intros; induction m;
[ replace (n+0) with n by auto |
  replace (n+ S m) with (S (n+m)) by auto] ;
try apply closed_w_succ;
assumption.
Qed.

Lemma closed_t_addition:
forall M n m,
  lc_t_n_Hyb n M -> lc_t_n_Hyb (n + m) M.
intros; induction m;
[ replace (n+0) with n by auto |
  replace (n + S m) with (S (n+m)) by auto] ;
try apply closed_t_succ;
assumption.
Qed.


From Hammer Require Import Hammer.

Require Import SetoidList.
Require Import Relations Morphisms.

Local Notation Fst := (@fst _ _).
Local Notation Snd := (@snd _ _).

Arguments relation_conjunction A%type (R R')%signature _ _.
Arguments relation_equivalence A%type (_ _)%signature.
Arguments subrelation A%type (R R')%signature.
Arguments Reflexive A%type R%signature.
Arguments Irreflexive A%type R%signature.
Arguments Symmetric A%type R%signature.
Arguments Transitive A%type R%signature.
Arguments PER A%type R%signature.
Arguments Equivalence A%type R%signature.
Arguments StrictOrder A%type R%signature.

Generalizable Variables A B RA RB Ri Ro f.

Definition RelCompFun {A} {B : Type}(R:relation B)(f:A->B) : relation A :=
fun a a' => R (f a) (f a').

Typeclasses Opaque RelCompFun.

Infix "@@" := RelCompFun (at level 30, right associativity) : signature_scope.

Notation "R @@1" := (R @@ Fst)%signature (at level 30) : signature_scope.
Notation "R @@2" := (R @@ Snd)%signature (at level 30) : signature_scope.

Class Measure {A B} (f : A -> B).

Instance fst_measure : @Measure (A * B) A Fst.
Instance snd_measure : @Measure (A * B) B Snd.

Definition RelProd {A : Type} {B : Type} (RA:relation A)(RB:relation B) : relation (A*B) :=
relation_conjunction (@RelCompFun (A * B) A RA fst) (RB @@2).

Typeclasses Opaque RelProd.

Infix "*" := RelProd : signature_scope.

Section RelCompFun_Instances.
Context {A : Type} {B : Type} (R : relation B).

Global Instance RelCompFun_Reflexive
`(Measure A B f, Reflexive _ R) : Reflexive (R@@f).
Proof. hammer_hook "RelationPairs" "RelationPairs.RelCompFun_Reflexive".   firstorder. Qed.

Global Instance RelCompFun_Symmetric
`(Measure A B f, Symmetric _ R) : Symmetric (R@@f).
Proof. hammer_hook "RelationPairs" "RelationPairs.RelCompFun_Symmetric".   firstorder. Qed.

Global Instance RelCompFun_Transitive
`(Measure A B f, Transitive _ R) : Transitive (R@@f).
Proof. hammer_hook "RelationPairs" "RelationPairs.RelCompFun_Transitive".   firstorder. Qed.

Global Instance RelCompFun_Irreflexive
`(Measure A B f, Irreflexive _ R) : Irreflexive (R@@f).
Proof. hammer_hook "RelationPairs" "RelationPairs.RelCompFun_Irreflexive".   firstorder. Qed.

Global Program Instance RelCompFun_Equivalence
`(Measure A B f, Equivalence _ R) : Equivalence (R@@f).

Global Program Instance RelCompFun_StrictOrder
`(Measure A B f, StrictOrder _ R) : StrictOrder (R@@f).

End RelCompFun_Instances.

Section RelProd_Instances.

Context {A : Type} {B : Type} (RA : relation A) (RB : relation B).

Global Instance RelProd_Reflexive `(Reflexive _ RA, Reflexive _ RB) : Reflexive (RA*RB).
Proof. hammer_hook "RelationPairs" "RelationPairs.RelProd_Reflexive".   firstorder. Qed.

Global Instance RelProd_Symmetric `(Symmetric _ RA, Symmetric _ RB)
: Symmetric (RA*RB).
Proof. hammer_hook "RelationPairs" "RelationPairs.RelProd_Symmetric".   firstorder. Qed.

Global Instance RelProd_Transitive
`(Transitive _ RA, Transitive _ RB) : Transitive (RA*RB).
Proof. hammer_hook "RelationPairs" "RelationPairs.RelProd_Transitive".   firstorder. Qed.

Global Program Instance RelProd_Equivalence
`(Equivalence _ RA, Equivalence _ RB) : Equivalence (RA*RB).

Lemma FstRel_ProdRel :
relation_equivalence (RA @@1) (RA*(fun _ _ : B => True)).
Proof. hammer_hook "RelationPairs" "RelationPairs.FstRel_ProdRel".   firstorder. Qed.

Lemma SndRel_ProdRel :
relation_equivalence (RB @@2) ((fun _ _ : A =>True) * RB).
Proof. hammer_hook "RelationPairs" "RelationPairs.SndRel_ProdRel".   firstorder. Qed.

Global Instance FstRel_sub :
subrelation (RA*RB) (RA @@1).
Proof. hammer_hook "RelationPairs" "RelationPairs.FstRel_sub".   firstorder. Qed.

Global Instance SndRel_sub :
subrelation (RA*RB) (RB @@2).
Proof. hammer_hook "RelationPairs" "RelationPairs.SndRel_sub".   firstorder. Qed.

Global Instance pair_compat :
Proper (RA==>RB==> RA*RB) (@pair _ _).
Proof. hammer_hook "RelationPairs" "RelationPairs.pair_compat".   firstorder. Qed.

Global Instance fst_compat :
Proper (RA*RB ==> RA) Fst.
Proof. hammer_hook "RelationPairs" "RelationPairs.fst_compat".
intros (x,y) (x',y') (Hx,Hy); compute in *; auto.
Qed.

Global Instance snd_compat :
Proper (RA*RB ==> RB) Snd.
Proof. hammer_hook "RelationPairs" "RelationPairs.snd_compat".
intros (x,y) (x',y') (Hx,Hy); compute in *; auto.
Qed.

Global Instance RelCompFun_compat (f:A->B)
`(Proper _ (Ri==>Ri==>Ro) RB) :
Proper (Ri@@f==>Ri@@f==>Ro) (RB@@f)%signature.
Proof. hammer_hook "RelationPairs" "RelationPairs.RelCompFun_compat".   unfold RelCompFun; firstorder. Qed.
End RelProd_Instances.

Hint Unfold RelProd RelCompFun.
Hint Extern 2 (RelProd _ _ _ _) => split.


From Coq.Unicode Require Import Utf8.
From Coq.Lists Require Import List.
From Coq.Relations Require Import Relations.
From Coq.micromega Require Import Lia.

Class valid_language {expr : Type}
    (is_val : expr → Prop)
    (is_ectx : (expr → expr) → Prop)
    (head_step : expr → expr → Prop) : Type :=
ValidLang {
  is_val_no_head_step : ∀ v, is_val v → ∀ e', ¬ head_step v e';
  is_val_under_ectx : ∀ e K , is_ectx K → is_val (K e) → is_val e;
  is_ectx_id : is_ectx (λ e, e);
  is_val_dec : ∀ e, is_val e ∨ ¬ is_val e;
  ectx_head_step : ∀ K e e', is_ectx K → head_step (K e) e' → (∀ f, K f = f) ∨ is_val e;
  ectx_inj : ∀ K e e', is_ectx K → K e = K e' → e = e';
  ectx_compose : ∀ K K', is_ectx K → is_ectx K' → is_ectx (λ e, K (K' e));
  ectxs_nesting : ∀ K e K' e',
      is_ectx K →
      is_ectx K' →
      K e = K' e' →
      ¬ is_val e →
      ¬ is_val e' →
      (∃ K'', is_ectx K'' ∧ ∀ f, K f = K' (K'' f)) ∨ (∃ K'', is_ectx K'' ∧ ∀ f, K' f = K (K'' f))
}.

Inductive step {expr is_val is_ectx head_step} `{@valid_language expr is_val is_ectx head_step} :
  expr → expr → Prop :=
| Step K e1 e2 : is_ectx K → head_step e1 e2 → step (K e1) (K e2).

Definition steps {expr is_val is_ectx head_step} `{@valid_language expr is_val is_ectx head_step} :=
  clos_refl_trans _ step.

Inductive nsteps {expr is_val is_ectx head_step} `{@valid_language expr is_val is_ectx head_step} :
  nat → expr → expr → Prop :=
| NSO e : nsteps 0 e e
| NSS n e1 e2 e3 : step e1 e2 → nsteps n e2 e3 → nsteps (S n) e1 e3.

Definition det_head_step
  {expr is_val is_ectx head_step} `{@valid_language expr is_val is_ectx head_step} e e' :=
  head_step e e' ∧ ∀ e'', head_step e e'' → e'' = e'.

Definition det_step
  {expr is_val is_ectx head_step} `{@valid_language expr is_val is_ectx head_step} e e' :=
  step e e' ∧ ∀ e'', step e e'' → e'' = e'.

Section language.
  Context {expr is_val is_ectx head_step} `{@valid_language expr is_val is_ectx head_step}.

  Lemma nsteps_refl e : nsteps 0 e e.
  Proof. constructor; fail. Qed.

  Lemma step_nsteps e e' : step e e' → nsteps 1 e e'.
  Proof. econstructor; [eassumption|econstructor]. Qed.

  Lemma nsteps_trans n n' e e' e'' : nsteps n e e' → nsteps n' e' e'' → nsteps (n + n') e e''.
  Proof.
    induction 1; [trivial; fail|].
    simpl.
    econstructor; [eassumption|auto].
  Qed.

  Lemma nsteps_take_step n e e' e'' :
    step e e' → nsteps n e' e'' → nsteps (S n) e e''.
  Proof. intros ? ?; eapply (nsteps_trans 1); [apply step_nsteps|]; eauto. Qed.

  Lemma steps_ind (P : expr → expr → Prop) :
    (∀ e, P e e) →
    (∀ e e' e'', step e e' → steps e' e'' → P e' e'' → P e e'') →
    ∀ e e', steps e e' → P e e'.
  Proof.
    intros Hrfl Hstp e e' Hsteps.
    apply clos_rt_rt1n_iff in Hsteps.
    induction Hsteps; [apply Hrfl|].
    eapply Hstp; [eassumption|apply clos_rt_rt1n_iff; assumption|assumption].
  Qed.

  Lemma steps_refl e : steps e e.
  Proof. constructor; fail. Qed.

  Lemma step_steps e e' : step e e' → steps e e'.
  Proof. constructor; assumption. Qed.

  Lemma steps_trans e e' e'' : steps e e' → steps e' e'' → steps e e''.
  Proof. econstructor; eauto; fail. Qed.

  Lemma steps_nsteps e e' : steps e e' → ∃ n, nsteps n e e'.
  Proof.
    induction 1 as [| |? ? ? ? [n Hn] ? [k Hk]];
      [eexists; eapply step_nsteps; assumption|exists 0; apply nsteps_refl|].
    eexists (_ + _); eapply nsteps_trans; eauto.
  Qed.

  Lemma nsteps_steps n e e' : nsteps n e e' → steps e e'.
  Proof.
    induction 1; [econstructor; fail|eapply steps_trans; [apply step_steps; eassumption|trivial]].
  Qed.

  Lemma val_no_step e : is_val e → ∀ e', ¬ step e e'.
  Proof.
    intros He e' Hstp.
    inversion Hstp as [K e1 e2 HK Hhs]; subst; clear Hstp.
    apply is_val_under_ectx in He; [|assumption].
    eapply is_val_no_head_step; eauto.
  Qed.

  Lemma val_steps_eq e e' : is_val e → steps e e' → e = e'.
  Proof.
    intros Hiv Hstps; revert Hiv.
    pattern e; pattern e'.
    match goal with
    | |- (λ e', (λ e, ?P) _) _ => simpl; apply (steps_ind (λ e e', P))
    end; [| |assumption]; clear e' e Hstps.
    - trivial.
    - intros ???????.
      exfalso; eapply val_no_step; eauto.
  Qed.

  Lemma head_step_step e e' : head_step e e' → step e e'.
  Proof. intros; eapply (Step (λ e, e)); [apply is_ectx_id|assumption]. Qed.

  Lemma ectx_step e e' K : is_ectx K → step e e' → step (K e) (K e').
  Proof.
    intros ?; inversion 1 as [K' e1 e2]; subst.
    eapply (Step (λ e, K (K' e))); [apply ectx_compose; assumption|assumption].
  Qed.

  Lemma ectx_steps e e' K : is_ectx K → steps e e' → steps (K e) (K e').
  Proof.
    intros HK Hstep.
    pattern e; pattern e'.
    match goal with
    | |- (λ e2, (λ e1, ?P) _) _ => simpl; apply (steps_ind (λ e1 e2, P))
    end; [| |assumption]; clear e e' Hstep.
    - intros ?; apply steps_refl.
    - intros e e' e'' Hstep Hsteps HKsteps.
      eapply steps_trans; [apply step_steps, ectx_step|]; eassumption.
  Qed.

  Lemma steps_eq_or_step_iff e e' : steps e e' ↔ e = e' ∨ ∃ e'', step e e'' ∧ steps e'' e'.
  Proof.
    split.
    - intros Hsteps; apply clos_rt_rt1n_iff in Hsteps.
      inversion Hsteps as [|??? Hsteps']; [eauto; fail|].
      apply clos_rt_rt1n_iff in Hsteps'; eauto.
    - intros [->|[? [? ?]]]; apply clos_rt_rt1n_iff;
        [constructor; fail|econstructor; [|apply clos_rt_rt1n_iff]]; eauto.
  Qed.

  Lemma step_under_ectx K e e' :
    is_ectx K → step (K e) e' →
    (is_val e) ∨ (∃ e'', step e e'' ∧ e' = K e'').
  Proof.
    intros HK Hstp.
    destruct (is_val_dec e) as [Hiv|Hniv].
    - auto.
    - right.
      inversion Hstp as [K' e1 e2 HK' Hhs HKe1e]; subst.
      destruct (ectxs_nesting _ _ _ _ HK' HK HKe1e) as [[K'' [HK''1 HK''2]]|[K'' [HK''1 HK''2]]];
      [intros ?; contradict Hhs; apply is_val_no_head_step; assumption|assumption| |].
      + rewrite HK''2 in HKe1e.
        apply ectx_inj in HKe1e; [|assumption].
        subst.
        exists (K'' e2); rewrite HK''2; split; [|reflexivity].
        constructor; trivial.
      + rewrite HK''2 in HKe1e.
        apply ectx_inj in HKe1e; [|assumption].
        subst.
        pose proof Hhs as Hhs'.
        apply ectx_head_step in Hhs as [Hhs|Hhs]; [|tauto|assumption].
        rewrite Hhs in Hhs'.
        exists e2; split; [apply head_step_step; assumption|].
        rewrite HK''2, Hhs; trivial.
  Qed.

  Definition Safe (P : expr → Prop) (e : expr) :=
    ∀ e', steps e e' → (is_val e' ∧ P e') ∨ ∃ e'', step e' e''.

  Lemma Safe_mono (P Q : expr → Prop) e : (∀ v, P v → Q v) → Safe P e → Safe Q e.
  Proof. unfold Safe; firstorder. Qed.

  Lemma Safe_val (P : expr → Prop) e : is_val e → P e → Safe P e.
  Proof.
    unfold Safe; intros He HPe e' Hstp.
    left.
    apply val_steps_eq in Hstp; subst; auto.
  Qed.

  Lemma Safe_val_inv (P : expr → Prop) e : is_val e → Safe P e → P e.
  Proof.
    unfold Safe; intros He HSf.
    destruct (HSf e) as [|[e' He']]; [apply steps_refl|tauto|].
    contradict He'; apply val_no_step; trivial.
  Qed.

  Lemma Safe_step (P : expr → Prop) e e' : step e e' → Safe P e → Safe P e'.
  Proof.
    intros Hstep HSf ei Hsteps.
    apply HSf.
    apply steps_eq_or_step_iff; eauto.
  Qed.

  Lemma det_head_step_det_step e e' : det_head_step e e' → det_step e e'.
  Proof.
    intros [Hhs Hdt]; split; [apply head_step_step; assumption|].
    intros e'' Hstp.
    inversion Hstp as [? ? ? ? Hhs']; subst.
    apply ectx_head_step in Hhs as [Hid|Hvl]; [| |assumption].
    - rewrite Hid; rewrite Hid in Hdt. apply Hdt; assumption.
    - contradict Hhs'; apply is_val_no_head_step; trivial.
  Qed.

  Lemma Safe_det_step_back (P : expr → Prop) e e' : det_step e e' → Safe P e' → Safe P e.
  Proof.
    intros Hdstep HSf ei Hsteps.
    apply steps_eq_or_step_iff in Hsteps as [->|(e'' & He''1 & He''2)].
    - right; eexists; apply Hdstep.
    - apply Hdstep in He''1; subst.
      apply HSf; assumption.
  Qed.

  Lemma Safe_head_step_back (P : expr → Prop) e e' : det_head_step e e' → Safe P e' → Safe P e.
  Proof.
    intros.
    eapply Safe_det_step_back; [apply det_head_step_det_step|]; eassumption.
  Qed.

  Lemma steps_under_ectx K e e' :
    is_ectx K → steps (K e) e' →
    (∃ e'', e' = K e'' ∧ steps e e'') ∨ ∃ v, is_val v ∧ steps e v ∧ steps (K v) e'.
  Proof.
    intros HK [n Hstps]%steps_nsteps.
    revert e e' HK Hstps.
    induction n; intros e e' HK Hstps.
    - inversion Hstps; subst; left; eexists _; split; [eauto|apply steps_refl].
    - inversion Hstps as [|? ? ex]; subst.
      destruct (step_under_ectx K e ex) as [|(e'' & He''1 & He''2)];
        [assumption|assumption| |subst].
      + right; eexists e; split; [assumption|].
        split; [apply steps_refl|eapply nsteps_steps; eassumption].
      + destruct (IHn e'' e') as [(? & -> &?)|(?&?&?&?)]; [assumption|assumption| |].
        * left; eexists; split; [reflexivity|eapply steps_trans; [apply step_steps|]; eauto].
        * right; eexists _; split; [eassumption|].
          split; [eapply steps_trans; [apply step_steps|]; eauto|assumption].
  Qed.

  Lemma Safe_bind (P Q : expr → Prop) e K :
    is_ectx K → Safe P e → (∀ v, is_val v → P v → Safe Q (K v)) → Safe Q (K e).
  Proof.
    intros HK He HKSf e' Hstps.
    apply steps_under_ectx in Hstps as [(e'' & -> & He'')|(v & Hv & Hv1 & Hv2)]; [| |assumption].
    - apply He in He'' as [[Hie'' HPe'']|[e3 He3]].
      + eapply HKSf; [eassumption|eassumption|apply steps_refl].
      + right; eexists; apply ectx_step; eauto.
    - apply He in Hv1 as [[]|[]]; [|exfalso; eapply val_no_step; eauto; fail].
      eapply HKSf; [eassumption|assumption|assumption].
  Qed.

  Definition Normalizes (P : expr → Prop) (e : expr) := ∃ v, is_val v ∧ steps e v ∧ P v.

  Lemma Normalizes_mono (P Q : expr → Prop) e : (∀ v, P v → Q v) → Normalizes P e → Normalizes Q e.
  Proof. unfold Safe; firstorder. Qed.

  Lemma Normalizes_val (P : expr → Prop) e : is_val e → P e → Normalizes P e.
  Proof.
    intros ? ?; eexists; repeat split; [eassumption|apply steps_refl|eassumption].
  Qed.

  Lemma Normalizses_val_inv (P : expr → Prop) e : is_val e → Normalizes P e → P e.
  Proof.
    intros Hiv (e' & He'1 & He'2 & He'3).
    apply val_steps_eq in He'2; [subst; trivial|assumption].
  Qed.

  Lemma Normalizes_step_back (P : expr → Prop) e e' : step e e' → Normalizes P e' → Normalizes P e.
  Proof.
    intros Hstep (v & Hv1 & Hv2 & Hv3).
    exists v; repeat split; [assumption| |assumption].
    apply steps_eq_or_step_iff; eauto.
  Qed.

  Lemma Normalizes_head_step_back (P : expr → Prop) e e' :
    head_step e e' → Normalizes P e' → Normalizes P e.
  Proof.
    intros Hstep (v & Hv1 & Hv2 & Hv3).
    exists v; repeat split; [assumption| |assumption].
    apply steps_eq_or_step_iff; eauto using head_step_step.
  Qed.

  Lemma Normalizes_det_step (P : expr → Prop) e e' :
    det_step e e' → Normalizes P e → Normalizes P e'.
  Proof.
    intros Hdstep (v & Hv1 & Hv2 & Hv3).
    exists v; repeat split; [assumption| |assumption].
    apply steps_eq_or_step_iff in Hv2 as [->|(e'' & He''1 & He''2)].
    - destruct Hdstep as [Hstp%val_no_step ?]; tauto.
    - pose proof He''1 as ->%Hdstep; assumption.
  Qed.

  Lemma Normalizes_bind (P Q : expr → Prop) e K :
    is_ectx K → Normalizes P e → (∀ v, is_val v → P v → Normalizes Q (K v)) → Normalizes Q (K e).
  Proof.
    intros HK He HKnrm.
    destruct He as (v & Hv1 & Hv2 & Hv3).
    destruct (HKnrm v) as (w & Hw1 & Hw2 & Hw3); [assumption|assumption|].
    exists w; repeat split; [assumption| |assumption].
    eapply steps_trans; [|eassumption].
    apply ectx_steps; assumption.
  Qed.

  Lemma val_nsteps_eq n e e' : is_val e → nsteps n e e' → n = 0 ∧ e = e'.
  Proof.
    inversion 2; subst; [split; reflexivity|].
    exfalso; eapply val_no_step; eauto.
  Qed.

  Lemma nsteps_eq_or_step_iff n e e' :
    nsteps n e e' ↔ (n = 0 ∧ e = e') ∨ ∃ n' e'', n = S n' ∧ step e e'' ∧ nsteps n' e'' e'.
  Proof.
    split.
    - intros Hsteps.
      inversion Hsteps; subst.
      + left; auto.
      + right; eexists _, _; split; [reflexivity|]; split; [eassumption|eassumption].
    - intros [[-> ->]|(?&?&->&?&?)]; [constructor|econstructor; eauto].
  Qed.

  Lemma ectx_nsteps n e e' K : is_ectx K → nsteps n e e' → nsteps n (K e) (K e').
  Proof. induction 2; econstructor; eauto using ectx_step. Qed.

  Definition SISafe (P : nat → expr → Prop) (n : nat) (e : expr) :=
    ∀ k e', k ≤ n → nsteps k e e' → (is_val e' ∧ P (n - k) e') ∨ ∃ e'', step e' e''.

  Lemma SISafe_mono (P Q : nat → expr → Prop) n e :
    (∀ n' v, n' ≤ n → P n' v → Q n' v) → SISafe P n e → SISafe Q n e.
  Proof.
    intros HPQ HSf ??? Hstps.
    apply HSf in Hstps as [?|?]; [|auto; fail|lia].
    left; split; [tauto|apply HPQ; [lia|tauto]].
  Qed.

  Lemma SISafe_down_closed (P : nat → expr → Prop) n n' e :
    n' ≤ n → (∀ k k' e, k' ≤ k → k ≤ n → P k e → P k' e) → SISafe P n e → SISafe P n' e.
  Proof.
    intros Hle HP Hne z e' Hz Hnstps.
    destruct (λ Hle, Hne z e' Hle Hnstps) as [[? ?]|]; [lia| |right; assumption].
    left; split; [assumption|].
    eapply HP; [| |eassumption]; [lia|lia].
  Qed.

  Lemma SISafe_down_closed' (P : nat → expr → Prop) n n' e :
    ¬ is_val e → n' ≤ n → (∀ k k' e, k' ≤ k → k < n → P k e → P k' e) → SISafe P n e → SISafe P n' e.
  Proof.
    intros Hniv Hle HP Hne z e' Hz Hnstps.
    destruct (λ Hle, Hne z e' Hle Hnstps) as [[? ?]|]; [lia| |right; assumption].
    inversion Hnstps; subst; [tauto|].
    left; split; [assumption|].
    eapply HP; [| |eassumption]; [lia|lia].
  Qed.

  Lemma SISafe_val (P : nat → expr → Prop) n e : is_val e → P n e → SISafe P n e.
  Proof.
    intros He HPe k e' Hk Hstp.
    left.
    apply val_nsteps_eq in Hstp as [? ?]; subst; [|assumption].
    replace (n - 0) with n by lia; auto.
  Qed.

  Lemma SISafe_val_inv (P : nat → expr → Prop) n e : is_val e → SISafe P n e → P n e.
  Proof.
    unfold Safe; intros He HSf.
    destruct (HSf 0 e) as [[Hiv HP]|[e' He']]; [lia|apply nsteps_refl| |].
    - replace (n - 0) with n in HP by lia; trivial.
    - contradict He'; apply val_no_step; trivial.
  Qed.

  Lemma SISafe_step (P : nat → expr → Prop) e e' n :
    step e e' → SISafe P (S n) e → SISafe P n e'.
  Proof.
    intros Hstep HSf k ei Hk Hsteps.
    apply (HSf (S k)); [lia|].
    econstructor; eauto.
  Qed.

  Lemma SISafe_det_step_back (P : nat → expr → Prop) e e' n :
    det_step e e' → (0 < n → SISafe P (n - 1) e') → SISafe P n e.
  Proof.
    intros Hdstep HSf k ei Hk Hsteps.
    apply nsteps_eq_or_step_iff in Hsteps as [[-> ->]|(m & e'' & -> & He''1 & He''2)].
    - right; eexists; apply Hdstep.
    - apply Hdstep in He''1; subst.
      destruct n as [|n]; [lia|].
      pose proof (λ H, HSf H m ei) as HSf'. simpl in *.
      replace (n - 0) with n in HSf' by lia.
      apply HSf'; [lia|lia|assumption].
  Qed.

  Lemma SISafe_head_step_back (P : nat → expr → Prop) e e' n :
    det_head_step e e' → (0 < n → SISafe P (n - 1) e') → SISafe P n e.
  Proof.
    intros.
    eapply SISafe_det_step_back; [apply det_head_step_det_step|]; eassumption.
  Qed.

  Lemma nsteps_under_ectx n K e e' :
    is_ectx K → nsteps n (K e) e' →
    (∃ e'', e' = K e'' ∧ nsteps n e e'') ∨
      ∃ k v, k ≤ n ∧ is_val v ∧ nsteps k e v ∧ nsteps (n - k) (K v) e'.
  Proof.
    revert e e'.
    induction n; intros e e' HK Hstps.
    - inversion Hstps; subst; left; eexists _; split; [eauto|econstructor].
    - inversion Hstps as [|? ? ex]; subst.
      destruct (step_under_ectx K e ex) as [|(e'' & He''1 & He''2)];
        [assumption|assumption| |subst].
      + right; eexists 0, e; split; [lia|split]; [assumption|].
        split; [econstructor|].
        rewrite PeanoNat.Nat.sub_0_r; trivial.
      + destruct (IHn e'' e') as [(? & -> &?)|(?&?&?&?&?&?)]; [assumption|assumption| |].
        * left; eexists; split; [reflexivity|econstructor; eauto].
        * right; eexists (S _), _; repeat split; [|eassumption| |eassumption]; [lia|].
          econstructor; eauto.
  Qed.

  Lemma SISafe_bind (P Q : nat → expr → Prop) e K n :
    is_ectx K →
    SISafe P n e →
    (∀ k v, k ≤ n → is_val v → P k v → SISafe Q k (K v)) →
    SISafe Q n (K e).
  Proof.
    intros HK He HKSf k e' Hk Hstps.
    apply nsteps_under_ectx in Hstps as [(e'' & -> & He'')|(m & ? & v & Hv & Hv1 & Hv2)];
      [| |assumption].
    - apply He in He'' as [[Hie'' HPe'']|[e3 He3]]; [| |lia].
      + apply HKSf in HPe''; [|lia|assumption].
        pose proof (HPe'' 0) as HPe3.
        replace (n - k - 0) with (n - k) in HPe3 by lia.
        apply HPe3; [lia|]; apply nsteps_refl.
      + right; eexists; apply ectx_step; eauto.
    - apply He in Hv1 as [[? HPkv]|[]]; [|exfalso; eapply val_no_step; eauto; fail|lia].
      apply HKSf in HPkv; [|lia|assumption].
      specialize (HPkv (k - m) e'); simpl in *.
      replace (n - m - (k - m)) with (n - k) in HPkv by lia.
      apply HPkv; [lia |assumption].
  Qed.

  Lemma SISafe_adequacy P e : (∀ n, SISafe (λ _ v, P v) n e) → Safe P e.
  Proof.
    intros HSI e' [n Hstps]%steps_nsteps.
    eapply (HSI n); [|eassumption]; lia.
  Qed.

End language.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

Theorem pipo_6 : (forall A B C D M : Universe, ((wd_ B D /\ (wd_ B A /\ (wd_ A C /\ (wd_ B C /\ (wd_ D A /\ (wd_ D C /\ (wd_ M A /\ (wd_ M C /\ (col_ B M D /\ (col_ A B D /\ col_ M A C)))))))))) -> col_ M A B)).
Proof.
  time tac.
Qed.

End FOFProblem.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

Theorem pipo_6 : (forall A B C D M : Universe, ((wd_ B D /\ (wd_ B A /\ (wd_ A C /\ (wd_ B C /\ (wd_ D A /\ (wd_ D C /\ (wd_ M A /\ (wd_ M C /\ (col_ B M D /\ (col_ C B D /\ col_ M A C)))))))))) -> col_ M B C)).
Proof.
  time tac.
Qed.

End FOFProblem.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

Theorem pipo_6 : (forall A B C I J K : Universe, ((wd_ A B /\ (wd_ B C /\ (wd_ I B /\ (wd_ I C /\ (wd_ K A /\ (wd_ K B /\ (wd_ A C /\ (wd_ I J /\ (wd_ J K /\ (wd_ J A /\ (wd_ J C /\ (wd_ I K /\ (col_ K A B /\ (col_ J A C /\ (col_ I B C /\ col_ A B C))))))))))))))) -> col_ A J K)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import Undecidability.L.L.
Require Import Undecidability.Synthetic.Undecidability.
From Undecidability.Synthetic Require Import
  DecidabilityFacts EnumerabilityFacts.
Require Import Undecidability.L.Enumerators.term_enum.

Require Import Undecidability.TM.TM.
Require Import Undecidability.TM.TM_undec.
Require Import Undecidability.L.Reductions.TM_to_L.

(* ** HaltL is undecidable *)

Lemma HaltL_undec :
  undecidable (HaltL).
Proof.
  apply (undecidability_from_reducibility HaltMTM_undec).
  eapply HaltMTM_to_HaltL.
Qed.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

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

End FOFProblem.


Require Import Bedrock.Platform.Cito.Syntax.
Require Bedrock.Platform.Cito.DepthExpr.
Require Import Bedrock.Platform.Cito.Max.

Set Implicit Arguments.

Local Notation edepth := DepthExpr.depth.

Fixpoint depth statement :=
  match statement with
    | Syntax.Skip => 0
    | Syntax.Seq a b => max (depth a) (depth b)
    | Syntax.If cond t f => max (edepth cond) (max (depth t) (depth f))
    | While cond body => max (edepth cond) (depth body)
    | Syntax.Call _ f args => max (edepth f) (max_list 0 (List.map edepth args))
    | Syntax.Label _ _ => 0
    | Syntax.Assign _ e => edepth e
  end.


(** Formal Reasoning About Programs <http://adam.chlipala.net/frap/>
  * Chapter 14: Concurrent Separation Logic
  * Author: Adam Chlipala
  * License: https://creativecommons.org/licenses/by-nc-nd/4.0/ *)

Require Import Map CSLSets Setoid Classes.Morphisms.
Require Import Decidable Coq.Logic.Eqdep Coq.Logic.EqdepFacts Peano_dec Coq.omega.Omega.

Require Export ho_proof_until_gen.
Require Export until_all_ok.

Set Implicit Arguments.

(* Let's combine the subjects of the last two lectures, to let us prove
 * correctness of concurrent programs that do dynamic management of shared
 * memory. *)

(** * Shared notations and definitions; main material starts afterward. *)

Notation heap := (fmap nat nat).
Notation locks := (set nat).

(* Hint Extern 1 (_ <= _) => linear_arithmetic. *)
(* Hint Extern 1 (@eq nat _ _) => linear_arithmetic. *)

(* Ltac simp := repeat (simplify; subst; propositional; *)
(*                      try match goal with *)
(*                          | [ H : ex _ |- _ ] => invert H *)
(*                         end); try linear_arithmetic. *)

(** * A shared-memory concurrent language with loops *)

(* Let's work with a variant of the shared-memory concurrent language from last
 * time.  We add back in result types, loops, and dynamic memory allocation. *)

Inductive loop_outcome acc :=
| Done (a : acc)
| Again (a : acc).

Definition valueOf {A} (o : loop_outcome A) :=
  match o with
  | Done v => v
  | Again v => v
  end.

Inductive cmd : Set -> Type :=
| Return {result : Set} (r : result) : cmd result
| Fail {result} : cmd result
| Bind {result result'} (c1 : cmd result') (c2 : result' -> cmd result) : cmd result
| Loop {acc : Set} (init : acc) (body : acc -> cmd (loop_outcome acc)) : cmd acc

| Read (a : nat) : cmd nat
| Write (a v : nat) : cmd unit
| Lock (a : nat) : cmd unit
| Unlock (a : nat) : cmd unit
| Alloc (numWords : nat) : cmd nat
| Free (base numWords : nat) : cmd unit

| Par (c1 c2 : cmd unit) : cmd unit.

(* The next span of definitions is copied from SeparationLogic.v.  Skip ahead to
 * the word "Finally" to see what's new. *)

Notation "x <- c1 ; c2" := (Bind c1 (fun x => c2)) (right associativity, at level 80).
Notation "'for' x := i 'loop' c1 'done'" := (Loop i (fun x => c1)) (right associativity, at level 80).
Infix "||" := Par.

Fixpoint initialize (h : heap) (base numWords : nat) : heap :=
  match numWords with
  | O => h
  | S numWords' => initialize h base numWords' $+ (base + numWords', 0)
  end.

Fixpoint deallocate (h : heap) (base numWords : nat) : heap :=
  match numWords with
  | O => h
  | S numWords' => deallocate (h $- base) (base+1) numWords'
  end.

Inductive cfg (A : Set) : Type :=
  Cfg {hp:heap
      ;lcks:locks
      ;command:cmd A}.

Inductive cslstep : forall A, cfg A -> cfg A -> Prop :=
| StepBindRecur : forall result result' (c1 c1' : cmd result') (c2 : result' -> cmd result) h l h' l',
  cslstep (Cfg h l c1) (Cfg h' l' c1')
  -> cslstep (Cfg h l (Bind c1 c2)) (Cfg h' l' (Bind c1' c2))
| StepBindProceed : forall (result result' : Set) (v : result') (c2 : result' -> cmd result) h l,
  cslstep (Cfg h l (Bind (Return v) c2)) (Cfg h l (c2 v))

| StepLoop : forall (acc : Set) (init : acc) (body : acc -> cmd (loop_outcome acc)) h l,
  cslstep (Cfg h l (Loop init body)) (Cfg h l (o <- body init; match o with
                                                     | Done a => Return a
                                                     | Again a => Loop a body
                                                     end))

| StepRead : forall h l a v,
  h $? a = Some v
  -> cslstep (Cfg h l (Read a)) (Cfg h l (Return v))
| StepWrite : forall h l a v v',
  h $? a = Some v
  -> cslstep (Cfg h l (Write a v')) (Cfg (h $+ (a, v')) l (Return tt))
| StepAlloc : forall h l numWords a,
  a <> 0
  -> (forall i, i < numWords -> h $? (a + i) = None)
  -> cslstep (Cfg h l (Alloc numWords)) (Cfg (initialize h a numWords) l (Return a))
| StepFree : forall h l a numWords,
  cslstep (Cfg h l (Free a numWords)) (Cfg (deallocate h a numWords) l (Return tt))

| StepLock : forall h l a,
  ~a \in l
  -> cslstep (Cfg h l (Lock a)) (Cfg h (l \cup {a}) (Return tt))
| StepUnlock : forall h l a,
  a \in l
  -> cslstep (Cfg h l (Unlock a)) (Cfg h (l \setminus {a}) (Return tt))

| StepPar1 : forall h l c1 c2 h' l' c1',
  cslstep (Cfg h l c1) (Cfg h' l' c1')
  -> cslstep (Cfg h l (Par c1 c2)) (Cfg h' l' (Par c1' c2))
| StepPar2 : forall h l c1 c2 h' l' c2',
  cslstep (Cfg h l c2) (Cfg h' l' c2')
  -> cslstep (Cfg h l (Par c1 c2)) (Cfg h' l' (Par c1 c2')).

Infix "==n" := eq_nat_dec (no associativity, at level 50).

Example incrementer :=
for i := tt loop
  _ <- Lock 0;
  n <- Read 0;
  _ <- Write 0 (n);
  _ <- Unlock 0;
  if n ==n 0 then
    Fail
  else
    Return (Again tt)
done.

Example incrementer_par := incrementer || incrementer.

Definition hprop := heap -> Prop.
(* We add the locks to the mix. *)

Definition himp (p q : hprop) := forall h, p h -> q h.
Definition heq (p q : hprop) := forall h, p h <-> q h.

(* Lifting a pure proposition: it must hold, and the heap must be empty. *)
Definition lift (P : Prop) : hprop :=
  fun h => P /\ h = $0.

(* Separating conjunction, one of the two big ideas of separation logic.
 * When does [star p q] apply to [h]?  When [h] can be partitioned into two
 * subheaps [h1] and [h2], respectively compatible with [p] and [q].  See book
 * module [Map] for definitions of [split] and [disjoint]. *)
Definition star (p q : hprop) : hprop :=
  fun h => exists h1 h2, split h h1 h2 /\ disjoint h1 h2 /\ p h1 /\ q h2.

(* Existential quantification *)
Definition exis A (p : A -> hprop) : hprop :=
  fun h => exists x, p x h.

(* Convenient notations *)
Notation "[| P |]" := (lift P) : sep_scope.
Infix "*" := star : sep_scope.
Notation "'exists' x .. y , p" := (exis (fun x => .. (exis (fun y => p)) ..)) : sep_scope.
Delimit Scope sep_scope with sep.
Notation "p === q" := (heq p%sep q%sep) (no associativity, at level 70).
Notation "p ===> q" := (himp p%sep q%sep) (no associativity, at level 70).

(* And now we prove some key algebraic properties, whose details aren't so
 * important.  The library automation uses these properties. *)

Lemma iff_two : forall A (P Q : A -> Prop),
  (forall x, P x <-> Q x)
  -> (forall x, P x -> Q x) /\ (forall x, Q x -> P x).
Proof.
  firstorder.
Qed.

Definition ptsto (a v : nat) : heap -> Prop := fun h => h = $0 $+ (a, v).

(* Recall that each lock has an associated invariant.  This program only uses
 * lock 0, and here's its invariant: memory cell 0 holds a positive number. *)
Definition incrementer_inv :=
  (exists n, ptsto 0 n * [| n > 0 |])%sep.

Definition incrementer_inv' :=
  (exis (fun n => ptsto 0 n * [| n > 0 |]))%sep.

Definition inc_inv A : cfg A -> Prop :=
  fun cfg => forall h l c,
      cfg = (Cfg h l c) ->
      exists (x : nat) (h1 h2 : heap),
        split h h1 h2 /\ disjoint h1 h2 /\ ptsto 0 x h1 /\ [|x > 0|]%sep h2.

(* Inductive ho_spec_old (B : Spec (cfg unit)) : Spec (cfg unit) := *)
(* | claim1_old : forall h P n, *)
(*     h = $0 $+ (0, n) -> n > 0 ->  *)
(*     B (Cfg h {} (P || incrementer)) (fun _ c => inc_inv c) (fun _ => False) -> *)

(*     (forall x x' x'' l l' l'' Z Q, *)
(*       B (Cfg x l (Z || Q)) (fun _ c => inc_inv c) (fun _ => False) <-> *)
(*       (forall Z', cslstep (Cfg x l (Z || Q)) (Cfg x' l' (Z' || Q)) -> *)
(*                   B (Cfg x' l' (Z' || Q)) (fun _ c => inc_inv c) (fun _ => False) *)
(*                   /\ inc_inv (Cfg x' l' (Z' || Q))) /\ *)
(*       (forall Q', cslstep (Cfg x l (Z || Q)) (Cfg x'' l'' (Z || Q')) -> *)
(*                   inc_inv (Cfg x'' l'' (Z || Q')) -> *)
(*                   B (Cfg x'' l'' (Z || Q')) (fun _ c => inc_inv c) (fun _ => False))) *)

(*     -> ho_spec_old B (Cfg (h $+ (0 ,n)) {} (P || incrementer)) *)
(*                (fun _ c => inc_inv c) (fun _ => False). *)

Inductive ho_spec (C : Spec (cfg unit)) : Spec (cfg unit) :=
| claim1 : forall h P n,
    h = $0 $+ (0, n) -> n > 0 ->
    C (Cfg h {} (P || incrementer)) (fun _ c => inc_inv c) (fun _ => False) ->
    (forall x x' l l' Z Z' Q,
        cslstep (Cfg x l (Z || Q)) (Cfg x' l' (Z' || Q)) ->
        C (Cfg x' l' (Z' || Q)) (fun _ c => inc_inv c) (fun _ => False) /\
        inc_inv (Cfg x' l' (Z' || Q))) ->
    ho_spec C (Cfg (h $+ (0, n)) {} (P || incrementer))
               (fun _ c => inc_inv c) (fun _ => False).

Inductive EnforceInvariance (C : Spec (cfg unit)) : Spec (cfg unit) :=
| enf1 : forall c c',
    cslstep c c' ->
    EnforceInvariance C c' (fun _ d => inc_inv d) (fun _ => False)
| enf2 : forall c,
    C c (fun _ d => inc_inv d) (fun _ => False) ->
    EnforceInvariance C c (fun _ d => inc_inv d) (fun _ => False).

Inductive ho_spec_simp (C : Spec (cfg unit)) : Spec (cfg unit) :=
| claim1_simp : forall h P n,
    h = $0 $+ (0, n) -> n > 0 ->
    C (Cfg h {} (P || incrementer)) (fun _ c => inc_inv c) (fun _ => False) ->
    ho_spec_simp C (Cfg (h $+ (0 ,n)) {} (P || incrementer))
                 (fun _ c => inc_inv c) (fun _ => False).

Lemma ho_spec_simp_mono : mono ho_spec_simp.
Proof.
  intro;intros;intro;intros. inversion H0; subst. constructor; auto.
Qed.

Lemma ho_subspec : forall A, subspec (ho_spec A) (ho_spec_simp A).
Proof.
  intros;intro;intros. inversion H; subst. constructor; auto.
Qed.

(* S defined as S H = H o EnforceInvariance *)
(* (S (ho_spec_simp)) x = ho_spec_simp (EnforceInvariance x) *)
Definition S := fun (H : Spec (cfg unit) -> Spec (cfg unit)) x => H (EnforceInvariance x).

Lemma EnfInv_mono : mono EnforceInvariance.
Proof.
  intro;intros;intro;intros.
  inversion H0; subst. eapply enf1. eassumption. constructor. apply H. assumption.
Qed.

Lemma S_mono : ho_mono S.
Proof.
  intro;intros;intro;intros;intro;intros. unfold S.
  unfold subspec, Proper, respectful in H.
  apply H with (EnforceInvariance x0). intros.
  revert H2. apply EnfInv_mono. assumption. assumption.
Qed.

Lemma subspecST : forall C A, mono C -> subspec (S C A) (T (step (@cslstep unit)) C A).
Proof.
  intros;intro;intros. unfold S in H0.
  apply tfun. apply step_mono. assumption.
  revert H0. apply H. intro;intros.
  inversion H0; subst.
  Focus 2. apply Tf_id. assumption.
  apply Tf_t. assumption.
  apply t_gfp with (F := EnforceInvariance). apply EnfInv_mono. intros;intro;intros.
  econstructor. apply EnfInv_mono. intros;intro;intros.
  Admitted.

(* ho_spec <= S ho_spec_simp *)
Lemma S_lemma : forall C, subspec (ho_spec C) (S ho_spec_simp C).
Proof.
  intros;intro;intros. unfold S. inversion H; subst.
  econstructor; auto. apply enf2. assumption.
Qed.

(* (* S ho_spec_simp <= ho_spec *) *)
(* Lemma S_lemma2 : forall C, subspec (S ho_spec_simp C) (ho_spec C). *)
(* Proof. *)
(*   intros;intro;intros. inversion H; subst. *)
(*   inversion H2; subst. *)
(*   Focus 2. econstructor; auto.  *)
(* Admitted. *)

(* (* S ho_spec <= ho_spec_simp *) *)
(* Lemma S_lemma3 : forall C, subspec (S ho_spec C) (ho_spec_simp C). *)
(* Proof. *)
(*   intros;intro;intros. inversion H; subst. *)
(*   constructor; auto. *)
(*   inversion H2; subst. *)
(*   Focus 2. assumption. admit. *)
(* Qed. *)

Lemma S_lemma2 : forall C, subspec (ho_spec_simp C) (S ho_spec C).
Proof.
  intros;intro;intros. unfold S. inversion H; subst.
  constructor; auto. apply enf2. assumption.
  intros. split. eapply enf1. eassumption.
  Admitted.

Inductive nonho_spec : Spec (cfg unit) :=
| nonho_claim : forall h n,
    h = $0 $+ (0, n) -> n > 0 ->
    nonho_spec (Cfg (h $+ (0, n)) {} (incrementer || incrementer))
               (fun _ c => inc_inv c) (fun _ => False).

Lemma ho_spec_mono : mono ho_spec.
Proof.
  destruct 2. econstructor; try eassumption. apply H. eassumption.
  intros. split; try apply H; eapply H3; eassumption.
Qed.

Lemma ho_gfp : subspec nonho_spec (ho_spec nonho_spec).
Proof.
  destruct 1. econstructor; try eassumption. assert (h = (h $+ (0,n))).
  subst. maps_equal. rewrite H1. econstructor; try eassumption.
  intros. split. admit. admit.
Qed.

Ltac injpair1 H H1 := inversion H;
                      (try repeat apply inj_pair2 in H1; subst).
Ltac injpair3 H H1 H2 H3 := inversion H;
                            (try repeat apply inj_pair2 in H1;
                             try repeat apply inj_pair2 in H2;
                             try repeat apply inj_pair2 in H3; subst).
Ltac injpair4 H H1 H2 H3 H4 := inversion H;
                               (try repeat apply inj_pair2 in H1;
                                try repeat apply inj_pair2 in H2;
                                try repeat apply inj_pair2 in H3;
                                try repeat apply inj_pair2 in H4; subst).

Lemma heap_eq : forall h n,
    h = $0 $+ (0, n) -> n > 0 ->
    exists (x : nat) (h1 h2 : heap),
      split (h $+ (0, n)) h1 h2 /\ disjoint h1 h2 /\ ptsto 0 x h1 /\ [|x > 0|]%sep h2.
Proof.
  intros.
  exists n. exists ($0 $+ (0,n)). exists (h $- 0).
  split. unfold split. subst.
  maps_equal. rewrite lookup_join1.
  rewrite lookup_add_eq. rewrite lookup_add_eq. trivial. trivial. trivial.
  eapply lookup_Some_dom. apply lookup_add_eq. trivial.

  rewrite lookup_add_ne. rewrite lookup_join2.
  rewrite lookup_remove_ne. trivial. omega.
  apply lookup_None_dom. rewrite lookup_add_ne. apply lookup_empty. omega. omega.

  split. unfold disjoint. intros. apply H1.
  destruct (($0 $+ (0, n)) $? a) eqn:H'.
  destruct ((h $- 0) $? a) eqn:H''.
  exfalso. apply lookup_split in H'. inversion H'. inversion H3.
  rewrite lookup_empty in H5. inversion H5. inversion H3; subst. inversion H3.
  apply lookup_remove_eq with (m := $0 $+ (0, n)) in H. rewrite H'' in H. inversion H.
  exfalso. apply H2. trivial. trivial.

  split. unfold ptsto. trivial. unfold lift. split. assumption.
  subst. maps_equal. destruct k. rewrite lookup_remove_eq. rewrite lookup_empty.
  trivial. trivial.
  rewrite lookup_remove_ne. rewrite lookup_add_ne. trivial. omega. omega.
Qed.

Ltac get_next1 := apply tstep; apply ho_spec_mono; econstructor; apply StepPar2;
                  econstructor; econstructor; econstructor.

Ltac get_next2 := apply tstep; apply ho_spec_mono; econstructor; apply StepPar2;
                 constructor; apply StepBindProceed.

Ltac incsolve H := unfold inc_inv; intros;
                  inversion H; subst;
                   apply heap_eq; auto.

Ltac lstep H := edestruct H; try eassumption; split; try eassumption;
                apply trule; try apply ho_spec_mono; assumption.

Lemma map_get : forall n (v : nat), ($0 $+ (0, n) $+ (0, n)) $? 0 = Some v -> n = v.
Proof.
  intros.
  assert (($0 $+ (0, n) $+ (0, n)) $? 0 = Some n).
  apply lookup_add_eq. trivial. rewrite H in H0. inversion H0. trivial.
Qed.

Lemma ho_spec_bT : forall A,
    subspec (ho_spec A) (step (@cslstep unit) (T (step (@cslstep unit)) ho_spec A)).
Proof.
    intros.
  destruct 1. apply sstep. econstructor.
  apply StepPar2. constructor.

  intros.
  injpair1 H3 H9.
  assert ($0 $+ (0,n) = $0 $+ (0,n) $+ (0,n)) by maps_equal.
  lstep H2.

  injpair3 H6 H8 H9 H12.
  split. incsolve H. clear H3.

  apply tstep. apply ho_spec_mono. econstructor. apply StepPar2.
  constructor. constructor. constructor. sets idtac.

  intros. injpair1 H H9.
  lstep H2. clear H.

  injpair4 H5 H9 H10 H10 H13.
  injpair4 H4 H10 H11 H11 H14.
  injpair1 H7 H12.
  split. incsolve H.

  apply tstep. apply ho_spec_mono. econstructor. apply StepPar2.
  constructor. apply StepBindProceed.

  intros. injpair1 H H13.
  lstep H2. clear H.

  injpair4 H10 H13 H14 H14 H17.
  injpair4 H9 H14 H15 H15 H18.
  inversion H11. do 2 (apply inj_pair2 in H16). apply inj_pair2 in H19; subst.
  split. incsolve H.

  apply tstep. apply ho_spec_mono. econstructor. apply StepPar2.
  constructor. constructor. constructor. eapply lookup_add_eq. trivial.

  intros. injpair1 H H16.
  lstep H2. clear H.

  injpair4 H12 H16 H17 H17 H20.
  injpair4 H11 H17 H18 H18 H21.
  injpair1 H13 H19.
  split. incsolve H.

  apply tstep. apply ho_spec_mono. econstructor. apply StepPar2.
  constructor. apply StepBindProceed.

  intros. injpair1 H H20.
  lstep H2. clear H.

  injpair4 H17 H20 H21 H21 H24.
  injpair4 H16 H21 H22 H22 H25.
  inversion H18. do 2 (apply inj_pair2 in H23). apply inj_pair2 in H26; subst.
  split. incsolve H.

  apply tstep. apply ho_spec_mono. econstructor. apply StepPar2.
  constructor. constructor. econstructor. eapply lookup_add_eq. trivial.

  intros. injpair1 H H23.
  lstep H2. clear H. (* clear H8. clear H14. clear H15. *)

  apply map_get in H15; subst.
  injpair4 H19 H22 H23 H23 H26.
  injpair4 H15 H23 H24 H24 H27.
  injpair1 H18 H26.
  split. incsolve H.

  apply tstep. apply ho_spec_mono. econstructor. apply StepPar2.
  constructor. apply StepBindProceed.

  intros. injpair1 H H26.
  lstep H2. clear H.

  injpair4 H23 H26 H27 H27 H30.
  injpair4 H22 H27 H28 H28 H31.
  inversion H24. do 2 (apply inj_pair2 in H29). apply inj_pair2 in H32; subst.
  split. incsolve H.

  apply tstep. apply ho_spec_mono. econstructor. apply StepPar2.
  constructor. constructor. constructor. sets idtac. right. unfold List.In.
  left. trivial.

  intros. injpair1 H H29.
  lstep H2. clear H.

  injpair4 H25 H29 H30 H30 H33.
  injpair4 H24 H30 H31 H31 H34.
  injpair1 H26 H32.
  split. incsolve H.

  apply tstep. apply ho_spec_mono. econstructor. apply StepPar2.
  constructor. apply StepBindProceed.

  intros. injpair1 H H33.
  lstep H2. clear H.

  injpair4 H30 H33 H34 H34 H37.
  injpair4 H29 H34 H35 H35 H38.
  inversion H31. do 2 (apply inj_pair2 in H36). apply inj_pair2 in H39; subst.
  split. incsolve H.

  destruct (v ==n 0). apply tdone. apply ho_spec_mono. omega.

  apply tstep. apply ho_spec_mono. econstructor. apply StepPar2.
  apply StepBindProceed.

  intros. injpair1 H H36.
  lstep H2. clear H.

  injpair4 H32 H36 H37 H37 H40.
  inversion H31. do 2 (apply inj_pair2 in H38). apply inj_pair2 in H41; subst.
  split. incsolve H.

  eapply ttrans. eapply ho_spec_mono.
  assert (T (step (@cslstep unit)) ho_spec A
            {| hp := $0 $+ (0, v); lcks := {}; command := P || incrementer |}
            (fun _ c : cfg unit => inc_inv c) (fun _ : cfg unit => False)).
  apply Tf_id. assumption.
  assert ($0 $+ (0, v) = $0 $+ (0, v) $+ (0, v) $+ (0, v)) by maps_equal.
  assert (({} \cup {0}) \setminus {0} = {}) by sets idtac.
  rewrite <- H3. rewrite H31. apply H.
  intros. inversion H.
Qed.

Lemma ho_spec_BT : forall A,
    subspec (ho_spec A) (B (step (@cslstep unit)) (T (step (@cslstep unit)) ho_spec) A).
Proof.
  intros;intro;intros.
  pose proof ho_spec_bT.
  assert (forall A1 : ho_proof_until_gen.Spec (cfg unit),
   subspec (ho_spec (step (cslstep (A:=unit)) A1))
     (step (cslstep (A:=unit)) (T (step (cslstep (A:=unit))) ho_spec A1))).
  unfold subspec;intros.
  apply H0 in H1. revert H1. apply step_mono.
  unfold subspec;intros. apply Tf_idem. apply step_mono. apply ho_spec_mono.
  revert H1. apply T_mono. apply ho_spec_mono. apply Tf_base. apply step_mono.
  econstructor. apply ho_spec_mono. assumption. assumption.
Qed.

Lemma ho_spec_simp_BT_help : forall A,
    subspec (ho_spec A) (B (step (@cslstep unit)) (T (step (@cslstep unit)) ho_spec_simp) A).
Proof.
  intros.
  assert (subspec (B (step (@cslstep unit)) (T (step (@cslstep unit)) ho_spec) A)
                  (B (step (@cslstep unit)) (T (step (@cslstep unit)) ho_spec_simp) A)).
  intros;intro;intros. revert H.
  apply B_mono. apply step_mono. apply T_mono. intro;intros;intro;intro;intros.
  apply ho_subspec. revert H0. apply ho_spec_mono. assumption.
  firstorder. intro;intros. eapply H. apply ho_spec_BT. assumption.
Qed.

Lemma ho_spec_simp_BT : forall A,
    subspec (ho_spec_simp A) (B (step (@cslstep unit)) (T (step (@cslstep unit)) ho_spec_simp) A).
Proof.
  intros;intro;intros.
  eapply SHT_lemma'. apply S_mono. apply ho_spec_mono. apply ho_spec_simp_mono.
  apply step_mono.
  intros. apply subspecST. apply H0.
  apply ho_spec_simp_BT_help. apply S_lemma2. assumption.
Qed.

(* Conclusion: need an S such that *)
(* S <= T and *)
(* ho_spec_simp <= S (ho_spec) *)
(* Proof also relies on ho_spec <= ho_spec_simp *)

(* Print Assumptions ho_spec_simp_BT. *)

Theorem ho_ok_all : sound (@cslstep unit) nonho_spec.
Proof.
  unfold sound. eapply ok with ho_spec_simp. apply ho_spec_simp_mono.
  intros;intro;intros.
  pose proof ho_spec_simp_BT.
  admit.

  intro;intros. inversion H.
  constructor; try assumption. rewrite H0.
  assert ($0 $+ (0,n) = $0 $+ (0,n) $+ (0,n)) by maps_equal.
  rewrite H5. constructor; auto.
Qed.

(* Print Assumptions ho_ok_all. *)