From Cat Require Import Cat.
From Cat.Universal Require Import
  Initial Terminal Product Coproduct Equalizer Coequalizer IndexedProduct IndexedCoproduct.

Class Apartoid : Type :=
{
  carrier : Type;
  neq : carrier -> carrier -> Prop;
  neq_irrefl  : forall x     : carrier, ~ neq x x;
  neq_sym     :> Symmetric neq; (* forall x y   : carrier, neq x y -> neq y x; *)
  neq_cotrans : forall x y z : carrier, neq x y -> neq z x \/ neq z y
}.

Coercion carrier : Apartoid >-> Sortclass.

Notation "x # y" := (neq x y) (at level 40).

#[global] Hint Resolve neq_irrefl neq_sym neq_cotrans : core.

Ltac apartoidob A := try intros until A;
match type of A with
| Apartoid =>
  let a := fresh A "_neq" in
  let b := fresh A "_neq_irrefl" in
  let c := fresh A "_neq_sym" in
  let d := fresh A "_neq_cotrans" in destruct A as [A a b c d]
| Ob _ => progress cbn in A; apartoidob A
end.

Ltac apartoidobs := intros; repeat
match goal with
| A : Apartoid |- _ => apartoidob A
| X : Ob _ |- _ => apartoidob X
end.

Record ApartoidHom (A B : Apartoid) : Type :=
{
  func :> A -> B;
  reflect_neq : forall a1 a2 : A, func a1 # func a2 -> a1 # a2;
}.

Ltac apartoidhom f := try intros until f;
match type of f with
| ApartoidHom _ _ =>
  let a := fresh "Proper_" f in destruct f as [f a]
| Hom _ _ => progress cbn in f; apartoidhom f
end.

Ltac apartoidhoms := intros; repeat
match goal with
| f : ApartoidHom _ _ |- _ => apartoidhom f
| f : Hom _ _ |- _ => apartoidhom f
end.

Definition ApartoidComp
  (X Y Z : Apartoid) (f : ApartoidHom X Y) (g : ApartoidHom Y Z) : ApartoidHom X Z.
Proof.
  exists (fun x => g (f x)).
  intros a1 a2 Hneq.
  now do 2 apply reflect_neq in Hneq.
Defined.

Definition ApartoidId (X : Apartoid) : ApartoidHom X X.
Proof.
  now exists (fun x : X => x).
Defined.

Ltac apartoid_simpl := repeat (red || split || cbn in * || intros).
Ltac apartoid_simpl' := repeat (apartoid_simpl || apartoidhoms || apartoidobs).

Ltac apartoid_neq := repeat
match goal with
| H : _ \/ _ |- _ => destruct H
| H : ?neq ?x ?x, irrefl : forall x : _, ~ ?neq x x |- False =>
  eapply irrefl; eauto
| H : ?P, H' : ~ ?P |- False =>
  eapply H'; eauto
| H : ?P ?x, H' : forall x : _, ~ ?P x |- False =>
  eapply H'; eauto
| H : ?P (?f _) (?g _), H' : forall x : _, ~ ?P (?f _) (?g _) |- False =>
  try (eapply H'; eauto; fail)
| _ => cat
end.

Ltac apartoid' :=
repeat (apartoid_simpl || apartoid_neq || apartoidobs || apartoidhoms || apartoid_neq;
match goal with
| |- context [Equivalence] => solve_equiv
| |- context [Proper] => proper
| |- False => apartoid_neq
| _ => eauto
end; eauto).
Ltac apartoid := try (apartoid'; eauto; fail).

#[refine]
#[export]
Instance ApartoidCat : Cat :=
{
  Ob := Apartoid;
  Hom := ApartoidHom;
  HomSetoid := fun A B : Apartoid =>
  {|
    equiv := fun f g : ApartoidHom A B => forall a : A, ~ f a # g a
  |};
  comp := ApartoidComp;
  id := ApartoidId
}.
Proof.
  - split; red.
    + now intros; apply neq_irrefl.
    + intros f g Heq a Hneq.
      now apply (Heq a); symmetry.
    + intros f g h Heq1 Heq2 a Hneq.
      destruct (neq_cotrans _ _ (g a) Hneq).
      * now apply (Heq1 a).
      * now apply (Heq2 a).
  - intros A B C f1  f2 Hf g1 g2 Hg a Hneq; cbn in *.
    destruct (neq_cotrans _ _ (g1 (f2 a)) Hneq).
    + apply reflect_neq in H.
      now apply (Hf a); symmetry.
    + now apply (Hg (f2 a)).
  - intros A B C D f g h a Hneq; cbn in *.
    now apply neq_irrefl in Hneq.
  - now cbn; intros; apply neq_irrefl.
  - now cbn; intros; apply neq_irrefl.
Defined.

#[refine]
#[export]
Instance Apartoid_init : Apartoid :=
{
  carrier := Empty_set;
  neq := fun (e : Empty_set) _ => match e with end
}.
Proof. all: easy. Defined.

Definition Apartoid_create (X : Apartoid) : ApartoidHom Apartoid_init X :=
{|
  func := fun e : Apartoid_init => match e with end;
  reflect_neq := ltac:(easy);
|}.

#[refine]
#[export]
Instance HasInit_Apartoid : HasInit ApartoidCat :=
{
  init := Apartoid_init;
  create := Apartoid_create
}.
Proof. easy. Defined.

#[export]
Instance HasStrictInit_Apartoid : HasStrictInit ApartoidCat.
Proof.
  intros A f.
  exists (create A).
  split; cycle 1.
  - now apply equiv_initial.
  - destruct f as [f Hf]; cbn.
    now intros x; destruct (f x).
Defined.

#[refine]
#[export]
Instance Apartoid_term : Apartoid :=
{
  carrier := unit;
  neq := fun _ _ => False
}.
Proof. all: easy. Defined.

Definition Apartoid_delete (X : Apartoid) : ApartoidHom X Apartoid_term.
Proof.
  now exists (fun _ => tt).
Defined.

#[refine]
#[export]
Instance HasTerm_Apartoid : HasTerm ApartoidCat :=
{
  term := Apartoid_term;
  delete := Apartoid_delete
}.
Proof. easy. Defined.

#[refine]
#[export]
Instance Apartoid_product (X Y : Apartoid) : Apartoid :=
{
  carrier := X * Y;
  neq := fun (p1 : X * Y) (p2 : X * Y) =>
    neq (fst p1) (fst p2) \/ neq (snd p1) (snd p2)
}.
Proof.
  - now intros [x y]; cbn; apartoid.
  - now intros [x1 y1] [x2 y2]; cbn; apartoid.
  - intros [x1 y1] [x2 y2] [x3 y3] []; cbn in *.
    + now destruct (neq_cotrans _ _ x3 H); auto.
    + now destruct (neq_cotrans _ _ y3 H); auto.
Defined.

Definition Apartoid_outl (X Y : Apartoid) : ApartoidHom (Apartoid_product X Y) X.
Proof.
  exists fst.
  now cbn; left.
Defined.

Definition Apartoid_outr (X Y : Apartoid) : ApartoidHom (Apartoid_product X Y) Y.
Proof.
  exists snd.
  now cbn; right.
Defined.

Definition Apartoid_fpair
  (A B X : Apartoid) (f : ApartoidHom X A) (g : ApartoidHom X B)
  : ApartoidHom X (Apartoid_product A B).
Proof.
  exists (fun x : X => (f x, g x)).
  now cbn; intros a1 a2 [H%reflect_neq | H%reflect_neq].
Defined.

#[refine]
#[export]
Instance HasProducts_Apartoid : HasProducts ApartoidCat :=
{
  product := Apartoid_product;
  outl := Apartoid_outl;
  outr := Apartoid_outr;
  fpair := Apartoid_fpair
}.
Proof.
  split; cbn.
  - easy.
  - easy.
  - now firstorder.
Defined.

#[refine]
#[export]
Instance Apartoid_coproduct (X Y : Apartoid) : Apartoid :=
{
    carrier := X + Y;
    neq := fun p1 p2 : X + Y =>
      match p1, p2 with
      | inl x, inl x' => neq x x'
      | inr y, inr y' => neq y y'
      | _, _ => True
      end
}.
Proof.
  - now intros [x | y].
  - now intros [x1 | y1] [x2 | y2]; auto.
  - now intros [x1 | y1] [x2 | y2] [x3 | y3]; auto.
Defined.

Definition Apartoid_finl
  (X Y : Apartoid) : ApartoidHom X (Apartoid_coproduct X Y).
Proof.
  now exists inl.
Defined.

Definition Apartoid_finr
  (X Y : Apartoid) : ApartoidHom Y (Apartoid_coproduct X Y).
Proof.
  now exists inr.
Defined.

Definition Apartoid_copair
  (A B X : Apartoid) (f : ApartoidHom A X) (g : ApartoidHom B X)
  : ApartoidHom (Apartoid_coproduct A B) X.
Proof.
  exists (fun p : A + B =>
    match p with
    | inl a => f a
    | inr b => g b
    end).
  now intros [a1 | b1] [a2 | b2]; apartoid.
Defined.

#[refine]
#[export]
Instance HasCoproducts_Apartoid : HasCoproducts ApartoidCat :=
{
  coproduct := Apartoid_coproduct;
  finl := Apartoid_finl;
  finr := Apartoid_finr;
  copair := Apartoid_copair
}.
Proof.
  split; cbn; [easy | easy |].
  intros P' [h1 h1'] [h2 h2'] Heq1 Heq2 [a | b] H; cbn in H, Heq1, Heq2.
  - now apply (Heq1 a).
  - now apply (Heq2 b).
Defined.

#[refine]
#[export]
Instance Apartoid_indexedProduct {J : Type} (A : J -> Apartoid) : Apartoid :=
{
  carrier := forall j : J, A j;
  neq := fun f g : forall j : J, A j => exists j : J, f j # g j
}.
Proof.
  - now intros x [j H]; apply neq_irrefl with (x j).
  - intros x y [j H].
    exists j.
    now apply neq_sym.
  - intros x y z [j H].
    destruct (neq_cotrans (x j) (y j) (z j) H).
    + now left; exists j.
    + now right; exists j.
Defined.

Definition Apartoid_out
  {J : Type} (A : J -> Apartoid) (j : J) : ApartoidHom (Apartoid_indexedProduct A) (A j).
Proof.
  exists (fun (f : forall j : J, A j) => f j).
  cbn; intros a1 a2 Hneq.
  now exists j.
Defined.

Definition Apartoid_tuple
  {J : Type} {A : J -> Apartoid} {X : Apartoid}
  (f : forall j : J, ApartoidHom X (A j))
  : ApartoidHom X (Apartoid_indexedProduct A).
Proof.
  exists (fun (x : X) (j : J) => f j x).
  cbn; intros a1 a2 [j Hneq].
  now apply reflect_neq in Hneq.
Defined.

#[refine]
#[export]
Instance HasIndexedProducts_Apartoid : HasIndexedProducts ApartoidCat :=
{
  indexedProduct := @Apartoid_indexedProduct;
  out := @Apartoid_out;
  tuple := @Apartoid_tuple;
}.
Proof.
  split; cbn in *; intros.
  - easy.
  - intros [j Hj].
    now apply (H j a).
Defined.

#[refine]
#[export]
Instance Apartoid_equalizer {X Y : Apartoid} (f g : ApartoidHom X Y) : Apartoid :=
{
  carrier := {x : X | ~ (f x) # (g x)};
  neq := fun p1 p2 : {x : X | ~ (f x) # (g x)} =>
    proj1_sig p1 # proj1_sig p2
}.
Proof.
  - easy.
  - easy.
  - intros [x Hx] [y Hy] [z Hz]; cbn.
    now apply neq_cotrans.
Defined.

Definition Apartoid_equalize
  {X Y : Apartoid} (f g : ApartoidHom X Y) : ApartoidHom (Apartoid_equalizer f g) X.
Proof.
  exists (@proj1_sig _ _).
  now cbn.
Defined.

Lemma trick
  (X Y E' : Apartoid) (f g : Hom X Y)
  (e' : Hom E' X) (H : e' .> f == e' .> g)
  : E' -> Apartoid_equalizer f g.
Proof.
  intros x; cbn in *.
  now exists (e' x).
Defined.

Lemma Apartoid_factorize
  (X Y : Apartoid) (f g : Hom X Y)
  (E' : Apartoid) (e' : Hom E' X) (H : e' .> f == e' .> g)
  : ApartoidHom E' (Apartoid_equalizer f g).
Proof.
  exists (trick X Y E' f g e' H); cbn.
  now intros a1 a2 Hneq%reflect_neq.
Defined.

#[refine]
#[export]
Instance HasEqualizers_Apartoid : HasEqualizers ApartoidCat :=
{
  equalizer := @Apartoid_equalizer;
  equalize := @Apartoid_equalize;
  factorize := @Apartoid_factorize;
}.
Proof.
  intros A B f g; split; cbn.
  - now intros [a Ha]; cbn.
  - now intros E' e' Hneq x.
  - easy.
Defined.

Inductive ACN {A B : Apartoid} (f g : ApartoidHom A B) : B -> B -> Prop :=
| ACN_glue :
  forall b1 b2 : B, b1 # b2 ->
  (forall a1 a2 : A, b1 = f a1 /\ b2 = g a2 -> False) ->
    ACN f g b1 b2
| ACN_sym : forall b1 b2 : B, ACN f g b1 b2 -> ACN f g b2 b1.

#[refine]
#[export]
Instance Apartoid_coequalizer {A B : Apartoid} (f g : ApartoidHom A B) : Apartoid :=
{
  carrier := B;
  neq := ACN f g;
}.
Proof.
  - intros x1.
    pose (x2 := x1); assert (Heq : x1 = x2) by easy.
    change (~ ACN f g x1 x2); clearbody x2.
    induction 1; subst.
    + now apply neq_irrefl in H.
    + now apply IHACN.
  - now red; apply ACN_sym.
  - induction 1.
    + destruct (neq_cotrans _ _ z H).
      * left; constructor; [easy |].
Abort.

#[refine]
#[export]
Instance Apartoid_indexedCoproduct {J : Apartoid} (A : J -> Apartoid) : Apartoid :=
{
  carrier := {j : J & A j};
  neq := fun p1 p2 : {j : J & A j} => projT1 p1 # projT1 p2
}.
Proof.
  - now intros [x x']; auto.
  - now intros [x x'] [y y']; cbn; auto.
  - now intros [x x'] [y y'] [z z']; cbn; auto.
Defined.

Definition Apartoid_inj
  {J : Apartoid} (A : J -> Apartoid) (j : J) : ApartoidHom (A j) (Apartoid_indexedCoproduct A).
Proof.
  exists (fun a : A j => existT _ j a); cbn.
  intros a1 a2 Hneq.
  now apply neq_irrefl in Hneq.
Defined.

Definition Apartoid_indexedCopair
  {J : Apartoid} {A : J -> Apartoid}
  {X : Apartoid} (f : forall j : J, ApartoidHom (A j) X)
  : ApartoidHom (Apartoid_indexedCoproduct A) X.
Proof.
  exists (fun p : {j : J & A j} => f (projT1 p) (projT2 p)).
Abort.


Require Import ssreflect.
Require Export Arith.
Require Export Compare_dec.
Require Export Relations.
Require Import ssrnat ssrfun ssrbool eqtype seq choice.
Require Import ordtype finmap.
Require Import Utf8.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Open Scope SEQ.

Require Import TermEvar.

Arguments fst {A B} _.
Notation type := term.

(** Typing local context *)
Definition ctx := list type.

Notation odef := (option term * type)%type.
Definition evar_context := list (ident * odef).

Inductive evar_decl : Set :=
  { evar_ctx : evar_context;
    evar_body : option term;
    evar_concl : type }.

Fixpoint closedn (n : nat) (t : term) : bool :=
  match t with
    | Srt s => true
    | Bnd n' => n' < n
    | Ref i => true
    | Op b t u => closedn n t && closedn (is_abs b + 1) u
    | Evar k l => all (closedn n) l
  end.

Definition closed := closedn 0.

Fixpoint fvs (t : term) : list ident :=
  match t with
    | Srt s => [::]
    | Bnd n' => [::]
    | Ref i => [:: i]
    | Op b t u => fvs t ++ fvs u
    | Evar k l => flatten (map fvs l)
  end.

Definition ctx_fvs (ctx : evar_context) := map fst ctx.

Fixpoint fevs (t : term) : list nat :=
  match t with
    | Srt s => [::]
    | Bnd n' => [::]
    | Ref i => [::]
    | Op b t u => fevs t ++ fevs u
    | Evar k l => k :: flatten (map fevs l)
  end.

Definition ctx_fevs (ctx : evar_context) := foldr (λ x acc,
            let: (id, (b, ty)) := x in
              acc ++ oapp fevs [::] b ++ fevs ty) [::] ctx.

Definition evar_decl_fevs evd :=
  ctx_fevs evd.(evar_ctx) ++
  fevs evd.(evar_concl) ++
  oapp fevs [::] evd.(evar_body).

Definition wf_term (t : term) :=
  closed t.

Definition incl {A : eqType} (l l' : seq A) :=
  all (λ x, x \in l') l.

Definition wf_open_term (ctx : evar_context) (t : term) :=
  incl (fvs t) (ctx_fvs ctx).

Definition owf_open_term (ctx : evar_context) (b : option term) :=
  oapp (wf_open_term ctx) true b.

Definition wf_evar_context (ctx : evar_context) :=
  let: (wfctx, b) :=
     foldr (λ x acc,
            let: (wfctx, wf) := acc in
            let: (id, (b, ty)) := x in
              (x :: wfctx, wf && wf_open_term wfctx ty &&
                              owf_open_term wfctx b))
           ([::], true) ctx
  in b.

Definition wf_evar_decl evd :=
  let ctx := evd.(evar_ctx) in
  wf_evar_context ctx &&
  owf_open_term ctx evd.(evar_body) &&
  wf_open_term ctx evd.(evar_concl).

Import Order.Theory.
Notation evar_map := {fmap nat -> evar_decl}.

Notation named_ctx := evar_context.
Notation local_ctx := (seq odef).

Notation def_elem := (None, Srt prop).

Notation ctxs := (evar_map * named_ctx * local_ctx)%type.

Definition get_emap (c : ctxs) : evar_map := c.1.1.
Definition get_nc (c : ctxs) : named_ctx := c.1.2.
Definition get_lc (c : ctxs) : local_ctx := c.2.

Fixpoint oget_def (N : named_ctx) (i : ident) : option odef :=
  match N with
  | [::] => None
  | ((j, e) :: N') => if i == j then Some e else oget_def N' i
  end.

Definition get_def (d : odef) (N : named_ctx) (i : ident) : odef :=
  if oget_def N i is Some def then def else d.

Notation "'[db' s ']' t" := (subst s t) (at level 20).

Reserved Notation "'[n' x ':=' t1 ']' t2" (at level 40).

Fixpoint nsubs x t1 t2 :=
  match t2 with
    | Srt _ | Bnd _ => t2
    | Ref i => if i == x then t1 else t2
    | Op b t u =>
      Op b ([n x:=t1]t) ([n x:=t1]u)
    | Evar n l => Evar n (map (nsubs x t1) l)
  end
where "'[n' x ':=' t1 ']' t2" := (nsubs x t1 t2).

Fixpoint nmulti_subs (n : named_ctx) (s : seq term) t :=
  match n, s with
    | [::], [::] => Some t
    | ((x, _) :: n'), (t' :: s') => nmulti_subs n' s' ([n x:=t']t)
    | _ , _ => None
  end.

Notation "'[n' l '::=' t1 ']' t2" := (nmulti_subs l t1 t2) (at level 40).

Reserved Notation "E '||-' t '~' T" (at level 40).
Reserved Notation "E '||-*' s '~' c" (at level 40).

Reserved Notation "E '||-' t1 '-->' t2" (at level 40).

Inductive red1 : ctxs -> term -> term -> Prop :=
  | beta C M N T : C ||- App (Abs T M) N --> subst N M
  | deltaN E N L i t T :
      oget_def N i = Some (Some t, T) ->
      (E, N, L) ||- Ref i --> t
  | deltaL E N L n t T :
      n < size L -> nth def_elem L n = (Some t, T) ->
      (E, N, L) ||- Bnd n --> t
  | deltaE E N L e s d b b':
      E.[e] = Some d -> d.(evar_body) = Some b ->
      [n d.(evar_ctx) ::= s]b = Some b' ->
      (E, N, L) ||- Evar e s --> b'
  | red1l (b : op) C M M' N :
      C ||- M --> M' ->
      C ||- b M N --> b M' N
  | red1r (b : op) C M M' N :
      C ||- M --> M' ->
      C ||- b N M --> b N M'
where  "E '||-' t1 '-->' t2" := (red1 E t1 t2).

Inductive conv (E : (evar_map * named_ctx * local_ctx)) (M : term) : term -> Prop :=
  | conv_refl : conv E M M
  | conv_trans1 P N : conv E M P -> red1 E P N -> conv E M N
  | conv_trans1V P N : conv E M P -> red1 E N P -> conv E M N.

Notation "E '||-' t '=?=' u" := (conv E t u) (at level 40).

Definition bhas_type (C : ctxs) (t1 t2 : term) :=
  let: (E, N, L) := C in
  match t1, t2 with
  | Srt prop, Srt (kind _) => true
  | Srt (kind i), Srt (kind j) => i <= j
  | Bnd i, _ => if i < size L then t2 == (nth def_elem L i).2
                else false
  | Ref i, _ => if i \in map fst N then t2 == (get_def def_elem N i).2
                else false
  | _, _ => false
  end.

(* TODO: missing acyclic test in evar_map *)
Inductive has_type (E : evar_map) (N : named_ctx) (L : local_ctx) (t : term) (T : type) : Prop :=
| TBase (HT : bhas_type (E, N, L) t T)
| TProd1 U V s
    (E1: t = Op Prod U V) (E2: T = Srt prop)
    (HT: has_type E N L T (Srt s))
    (HU: has_type E N ((None, T) :: L) U (Srt prop))
(*| TProd2 E N L T U i j k:
    i <= k -> j <= k ->
    (E, N, L) ||- T ~ Srt (kind i) ->
    (E, N, (None, T) :: L) ||- U ~ Srt (kind j) ->
    (E, N, L) ||- Op Prod T U ~ Srt (kind k)
| TLam E N L T t U s1 s2:
    (E, N, L) ||- T ~ s1 ->
    (E, N, (None, T) :: L) ||- t ~ U ->
    (E, N, L) ||- Op Prod T U ~ s2 ->
    (E, N, L) ||- Op Abs T t ~ Op Prod T U
| TApp C t u T U:
    C ||- t ~ Op Prod U T ->
    C ||- u ~ U ->
    C ||- Op App t u ~ [db u]T
| TEvar E N L e d s T:
    E.[e] = Some d ->
    (E, N, L) ||-* s ~ d.(evar_ctx) ->
    [n d.(evar_ctx) ::= s](d.(evar_concl)) = Some T ->
    (E, N, L) ||- Evar e s ~ T
| TConv E t T U :
    E ||- t ~ T ->
    E ||- T =?= U ->
    E ||- t ~ U

with has_types : (evar_map * named_ctx * local_ctx) -> seq term -> named_ctx -> Prop :=
| CTId E : E ||-* [::] ~ [::]
| CTAss E x t T T' s N :
    E ||-* s ~ N ->
    [n N ::= s]T = Some T' ->
    E ||- t ~ T' ->
    E ||-* (t :: s) ~ ((x, (None, T)) :: N)
| CTDef E x t t' T T' s N :
    E ||-* s ~ N ->
    [n N ::= s]T = Some T' ->
    E ||- t ~ T' ->
    E ||- t =?= t' ->
    E ||-* (t :: s) ~ ((x, (Some t', T)) :: N)
*)
.
(* where "< E , N , L > '||-' t '~' T" := (has_type E N L t T). *)
(* and "E '||-*' s '~' N" := (has_types E s N). *)

Definition wfE E := forall k v t,
  E.[k] = Some v ->
  (v.(evar_body) = None ->
   exists s, has_type E v.(evar_ctx) [::] v.(evar_concl) (Srt s)) /\
  (v.(evar_body) = Some t ->
   has_type E v.(evar_ctx) [::] t v.(evar_concl)).

Inductive wfN : evar_map -> named_ctx -> Prop :=
| WFN0 E : wfN E [::]
| WFNAss E (N : named_ctx) (x : ident) T s:
    x \notin (map fst N) ->
    has_type E N [::] T (Srt s) ->
    wfN E ((x, (None, T)) :: N)
| WFNDef E (N : named_ctx) (x : ident) t T:
    x \notin (map fst N) ->
    has_type E N [::] t T ->
    wfN E ((x, (Some t, T)) :: N).

Inductive wfL : (evar_map * named_ctx) -> local_ctx -> Prop :=
| WFL0 E N : wfL (E, N) [::]
| WFLAss E N L T s:
    has_type E N L T (Srt s) ->
    wfL (E, N) ((None, T) :: L)
| WFLDef E N L t T:
    has_type E N L t T ->
    wfL (E, N) ((Some t, T) :: L).

Definition WF E N L := wfE E /\ wfN E N /\ wfL (E, N) L.

Lemma get_def_weak d N i i' e : i != i' ->
  get_def d N i = get_def d ((i', e) :: N) i.
Proof. by move=>H; rewrite {2}/get_def /= (negbTE H). Qed.
Arguments get_def_weak [_ _ _] i' e _.

Lemma in_not_in (T : eqType) x y (s : seq T) : x \in s -> y \notin s -> x != y.
Proof.
  elim:s =>// z s IH.
  rewrite !inE.
  case/orP.
  - move/eqP=>->.
    rewrite Bool.negb_orb.
    by case/andP; rewrite eq_sym.
  move/IH {IH}=>IH.
  rewrite Bool.negb_orb.
  by case/andP=>_; move/IH.
Qed.

Lemma bhas_type_weakN E N L t1 t2 i V:
  i \notin (map fst N) ->
  bhas_type (E, N, L) t1 t2 ->
  bhas_type (E, (i, V) :: N, L) t1 t2.
Proof.
  elim: t1; try by [].
  move=>i' H1 /=.
  case H: (_ \in _); last by [].
  have ii': i' != i by rewrite (in_not_in H).
  rewrite -get_def_weak; last by [].
  by rewrite inE H orbT.
Qed.

Lemma weakeningN E0 N0 L0 t0 T0 i v :
  has_type E0 N0 L0 t0 T0 ->
  forall Ni : i \notin (map fst N0),
  has_type E0 ((i, v) :: N0) L0 t0 T0.
Proof.
  elim;
  intros; subst.
  - apply: TBase.
    by apply: bhas_type_weakN.
  - apply: TProd1; try by [].
    + by eapply H.
    by apply: H0.

(* UNTIL HERE *)

Theorem progress E t u T :
  E ||- t ~ T ->
  E ||- t --> u ->
  E ||- u ~ T.
Proof.
elim; (try by (intros;
              match goal with
                  x : _ ||- _ --> _ |- _ => inversion x
              end)); move: E=>_.
- move=>E N L i.
  move=>H1 H2 H3.
  inversion H3; subst.
  rewrite H8.
  rewrite H8 in H2.
  rewrite /= in H2 *.
  inversion H2; subst.


(** **********************************************************
Contents:
        - Definition of the Kleisli category of a monad.
        - The canonical adjunction between a category C and the Kleisli
          category of a monad on C.
TODO:
        - Show that this definition is equivalent to the Kleisli category of a
          relative monad with respect to the identity functor.

Written by: Brandon Doherty (July 2018)
************************************************************)

Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Adjunctions.Core.
Require Import UniMath.CategoryTheory.Monads.Monads.
Require Import UniMath.CategoryTheory.whiskering.

Local Open Scope cat.

Section Monad_Lemmas.

(*A couple of lemmas involving bind*)

Lemma bind_comp_η {C : category} {T : Monad C} {a b : C} (f : C ⟦a , b⟧) :
  bind (f · (η T) b) = # T f.
Proof.
  unfold bind; rewrite functor_comp.
  rewrite <- assoc.
  rewrite <- id_right.
  apply cancel_precomposition.
  apply bind_η.
Qed.

Lemma bind_identity {C : category} {T : Monad C} (a : C) :
  bind (identity (T a)) = (μ T) a.
Proof.
  unfold bind.
  rewrite functor_id.
  apply id_left.
Qed.

End Monad_Lemmas.

Section Kleisli_Categories.

Definition Kleisli_precat_ob_mor_monad {C : precategory_data} (T : Monad_data C) :
  precategory_ob_mor.
Proof.
  use tpair.
  - exact (ob C).
  - intros X Y.
    exact (X --> T Y).
Defined.

Definition Kleisli_precat_data_monad {C : precategory_data} (T : Monad_data C) :
  precategory_data.
Proof.
  use make_precategory_data.
  - exact (Kleisli_precat_ob_mor_monad T).
  - intro c.
    exact (η T c).
  - intros a b c f g.
    exact (f · (bind g)).
Defined.

Lemma Kleisli_precat_monad_is_precat {C : category} (T : Monad C) :
  is_precategory (Kleisli_precat_data_monad T).
Proof.
  apply is_precategory_one_assoc_to_two.
  split.
  - split.
    + intros a b f.
      unfold identity; unfold compose; cbn.
      apply η_bind.
    + intros a b f.
      unfold identity; unfold compose; cbn.
      rewrite <- id_right.
      apply cancel_precomposition.
      apply bind_η.
  - intros a b c d f g h.
    unfold compose; cbn.
    rewrite <- bind_bind.
    apply assoc.
Defined.

Definition Kleisli_precat_monad {C : category} (T : Monad C) : precategory := (Kleisli_precat_data_monad T,,Kleisli_precat_monad_is_precat T).

Lemma Kleisli_precat_monad_has_homsets {C : category} (T : Monad C)
      (hs : has_homsets C) : has_homsets (Kleisli_precat_data_monad T).
Proof.
  intros a b.
  apply hs.
Defined.

Definition Kleisli_cat_monad {C : category} (T : Monad C): category
  := (Kleisli_precat_monad T,, Kleisli_precat_monad_has_homsets T
  (homset_property C)).

(*TODO: show that this is equivalent to the definition of the Kleisli category of a relative monad with respect to the identity*)

(*The canonical adjunction between C and the Kleisli category of a monad on C*)

Definition Left_Kleisli_functor_data {C : category} (T: Monad C) :
  functor_data C (Kleisli_precat_monad T).
Proof.
  use make_functor_data.
  - apply idfun.
  - intros a b f; unfold idfun.
    exact (f · (η T) b).
Defined.

Lemma Left_Kleisli_is_functor {C : category} (T: Monad C) :
  is_functor (Left_Kleisli_functor_data T).
Proof.
  split.
  - intro a.
    unfold Left_Kleisli_functor_data; cbn.
    apply id_left.
  - intros a b c f g.
    unfold Left_Kleisli_functor_data; cbn.
    do 2 (rewrite <- assoc).
    apply cancel_precomposition.
    apply pathsinv0.
    apply η_bind.
Defined.

Definition Left_Kleisli_functor {C : category} (T : Monad C) :
  functor C (Kleisli_cat_monad T)
  := (Left_Kleisli_functor_data T,,Left_Kleisli_is_functor T).

Definition Right_Kleisli_functor_data {C : category} (T : Monad C) :
  functor_data (Kleisli_cat_monad T) C.
Proof.
  use make_functor_data.
  - exact T.
  - intros a b.
    apply bind.
Defined.

Lemma Right_Kleisli_is_functor {C : category} (T : Monad C) :
  is_functor (Right_Kleisli_functor_data T).
Proof.
  use tpair.
  - intro a.
    unfold Right_Kleisli_functor_data; unfold identity;
    unfold functor_on_morphisms; cbn.
    apply bind_η.
  - intros a b c f g; cbn.
    apply pathsinv0.
    apply bind_bind.
Defined.

Definition Right_Kleisli_functor {C : category} (T : Monad C) :
  functor (Kleisli_cat_monad T) C
  := (Right_Kleisli_functor_data T,,Right_Kleisli_is_functor T).

(*Composition of the left and right Kleisli functors is equal to T as a functor*)

Definition Kleisli_functor_left_right_compose {C : category} (T : Monad C) :
  (Left_Kleisli_functor T) ∙ (Right_Kleisli_functor T) = T.
Proof.
  use functor_eq.
  - apply homset_property.
  - use functor_data_eq_from_nat_trans.
    + intro a; apply idpath.
    + intros a b f; cbn.
      rewrite id_right.
      rewrite id_left.
      apply bind_comp_η.
Defined.

(*Showing that these functors are adjoints*)

Definition Kleisli_homset_iso {C : category} (T : Monad C) : natural_hom_weq (Left_Kleisli_functor T) (Right_Kleisli_functor T).
Proof.
  use tpair.
  - intros a b; cbn.
    apply idweq.
  - cbn; split.
    + intros.
      rewrite <- assoc.
      apply cancel_precomposition.
      apply η_bind.
    + intros; apply idpath.
Defined.

Definition Kleisli_functors_are_adjoints {C : category} (T : Monad C) : are_adjoints (Left_Kleisli_functor T) (Right_Kleisli_functor T) := adj_from_nathomweq (Kleisli_homset_iso T).

Definition Left_Kleisli_is_left_adjoint {C : category} (T : Monad C)
  : is_left_adjoint (Left_Kleisli_functor T)
    := are_adjoints_to_is_left_adjoint (Left_Kleisli_functor T)
    (Right_Kleisli_functor T) (Kleisli_functors_are_adjoints T).

Definition Right_Kleisli_is_right_adjoint {C : category} (T : Monad C)
  : is_right_adjoint (Right_Kleisli_functor T)
    := are_adjoints_to_is_right_adjoint (Left_Kleisli_functor T)
    (Right_Kleisli_functor T) (Kleisli_functors_are_adjoints T).

Theorem Kleisli_adjunction_monad_eq {C : category} (T : Monad C)  : Monad_from_adjunction (Kleisli_functors_are_adjoints T) = T.
Proof.
  use Monad_eq_raw_data.
  apply total2_paths_equiv; use tpair.
  + cbn.
    apply idpath.
  + cbn.
    apply total2_paths_equiv; use tpair.
    * cbn.
      apply total2_paths_equiv; use tpair.
      -- cbn.
         do 2 (apply funextsec; intro).
         apply funextfun; intro f.
         cbn.
         apply bind_comp_η.
      -- cbn.
         rewrite transportf_const.
         cbn.
         apply funextsec; intro c.
         apply bind_identity.
    * cbn.
      rewrite transportf_const.
      apply idpath.
Defined.

End Kleisli_Categories.

(**
 Two useful laws
 *)
Definition η_η_bind
           {C : category}
           (M : Monad C)
           (x : C)
  : η M x · η M _ · bind (identity _) = η M x.
Proof.
  rewrite bind_identity.
  rewrite !assoc'.
  refine (_ @ id_right _).
  apply maponpaths.
  apply Monad_law1.
Qed.

Definition η_bind_bind
           {C : category}
           (M : Monad C)
           (x : C)
  : η M (M(M x)) · bind (identity _) · bind (identity _)
    =
    μ M x · η M (M x) · bind (identity _).
Proof.
  rewrite !bind_identity.
  rewrite Monad_law1, id_left.
  rewrite !assoc'.
  refine (!_).
  etrans.
  {
    apply maponpaths.
    apply Monad_law1.
  }
  apply id_right.
Qed.

(** The universal mapping property of the Kleisli category *)
Section KleisliUMP1.
  Context {C₁ C₂ : category}
          (m : Monad C₁)
          (F : C₁ ⟶ C₂)
          (γ : m ∙ F ⟹ F)
          (p₁ : ∏ (x : C₁), #F (η m x) · γ x = identity _)
          (p₂ : ∏ (x : C₁), γ _ · γ x = #F (μ m x) · γ x).

  Definition functor_from_kleisli_cat_monad_data
    : functor_data (Kleisli_cat_monad m) C₂.
  Proof.
    use make_functor_data.
    - exact F.
    - exact (λ x y f, #F f · γ y).
  Defined.

  Definition functor_from_kleisli_cat_monad_is_functor
    : is_functor functor_from_kleisli_cat_monad_data.
  Proof.
    split.
    - intro x ; cbn.
      apply p₁.
    - intros x y z f g ; cbn ; unfold bind.
      rewrite !functor_comp.
      rewrite !assoc'.
      apply maponpaths.
      etrans.
      {
        apply maponpaths.
        exact (!(p₂ z)).
      }
      rewrite !assoc.
      apply maponpaths_2.
      exact (nat_trans_ax γ _ _ g).
  Qed.

  Definition functor_from_kleisli_cat_monad
    : Kleisli_cat_monad m ⟶ C₂.
  Proof.
    use make_functor.
    - exact functor_from_kleisli_cat_monad_data.
    - exact functor_from_kleisli_cat_monad_is_functor.
  Defined.

  Definition functor_from_kleisli_cat_monad_nat_trans
    : Left_Kleisli_functor m ∙ functor_from_kleisli_cat_monad ⟹ F.
  Proof.
    use make_nat_trans.
    - exact (λ x, identity _).
    - abstract
        (intros x y f ; cbn ;
         rewrite id_right, id_left ;
         rewrite functor_comp ;
         rewrite !assoc' ;
         etrans ;
           [ apply maponpaths ;
             exact (p₁ y)
           | ] ;
         apply id_right).
  Defined.

  Definition functor_from_kleisli_cat_monad_nat_trans_is_z_iso
    : is_nat_z_iso functor_from_kleisli_cat_monad_nat_trans.
  Proof.
    intro x.
    apply is_z_isomorphism_identity.
  Defined.
End KleisliUMP1.

Definition kleisli_monad_nat_trans
           {C : category}
           (m : Monad C)
  : m ∙ Left_Kleisli_functor m ⟹ Left_Kleisli_functor m.
Proof.
  use make_nat_trans.
  - exact (λ x, identity (m x)).
  - abstract
      (intros x y f ; cbn ; unfold bind ;
       rewrite functor_id, !id_left ;
       rewrite functor_comp ;
       rewrite !assoc' ;
       apply maponpaths ;
       exact (Monad_law1 _ @ !(Monad_law2 _))).
Defined.

Section KleisliUMP2.
  Context {C₁ C₂ : category}
          (m : Monad C₁)
          {G₁ G₂ : Kleisli_cat_monad m ⟶ C₂}
          (α : Left_Kleisli_functor m ∙ G₁ ⟹ Left_Kleisli_functor m ∙ G₂)
          (p : ∏ (x : C₁),
               #G₁ (kleisli_monad_nat_trans m x) · α x
               =
               α (m x) · # G₂ (kleisli_monad_nat_trans m x)).

  Definition nat_trans_from_kleisli_cat_monad_is_nat_trans
    : is_nat_trans G₁ G₂ (λ x, α x).
  Proof.
    intros x y f.
    pose (maponpaths (λ z, z · # G₂ (identity (m y))) (nat_trans_ax α _ _ f)) as q.
    cbn in q.
    refine (_ @ q @ _) ; clear q.
    - rewrite !assoc'.
      refine (!_).
      etrans.
      {
        apply maponpaths.
        exact (!(p y)).
      }
      cbn.
      rewrite !assoc.
      apply maponpaths_2.
      refine (!(functor_comp G₁ _ _) @ _).
      apply maponpaths.
      cbn ; unfold bind.
      rewrite functor_id, id_left.
      rewrite !assoc'.
      refine (_ @ id_right _).
      apply maponpaths.
      apply Monad_law1.
    - rewrite !assoc'.
      apply maponpaths.
      refine (!(functor_comp G₂ _ _) @ _).
      apply maponpaths.
      cbn ; unfold bind.
      rewrite functor_id, id_left.
      rewrite !assoc'.
      refine (_ @ id_right _).
      apply maponpaths.
      apply Monad_law1.
  Qed.

  Definition nat_trans_from_kleisli_cat_monad
    : G₁ ⟹ G₂.
  Proof.
    use make_nat_trans.
    - exact (λ x, α x).
    - exact nat_trans_from_kleisli_cat_monad_is_nat_trans.
  Defined.

  Definition pre_whisker_nat_trans_from_kleisli_cat_monad
    : pre_whisker _ nat_trans_from_kleisli_cat_monad = α.
  Proof.
    use nat_trans_eq.
    {
      apply homset_property.
    }
    intro ; cbn.
    apply idpath.
  Qed.

  Definition nat_trans_from_kleisli_cat_monad_unique
             {β₁ β₂ : G₁ ⟹ G₂}
             (q₁ : pre_whisker _ β₁ = α)
             (q₂ : pre_whisker _ β₂ = α)
    : β₁ = β₂.
  Proof.
    use nat_trans_eq.
    {
      apply homset_property.
    }
    intro ; cbn.
    exact (nat_trans_eq_pointwise q₁ x @ !(nat_trans_eq_pointwise q₂ x)).
  Qed.
End KleisliUMP2.


From iris.algebra Require Import frac.
From iris.bi Require Export bi.
From iris.base_logic Require Export bi.
From iris.prelude Require Import options.
Import bi.bi base_logic.bi.uPred.

(** Derived laws for Iris-specific primitive connectives (own, valid).
    This file does NOT unseal! *)

Module uPred.
Section derived.
  Context {M : ucmra}.
  Implicit Types φ : Prop.
  Implicit Types P Q : uPred M.
  Implicit Types A : Type.

  (* Force implicit argument M *)
  Notation "P ⊢ Q" := (bi_entails (PROP:=uPredI M) P Q).
  Notation "P ⊣⊢ Q" := (equiv (A:=uPredI M) P%I Q%I).

  (** Propers *)
  Global Instance ownM_proper: Proper ((≡) ==> (⊣⊢)) (@uPred_ownM M) := ne_proper _.
  Global Instance cmra_valid_proper {A : cmra} :
    Proper ((≡) ==> (⊣⊢)) (@uPred_cmra_valid M A) := ne_proper _.

  (** Own and valid derived *)
  Lemma persistently_cmra_valid_1 {A : cmra} (a : A) : ✓ a ⊢@{uPredI M} <pers> (✓ a).
  Proof. by rewrite {1}plainly_cmra_valid_1 plainly_elim_persistently. Qed.
  Lemma intuitionistically_ownM (a : M) : CoreId a → □ uPred_ownM a ⊣⊢ uPred_ownM a.
  Proof.
    rewrite /bi_intuitionistically affine_affinely=>?; apply (anti_symm _);
      [by rewrite persistently_elim|].
    by rewrite {1}persistently_ownM_core core_id_core.
  Qed.
  Lemma ownM_invalid (a : M) : ¬ ✓{0} a → uPred_ownM a ⊢ False.
  Proof. by intros; rewrite ownM_valid cmra_valid_elim. Qed.
  Global Instance ownM_mono : Proper (flip (≼) ==> (⊢)) (@uPred_ownM M).
  Proof. intros a b [b' ->]. by rewrite ownM_op sep_elim_l. Qed.
  Lemma ownM_unit' : uPred_ownM ε ⊣⊢ True.
  Proof. apply (anti_symm _); first by apply pure_intro. apply ownM_unit. Qed.
  Lemma plainly_cmra_valid {A : cmra} (a : A) : ■ ✓ a ⊣⊢ ✓ a.
  Proof. apply (anti_symm _), plainly_cmra_valid_1. apply plainly_elim, _. Qed.
  Lemma intuitionistically_cmra_valid {A : cmra} (a : A) : □ ✓ a ⊣⊢ ✓ a.
  Proof.
    rewrite /bi_intuitionistically affine_affinely. intros; apply (anti_symm _);
      first by rewrite persistently_elim.
    apply:persistently_cmra_valid_1.
  Qed.
  Lemma bupd_ownM_update x y : x ~~> y → uPred_ownM x ⊢ |==> uPred_ownM y.
  Proof.
    intros; rewrite (bupd_ownM_updateP _ (y =.)); last by apply cmra_update_updateP.
    by apply bupd_mono, exist_elim=> y'; apply pure_elim_l=> ->.
  Qed.

  (** Timeless instances *)
  Global Instance valid_timeless {A : cmra} `{!CmraDiscrete A} (a : A) :
    Timeless (✓ a : uPred M)%I.
  Proof. rewrite /Timeless !discrete_valid. apply (timeless _). Qed.
  Global Instance ownM_timeless (a : M) : Discrete a → Timeless (uPred_ownM a).
  Proof.
    intros ?. rewrite /Timeless later_ownM. apply exist_elim=> b.
    rewrite (timeless (a≡b)) (except_0_intro (uPred_ownM b)) -except_0_and.
    apply except_0_mono. rewrite internal_eq_sym.
    apply (internal_eq_rewrite' b a (uPred_ownM) _);
      auto using and_elim_l, and_elim_r.
  Qed.

  (** Plainness *)
  Global Instance cmra_valid_plain {A : cmra} (a : A) :
    Plain (✓ a : uPred M)%I.
  Proof. rewrite /Persistent. apply plainly_cmra_valid_1. Qed.

  (** Persistence *)
  Global Instance cmra_valid_persistent {A : cmra} (a : A) :
    Persistent (✓ a : uPred M)%I.
  Proof. rewrite /Persistent. apply persistently_cmra_valid_1. Qed.
  Global Instance ownM_persistent a : CoreId a → Persistent (@uPred_ownM M a).
  Proof.
    intros. rewrite /Persistent -{2}(core_id_core a). apply persistently_ownM_core.
  Qed.

  (** For big ops *)
  Global Instance uPred_ownM_sep_homomorphism :
    MonoidHomomorphism op uPred_sep (≡) (@uPred_ownM M).
  Proof. split; [split|]; try apply _; [apply ownM_op | apply ownM_unit']. Qed.

  (** Derive [NonExpansive]/[Contractive] from an internal statement *)
  Lemma ne_internal_eq {A B : ofe} (f : A → B) :
    NonExpansive f ↔ ∀ x1 x2, x1 ≡ x2 ⊢ f x1 ≡ f x2.
  Proof.
    split; [apply f_equivI|].
    intros Hf n x1 x2. by eapply internal_eq_entails.
  Qed.

  Lemma ne_2_internal_eq {A B C : ofe} (f : A → B → C) :
    NonExpansive2 f ↔ ∀ x1 x2 y1 y2, x1 ≡ x2 ∧ y1 ≡ y2 ⊢ f x1 y1 ≡ f x2 y2.
  Proof.
    split.
    - intros Hf x1 x2 y1 y2.
      change ((x1,y1).1 ≡ (x2,y2).1 ∧ (x1,y1).2 ≡ (x2,y2).2
        ⊢ uncurry f (x1,y1) ≡ uncurry f (x2,y2)).
      rewrite -prod_equivI. apply ne_internal_eq. solve_proper.
    - intros Hf n x1 x2 Hx y1 y2 Hy.
      change (uncurry f (x1,y1) ≡{n}≡ uncurry f (x2,y2)).
      apply ne_internal_eq; [|done].
      intros [??] [??]. rewrite prod_equivI. apply Hf.
  Qed.

  Lemma contractive_internal_eq {A B : ofe} (f : A → B) :
    Contractive f ↔ ∀ x1 x2, ▷ (x1 ≡ x2) ⊢ f x1 ≡ f x2.
  Proof.
    split; [apply f_equivI_contractive|].
    intros Hf n x1 x2 Hx. specialize (Hf x1 x2).
    rewrite -later_equivI internal_eq_entails in Hf. apply Hf. by f_contractive.
  Qed.

  (** Soundness statement for our modalities: facts derived under modalities in
  the empty context also without the modalities.
  For basic updates, soundness only holds for plain propositions. *)
  Lemma bupd_soundness P `{!Plain P} : (⊢ |==> P) → ⊢ P.
  Proof. rewrite bupd_plain. done. Qed.

  Lemma laterN_soundness P n : (⊢ ▷^n P) → ⊢ P.
  Proof. induction n; eauto using later_soundness. Qed.

  (** As pure demonstration, we also show that this holds for an arbitrary nesting
  of modalities. We have to do a bit of work to be able to state this theorem
  though. *)
  Inductive modality := MBUpd | MLater | MPersistently | MPlainly.
  Definition denote_modality (m : modality) : uPred M → uPred M :=
    match m with
    | MBUpd => bupd
    | MLater => bi_later
    | MPersistently => bi_persistently
    | MPlainly => plainly
    end.
  Definition denote_modalities (ms : list modality) : uPred M → uPred M :=
    λ P, foldr denote_modality P ms.

  (** Now we can state and prove 'soundness under arbitrary modalities' for plain
  propositions. This is probably not a lemma you want to actually use. *)
  Corollary modal_soundness P `{!Plain P} (ms : list modality) :
    (⊢ denote_modalities ms P) → ⊢ P.
  Proof.
    intros H. apply (laterN_soundness _ (length ms)).
    move: H. apply bi_emp_valid_mono.
    induction ms as [|m ms IH]; first done; simpl.
    destruct m; simpl; rewrite IH.
    - rewrite -later_intro. apply bupd_plain. apply _.
    - done.
    - rewrite -later_intro persistently_elim. done.
    - rewrite -later_intro plainly_elim. done.
  Qed.

  (** Consistency: one cannot deive [False] in the logic, not even under
  modalities. Again this is just for demonstration and probably not practically
  useful. *)
  Corollary consistency : ¬ ⊢@{uPredI M} False.
  Proof. intros H. by eapply pure_soundness. Qed.
End derived.
End uPred.


From sflib Require Import sflib.
From Paco Require Import paco.
From Fairness Require Import ITreeLib IProp IPM ModSim ModSimNat PCM Weakest Concurrency ModAdequacy Axioms.
Require Import Coq.Logic.PropExtensionality.
From Fairness Require PCMLarge.
Require Import Program.

Set Implicit Arguments.

Lemma list_of_numbering_nm_wf_pair A B (l0: list A) (l1: list B)
      (LEN: List.length l0 = List.length l1):
  nm_wf_pair (NatMapP.of_list (numbering l0)) (NatMapP.of_list (numbering l1)).
Proof.
  unfold numbering. generalize 0.
  revert l1 LEN. induction l0; ss; i.
  { destruct l1; ss. apply nm_wf_pair_empty_empty_eq. }
  { destruct l1; ss. inv LEN. ss.
    unfold NatMapP.uncurry. ss. eapply nm_wf_pair_add. eauto. }
Qed.

Lemma prog2ths_nm_wf_pair md0 md1 c:
  nm_wf_pair (prog2ths md0 c) (prog2ths md1 c).
Proof.
  eapply list_of_numbering_nm_wf_pair.
  repeat rewrite map_length. auto.
Qed.

Lemma key_set_idempotent (m: NatMap.t unit)
  :
  key_set m = m.
Proof.
  pattern m. revert m. eapply nm_ind.
  { apply key_set_empty_empty_eq. }
  i. destruct v. rewrite key_set_pull_add_eq.
  f_equal. auto.
Qed.

Section DISJOINTWF.
  Context `{Σ: GRA.t}.

  Definition disjoint_GRA (r0 r1: Σ): Prop :=
    forall n, r0 n = URA.unit \/ r1 n = URA.unit.

  Definition disjoint_GRA_sym r0 r1
             (DISJ: disjoint_GRA r0 r1)
    :
    disjoint_GRA r1 r0.
  Proof.
    ii. exploit DISJ; auto. i. des; eauto.
  Qed.

  Definition disjoint_GRA_unit_r r
    :
    disjoint_GRA r URA.unit.
  Proof.
    ii. auto.
  Qed.

  Definition disjoint_GRA_unit_l r
    :
    disjoint_GRA URA.unit r.
  Proof.
    ii. auto.
  Qed.

  Lemma disjoint_GRA_dist_r r0 r1 r2
        (DISJ0: disjoint_GRA r0 r1)
        (DISJ1: disjoint_GRA r0 r2)
    :
    disjoint_GRA r0 (r1 ⋅ r2).
  Proof.
    Local Transparent GRA.to_URA.
    ii. hexploit (DISJ0 n); auto. i.
    hexploit (DISJ1 n); auto. i. des; auto.
    right. rewrite URA.unfold_add. ss.
    rewrite H. rewrite H0. apply URA.unit_id.
  Qed.

  Lemma disjoint_GRA_dist_l r0 r1 r2
        (DISJ0: disjoint_GRA r0 r1)
        (DISJ1: disjoint_GRA r0 r2)
    :
    disjoint_GRA (r1 ⋅ r2) r0.
  Proof.
    eapply disjoint_GRA_sym. eapply disjoint_GRA_dist_r; auto.
  Qed.

  Lemma disjoint_GRA_embed M0 M1
        `{ING0: @GRA.inG M0 Σ}
        `{ING1: @GRA.inG M1 Σ}
        (r0: M0) (r1: M1)
        (DIFF: ING0.(GRA.inG_id) <> ING1.(GRA.inG_id))
    :
    disjoint_GRA (GRA.embed r0) (GRA.embed r1).
  Proof.
    Local Transparent GRA.to_URA.
    ii. revert r0 r1. dependent destruction ING0.
    dependent destruction ING1.
    ss. unfold GRA.embed. des_ifs; ss; auto.
    i. dependent destruction e. ss.
  Qed.

  Lemma res_wf_disjoint (r0 r1: Σ)
        (WF0: URA.wf r0)
        (WF1: URA.wf r1)
        (DISJ: disjoint_GRA r0 r1)
    :
    URA.wf (r0 ⋅ r1).
  Proof.
    Local Transparent GRA.to_URA.
    ur. i. ur in WF0. ur in WF1.
    specialize (WF0 k). specialize (WF1 k).
    exploit DISJ. i. des.
    { rewrite x0. rewrite URA.unit_idl. auto. }
    { rewrite x0. rewrite URA.unit_id. auto. }
  Qed.
End DISJOINTWF.

Ltac disj_tac :=
  try
    match goal with
    | |- disjoint_GRA (@URA.add _ _ _) _ =>
        eapply disjoint_GRA_dist_l;[disj_tac|disj_tac]
    | |- disjoint_GRA _ (@URA.add _ _ _) =>
        eapply disjoint_GRA_dist_r;[disj_tac|disj_tac]
    | |- disjoint_GRA (@GRA.embed _ _ _ _) (@GRA.embed _ _ _ _) =>
        eapply disjoint_GRA_embed; (try by ss)
    end.

Ltac grawf_tac :=
  try
    match goal with
    | |- @URA.wf _ (@URA.add _ _ _) =>
        eapply res_wf_disjoint;
        [grawf_tac|grawf_tac|disj_tac]
    | |- @URA.wf _ (@GRA.embed _ _ _ _) =>
        eapply GRA.wf_embed
    end.

Ltac ndtac :=
  try match goal with
      | |- NoDup _ => econs; ii; ss; des; ss; ndtac
      end.

Module WSim.
  Section WSIM.
    Variable md_src: Mod.t.
    Variable md_tgt: Mod.t.

    Let NUNBOUND: forall n, exists m, n < m.
    Proof. i. exists (S n). econs. Qed.

    Let THSEQ: forall c,
        (NatMapP.of_list (numbering (List.map (fun _ => tt) c))) = (key_set (prog2ths md_src c)).
    Proof.
      i. etrans.
      { symmetry. apply key_set_idempotent. }
      eapply list_of_numbering_nm_wf_pair.
      repeat rewrite map_length. auto.
    Qed.

    Context `{Σ: GRA.t}.

    Lemma iProp_satisfable (r0: Σ) (P: iProp) (WF: URA.wf r0)
          (IMPL: Own r0 ⊢ #=> P)
      :
      exists r1, P r1 /\ URA.wf r1.
    Proof.
      rr in IMPL. unseal "iProp". hexploit (IMPL r0); auto.
      { rr. unseal "iProp". reflexivity. }
      i. rr in H. unseal "iProp".
      hexploit (H URA.unit).
      { rewrite URA.unit_id. auto. }
      i. des. rewrite URA.unit_id in H0. esplits; eauto.
    Qed.

    Context `{MONORA: @GRA.inG monoRA Σ}.
    Context `{THDRA: @GRA.inG ThreadRA Σ}.
    Context `{STATESRC: @GRA.inG (stateSrcRA md_src.(Mod.state)) Σ}.
    Context `{STATETGT: @GRA.inG (stateTgtRA md_tgt.(Mod.state)) Σ}.
    Context `{IDENTSRC: @GRA.inG (identSrcRA md_src.(Mod.ident)) Σ}.
    Context `{IDENTTGT: @GRA.inG (identTgtRA md_tgt.(Mod.ident)) Σ}.
    Context `{OBLGRA: @GRA.inG ObligationRA.t Σ}.
    Context `{ARROWRA: @GRA.inG (ArrowRA md_tgt.(Mod.ident)) Σ}.
    Context `{EDGERA: @GRA.inG EdgeRA Σ}.
    Context `{ONESHOTRA: @GRA.inG (@FiniteMap.t (OneShot.t unit)) Σ}.

    Definition initial_res_wf (init_res: Σ): Prop :=
      (<<INITDISJ: (disjoint_GRA init_res (@default_initial_res _ md_src.(Mod.state) md_tgt.(Mod.state) md_src.(Mod.ident) md_tgt.(Mod.ident) _ _ _ _ _ _ _))>>) /\
        (<<DEFAULTDISJ:
          (NoDup [THDRA.(GRA.inG_id);
                  STATESRC.(GRA.inG_id);
                  STATETGT.(GRA.inG_id);
                  IDENTSRC.(GRA.inG_id);
                  IDENTTGT.(GRA.inG_id);
                  OBLGRA.(GRA.inG_id);
                  ARROWRA.(GRA.inG_id);
                  EDGERA.(GRA.inG_id)])>>) /\
        (<<INITRES: URA.wf init_res>>).

    Lemma reswf_gen
          init_res
          (WF: initial_res_wf init_res)
      : URA.wf (init_res ⋅ (@default_initial_res _ md_src.(Mod.state) md_tgt.(Mod.state) md_src.(Mod.ident) md_tgt.(Mod.ident) _ _ _ _ _ _ _)).
    Proof.
      r in WF. des. inv DEFAULTDISJ. ss.
      inv H2. ss. inv H4. inv H5. ss. inv H6. ss. inv H7. ss. inv H8; ss.
      grawf_tac; auto.
      unfold default_initial_res.
      grawf_tac; (try match goal with | |- _ <> _ => auto 10 end).
      { ur. split; auto.
        { eexists. eapply URA.unit_idl. }
        { ur. auto. }
      }
      { ur. split; auto.
        { eexists _. erewrite URA.unit_idl. eapply URA.unit_id. }
        { ur. ss. }
      }
      { ur. split; auto.
        { eexists _. erewrite URA.unit_idl. eapply URA.unit_id. }
        { ur. ss. }
      }
      { eapply FairRA.source_init_resource_wf. }
      { ur. i. ur. split; auto. reflexivity. }
      { ur. i. ur. auto. }
      { ur. i. ur. auto. }
    Qed.

    Definition initial_prop (ths: TIdSet.t) o: iProp :=
      ((FairRA.whites (fun _ => True: Prop) o)
         **
         (FairRA.blacks (fun i => match i with | inr _ => True | _ => False end: Prop))
         **
         (natmap_prop_sum ths (fun tid _ => ObligationRA.duty (inl tid) []))
         **
         (natmap_prop_sum ths (fun tid _ => own_thread tid))
         **
         (St_src md_src.(Mod.st_init))
         **
         (St_tgt md_tgt.(Mod.st_init)))%I
    .

    Lemma stsim_lsim (I: list iProp) tid (r r_shared r_ctx: Σ)
          ths im_src im_tgt0 im_tgt1 (st_src: md_src.(Mod.state)) (st_tgt: md_tgt.(Mod.state)) (fs ft: bool)
          (th0: thread (Mod.ident md_src) (sE (Mod.state md_src)) Any.t)
          (th1: thread (Mod.ident md_tgt) (sE (Mod.state md_tgt)) Any.t)
          (SIM: stsim I tid (topset I) ibot7 ibot7
                      (fun r_src r_tgt =>
                         ((own_thread tid ** ObligationRA.duty (inl tid) []) ** ⌜r_src = r_tgt⌝)%I) false false th0 th1 r)
          (INV: (default_I ths im_src im_tgt0 st_src st_tgt **
                              mset_all (nth_default True%I I) (topset I)) r_shared)
          (FUPD: fair_update im_tgt0 im_tgt1 (prism_fmap inlp (tids_fmap tid ths)))
          (WF: URA.wf ((r_shared ⋅ r) ⋅ r_ctx))
      :
      (@lsim
         (to_LURA (GRA.to_URA Σ)) (Mod.state md_src) (Mod.state md_tgt)
         (Mod.ident md_src) (Mod.ident md_tgt) owf nat_wf
         (liftI
            (fun (ths : TIdSet.t)
                 (im_src : imap (Mod.ident md_src) owf)
                 (im_tgt : imap (sum_tid (Mod.ident md_tgt)) nat_wf)
                 (st_src : Mod.state md_src) (st_tgt : Mod.state md_tgt) =>
               default_I ths im_src im_tgt st_src st_tgt **
                         mset_all (nth_default True%I I) (topset I)))
         tid
         Any.t Any.t
         (@local_RR
            (to_LURA (GRA.to_URA Σ)) (Mod.state md_src) (Mod.state md_tgt)
            (Mod.ident md_src) (Mod.ident md_tgt) owf nat_wf
            (liftI
               (fun (ths : TIdSet.t)
                    (im_src : imap (Mod.ident md_src) owf)
                    (im_tgt : imap (sum_tid (Mod.ident md_tgt)) nat_wf)
                    (st_src : Mod.state md_src) (st_tgt : Mod.state md_tgt) =>
                  default_I ths im_src im_tgt st_src st_tgt **
                            mset_all (nth_default True%I I) (topset I)))
            Any.t Any.t
            eq tid)) fs ft r_ctx th0 th1
                     (ths, im_src, im_tgt1, st_src, st_tgt).
    Proof.
      Local Opaque GRA.to_URA.
      ii. rr in SIM. unseal "iProp". specialize (SIM ths).
      rr in SIM. unseal "iProp". specialize (SIM im_src).
      rr in SIM. unseal "iProp". specialize (SIM im_tgt1).
      rr in SIM. unseal "iProp". specialize (SIM st_src).
      rr in SIM. unseal "iProp". specialize (SIM st_tgt).
      r in INV.
      rr in SIM. unseal "iProp". hexploit (SIM r_shared).
      { eapply URA.wf_mon. instantiate (1:=r_ctx). r_wf WF. }
      { rr in INV. rr. unseal "iProp". des. subst. esplits.
        { eauto. }
        { rr. unseal "iProp". esplits. rr. unseal "iProp". esplits.
          { symmetry. apply URA.unit_idl. }
          { rr. unseal "iProp". eauto. }
          { auto. }
        }
        { auto. }
      }
      i. rr in H. unseal "iProp". hexploit H.
      { instantiate (1:=r_ctx). r_wf WF. }
      i. eapply lsim_flag_any. eapply lsim_monoR.
      { ginit. ss. refine (@eq_rect _ _ id H0 _ _).
        f_equal; cycle 1.
        { i. subst. f_equal. repeat (let x := fresh "x" in extensionality x).
          eapply propositional_extensionality. split; i; ss.
          dependent destruction H1. rr in REL. unseal "iProp". des.
          rr in REL. unseal "iProp". des. subst.
          rr in REL. unseal "iProp". des. subst.
          rr in REL0. unseal "iProp". ss.
        }
        { repeat (let x := fresh "x" in extensionality x).
          eapply propositional_extensionality. split; i; ss.
          dependent destruction H1. rr in REL. unseal "iProp". des.
          rr in REL. unseal "iProp". des. subst.
          rr in REL. unseal "iProp". des. subst.
          rr in REL0. unseal "iProp". ss.
        }
        { reflexivity. }
        { i. auto. clarify. rewrite H13. rewrite H11. rewrite H10. auto. }
      }
      { i. ss. des_ifs. des.
        rr in RET0. unseal "iProp". des. subst.
        rr in RET2. unseal "iProp". des. subst.
        rr in RET3. unseal "iProp". subst.
        rr in RET1. unseal "iProp". des. subst.
        hexploit (@default_I_past_final md_src.(Mod.state) md_tgt.(Mod.state) md_src.(Mod.ident) md_tgt.(Mod.ident)).
        i. rr in H1. unseal "iProp". hexploit H1.
        { instantiate (1:=a1). eapply URA.wf_mon.
          instantiate (1:=b ⋅ (a0 ⋅ b0) ⋅ r_ctx0). r_wf WF0.
        }
        { eauto. }
        i. rr in H2. unseal "iProp".
        hexploit H2.
        { instantiate (1:=a0). eapply URA.wf_mon.
          instantiate (1:=b ⋅ b0 ⋅ r_ctx0). r_wf WF0.
        }
        { eauto. }
        i. rr in H3. unseal "iProp".
        hexploit H3.
        { instantiate (1:=b ⋅ b0 ⋅ r_ctx0). r_wf WF0. }
        i. des.
        rr in H5. unseal "iProp". des.
        rr in H5. unseal "iProp". des. subst.
        rr in H6. unseal "iProp".
        rr. esplits.
        { eauto. }
        2:{ rr. unseal "iProp". esplits; eauto. }
        { instantiate (1:=URA.unit).
          rewrite PCMLarge.URA.unfold_wf.
          rewrite PCMLarge.URA.unfold_add. ss.
          cut (URA.wf (((b1 ⋅ b) ⋅ ε) ⋅ r_ctx0)).
          { intros WFH. rewrite URA.unfold_wf in WFH.
            rewrite URA.unfold_add in WFH.
            rewrite URA.unfold_add. ss.
          }
          eapply URA.wf_mon. instantiate (1:=a ⋅ b0). r_wf H4.
        }
        { auto. }
      }
    Qed.

    Lemma stsim_local_sim_init (I: list iProp) tid (r: Σ)
          (th0: thread (Mod.ident md_src) (sE (Mod.state md_src)) Any.t)
          (th1: thread (Mod.ident md_tgt) (sE (Mod.state md_tgt)) Any.t)
          (SIM: stsim I tid (topset I) ibot7 ibot7
                      (fun r_src r_tgt =>
                         ((own_thread tid ** ObligationRA.duty (inl tid) []) ** ⌜r_src = r_tgt⌝)%I) false false th0 th1 r)
      :
      @local_sim_init
        (to_LURA (GRA.to_URA Σ)) (Mod.state md_src) (Mod.state md_tgt)
        (Mod.ident md_src) (Mod.ident md_tgt) owf nat_wf
        (liftI
           (fun (ths : TIdSet.t)
                (im_src : imap (Mod.ident md_src) owf)
                (im_tgt : imap (sum_tid (Mod.ident md_tgt)) nat_wf)
                (st_src : Mod.state md_src) (st_tgt : Mod.state md_tgt) =>
              default_I ths im_src im_tgt st_src st_tgt **
                        mset_all (nth_default True%I I) (topset I))) Any.t Any.t eq r tid th0 th1.
    Proof.
      ii. assert (WF: URA.wf ((r_shared ⋅ r) ⋅ r_ctx)).
      { rewrite PCMLarge.URA.unfold_wf in VALID.
        rewrite PCMLarge.URA.unfold_add in VALID.
        rewrite URA.unfold_wf.
        rewrite URA.unfold_add. auto.
      }
      eapply stsim_lsim; eauto.
    Qed.

    Lemma stsim_local_sim (I: list iProp)
          (th0: thread (Mod.ident md_src) (sE (Mod.state md_src)) Any.t)
          (th1: thread (Mod.ident md_tgt) (sE (Mod.state md_tgt)) Any.t)
          (SIM: forall tid,
              ((own_thread tid)
                 ⊢
                 (ObligationRA.duty (inl tid) [])
                 -∗
                 (stsim I tid (topset I) ibot7 ibot7
                        (fun r_src r_tgt =>
                           ((own_thread tid ** ObligationRA.duty (inl tid) []) ** ⌜r_src = r_tgt⌝)%I) false false th0 th1))%I)
      :
      @local_sim
        (to_LURA (GRA.to_URA Σ)) (Mod.state md_src) (Mod.state md_tgt)
        (Mod.ident md_src) (Mod.ident md_tgt) owf nat_wf
        (liftI
           (fun (ths : TIdSet.t)
                (im_src : imap (Mod.ident md_src) owf)
                (im_tgt : imap (sum_tid (Mod.ident md_tgt)) nat_wf)
                (st_src : Mod.state md_src) (st_tgt : Mod.state md_tgt) =>
              default_I ths im_src im_tgt st_src st_tgt **
                        mset_all (nth_default True%I I) (topset I))) Any.t Any.t eq th0 th1.
    Proof.
      ii. assert (WF: URA.wf (r_shared0 ⋅ r_ctx0)).
      { rewrite PCMLarge.URA.unfold_wf in VALID.
        rewrite PCMLarge.URA.unfold_add in VALID.
        rewrite URA.unfold_wf.
        rewrite URA.unfold_add. auto.
      }
      specialize (SIM tid). r in INV.
      assert (IMPL:
               (default_I ths0 im_src0 im_tgt0 st_src0 st_tgt0 **
                          mset_all (nth_default True%I I) (topset I))
                 ⊢
                 #=> ((default_I ths1 im_src0 im_tgt1 st_src0 st_tgt0)
                        **
                        (mset_all (nth_default True%I I) (topset I))
                        **
                        stsim I tid (topset I) ibot7 ibot7
                        (λ r_src r_tgt : Any.t,
                            (own_thread tid ** ObligationRA.duty (inl tid) []) ** ⌜r_src = r_tgt⌝)
                        false false th0 th1)).
      { iIntros "[D SAT]".
        iPoseProof (default_I_thread_alloc with "D") as "> [[OWN DUTY] D]".
        { eauto. }
        { eauto. }
        iModIntro. iFrame. iApply (SIM with "OWN DUTY").
      }
      rr in IMPL. unseal "iProp".
      hexploit IMPL; [|eauto|..].
      { eapply URA.wf_mon. instantiate (1:=r_ctx0). r_wf WF. }
      i. rr in H. unseal "iProp".
      hexploit H.
      { eauto. }
      i. des.
      rr in H1. unseal "iProp". des. subst.
      exists a, b. splits.
      { r. auto. }
      { rewrite PCMLarge.URA.unfold_wf.
        rewrite PCMLarge.URA.unfold_add. ss.
        rewrite URA.unfold_wf in H0.
        rewrite URA.unfold_add in H0. auto.
      }
      i. ss. eapply stsim_lsim.
      { eauto. }
      { eapply INV0. }
      { eauto. }
      { rewrite PCMLarge.URA.unfold_wf in VALID0.
        rewrite PCMLarge.URA.unfold_add in VALID0. ss.
        rewrite URA.unfold_wf.
        rewrite URA.unfold_add. auto.
      }
    Qed.

    Section WHOLE_PROGRAM_SIM.
      Variable c: list (fname * Any.t).

      Definition fun_pairs :=
        (NatMapP.of_list (numbering (List.map (fun '(fn, arg) => (fn2th md_src fn arg, fn2th md_tgt fn arg)) c))).

      Lemma natmap_prop_sum_resmap A (P: nat -> A -> iProp) (m: NatMap.t A) rs
            (SAT: natmap_prop_sum m P rs)
            (WF: URA.wf rs)
        :
        exists (rm: NatMap.t Σ),
          (<<EXT: URA.extends (NatMap.fold (fun _ r s => URA.add r s) rm URA.unit) rs>>)/\
            (<<PAIR: nm_wf_pair m rm>>) /\
            (<<FORALL: forall k a r
                              (FINDA: NatMap.find k m = Some a)
                              (FINDR: NatMap.find k rm = Some r),
                P k a r>>).
      Proof.
        revert rs SAT WF.
        pattern m. revert m. eapply nm_ind; i.
        { exists (NatMap.empty _). splits.
          { exists rs. eapply URA.unit_idl. }
          { eapply nm_wf_pair_empty_empty_eq. }
          { i. rewrite NatMapP.F.empty_o in FINDA. ss. }
        }
        hexploit natmap_prop_remove_find.
        { eapply nm_find_add_eq. }
        i. rr in H. unseal "iProp".
        hexploit H.
        { eapply WF. }
        { eauto. }
        i. rr in H0. unseal "iProp". des. subst.
        rewrite nm_find_none_rm_add_eq in H2; auto.
        hexploit IH; eauto.
        { eapply URA.wf_mon. instantiate (1:=a). r_wf WF. }
        i. des. exists (NatMap.add k a rm). splits.
        { r in EXT. des. subst. exists ctx. rewrite NatMapP.fold_add; auto.
          { r_solve. }
          { ii. subst. auto. }
          { ii. r_solve. }
          { eapply nm_wf_pair_find_cases in PAIR. des.
            apply NatMapP.F.not_find_in_iff. eapply PAIR; auto.
          }
        }
        { eapply nm_wf_pair_add; eauto. }
        { i. rewrite NatMapP.F.add_o in FINDA.
          rewrite NatMapP.F.add_o in FINDR. des_ifs.
          eapply FORALL; auto.
        }
      Qed.

      Record whole_sim: Prop :=
        mk_whole_sim {
            init_res: Σ;
            init_res_cond: initial_res_wf init_res;
            init_inv:
            exists (o: Ord.t),
              (Own init_res ** (initial_prop (key_set (prog2ths md_src c)) o)) (* INIT *)
                -∗
                (#=>
                   ∃ (I_whole: list iProp),
                     (MUpd
                        (nth_default True%I I_whole) (fairI (ident_tgt:=md_tgt.(Mod.ident))) [] []
                        ((mset_all (nth_default True%I I_whole) (topset I_whole))
                           **
                           (natmap_prop_sum
                              fun_pairs
                              (fun tid '(th_src, th_tgt) =>
                                 stsim
                                   I_whole tid (topset I_whole)
                                   ibot7 ibot7
                                   (fun r_src r_tgt => own_thread tid ** ObligationRA.duty (inl tid) [] ** ⌜r_src = r_tgt⌝)
                                   false false th_src th_tgt))
                )));
          }.

      Lemma whole_sim_implies_usersim
            (SIM: whole_sim)
        :
        UserSim.sim md_src md_tgt (prog2ths md_src c) (prog2ths md_tgt c).
      Proof.
        inv SIM. des.
        assert (forall im_tgt,
                 exists (r: Σ),
                   (<<SAT:
                     (∃ (I_whole: list iProp) im_src,
                         ((default_I (key_set (prog2ths md_src c)) im_src im_tgt (Mod.st_init md_src) (Mod.st_init md_tgt))
                            **
                            (mset_all (nth_default True%I I_whole) (topset I_whole)))
                           **
                           (natmap_prop_sum
                              fun_pairs
                              (fun tid '(th_src, th_tgt) =>
                                 stsim
                                   I_whole tid (topset I_whole)
                                   ibot7 ibot7
                                   (fun r_src r_tgt => own_thread tid ** ObligationRA.duty (inl tid) [] ** ⌜r_src = r_tgt⌝)
                                   false false th_src th_tgt)))%I r>>) /\
                     (<<WF: URA.wf r>>)).
        { i. eapply iProp_satisfable.
          { eapply reswf_gen; eauto. }
          iIntros "[H0 H1]".
          iPoseProof (default_initial_res_init with "H1") as "H1".
          iPoseProof ("H1" $! _ _ _ _ _) as "> [% [[[[[[[[X Y] Z] B] C] D] E] F] G]]".
          unfold initial_prop in init_inv.
          iPoseProof (init_inv with "[H0 E B C D F G]") as "> [% init_ctx]".
          { iFrame. }
          iPoseProof ("init_ctx" with "[Y Z]") as "> [[[Y Z] W] [D H]]".
          { iFrame. }
          iModIntro. iExists _, _. iFrame.
        }
        apply (@UserSim.mk
                 md_src md_tgt (prog2ths md_src c) (prog2ths md_tgt c) owf nat_wf (inhabits 0) NUNBOUND (to_LURA Σ)).
        i. specialize (H im_tgt). des.
        rr in SAT. unseal "iProp". des. rename x into I_whole.
        rr in SAT. unseal "iProp". des. rename x into im_src.
        rr in SAT. unseal "iProp". des. subst.
        rr in SAT0. unseal "iProp". des. subst.
        hexploit natmap_prop_sum_resmap.
        { eauto. }
        { eapply URA.wf_mon. instantiate (1:=a0 ⋅ b0). r_wf WF. }
        i. des.
        eexists (liftI (fun ths im_src im_tgt st_src st_tgt => @default_I md_src.(Mod.state) md_tgt.(Mod.state) md_src.(Mod.ident) md_tgt.(Mod.ident) Σ _ _ _ _ _ _ _ _ _ ths im_src im_tgt st_src st_tgt ** mset_all (nth_default True%I I_whole) (topset I_whole)%I)), im_src, rm, _.
        splits.
        { ss. rr. unseal "iProp". esplits; eauto. }
        { apply nm_find_some_implies_forall3.
          { eapply prog2ths_nm_wf_pair. }
          { etrans; [|apply PAIR].
            eapply list_of_numbering_nm_wf_pair.
            repeat rewrite map_length. auto.
          }
          i. hexploit (FORALL k (e1, e2) e3).
          { clear - FIND1 FIND2. unfold fun_pairs, prog2ths in *.
            unfold numbering in *. revert FIND1 FIND2.
            generalize 0. revert e1 e2. induction c; ss; i.
            { unfold NatMapP.uncurry in *. destruct a. ss.
              rewrite NatMapP.F.add_o in FIND1. rewrite NatMapP.F.add_o in FIND2.
              rewrite NatMapP.F.add_o. des_ifs.
              eapply IHl; eauto.
            }
          }
          { auto. }
          i. ii. eapply stsim_local_sim_init; eauto.
        }
        { cut (URA.wf ((a0 ⋅ b0) ⋅ (NatMap.fold (fun _ r s => r ⋅ s) rm URA.unit))).
          { i. rewrite PCMLarge.URA.unfold_wf. s.
            rewrite PCMLarge.URA.unfold_add. s.
            change (@PCMLarge.URA.unit (to_LURA (GRA.to_URA Σ))) with (@URA.unit Σ).
            rewrite URA.unfold_wf in H.
            rewrite URA.unfold_add in H.
            rewrite URA.unfold_add. auto.
          }
          eapply URA.wf_extends; [|eauto].
          rr in EXT. des. subst. exists ctx. r_solve.
        }
      Qed.

      Lemma whole_sim_implies_refinement
            (SIM: whole_sim)
        :
        Adequacy.improves (interp_all md_src.(Mod.st_init) (prog2ths md_src c) 0)
                          (interp_all md_tgt.(Mod.st_init) (prog2ths md_tgt c) 0).
      Proof.
        eapply usersim_adequacy. eapply whole_sim_implies_usersim. auto.
      Qed.

      Record whole_sim_simple: Prop :=
        mk_whole_sim_simple {

            whole_sim_simple_invariant: iProp; (* I *)

            whole_sim_funs_simple:
            exists (r: Σ),
              (<<WF: initial_res_wf r>>) /\
                (<<SIM: ((Own r ** (initial_prop (key_set (prog2ths md_src c)) Ord.omega))
                           ⊢ #=>
                           (whole_sim_simple_invariant
                              **
                              (natmap_prop_sum
                                 fun_pairs
                                 (fun tid '(th_src, th_tgt) =>
                                    stsim
                                      [whole_sim_simple_invariant] tid [0]
                                      ibot7 ibot7
                                      (fun r_src r_tgt => own_thread tid ** FairRA.black_ex (inl tid) 1 ** ⌜r_src = r_tgt⌝)
                                      false false th_src th_tgt))))>>);
          }.

      Lemma whole_sim_simple_whole_sim
            (SIM: whole_sim_simple)
        :
        whole_sim.
      Proof.
        inv SIM. des. econs.
        { eauto. }
        exists Ord.omega. iIntros "H".
        iPoseProof (SIM with "H") as "> [H0 H1]". iModIntro.
        iExists [whole_sim_simple_invariant]. iModIntro.
        iSplitL "H0".
        { iFrame. }
        iApply (natmap_prop_sum_impl with "H1"). i. des_ifs.
        iApply (stsim_mono). i.
        iIntros "[[H0 H1] H2]". iModIntro. iFrame.
        iApply black_to_duty. auto.
      Qed.

      Theorem whole_sim_simple_implies_refinement
              (SIM: whole_sim_simple)
        :
        Adequacy.improves (interp_all md_src.(Mod.st_init) (prog2ths md_src c) 0)
                          (interp_all md_tgt.(Mod.st_init) (prog2ths md_tgt c) 0).
      Proof.
        apply whole_sim_implies_refinement.
        apply whole_sim_simple_whole_sim. auto.
      Qed.

    End WHOLE_PROGRAM_SIM.

    Section CONTEXT_SIM.

      Record context_sim: Prop :=
        mk_context_sim {
            init_res: Σ;
            init_res_cond: initial_res_wf init_res;
            init_inv:
            exists o,
              (Own init_res ** (initial_prop TIdSet.empty o)) (* INIT *)
                -∗
                (#=>
                   ∃ (I_ctx: list iProp),
                     MUpd
                       (nth_default True%I I_ctx) (fairI (ident_tgt:=md_tgt.(Mod.ident))) [] []
                       ((mset_all (nth_default True%I I_ctx) (topset I_ctx))
                        ∧
                          (⌜forall fn args,
                                match md_src.(Mod.funs) fn, md_tgt.(Mod.funs) fn with
                                | Some ktr_src, Some ktr_tgt =>
                                    forall tid,
                                      (own_thread tid)
                                        -∗
                                        (ObligationRA.duty (inl tid) [])
                                        -∗
                                        (stsim
                                           I_ctx tid (topset I_ctx)
                                           ibot7 ibot7
                                           (fun r_src r_tgt => own_thread tid ** ObligationRA.duty (inl tid) [] ** ⌜r_src = r_tgt⌝)
                                           false false (ktr_src args) (ktr_tgt args))
                                | None, None => True
                                | _, _ => False
                                end⌝)));
          }.

      Lemma context_sim_implies_modsim
            (SIM: context_sim)
        :
        ModSim.mod_sim md_src md_tgt.
      Proof.
        inv SIM. des.
        i. assert (forall im_tgt,
                    exists (r: Σ),
                      (<<SAT:
                        ((∃ (I_ctx: list iProp) im_src,
                             ((default_I NatSet.empty im_src im_tgt (Mod.st_init md_src) (Mod.st_init md_tgt) ** (mset_all (nth_default True%I I_ctx) (topset I_ctx))))
                             ∧
                               (⌜forall fn args,
                                     match md_src.(Mod.funs) fn, md_tgt.(Mod.funs) fn with
                                     | Some ktr_src, Some ktr_tgt =>
                                         forall tid,
                                           (own_thread tid)
                                             -∗
                                             (ObligationRA.duty (inl tid) [])
                                             -∗
                                             (stsim
                                                I_ctx tid (topset I_ctx)
                                                ibot7 ibot7
                                                (fun r_src r_tgt => own_thread tid ** ObligationRA.duty (inl tid) [] ** ⌜r_src = r_tgt⌝)
                                                false false (ktr_src args) (ktr_tgt args))
                                     | None, None => True
                                     | _, _ => False
                                     end⌝))%I) r>>) /\
                        (<<WF: URA.wf r>>)).
        { i. eapply iProp_satisfable.
          { eapply reswf_gen; eauto. }
          iIntros "[H0 H1]".
          iPoseProof (default_initial_res_init with "H1") as "H1".
          iPoseProof ("H1" $! _ _ _ _ _) as "> [% [[[[[[[[X Y] Z] B] C] D] E] F] G]]".
          unfold initial_prop in init_inv.
          iPoseProof (init_inv with "[H0 E B C D F G]") as "> [% init_ctx]".
          { iFrame. }
          iPoseProof ("init_ctx" with "[Y Z]") as "> [[[Y Z] W] [D H]]".
          { iFrame. }
          iModIntro. iExists _, _. iFrame.
        }
        apply (@ModSim.mk
                 md_src md_tgt owf nat_wf (inhabits 0) NUNBOUND (to_LURA Σ)).
        i. specialize (H im_tgt). des.
        rr in SAT. unseal "iProp". des. rename x into I_ctx.
        rr in SAT. unseal "iProp". des.
        rr in SAT. unseal "iProp". des. subst.
        rr in SAT0. unseal "iProp".
        exists (liftI (fun ths im_src im_tgt st_src st_tgt => @default_I md_src.(Mod.state) md_tgt.(Mod.state) md_src.(Mod.ident) md_tgt.(Mod.ident) Σ _ _ _ _ _ _ _ _ _ ths im_src im_tgt st_src st_tgt ** mset_all (nth_default True%I I_ctx) (topset I_ctx)%I)).
        esplits.
        { ss. eauto. }
        { rewrite PCMLarge.URA.unfold_wf. rewrite URA.unfold_wf in WF. auto. }
        { i. specialize (SAT0 fn args). des_ifs.
          eapply stsim_local_sim; eauto.
        }
      Qed.

      Lemma context_sim_implies_contextual_refinement
            (SIM: context_sim)
        :
        forall p,
          Adequacy.improves (interp_all md_src.(Mod.st_init) (prog2ths md_src p) 0)
                            (interp_all md_tgt.(Mod.st_init) (prog2ths md_tgt p) 0).
      Proof.
        eapply modsim_adequacy. eapply context_sim_implies_modsim. auto.
      Qed.

      Record context_sim_simple: Prop :=
        mk_context_sim_simple {

            context_sim_simple_invariant: iProp; (* I *)

            init_satisfied:
            exists (r: Σ),
              (<<WF: initial_res_wf r>>) /\
                (<<SAT: ((Own r ** (initial_prop TIdSet.empty Ord.omega))
                           ⊢ #=> context_sim_simple_invariant)%I>>);

            sim_funs:
            forall fn args,
              match md_src.(Mod.funs) fn, md_tgt.(Mod.funs) fn with
              | Some ktr_src, Some ktr_tgt =>
                  forall tid,
                      (FairRA.black_ex (inl tid) 1)
                      -∗
                      (stsim
                         [context_sim_simple_invariant] tid [0]
                         ibot7 ibot7
                         (fun r_src r_tgt => FairRA.black_ex (inl tid) 1 ** ⌜r_src = r_tgt⌝)
                         false false (ktr_src args) (ktr_tgt args))
              | None, None => True
              | _, _ => False
              end;
          }.

      Lemma context_sim_simple_context_sim
            (SIM: context_sim_simple)
        :
        context_sim.
      Proof.
        inv SIM. des. econs.
        { eauto. }
        { exists Ord.omega. iIntros "H".
          iPoseProof (SAT with "H") as "> SAT". iModIntro.
          iExists [context_sim_simple_invariant]. iModIntro. iSplit.
          { ss. iFrame. }
          iPureIntro. auto.
          i. specialize (sim_funs fn args). des_ifs.
          i. iIntros "H B". iPoseProof (sim_funs with "[B]") as "B".
          { iApply duty_to_black. auto. }
          iApply (stsim_wand with "B [H]").
          iIntros (? ?) "[H0 H1]". iModIntro. iFrame.
          iApply black_to_duty. auto.
        }
      Qed.

      Theorem context_sim_simple_implies_contextual_refinement
              (SIM: context_sim_simple)
        :
        forall p,
          Adequacy.improves (interp_all md_src.(Mod.st_init) (prog2ths md_src p) 0)
                            (interp_all md_tgt.(Mod.st_init) (prog2ths md_tgt p) 0).
      Proof.
        apply context_sim_implies_contextual_refinement.
        apply context_sim_simple_context_sim. auto.
      Qed.

    End CONTEXT_SIM.
  End WSIM.
End WSim.