(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)

(** * Initialization code for typeclasses, setting up the default tactic
   for instance search.

   Author: Matthieu Sozeau
   Institution: LRI, CNRS UMR 8623 - University Paris Sud
*)

(** Hints for the proof search: these combinators should be considered rigid. *)

Require Import Coq.Program.Basics.

Typeclasses Opaque id const flip compose arrow impl iff not all.

(** Apply using the same opacity information as typeclass proof search. *)

Ltac class_apply c := autoapply c using typeclass_instances.

(** The unconvertible typeclass, to test that two objects of the same type are
   actually different. *)

Class Unconvertible (A : Type) (a b : A) := unconvertible : unit.

Ltac unconvertible :=
  match goal with
    | |- @Unconvertible _ ?x ?y => unify x y with typeclass_instances ; fail 1 "Convertible"
    | |- _ => exact tt
  end.

Hint Extern 0 (@Unconvertible _ _ _) => unconvertible : typeclass_instances.


Require SN_ECC_Real.
Import ZF ZFsum ZFnats ZFrelations ZFord ZFfix.
Require Import ZFfunext ZFcoc ZFuniv_real.
Import Sat.
Import SN_ECC_Real.

(********************************************************************************)
(** Occurrences *)

Module B := VarMap.Bool.

  (* Non-occurrence : interp do not depend on variables in set [f] *)
  Definition noccur (f:B.map) (T:term) : Prop :=
    forall i i',
    (forall n, if f n then True else i n == i' n) ->
    int T i == int T i'.

  Lemma noc_var : forall f n, f n = false -> noccur f (Ref n).
red; simpl; intros.
specialize (H0 n).
rewrite H in H0; trivial.
Qed.

  Lemma noc_kind : forall f, noccur f kind.
red; simpl; reflexivity.
Qed.

  Lemma noc_prop : forall f, noccur f prop.
red; simpl; reflexivity.
Qed.

  Lemma noc_app : forall f a b,
    noccur f a -> noccur f b -> noccur f (App a b).
unfold noccur; simpl; intros.
rewrite (H _ _ H1).
rewrite (H0 _ _ H1).
reflexivity.
Qed.

(********************************************************************************)
(** Judgements with variance *)

Module OTeq.
Definition t := option term.
Definition eq := @eq (option term).
Definition eq_equiv : Equivalence eq := eq_equivalence.
Existing Instance eq_equiv.
End OTeq.
Module OT := VarMap.Make(OTeq).

(* Environments with tags on ordinal and recursive function variables *)
Record fenv := {
  tenv : env;
  ords : B.map; (* variables denoting ordinals *)
  fixs : OT.map (* variables denoting recursive functions with their domain *)
}.

Definition tinj e :=
  Build_fenv e (B.nil false) (OT.nil None).

Definition push_var e T :=
  Build_fenv (T::tenv e) (B.cons false (ords e)) (OT.cons None (fixs e)).

Definition push_fun e dom rng :=
  Build_fenv (Prod dom rng::tenv e)
    (B.cons false (ords e)) (OT.cons (Some dom) (fixs e)).

Definition push_ord e T :=
  Build_fenv (T::tenv e) (B.cons true (ords e)) (OT.cons None (fixs e)).

(* Additional judgments for fix body *)
Definition val_mono (e:fenv) i j i' j' :=
    val_ok (tenv e) i j /\
    val_ok (tenv e) i' j' /\
    forall n,
    if ords e n then i n ⊆ i' n
    else match fixs e n with
      Some T => forall x, x ∈ El(int T (V.shift (S n) i)) -> app (i n) x == app (i' n) x
    | _ => i n == i' n
    end.

Lemma val_mono_refl : forall e i j,
  val_ok (tenv e) i j -> val_mono e i j i j.
split;[idtac|split]; simpl; auto with *.
intro n.
destruct (ords e n); auto with *.
destruct (fixs e n); auto with *.
Qed.

Lemma val_push_var : forall e i j i' j' x t x' t' T,
  val_mono e i j i' j' ->
  x == x' ->
  [x,t] \real int T i ->
  [x',t'] \real int T i' ->
  T <> kind ->
  val_mono (push_var e T) (V.cons x i) (I.cons t j) (V.cons x' i') (I.cons t' j').
destruct 1 as (?&?&?); split;[idtac|split]; trivial.
 unfold push_var; simpl.
 apply vcons_add_var; trivial.

 unfold push_var; simpl.
 apply vcons_add_var; trivial.

 destruct n as [|n]; simpl; auto.
 generalize (H1 n).
 destruct (ords e n); trivial.
Qed.

Lemma val_push_ord : forall e i j i' j' x t x' t' T,
  val_mono e i j i' j' ->
  x ⊆ x' ->
  [x,t] \real int T i ->
  [x',t'] \real int T i' ->
  T <> kind ->
  val_mono (push_ord e T) (V.cons x i) (I.cons t j) (V.cons x' i') (I.cons t' j').
destruct 1 as (?&?&?); split;[idtac|split]; trivial.
 unfold push_ord; simpl.
 apply vcons_add_var; trivial.

 unfold push_ord; simpl.
 apply vcons_add_var; trivial.

 destruct n as [|n]; simpl; auto.
 generalize (H1 n).
 destruct (ords e n); trivial.
Qed.

Lemma val_push_fun : forall e i j i' j' f tf g tg T U,
  val_mono e i j i' j' ->
  [f,tf] \real int (Prod T U) i ->
  [g,tg] \real int (Prod T U) i' ->
  fcompat (El(int T i)) f g ->
  val_mono (push_fun e T U) (V.cons f i) (I.cons tf j) (V.cons g i') (I.cons tg j').
destruct 1 as (?&?&?); split;[idtac|split]; trivial.
 unfold push_fun; simpl.
 apply vcons_add_var; trivial.
 discriminate.

 unfold push_fun; simpl.
 apply vcons_add_var; trivial.
 discriminate.

 destruct n as [|n]; simpl; auto.
 generalize (H1 n).
 destruct (ords e n); trivial.
Qed.

(** Function Extension judgment *)
Definition fx_extends e dom M :=
  forall i i' j j', val_mono e i j i' j' ->
  fcompat (El(int dom i)) (int M i) (int M i').

(** Covariance judgment *)
Definition fx_sub e M :=
  forall i i' j j', val_mono e i j i' j' ->
  forall x t, [x,t] \real int M i -> [x,t] \real int M i'.

Definition fx_subval e M :=
  forall i i' j j', val_mono e i j i' j' -> int M i ⊆ int M i'.

(** Invariance *)
Definition fx_equals e M :=
  forall i i' j j', val_mono e i j i' j' -> int M i == int M i'.

Lemma El_sub e T i j i' j':
  fx_sub e T ->
  val_mono e i j i' j' ->
  El (int T i) ⊆ El (int T i').
intros.
apply H in H0.
red; intros.
apply H0 with daimont.
split;[trivial|apply varSAT].
Qed.
Lemma El_eq e T i j i' j':
  fx_equals e T ->
  val_mono e i j i' j' ->
  El (int T i) == El (int T i').
intros.
apply H in H0.
rewrite H0; reflexivity.
Qed.

Require Import Bool.

Definition spec_var e n :=
  ords e n || match fixs e n with Some _ => true | _ => false end.

  Lemma fx_eq_noc : forall e t,
    noccur (spec_var e) t ->
    fx_equals e t.
unfold noccur, fx_equals, spec_var; intros.
apply H; intros.
destruct H0 as (_,(_,H0)).
generalize (H0 n).
destruct (ords e n); simpl; trivial.
destruct (fixs e n); simpl; trivial.
Qed.

  Lemma fx_eq_app : forall e u v,
    fx_equals e u ->
    fx_equals e v ->
    fx_equals e (App u v).
unfold fx_equals; intros.
specialize H with (1:=H1).
specialize H0 with (1:=H1).
simpl.
rewrite H; rewrite H0; reflexivity.
Qed.

  Lemma fx_eq_abs : forall e T M,
    T <> kind ->
    fx_equals e T ->
    fx_equals (push_var e T) M ->
    fx_equals e (Abs T M).
unfold fx_equals; intros.
simpl.
apply lam_ext; eauto.
red; intros.
apply H1 with (I.cons daimont j) (I.cons daimont j').
specialize H0 with (1:=H2).
apply val_push_var; auto.
 split; trivial.
 apply varSAT.

 split.
 2:apply varSAT.
 unfold inX; rewrite <- H4; rewrite <- H0; trivial.
Qed.

  Lemma fx_eq_app_irr e m x T :
    T <> kind ->
    fx_extends e T m ->
    fx_equals e x ->
    typ (tenv e) x T ->
    fx_equals e (App m x).
unfold typ, fx_extends,fx_equals; intros Tnk m_ext x_eq x_ty i i' j j' valm.
simpl.
specialize x_eq with (1:=valm).
specialize m_ext with (1:=valm).
rewrite <- x_eq.
apply m_ext.
specialize x_ty with (1:=proj1 valm).
apply in_int_not_kind in x_ty; trivial.
destruct x_ty as (?,_ ); trivial.
Qed.

  (* Covariance *)

  Lemma fx_equals_subval : forall e M, fx_equals e M -> fx_subval e M.
unfold fx_subval, fx_equals; intros.
apply H in H0.
rewrite <- H0; reflexivity.
Qed.

  Lemma fx_equals_sub : forall e M, fx_equals e M -> fx_sub e M.
unfold fx_sub, fx_equals; intros.
apply H in H0.
destruct H1.
split.
 red.
 rewrite <- H0; trivial.

 rewrite <- H0; trivial.
Qed.

  Lemma var_sub : forall e n,
    ords e n = true ->
    fx_subval e (Ref n).
unfold fx_subval; intros.
destruct H0 as (_,(_,H0)).
generalize (H0 n); rewrite H.
simpl; trivial.
Qed.

Lemma fx_sub_prod : forall e T U,
  T <> kind ->
  fx_equals e T ->
  fx_sub (push_var e T) U ->
  fx_sub e (Prod T U).
red; intros.
red in H0; specialize H0 with (1:=H2).
destruct H3.
red in H3.
rewrite El_int_prod in H3.
rewrite Real_int_prod in H4; trivial.
apply and_split; intros.
 red; rewrite El_int_prod.
 revert H3; apply cc_prod_covariant; intros.
  do 2 red; intros.
  rewrite H5; reflexivity.

  rewrite H0; reflexivity.

  apply El_sub with (1:=H1) (j:=I.cons daimont j) (j':=I.cons daimont j').
  apply val_push_var; auto with *.
   split;[trivial|apply varSAT].
   split;[|apply varSAT].
   red; rewrite <- H0; trivial.

 red in H5; rewrite El_int_prod in H5.
 rewrite Real_int_prod; trivial.
 revert t H4; apply piSAT0_mono with (f:=fun x=>x); intros; auto with *.
  rewrite H0; trivial.

  rewrite H0; reflexivity.

  rewrite <- H0 in H4.
  red; intros.
  apply H1 with (i:=V.cons x0 i) (j:=I.cons daimont j) (j':=I.cons daimont j').
   apply val_push_var; auto with *.
   split; trivial; apply varSAT.
   split.
    red; rewrite <- H0; trivial.
    apply varSAT.

   split; trivial.
   unfold inX; apply cc_prod_elim with (1:=H3); trivial.
Qed.

  (* Function subtyping *)

  Lemma fx_ext_var e n T :
    ords e n = false ->
    fixs e n = Some T ->
    fx_extends e (lift (S n) T) (Ref n).
red; intros.
simpl.
assert (h := proj2 (proj2 H1) n).
rewrite H,H0 in h.
red; intros.
apply h.
rewrite int_lift_eq in H2; trivial.
Qed.

  Lemma fx_eq_rec_call : forall e n x T U,
    ords e n = false ->
    fixs e n = Some T ->
    T <> kind ->
    typ (tenv e) (Ref n) (Prod (lift (S n) T) U) ->
    fx_equals e x ->
    typ (tenv e) x (lift (S n) T) ->
    fx_equals e (App (Ref n) x).
intros.
apply fx_eq_app_irr with (lift (S n) T); trivial.
 destruct T; [discriminate|elim H1; trivial].

 apply fx_ext_var; trivial.
Qed.

  Lemma fx_abs : forall e U T M,
    T <> kind ->
    fx_sub e T ->
    fx_equals (push_var e T) M ->
    typ (T::tenv e) M U ->
    U <> kind ->
    fx_extends e T (Abs T M).
unfold fx_equals, fx_extends; intros.
specialize El_sub with (1:=H0)(2:=H4); clear H0; intro H0.
simpl.
red; intros.
rewrite beta_eq; try assumption.
 assert (H5' := H0 _ H5).
 rewrite beta_eq; trivial.
  apply H1 with (I.cons daimont j) (I.cons daimont j').
  apply val_push_var; auto with *.
   split; [trivial|apply varSAT].

   split; [trivial|apply varSAT].

  red; red; intros.
  rewrite H7; reflexivity.

 red; red; intros.
 rewrite H7; reflexivity.
Qed.

(****************************************************************************************)
(** Compound judgements : typing + variance *)

Definition typ_ext e M A B :=
  fx_extends e A M /\ typ (tenv e) M (Prod A B).

Definition typ_mono e M :=
  fx_sub e M /\ typs (tenv e) M.

Definition typ_monoval e M T :=
  fx_subval e M /\ typ (tenv e) M T.

Definition typ_impl e M T :=
  fx_equals e M /\ typ (tenv e) M T.

Instance typ_impl_morph e : Proper (eq_term ==> eq_term ==> iff) (typ_impl e).
apply morph_impl_iff2; auto with *.
do 4 red; intros.
destruct H1; split.
 red; intros.
 rewrite <- H; eauto.

 rewrite <- H; rewrite <- H0; eauto.
Qed.

Lemma typ_impl_inj e M T :
  typ e M T ->
  typ_impl (tinj e) M T.
split; trivial.
red; intros.
apply int_morph; auto with *.
intros k.
generalize (proj2 (proj2 H0) k); simpl.
auto.
Qed.

Lemma typ_impl_subsumption e M T T' :
  typ_impl e M T ->
  sub_typ (tenv e) T T' ->
  T <> kind ->
  T' <> kind ->
  typ_impl e M T'.
 destruct 1; split; trivial.
 apply  typ_subsumption with T; trivial.
Qed.

Lemma typ_var_impl : forall e n t T,
    spec_var e n = false ->
    nth_error (tenv e) n = value t ->
    t <> kind ->
    T <> kind ->
    sub_typ (tenv e) (lift (S n) t) T ->
    typ_impl e (Ref n) T.
intros.
split.
 apply fx_eq_noc; apply noc_var; trivial.

 apply typ_subsumption with (lift (S n) t); trivial.
  apply typ_var; trivial.

  destruct t as [(t,tm)|]; simpl in *; auto.
  discriminate.
Qed.

  Lemma impl_abs : forall e s1 U T T' M,
    T <> kind ->
    U <> kind ->
    s1=prop \/ s1=kind ->
    eq_typ (tenv e) T T' ->
    typ_impl e T s1 ->
    typ_impl (push_var e T) M U ->
    typ_impl e (Abs T M) (Prod T' U).
intros.
destruct H3; destruct H4.
split.
 apply fx_eq_abs; trivial.

 apply typ_conv with (Prod T U); auto.
  apply typ_abs; trivial.
  destruct H1; subst s1; red; auto.

  apply eq_typ_prod; trivial.
  reflexivity.

  discriminate.

  discriminate.
Qed.

Lemma impl_app : forall e u v V Ur T,
  T <> kind ->
  V <> kind ->
  Ur <> kind ->
  sub_typ (tenv e) (subst v Ur) T ->
  typ_impl e u (Prod V Ur) ->
  typ_impl e v V ->
  typ_impl e (App u v) T.
intros.
destruct H3.
destruct H4.
split.
 apply fx_eq_app; trivial.

 apply typ_subsumption with (subst v Ur); trivial.
  apply typ_app with V; auto.

  destruct Ur as [(Ur,Urm)|]; simpl; trivial.
  discriminate.
Qed.

  Lemma typ_var_mono : forall e n t T,
    ords e n = true ->
    nth_error (tenv e) n = value t ->
    T <> kind ->
    t <> kind ->
    sub_typ (tenv e) (lift (S n) t) T ->
    typ_monoval e (Ref n) T.
intros.
split.
 apply var_sub; trivial.

 apply typ_subsumption with (lift (S n) t); trivial.
  apply typ_var; trivial.

  destruct t as [(t,tm)|]; simpl in *; auto.
  discriminate.
Qed.

  Lemma ext_abs : forall e U T M,
    T <> kind ->
    U <> kind ->
    typ_mono e T ->
    typ_impl (push_var e T) M U ->
    typ_ext e (Abs T M) T U.
intros.
destruct H1; destruct H2; split.
 apply fx_abs with U; trivial.

 apply typ_abs; trivial.
Qed.

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

  Lemma impl_call : forall e n x t u T,
    ords e n = false ->
    fixs e n = Some t ->
    T <> kind ->
    t <> kind ->
    u <> kind ->
    nth_error (tenv e) n = value (Prod t u) ->
    sub_typ (tenv e) (subst x (lift_rec (S n) 1 u)) T ->
    typ_impl e x (lift (S n) t) ->
    typ_impl e (App (Ref n) x) T.
intros.
destruct H6.
assert (typ (tenv e) (Ref n) (Prod (lift (S n) t) (lift_rec (S n) 1 u))).
 apply typ_var0; rewrite H4; split;[discriminate|].
 apply sub_refl.

 unfold lift; rewrite red_lift_prod.
 reflexivity.
split.
 apply fx_eq_rec_call with t (lift_rec (S n) 1 u); trivial.

 apply typ_subsumption with (subst x (lift_rec (S n) 1 u)); auto.
 2:destruct u as [(u,um)|]; trivial.
 2:discriminate.
 apply typ_app with (lift (S n) t); trivial.
 destruct t as [(t,tm)|]; trivial.
 discriminate.
 destruct u as [(u,um)|]; trivial.
 discriminate.
Qed.

(** Variance and ordinals *)
Require Import SN_ord.

Definition typ_ord_mono (e:fenv) O :=
  fx_subval e O /\ typ_ord (tenv e) O.

Definition typ_ord_impl (e:fenv) O :=
  fx_equals e O /\ typ_ord (tenv e) O.

Lemma OSucc_subval e O :
  typ_ord (tenv e) O ->
  fx_subval e O ->
  fx_subval e (OSucc O).
unfold fx_subval; intros.
specialize H0 with (1:=H1).
destruct (H _ _ (proj1 H1)) as (?,_).
destruct (H _ _ (proj1 (proj2 H1))) as (?,_).
simpl.
apply osucc_mono; trivial.
Qed.

Hint Resolve OSucc_subval.

  Lemma typ_Ordt_ord e O o :
    isOrd o ->
    typ e O (Ordt o) ->
    typ_ord e O.
red; intros.
destruct H0 with (1:=H1) as (_,(?,?)).
simpl in H2; red in H2.
rewrite El_def in H2.
simpl in H3; rewrite Real_def in H3; trivial.
2:reflexivity.
apply sat_sn in H3; split; trivial.
apply cc_bot_ax in H2; destruct H2.
 rewrite H2; trivial.

 apply isOrd_inv with o; trivial.
Qed.

  Lemma OSucc_fx_sub : forall e O o,
    isOrd o ->
    zero ∈ o ->
    typ_monoval e O (Ordt o)->
    typ_monoval e (OSucc O) (Ordt (osucc o)).
destruct 3.
split.
 apply OSucc_subval; trivial.
 apply typ_Ordt_ord with o; trivial.

 red; simpl; intros.
 apply in_int_intro; try discriminate.
 destruct tyord_inv with (3:=H2)(4:=H3) as (_,(?,_)); trivial.
 assert (osucc (int O i) ∈ El (int (Ordt (osucc o)) i)).
  rewrite El_int_ord.
  apply lt_osucc_compat; trivial.
  apply ole_lts; auto.
 split; simpl; trivial.
 rewrite Real_def; auto with *.
  assert (h:= H2 _ _ H3).
  apply in_int_sn in h.
  simpl; trivial.

  simpl.
  apply cc_bot_intro.
  apply lt_osucc_compat; trivial.
Qed.


From iris.proofmode Require Import coq_tactics reduction spec_patterns.
From melocoton.language Require Import wp_link.
From iris.proofmode Require Export tactics.
From melocoton.c_lang Require Import lang notation proofmode.
From iris.prelude Require Import options.
Import uPred.

(** Heap tactics *)
Section examples.
Context `{SI:indexT}.
Context `{!heapG_C Σ, !invG Σ}.

Fixpoint fib (n:nat) : nat := match n with
  0 => 0
| S n' => match n' with
      0 => 1
    | S n'' => fib n' + fib n'' end end.

Definition fib_prog name (x:expr) : expr :=
(if: "x" < #2
 then "x"
 else (call: (&name) with ("x" - #1)) + (call: (&name) with ("x" - #2) )).

Definition heap_example : expr :=
  let: "x" := malloc (#2) in
 (call: &"store_it" with (("x" +ₗ #1), call: &"fib_left" with ( Val (#3) )) ;;
 ("x" +ₗ #0) <- #1337 ;;
  let: "y" := *("x" +ₗ #1) in
  free ("x" +ₗ #1, #1) ;;
  *"x" + "y").

Definition fib_func name : function := Fun [BNamed "x"] (fib_prog name "x").
Definition exampleProgram fname cname : gmap string function :=
  {[ fname := fib_func cname ]}.

Notation FibSpec name := (λ (s:string) (v:list val) (Φ : (val → iPropI Σ)), match (s,v) with
      (name, [ #(LitInt z) ]) => (⌜(z >= 0)%Z⌝ ∗ Φ (#(fib (Z.to_nat z))))%I
    | _ => ⌜False⌝%I end).

Definition StoreItSpec := λ s v Φ, match (s,v) with
      ("store_it", [ #(LitLoc l) ; v' ]) => (∃ v, (l I↦C v) ∗ ((l ↦C v') -∗ Φ (#0)))%I
    | _ => ⌜False⌝%I end.

Definition FibLeftSpec := FibSpec "fib_left".
Definition FibRightSpec := FibSpec "fib_right".

Definition SimpleEnv : prog_environ C_lang Σ :=
  ⟨ exampleProgram "fib_impl" "fib_impl", StoreItSpec ⟩.

Definition FinalSpec := spec_union (FibLeftSpec) FibRightSpec.

Definition LeftEnv : prog_environ C_lang Σ :=
  ⟨ exampleProgram "fib_left" "fib_right", (* function called fib_left calls fib_right *)
    spec_union FibRightSpec StoreItSpec ⟩.

Definition RightEnv : prog_environ C_lang Σ :=
  ⟨ exampleProgram "fib_right" "fib_left", (* function called fib_right calls fib_left *)
    spec_union FibLeftSpec StoreItSpec ⟩.

Definition FinalEnv : prog_environ C_lang Σ :=
  ⟨ {[ "fib_right" := fib_func "fib_left"; "fib_left" := fib_func "fib_right" ]},
    StoreItSpec ⟩.

(* A simple recursive function *)
Lemma fib_prog_correct' (n:nat)
  : ⊢ (WP (call: &"fib_impl" with (Val #n)) @ SimpleEnv; ⊤ {{ v, ⌜v = #(fib n)⌝ }})%CE.
Proof.
  iStartProof.
  iLöb as "IH" forall (n).
  wp_pures.
  destruct (bool_decide _) eqn:Heq.
  - wp_pures. iModIntro. apply bool_decide_eq_true in Heq.
    assert (n=0 ∨ n=1) as [-> | ->] by lia; done.
  - do 2 wp_pure _. apply bool_decide_eq_false in Heq. wp_bind (FunCall _ _).
    wp_apply wp_wand.
    { assert ((n-1)%Z=(n-1)%nat) as -> by lia. iApply "IH". }
    iIntros (v) "->". wp_bind (FunCall _ _). wp_pure _. wp_apply wp_wand.
    { assert ((n-2)%Z=(n-2)%nat) as -> by lia. iApply "IH". }
    iIntros (v) "->". wp_pures. iModIntro. iPureIntro. rewrite <- Nat2Z.inj_add.
    repeat f_equal.
    assert (n = S (S (n-2))) as -> by lia.
    cbn. do 2 f_equal. lia.
Qed.

Lemma heap_prog_correct (n:nat)
  : ⊢ (WP heap_example @ RightEnv; ⊤ {{ v, ⌜v = #(1337 + fib 3)⌝ }}).
Proof.
  iStartProof. unfold heap_example.
  wp_alloc l as "Hl"; first lia. change (Z.to_nat 2) with 2.
  destruct l as [l]. cbn. unfold loc_add; cbn.
  iDestruct "Hl" as "(Hl0 & Hl1 & _)".
  do 2 wp_pure _.
  change (l + 1)%Z with (l + 1%nat)%Z.
  wp_bind (FunCall _ _).
  change 3 with (Z.of_nat 3).
(*

Tactic Notation "mwp_extern" :=
  iStartProof;
  lazymatch goal with
  | |- envs_entails _ (wp ?s ?E ?e ?Q) =>
    let e := eval simpl in e in
    reshape_expr e ltac:(fun K e' => match e' with FunCall (Val (& ?s)) (map Val ?vv) =>
      iApply (@wp_extern _ _ C_lang _ _ _ K _ s vv); [iPureIntro; vm_compute; reflexivity | ] end)
    || fail "wp_extern: expression not a call"
  | _ => fail "wp_extern: not a 'wp'"
  end.
Set Ltac Debug.
iApply (@wp_extern _ _ C_lang _ _ _ [] _ "fib_left" [(#3)%V]).
1: iPureIntro; vm_compute.
mwp_extern.

  Locate wp_extern. *)
  wp_extern. cbn. iLeft. cbn. iModIntro.
  iSplitR; first (iPureIntro; lia). wp_pures.
  wp_bind (FunCall _ _).
  wp_extern. cbn. iRight. cbn. iModIntro.
  iExists _. iFrame. iIntros "Hl1".
  wp_pures.
  wp_pures.
  wp_apply (wp_store with "Hl0"); iIntros "Hl0".
  wp_pures.
  wp_apply (wp_load with "Hl1"); iIntros "Hl1".
  wp_pures.
  wp_free.
  wp_pures.
  rewrite Z.add_0_r.
  wp_apply (wp_load with "Hl0"); iIntros "Hl0".
  wp_pures.
  done.
Qed.

Section linking.

  (* This section is very ugly *)
  (* Ugly tactic to reduce matches on strings *)
  Ltac string_resolve s t :=
      let b1 := fresh "b1" in
      let b2 := fresh "b2" in
      let b3 := fresh "b3" in
      let b4 := fresh "b4" in
      let b5 := fresh "b5" in
      let b6 := fresh "b6" in
      let b7 := fresh "b7" in
      let b8 := fresh "b8" in
      repeat (destruct s as [|[b1 b2 b3 b4 b5 b6 b7 b8] s]; (try t); eauto;
                    try (destruct b1; try t; eauto;
                    try (destruct b2; try t; eauto;
                    try (destruct b3; try t; eauto;
                    try (destruct b4; try t; eauto;
                    try (destruct b5; try t; eauto;
                    try (destruct b6; try t; eauto;
                    try (destruct b7; try t; eauto;
                    try (destruct b8; try t; eauto))))))))).

Lemma fib_left_correct : ⊢ env_fulfills LeftEnv FibLeftSpec.
Proof.
  iStartProof. unfold env_fulfills. unfold program_fulfills.
  iIntros (s vv Φ) "Hvv"; unfold FibLeftSpec.
  Ltac ft := (iDestruct "Hvv" as "%Hvv"; exfalso; done).
  string_resolve s ft. destruct vv as [|[[z| | |]] []]; try ft.
  iSplitR; first (iPureIntro; done).
  iDestruct "Hvv" as "(%Hnp & Hvv)".
  assert (exists n, Z.of_nat n = z) as [n <-].
  1: {exists (Z.to_nat z). lia. }
  wp_pures.
  destruct (bool_decide _) eqn:Heq.
  - wp_pures. iModIntro. apply bool_decide_eq_true in Heq.
    assert (n=0 \/ n=1) as [-> | ->] by lia; done.
  - do 2 wp_pure _. apply bool_decide_eq_false in Heq. wp_bind (FunCall _ _).
    wp_extern. cbn. iLeft. cbn. iModIntro. iSplitR; first by (iPureIntro; lia).
    wp_pures. wp_bind (FunCall _ _). wp_pures.
    wp_extern. cbn. iLeft. cbn. iModIntro. iSplitR; first by (iPureIntro; lia).
    wp_pures. wp_pures. iModIntro.
    assert (Z.to_nat (n - 1) = Z.to_nat n - 1) as -> by lia.
    assert (Z.to_nat (n - 2) = Z.to_nat n - 2) as -> by lia.
    rewrite ! Nat2Z.id.
    assert (exists n', n = S(S(n'))) as [n' ->].
    {destruct n as [|[|n']]; try lia. now exists n'. }
    cbn -[fib]. rewrite Nat.sub_0_r. rewrite <- Nat2Z.inj_add. iApply "Hvv".
Qed.

Lemma fib_right_correct : ⊢ env_fulfills RightEnv FibRightSpec.
Proof.
  iStartProof.
  iIntros (s vv Φ) "Hvv". unfold FibRightSpec.
  string_resolve s ft. destruct vv as [|[[z| | |]] []]; try ft.
  iSplitR; first (iPureIntro; done).
  iDestruct "Hvv" as "(%Hnp & Hvv)".
  assert (exists n, Z.of_nat n = z) as [n <-].
  1: {exists (Z.to_nat z). lia. }
  wp_pures.
  destruct (bool_decide _) eqn:Heq.
  - wp_pures. iModIntro. apply bool_decide_eq_true in Heq.
    assert (n=0 \/ n=1) as [-> | ->] by lia; done.
  - do 2 wp_pure _. apply bool_decide_eq_false in Heq. wp_bind (FunCall _ _).
    wp_extern. cbn. iLeft. cbn. iModIntro. iSplitR; first by (iPureIntro; lia).
    wp_pures. wp_bind (FunCall _ _). wp_pures.
    wp_extern. cbn. iLeft. cbn. iModIntro. iSplitR; first by (iPureIntro; lia).
    wp_pures. wp_pures. iModIntro.
    assert (Z.to_nat (n - 1) = Z.to_nat n - 1) as -> by lia.
    assert (Z.to_nat (n - 2) = Z.to_nat n - 2) as -> by lia.
    rewrite ! Nat2Z.id.
    assert (exists n', n = S(S(n'))) as [n' ->].
    {destruct n as [|[|n']]; try lia. now exists n'. }
    cbn -[fib]. rewrite Nat.sub_0_r. rewrite <- Nat2Z.inj_add. iApply "Hvv".
Qed.

Lemma example_can_link : can_link FibLeftSpec FibRightSpec StoreItSpec (spec_union FibLeftSpec FibRightSpec)
         (exampleProgram "fib_left" "fib_right") (exampleProgram "fib_right" "fib_left") (penv_prog FinalEnv).
Proof.
  assert (
    ((<["fib_right":=fib_func "fib_left"]> (<["fib_left":=fib_func "fib_right"]> ∅)))
  = (union_with (λ _ _ : func C_lang, None) (exampleProgram "fib_left" "fib_right") (exampleProgram "fib_right" "fib_left"))) as Heq.
  { apply map_eq_iff. intros i.
    destruct (decide (i = "fib_right")) as [-> | Hno].
    1: done.
    destruct (decide (i = "fib_left")) as [-> | Hno2].
    1: done.
    rewrite lookup_union_with.
    rewrite ! lookup_insert_ne. 2-4: done. cbn. done. }
  split.
  - unfold exampleProgram. set_solver.
  - iIntros (s vv Φ) "Hvv". iApply "Hvv".
  - iIntros (s vv Φ) "Hvv".
    unfold StoreItSpec.
    string_resolve s ft.
  - iApply fib_left_correct.
  - iApply fib_right_correct.
  - unfold FinalEnv. cbn. rewrite Heq. done.
Qed.

Lemma fib_link_correct : ⊢ env_fulfills FinalEnv FinalSpec.
Proof.
  iStartProof.
  iApply (wp_link_progs).
  apply can_link_can_link_all.
  apply example_can_link.
Qed.

End linking.

End examples.


From iris.proofmode Require Export tactics.
From iris.proofmode Require Import reduction coq_tactics intro_patterns.

Tactic Notation "iApply" open_constr(lem) "in" constr(i) :=
  iDestruct (lem with i) as i.

Lemma tac_assumption_eq {PROP:bi} Δ i p (P Q: PROP) :
  envs_lookup i Δ = Some (p, P) →
  P = Q →
  (let Δ' := envs_delete true i p Δ in
   if env_spatial_is_nil Δ' then TCTrue
   else TCOr (Absorbing Q) (AffineEnv (env_spatial Δ'))) →
  envs_entails Δ Q.
Proof.
  intros ? -> ?.
  eapply coq_tactics.tac_assumption; eauto.
  apply _.
Qed.

Tactic Notation "iExactEq" constr(H) :=
  let i := lazymatch type of H with
           | string => constr:(INamed H)
           | _ => H
           end in
  eapply (tac_assumption_eq _ i);
  [ first [ pm_reflexivity
          | fail 1 "iExactEq:" H "not found" ]
  | (* equality goal *)
  | pm_reduce; tc_solve
  ].

(* TODO: this works, but maybe we can do better *)
Tactic Notation "iLeft" "in" constr(H) :=
  let pat := constr:(IList [[IIdent H; IDrop]]) in
  iDestruct H as pat.
Tactic Notation "iRight" "in" constr(H) :=
  let pat := constr:(IList [[IDrop; IIdent H]]) in
  iDestruct H as pat.

(** freezing: hiding a hypothesis body

    the basic interface for this trick is borrowed from VST *)

Definition freeze {A} (x:A) := x.

Lemma freeze_eq {A} (x:A) : freeze x = x.
Proof. reflexivity. Qed.

Ltac iFreezeCore H :=
  let i := lazymatch type of H with
           | string => constr:(INamed H)
           | _ => H
           end in
  lazymatch iTypeOf i with
  | Some (_, ?P) =>
    iEval (rewrite -(freeze_eq P)) in i;
    let var := fresh "__frozen" in
    set (var:=freeze P)
  | None => let H := pretty_ident i in
            fail 1 "iFreeze:" H "not found"
  end.

Local Ltac iFreeze_go Hs :=
  lazymatch Hs with
  | [] => idtac
  | ESelIdent _ ?H :: ?Hs => iFreezeCore H; iFreeze_go Hs
  | ESelPure _ :: _ => fail 1 "iFreeze does not support Gallina identifiers"
  end.
Tactic Notation "iFreeze" constr(Hs) :=
  let Hs := iElaborateSelPat Hs in iFreeze_go Hs.

Ltac iThawCore H :=
  let i := lazymatch type of H with
           | string => constr:(INamed H)
           | _ => H
           end in
  lazymatch iTypeOf i with
  | Some (_, ?P) =>
    first [ is_var P; subst P; rewrite freeze_eq
          | let H := pretty_ident i in
            fail 0 "iThaw:" H "is not frozen"]
  | None => let H := pretty_ident i in
            fail 0 "iThaw:" H "not found"
  end.
Local Ltac iThaw_go Hs :=
  lazymatch Hs with
  | [] => idtac
  | ESelIdent _ ?H :: ?Hs => try iThawCore H; iThaw_go Hs
  end.
Tactic Notation "iThaw" constr(Hs) :=
  let Hs := iElaborateSelPat Hs in iThaw_go Hs.

Typeclasses Opaque freeze.
Opaque freeze.

(* hide frozen terms from display (even in the Coq context) *)
(* closing this scope will re-display frozen terms *)
Declare Scope freeze_scope.
Notation "☃" := (freeze _) (at level 0, only printing) : freeze_scope.
Global Open Scope freeze_scope.

Lemma tac_delay_split {PROP: bi} (R P Q: PROP) :
  (P ∗ R) -∗ (R -∗ Q) -∗ P ∗ Q.
Proof.
  iIntros "[$ R]".
  iIntros "H".
  iApply "H"; iFrame.
Qed.

Ltac iSplitDelay :=
  let PROP := iBiOfGoal in
  let R := fresh "remainder" in
  evar (R:PROP.(bi_car));
  iApply (tac_delay_split R with "[-] []");
  subst R.

Module tests.
  Section bi.
    Context {PROP: bi} `{BiAffine PROP}.
    Set Default Proof Using "All".
    Implicit Types (P Q: PROP) (Φ: nat → PROP).

    Example test_simple P : P -∗ P.
    Proof.
      iIntros "H".
      iExactEq "H".
      reflexivity.
    Qed.

    Example test_predicate Φ n : Φ (n + 1) -∗ Φ (S n).
    Proof.
      iIntros "H".
      iExactEq "H".
      f_equal; lia.
    Qed.

    Example test_non_existent P : P -∗ P.
    Proof.
      iIntros "H".
      Fail iExactEq "foo".
    Abort.

    Example test_freeze_one Φ n :
      Φ (n + 1) -∗ Φ (n + 1).
    Proof.
      iIntros "H".
      iFreeze "H".
      Fail progress iFrame.
      iThaw "H".
      iExact "H".
    Qed.

    Example test_freeze_several Φ1 Φ2 Φ3 n :
      Φ1 n -∗ Φ2 2 -∗ (Φ1 n ∗ Φ3 n) -∗ Φ1 n ∗ Φ2 2.
    Proof.
      iIntros "H1 H2 H3".
      iFreeze "H1 H2".
      iDestruct "H3" as "[$ _]".
      iThaw "H2".
      iFrame.
    Qed.

    Example test_freeze_persistent Φ1 Φ2 Φ3 n :
      □Φ1 n -∗ □Φ2 2 -∗ (Φ1 n ∗ Φ3 n) -∗ Φ1 n.
    Proof.
      iIntros "#H1 #H2 H3".
      iFreeze "#".
      iThaw "#".
      iDestruct "H3" as "[$ _]".
    Qed.

    Example test_delay_split (P Q R S T: PROP) :
      P ∗ Q ∗ R ∗ S ∗ T -∗ (P ∗ T ∗ R) ∗ (S ∗ Q).
    Proof.
      iIntros "(P&Q&R&S&T)".
      iSplitDelay.
      - iFrame.
        rewrite left_id. iAccu. (* would be iNamedAccu *)
      - iIntros "(Q&S)". (* would be iNamed 1 *)
        iFrame.
    Qed.

  End bi.
End tests.


Require Import String.
Require Import Functors.
Require Import MonadLib.
Require Import Names.
Require Import EffPure.
Require Import EffState.
Require Import EffExcept.
Require Import Arith.
Require Import Ref.
Require Import Exception.
Require Import ESoundES.

Open Scope string_scope.

Section Test_Section.

  Definition D := AType :+: RefType :+: UnitType.

  Definition E := Arith :+: RefE :+: (ExceptE D).

  Definition V := StuckValue :+: NatValue :+: UnitValue :+: LocValue.

  Variable MT : Set -> Set.
  Context `{Fail_MT : FailMonad MT}.
  Context {Inj_MT : InjMonad MT}.
  Context {Reasonable_MT : Reasonable_Monad MT}.
  Context {MT_eq_dec : forall (A : Set) (mta : MT A),
    {exists a, mta = return_ a} + {mta = fail}}.

  Variable ME : Set -> Set.
  Context `{StateM_ME : StateM ME (list (Value V))}.
  Context {Exception_ME : Exception ME Datatypes.unit}.
  Context {Reasonable_ME : Reasonable_Monad ME}.

  Definition WFV := (WFValue_VI V D (list (Names.DType D))) ::+::
    (WFValue_Unit D V _) ::+:: (WFValue_Loc D V _).

  Instance DType_Env_CE : ConsExtensionC (list (DType D)). eauto with typeclass_instances. Defined.
  Instance DType_Env_WFE : WF_EnvC V (list (DType D)). apply (DType_Env_WFE _ _ WFV). Defined.

  Definition WFVM :=
    (WFValueM_base D V MT ME (list (DType D)) WFV) ::+::
    (WFValueM_State D V MT ME _) ::+::
    (WFValueM_Except D V MT ME _).

  Instance typeof_alg : forall T : Set, FAlgebra TypeofName T (typeofR D MT) E.
  Proof.
    intros; eauto with typeclass_instances.
    apply FAlgebra_Plus; eauto with typeclass_instances.
    apply FAlgebra_Plus; eauto with typeclass_instances.
    apply MAlgebra_typeof_RefE with (Fun_MT := functor) (Mon_MT := monad);
      eauto with typeclass_instances.
  Defined.

  Instance eval_alg : forall T : Set, FAlgebra EvalName T (evalMR V ME) E.
  Proof.
    intros; eauto with typeclass_instances.
    apply FAlgebra_Plus; eauto with typeclass_instances.
    apply FAlgebra_Plus; eauto with typeclass_instances.
    apply MAlgebra_evalM_RefE with (Fun_M := functor0) (Mon_M := monad0);
      eauto with typeclass_instances.
  Defined.

    Context {ME_eq_dec' : forall (A : Set) (mte : ME A) (env : list (Value V)),
      (exists a, exists env',
        put env >> mte = put env' >> return_ a) \/
      (exists env', put env >> mte = put env' >> throw tt)}.
    Context {put_catch : forall (A : Set) (env : list (Value V)) e h,
      put env >>= (fun _ => catch (A := A) e h) = catch (put env >>= fun _ => e) h}.
    Context {Put_Exception_Disc :
      forall (A B : Set) (a : A) (mb : ME B) env n,
        (put env >>= fun _ => return_ a) <> mb >>= fun _ => throw n}.
    Context {put_throw : forall (A B : Set) (env env' : list (Value V)) t,
      put env >>= (fun _ => throw t (A := A)) = put env' >>= (fun _ => throw t) ->
      put env >>= (fun _ => throw t (A := B)) = put env' >>= (fun _ => throw t)}.

  Theorem eval_Sound :
    forall (e : Exp E) Sigma (T : DType D)
      (env : list (Value V)),
      WF_Environment D V _ WFV Sigma env Sigma ->
      fmap (@proj1_sig _ _) (typeof D E MT (proj1_sig e)) = return_ (proj1_sig T) ->
      (exists v : Value V, exists env', exists Sigma',
        (put env) >> evalM (evalM_E := eval_alg) V E ME (proj1_sig e) = put env' >> return_ (M := ME) v /\
        WFValueC D V _ WFV Sigma' v T) \/
      (exists t, exists env', exists Sigma',
        put env >> evalM (evalM_E := eval_alg) V E ME (proj1_sig e) = put env' >> throw t
        /\ WF_Environment D V _ WFV Sigma' env' Sigma'
        /\ (forall n T, lookup Sigma n = Some T -> lookup Sigma' n = Some T)).
  Proof.
    apply eval_Except_State_Sound with (WFVM' := WFVM).
    eauto 250 with typeclass_instances.
    eauto 250 with typeclass_instances.
    intros; repeat apply @P2Algebra_Plus.
    eapply Arith_eval_soundness' with (WFV := WFV);
      eauto 250 with typeclass_instances.
    eapply Ref_eval_soundness'' with (WFV := WFV);
      eauto 250 with typeclass_instances.
    eapply Except_eval_soundness';
      eauto 250 with typeclass_instances.
    eauto 250 with typeclass_instances.
    eauto 250 with typeclass_instances.
  Qed.

  Eval compute in ("Soundness for 'Arith :+: Ref :+: Exceptions ' Proven!").

End Test_Section.

(*
*** Local Variables: ***
*** coq-prog-args: ("-emacs-U" "-impredicative-set") ***
*** End: ***
*)


From mathcomp.ssreflect
Require Import ssreflect ssrbool ssrnat eqtype ssrfun seq.
From mathcomp
Require Import path.
Require Import Eqdep.
Require Import Relation_Operators.
From fcsl
Require Import axioms pred prelude ordtype finmap pcm unionmap heap.
From DiSeL
Require Import Freshness State EqTypeX Protocols Worlds NetworkSem Rely.
From DiSeL
Require Import Actions Injection Process Always HoareTriples InferenceRules.

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

(* The Hello World example - a distributed protocol, allowing anyone send
anyone a greeting message. *)

Module GreeterProtocol.
Section GreeterProtocol.

Variable fixed_nodes : seq nid.

Section GreeterCoh.

(* All nodes are welcome to participate in the protocol *)
Definition nodes (d : dstatelet) : pred nid := mem fixed_nodes.

(* Defining coherence predicate for the greeter statelet *)

Definition hello := [:: 3; 1; 1; 0].
Definition counter := ptr_nat 1.

(* All messages have fixed shape *)
Definition soupCoh : Pred soup :=
  [Pred s | valid s /\
            forall m msg,
              find m s = Some msg ->
              let: from := from msg in
              let: tag := tag (content msg) in
              let: val := tms_cont (content msg) in
              [/\ from \in fixed_nodes,
                  tag == 0 & behead val == hello]].

(* Coherence for the local state ensures that is has just one counter,
   which we will later use to count incoming messages  *)
Definition localCoh : Pred heap :=
  [Pred h | exists n : nat, h = counter :-> n].

(* Overall coherence *)
Definition greeter_coh d : Prop :=
  let: dl := dstate d in
  let: ds := dsoup d in
  [/\ soupCoh ds, dom dl =i fixed_nodes,
   valid dl &
   forall n, n \in fixed_nodes -> localCoh (getLocal n d)].

(* Axioms of the coherence predicate *)
Lemma l1 d: greeter_coh d -> valid (dstate d).
Proof. by case. Qed.

Lemma l2 d: greeter_coh d -> valid (dsoup d).
Proof. by case; case. Qed.

Lemma l3 d: greeter_coh d -> dom (dstate d) =i nodes d.
Proof. by case. Qed.

(* Wrapping up the coherence predicate *)
Definition GreeterCoh := CohPred (CohPredMixin l1 l2 l3).
End GreeterCoh.

Section GreeterSend.

Section SendBase.

Notation coh := GreeterCoh.

(* Defining send and receive transitions *)
Definition greet_safe (this n : nid) (d : dstatelet) msg :=
  [/\ this \in fixed_nodes,
      n \in fixed_nodes,
      exists m, msg == m :: hello &
      coh d].

Section GreetAux.

Variables (this : nid) (d : dstatelet)
          (C : coh d).

Lemma lcoh n : n \in fixed_nodes -> localCoh (getLocal n d).
Proof. by move=> H; case: C => _ _ _/(_ n H). Qed.

Lemma cohN n v :
  n \in fixed_nodes ->
  find counter (getLocal n d) = Some v ->
  dyn_tp v = nat.
Proof. by move=>H; case: (lcoh H)=>m->; rewrite findPt /=; case=><-. Qed.

Definition getN n (pf : n \in fixed_nodes) : nat :=
  match find counter (getLocal n d) as f return _ = f -> _ with
    Some v => fun epf => icast (sym_eq (cohN pf epf)) (dyn_val v)
  | None => fun epf => 0
  end (erefl _).

Lemma getNK n (Hn : n \in fixed_nodes) m:
  getLocal n d = counter :-> m -> getN Hn = m.
Proof.
move=>E; rewrite /getN; move: (cohN)=>H.
by move: (H n)=>{H}; rewrite E=>H/=; apply: eqc.
Qed.

End GreetAux.

Lemma this_in_pf this to d msg :
  greet_safe this to d msg -> this \in fixed_nodes.
Proof. by case. Qed.

Lemma greet_safe_coh this to d m : greet_safe this to d m -> coh d.
Proof. by case. Qed.

Definition greet_step (this to : nid) (d : dstatelet)
           (msg : seq nat)
           (pf: greet_safe this to d msg)
  : option heap :=
  if (behead msg == hello) && (to \in fixed_nodes)
  then Some (counter :-> (getN (greet_safe_coh pf) (this_in_pf pf)).+1)
  else None.

Lemma greet_safe_in this to d m : greet_safe this to d m ->
                                  this \in nodes d /\ to \in nodes d.
Proof. by case. Qed.

Lemma greet_safe_def this to d msg :
      greet_safe this to d msg <->
      exists b pf, @greet_step this to d msg pf = Some b.
Proof.
split=>[H|].
- exists (counter :-> (getN (greet_safe_coh H) (this_in_pf H)).+1), H.
  rewrite/greet_step; case: (H)=>H1 H2 H3 H4.
  move: (And4 H1 H2 H3 H4)=>C; rewrite H2; case: H3=>m H3.
  by move/eqP: H3=>H3; subst msg=>/=.
by case=>h[pf]; rewrite/greet_step; case:ifP=>///andP[/eqP->H]_; split.
Qed.

Definition greet_tag := 0.

(* We might need to put this statement into a separate definition *)
Lemma greet_step_coh this to d msg (pf : greet_safe this to d msg) b :
  let: f := dstate d in
  let: s := dsoup d  in
  Some b = greet_step pf ->
  let: f' := upd this b f in
  let: tms := TMsg greet_tag msg in
  let: s' := (post_msg s (Msg tms this to true)).1 in
  coh (DStatelet f' s').
Proof.
rewrite/greet_step; case:ifP=>///andP[/eqP Z1 H][]Z'; subst b=>/=.
case:pf=>[F1]F2 F3 [Cs D]Cl Cn.
split=>//=; do?[by rewrite validU/=].
- split; first by rewrite valid_fresh; case: Cs.
  move=>m msg'; rewrite findUnR ?domPt ?inE ?valid_fresh; last by case: Cs.
  case: ifP=>[/eqP Z|_]; last by case: Cs=>_ Cs; move/Cs.
  case:F3=>[m']/eqP E; subst msg.
  by subst m; rewrite findPt/=; case=><-.
- move=>n; rewrite domU inE/=; case: ifP=>[/eqP Z| _]//; subst n.
  by rewrite Cl F1.
move: (And4 F1 F2 F3 (And4 Cs D Cl Cn)) => S.
move=>n Hn; exists (if n == this
                    then (getN (greet_safe_coh S) (this_in_pf S)).+1
                    else (getN (greet_safe_coh S) Hn)); rewrite /getLocal/=.
rewrite findU; case Z: (n == this)=>/=.
- by move/eqP: Z=>Z; subst n; move: (And4 Cs D Cl Cn)=>C; rewrite Cl.
case: (Cn n Hn)=>m E; move: (E); rewrite /getLocal=>->; congr (_ :-> _).
by move: (getNK (greet_safe_coh S) Hn E)=><-.
Qed.

End SendBase.

(*  Defined the send-transition of the greeter  *)
Definition greeter_send_trans :=
  SendTrans greet_safe_coh greet_safe_in greet_safe_def greet_step_coh.

End GreeterSend.

Variable l : Label.

(* Defining the protocol *)
Program Definition GreeterProt : protocol :=
  @Protocol _ l _ [:: greeter_send_trans] [::] _ _.

End GreeterProtocol.

Module Exports.
Section Exports.

Definition getN := getN.
Definition getNK := getNK.
Definition GreeterProtocol := GreeterProt.
Definition gsend := greeter_send_trans.
Definition hello := hello.
Definition counter := counter.
Definition greet_safe_coh := greet_safe_coh.

End Exports.
End Exports.

End GreeterProtocol.

Export GreeterProtocol.Exports.

Section GreeterPrograms.

Variable l : Label.
Variable nodes : seq nid.

Definition gp := GreeterProtocol nodes l.

(* Simplest world with one protocol *)
(* TODO: simplify this using canonicals *)
Definition W : world := (l \\-> gp, Unit).

Variable this : nid.

Lemma grEq : (getProtocol W l) = gp.
Proof. by rewrite /getProtocol findPt. Qed.

(* Defining an action for greeting on top of the corresponding transition *)
(* Sends and argument number and a suffix *)
Program Definition greet_act n :=
  @send_action_wrapper W gp this l grEq (gsend nodes) _ (n :: hello).
Next Obligation. by rewrite InE. Qed.

Hypothesis P1 : this \in nodes.

Program Definition read_act :=
  @skip_action_wrapper W this l gp grEq nat (fun s pf => getN pf P1).

Notation loc i := (getLocal this (getStatelet i l)).
Notation msgs i := (dsoup (getStatelet i l)).

Definition greeter_spec to :=
  {n : nat}, DHT [this, W]
  (fun i => loc i = counter :-> n /\ to \in nodes,
   fun r m =>
       [/\ loc m = counter :-> n.+1,
        head 0 r = n &
        exists z b, find z (msgs m) = Some (Msg (TMsg 0 (n :: hello)) this to b)]).

Program Definition greet to : greeter_spec to :=
  Do (n <-- act read_act;
      act (greet_act n to)).

Next Obligation.
apply ghC=>s1 n [Hloc] Hto C1.

apply: step.
- apply: act_rule.
  move=> s2 R1.
  split; first by move: R1=> /rely_coh[]; rewrite /read_act/=/Actions.skip_safe.
  move=> y s2' s3 [Sf1]/=.
  rewrite /Actions.skip_step => -[] C2 ? ? R2; subst s2'; subst.

(* Applying inference rule for actions *)
apply: act_rule=>s4 R3.
(* Dealing with rely *)

(* Proving the precondition *)
split=>[|r s5 s6 [Sf2] St R4].
- split; case/rely_coh: R3=>C3 C4=>//.
  + split=>//; first by eauto.
    by case: C4=>_ _ _ _/(_ l); rewrite grEq.
  + by apply/andP; split=>//; move: (cohD C4)=><-; rewrite domPt inE; apply/eqP.
  move=>???/=.
  move => F.
  apply sym_eq in F.
  move: F.
  by move/find_some; rewrite /Actions.filter_hooks umfilt0 dom0.
(*Bookkeeping for the postconidtion *)
case: St=>Z1[h]/=[St]Z2; subst.

(* Making use of the stepping relation *)
rewrite /GreeterProtocol.greet_step/= Hto in St; case: St=>Z'; subst h.
(* Rewriting the state getter *)
erewrite !getNK in R4; first last.
- by rewrite (rely_loc' l R3) (rely_loc' l R2) (rely_loc' l R1); exact: Hloc.
- by rewrite (rely_loc' l R1); exact: Hloc.
(* rewriting via rely *)
case/rely_coh: (R3)=>C3 C4.
erewrite getNK; last by rewrite (rely_loc' l R1); exact: Hloc.
rewrite (rely_loc' l R4); split=>//.
- rewrite /getLocal/getStatelet findU eqxx/= (cohS C4)/= findU eqxx/=.
  rewrite getsE /=; last by rewrite -(cohD C4) domPt inE; apply/eqP.
  by rewrite (cohVl (coh_coh l C4)).

(* Reasoning about message soup *)
exists (fresh (msgs s4)).
case: (rely_send_other' R4 (m := fresh (msgs s4)) (l := l)
                        (tm := {| tag := GreeterProtocol.greet_tag; tms_cont := n :: hello |})
                        (to := to) (b := true)); last by move=>b[->]/= _; exists b.
rewrite /getStatelet findU eqxx/= (cohS C4)/=.
rewrite getsE /=; last by rewrite -(cohD C4) domPt inE; apply/eqP.
rewrite joinC findPtUn // joinC valid_fresh.
by apply: (cohVs (coh_coh l C4)).
Qed.

Definition greeter_spec2 n to :=
  DHT [this, W]
  (fun i => loc i = counter :-> n /\ to \in nodes,
   fun r m =>
     loc m = counter :-> n.+2 /\ head 0 r = n.+1).

Program Definition greet2 n to : greeter_spec2 n to :=
  Do (r <-- greet to;
      greet to).

Next Obligation.
move=>i/=[H1 H2].
(* Switch to the continuation *)
apply: step.
apply: (gh_ex (g := n)); apply: call_rule=>//.
move=>? j[Hcount Hhead _] Cj.
apply: (gh_ex (g := n.+1)); apply: call_rule=>//.
by move=>r m[X1 X2 _].
Qed.

End GreeterPrograms.

Section CombineGreeters.

Variables (l1 l2 : Label) (nodes : seq nid) (this : nid).
Variable (lab_disj : l2 != l1).

Definition gp1 := GreeterProtocol nodes l1.
Definition gp2 := GreeterProtocol nodes l2.

Definition V := (W l1 nodes) \+ (W l2 nodes).

Lemma validV : valid V.
Proof.
rewrite /V; apply/andP=>/=.
split; first by rewrite validPtUn/= validPt/= domPt inE/=.
by rewrite unitR valid_unit.
Qed.

Notation loc i k := (getLocal this (getStatelet i k)).
Notation msgs i k := (dsoup (getStatelet i k)).

Hypothesis T : this \in nodes.

Definition greet_prog1 := greet2 l1 T.
Definition greet_prog2 := greet2 l2 T.

Definition greeter_spec3 n1 n2 to :=
  DHT [this, V]
  (fun i =>
     [/\ loc i l1 = counter :-> n1,
      loc i l2 = counter :-> n2 &
      to \in nodes],
   fun r m =>
     [/\ loc m l1 = counter :-> n1.+2,
      loc m l2 = counter :-> n2.+2 &
      r = n1 + n2 + 2]).

Lemma hook_complete_unit (c : context) : hook_complete (c, Unit).
Proof. by move=>????; rewrite dom0. Qed.

Lemma hooks_consistent_unit (c : context) : hooks_consistent c Unit.
Proof. by move=>????; rewrite dom0. Qed.

Program Definition greet3 n1 n2 to : greeter_spec3 n1 n2 to :=
  Do (r1 <-- iinject (greet_prog1 n1 to);
      r2 <-- iinject (greet_prog2 n2 to);
      ret _ _ (head 0 r1 + head 0 r2)).

Next Obligation. exact Unit. Defined.
Next Obligation.
rewrite -(unitR V)/V.
have V: valid (W l1 nodes \+ W l2 nodes \+ Unit) by rewrite unitR validV.
apply: (injectL V); do?[apply: hook_complete_unit | apply: hooks_consistent_unit].
by move=>??????; rewrite dom0.
Qed.
Next Obligation. exact Unit. Defined.
Next Obligation.
rewrite -(unitR V)/V.
have V: valid (W l1 nodes \+ W l2 nodes \+ Unit) by rewrite unitR validV.
apply: (injectR V); do?[apply: hook_complete_unit | apply: hooks_consistent_unit].
by move=>??????; rewrite dom0.
Defined.

Lemma hcomp l : hook_complete (W l nodes).
Proof. by move=>????; rewrite dom0. Qed.

Next Obligation.
move=>i/=[H1]H2 N.
apply: vrf_coh=>C.
apply: step.
move: (coh_split C (@hcomp l1) (@hcomp l2))=>[i1[j1]][C1 C2 Z]; subst i.
apply: inject_rule=>//.
have E1 : loc (i1 \+ j1) l1 = loc i1 l1
  by rewrite (locProjL C _ C1)// domPt inE/=.
rewrite E1 in H1; apply: call_rule=>// r1 m1 [Q1 Z1] C1' j' C' R1.
have E2 : loc (i1 \+ j1) l2 = loc j1 l2.
  by rewrite (locProjR C _ C2)// domPt inE/=.
rewrite E2 -(rely_loc' l2 R1) in H2.
apply: step.
rewrite joinC; apply: inject_rule.
- case: (rely_coh R1)=>/= _.
  by rewrite injExtL//(cohW C).
apply: call_rule=>//r2 m2 [E3]Z2 C3 j'' C3' R2.
apply: ret_rule=>m3 R3[G1]G2 G3; split; last first.
(* Playing with locality of transitions, propagating once obtained
   results from intermediate states to the post-state. *)
- by rewrite Z1 Z2 -[_.+1]addn1 -[n2.+1]addn1
             addnAC !addnA !addn1 -addn2.
- rewrite (rely_loc' l2 R3) joinC; rewrite joinC in C3'.
  by rewrite (locProjR C3' _ C3)// domPt inE/=.
rewrite (rely_loc' l1 R3).
move/rely_coh: (R2)=>[]; rewrite injExtR ?(cohW C)// =>_ C5.
rewrite joinC in C3' *.
rewrite (locProjL C3' _ C5)//?/ddom ?domPt ?inE//=.
by rewrite (rely_loc' l1 R2).
Qed.

End CombineGreeters.


(** Here we define the notion of a HIT *)
Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.

Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.Groupoids.
Require Import UniMath.Bicategories.Core.Bicat.
Require Import UniMath.Bicategories.Core.Examples.OneTypes.
Require Import UniMath.Bicategories.Colimits.Initial.

Require Import prelude.all.
Require Import signature.hit_signature.
Require Import algebra.groupoid_polynomials.

Local Open Scope cat.

Definition quot_rel
           {X : UU}
           (R : X → X → UU)
           (ER : ∏ (x y : X), R x y → R x y → hProp)
  : X → X → hSet
  := λ x y,
     make_hSet
       (setquot (ER x y))
       (isasetsetquot _).

Definition poly_act_rel2
           (P : poly_code)
           {X : UU}
           {R : X → X → UU}
           (ER : ∏ (x y : X), R x y → R x y → UU)
           {x y : poly_act P X}
  : poly_act_rel P R x y → poly_act_rel P R x y → UU.
Proof.
  induction P as [A | | P₁ IHP₁ P₂ IHP₂ | P₁ IHP₁ P₂ IHP₂].
  - exact (λ p q, p = q).
  - exact (ER x y).
  - induction x as [x | x], y as [y | y].
    + exact (IHP₁ x y).
    + exact (λ _ _, hfalse).
    + exact (λ _ _, hfalse).
    + exact (IHP₂ x y).
  - exact (λ r₁ r₂, IHP₁ _ _ (pr1 r₁) (pr1 r₂) × IHP₂ _ _ (pr2 r₁) (pr2 r₂)).
Defined.

Definition isaprop_poly_act_rel2
           (P : poly_code)
           {X : UU}
           {R : X → X → UU}
           (ER : ∏ (x y : X), R x y → R x y → hProp)
           {x y : poly_act P X}
           (r₁ r₂ : poly_act_rel P R x y)
  : isaprop (poly_act_rel2 P ER r₁ r₂).
Proof.
  induction P as [A | | P₁ IHP₁ P₂ IHP₂ | P₁ IHP₁ P₂ IHP₂].
  - exact (one_type_isofhlevel A _ _ _ _).
  - apply (ER x y r₁ r₂).
  - induction x as [x | x], y as [y | y].
    + exact (IHP₁ x y r₁ r₂).
    + apply isapropempty.
    + apply isapropempty.
    + exact (IHP₂ x y r₁ r₂).
  - exact (isapropdirprod
             _ _
             (IHP₁ _ _ (pr1 r₁) (pr1 r₂))
             (IHP₂ _ _ (pr2 r₁) (pr2 r₂))).
Defined.

Definition poly_act_hrel
           (P : poly_code)
           {X : UU}
           {R : X → X → UU}
           (ER : ∏ (x y : X), hrel (R x y))
           (x y : poly_act P X)
  : hrel (poly_act_rel P R x y)
  := λ r₁ r₂,
     make_hProp
       (poly_act_rel2 P ER r₁ r₂)
       (isaprop_poly_act_rel2 P ER r₁ r₂).

Definition poly_act_hrel_istrans
           (P : poly_code)
           {X : UU}
           {R : X → X → UU}
           (ER : ∏ (x y : X), hrel (R x y))
           (HER : ∏ (x y : X), istrans (ER x y))
           (x y : poly_act P X)
  : istrans (poly_act_hrel P ER x y).
Proof.
  induction P as [A | | P₁ IHP₁ P₂ IHP₂ | P₁ IHP₁ P₂ IHP₂].
  - exact (λ _ _ _ p q, p @ q).
  - exact (HER x y).
  - intros r₁ r₂ r₃ p q.
    induction x as [x | x], y as [y | y].
    + exact (IHP₁ _ _ _ _ _ p q).
    + exact (fromempty p).
    + exact (fromempty p).
    + exact (IHP₂ _ _ _ _ _ p q).
  - intros r₁ r₂ r₃ p q.
    exact (IHP₁ _ _ _ _ _ (pr1 p) (pr1 q) ,, IHP₂ _ _ _ _ _ (pr2 p) (pr2 q)).
Qed.

Definition poly_act_hrel_isrefl
           (P : poly_code)
           {X : UU}
           {R : X → X → UU}
           (ER : ∏ (x y : X), hrel (R x y))
           (HER : ∏ (x y : X), isrefl (ER x y))
           (x y : poly_act P X)
  : isrefl (poly_act_hrel P ER x y).
Proof.
  induction P as [A | | P₁ IHP₁ P₂ IHP₂ | P₁ IHP₁ P₂ IHP₂].
  - exact (λ _, idpath _).
  - exact (HER x y).
  - intros r.
    induction x as [x | x], y as [y | y].
    + exact (IHP₁ _ _ r).
    + exact (fromempty r).
    + exact (fromempty r).
    + exact (IHP₂ _ _ r).
  - intros r.
    exact (IHP₁ _ _ (pr1 r) ,, IHP₂ _ _ (pr2 r)).
Qed.

Definition poly_act_hrel_issymm
           (P : poly_code)
           {X : UU}
           {R : X → X → UU}
           (ER : ∏ (x y : X), hrel (R x y))
           (HER : ∏ (x y : X), issymm (ER x y))
           (x y : poly_act P X)
  : issymm (poly_act_hrel P ER x y).
Proof.
  induction P as [A | | P₁ IHP₁ P₂ IHP₂ | P₁ IHP₁ P₂ IHP₂].
  - exact (λ _ _ p, ! p).
  - exact (HER x y).
  - intros r.
    induction x as [x | x], y as [y | y].
    + exact (IHP₁ _ _ r).
    + exact (fromempty r).
    + exact (fromempty r).
    + exact (IHP₂ _ _ r).
  - intros ? ? r.
    exact (IHP₁ _ _ _ _ (pr1 r) ,, IHP₂ _ _ _ _ (pr2 r)).
Qed.

Definition poly_act_iseqrel
           (P : poly_code)
           {X : UU}
           {R : X → X → UU}
           (ER : ∏ (x y : X), eqrel (R x y))
           (x y : poly_act P X)
  : iseqrel (poly_act_hrel P ER x y).
Proof.
  refine ((_ ,, _) ,, _).
  - refine (poly_act_hrel_istrans P ER _ x y).
    apply ER.
  - refine (poly_act_hrel_isrefl P ER _ x y).
    apply ER.
  - refine (poly_act_hrel_issymm P ER _ x y).
    apply ER.
Defined.

Definition poly_act_eqrel
           (P : poly_code)
           {X : UU}
           {R : X → X → UU}
           (ER : ∏ (x y : X), eqrel (R x y))
           (x y : poly_act P X)
  : eqrel (poly_act_rel P R x y).
Proof.
  use make_eqrel.
  - exact (poly_act_hrel P ER x y).
  - exact (poly_act_iseqrel P ER x y).
Defined.

Definition poly_act_quot_rel
           {P : poly_code}
           {X : UU}
           {R : X → X → UU}
           (ER : ∏ (x y : X), eqrel (R x y))
           {x y : poly_act P X}
  : poly_act_rel P (quot_rel R ER) x y
    →
    quot_rel
      (poly_act_rel P R)
      (poly_act_eqrel P ER)
      x
      y.
Proof.
  induction P as [A | | P₁ IHP₁ P₂ IHP₂ | P₁ IHP₁ P₂ IHP₂].
  - exact (setquotpr _).
  - exact (λ z, z).
  - induction x as [x | x], y as [y | y].
    + exact (IHP₁ x y).
    + exact fromempty.
    + exact fromempty.
    + exact (IHP₂ x y).
  - intros z.
    specialize (IHP₁ _ _ (pr1 z)).
    specialize (IHP₂ _ _ (pr2 z)).
    revert IHP₁.
    use setquotuniv'.
    + apply isasetsetquot.
    + intro r₁.
      revert IHP₂.
      use setquotuniv'.
      * apply isasetsetquot.
      * intros r₂.
        apply setquotpr.
        exact (r₁ ,, r₂).
      * abstract
          (intros r₂ r₂' f ;
           use iscompsetquotpr ; simpl ;
           refine (_ ,, _) ;
           [ apply poly_act_hrel_isrefl ;
             apply ER
           | exact f ]).
    + abstract
        (intros r₁ r₁' f ;
         revert IHP₂ ;
         use (setquotunivprop _ (λ _, make_hProp _ _)) ;
         [ exact (isasetsetquot _ _ _)
         | intros r₂ ;
           use iscompsetquotpr ; simpl ;
           refine (_ ,, _) ;
           [ exact f
           | apply poly_act_hrel_isrefl ;
             apply ER]]).
Defined.

Definition isaset_poly_act_rel_quot_rel
           {P : poly_code}
           {X : UU}
           {R : X → X → UU}
           (ER : ∏ (x y : X), eqrel (R x y))
           {x y : poly_act P X}
  : isaset (poly_act_rel P (quot_rel R ER) x y).
Proof.
  induction P as [A | | P₁ IHP₁ P₂ IHP₂ | P₁ IHP₁ P₂ IHP₂].
  - exact (one_type_isofhlevel A _ _).
  - apply isasetsetquot.
  - induction x as [x | x], y as [y | y].
    + apply IHP₁.
    + apply isasetempty.
    + apply isasetempty.
    + apply IHP₂.
  - apply isasetdirprod.
    + apply IHP₁.
    + apply IHP₂.
Defined.

Definition quot_rel_poly_act
           {P : poly_code}
           {X : UU}
           {R : X → X → UU}
           (ER : ∏ (x y : X), eqrel (R x y))
           {x y : poly_act P X}
  : quot_rel
      (poly_act_rel P R)
      (poly_act_eqrel P ER)
      x
      y
    →
    poly_act_rel P (quot_rel R ER) x y.
Proof.
  induction P as [A | | P₁ IHP₁ P₂ IHP₂ | P₁ IHP₁ P₂ IHP₂].
  - use setquotuniv'.
    + exact (one_type_isofhlevel A _ _).
    + exact (λ p, p).
    + exact (λ _ _ r, r).
  - exact (λ z, z).
  - induction x as [x | x], y as [y | y].
    + exact (IHP₁ x y).
    + simpl.
      use setquotuniv'.
      * exact isasetempty.
      * exact (λ z, z).
      * exact (λ z, fromempty z).
    + simpl.
      use setquotuniv'.
      * exact isasetempty.
      * exact (λ z, z).
      * exact (λ z, fromempty z).
    + exact (IHP₂ x y).
  - use setquotuniv'.
    + apply isaset_poly_act_rel_quot_rel.
    + exact (λ r, IHP₁ _ _ (setquotpr _ (pr1 r)) ,, IHP₂ _ _ (setquotpr _ (pr2 r))).
    + abstract
        (intros r₁ r₂ f ;
         apply pathsdirprod ;
         [ apply maponpaths ;
           apply iscompsetquotpr ;
           exact (pr1 f)
         | apply maponpaths ;
           apply iscompsetquotpr ;
           exact (pr2 f)]).
Defined.

Definition poly_act_quot_rel_quot_rel_poly_act
           (P : poly_code)
           {X : UU}
           (R : X → X → UU)
           (ER : ∏ (x y : X), eqrel (R x y))
           (x y : poly_act P X)
           (z : quot_rel
                  (poly_act_rel P R)
                  (poly_act_eqrel P ER)
                  x
                  y)
  : poly_act_quot_rel ER (quot_rel_poly_act ER z) = z.
Proof.
  induction P as [A | | P₁ IHP₁ P₂ IHP₂ | P₁ IHP₁ P₂ IHP₂].
  - revert z.
    use (setquotunivprop _ (λ _, make_hProp _ _)).
    + apply isasetsetquot.
    + exact (λ _, idpath _).
  - apply idpath.
  - induction x as [x | x], y as [y | y].
    + exact (IHP₁ x y z).
    + induction (setquotuniv
                   (λ _ _, make_hProp ∅ isapropempty)
                   (make_hSet ∅ isasetempty)
                   (λ z0, z0)
                   (λ z0, fromempty z0) z).
    + induction (setquotuniv
                   (λ _ _, make_hProp ∅ isapropempty)
                   (make_hSet ∅ isasetempty)
                   (λ z0, z0)
                   (λ z0, fromempty z0) z).
    + exact (IHP₂ x y z).
  - revert z.
    use (setquotunivprop _ (λ _, make_hProp _ _)).
    + apply isasetsetquot.
    + intros z ; simpl.
      specialize (IHP₁ (pr1 x) (pr1 y) (setquotpr _ (pr1 z))).
      specialize (IHP₂ (pr2 x) (pr2 y) (setquotpr _ (pr2 z))).
      etrans.
      {
        apply maponpaths.
        apply IHP₁.
      }
      etrans.
      {
        apply (@setquotuniv'_comm _ (poly_act_eqrel P₁ ER (pr1 x) (pr1 y))).
      }
      etrans.
      {
        apply maponpaths.
        apply IHP₂.
      }
      apply idpath.
Defined.

Definition quot_rel_poly_act_poly_act_quot_rel
           (P : poly_code)
           {X : UU}
           (R : X → X → UU)
           (ER : ∏ (x y : X), eqrel (R x y))
           (x y : poly_act P X)
           (z : poly_act_rel P (quot_rel R ER) x y)
  : quot_rel_poly_act ER (poly_act_quot_rel ER z) = z.
Proof.
  induction P as [A | | P₁ IHP₁ P₂ IHP₂ | P₁ IHP₁ P₂ IHP₂].
  - apply idpath.
  - apply idpath.
  - induction x as [x | x], y as [y | y].
    + exact (IHP₁ x y z).
    + induction z.
    + induction z.
    + exact (IHP₂ x y z).
  - specialize (IHP₁ _ _ (pr1 z)).
    specialize (IHP₂ _ _ (pr2 z)).
    refine (_ @ pathsdirprod IHP₁ IHP₂) ; clear IHP₁ IHP₂.
    etrans.
    {
      apply maponpaths.
      simpl.
      apply idpath.
    }
    generalize (poly_act_quot_rel ER (pr1 z)).
    generalize (poly_act_quot_rel ER (pr2 z)).
    clear z.
    use (setquotunivprop _ (λ _, make_hProp _ _)).
    + use impred_isaprop ; intro.
      apply (@isaset_poly_act_rel_quot_rel (P₁ * P₂)).
    + intro z₂.
      use (setquotunivprop _ (λ _, make_hProp _ _)).
      * apply (@isaset_poly_act_rel_quot_rel (P₁ * P₂)).
      * intro z₁.
        apply idpath.
Defined.

Definition quot_rel_poly_act_identity
           {P : poly_code}
           {X : UU}
           {R : X → X → UU}
           (r : ∏ (x : X), R x x)
           (ER : ∏ (x y : X), eqrel (R x y))
           {x : poly_act P X}
  : quot_rel_poly_act
      ER
      (setquotpr
         _
         (poly_act_rel_identity
            P
            _
            r
            x))
    =
    poly_act_rel_identity
      P
      _
      (λ z, setquotpr _ (r z))
      x.
Proof.
  induction P as [A | | P₁ IHP₁ P₂ IHP₂ | P₁ IHP₁ P₂ IHP₂].
  - apply idpath.
  - exact (setquotpr_eq
             (poly_act_iseqrel I ER x x)
             _
             (r x)).
  - induction x as [x | x].
    + simpl.
      refine (_ @ IHP₁ x).
      apply maponpaths.
      exact (setquotpr_eq
               (poly_act_iseqrel (P₁ + P₂) ER (inl x) (inl x))
               _
               _).
    + simpl.
      refine (_ @ IHP₂ x).
      apply maponpaths.
      exact (setquotpr_eq
               (poly_act_iseqrel (P₁ + P₂) ER (inr x) (inr x))
               _
               _).
  - exact (pathsdirprod (IHP₁ (pr1 x)) (IHP₂ (pr2 x))).
Qed.


Require Export DACandMAC.

Set Implicit Arguments.
Unset Strict Implicit.

(*********************************************************************)
(*                           aclstat                                 *)
(*********************************************************************)

(*This operation outputs the information stored in the ACL of a given*)
(*object. PreDACRead should be satisfied for the invoking user and   *)
(*object. There is no change of state.                               *)

Section Aclstat.

Variable s : SFSstate.

Inductive aclstat (u : SUBJECT) (o : OBJECT) :
SFSstate -> Exc AccessCtrlListData -> Prop :=
    AclstatOK :
      PreDACRead s u o ->
      aclstat u o s
        match facl (acl s) o with
        | None => None (A:=AccessCtrlListData)
        | Some y =>
            Some
              (acldata (owner y) (group y) (UsersReaders y)
                 (GroupReaders y) (UsersWriters y)
                 (GroupWriters y) (UsersOwners y) (GroupOwners y))
        end.

End Aclstat.