From Ordinal Require Import sflib Basics.
From Ordinal Require Export Ordinal Arithmetic Hessenberg ClassicalOrdinal.

Require Import Coq.Classes.RelationClasses Coq.Classes.Morphisms.

Set Implicit Arguments.
Set Primitive Projections.

(* TODO: find a constructive proof!! *)
Module ClassicJacobsthal.
  Lemma mult_dist o0 o1 o2: Ord.eq (Jacobsthal.mult o0 (Hessenberg.add o1 o2)) (Hessenberg.add (Jacobsthal.mult o0 o1) (Jacobsthal.mult o0 o2)).
  Proof.
    destruct (ClassicOrd.total o0 Ord.O) as [LE|LT].
    { assert (ZERO: Ord.eq o0 Ord.O).
      { split; auto. apply Ord.O_bot. }
      rewrite ZERO. rewrite ! Jacobsthal.mult_O_l. rewrite Hessenberg.add_O_l. reflexivity.
    }
    revert o1 o2.
    eapply (double_well_founded_induction Ord.lt_well_founded Ord.lt_well_founded).
    i. hexploit (ClassicOrd.limit_or_S a1). i. des.
    { hexploit Ord.is_S_unique.
      { eapply H. }
      { eapply Ord.S_is_S. }
      i. rewrite H0. rewrite Hessenberg.add_S_l.
      rewrite Jacobsthal.mult_S. rewrite Jacobsthal.mult_S.
      rewrite IHL.
      { rewrite Hessenberg.add_assoc. reflexivity. }
      { eapply H. }
    }
    hexploit (ClassicOrd.limit_or_S b1). i. des.
    { hexploit Ord.is_S_unique.
      { eapply H1. }
      { eapply Ord.S_is_S. }
      i. rewrite H2. rewrite Hessenberg.add_S_r.
      rewrite Jacobsthal.mult_S. rewrite Jacobsthal.mult_S.
      rewrite IHR.
      { rewrite Hessenberg.add_comm.
        rewrite Hessenberg.add_assoc.
        eapply Hessenberg.eq_add_r.
        eapply Hessenberg.add_comm.
      }
      { eapply H1. }
    }
    hexploit Ord.is_join_unique.
    { eapply H. }
    { eapply Ord.join_is_join. }
    i. rewrite H3.
    hexploit Ord.is_join_unique.
    { eapply H1. }
    { eapply Ord.join_is_join. }
    i. rewrite H4.
    rewrite Jacobsthal.mult_join. rewrite Jacobsthal.mult_join.
    rewrite <- Ord.build_join; auto.
    rewrite <- Ord.build_join; auto.
    symmetry. rewrite <- Ord.build_join.
    2:{ ii. specialize (H0 a0). des. exists a2. eapply Jacobsthal.lt_mult_r; auto. }
    rewrite <- Ord.build_join.
    2:{ ii. specialize (H2 a0). des. exists a2. eapply Jacobsthal.lt_mult_r; auto. }
    rewrite Hessenberg.add_red.
    rewrite Hessenberg.add_red.
    rewrite Jacobsthal.mult_union. eapply Ord.eq_union.
    { rewrite Jacobsthal.mult_build. rewrite Ord.build_join.
      2:{ ii. specialize (H2 a0). des. exists a2. eapply Hessenberg.lt_add_r. eapply Jacobsthal.lt_mult_r; auto. }
      split.
      { eapply Ord.le_join. i. hexploit (H2 a0); auto. i. des.
        exists a2. rewrite (Ord.build_join H0); auto.
        rewrite <- H3. rewrite IHR.
        2:{ rewrite H4. rewrite <- Ord.build_join; auto. eapply Ord.build_upperbound. }
        eapply Ord.S_supremum in H5. rewrite <- H5.
        rewrite Jacobsthal.mult_S. rewrite <- Hessenberg.add_assoc.
        rewrite <- Hessenberg.add_assoc.
        eapply Hessenberg.le_add_l.
        eapply Ord.build_supremum. i.
        eapply Ord.lt_le_lt.
        { apply Jacobsthal.lt_mult_r; auto. eapply Ord.build_upperbound. }
        { rewrite Ord.build_join; auto.
          rewrite <- H3. rewrite Hessenberg.add_comm.
          rewrite <- Hessenberg.add_assoc. eapply Hessenberg.add_base_r.
        }
      }
      { eapply Ord.le_join. i. hexploit (H2 a0); auto. i. des.
        exists a2. rewrite Ord.build_join; auto.
        rewrite <- H3. rewrite IHR.
        2:{ rewrite H4. rewrite <- Ord.build_join; auto. eapply Ord.build_upperbound. }
        eapply Ord.S_supremum in H5. rewrite <- H5.
        rewrite Jacobsthal.mult_S. rewrite <- Hessenberg.add_assoc.
        rewrite <- Hessenberg.add_assoc.
        eapply Hessenberg.le_add_l.
        rewrite Hessenberg.add_comm.
        eapply Hessenberg.le_add_l.
        rewrite H3. rewrite Jacobsthal.mult_join.
        rewrite Ord.build_join; auto.
        2:{ ii. specialize (H0 a3). des. exists a4. apply Jacobsthal.lt_mult_r; auto. }
        reflexivity.
      }
    }
    { rewrite Jacobsthal.mult_build. rewrite Ord.build_join.
      2:{ ii. specialize (H0 a0). des. exists a2. eapply Hessenberg.lt_add_l. eapply Jacobsthal.lt_mult_r; auto. }
      split.
      { eapply Ord.le_join. i. hexploit (H0 a0); auto. i. des.
        exists a2. rewrite (Ord.build_join H2); auto.
        rewrite <- H4. rewrite IHL.
        2:{ rewrite H3. rewrite <- Ord.build_join; auto. eapply Ord.build_upperbound. }
        eapply Ord.S_supremum in H5. rewrite <- H5.
        rewrite Jacobsthal.mult_S. transitivity (Jacobsthal.mult o0 (os a0) ⊕ o0 ⊕ Jacobsthal.mult o0 b1)%ord.
        { eapply Hessenberg.le_add_r.
          eapply Ord.build_supremum. i.
          eapply Ord.lt_le_lt.
          { apply Jacobsthal.lt_mult_r; auto. eapply Ord.build_upperbound. }
          { rewrite Ord.build_join; auto.
            rewrite <- H4. eapply Hessenberg.add_base_r.
          }
        }
        { etransitivity; [|eapply Hessenberg.add_base_r].
          rewrite <- Hessenberg.add_assoc.
          eapply Hessenberg.le_add_l. rewrite Hessenberg.add_comm. reflexivity.
        }
      }
      { eapply Ord.le_join. i. hexploit (H0 a0); auto. i. des.
        exists a2. rewrite Ord.build_join; auto.
        rewrite <- H4. rewrite IHL.
        2:{ rewrite H3. rewrite <- Ord.build_join; auto. eapply Ord.build_upperbound. }
        eapply Ord.S_supremum in H5. rewrite <- H5.
        rewrite Jacobsthal.mult_S. rewrite Hessenberg.add_assoc.
        eapply Hessenberg.le_add_r.
        eapply Hessenberg.le_add_r.
        rewrite H4. rewrite Jacobsthal.mult_join.
        rewrite Ord.build_join; auto.
        2:{ ii. specialize (H2 a3). des. exists a4. apply Jacobsthal.lt_mult_r; auto. }
        reflexivity.
      }
    }
  Qed.

  Lemma mult_assoc o0 o1 o2: Ord.eq (Jacobsthal.mult (Jacobsthal.mult o0 o1) o2) (Jacobsthal.mult o0 (Jacobsthal.mult o1 o2)).
  Proof.
    revert o0 o1. induction o2. i. etransitivity.
    { eapply Jacobsthal.mult_build. } etransitivity.
    2: {
      eapply Jacobsthal.eq_mult_r; auto.
      { symmetry. eapply Jacobsthal.mult_build. }
    }
    etransitivity.
    2: { symmetry. eapply Jacobsthal.mult_join. }
    split.
    { eapply Ord.le_join. i. exists a0.
      etransitivity.
      { eapply Hessenberg.le_add_r. eapply H. }
      { eapply mult_dist. }
    }
    { eapply Ord.le_join. i. exists a0.
      etransitivity.
      { eapply mult_dist. }
      { eapply Hessenberg.le_add_r. eapply H. }
    }
  Qed.
End ClassicJacobsthal.


Require Import Setoid Morphisms RelationClasses Program.Basics.
Require Import ILogic IBILogic BILogic BILInsts ILQuantTac ILInsts Pure ILEmbed.
Require Import Rel SepAlg.

Set Implicit Arguments.
Unset Strict Implicit.
Set Maximal Implicit Insertion.

Section PureBIInsts.
  Context {A} `{sa : SepAlg A}.
  Context {B} `{IL: ILogic B}.
  Context {HPre : PreOrder (@rel A _)}.

  Existing Instance SABIOps.
  Existing Instance SABILogic.
  Existing Instance pureop_bi_sepalg.
  Existing Instance pure_bi_sepalg.
  Existing Instance ILPre_Ops.
  Existing Instance ILPre_ILogic.

  Transparent ILPre_Ops.
  Transparent SABIOps.

  Instance pure_ltrue : pure ltrue.
  Proof.
    intros h h'; reflexivity.
  Qed.

  Instance pure_lfalse : pure lfalse.
  Proof.
    intros h h'; reflexivity.
  Qed.

  Instance pure_land p q (Hp : pure p) (Hq : pure q) : pure (p //\\ q).
  Proof.
    intros h h'; simpl.
    specialize (Hp h h'); specialize (Hq h h').
    rewrite Hp, Hq; reflexivity.
  Qed.

  Instance pure_lor p q (Hp : pure p) (Hq : pure q) : pure (p \\// q).
  Proof.
    intros h h'; simpl.
    specialize (Hp h h'); specialize (Hq h h').
    rewrite Hp, Hq; reflexivity.
  Qed.

  Instance pure_limpl p q (Hp : pure p) (Hq : pure q) : pure (p -->> q).
  Proof.
    intros h h'; simpl.
    apply lforallR; intro h''; apply lforallR; intro H.
    apply lforallL with h. apply lforallL; [reflexivity|].
    specialize (Hp h'' h); specialize (Hq h h'').
    rewrite Hp, Hq; reflexivity.
  Qed.

  Instance pure_lsc p q (Hp : pure p) (Hq : pure q) : pure (p ** q).
  Proof.
    intros h h'; simpl.
    apply lexistsL; intro h''; apply lexistsL; intro h'''; apply lexistsL; intro H.
    destruct (sa_unit_ex h') as [u [Ha H1]].
    apply lexistsR with h'; apply lexistsR with u. apply lexistsR with H1.
    specialize (Hp h'' h'); specialize (Hq h''' u).
    rewrite Hp, Hq; reflexivity.
  Qed.

  Instance pure_lsi p q (Hp : pure p) (Hq : pure q) : pure (p -* q).
  Proof.
    intros h h'; simpl.
    apply lforallR; intro h''; apply lforallR; intro h'''; apply lforallR; intro H.
    destruct (sa_unit_ex h) as [u [Ha H1]].
    apply lforallL with u; apply lforallL with h; apply lforallL with H1.
    specialize (Hp h'' u); specialize (Hq h h''').
    rewrite Hp, Hq; reflexivity.
  Qed.

  Context {C : Type} {ILC : ILogicOps C} {HCOp: EmbedOp C B} {HC: Embed C B}.

  Local Existing Instance EmbedILPreDropOp.
  Local Existing Instance EmbedILPreOp.
  Transparent EmbedILPreDropOp.
  Transparent EmbedILPreOp.

  Instance pure_bi_embed_drop (p : C) : pure (@embed C (ILPreFrm rel B) _ p).
  Proof.
    intros h h'; simpl; reflexivity.
  Qed.

  Instance pure_bi_embed (p : ILPreFrm rel C) (H : pure p) :
    pure (@embed (ILPreFrm rel C) (ILPreFrm rel B) _ p).
  Proof.
    intros h h'; simpl.
    specialize (H h h'). rewrite H. reflexivity.
  Qed.

End PureBIInsts.

Section PureIBIInsts.
  Context {A} `{sa : SepAlg A}.
  Context {B} `{IL: ILogic B}.
  Context {HPre : PreOrder (@rel A _)}.

  Existing Instance SAIBIOps.
  Existing Instance SAIBILogic.
  Existing Instance pureop_pure_ibi_sepalg.
  Existing Instance pure_ibi_sepalg.
  Existing Instance ILPre_Ops.
  Existing Instance ILPre_ILogic.

  Transparent ILPre_Ops.
  Transparent SAIBIOps.

  Instance ibi_pure_ltrue : pure ltrue.
  Proof.
    intros h h'; reflexivity.
  Qed.

  Instance ibi_pure_lfalse : pure lfalse.
  Proof.
    intros h h'; reflexivity.
  Qed.

  Instance ibi_pure_emp : pure empSP.
  Proof.
    intros h h'; simpl; apply ltrueR.
  Qed.

  Instance ibi_pure_land p q (Hp : pure p) (Hq : pure q) : pure (p //\\ q).
  Proof.
    intros h h'; simpl.
    specialize (Hp h h'); specialize (Hq h h').
    rewrite Hp, Hq; reflexivity.
  Qed.

  Instance ibi_pure_lor p q (Hp : pure p) (Hq : pure q) : pure (p \\// q).
  Proof.
    intros h h'; simpl.
    specialize (Hp h h'); specialize (Hq h h').
    rewrite Hp, Hq; reflexivity.
  Qed.

  Instance ibi_pure_limpl p q (Hp : pure p) (Hq : pure q) : pure (p -->> q).
  Proof.
    intros h h'; simpl.
    apply lforallR; intro h''; apply lforallR; intro H.
    apply lforallL with h. apply lforallL; [reflexivity|].
    specialize (Hp h'' h); specialize (Hq h h'').
    rewrite Hp, Hq; reflexivity.
  Qed.

  Instance ibi_pure_lsc p q (Hp : pure p) (Hq : pure q) : pure (p ** q).
  Proof.
    intros h h'; simpl.
    apply lexistsL; intro h''; apply lexistsL; intro h'''; apply lexistsL; intro H.
    destruct (sa_unit_ex h') as [u [Ha H1]].
    apply lexistsR with h'; apply lexistsR with u. apply lexistsR with H1.
    specialize (Hp h'' h'); specialize (Hq h''' u).
    rewrite Hp, Hq; reflexivity.
  Qed.

  Instance ibi_pure_lsi p q (Hp : pure p) (Hq : pure q) : pure (p -* q).
  Proof.
    intros h h'; simpl.
    apply lforallR; intro h''; apply lforallR; intro h'''; apply lforallR; intro H.
    destruct (sa_unit_ex h) as [u [Ha H1]].
    apply lforallL with u; apply lforallL with h; apply lforallL with H1.
    specialize (Hp h'' u); specialize (Hq h h''').
    rewrite Hp, Hq; reflexivity.
  Qed.

  Context {C : Type} {ILC : ILogicOps C} {HCOp: EmbedOp C B} {HC: Embed C B}.

  Local Existing Instance EmbedILPreDropOp.
  Local Existing Instance EmbedILPreOp.

  Transparent EmbedILPreDropOp.
  Transparent EmbedILPreOp.

  Instance pure_ibi_embed_drop (p : C) : pure (@embed C (ILPreFrm subheap B) _ p).
  Proof.
    intros h h'; simpl; reflexivity.
  Qed.

  Instance pure_ibi_embed (p : ILPreFrm subheap C) (H : pure p) :
    pure (@embed (ILPreFrm subheap C) (ILPreFrm subheap B) _ p).
  Proof.
    intros h h'; simpl.
    specialize (H h h'). rewrite H. reflexivity.
  Qed.

End PureIBIInsts.

Section PureEmbedFun.
  Context (T: Type).
  Context {A : Type} `{BIL: BILogic A}.
  Context {HIL : ILogic A}.
  Context {B : Type} {ILX : ILogicOps B} {HBOp: EmbedOp B A} {HB : Embed B A}.
  Context {POA : @PureOp A} {PA : Pure POA}.

  Existing Instance PureBILFunOp.
  Existing Instance PureBILFun.
  Existing Instance ILFun_Ops.
  Existing Instance ILFun_ILogic.
  Existing Instance BILFun_Ops.
  Existing Instance BILFunLogic.
  Existing Instance EmbedILFunDropOp.
  Existing Instance EmbedILFunDrop.
  Existing Instance EmbedILFunOp.
  Existing Instance EmbedILFun.

  Transparent EmbedILFunDropOp.
  Transparent EmbedILFunOp.

  Instance pure_embed_fun_drop (p : B) (H : pure (@embed B A _ p)) :
    pure (@embed B (T -> A) _ p).
  Proof.
    intros t; simpl; apply H.
  Qed.

  Instance pure_embed_fun (p : T -> B) (H : forall t, pure (@embed B A _ (p t))) :
    pure (@embed (T -> B) (T -> A) _ p).
  Proof.
    intros t; simpl; apply H.
  Qed.

End PureEmbedFun.

Section PureEmbedPre.
  Context T (ord: relation T) {HPre: PreOrder ord}.
  Context {A : Type} `{HBI: BILogic A}.
  Context {HIL : ILogic A}.
  Context {B : Type} {ILX : ILogicOps B} {HBOp: EmbedOp B A} {HB : Embed B A}.
  Context {POA : @PureOp A} {PA : Pure POA}.

  Existing Instance PureBILPreOp.
  Existing Instance PureBILPre.
  Existing Instance ILPre_Ops.
  Existing Instance ILPre_ILogic.
  Existing Instance BILPre_Ops.
  Existing Instance BILPreLogic.
  Existing Instance EmbedILPreDropOp.
  Existing Instance EmbedILPreDrop.
  Existing Instance EmbedILPreOp.
  Existing Instance EmbedILPre.

  Instance pure_embed_pre_drop (p : B) (H : pure (@embed B A _ p)) :
    pure (@embed B (ILPreFrm ord A) _ p).
  Proof.
    intros t; simpl; apply H.
  Qed.

  Instance pure_embed_pre (p : ILPreFrm ord B) (H : forall t, pure (@embed B A _ (ILPreFrm_pred p t))) :
    pure (@embed (ILPreFrm ord B) (ILPreFrm ord A) _ p).
  Proof.
    intros t; simpl; apply H.
  Qed.

End PureEmbedPre.


Require Export FinTypes.

Lemma dec_DM_and_iff (X Y : Prop) : dec X -> ~ (X /\ Y) <-> ~ X \/ ~ Y.
  split;[now eapply dec_DM_and|firstorder].
Qed.
Lemma dec_DM_and_iff' (X Y : Prop) : dec Y -> ~ (X /\ Y) <-> ~ X \/ ~ Y.
  split;[now eapply dec_DM_and'|firstorder].
Qed.
Lemma dec_DN_iff (X : Prop) : dec X -> ~ ~ X <-> X.
  split;[now eapply dec_DN|firstorder].
Qed.
Lemma dec_DM_impl_iff (X Y : Prop) : dec X -> dec Y -> ~ (X -> Y) <-> X /\ ~ Y.
  split;[now eapply dec_DM_impl|firstorder].
Qed.

Ltac simpl_dec' H :=
  (first [(setoid_rewrite (DM_notAll _) in H;eauto)|
          (setoid_rewrite (dec_DM_and_iff _ _) in H;eauto)|
          (setoid_rewrite (dec_DM_and_iff' _ _) in H;eauto)|
          setoid_rewrite DM_not_exists in H|
          setoid_rewrite DM_or in H|
          (setoid_rewrite (dec_DN_iff _) in H;eauto)|
          (setoid_rewrite (dec_DM_impl_iff _ _) in H;eauto)]).
Ltac simpl_dec :=
  (try (setoid_rewrite DM_notAll;[|eauto]);
   try (setoid_rewrite (dec_DM_and_iff _ _);[|eauto]);
   try (setoid_rewrite (dec_DM_and_iff' _ _);[|eauto]);
   try setoid_rewrite DM_not_exists;
   try setoid_rewrite DM_or;
   try (setoid_rewrite (dec_DN_iff _);[|eauto]);
   try (setoid_rewrite (dec_DM_impl_iff _ _);eauto)).

(*Ltac collapse H :=
  lazymatch type of H with
  | ?a /\ ?b => let H1 := fresh "H" in
              let H2 := fresh "H" in
              destruct H as [H1 H2];
              collapse H1;
              collapse H2
  | ?a \/ ?b => destruct H as [H|H]; collapse H
  | ~ ?x => simpl_dec' H; collapse H
  | _ => idtac
  end.*)


(* colimits are computed pointwise
 *)

(**
It is the product of modules
Then it induces a morphism
*)
(* TODO : Faire les mêmes choses pour les limites de Modules *)
Require Import UniMath.Foundations.Propositions.
Require Import UniMath.Foundations.Sets.

Require Import UniMath.MoreFoundations.Tactics.

Require Import UniMath.CategoryTheory.Core.Prelude.
Require Import UniMath.CategoryTheory.FunctorCategory.
Require Import UniMath.CategoryTheory.whiskering.
Require Import UniMath.CategoryTheory.limits.graphs.limits.
Require Import UniMath.CategoryTheory.limits.graphs.colimits.
Require Import UniMath.CategoryTheory.Monads.Monads.
Require Import UniMath.CategoryTheory.Monads.LModules.

Require Import Modules.Signatures.Signature.
Require Import Modules.Prelims.LModulesColims.
Require Import Modules.Prelims.CoproductsComplements.

Local Open Scope cat.

(*
Lemma compfNat
   {C : precategory} {g : graph} {d1 d2 d3 : diagram g C}

   {f : ∏ u : vertex g, C ⟦ dob d1 u, dob d2 u ⟧}
  (fNat : ∏ (u v : vertex g) (e : edge u v), dmor d1 e · f v = f u · dmor d2 e)
   {f2 : ∏ u : vertex g, C ⟦ dob d2 u, dob d3 u ⟧}
   (fNat2 : ∏ (u v : vertex g) (e : edge u v), dmor d2 e · f2 v = f2 u · dmor d3 e)
   (f3 := fun u => f u · f2 u)
   :
   ∏ (u v : vertex g) (e : edge u v), dmor d1 e · f3 v = f3 u · dmor d3 e .
  intros u v e.
  etrans;[apply assoc|].
  etrans;[apply cancel_postcomposition; apply fNat|].
  etrans;[|apply assoc].
  etrans;[|apply cancel_precomposition; apply fNat2].
  apply pathsinv0.
  apply assoc.
Qed.
*)
(*
Lemma compColimOfArrows
   (C : precategory) (g : graph) (d1 d2 d3 : diagram g C) (CC1 : ColimCocone d1)
   (CC2 : ColimCocone d2)(CC3 : ColimCocone d3)
   (f : ∏ u : vertex g, C ⟦ dob d1 u, dob d2 u ⟧)
  (fNat : ∏ (u v : vertex g) (e : edge u v), dmor d1 e · f v = f u · dmor d2 e)
   (f2 : ∏ u : vertex g, C ⟦ dob d2 u, dob d3 u ⟧)
  (fNat2 : ∏ (u v : vertex g) (e : edge u v), dmor d2 e · f2 v = f2 u · dmor d3 e)
  (x : C) (cc : cocone d2 x) :
  colimOfArrows CC1 CC2 f fNat · colimOfArrows CC2 CC3 f2 fNat2 =
  colimOfArrows CC1 CC3 (fun z => f z · f2 z) (compfNat  fNat fNat2).
  etrans;[apply precompWithColimOfArrows|].
  cbn.
  unfold colimOfArrows.
  apply maponpaths.
  Abort.
*)
(*

  use map_on_two_paths.
  maponpaths
  apply maponpaths2.

  reflexivity.
.fNat · colimOfArrows CC2 CC3 f2 fNat2 .
  colimOfArrows CC1 CC3 (fun
  colimArrow CC1 x
    (make_cocone (λ u : vertex g, f u · coconeIn cc u)
       (preCompWithColimOfArrows_subproof CC1 CC2 f fNat x cc)).
*)
(* forget ful functor from Modules to functors *)

(* TODO déplacer ça dans Signature.v *)

Section ColimsSig.
  Context
          {C : category}
          {g : graph} (colims_g : Colims_of_shape g C)
          (lims_g : Lims_of_shape g C).
  Let hsC := (homset_property C).
          (* (hsB : has_homsets B) *)
  Let coMod R := (LModule_Colims_of_shape C (B := C) R _ colims_g).
  Let limMod R := (LModule_Lims_of_shape C (B := C) R _ lims_g).

  (* Local Notation limMod := (LModule_Lims_of_shape _ B _ hsC colims_g). *)
  (* Local Notation coFunc := (ColimsFunctorCategory_of_shape _ B _ hsC colims_g). *)
  (* Local Notation limFunc := (LimsFunctorCategory_of_shape _ B _ hsC lims_g). *)
  (* Local Notation bpFunct := *)
  (*   (BinProducts_functor_precat B C bpC hsC (M : functor _ _) (N : functor _ _)). *)

  (* Definition LModule_colim_functor : functor _ _ := *)
  (*   BinProductObject  _ bpFunct. *)
  Local Notation MOD R := (precategory_LModule R C).
  Local Notation HAR := (signature_precategory (C:=C)).
  Variable (d : diagram g HAR).
  (* TODO generalize this kind of construction : composition of a diagram and a functor
(here the forget ful functor MOD --> [B , C])
   *)
  Let FORGET R := (forget_Sig (C:=C) R ).
  Let d' R := (  mapdiagram (FORGET R) d : diagram g (MOD R) ).
  (* The natural candidate *)
  Let  F R := (colim (coMod _ (d' R)) : LModule _ _).
  Let  F' R := (lim (limMod _ (d' R)) : LModule _ _).
  (* Local Notation BP := (binproduct_functor bpC). *)

  (* Is there a lemma that state the existence of a natural transformation
  (A x B) o R --> A o R x B o R  ? *)
  (* TODO define it without nat_trans *)
  Definition Sig_colim_on_mor (R S : Monad C) (f : Monad_Mor R S) :
    LModule_Mor _ (F R) (pb_LModule f (F S)).
  Proof.
  eapply (compose (C:= MOD _)); [| apply pb_LModule_colim_iso].
  use  colimOfArrows.
  - intro u.
    exact ((#(dob d u : signature _))%ar f).
  - abstract (intros u v e;
    apply LModule_Mor_equiv;[apply homset_property|];
    apply pathsinv0;
    apply signature_Mor_ax).
  Defined.

  Definition Sig_lim_on_mor (R S : Monad C) (f : Monad_Mor R S) :
    LModule_Mor _ (F' R) (pb_LModule f (F' S)).
  Proof.
  eapply (compose (C:= MOD _)); [| apply pb_LModule_lim_iso].
  use  limOfArrows.
  - intro u.
    exact ((#(dob d u : signature _))%ar f).
  - abstract(intros u v e;
    apply LModule_Mor_equiv;[apply homset_property|];
    apply signature_Mor_ax).
  Defined.

  Definition Sig_colim_signature_data : signature_data := _ ,, Sig_colim_on_mor.
  Definition Sig_lim_signature_data : signature_data := _ ,, Sig_lim_on_mor.

  Lemma Sig_colim_is_signature : is_signature Sig_colim_signature_data.
  Proof.
    split.
    - intros R c.
      apply pathsinv0.
      apply colim_endo_is_identity.
      intro u.
      cbn.
      rewrite id_right.
      set (cc := colims_g _).
      etrans;[apply (colimArrowCommutes  cc)|].
      cbn.
      etrans;[|apply id_left].
      apply cancel_postcomposition.
      apply signature_id.
    - intros U V W m n.
      apply LModule_Mor_equiv;[apply homset_property|].
      apply nat_trans_eq;[apply homset_property|].
      intro c.
      cbn.
      repeat rewrite id_right.
      apply pathsinv0.
      apply colimArrowUnique.
      intro u.
      cbn.
      etrans.
      {
        etrans;[apply assoc|].
        apply cancel_postcomposition.
        set (cc := colims_g _).
        apply (colimArrowCommutes cc).
      }
      cbn.
      etrans.
      {
        cbn.
        rewrite <- assoc.
        apply cancel_precomposition.
        set (cc := colims_g _).
        apply (colimArrowCommutes cc).
        }
      cbn.
      rewrite assoc.
      apply cancel_postcomposition.
      apply pathsinv0.
      etrans.
      {
      assert (h := signature_comp (dob d u) m n).
      eapply LModule_Mor_equiv in h; try apply homset_property.
      eapply nat_trans_eq_pointwise in h.
      apply h.
      }
      cbn.
      now rewrite id_right.
  Qed.
  Lemma Sig_lim_is_signature : is_signature Sig_lim_signature_data.
  Proof.
    split.
    - intros R c.
      apply pathsinv0.
      apply lim_endo_is_identity.
      intro u.
      cbn.
      rewrite id_right.
      set (cc := lims_g _).
      etrans;[apply (limArrowCommutes  cc)|].
      cbn.
      etrans;[|apply id_right].
      apply cancel_precomposition.
      apply signature_id.
    - intros U V W m n.
      apply LModule_Mor_equiv;[apply homset_property|].
      apply nat_trans_eq;[apply homset_property|].
      intro c.
      cbn.
      repeat rewrite id_right.
      apply pathsinv0.
      apply limArrowUnique.
      intro u.
      cbn.
      etrans.
      {
        rewrite <- assoc.
        (* etrans;[apply assoc|]. *)
        apply cancel_precomposition.
        set (cc := lims_g _).
        apply (limArrowCommutes cc).
      }
      cbn.
      etrans.
      {
        cbn.
        rewrite assoc.
        apply cancel_postcomposition.
        set (cc := lims_g _).
        apply (limArrowCommutes cc).
        }
      cbn.
      rewrite <- assoc.
      apply cancel_precomposition.
      apply pathsinv0.
      etrans.
      {
      assert (h := signature_comp (dob d u) m n).
      eapply LModule_Mor_equiv in h; try apply homset_property.
      eapply nat_trans_eq_pointwise in h.
      apply h.
      }
      cbn.
      now rewrite id_right.
  Qed.

  Definition Sig_colim : signature _ :=
    _ ,, Sig_colim_is_signature.

  Definition Sig_lim : signature _ :=
    _ ,, Sig_lim_is_signature.

  Lemma Sig_coconeIn_laws v :
    is_signature_Mor
                      (dob d v : signature  _)  Sig_colim
      (fun R => (coconeIn (colimCocone (coMod R (d' R))) v   )).
  Proof.
    intros X Y f.
    (* not necessary but more convenienet *)
    apply nat_trans_eq;[apply homset_property|].
    intro x.
    cbn.
    rewrite id_right.
    set (cc1 := colims_g _).
    set (cc2 := colims_g _).
    apply pathsinv0.
    cbn.
    apply (colimArrowCommutes cc2).
  Qed.
  Lemma Sig_coneOut_laws v :
    is_signature_Mor
                  Sig_lim    (dob d v : signature  _)
      (fun R => (coneOut (limCone (limMod R (d' R))) v   )).
  Proof.
    intros X Y f.
    (* not necessary but more convenienet *)
    apply nat_trans_eq;[apply homset_property|].
    intro x.
    cbn.
    rewrite id_right.
    set (cc1 := lims_g _).
    set (cc2 := lims_g _).
    cbn.
    apply (limArrowCommutes cc1).
  Qed.

  Definition Sig_coconeIn v : signature_precategory ⟦ dob d v, Sig_colim ⟧ :=
    _ ,, Sig_coconeIn_laws v.

  Definition Sig_coneOut v : signature_precategory ⟦ Sig_lim, dob d v ⟧ :=
    _ ,, Sig_coneOut_laws v.

  Lemma Sig_coconeIn_commutes (u v : vertex g) (e : edge u v) :
    dmor d e · Sig_coconeIn v = Sig_coconeIn u.
  Proof.
    apply signature_Mor_eq.
    intro R.
    apply (coconeInCommutes (colimCocone (coMod R (d' R)))).
  Defined.
  Lemma Sig_coneOut_commutes (u v : vertex g) (e : edge u v) :
      Sig_coneOut u · dmor d e = Sig_coneOut v.
  Proof.
    apply signature_Mor_eq.
    intro R.
    apply (coneOutCommutes (limCone (limMod _ (d' R)))).
  Defined.

  Definition Sig_colim_cocone : cocone d Sig_colim :=
    make_cocone Sig_coconeIn Sig_coconeIn_commutes.

  Definition Sig_lim_cone : cone d Sig_lim :=
    make_cone Sig_coneOut Sig_coneOut_commutes.

  Lemma Sig_colimArrow_laws {M : signature C} (cc : cocone d M) :
    is_signature_Mor
       (  Sig_colim) (M)
      (fun R => colimArrow  (coMod R (d' R)) (M R) (mapcocone (FORGET R) d cc)  ).
  Proof.
    intros R S f.
    apply nat_trans_eq;[apply homset_property|].
    intro c.
    cbn.
    repeat rewrite id_right.
    apply pathsinv0.
    etrans;[apply postcompWithColimArrow|].
    apply pathsinv0.
    apply colimArrowUnique.
    intro u.
    cbn.
    etrans.
    {
      rewrite assoc.
      apply cancel_postcomposition.
      set (cc1 := colims_g _).
      apply (colimArrowCommutes cc1).
    }
    cbn.
    etrans.
    {
      rewrite <- assoc.
      apply cancel_precomposition.
      set (cc1 := colims_g _).
      apply (colimArrowCommutes cc1).
    }
    cbn.
    apply signature_Mor_ax_pw.
  Qed.
  Lemma Sig_limArrow_laws {M : signature C} (cc : cone d M) :
    is_signature_Mor
      M  (  Sig_lim)
      (fun R => limArrow  (limMod R (d' R)) (M R) (mapcone (FORGET R) d cc)  ).
  Proof.
    intros R S f.
    apply nat_trans_eq;[apply homset_property|].
    intro c.
    cbn.
    repeat rewrite id_right.
    apply pathsinv0.
    etrans;[apply postCompWithLimArrow|].
    apply pathsinv0.
    apply limArrowUnique.
    intro u.
    cbn.
    etrans.
    {
      rewrite <- assoc.
      apply cancel_precomposition.
      set (cc1 := lims_g _).
      apply (limArrowCommutes cc1).
    }
    cbn.
    apply pathsinv0.
    etrans.
    {
      rewrite assoc.
      apply cancel_postcomposition.
      set (cc1 := lims_g _).
      apply (limArrowCommutes cc1).
    }
    cbn.
    apply pathsinv0.
    apply signature_Mor_ax_pw.
  Qed.

  Definition Sig_colimArrow {M : signature _} (cc : cocone d M) :
    signature_Mor  Sig_colim M := _ ,, Sig_colimArrow_laws  cc.

  Definition Sig_limArrow {M : signature C} (cc : cone d M) :
    signature_Mor  M Sig_lim := _ ,, Sig_limArrow_laws  cc.

  Lemma Sig_isColimCocone : isColimCocone _ _ Sig_colim_cocone.
    intros M cc.
    use unique_exists.
    - exact (Sig_colimArrow cc).
    - intro v.
      apply signature_Mor_eq.
      intro R.
      apply (colimArrowCommutes (coMod _ (d' R))).
    - intro y.
      cbn -[isaprop].
      apply  impred_isaprop.
      intro u.
      use signature_category_has_homsets.
    - intros y h.
      apply signature_Mor_eq.
      intro R.
      apply (colimArrowUnique (coMod _ (d' R))).
      intro u.
      apply (  maponpaths (fun z => pr1 z R) (h u)).
  Defined.
  Lemma Sig_isLimCone : isLimCone _ _ Sig_lim_cone.
    intros M cc.
    use unique_exists.
    - exact (Sig_limArrow cc).
    - intro v.
      apply signature_Mor_eq.
      intro R.
      apply (limArrowCommutes (limMod _ (d' R))).
    - intro y.
      cbn -[isaprop].
      apply  impred_isaprop.
      intro u.
      use signature_category_has_homsets.
    - intros y h.
      apply signature_Mor_eq.
      intro R.
      apply (limArrowUnique (limMod _ (d' R))).
      intro u.
      apply (  maponpaths (fun z => pr1 z R) (h u)).
  Defined.

  Definition Sig_ColimCocone : ColimCocone d :=
    make_ColimCocone  _ _ _  Sig_isColimCocone.

  Definition Sig_LimCone : LimCone d :=
    make_LimCone  _ _ _  Sig_isLimCone.

End ColimsSig.

Definition Sig_Colims_of_shape {C : category}
           (g : graph)
           (colims_g : Colims_of_shape g C)
            : Colims_of_shape g (signature_category) :=
   Sig_ColimCocone  (C:= C) (g := g) colims_g.
Definition Sig_Lims_of_shape {C : category}
           (g : graph)
           (lims_g : Lims_of_shape g C)
            : Lims_of_shape g (signature_precategory) :=
   Sig_LimCone  (C:= C) (g := g) lims_g.


Require Import Brenner.
Import Syntax.CST.

(** * An example *)

Definition t1 := 1.
Definition td := 2.
Definition ph1 := 1.
Parameter bf : prog.

Definition bl := t1 <- NEW_TID;; REG(ph1, t1);; FORK(t1, bf);; END.
Definition bd := LOOP(bl) ;; DEREG(ph1);; END.
Definition b := ph1 <- NEW_PHASER;; bd.
Definition s1_tm := TaskMap.add td b TaskMap.make.

(** Initializes an abstract state from a program. *)
Definition s1 := load td b.

(** Performs the first reduction step that creates a phaser. *)
Definition s2_td := bd.
Definition s2_tm := add td s2_td s1_tm.
Definition s2_pm := PhaserMap.eval PhaserMap.make td (PhaserMap.NEW ph1).
Definition s2 :state := (s2_pm, s2_tm).
Lemma td_In_s1_tm : TaskMap.MapsTo td b s1_tm.
  assert (H: TID.eq td td) by apply (TID.eq_refl td).
  apply Map_TID.add_1; auto.
Qed.

Goal Reduces s1 s2.
  eauto using r_phaser, PhaserMap.make, s1_tm, td_In_s1_tm.
Qed.

Definition s3_td := t1 <- NEW_TID;; REG(ph1, t1);; FORK(t1, bf);; bd.
Definition s3_tm := TaskMap.add td s3_td s2_tm.
Definition s3_pm := s2_pm.
Definition s3 :state := (s3_pm, s3_tm).

(** The next reduction step is to unfold the loop. *)
Goal Reduces s2 s3.
  apply r_cflow with (c:=loop bl) (p:=DEREG(ph1);; END).
  - unfold s2_tm.
    unfold s2_td.
    unfold bd.
    apply Map_TID.add_1; auto using TID.eq_refl.
  - eapply ControlFlow.r_iter; eauto.
Qed.


(********** Syntax of the contract language **********)

Require Export Reals.
Require Export Utils.
Require Export Equalities.

(* The types of assets and parties are kept abstract. They should at
least be decicable, though. *)

Parameter Asset : Set.
Parameter Party : Set.

Module Asset.
  Parameter eqb : Asset -> Asset -> bool.
  Axiom eqb_eq : forall x y, eqb x y = true <-> x = y.

  Lemma eqb_refl p:  eqb p p = true.
  Proof.
    assert (p = p) as E by reflexivity. rewrite <- eqb_eq in E. auto.
  Qed.

End Asset.

Module Party.
  Parameter eqb : Party -> Party -> bool.
  Axiom eqb_eq : forall x y, eqb x y = true <-> x = y.
  Lemma eqb_refl p:  eqb p p = true.
  Proof.
    assert (p = p) as E by reflexivity. rewrite <- eqb_eq in E. auto.
  Qed.

End Party.

(* We also keep the types for Boolean and real observable labels
abstract. *)

Parameter BoolObs : Set.
Parameter RealObs : Set.

(* The type of variables. *)

Inductive Var : Set := V1 | VS (v:Var).

(* The type of labels that describe external observables. *)

Inductive ObsLabel : Set := LabR (l:RealObs) | LabB (l:BoolObs).

(* The type of operations that may be used in expressions. *)

Inductive Op : Set := Add | Sub | Mult | Div | And | Or | Less | Leq | Equal |
                      Not | Neg |
                      BLit (b : bool) | RLit (r:R) |
                      Cond.

(* The type of expressions. *)

Inductive Exp : Set := OpE (op : Op) (args : list Exp)
                     | Obs (l:ObsLabel) (i: Z)
                     | VarE (v:Var)
                     | Acc (f : Exp) (d : nat) (e : Exp).

(* We need to define a custom induction principle for expressions. The
automatically generated induction principle is too weak. *)

Definition Exp_ind'   : forall P : Exp -> Prop,
       (forall (op : Op) (args : list Exp), all P args -> P (OpE op args)) ->
       (forall (l : ObsLabel) (i : Z), P (Obs l i)) ->
       (forall v : Var, P (VarE v)) ->
       (forall f2 : Exp,
        P f2 -> forall (d : nat) (e : Exp), P e -> P (Acc f2 d e)) ->
       forall e : Exp, P e :=
fun (P : Exp -> Prop)
  (f : forall (op : Op) (args : list Exp), all P args -> P (OpE op args))
  (f0 : forall (l : ObsLabel) (i : Z), P (Obs l i))
  (f1 : forall v : Var, P (VarE v))
  (f2 : forall f2 : Exp,
        P f2 -> forall (d : nat) (e : Exp), P e -> P (Acc f2 d e)) =>
fix F (e : Exp) : P e :=
  match e as e0 return (P e0) with
  | OpE op args => let fix step es : all P es :=
                       match es with
                           | nil => forall_nil P
                           | e' :: es' => forall_cons P (F e') (step es')
                       end
                   in  f op args (step args)
  | Obs l i => f0 l i
  | VarE v => f1 v
  | Acc f3 d e0 => f2 f3 (F f3) d e0 (F e0)
  end.

(* This type defines the syntax of the contract language *)

Inductive Contr : Type :=
 | Zero : Contr
 | Let : Exp -> Contr -> Contr
 | Transfer : Party -> Party -> Asset -> Contr
 | Scale : Exp -> Contr -> Contr
 | Translate : nat -> Contr -> Contr
 | Both : Contr -> Contr -> Contr
 | If : Exp -> nat -> Contr -> Contr -> Contr.


Require Import msl.msl_standard.
Require Import Maps.

(*** Machine specification ***)

(** Abstract syntax of machine code **)

Definition var: Set := positive.
Definition var_eq: forall (v1 v2: var), {v1=v2} + {v1<>v2} := peq.
Definition V (n: nat) : var := P_of_succ_nat n.

Definition label: Set := positive.
Definition label_eq: forall (l1 l2: label), {l1=l2} + {l1<>l2} := peq.
Definition L (n: nat) : label := P_of_succ_nat n.

Section instr_def.
  Variable X:Type.

  Inductive instr : Type :=
  | instr_assert : X -> instr

  | instr_getlabel: label -> var -> instr
  | instr_fetch_field: var -> nat -> var -> instr
  | instr_cons: var -> var -> var -> instr

  | instr_seq: instr -> instr -> instr
  | instr_if_nil : var -> instr -> instr -> instr
  | instr_call: var -> instr
  | instr_return: instr.

(*  | instr_nil : instr.*)
End instr_def.

Implicit Arguments instr_assert [X].
Implicit Arguments instr_getlabel [X].
Implicit Arguments instr_fetch_field [X].
Implicit Arguments instr_cons [X].
Implicit Arguments instr_seq [X].
Implicit Arguments instr_if_nil [X].
Implicit Arguments instr_call [X].
Implicit Arguments instr_return [X].

Fixpoint fmap_instr {A B} (f:A->B) (x:instr A) : instr B :=
  match x with
  | instr_assert a => instr_assert (f a)
  | instr_getlabel l v => instr_getlabel l v
  | instr_fetch_field v1 n v2 => instr_fetch_field v1 n v2
  | instr_cons v1 v2 v3 => instr_cons v1 v2 v3
  | instr_seq i1 i2 => instr_seq (fmap_instr f i1) (fmap_instr f i2)
  | instr_if_nil v i1 i2 => instr_if_nil v (fmap_instr f i1) (fmap_instr f i2)
  | instr_call v => instr_call v
  | instr_return => instr_return
(*  | instr_nil => instr_nil _*)
  end.

(** Run-time values and environments **)

Inductive value: Set :=
  | value_label: label -> value
  | value_cons: value -> value -> value.

Definition store := map value.
Definition store_empty : store := empty value.

Definition program X := map (instr X).

Module KnotInput <: KNOT_INPUT__HERED_PROP_OTH.
  Definition F := program.

  Definition fmap A B (f:A->B) := map_fmap _ _ (fmap_instr f).
  Implicit Arguments fmap [A B].

  Lemma fmap_id : forall A, fmap (id A) = id (F A).
  Proof.
    intros; unfold fmap.
    extensionality x.
    induction x; simpl; auto.
    destruct o; unfold id; f_equal; auto.
    f_equal.
    induction i; simpl; auto; congruence.
  Qed.

  Lemma fmap_comp : forall A B C (f:B -> C) (g:A -> B),
    fmap f oo fmap g = fmap (f oo g).
  Proof.
    unfold fmap, compose; intros; extensionality x.
    induction x; simpl; auto.
    destruct o; unfold id; f_equal; auto.
    f_equal.
    induction i; simpl; auto; congruence.
  Qed.

  Definition other := store.
End KnotInput.

Module K <: KNOT__HERED_PROP_OTH := Knot_HeredPropOth(KnotInput).
Import K.

Definition prog := K.knot.
Definition world := (prog * store)%type.
Definition assert := pred world.

Definition instruction := instr assert.
Definition stack := list instruction.

Infix ";;" := instr_seq (at level 60, right associativity).

Definition prog_lookup (p:prog) (l:label) : option instruction :=
  get _ (snd (unsquash p)) l.

(** Execution of machine code **)

Inductive step : prog -> prog -> store -> stack -> store -> stack -> Prop :=

  | step_assert : forall p r i stk (P:assert),
      P (p,r) ->
    (*----------------------------------------------------*)
      step p p r ((instr_assert P ;; i) :: stk) r (i :: stk)

  | step_getlabel: forall p r l v i stk,
    (*----------------------------------------------------*)
      step p p r ((instr_getlabel l v ;; i) :: stk) (r#v <- (value_label l)) (i :: stk)

  | step_fetch_field_0: forall p r v1 v2 i a0 a1 stk,
      r#v1 = Some (value_cons a0 a1) ->
    (*----------------------------------------------------*)
      step p p r ((instr_fetch_field v1 0 v2 ;; i) :: stk) (r#v2 <- a0) (i :: stk)

  | step_fetch_field_1: forall p r v1 v2 i a0 a1 stk,
      r#v1 = Some (value_cons a0 a1) ->
    (*----------------------------------------------------*)
      step p p r ((instr_fetch_field v1 1 v2 ;; i) :: stk) (r#v2 <- a1) (i :: stk)

  | step_cons: forall p r v1 v2 v3 i a1 a2 stk,
      r#v1 = Some a1 ->
      r#v2 = Some a2 ->
    (*----------------------------------------------------*)
      step p p r ((instr_cons v1 v2 v3 ;; i) :: stk) (r#v3 <- (value_cons a1 a2)) (i :: stk)

  | step_seq: forall p r i1 i2 i3 stk,
    (*----------------------------------------------------*)
      step p p r (((i1 ;; i2) ;; i3) :: stk) r ((i1 ;; i2 ;; i3) :: stk)

  | step_if_nil1 : forall p r v i1 i2 i stk,
      r#v = Some (value_label (L 0)) ->
    (*----------------------------------------------------*)
      step p p r ((instr_if_nil v i1 i2 ;; i) :: stk) r ((i1 ;; i) :: stk)

  | step_if_nil2 : forall p r v i1 i2 i a1 a2 stk,
      r#v = Some (value_cons a1 a2) ->
    (*----------------------------------------------------*)
      step p p r ((instr_if_nil v i1 i2 ;; i) :: stk) r ((i2 ;; i) :: stk)

  | step_call : forall p p' r v l i i' stk,
      r#v = Some (value_label l) ->
      prog_lookup p l = Some i' ->
      age p p' ->
    (*----------------------------------------------------*)
      step p p' r ((instr_call v ;; i) :: stk) r ((i' ;; instr_assert FF) :: i :: stk)

  | step_return : forall p r stk i,
    (*----------------------------------------------------*)
      step p p r ((instr_return ;; i) :: stk) r stk.

(* Safety property *)

Inductive stepstar : prog -> prog -> store -> stack -> store -> stack ->  Prop :=
 | stepstar_O: forall s i p, stepstar p p s i s i
 | stepstar_S: forall p p' p'' s i s' i' s'' i'',
              step p p' s i s' i' -> stepstar p' p'' s' i' s'' i'' -> stepstar p p'' s i s'' i''.

Inductive step_or_halt : prog -> store -> stack -> Prop :=
  | step_or_halt_step: forall p p' r i r' i',
      step p p' r i r' i' -> step_or_halt p r i
  | step_or_halt_halt: forall p r,
      step_or_halt p r nil.

Definition safe (p: prog) (s: store) (k: stack) :=
   forall p' s' k', stepstar p p' s k s' k' -> step_or_halt p' s' k'.

Definition safe_prog (p: program assert) (l:label) :=
  exists i, p#l = Some i /\
    forall n s, safe (K.squash (n,p)) s (i::nil).

Definition eventually_halts (p:prog) (r:store) (s:stack) : Prop :=
  exists p', exists r', stepstar p p' r s r' nil.

Definition eventually_halts_n (n : nat) (p:prog) (r:store) (s:stack) : Prop :=
  exists p', exists r', (level p - level p' <= n) /\ stepstar p p' r s r' nil.

(*****)
(* Other Stuff *)

Inductive stepN : nat -> prog -> prog -> store -> stack -> store -> stack ->  Prop :=
 | stepN_O: forall p s i, stepN O p p s i s i
 | stepN_S: forall n s i p p' p'' s' i' s'' i'',
              step p p' s i s' i' -> stepN n p' p'' s' i' s'' i'' -> stepN (S n) p p'' s i s'' i''.

Lemma stepstar_stepN : forall p p' s i s' i',
  stepstar p p' s i s' i' ->
  exists n, stepN n p p' s i s' i'.
Proof.
  intros p p' s i s' i' H; induction H.
  exists 0; apply stepN_O.
  destruct IHstepstar as [n Hn].
  exists (S n).
  eapply stepN_S.
  apply H.
  apply Hn.
Qed.

Lemma stepN_stepstar : forall p p' n s i s' i',
  stepN n p p' s i s' i' ->
  stepstar p p' s i s' i'.
Proof.
  intros p p' n s i s' i' H; induction H.
  apply stepstar_O.
  eapply stepstar_S.
  apply H.
  apply IHstepN.
Qed.

Lemma step_deterministic : forall p p1 p2 s i s1 s2 i1 i2,
  step p p1 s i s1 i1 ->
  step p p2 s i s2 i2 ->
  s1 = s2 /\ i1 = i2 /\ p1 = p2.
Proof.
  intros p p1 p2 s i s1 s2 i1 i2 H1 H2.
  inversion H1; subst; inversion H2; subst; unfold age in *;
    try intuition congruence.
Qed.

Lemma step_confluent : forall p p1 p2 p' n s s1 s2 s' i i1 i2 i',
  step p p1 s i s1 i1 ->
  step p p2 s i s2 i2 ->
  stepN n p1 p' s1 i1 s' i' ->
  stepN n p2 p' s2 i2 s' i'.
Proof.
 intros p p1 p2 p' n s s1 s2 s' i i1 i2 i' H1 H2 H3.
 generalize (step_deterministic _ _ _ _ _ _ _ _ _ H1 H2).
 intuition; subst; auto.
Qed.

Lemma step_triangle : forall n1 n2 p p1 p2 s s1 s2 i i1 i2,
  n1 <= n2 ->
  stepN n1 p p1 s i s1 i1 ->
  stepN n2 p p2 s i s2 i2 ->
  stepN (n2 - n1) p1 p2 s1 i1 s2 i2.
Proof.
  intros n1; induction n1; simpl; intros.
  inversion H0; subst; clear H0.
  replace (n2 -0) with n2; [ auto | omega ].
  inversion H0; subst; clear H0.
  destruct n2; simpl in *.
  inversion H.
  eapply IHn1.
  omega.
  apply H4.
  inversion H1; subst; clear H1.
  destruct (step_deterministic p p' p'0 s i s' s'0 i' i'0) as [? [? ?]]; auto.
  subst; auto.
Qed.


Require Import Unicode.Utf8 ssreflect.
Require Import micromega.Lia.

Set Primitive Projections.

Record iso (A B : Type) :=
  {intro : A → B;
   elim : B → A;
   eta : ∀ x, intro (elim x) = x;
   beta : ∀ x, elim (intro x) = x}.

Arguments intro [_] [_] _.
Arguments elim [_] [_] _.

Record product (A B : Type) :=
  {π1 : A;
   π2 : B}.

Arguments Build_product [_] [_] _ _.
Arguments π1 [_] [_] _.
Arguments π2 [_] [_] _.

Infix "≅" := iso (at level 100).
Notation "◻" := Type.
Notation "f ∘ g" := (λ x, f (g x)) (at level 10).

Axiom later : Type → Type.
Notation "▶ A" := (later A) (at level 60).

Axiom dlater : ▶ Prop → Prop.
Notation "⟨▷⟩ A" := (dlater A) (at level 60).

Axiom plater : Prop → Prop.
Notation "▷ A" := (plater A) (at level 60).

Axiom next : ∀ {A}, A → ▶ A.
Axiom pnext : ∀ {P : Prop}, P → ▷ P.
Notation "next: x" := (next x) (at level 100).

Axiom loeb : ∀ {A}, (▶ A → A) → A.
Axiom ploeb : ∀ {A : Prop}, (▷ A → A) → A.
Notation "fix: x ; e" := (loeb (λ x, e)) (at level 100).
Axiom loeb_unfold : ∀ {A f}, @loeb A f = f (next (loeb f)).

Module Later.
  Axiom from_eq : ∀ {A} (a b : A), ▷ (a = b) → next a = next b.
  Axiom to_eq : ∀ {A} (a b : A), next a = next b → ▷ (a = b).
  Axiom ap : ∀ {A B}, later (A → B) → later A → later B.
  Axiom pap : ∀ {A B : Prop}, plater (A → B) → plater A → plater B.

  Axiom dlater_compute : ∀ A, ⟨▷⟩ (next A) = ▷ A.

  Module ApNotation.
    Infix "⊛" := ap (at level 50).
    Infix "⊛p" := pap (at level 50).
  End ApNotation.

  Import ApNotation.

  Axiom ap_compute : ∀ {A B} (f : A → B) (x : A), next f ⊛ next x = next (f x).

  Definition map {A B} : (A → B) → later A → later B :=
    fun f x => next f ⊛ x.

  Definition pmap {A B : Prop} : (A → B) → plater A → plater B :=
    fun f x => pnext f ⊛p x.
End Later.

Export Later.ApNotation.
Infix "<$>" := Later.map (at level 50).

Fixpoint boom n :=
  ▷ match n with
    | 0 => False
    | S n => boom n
    end.

Notation "n ⊩ P" := (boom n → P) (at level 100).

Lemma boom_suc : ∀ n, boom n → boom (S n).
Proof.
  move=> n.
  apply: pnext.
Qed.

Lemma boom_leq : ∀ m n, m ≤ n → boom m → boom n.
Proof.
  move=> m; elim.
  - move=> ?.
    replace m with 0; first by auto.
    by lia.
  - move=> n ih p z.
    compare m (S n).
    + by move=> <- .
    + move=> q.
      apply: pnext; apply: ih; last by auto.
      by lia.
Defined.