Require Import Bool Arith List Omega.
Require Import OrderedType OrderedTypeEx.
Require FMapList.
Require FMapFacts.
Import ListNotations.

(*************************************************************)
(* get us some maps *)

Module NatMap := FMapList.Make Nat_as_OT.
Module NatMapFacts := FMapFacts.WFacts_fun Nat_as_OT NatMap.

(*************************************************************)
(* Data block model *)

(*
 * A data block is either a user block (which we identify
 * by a file number, file block number, and generation number) or
 * a FS metadata block, which is a value of some type T
 * defined by the FS.
 *
 * XXX: how do we want to do this parameterization? I suspect what
 * I've put here for the moment is going to suck.
 *)

Section DataBlocks.

Inductive DataBlock : Type :=
(*
| UserData: forall (userfilenum fileblocknum generation : nat), DataBlock
| FSData: forall T : Type, forall metadata : T, DataBlock
*)
| DNat (n:nat)
.

(*
 * A block table is a map from block addresses (nats) to data.
 *)
Definition BlockTable : Type := NatMap.t DataBlock.

End DataBlocks.

(*************************************************************)
(* Cache model *)

Section Cache.

(*
 * We have two caches: a disk cache (on the disk) and an OS-level
 * buffer cache. These are both write-back but have different
 * behavior, reflecting the real-world behavior of these abstractions.
 *
 * Both caches are modeled using maps containing pending writes. (We
 * don't bother to model the read behavior of caches as we aren't
 * interested in trying to model performance.)
 *
 * The disk cache is a list of maps; a new entry is pushed on the list
 * when a write ordering barrier is issued. Therefore, more than one
 * value for any given block may be kept on file, but only with a
 * write barrier in between. I'm assuming that sending a disk new data
 * for a block still pending will overwrite the old version in the cache
 * if there's no write barrier prohibiting such combining.
 *
 * (XXX: do we need to make sure not to write the same block on both
 * sides of a write barrier to keep the disk from screwing up?)
 *
 * The OS cache is one map, but there's a lot more machinery to access
 * it.
 *
 * The complete cache has both cache layers and a platter, which
 * represents what's actually on the physical media.
 *)

Definition RawCache : Type := BlockTable.

Definition DiskPlatter : Type := BlockTable.
Definition DiskCache : Type := list RawCache.
Definition OSCache : Type := RawCache.

Inductive Cache : Type :=
| cache : forall (oc : OSCache) (dc : DiskCache) (dp : DiskPlatter), Cache
.

(*
 * Operations on DiskPlatter.
 *
 * DiskPlatter_empty is a totally empty platter.
 *)

Definition DiskPlatter_empty := NatMap.empty DataBlock.

Definition DiskPlatter_read (plat : DiskPlatter) (bn : nat) :=
   NatMap.find bn plat.

Definition DiskPlatter_write (plat : DiskPlatter) (bn : nat) (data : DataBlock):=
   NatMap.add bn data plat.

(*
 * Operations on RawCache.
 *
 * RawCache_empty is the empty cache.
 *
 * RawCache_read reads the value for the indicated block, if any.
 *
 * RawCache_write inserts a new block value into the cache,
 * overwriting any value that already exists.
 *
 * RawCache_sync transfers all the blocks to the platter (passed in)
 * and returns a new platter. It does not return a new RawCache; use
 * RawCache_empty.
 *)

Definition RawCache_empty := NatMap.empty DataBlock.

Definition RawCache_read (rc : RawCache) (bn : nat) :=
   NatMap.find bn rc.

Definition RawCache_write (rc : RawCache) (bn : nat) (data : DataBlock) :=
   NatMap.add bn data rc.

Definition RawCache_sync (rc : RawCache) (plat : DiskPlatter) :=
   NatMap.fold (fun bn data plat =>
                   DiskPlatter_write plat bn data) rc plat.

(*
 * Operations on DiskCache.
 *
 * DiskCache_empty is the empty cache.
 *
 * DiskCache_read reads the latest value for the indicated block.
 *
 * DiskCache_write inserts a new block value into the cache.
 *
 * DiskCache_writebarrier issues a write barrier.
 *
 * DiskCache_sync transfers all blocks to the platter, obeying the
 * write barriers. It returns a new DiskPlatter. It does not return
 * a new DiskCache; use DiskCache_empty.
 *)

Definition DiskCache_empty := [] : list RawCache.

Function DiskCache_read (dc : DiskCache) (bn : nat) :=
   match dc with
   | [] => None
   | rc :: more =>
        match RawCache_read rc bn with
        | None => DiskCache_read more bn
        | Some data => Some data
        end
   end.

Function DiskCache_write (dc : DiskCache) (bn : nat) (data : DataBlock) :=
   match dc with
   | [] => [RawCache_write RawCache_empty bn data]
   | rc :: more => (RawCache_write rc bn data) :: more
   end.

Function DiskCache_writebarrier (dc : DiskCache) :=
   RawCache_empty :: dc.

Function DiskCache_sync (dc : DiskCache) (plat : DiskPlatter) :=
   match dc with
   | [] => plat
   | rc :: more =>
        RawCache_sync rc (DiskCache_sync more plat)
   end.

(*
 * Operations on OSCache.
 *
 * OSCache_empty is the empty cache.
 * OSCache_read reads the value for the indicated block, if any.
 * OSCache_write inserts a new block value into the cache.
 *
 * (more TBD)
 *)

Definition OSCache_empty := RawCache_empty.
Definition OSCache_read := RawCache_read.
Definition OSCache_write := RawCache_write.

(*
 * Operations on the whole cache.
 *
 * Cache_boot generates an empty cache attached to the given platter.
 * Cache_read reads the value for the indicated block.
 * Cache_write inserts a new block value and does not flush it.
 *
 * (more tbd)
 *)

Function Cache_boot (plat : DiskPlatter) :=
   cache OSCache_empty DiskCache_empty plat.

Function Cache_read (c : Cache) (bn : nat) :=
   match c with
   | cache oc dc plat =>
        match OSCache_read oc bn with
        | Some data => Some data
        | None =>
             match DiskCache_read dc bn with
             | Some data => Some data
             | None =>
                  DiskPlatter_read plat bn
             end
        end
   end.

Function Cache_write (c : Cache) (bn : nat) (data : DataBlock) :=
   match c with
   | cache oc dc plat =>
        let oc' := OSCache_write oc bn data in
        cache oc' dc plat
   end.

End Cache.

Section CacheFacts.

(*
 * Lemmas about caches.
 *)

(*
 * Reading returns the latest write.
 *)

Local Hint Unfold RawCache_write RawCache_read.
Local Hint Unfold DiskPlatter_read DiskPlatter_write.
Local Hint Unfold OSCache_read OSCache_write.
Local Hint Resolve NatMapFacts.add_eq_o.

Lemma RawCache_read_nonstale:
   forall rc bn data,
      RawCache_read (RawCache_write rc bn data) bn = Some data.
Proof.
  autounfold; auto.
Qed.

Hint Rewrite RawCache_read_nonstale : cache.
Local Hint Resolve  RawCache_read_nonstale.

Lemma DiskPlatter_read_nonstale:
   forall plat bn data,
      DiskPlatter_read (DiskPlatter_write plat bn data) bn = Some data.
Proof.
   autounfold; auto.
Qed.

Lemma DiskCache_read_nonstale:
   forall dc bn data,
      DiskCache_read (DiskCache_write dc bn data) bn = Some data.
Proof.
   intros.
   destruct dc; simpl; autorewrite with cache; auto.
Qed.

Lemma OSCache_read_nonstale:
   forall oc bn data,
      OSCache_read (OSCache_write oc bn data) bn = Some data.
Proof.
   auto.
Qed.

Hint Rewrite OSCache_read_nonstale : cache.

Lemma Cache_read_nonstale:
   forall c bn data,
      Cache_read (Cache_write c bn data) bn = Some data.
Proof.
   destruct c; intros; simpl; autorewrite with cache; auto.
Qed.

(*
 * Writing something else doesn't affect reads.
 *)

Hint Rewrite NatMapFacts.add_neq_o : cache.

Lemma RawCache_read_noninterfere:
   forall rc bn1 bn2 data,
      bn1 <> bn2 ->
      RawCache_read (RawCache_write rc bn1 data) bn2 = RawCache_read rc bn2.
Proof.
   intros; autounfold; autorewrite with cache; auto.
Qed.

Lemma DiskPlatter_read_noninterfere:
   forall plat bn1 bn2 data,
      bn1 <> bn2 ->
      DiskPlatter_read (DiskPlatter_write plat bn1 data) bn2 = DiskPlatter_read plat bn2.
Proof.
   intros; autounfold; autorewrite with cache; auto.
Qed.

Hint Rewrite RawCache_read_noninterfere : cache.
Local Hint Resolve RawCache_read_noninterfere.

Lemma DiskCache_read_noninterfere:
   forall dc bn1 bn2 data,
      bn1 <> bn2 ->
      DiskCache_read (DiskCache_write dc bn1 data) bn2 = DiskCache_read dc bn2.
Proof.
   intros; destruct dc; simpl; autorewrite with cache; auto.
Qed.

Lemma OSCache_read_noninterfere:
   forall oc bn1 bn2 data,
      bn1 <> bn2 ->
      OSCache_read (OSCache_write oc bn1 data) bn2 = OSCache_read oc bn2.
Proof.
   auto.
Qed.

Lemma Cache_read_noninterfere:
   forall c bn1 bn2 data,
      bn1 <> bn2 ->
      Cache_read (Cache_write c bn1 data) bn2 = Cache_read c bn2.
Proof.
   intros; destruct c; simpl; autorewrite with cache; auto.
Qed.

(*
 * A write barrier doesn't affect what you read.
 *)
Lemma DiskCache_read_writebarrier:
   forall dc bn,
      DiskCache_read (DiskCache_writebarrier dc) bn = DiskCache_read dc bn.
Proof.
   auto.
Qed.

End CacheFacts.


Require Import Axioms.
Require Import Tactics.
Require Import Sigma.
Require Import Equality.
Require Import Relation.
Require Import Syntax.
Require Import Ofe.
Require Import Uniform.
Require Import Spaces.
Require Import Dynamic.
Require Import Hygiene.
Require Import Equivalence.
Require Import Urelsp.
Require Import Intensional.
Require Import Ordinal.
Require Import Candidate.
Require Import Ceiling.
Require Import Truncate.
Require Import MapTerm.
Require Import Extend.
Require Import Standard.
Require Import Equivalences.
Require Import ExtendTruncate.
Require Import SemanticsProperty.

Local Ltac prove_hygiene :=
  repeat (first [ apply hygiene_shift_permit
                | apply hygiene_sumbool
                | apply hygiene_auto; cbn [row_rect nat_rect]; repeat2 split; auto
                ]);
  eauto using hygiene_weaken, clo_min, hygiene_shift', hygiene_subst1;
  try (apply hygiene_var; cbn; auto; done).

(* We could define this using set types, but it is much less messy to avoid dependent types. *)

Lemma squash_downward :
  forall w (A : wurel w) i,
    (exists m p, rel A (S i) m p)
    -> (exists m p, rel A i m p).
Proof.
intros w A i H.
destruct H as (m & p & H).
exists m, p.
apply urel_downward; auto.
Qed.

Definition squash_urel
  (w : ordinal) (A : wurel w) (i : nat)
  :=
  property_urel (fun j => exists m p, rel A j m p) w i (squash_downward w A).

Lemma ceiling_squash :
  forall w A n i,
    ceiling (S n) (squash_urel w A i)
    =
    squash_urel w A (min i n).
Proof.
intros w A n i.
apply ceiling_property.
Qed.

Lemma ceiling_squash_inner :
  forall w A i j,
    j < i
    -> squash_urel w A j = squash_urel w (ceiling i A) j.
Proof.
intros w A i j Hji.
unfold squash_urel.
apply property_urel_extensionality; auto.
intros k Hk.
split.
  {
  intros (m & p & H).
  exists m, p.
  split; auto.
  omega.
  }

  {
  intros (m & p & H).
  exists m, p.
  destruct H.
  auto.
  }
Qed.

Lemma ceiling_squash_both :
  forall w A n i,
    n <= i
    -> squash_urel w (ceiling (S n) A) n
       =
       ceiling (S n) (squash_urel w A i).
Proof.
intros w A n i Hle.
rewrite -> ceiling_squash.
rewrite -> Nat.min_r; auto.
symmetry.
apply ceiling_squash_inner.
omega.
Qed.

Definition embed_ceiling_squash_ne w (n i : nat) (A : wurel w) (h : n <= i) :
  urelsp (squash_urel w (ceiling (S n) A) n) -n> urelsp (squash_urel w A i)
  :=
  nearrow_compose
    (embed_ceiling_ne (S n) (squash_urel w A i))
    (transport_ne (ceiling_squash_both w A n i h) urelsp).

Lemma extend_squash :
  forall v w A i,
    v <<= w
    -> extend_urel v w (squash_urel v A i)
      =
      squash_urel w (extend_urel v w A) i.
Proof.
intros v w A i Hle.
unfold squash_urel.
rewrite -> extend_property; auto.
apply urel_extensionality.
cbn.
f_equal.
fextensionality 1.
intro j.
pextensionality.
  {
  intros (m & p & H).
  exists (map_term (extend v w) m).
  exists (map_term (extend v w) p).
  rewrite -> !extend_term_cancel; auto.
  }

  {
  intros (m & p & H).
  exists (map_term (extend w v) m).
  exists (map_term (extend w v) p).
  auto.
  }
Qed.

Lemma squash_intro :
  forall w (A : wurel w) i j m p,
    j <= i
    -> rel A j m p
    -> rel (squash_urel w A i) j triv triv.
Proof.
intros w A i j m p Hj Hmp.
do2 5 split; eauto using star_refl; try prove_hygiene.
Qed.

Definition guard_action
  (w : ordinal) i (A : wurel w) (B : urelsp_car (squash_urel w A i) -> wurel w)
  : nat -> relation (wterm w)
  :=
  fun i' m n =>
    exists (Hi' : i' <= i),
      hygiene clo m
      /\ hygiene clo n
      /\ forall j p q (Hj : j <= i') (Hrel : rel A j p q),
            rel (B (urelspinj (squash_urel w A i) j triv triv (squash_intro _#6 (le_trans _#3 Hj Hi') Hrel))) j m n.

Lemma guard_uniform :
  forall w i A B, uniform _ (guard_action w i A B).
Proof.
intros w i A B.
do2 3 split.

(* closed *)
{
intros i' m n H.
decompose H; auto.
}

(* equiv *)
{
intros i' m m' n n' Hclm' Hcln' Hm Hn H.
decompose H.
intros Hi' Hclm Hcln Hact.
exists Hi'.
do2 2 split; auto.
intros j p q Hj Hpq.
so (Hact _#3 Hj Hpq) as H.
eapply urel_equiv; eauto.
}

(* zigzag *)
{
intros i' m n p q Hmn Hpn Hpq.
destruct Hmn as (Hi' & Hclm & _ & Hmn).
destruct Hpn as (H & _ & _ & Hpn).
so (proof_irrelevance _ Hi' H); subst H.
destruct Hpq as (H & _ & Hclq & Hpq).
so (proof_irrelevance _ Hi' H); subst H.
exists Hi'.
do2 2 split; auto.
intros j r t Hj Hrt.
so (Hmn _#3 Hj Hrt) as H1.
so (Hpn _#3 Hj Hrt) as H2.
so (Hpq _#3 Hj Hrt) as H3.
eapply urel_zigzag; eauto.
}

(* downward *)
{
intros i' m n Hmn.
decompose Hmn.
intros Hi' Hclm Hcln Hact.
assert (i' <= i) as Hle by omega.
exists Hle.
do2 2 split; eauto.
intros j p q Hj Hpq.
assert (j <= S i') as Hj' by omega.
so (Hact _#3 Hj' Hpq) as H.
force_exact H; clear H.
f_equal.
f_equal.
apply urelspinj_equal.
eapply squash_intro; eauto.
omega.
}
Qed.

Definition guard_urel w i A B :=
  mk_urel (guard_action w i A B) (guard_uniform _ _ _ _).

Lemma ceiling_guard :
  forall n w i (A : wurel w) (B : car (urelsp (squash_urel w A i)) -> car (wurel_ofe w)) (h : n <= i),
    nonexpansive B
    -> ceiling (S n) (guard_urel w i A B)
       =
       guard_urel w n (ceiling (S n) A)
         (fun C => ceiling (S n) (B (embed_ceiling (S n) (squash_urel w A i)
                                       (transport (ceiling_squash_both w A n i h) urelsp_car C)))).
Proof.
intros n w i A B h Hne.
apply urel_extensionality.
fextensionality 3.
intros j m p.
cbn.
pextensionality.
  {
  intros (Hj_n & H).
  decompose H.
  intros Hji Hclm Hclp Hact.
  assert (j <= n) as Hjn by omega.
  exists Hjn.
  do2 2 split; auto.
  intros k q r Hk Hqr.
  destruct Hqr as (Hk_n & Hqr).
  cbn.
  split; [omega |].
  so (Hact k q r Hk Hqr) as Hmp.
  force_exact Hmp.
  f_equal.
  f_equal.
  erewrite -> transport_urelspinj.
Unshelve.
  2:{
    exact (conj Hk_n (squash_intro _#6 (le_trans _#3 Hk Hji) Hqr)).
    }
  rewrite -> embed_ceiling_urelspinj.
  reflexivity.
  }

  {
  intros H.
  decompose H.
  intros Hjn Hclm Hclp Hact.
  split; [omega |].
  assert (j <= i) as Hji by omega.
  exists Hji.
  do2 2 split; auto.
  intros k q r Hk Hqr.
  assert (k < S n) as Hk_n by omega.
  so (Hact k q r Hk (conj Hk_n Hqr)) as Hmp.
  destruct Hmp as (_ & Hmp).
  force_exact Hmp.
  f_equal.
  f_equal.
  erewrite -> transport_urelspinj.
Unshelve.
  2:{
    exact (conj Hk_n (squash_intro _#6 (le_trans _#3 Hk Hji) Hqr)).
    }
  rewrite -> embed_ceiling_urelspinj.
  reflexivity.
  }
Qed.

Lemma extend_guard :
  forall v w (h : v <<= w) i A B,
    extend_urel v w (guard_urel v i A B)
    =
    guard_urel w i (extend_urel v w A)
      (fun C => extend_urel v w
                  (B (deextend_urelsp h (squash_urel v A i)
                        (transport (eqsymm (extend_squash v w A i h)) urelsp_car C)))).
Proof.
intros v w h i A B.
apply urel_extensionality.
fextensionality 3.
intros j m p.
cbn.
pextensionality.
  {
  intro H.
  decompose H.
  intros Hj Hclm Hcln Hact.
  exists Hj.
  do2 2 split; eauto using map_hygiene_conv.
  intros k n q Hk Hnq.
  so (Hact _#3 Hk Hnq) as H.
  cbn.
  force_exact H; clear H.
  f_equal.
  f_equal.
  assert (rel (extend_urel v w (squash_urel v A i)) k triv triv) as Htriv.
    {
    eapply squash_intro; try omega.
    exact Hnq.
    }
  rewrite -> (transport_urelspinj _#3 (eqsymm (extend_squash v w A i h)) _#4 Htriv).
  rewrite -> deextend_urelsp_urelspinj.
  apply urelspinj_equal.
  exact Htriv.
  }

  {
  intro H.
  decompose H.
  intros Hj Hclm Hcln Hact.
  exists Hj.
  do2 2 split; eauto using map_hygiene.
  intros k n q Hk Hnq.
  assert (rel (extend_urel v w A) k (map_term (extend v w) n) (map_term (extend v w) q)) as Hnq'.
    {
    cbn.
    rewrite -> !extend_term_cancel; auto.
    }
  so (Hact k (map_term (extend v w) n) (map_term (extend v w) q) Hk Hnq') as H.
  cbn in H.
  force_exact H; clear H.
  f_equal.
  f_equal.
  assert (rel (extend_urel v w (squash_urel v A i)) k triv triv) as Htriv.
    {
    eapply squash_intro; try omega.
    exact Hnq.
    }
  rewrite -> (transport_urelspinj _#3 (eqsymm (extend_squash v w A i h)) _#4 Htriv).
  rewrite -> deextend_urelsp_urelspinj.
  apply urelspinj_equal.
  exact Htriv.
  }
Qed.

Lemma maximum_element :
  forall (P : nat -> Prop),
    (exists i, forall k, P k -> k < i)
    -> (forall i, ~ P i) \/ (exists i, P i /\ (forall j, P j -> j <= i)).
Proof.
intros P (i & Hi).
revert Hi.
induct i.

(* 0 *)
{
intro Hi.
left.
intros j Hj.
so (Hi j Hj).
omega.
}

(* S *)
{
intros i IH Hi.
so (excluded_middle (P i)) as [Hyes | Hno].  (* EXCLUDED MIDDLE *)
  {
  right.
  exists i.
  split; auto.
  intros j Hj.
  so (Hi j Hj).
  omega.
  }

  {
  apply IH.
  intros k Hk.
  so (eq_nat_dec i k) as [Heq | Hneq].
    {
    subst k.
    contradiction.
    }

    {
    so (Hi k Hk) as H.
    omega.
    }
  }
}
Qed.

Lemma unguard_prop :
  forall (T : ofe) w (A : wurel w) i (B : urelsp (squash_urel w A i) -n> T) (x : car T),
    exists (y : car T),
      forall j m p (Hj : j <= i) (Hmp : rel A j m p),
        dist (S j) y (pi1 B (urelspinj (squash_urel w A i) j triv triv (squash_intro _#6 Hj Hmp))).
Proof.
intros T w A i B x.
exploit (maximum_element (fun j => j <= i /\ exists m p, rel A j m p)) as H.
  {
  exists (S i).
  intros k (H & _).
  omega.
  }
destruct H as [Hnone | Hsome].
  {
  exists x.
  intros j m p Hj Hmp.
  exfalso.
  refine (Hnone j _).
  eauto.
  }

  {
  destruct Hsome as (j & (Hji & m & p & Hmp) & Hmax).
  exists (pi1 B (urelspinj (squash_urel w A i) j triv triv (squash_intro _#6 Hji Hmp))).
  intros k n q Hk Hnq.
  exploit (Hmax k) as Hkj; eauto.
  apply (pi2 B).
  apply dist_symm.
  apply urelspinj_dist; auto.
  }
Qed.

Lemma unguard_prop_unique :
  forall w (A : wurel w) i (B : urelsp (squash_urel w A i) -n> wiurel_ofe w),
    exists! (x : car (wiurel_ofe w)),
      (forall j,
         (forall k m p, k <= i -> rel A k m p -> k < j)
         -> x = iutruncate j x)
      /\
      (forall j m p (Hj : j <= i) (Hmp : rel A j m p),
         dist (S j) x (pi1 B (urelspinj (squash_urel w A i) j triv triv (squash_intro _#6 Hj Hmp)))).
Proof.
intros w A i B.
exploit (maximum_element (fun j => j <= i /\ exists m p, rel A j m p)) as H.
  {
  exists (S i).
  intros k (H & _).
  omega.
  }
destruct H as [Hnone | Hsome].
  {
  exists (iubase empty_urel).
  split.
    {
    split.
      {
      intros j Hj.
      rewrite -> iutruncate_iubase.
      rewrite -> ceiling_empty_urel.
      reflexivity.
      }

      {
      intros j m p Hj Hmp.
      exfalso.
      refine (Hnone j _).
      eauto.
      }
    }

    {
    intros y (Hy & _).
    exploit (Hy 0) as Heq.
      {
      intros k m p Hki Hmp.
      exfalso.
      refine (Hnone 0 _).
      split; [omega |].
      exists m, p.
      apply (urel_downward_leq _#3 k); auto.
      omega.
      }

      {
      rewrite -> Heq.
      symmetry.
      apply iutruncate_zero.
      }
    }
  }

  {
  destruct Hsome as (j & (Hji & m & p & Hmp) & Hbound).
  exists (iutruncate (S j) (pi1 B (urelspinj (squash_urel w A i) j triv triv (squash_intro _#6 Hji Hmp)))).
  split.
    {
    split.
      {
      intros k Hk.
      rewrite -> iutruncate_combine.
      so (Hk j m p Hji Hmp) as Hjk.
      rewrite -> Nat.min_r; auto.
      }

      {
      intros k n q Hk Hnq.
      exploit (Hbound k) as Hkj; eauto.
      eapply dist_trans.
        {
        apply (dist_downward_leq _ _ (S j)); [omega |].
        apply iutruncate_near.
        }

        {
        apply (pi2 B).
        apply dist_symm.
        apply urelspinj_dist; auto.
        }
      }
    }

    {
    intros y (Htrunc & Hdist).
    exploit (Htrunc (S j)) as Heq.
      {
      intros k n q Hki Hnq.
      cut (k <= j); [omega |].
      apply Hbound; eauto.
      }
    rewrite -> Heq.
    apply iutruncate_collapse.
    apply dist_symm.
    apply Hdist.
    }
  }
Qed.

Lemma unguard :
  forall w (A : wurel w) i (B : urelsp (squash_urel w A i) -n> wiurel_ofe w),
    existsT (x : car (wiurel_ofe w)),
      (forall j,
         (forall k m p, k <= i -> rel A k m p -> k < j)
         -> x = iutruncate j x)
      /\
      (forall j m p (Hj : j <= i) (Hmp : rel A j m p),
         dist (S j) x (pi1 B (urelspinj (squash_urel w A i) j triv triv (squash_intro _#6 Hj Hmp)))).
Proof.
intros w A i B.
exact (description _ _ (unguard_prop_unique w A i B)).
Qed.

Lemma iutruncate_unguard :
  forall n w i A B (h : n <= i),
    iutruncate (S n) (pi1 (unguard w A i B))
    =
    pi1 (unguard w (ceiling (S n) A) n
           (nearrow_compose
              (nearrow_compose (iutruncate_ne (S n)) B)
              (embed_ceiling_squash_ne w n i A h))).
Proof.
intros n w i A B h.
set (X := unguard w A i B).
destruct X as (C & HtruncC & HC).
match goal with
| |- _ = pi1 ?Y => set (X := Y)
end.
destruct X as (D & HtruncD & HD).
cbn [pi1].
exploit (maximum_element (fun j => exists m p, j <= i /\ rel A j m p)) as H.
  {
  exists (S i).
  intros k (_ & _ & H & _).
  omega.
  }
destruct H as [Hnone | Hsome].
  {
  clear HC HD.
  exploit (HtruncC 0) as HeqC.
    {
    intros k m p Hk Hmp.
    exfalso.
    refine (Hnone k _).
    eauto.
    }
  exploit (HtruncD 0) as HeqD.
    {
    intros k m p Hk Hmp.
    destruct Hmp as (_ & Hmp).
    exfalso.
    refine (Hnone k _).
    exists m, p.
    split; auto.
    omega.
    }
  rewrite -> HeqC, -> HeqD.
  rewrite -> iutruncate_combine.
  rewrite -> Nat.min_r; [| omega].
  rewrite -> !iutruncate_zero.
  reflexivity.
  }

  {
  destruct Hsome as (j & (m & p & Hji & Hmp) & Hmax).
  exploit (HtruncC (S j)) as HeqC.
    {
    intros k q r Hk Hqr.
    cut (k <= j); [omega |].
    apply Hmax; eauto.
    }
  exploit (HtruncD (min (S n) (S j))) as HeqD.
    {
    intros k q r Hk Hqr.
    destruct Hqr as (_ & Hqr).
    rewrite <- Nat.succ_min_distr.
    apply le_lt_n_Sm.
    apply Nat.min_glb; auto.
    apply Hmax.
    exists q, r.
    split; auto.
    omega.
    }
  rewrite -> HeqC, -> HeqD.
  clear HeqC HeqD.
  cbn [snd iutruncate].
  rewrite -> iutruncate_combine.
  clear Hji Hmax.
  rewrite <- Nat.succ_min_distr.
  so (Nat.le_min_l n j) as Hkn.
  set (k := min n j) in Hkn |- *.
  assert (rel A k m p) as Hmp'.
    {
    so (Nat.le_min_r n j).
    eapply urel_downward_leq; eauto.
    }
  clearbody k.
  clear j Hmp.
  rename Hmp' into Hmp.
  apply iutruncate_collapse.
  assert (rel (ceiling (S n) A) k m p) as Hmpn.
    {
    split; auto.
    omega.
    }
  eapply dist_trans.
    {
    apply (HC k m p (le_trans _#3 Hkn h) Hmp).
    }
  apply dist_symm.
  eapply dist_trans.
    {
    apply (HD k m p Hkn Hmpn).
    }
  cbn -[dist].
  eapply dist_trans.
    {
    apply (dist_downward_leq _ _ (S n)); [omega |].
    apply iutruncate_near.
    }
  apply (pi2 B).
  assert (k < S n) as Hkn' by omega.
  assert (rel (squash_urel w A i) k triv triv) as Htriv.
    {
    eapply squash_intro; eauto.
    omega.
    }
  erewrite -> transport_urelspinj.
Unshelve.
  2:{
    exact (conj Hkn' Htriv).
    }
  rewrite -> embed_ceiling_urelspinj.
  apply urelspinj_dist.
  auto.
  }
Qed.

Lemma extend_unguard :
  forall v w (h : v <<= w) i A B,
    extend_iurel h (pi1 (unguard v A i B))
    =
    pi1 (unguard w (extend_urel v w A) i
           (nearrow_compose
              (extend_iurel_ne h)
              (nearrow_compose B
                 (nearrow_compose
                    (deextend_urelsp_ne h (squash_urel v A i))
                    (transport_ne (eqsymm (extend_squash v w A i h)) urelsp))))).
Proof.
intros v w h i A B.
set (X := unguard v A i B).
destruct X as (C & HtruncC & HC).
match goal with
| |- _ = pi1 ?Y => set (X := Y)
end.
destruct X as (D & HtruncD & HD).
cbn.
exploit (maximum_element (fun j => exists m p, j <= i /\ rel A j m p)) as H.
  {
  exists (S i).
  intros k (_ & _ & H & _).
  omega.
  }
destruct H as [Hnone | Hsome].
  {
  clear HC HD.
  exploit (HtruncC 0) as HeqC.
    {
    intros k m p Hk Hmp.
    exfalso.
    refine (Hnone k _).
    eauto.
    }
  exploit (HtruncD 0) as HeqD.
    {
    intros k m p Hk Hmp.
    cbn in Hmp.
    exfalso.
    refine (Hnone k _).
    exists (map_term (extend w v) m), (map_term (extend w v) p).
    split; auto.
    }
  rewrite -> HeqC, -> HeqD.
  rewrite -> !iutruncate_zero.
  cbn.
  rewrite -> extend_iubase.
  rewrite -> extend_empty_urel; auto.
  }

  {
  destruct Hsome as (j & (m & p & Hji & Hmp) & Hmax).
  exploit (HtruncC (S j)) as HeqC.
    {
    intros k q r Hk Hqr.
    cut (k <= j); [omega |].
    apply Hmax; eauto.
    }
  exploit (HtruncD (S j)) as HeqD.
    {
    intros k q r Hk Hqr.
    cbn in Hqr.
    apply le_lt_n_Sm.
    apply Hmax.
    do 2 eexists.
    eauto.
    }
  rewrite -> HeqC, -> HeqD.
  clear HeqC HeqD.
  rewrite <- iutruncate_extend_iurel.
  apply iutruncate_collapse.
  assert (rel (extend_urel v w A) j (map_term (extend v w) m) (map_term (extend v w) p)) as Hmp'.
    {
    cbn.
    rewrite -> !extend_term_cancel; auto.
    }
  eapply dist_trans.
  2:{
    eapply dist_symm.
    so (HD j (map_term (extend v w) m) (map_term (extend v w) p) Hji Hmp') as H.
    exact H.
    }
  apply extend_iurel_nonexpansive.
  eapply dist_trans.
    {
    so (HC j m p Hji Hmp) as H.
    exact H.
    }
  apply dist_refl'.
  cbn.
  f_equal.
  erewrite -> (transport_urelspinj _#3 (eqsymm (extend_squash v w A i h))).
Unshelve.
  2:{
    eapply squash_intro; eauto.
    }
  rewrite -> deextend_urelsp_urelspinj.
  reflexivity.
  }
Qed.

Definition iuguard (w : ordinal) i (A : wiurel w) (B : urelsp (squash_urel w (den A) i) -n> wiurel_ofe w) : wiurel w
  :=
  (guard_urel w i (den A) (fun C => den (pi1 B C)),
   snd (pi1 (unguard w (den A) i B))).

Lemma iutruncate_iuguard :
  forall n w i (A : wiurel w) (B : urelsp (squash_urel w (den A) i) -n> wiurel_ofe w) (h : n <= i),
    iutruncate (S n) (iuguard w i A B)
    =
    iuguard w n
      (iutruncate (S n) A)
      (nearrow_compose
         (nearrow_compose (iutruncate_ne (S n)) B)
         (embed_ceiling_squash_ne w n i (den A) h)).
Proof.
intros n w i A B h.
unfold iuguard.
unfold iutruncate.
cbn [den fst snd].
f_equal.
  {
  rewrite -> (ceiling_guard _#5 h); auto.
  exact (pi2 (nearrow_compose den_ne B)).
  }

  {
  exact (f_equal snd (iutruncate_unguard n w i (den A) B h)).
  }
Qed.

Lemma extend_iuguard :
  forall v w (h : v <<= w) i A B,
    extend_iurel h (iuguard v i A B)
    =
    iuguard w i (extend_iurel h A)
      (nearrow_compose (extend_iurel_ne h)
         (nearrow_compose B
            (nearrow_compose
               (deextend_urelsp_ne h (squash_urel v (den A) i))
               (transport_ne (eqsymm (extend_squash v w (den A) i h)) urelsp)))).
Proof.
intros v w h i A B.
unfold iuguard, extend_iurel.
cbn.
f_equal.  (* Why slow? *)
  {
  rewrite -> (extend_guard _ _ h).
  reflexivity.
  }

  {
  exact (f_equal snd (extend_unguard _ _ h i (den A) B)).
  }
Qed.

Lemma guard_urel_satisfied_eq :
  forall w
    (A : wurel w)
    i
    (B : car (urelsp (squash_urel w A i)) -> car (wurel_ofe w))
    j m p
    (Hj : j <= i)
    (Hmp : rel A j m p),
      nonexpansive B
      -> ceiling (S j) (B (urelspinj _#4 (squash_intro _#6 Hj Hmp)))
         =
         ceiling (S j) (guard_urel w i A B).

Proof.
intros w A i B j m p Hj Hmp Hne.
apply urel_extensionality.
fextensionality 3.
intros k n q.
cbn.
pextensionality.
  {
  intros (Hk & Hnq).
  split; auto.
  assert (k <= i) as Hki by omega.
  exists Hki.
  so (urel_closed _#5 Hnq) as (Hcln & Hclq).
  do2 2 split; auto.
  intros l r t Hl Hrt.
  eapply rel_from_dist.
  2:{
    apply (urel_downward_leq _#3 k); eauto.
    }
  apply Hne.
  apply dist_symm.
  apply urelspinj_dist.
  omega.
  }

  {
  intros (Hk & Hnq).
  split; auto.
  destruct Hnq as (Hki & _ & _ & Hact).
  assert (k <= j) as Hkj by omega.
  so (urel_downward_leq _#6 Hkj Hmp) as Hmp'.
  so (Hact k m p (le_refl _) Hmp') as Hnq.
  eapply rel_from_dist; eauto.
  apply Hne.
  apply urelspinj_dist; auto.
  }
Qed.

Lemma iuguard_satisfied_eq :
  forall w
    (A : wiurel w)
    i
    (B : urelsp (squash_urel w (den A) i) -n> wiurel_ofe w)
    j m p
    (Hj : j <= i)
    (Hmp : rel (den A) j m p),
      iutruncate (S j) (pi1 B (urelspinj _#4 (squash_intro _#6 Hj Hmp)))
      =
      iutruncate (S j) (iuguard w i A B).
Proof.
intros w A i B j m p Hj Hmp.
unfold iutruncate, iuguard.
cbn [fst snd].
f_equal.
  {
  eapply (guard_urel_satisfied_eq _#3 (fun C => den (pi1 B C))).
  apply compose_ne_ne.
    {
    apply den_nonexpansive.
    }

    {
    exact (pi2 B).
    }
  }

  {
  apply meta_truncate_collapse.
  apply dist_prod_snd.
  set (X := unguard w (den A) i B).
  destruct X as (C & Htrunc & HC).
  cbn [pi1].
  apply dist_symm.
  auto.
  }
Qed.


From Coq Require Import Bool String List BinPos Compare_dec Lia Arith.
From Equations Require Import Equations.
From Translation Require Import util Sorts SAst SLiftSubst SCommon Equality.

Reserved Notation " Σ ;;; Γ '|-x' t : T " (at level 50, Γ, t, T at next level).
Reserved Notation " Σ ;;; Γ '|-x' t ≡ u : T " (at level 50, Γ, t, u, T at next level).

Open Scope s_scope.

Section XTyping.

Context `{Sort_notion : Sorts.notion}.

Inductive typing (Σ : sglobal_context) (Γ : scontext) : sterm -> sterm -> Type :=
| type_Rel n :
    forall A,
      nth_error Γ n = Some A ->
      Σ ;;; Γ |-x (sRel n) : lift0 (S n) A

| type_Sort s :
    Σ ;;; Γ |-x (sSort s) : sSort (succ s)

| type_Prod n t b s1 s2 :
    Σ ;;; Γ |-x t : sSort s1 ->
    Σ ;;; Γ ,, t |-x b : sSort s2 ->
    Σ ;;; Γ |-x (sProd n t b) : sSort (Sorts.prod_sort s1 s2)

| type_Lambda n n' t b s1 s2 bty :
    Σ ;;; Γ |-x t : sSort s1 ->
    Σ ;;; Γ ,, t |-x bty : sSort s2 ->
    Σ ;;; Γ ,, t |-x b : bty ->
    Σ ;;; Γ |-x (sLambda n t bty b) : sProd n' t bty

| type_App n s1 s2 t A B u :
    Σ ;;; Γ |-x A : sSort s1 ->
    Σ ;;; Γ ,, A |-x B : sSort s2 ->
    Σ ;;; Γ |-x t : sProd n A B ->
    Σ ;;; Γ |-x u : A ->
    Σ ;;; Γ |-x (sApp t A B u) : B{ 0 := u }

| type_Sum n t b s1 s2 :
    Σ ;;; Γ |-x t : sSort s1 ->
    Σ ;;; Γ ,, t |-x b : sSort s2 ->
    Σ ;;; Γ |-x (sSum n t b) : sSort (Sorts.sum_sort s1 s2)

| type_Pair n A B u v s1 s2 :
    Σ ;;; Γ |-x A : sSort s1 ->
    Σ ;;; Γ ,, A |-x B : sSort s2 ->
    Σ ;;; Γ |-x u : A ->
    Σ ;;; Γ |-x v : B{ 0 := u } ->
    Σ ;;; Γ |-x sPair A B u v : sSum n A B

| type_Pi1 n A B s1 s2 p :
    Σ ;;; Γ |-x p : sSum n A B ->
    Σ ;;; Γ |-x A : sSort s1 ->
    Σ ;;; Γ ,, A |-x B : sSort s2 ->
    Σ ;;; Γ |-x sPi1 A B p : A

| type_Pi2 n A B s1 s2 p :
    Σ ;;; Γ |-x p : sSum n A B ->
    Σ ;;; Γ |-x A : sSort s1 ->
    Σ ;;; Γ ,, A |-x B : sSort s2 ->
    Σ ;;; Γ |-x sPi2 A B p : B{ 0 := sPi1 A B p }

| type_Eq s A u v :
    Σ ;;; Γ |-x A : sSort s ->
    Σ ;;; Γ |-x u : A ->
    Σ ;;; Γ |-x v : A ->
    Σ ;;; Γ |-x sEq A u v : sSort (Sorts.eq_sort s)

| type_Refl s A u :
    Σ ;;; Γ |-x A : sSort s ->
    Σ ;;; Γ |-x u : A ->
    Σ ;;; Γ |-x sRefl A u : sEq A u u

| type_Ax id ty :
    lookup_glob Σ id = Some ty ->
    Σ ;;; Γ |-x sAx id : ty

| type_conv t A B s :
    Σ ;;; Γ |-x t : A ->
    Σ ;;; Γ |-x B : sSort s ->
    Σ ;;; Γ |-x A ≡ B : sSort s ->
    Σ ;;; Γ |-x t : B

where " Σ ;;; Γ '|-x' t : T " := (@typing Σ Γ t T) : x_scope

with eq_term (Σ : sglobal_context) (Γ : scontext) : sterm -> sterm -> sterm -> Type :=
| eq_reflexivity u A :
    Σ ;;; Γ |-x u : A ->
    Σ ;;; Γ |-x u ≡ u : A

| eq_symmetry u v A :
    Σ ;;; Γ |-x u ≡ v : A ->
    Σ ;;; Γ |-x v ≡ u : A

| eq_transitivity u v w A :
    Σ ;;; Γ |-x u ≡ v : A ->
    Σ ;;; Γ |-x v ≡ w : A ->
    Σ ;;; Γ |-x u ≡ w : A

| eq_beta s1 s2 n A B t u :
    Σ ;;; Γ |-x A : sSort s1 ->
    Σ ;;; Γ ,, A |-x B : sSort s2 ->
    Σ ;;; Γ ,, A |-x t : B ->
    Σ ;;; Γ |-x u : A ->
    Σ ;;; Γ |-x sApp (sLambda n A B t) A B u ≡ t{ 0 := u } : B{ 0 := u }

| eq_conv s T1 T2 t1 t2 :
    Σ ;;; Γ |-x t1 ≡ t2 : T1 ->
    Σ ;;; Γ |-x T1 ≡ T2 : sSort s ->
    Σ ;;; Γ |-x t1 ≡ t2 : T2

| cong_Prod n1 n2 A1 A2 B1 B2 s1 s2 :
    Σ ;;; Γ |-x A1 ≡ A2 : sSort s1 ->
    Σ ;;; Γ ,, A1 |-x B1 ≡ B2 : sSort s2 ->
    Σ ;;; Γ ,, A1 |-x B1 : sSort s2 ->
    Σ ;;; Γ ,, A2 |-x B2 : sSort s2 ->
    Σ ;;; Γ |-x (sProd n1 A1 B1) ≡ (sProd n2 A2 B2) :
               sSort (Sorts.prod_sort s1 s2)

| cong_Lambda n1 n2 n' A1 A2 B1 B2 t1 t2 s1 s2 :
    Σ ;;; Γ |-x A1 ≡ A2 : sSort s1 ->
    Σ ;;; Γ ,, A1 |-x B1 ≡ B2 : sSort s2 ->
    Σ ;;; Γ ,, A1 |-x t1 ≡ t2 : B1 ->
    Σ ;;; Γ ,, A1 |-x B1 : sSort s2 ->
    Σ ;;; Γ ,, A2 |-x B2 : sSort s2 ->
    Σ ;;; Γ ,, A1 |-x t1 : B1 ->
    Σ ;;; Γ ,, A2 |-x t2 : B2 ->
    Σ ;;; Γ |-x (sLambda n1 A1 B1 t1) ≡ (sLambda n2 A2 B2 t2) : sProd n' A1 B1

| cong_App n1 n2 s1 s2 t1 t2 A1 A2 B1 B2 u1 u2 :
    Σ ;;; Γ |-x A1 ≡ A2 : sSort s1 ->
    Σ ;;; Γ ,, A1 |-x B1 ≡ B2 : sSort s2 ->
    Σ ;;; Γ |-x t1 ≡ t2 : sProd n1 A1 B1 ->
    Σ ;;; Γ |-x u1 ≡ u2 : A1 ->
    Σ ;;; Γ ,, A1 |-x B1 : sSort s2 ->
    Σ ;;; Γ ,, A2 |-x B2 : sSort s2 ->
    Σ ;;; Γ |-x t1 : sProd n1 A1 B1 ->
    Σ ;;; Γ |-x t2 : sProd n2 A2 B2 ->
    Σ ;;; Γ |-x u1 : A1 ->
    Σ ;;; Γ |-x u2 : A2 ->
    Σ ;;; Γ |-x (sApp t1 A1 B1 u1) ≡ (sApp t2 A2 B2 u2) : B1{ 0 := u1 }

| cong_Sum n1 n2 A1 A2 B1 B2 s1 s2 :
    Σ ;;; Γ |-x A1 ≡ A2 : sSort s1 ->
    Σ ;;; Γ ,, A1 |-x B1 ≡ B2 : sSort s2 ->
    Σ ;;; Γ ,, A1 |-x B1 : sSort s2 ->
    Σ ;;; Γ ,, A2 |-x B2 : sSort s2 ->
    Σ ;;; Γ |-x (sSum n1 A1 B1) ≡ (sSum n2 A2 B2) : sSort (Sorts.sum_sort s1 s2)

| cong_Pair n A1 A2 B1 B2 u1 u2 v1 v2 s1 s2 :
    Σ ;;; Γ |-x A1 ≡ A2 : sSort s1 ->
    Σ ;;; Γ ,, A1 |-x B1 ≡ B2 : sSort s2 ->
    Σ ;;; Γ |-x u1 ≡ u2 : A1 ->
    Σ ;;; Γ |-x v1 ≡ v2 : B1{ 0 := u1 } ->
    Σ ;;; Γ ,, A1 |-x B1 : sSort s2 ->
    Σ ;;; Γ ,, A2 |-x B2 : sSort s2 ->
    Σ ;;; Γ |-x u1 : A1 ->
    Σ ;;; Γ |-x u2 : A2 ->
    Σ ;;; Γ |-x v1 : B1{ 0 := u1 } ->
    Σ ;;; Γ |-x v2 : B2{ 0 := u2 } ->
    Σ ;;; Γ |-x sPair A1 B1 u1 v1 ≡ sPair A2 B2 u2 v2 : sSum n A1 B1

| cong_Pi1 nx ny A1 A2 B1 B2 s1 s2 p1 p2 :
    Σ ;;; Γ |-x p1 ≡ p2 : sSum nx A1 B1 ->
    Σ ;;; Γ |-x A1 ≡ A2 : sSort s1 ->
    Σ ;;; Γ ,, A1 |-x B1 ≡ B2 : sSort s2 ->
    Σ ;;; Γ ,, A1 |-x B1 : sSort s2 ->
    Σ ;;; Γ ,, A2 |-x B2 : sSort s2 ->
    Σ ;;; Γ |-x p1 : sSum nx A1 B1 ->
    Σ ;;; Γ |-x p2 : sSum ny A2 B2 ->
    Σ ;;; Γ |-x sPi1 A1 B1 p1 ≡ sPi1 A2 B2 p2 : A1

| cong_Pi2 nx ny A1 A2 B1 B2 s1 s2 p1 p2 :
    Σ ;;; Γ |-x p1 ≡ p2 : sSum nx A1 B1 ->
    Σ ;;; Γ |-x A1 ≡ A2 : sSort s1 ->
    Σ ;;; Γ ,, A1 |-x B1 ≡ B2 : sSort s2 ->
    Σ ;;; Γ ,, A1 |-x B1 : sSort s2 ->
    Σ ;;; Γ ,, A2 |-x B2 : sSort s2 ->
    Σ ;;; Γ |-x p1 : sSum nx A1 B1 ->
    Σ ;;; Γ |-x p2 : sSum ny A2 B2 ->
    Σ ;;; Γ |-x sPi2 A1 B1 p1 ≡ sPi2 A2 B2 p2 : B1{ 0 := sPi1 A1 B1 p1 }

| cong_Eq s A1 A2 u1 u2 v1 v2 :
    Σ ;;; Γ |-x A1 ≡ A2 : sSort s ->
    Σ ;;; Γ |-x u1 ≡ u2 : A1 ->
    Σ ;;; Γ |-x v1 ≡ v2 : A1 ->
    Σ ;;; Γ |-x sEq A1 u1 v1 ≡ sEq A2 u2 v2 : sSort (Sorts.eq_sort s)

| cong_Refl s A1 A2 u1 u2 :
    Σ ;;; Γ |-x A1 ≡ A2 : sSort s ->
    Σ ;;; Γ |-x u1 ≡ u2 : A1 ->
    Σ ;;; Γ |-x sRefl A1 u1 ≡ sRefl A2 u2 : sEq A1 u1 u1

| reflection A u v e :
    Σ ;;; Γ |-x e : sEq A u v ->
    Σ ;;; Γ |-x u ≡ v : A

| eq_alpha u v A :
    nl u = nl v ->
    Σ ;;; Γ |-x u : A ->
    Σ ;;; Γ |-x u ≡ v : A

where " Σ ;;; Γ '|-x' t ≡ u : T " := (@eq_term Σ Γ t u T) : x_scope.

Delimit Scope x_scope with x.

Open Scope x_scope.

Inductive wf (Σ : sglobal_context) : scontext -> Type :=
| wf_nil :
    wf Σ nil

| wf_snoc Γ A s :
    wf Σ Γ ->
    Σ ;;; Γ |-x A : sSort s ->
    wf Σ (Γ ,, A).

Derive Signature for typing.
Derive Signature for wf.
Derive Signature for eq_term.

End XTyping.

Notation " Σ ;;; Γ '|-x' t : T " :=
  (@typing _ Σ Γ t T) (at level 50, Γ, t, T at next level) : x_scope.
Notation " Σ ;;; Γ '|-x' t ≡ u : T " :=
  (@eq_term _ Σ Γ t u T) (at level 50, Γ, t, u, T at next level) : x_scope.


(*
Class NormalImperativeProgrammingLanguage (Imp: ImperativeProgrammingLanguage): Type := {
  Ssequence: cmd -> cmd -> cmd;
  Sskip: cmd;
  neq_Sskip_Ssequence: forall c1 c2, Sskip <> Ssequence c1 c2
}.

Class SmallStepSemantics (Imp: ImperativeProgrammingLanguage) (MD: Model): Type := {
  state := model;
  exceptional_state: Type;
  step: cmd * state -> cmd * state + exceptional_state -> Prop
}.

Definition fmap_sum_left {A1 A2 B: Type} (f: A1 -> A2) (x: A1 + B): A2 + B :=
  match x with
  | inl a => inl (f a)
  | inr b => inr b
  end.

Definition fmap_Sseq {Imp: ImperativeProgrammingLanguage} {nImp: NormalImperativeProgrammingLanguage Imp} {MD: Model} {sss: SmallStepSemantics Imp MD} (mcs: cmd * state + exceptional_state) (c0: cmd) :=
  fmap_sum_left (fun cs: cmd * state => let (c, s) := cs in (Ssequence c c0, s)) mcs.

Definition fmap_pair_cmd {Imp: ImperativeProgrammingLanguage} {nImp: NormalImperativeProgrammingLanguage Imp} {MD: Model} {sss: SmallStepSemantics Imp MD} (ms: state + exceptional_state) (c: cmd) :=
  fmap_sum_left (pair c) ms.

Class NormalSmallStepSemantics (Imp: ImperativeProgrammingLanguage) {nImp: NormalImperativeProgrammingLanguage Imp} (MD: Model) (sss: SmallStepSemantics Imp MD): Type := {
  step_Ssequence1: forall c1 c2 s1 mcs2,
    c2 <> Sskip ->
    ((exists mcs1, step (c1, s1) mcs1 /\ mcs2 = fmap_Sseq mcs1 c2) <->
     step (Ssequence c1 c2, s1) mcs2);
  step_Ssequence2: forall c s mcs,
    step (c, s) mcs <->
    step (Ssequence Sskip c, s) mcs;
  step_progress: forall c s, c = Sskip <-> exists mcs, step (c, s) mcs
}.

Inductive iter_step {Imp: ImperativeProgrammingLanguage} {nImp: NormalImperativeProgrammingLanguage Imp} {MD: Model} {sss: SmallStepSemantics Imp MD}: cmd * state + exceptional_state -> cmd * state + exceptional_state -> Prop :=
| iter_step_refl: forall mcs, iter_step mcs mcs
| iter_step_step: forall cs mcs1 mcs2, step cs mcs1 -> iter_step mcs1 mcs2 -> iter_step (inl cs) mcs2.

Definition access {Imp: ImperativeProgrammingLanguage} {nImp: NormalImperativeProgrammingLanguage Imp} {MD: Model} {sss: SmallStepSemantics Imp MD} (ms_init: state + exceptional_state) (c: cmd) (ms_end: state + exceptional_state): Prop :=
  iter_step (fmap_pair_cmd ms_init c) (fmap_pair_cmd ms_end Sskip).
*)
(*
Lemma exception_go_nowhere: forall e c ms,
  access (inr e) c ms <->
  ms = inr e.
Proof.
  intros.
  split; intros.
  + hnf in H.
    remember (fmap_pair_cmd (inr e) c) as mcs1 eqn:?H.
    remember (fmap_pair_cmd ms Sskip) as mcs2 eqn:?H.
    induction H.
    - subst.
      destruct ms; inversion H1.
      subst; auto.
    - subst.
      inversion H0.
  + subst.
    hnf.
    simpl.
    apply iter_step_refl.
Qed.

Lemma aux_sequence_sound: forall c1 c2 ms1 ms3,
  access ms1 (Ssequence c1 c2) ms3 ->
  exists ms2,
  access ms1 c1 ms2 /\ access ms2 c2 ms3.
Proof.
  intros.
  destruct ms1 as [s1 | e1].
  Focus 2. {
    exists (inr e1).
    rewrite exception_go_nowhere in H.
    subst.
    split; rewrite exception_go_nowhere; auto.
  } Unfocus.
  unfold access in H.
  remember (fmap_pair_cmd (inl s1) (Ssequence c1 c2)) as mcs1 eqn:?H.
  remember (fmap_pair_cmd ms3 Sskip) as mcs2 eqn:?H.
  revert c1 H0.
  induction H; intros; subst.
  + destruct ms3 as [s3 | e3]; inversion H0.
    apply neq_Sskip_Ssequence in H1; contradiction.
  + rename IHiter_step into IH.
    specialize (IH eq_refl).
    inversion H2; subst; clear H2.
*)(*
Lemma hoare_sequence_sound: forall c1 c2 P Q R,
  triple_valid guard P c1 Q ->
  triple_valid guard Q c2 R ->
  triple_valid guard P (Ssequence c1 c2) R.
Proof.
  intros.
  hnf; intros.
  unfold access in H1.
  remember (fmap_pair_cmd (inl s_pre) (Ssequence c1 c2)) as mcs1 eqn:?H.
  remember (fmap_pair_cmd ms_post Sskip) as mcs2 eqn:?H.
  revert P c1 H H2 H3.
  induction H1; intros; subst.
  + destruct ms_post as [s_post | e]; [| inversion H3].
    inversion H3; clear H3.
    apply neq_Sskip_Ssequence in H4; contradiction.
  + rename IHiter_step into IH.
    specialize (IH eq_refl).
Abort.

*)


Generalizable All Variables.
Set Implicit Arguments.
Require Export setoid ring ZArith.

Declare Scope real_scope.
Delimit Scope real_scope with R.
Open Scope setoid_scope.
Open Scope ring_scope.
Open Scope real_scope.
Open Scope Z_scope.

Definition comparison_eq a b :=
  match a, b with
  | Eq, Eq => True
  | Lt, Lt => True
  | Gt, Gt => True
  | _, _ => False
  end.
#[global] Hint Unfold comparison_eq : eq.
Program Canonical Structure comparisonS :=
  [ ==: comparison_eq ].
Next Obligation.
  split; intros x; case x; try (intros y; case y);
  simpl; intuition.
Defined.

Class IsR (Rt : Field) (comp : Dymap Rt Rt comparison)
          (up : Rt -> Z) (IZR : Z -> Rt) :=
{
  Rlt_asym : forall a b : Rt, (comp a b == Lt) == (comp b a == Gt);
  Rlt_trans : Transitive (fun a b => comp a b == Lt);
  Radd_lt_compat : forall a b c : Rt, (comp b c == Lt) -> (comp (a + b) (a + c) == Lt);
  Rmul_lt_compat : forall (a : fucar Rt) (b c : Rt), (comp b c == Lt) -> (comp (a * b) (a * c) == Lt);
  archimed : forall a : Rt, IZR (up r) /\ IZR (up r) - r <= 1;
  complete : forall E : {ens Rt},
}.

Structure R := {
  rcar :> Field;
  compr : Dymap rcar rcar comparison;
  Rup : rcar -> Z

}.

Notation "$ x" := (proj1_sig x)
  (at level 35, right associativity, format "$ x") : real_scope.

Class IsR (Rt : Set) (R0 R1 : Rt) (Req Rlt : Rt -> Rt -> Prop)
          (Rplus Rmult : Rt -> Rt -> Rt) (Ropp : Rt -> Rt)
          (Rinv : {r : Rt | Rlt R0 r} -> {r : Rt | Rlt R0 r})
          (Rup : Rt -> Z) :=
{
  Req_equiv :> Equivalence Req;
  Rplus_comm : forall a b, Req (Rplus a b) (Rplus b a);
  Rplus_assoc : forall a b c, Req (Rplus a (Rplus b c)) (Rplus (Rplus a b) c);
  Rplus_opp_r : forall a, Req (Rplus a (Ropp a)) R0;
  Rplus_0_l : forall a, Req (Rplus R0 a) a;
  Rmult_comm : forall a b, Req (Rmult a b) (Rmult b a);
  Rmult_assoc : forall a b c, Req (Rmult a (Rmult b c)) (Rmult (Rmult a b) c);
  Rinv_l : forall a, Req (Rmult ($(Rinv a)) ($a)) R1;
  Rmult_1_l : forall a, Req (Rmult R1 a) a;
  mulRDr : forall a b c, Req (Rmult a (Rplus b c)) (Rplus (Rmult a b) (Rmult a c));

  Rtotord : forall a b, Rlt a b \/ Req a b \/ Rlt b a;
  Rlt_asym : forall a b, Rlt a b -> ~ Rlt b a;
  Rlt_trans :> Transitive Rlt;
  Rplus_lt_compat_l : forall a b c, Rlt b c -> Rlt (Rplus a b) (Rplus a c);
  Rmult_lt_compat_l : forall a b c, Rlt a R0 -> Rlt b c -> Rlt (Rmult a b) (Rmult a c)

  archimed :
}.

Structure R : Set := {
  Rcarrier :> Set;
  R0 : Rcarrier;
  R1 : Rcarrier;
  Req : Rcarrier -> Rcarrier -> Prop;
  Rlt : Rcarrier -> Rcarrier -> Prop;
  Rplus : Rcarrier -> Rcarrier -> Rcarrier;
  Rmult : Rcarrier -> Rcarrier -> Rcarrier;
  Ropp : Rcarrier -> Rcarrier;
  Rinv : {r : Rcarrier | Rlt R0 r} -> Rcarrier;
  Rup : Rcarrier -> Z
}.

(* RをInductiveに定義すると、四則演算で作れる数しか
   実数として認めないことになる *)
Inductive Runit : Set :=
| R1 : Runit
| Rinv : Runit -> Runit
| Rmulu : Runit -> Runit -> Runit
|
.

Inductive R : Set :=
| R

Inductive R : Set :=
| R0 : R
| R1 : R
| Rplus : R -> R -> R
| Rmult : R -> R -> R
| Ropp : R -> R
| Rinv : {r : R | Rlt R0 r} -> R
with Rlt : R -> R -> Prop :=
| Rlt_trans : forall a b c, R_lt a b -> R_lt b c -> R_lt a c
| Rplus_lt_compat_l : forall a b c, R_lt b c -> R_lt (a + b) (a + c)
| Rmult_lt_compat_l : forall a b c, R_lt a R0 -> R_lt b c -> R_lt (a * b) (a * c)
.

Notation "a + b" := (Rplus a b) : real_scope.
Notation "a * b" := (Rmult a b) : real_scope.
Notation "- r" := (Ropp r) : real_scope.
Notation "/ r" := (Rinv r) : real_scope.

Inductive R_eq : R -> R -> Prop :=
| R_eq_refl : forall a, R_eq a a
| R_eq_sym : forall a b, R_eq a b -> R_eq b a
| R_eq_trans : forall a b c, R_eq a b -> R_eq b c -> R_eq a c
| Rplus_comm : forall a b, R_eq (a + b) (b + a)
| Rplus_assoc : forall a b c, R_eq (a + (b + c)) (a + b + c)
| Rplus_opp_r : forall a, R_eq (a + -a) R0
| Rplus_0_l : forall a, R_eq (R0 + a) a
| Rmult_comm : forall a b, R_eq (a * b) (b * a)
| Rmult_assoc : forall a b c, R_eq (a * (b * c)) (a * b * c)
| Rmult_1_l : forall a, R_eq (R1 * a) a
| mulRDr : forall a b c, R_eq (a * (b + c)) (a * b + a * c)
.

Inductive R_lt : R -> R -> Prop :=
(* | totord : forall a b, R_lt b a \/ R_eq a b \/ R_lt a b *)
(* | Rlt_asym : forall a b, (~ R_lt b a) -> R_lt a b *)
| Rlt_trans : forall a b c, R_lt a b -> R_lt b c -> R_lt a c
| Rplus_lt_compat_l : forall a b c, R_lt b c -> R_lt (a + b) (a + c)
| Rmult_lt_compat_l : forall a b c, R_lt a R0 -> R_lt b c -> R_lt (a * b) (a * c)
.


Require Import Lia.
Require Import RelationClasses.

From Paco Require Import paco.
From sflib Require Import sflib.

From PromisingLib Require Import Axioms.
From PromisingLib Require Import Basic.
From PromisingLib Require Import DataStructure.
Require Import Time.
Require Import Event.
From PromisingLib Require Import Language.
Require Import View.
Require Import Cell.
Require Import Memory.
Require Import Cover.
Require Import TView.
Require Import Local.
Require Import Thread.
Require Import Configuration.
Require Import Progress.
Require Import APromiseConsistent.
From PromisingLib Require Import Loc.

Require Import APF.
Require Import Race.
Require Import Behavior.
Require Import SimMemory.
Require Import yjtac.
Require Import Program.
Require Import Cell.
Require Import Time.
Require Import PredStep.
Require Import ReorderPromises2.

Require Import Pred.
Require Import AMemory.
Require Import ALocal.
Require Import AThread.
Require Import APredStep.
Require Import ADRF_PF0.
Require Import ADRF_PF1.
Require Import ADRF_PF2.
Require Import ADRF_PF3.
Require Import ADRF_PF4.
Require Import ADRF_PF5.
Require Import AMapping.

Set Implicit Arguments.

Lemma forget_config_terminal c_src c_tgt
      (SIM: forget_config c_src c_tgt)
      (TERMINAL: Configuration.is_terminal c_tgt)
  :
    Configuration.is_terminal c_src.
Proof.
  inv SIM. ii. specialize (THS tid). rewrite FIND in *.
  unfold option_rel in THS. des_ifs. inv THS. split; auto.
  eapply TERMINAL; eauto.
Qed.

Lemma sim_pf_all_adequacy c_src c_tgt
      (SIM: sim_pf_all c_src c_tgt)
  :
    behaviors Configuration.step c_tgt <1=
    behaviors APFConfiguration.step c_src.
Proof.
  i. ginduction PR; i.
  - inv SIM. inv SIM0. econs 1. eapply forget_config_terminal; eauto.
  - exploit sim_pf_step; eauto. i. des; clarify.
    + inv STEP0. econs 2; eauto. econs 3; eauto.
    + inv STEP0. econs 2; eauto.
  - exploit sim_pf_step; eauto. i. des; clarify.
    + inv STEP0. econs 3; eauto.
    + inv STEP0. econs 3; eauto.
    + inv STEP0. econs 3; eauto.
  - exploit sim_pf_step; eauto. i. des; clarify.
    + inv STEP0.
      * econs 3; eauto.
      * econs 4; eauto. econs 3; eauto.
    + inv STEP0.
      * eauto.
      * econs 4; eauto.
Qed.

Theorem drf_apf s
        (RACEFREE: pf_racefree APFConfiguration.step (Configuration.init s))
  :
    behaviors Configuration.step (Configuration.init s) <1=
    behaviors APFConfiguration.step (Configuration.init s).
Proof.
  eapply sim_pf_all_adequacy.
  eapply sim_pf_init; auto.
Qed.


From iris.proofmode Require Import proofmode.
From stdpp Require Import sets list.
From cap_machine Require Import addr_reg region.

Class DisjointList A := disjoint_list : list A → Prop.
#[export] Hint Mode DisjointList ! : typeclass_instances.
Instance: Params (@disjoint_list) 2 := {}.
Notation "## Xs" := (disjoint_list Xs) (at level 20, format "##  Xs") : stdpp_scope.
Notation "##@{ A } Xs" :=
  (@disjoint_list A _ Xs) (at level 20, only parsing) : stdpp_scope.

Section disjoint_list.
  Variable A: Type.
  Context `{Disjoint A, Union A, Empty A}.
  Implicit Types X : A.

  Inductive disjoint_list_default : DisjointList A :=
    | disjoint_nil_2 : ##@{A} []
    | disjoint_cons_2 (X : A) (Xs : list A) : X ## ⋃ Xs → ## Xs → ## (X :: Xs).
  Global Existing Instance disjoint_list_default.

  Lemma disjoint_list_nil  : ##@{A} [] ↔ True.
  Proof. split; constructor. Qed.
  Lemma disjoint_list_cons X Xs : ## (X :: Xs) ↔ X ## ⋃ Xs ∧ ## Xs.
  Proof.
    split; [inversion_clear 1; auto |].
    intros [??]. constructor; auto.
  Qed.
End disjoint_list.

Lemma disjoint_mono_l A C `{ElemOf A C} (X Y Z: C) : X ⊆ Y → Y ## Z → X ## Z.
Proof. intros * HXY. rewrite !elem_of_disjoint. eauto. Qed.

Lemma disjoint_mono_r A C `{ElemOf A C} (X Y Z: C) : X ⊆ Y → Z ## Y → Z ## X.
Proof. intros * HXY. rewrite !elem_of_disjoint. eauto. Qed.

Definition ByReflexivity (P: Prop) :=
  P.
#[export] Hint Extern 1 (ByReflexivity _) => reflexivity : disj_regions.

Definition AddrRegionRange (l: list Addr) (b e: Addr) :=
  ∀ a, a ∈ l → (b <= a)%a ∧ (a < e)%a.

Lemma AddrRegionRange_singleton a :
  ByReflexivity (eqb_addr a top = false) →
  AddrRegionRange [a] a (a^+1)%a.
Proof.
  unfold ByReflexivity. cbn. intros ?%Z.eqb_neq.
  intros a' ->%elem_of_list_singleton. solve_addr.
Qed.
#[export] Hint Resolve AddrRegionRange_singleton : disj_regions.

Lemma AddrRegionRange_region_addrs b e :
  AddrRegionRange (finz.seq_between b e) b e.
Proof.
  intros a ?%elem_of_finz_seq_between. solve_addr.
Qed.
#[export] Hint Resolve AddrRegionRange_region_addrs : disj_regions.

Definition AddrRegionsRange (ll: list (list Addr)) (b e: Addr) :=
  ∀ l a, l ∈ ll → a ∈ l → (b <= a)%a ∧ (a < e)%a.

Lemma AddrRegionsRange_single l b e :
  AddrRegionRange l b e →
  AddrRegionsRange [l] b e.
Proof.
  intros Hl l' a ->%elem_of_list_singleton ?%Hl. solve_addr.
Qed.
#[export] Hint Resolve AddrRegionsRange_single | 1 : disj_regions.

Lemma AddrRegionsRange_cons l ll b e b' e' :
  AddrRegionRange l b e →
  AddrRegionsRange ll b' e' →
  AddrRegionsRange (l :: ll) (finz.min b b') (finz.max e e').
Proof.
  intros Hl Hll l' a [->|H]%elem_of_cons.
  - intros ?%Hl. solve_addr.
  - intros ?%Hll; auto. solve_addr.
Qed.
#[export] Hint Resolve AddrRegionsRange_cons | 10 : disj_regions.

Instance Empty_list {A}: Empty (list A). exact []. Defined.
Instance Union_list {A}: Union (list A). exact app. Defined.
Instance Singleton_list {A}: Singleton A (list A). exact (λ a, [a]). Defined.

Lemma addr_range_union_incl_range (ll: list (list Addr)) (b e: Addr):
  AddrRegionsRange ll b e →
  ⋃ ll ⊆ finz.seq_between b e.
Proof.
  revert b e. induction ll as [| l ll].
  - intros. cbn. unfold subseteq, list_subseteq. unfold empty, Empty_list.
    inversion 1.
  - intros b e HInd. cbn. unfold union, Union_list, subseteq, list_subseteq.
    intros x. intros [Hx|Hx]%elem_of_app.
    + specialize (HInd l x ltac:(constructor) Hx). apply elem_of_finz_seq_between.
      solve_addr.
    + assert (HI: AddrRegionsRange ll b e).
      { intros ? ? ? ?. eapply HInd. apply elem_of_list_further; eassumption.
        auto. }
      specialize (IHll _ _ HI).
      rewrite elem_of_subseteq in IHll.
      by apply IHll.
Qed.

Lemma AddrRegionRange_iff_incl_region_addrs l b e :
  AddrRegionRange l b e ↔ (l ⊆ finz.seq_between b e).
Proof.
  unfold AddrRegionRange, subseteq, list_subseteq.
  split.
  - intros H **. rewrite elem_of_finz_seq_between. by apply H.
  - intros H **. apply elem_of_finz_seq_between. by apply H.
Qed.

Lemma addr_range_disj_union_empty (l: list Addr) :
  l ## ⋃ [].
Proof.
  cbn. unfold empty, Empty_list, disjoint.
  unfold set_disjoint_instance. intros * ? ?%elem_of_nil. auto.
Qed.
#[export] Hint Resolve addr_range_disj_union_empty | 1 : disj_regions.

Lemma addr_range_disj_range_union (l: list Addr) ll b e b' e':
  AddrRegionRange l b e →
  AddrRegionsRange ll b' e' →
  ByReflexivity ((e <=? b') || (e' <=? b) = true)%a →
  l ## ⋃ ll.
Proof.
  intros Hl Hll. unfold ByReflexivity.
  rewrite orb_true_iff !Z.leb_le.
  intros.
  rewrite AddrRegionRange_iff_incl_region_addrs in Hl.
  eapply disjoint_mono_l; eauto.
  eapply disjoint_mono_r. eapply addr_range_union_incl_range; eauto.
  unfold disjoint.
  intro. rewrite !elem_of_finz_seq_between. solve_addr.
Qed.
#[export] Hint Resolve addr_range_disj_range_union | 10 : disj_regions.

Lemma addr_disjoint_list_empty : ## ([]: list (list Addr)).
Proof. constructor. Qed.
#[export] Hint Resolve addr_disjoint_list_empty : disj_regions.

Lemma addr_disjoint_list_cons (l: list Addr) ll :
  l ## ⋃ ll →
  ## ll →
  ## (l :: ll).
Proof. intros. rewrite disjoint_list_cons; auto. Qed.
#[export] Hint Resolve addr_disjoint_list_cons : disj_regions.

Ltac disj_regions :=
  once (typeclasses eauto with disj_regions).


(**
CoLoR, a Coq library on rewriting and termination.
See the COPYRIGHTS and LICENSE files.

- Adam Koprowski, 2006-04-27

Constructing terms.
*)

Set Implicit Arguments.

From CoLoR Require Import RelExtras ListExtras LogicUtil.
From CoLoR Require TermsActiveEnv.
From Coq Require Import Lia.

Module TermsBuilding (Sig : TermsSig.Signature).

  Module Export TAE := TermsActiveEnv.TermsActiveEnv Sig.

  Record appCond : Type := {
     appL: Term;
     appR: Term;
     eqEnv: env appL = env appR;
     typArr: isArrowType (type appL);
     typOk: type_left (type appL) = type appR
  }.

  Definition buildApp : appCond -> Term.

  Proof.
    intro t; inversion t as [L R eq_env typ_arr typ_ok].
    destruct L as [?? typeL typingL]; destruct R as [??? typingR]; simpl in *.
    rewrite eq_env in typingL.
    destruct typeL; try contr; simpl in *.
    rewrite typ_ok in typingL.
    exact (buildT (TApp typingL typingR)).
  Defined.

  Lemma buildApp_isApp : forall a, isApp (buildApp a).

  Proof.
    intros; destruct a; term_type_inv appL0; term_type_inv appR0.
  Qed.

  Lemma buildApp_Lok : forall a, appBodyL (buildApp_isApp a) = a.(appL).

  Proof.
    destruct a; destruct appR0; term_type_inv appL0.
  Qed.

  Lemma buildApp_Rok : forall a, appBodyR (buildApp_isApp a) = a.(appR).

  Proof.
    destruct a; destruct appR0; term_type_inv appL0.
  Qed.

  Lemma buildApp_preterm : forall a,
    term (buildApp a) = term a.(appL) @@ term a.(appR).

  Proof.
    destruct a; destruct appR0; term_type_inv appL0.
  Qed.

  Lemma buildApp_env_l : forall a, env (buildApp a) = env a.(appL).

  Proof.
    destruct a; destruct appR0; term_type_inv appL0.
  Qed.

  Lemma buildApp_type : forall a,
    type (buildApp a) = type_right (type a.(appL)).

  Proof.
    destruct a; destruct appR0; term_type_inv appL0.
  Qed.

  Record absCond : Type := {
    absB: Term;
    absT: SimpleType;
    envNotEmpty: env absB |= 0 := absT
  }.

  Definition buildAbs : absCond -> Term.

  Proof.
    intro t; inversion t as [aBody aType envCond].
    destruct aBody as [env ?? typing]; simpl in *; destruct env.
    try_solve.
    destruct o.
    exact (buildT (TAbs typing)).
    try_solve.
  Defined.

  Lemma buildAbs_isAbs: forall a, isAbs (buildAbs a).
  Proof.
    destruct a as [[env ???] ??]; destruct env.
    try_solve.
    destruct o; try_solve.
  Qed.

  Lemma buildAbs_absBody : forall a, absBody (buildAbs_isAbs a) = a.(absB).

  Proof.
    destruct a as [[env ???] ??]; destruct env.
    try_solve.
    destruct o; try_solve.
  Qed.

  Lemma buildAbs_absType : forall a, absType (buildAbs_isAbs a) = a.(absT).

  Proof.
    destruct a as [[env ???] ??]; destruct env.
    try_solve.
    destruct o; try_solve.
    unfold VarD in * .
    inversion envNotEmpty0; trivial.
  Qed.

  Lemma buildAbs_env : forall a, env (buildAbs a) = tail (env a.(absB)).

  Proof.
    destruct a as [[env ???] ??]; destruct env.
    try_solve.
    destruct o; try_solve.
  Qed.

  Definition buildVar : forall A x, (copy x None ++ A [#] EmptyEnv) |- %x := A.

  Proof.
    constructor; unfold VarD.
    rewrite nth_app_right; autorewrite with datatypes using try lia.
    replace (x - x) with 0; trivial.
    lia.
  Defined.

  Lemma buildVar_minimal : forall A x, envMinimal (buildT (buildVar A x)).

  Proof.
    intros; unfold envMinimal; trivial.
  Qed.

End TermsBuilding.


From iris.program_logic Require Export weakestpre hoare.
From iris.heap_lang Require Export lang.
From iris.algebra Require Import excl agree csum.
From iris.heap_lang Require Import assert proofmode notation.
From iris.proofmode Require Import tactics.
Set Default Proof Using "Type".

Definition one_shot_example : val := λ: <>,
  let: "x" := ref NONE in (
  (* tryset *) (λ: "n",
    CAS "x" NONE (SOME "n")),
  (* check  *) (λ: <>,
    let: "y" := !"x" in λ: <>,
    match: "y" with
      NONE => #()
    | SOME "n" =>
       match: !"x" with
         NONE => assert: #false
       | SOME "m" => assert: "n" = "m"
       end
    end)).

Definition one_shotR := csumR (exclR unitC) (agreeR ZC).
Definition Pending : one_shotR := Cinl (Excl ()).
Definition Shot (n : Z) : one_shotR := Cinr (to_agree n).

Class one_shotG Σ := { one_shot_inG :> inG Σ one_shotR }.
Definition one_shotΣ : gFunctors := #[GFunctor one_shotR].
Instance subG_one_shotΣ {Σ} : subG one_shotΣ Σ → one_shotG Σ.
Proof. solve_inG. Qed.

Section proof.
Local Set Default Proof Using "Type*".
Context `{!heapG Σ, !one_shotG Σ}.

Definition one_shot_inv (γ : gname) (l : loc) : iProp Σ :=
  (l ↦ NONEV ∗ own γ Pending ∨ ∃ n : Z, l ↦ SOMEV #n ∗ own γ (Shot n))%I.

Lemma wp_one_shot (Φ : val → iProp Σ) :
  (∀ f1 f2 : val,
    (∀ n : Z, □ WP f1 #n {{ w, ⌜w = #true⌝ ∨ ⌜w = #false⌝ }}) ∗
    □ WP f2 #() {{ g, □ WP g #() {{ _, True }} }} -∗ Φ (f1,f2)%V)
  ⊢ WP one_shot_example #() {{ Φ }}.
Proof.
  iIntros "Hf /=". pose proof (nroot .@ "N") as N.
  rewrite -wp_fupd /one_shot_example /=. wp_seq. wp_alloc l as "Hl". wp_let.
  iMod (own_alloc Pending) as (γ) "Hγ"; first done.
  iMod (inv_alloc N _ (one_shot_inv γ l) with "[Hl Hγ]") as "#HN".
  { iNext. iLeft. by iSplitL "Hl". }
  iModIntro. iApply "Hf"; iSplit.
  - iIntros (n) "!#". wp_let.
    iInv N as ">[[Hl Hγ]|H]"; last iDestruct "H" as (m) "[Hl Hγ]".
    + iMod (own_update with "Hγ") as "Hγ".
      { by apply cmra_update_exclusive with (y:=Shot n). }
      wp_cas_suc. iSplitL; last eauto.
      iModIntro. iNext; iRight; iExists n; by iFrame.
    + wp_cas_fail. iSplitL; last eauto.
      rewrite /one_shot_inv; eauto 10.
  - iIntros "!# /=". wp_seq. wp_bind (! _)%E.
    iInv N as ">Hγ".
    iAssert (∃ v, l ↦ v ∗ ((⌜v = NONEV⌝ ∗ own γ Pending) ∨
       ∃ n : Z, ⌜v = SOMEV #n⌝ ∗ own γ (Shot n)))%I with "[Hγ]" as "Hv".
    { iDestruct "Hγ" as "[[Hl Hγ]|Hl]"; last iDestruct "Hl" as (m) "[Hl Hγ]".
      + iExists NONEV. iFrame. eauto.
      + iExists (SOMEV #m). iFrame. eauto. }
    iDestruct "Hv" as (v) "[Hl Hv]". wp_load.
    iAssert (one_shot_inv γ l ∗ (⌜v = NONEV⌝ ∨ ∃ n : Z,
      ⌜v = SOMEV #n⌝ ∗ own γ (Shot n)))%I with "[Hl Hv]" as "[Hinv #Hv]".
    { iDestruct "Hv" as "[[% ?]|Hv]"; last iDestruct "Hv" as (m) "[% ?]"; subst.
      + Show. iSplit. iLeft; by iSplitL "Hl". eauto.
      + iSplit. iRight; iExists m; by iSplitL "Hl". eauto. }
    iSplitL "Hinv"; first by eauto.
    iModIntro. wp_let. iIntros "!#". wp_seq.
    iDestruct "Hv" as "[%|Hv]"; last iDestruct "Hv" as (m) "[% Hγ']"; subst.
    { by wp_match. }
    wp_match. wp_bind (! _)%E.
    iInv N as "[[Hl >Hγ]|H]"; last iDestruct "H" as (m') "[Hl Hγ]".
    { by iDestruct (own_valid_2 with "Hγ Hγ'") as %?. }
    wp_load. Show.
    iDestruct (own_valid_2 with "Hγ Hγ'") as %?%agree_op_invL'; subst.
    iModIntro. iSplitL "Hl".
    { iNext; iRight; by eauto. }
    wp_match. iApply wp_assert.
    wp_op. by case_bool_decide.
Qed.

Lemma ht_one_shot (Φ : val → iProp Σ) :
  {{ True }} one_shot_example #()
    {{ ff,
      (∀ n : Z, {{ True }} Fst ff #n {{ w, ⌜w = #true⌝ ∨ ⌜w = #false⌝ }}) ∗
      {{ True }} Snd ff #() {{ g, {{ True }} g #() {{ _, True }} }}
    }}.
Proof.
  iIntros "!# _". iApply wp_one_shot. iIntros (f1 f2) "[#Hf1 #Hf2]"; iSplit.
  - iIntros (n) "!# _". wp_proj. iApply "Hf1".
  - iIntros "!# _". wp_proj.
    iApply (wp_wand with "Hf2"). by iIntros (v) "#? !# _".
Qed.
End proof.


Require Import Category.Lib.
Require Import Category.Theory.Category.
Require Import Category.Theory.Functor.
Require Import Category.Structure.Terminal.
Require Import Category.Instance.Cat.

Generalizable All Variables.

Program Definition _1@{o h p} : Category@{o h p} := {|
  obj     := poly_unit@{o};
  hom     := fun _ _ => poly_unit@{h};
  homset  := Morphism_equality@{o h p};
  id      := fun _ => ttt;
  compose := fun _ _ _ _ _ => ttt
|}.
Next Obligation.
  now destruct f.
Qed.
Next Obligation.
  now destruct f.
Qed.

Notation "1" := _1 : category_scope.

Notation "one[ C ]" := (@one Cat _ C)
  (at level 9, format "one[ C ]") : object_scope.

#[export]
Program Instance Erase `(C : Category) : C ⟶ 1 := {
  fobj := fun _ => ttt;
  fmap := fun _ _ _ => id
}.

#[export]
Program Instance Cat_Terminal : @Terminal Cat := {
  terminal_obj := _1;
  one := Erase
}.
Next Obligation.
  constructive; auto; try exact ttt.
  destruct (fmap[f] f0); auto.
Qed.


Require Import
        Coq.Strings.String
        Coq.Arith.Mult
        Coq.Vectors.Vector.

Require Import
        Fiat.Common.SumType
        Fiat.Common.BoundedLookup
        Fiat.Common.ilist
        Fiat.Common.i2list
        Fiat.Common.DecideableEnsembles
        Fiat.Common.IterateBoundedIndex
        Fiat.Computation
        Fiat.Narcissus.Common.Specs
        Fiat.Narcissus.Common.ComposeOpt
        Fiat.Narcissus.Formats.SumTypeOpt
        Fiat.Narcissus.BinLib.AlignedByteString
        Fiat.Narcissus.BinLib.AlignedDecoders
        Fiat.Narcissus.BinLib.AlignWord
        Fiat.Narcissus.BinLib.AlignedEncodeMonad
        Fiat.Narcissus.BinLib.AlignedDecodeMonad.

Require Import
        Bedrock.Word.

Section AlignedSumType.

  Context {cache : Cache}.
  Context {cacheAddNat : CacheAdd cache nat}.

  Definition align_format_sumtype
             {m : nat}
             {types : t Type m}
             (align_encoders_n :
                ilist2.ilist2 (B := fun T : Type => T -> CacheFormat -> nat) types)
             (align_encoders_v :
                i2list (B := fun T : Type => T -> CacheFormat -> nat)
                       (fun (T : Type) (n : _) => forall t ce, Vector.t (word 8) (n t ce)) align_encoders_n)
             (align_encoders_ce :
                ilist (B := (fun T : Type => T -> CacheFormat -> CacheFormat)) types)
             (st : SumType types)
             (ce : CacheFormat)
    := (existT _ _ (i2th align_encoders_v (SumType_index types st) (SumType_proj types st) ce),
        ith align_encoders_ce (SumType_index types st) (SumType_proj types st) ce).

  Lemma align_format_sumtype_OK'
        {m : nat}
        {types : t Type m}
        (align_encoders_n :
           ilist2.ilist2 (B := fun T : Type => T -> CacheFormat -> nat) types)
        (align_encoders_v :
           i2list (B := fun T : Type => T -> CacheFormat -> nat)
                  (fun (T : Type) (n : _) => forall t ce, Vector.t (word 8) (n t ce)) align_encoders_n)
        (align_encoders_ce :
           ilist (B := (fun T : Type => T -> CacheFormat -> CacheFormat)) types)
        (formatrs :
           ilist (B := (fun T : Type => T -> @CacheFormat cache -> Comp (ByteString * (CacheFormat)))) types)
        (formatrs_OK : forall idx t (ce : CacheFormat),
            refine (ith formatrs idx t ce)
                   (ret (build_aligned_ByteString (i2th align_encoders_v idx t ce),
                         ith align_encoders_ce idx t ce)))
    : forall (st : SumType types)
             (ce : CacheFormat),
      refine (format_SumType types formatrs st ce)
             (ret (build_aligned_ByteString (projT2 (fst (align_format_sumtype
                                                            align_encoders_n
                                                            align_encoders_v
                                                            align_encoders_ce st ce))),
                   (snd (align_format_sumtype align_encoders_n
                                                            align_encoders_v
                                                            align_encoders_ce st ce)))).
  Proof.
    intros; unfold format_SumType, align_format_sumtype.
    rewrite formatrs_OK; reflexivity.
  Qed.

  Corollary align_format_sumtype_OK
            {m : nat}
            {types : t Type m}
            (align_encoders_n :
               ilist2.ilist2 (B := fun T : Type => T -> CacheFormat -> nat) types)
            (align_encoders_v :
               i2list (B := fun T : Type => T -> CacheFormat -> nat)
                      (fun (T : Type) (n : _) => forall t ce, Vector.t (word 8) (n t ce)) align_encoders_n)
            (align_encoders_ce :
               ilist (B := (fun T : Type => T -> CacheFormat -> CacheFormat)) types)
            (formatrs :
               ilist (B := (fun T : Type => T -> @CacheFormat cache -> Comp (ByteString * (CacheFormat)))) types)
            (formatrs_OK : Iterate_Ensemble_BoundedIndex (fun idx => forall t (ce : CacheFormat),
                                                              refine (ith formatrs idx t ce)
                                                                         (ret (build_aligned_ByteString (i2th align_encoders_v idx t ce),
                                                                               ith align_encoders_ce idx t ce))))
    : forall (st : SumType types)
             (ce : CacheFormat),
      refine (format_SumType types formatrs st ce)
             (ret (build_aligned_ByteString (projT2 (fst (align_format_sumtype align_encoders_n
                                                                               align_encoders_v
                                                                               align_encoders_ce st ce))),
                   (snd (align_format_sumtype align_encoders_n
                                              align_encoders_v
                                              align_encoders_ce st ce)))).
  Proof.
    intros; eapply align_format_sumtype_OK'; intros.
    eapply Iterate_Ensemble_BoundedIndex_equiv in formatrs_OK.
    apply formatrs_OK.
  Qed.

  Lemma align_format_sumtype_OK_inv'
        {m : nat}
        {types : t Type m}
        (A_OKs : SumType types -> Prop)
        (align_encoders_n :
               ilist2.ilist2 (B := fun T : Type => T -> CacheFormat -> nat) types)
            (align_encoders_v :
               i2list (B := fun T : Type => T -> CacheFormat -> nat)
                      (fun (T : Type) (n : _) => forall t ce, Vector.t (word 8) (n t ce)) align_encoders_n)
            (align_encoders_ce :
               ilist (B := (fun T : Type => T -> CacheFormat -> CacheFormat)) types)
        (encoders :
           ilist (B := (fun T : Type => T -> CacheFormat -> Comp (ByteString * (CacheFormat)))) types)
        (encoders_OK : forall idx t (ce : CacheFormat),
            A_OKs (inj_SumType _ idx t)
            -> refine (ith encoders idx t ce)
                      (ret (build_aligned_ByteString (i2th align_encoders_v idx t ce),
                            ith align_encoders_ce idx t ce)))
    : forall (st : SumType types)
             (ce : CacheFormat),
      A_OKs st
      -> refine (format_SumType types encoders st ce)
                (ret (build_aligned_ByteString (projT2 (fst (align_format_sumtype align_encoders_n
                                                                               align_encoders_v
                                                                               align_encoders_ce st ce))),
                      (snd (align_format_sumtype align_encoders_n
                                                 align_encoders_v
                                                 align_encoders_ce st ce)))).
  Proof.
    intros; unfold format_SumType, align_format_sumtype.
    rewrite encoders_OK; eauto.
    reflexivity.
    rewrite inj_SumType_proj_inverse; eauto.
  Qed.

  Corollary align_format_sumtype_OK_inv
            {m : nat}
            {types : t Type m}
            (A_OKs : SumType types -> Prop)
            (align_encoders_n :
               ilist2.ilist2 (B := fun T : Type => T -> CacheFormat -> nat) types)
            (align_encoders_v :
               i2list (B := fun T : Type => T -> CacheFormat -> nat)
                      (fun (T : Type) (n : _) => forall t ce, Vector.t (word 8) (n t ce)) align_encoders_n)
            (align_encoders_ce :
               ilist (B := (fun T : Type => T -> CacheFormat -> CacheFormat)) types)
            (encoders :
               ilist (B := (fun T : Type => T -> CacheFormat -> Comp (ByteString * (CacheFormat)))) types)
            (encoders_OK : Iterate_Ensemble_BoundedIndex
                             (fun idx => forall t (ce : CacheFormat),
                                  A_OKs (inj_SumType _ idx t)
                                  -> refine (ith encoders idx t ce)
                                            (ret (build_aligned_ByteString (i2th align_encoders_v idx t ce),
                                                  ith align_encoders_ce idx t ce))))
    : forall (st : SumType types)
             (ce : CacheFormat),
      A_OKs st
      -> refine (format_SumType types encoders st ce)
                (ret (build_aligned_ByteString (projT2 (fst (align_format_sumtype align_encoders_n
                                                                               align_encoders_v
                                                                               align_encoders_ce st ce))),
                      (snd (align_format_sumtype align_encoders_n
                                                 align_encoders_v
                                                 align_encoders_ce st ce)))).
  Proof.
    intros; eapply align_format_sumtype_OK_inv'; intros.
    eapply Iterate_Ensemble_BoundedIndex_equiv in encoders_OK.
    apply encoders_OK; eauto.
    eauto.
  Qed.

  Lemma AlignedFormatSumTypeDoneC
            {m : nat}
            {types : t Type m}
            (A_OKs_l : ilist (B := fun T : Type => T -> Prop) types)
            (A_OKs : SumType types -> Prop := fun st => ith A_OKs_l (SumType_index _ st) (SumType_proj _ st))
            (align_encoders_n :
               ilist2.ilist2 (B := fun T : Type => T -> CacheFormat -> nat) types)
            (align_encoders_v :
               i2list (B := fun T : Type => T -> CacheFormat -> nat)
                      (fun (T : Type) (n : _) => forall t ce, Vector.t (word 8) (n t ce)) align_encoders_n)
            (align_encoders_ce :
               ilist (B := (fun T : Type => T -> CacheFormat -> CacheFormat)) types)
            (encoders :
               ilist (B := (fun T : Type => T -> CacheFormat -> Comp (ByteString * (CacheFormat)))) types)
            (encoders_OK : Iterate_Ensemble_BoundedIndex
                             (fun idx => forall t (ce : CacheFormat),
                                  A_OKs (inj_SumType _ idx t)
                                  -> refine (ith encoders idx t ce)
                                            (ret (build_aligned_ByteString (i2th align_encoders_v idx t ce),
                                                  ith align_encoders_ce idx t ce))))
    : forall (st : SumType types)
             (ce : CacheFormat),
      A_OKs st
      -> refine (((format_SumType types encoders st) DoneC) ce)
                (ret (build_aligned_ByteString (projT2 (fst (align_format_sumtype align_encoders_n
                                                                                align_encoders_v
                                                                                align_encoders_ce st ce))),
                      (snd (align_format_sumtype align_encoders_n
                                                 align_encoders_v
                                                 align_encoders_ce st ce)))).
  Proof.
    intros.
    etransitivity.
    eapply AlignedFormatDoneC.
    rewrite (align_format_sumtype_OK_inv A_OKs); try eassumption.
    instantiate (2 := fun ce => fst (align_format_sumtype align_encoders_n align_encoders_v align_encoders_ce st ce)).
    instantiate (1 := fun ce => snd (align_format_sumtype align_encoders_n align_encoders_v align_encoders_ce st ce)).
    simpl; reflexivity.
    simpl; reflexivity.
  Qed.

  Definition AlignedEncodeSumType
             {m : nat}
             {types : t Type m}
             (aligned_encoders :
                  ilist (B := fun T : Type => forall sz, AlignedEncodeM (S := T) sz) types)
    : forall sz, AlignedEncodeM (S := SumType types) sz :=
    fun sz v idx st env => ith aligned_encoders (SumType_index types st) sz v idx (SumType_proj types st) env.

  Lemma CorrectAlignedEncoderForFormatSumType'
            {m : nat}
            {types : t Type m}
            (formats : ilist types)
            (aligned_encoders :
                  ilist (B := fun T : Type => forall sz, AlignedEncodeM (S := T) sz) types)
            (encoders_OK :
               forall idx,
                 CorrectAlignedEncoder (ith formats idx) (ith aligned_encoders idx))
    : CorrectAlignedEncoder (format_SumType types formats)
                            (AlignedEncodeSumType aligned_encoders).
  Proof.
    unfold CorrectAlignedEncoder; intros.
    eexists (fun st => projT1 (encoders_OK (SumType_index types st)) (SumType_proj types st)).
    split; [ | split]; intros.
    - pose proof (projT2 (encoders_OK (SumType_index types s))); simpl in *; destruct H.
      specialize (H (SumType_proj types s) env); intuition.
    - pose proof (projT2 (encoders_OK (SumType_index types s))); simpl in *; destruct H0.
      specialize (H0 (SumType_proj types s) env); intuition.
      specialize (H0 (SumType_proj types s) env); intuition eauto.
    - unfold EncodeMEquivAlignedEncodeM; intros.
      pose proof (projT2 (encoders_OK (SumType_index types s))); simpl in *; destruct H.
      unfold EncodeMEquivAlignedEncodeM in H0; intuition eauto;
        specialize (H2 env (SumType_proj types s) idx); intuition eauto;
          specialize (H2 t env' _ v); specialize (H5 t env'); eauto.
  Qed.

  Lemma CorrectAlignedEncoderForFormatSumType
            {m : nat}
            {types : t Type m}
            (formats : ilist types)
            (aligned_encoders :
                  ilist (B := fun T : Type => forall sz, AlignedEncodeM (S := T) sz) types)
            (encoders_OK :
               Iterate_Dep_Type_BoundedIndex
                 (fun idx =>
                 CorrectAlignedEncoder (ith formats idx) (ith aligned_encoders idx)))
    : CorrectAlignedEncoder (format_SumType types formats)
                            (AlignedEncodeSumType aligned_encoders).
  Proof.
    intros; eapply CorrectAlignedEncoderForFormatSumType'.
    eapply Lookup_Iterate_Dep_Type; eauto.
  Qed.

  Definition SumTypeAlignedDecodeM {n m}
           {types : Vector.t Type (S n)}
           (aligned_decoders :
              ilist (B := fun T => forall n, AlignedDecodeM T n) types)
           (idx : Fin.t (S n))
    : AlignedDecodeM (SumType types) m :=
    (fun v idx' cd => `(i, bs, cd') <- (ith aligned_decoders idx _ v idx' cd);
     Ok (inj_SumType types idx i, bs, cd')).

  Lemma AlignedDecodeSumTypeM {C : Type}
        {n}
        {types : Vector.t Type (S n)}
        (decoders : ilist (B := fun T => ByteString -> CacheDecode -> Hopefully (T * ByteString * CacheDecode)) types)
        (aligned_decoders :
           ilist (B := fun T => forall n, AlignedDecodeM T n) types)
        (idx : Fin.t (S n))
    : forall (t : SumType types -> DecodeM (C * _) ByteString)
             (t' : SumType types -> forall {numBytes}, AlignedDecodeM C numBytes),
      (Iterate_Ensemble_BoundedIndex (fun idx =>
                                        DecodeMEquivAlignedDecodeM (ith decoders idx) (ith aligned_decoders idx)))
      -> (forall b, DecodeMEquivAlignedDecodeM (t b) (@t' b))
      -> DecodeMEquivAlignedDecodeM
           (fun v cd => `(l, bs, cd') <- decode_SumType types decoders idx v cd;
                          t l bs cd')
           (fun numBytes => l <- SumTypeAlignedDecodeM aligned_decoders idx;
                            t' l)%AlignedDecodeM%list.
  Proof.
    intros.
    eapply Bind_DecodeMEquivAlignedDecodeM; eauto.
    apply (proj1 (Iterate_Ensemble_BoundedIndex_equiv _)) with (idx0 := idx) in H.
    unfold decode_SumType, SumTypeAlignedDecodeM.
    eapply DecodeMEquivAlignedDecodeM_trans; simpl; intros.
    eapply Bind_DecodeMEquivAlignedDecodeM; eauto.
    2: { simpl. destruct (ith decoders idx b cd) as [((?&?)&?)|]; eauto; simpl.
         constructor; left.
         higher_order_reflexivity. }
    2: simpl; unfold AlignedDecodeMEquiv; simpl; intros.
    intros.
    eapply DecodeMEquivAlignedDecodeM_trans; simpl; intros.
    eapply Return_DecodeMEquivAlignedDecodeM.
    higher_order_reflexivity.
    apply AlignedDecodeMEquiv_refl.
    unfold BindAlignedDecodeM, DecodeBindOpt2, BindOpt.
    destruct (ith aligned_decoders idx n0 v idx0 c); simpl; eauto.
    destruct p as [ [? ?] ?]; reflexivity.
  Qed.

End AlignedSumType.

Arguments align_format_sumtype : simpl never.
Arguments SumType_proj : simpl never.
Arguments SumType_index : simpl never.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

Theorem pipo_6 : (forall A B C Aprime Bprime Cprime O X Y M : Universe, ((wd_ B O /\ (wd_ A O /\ (wd_ C O /\ (wd_ Bprime O /\ (wd_ Aprime O /\ (wd_ Cprime O /\ (wd_ X Y /\ (wd_ A Aprime /\ (wd_ A M /\ (wd_ Aprime X /\ (wd_ A B /\ (wd_ Aprime B /\ (wd_ Bprime A /\ (wd_ Bprime B /\ (wd_ Aprime Cprime /\ (wd_ Aprime Bprime /\ (wd_ A Cprime /\ (wd_ B C /\ (wd_ Bprime Cprime /\ (wd_ A C /\ (wd_ Aprime C /\ (wd_ C Cprime /\ (col_ O A Aprime /\ (col_ O B Bprime /\ (col_ O C Cprime /\ (col_ A X Y /\ (col_ Aprime X Y /\ (col_ M X Y /\ col_ M O C)))))))))))))))))))))))))))) -> col_ Aprime X A)).
Proof.
  time tac.
Qed.

End FOFProblem.


(* *********************************************************************)
(*                                                                     *)
(*            The CertiKOS Certified Kit Operating System              *)
(*                                                                     *)
(*                   The FLINT Group, Yale University                  *)
(*                                                                     *)
(*  Copyright The FLINT Group, Yale University.  All rights reserved.  *)
(*  This file is distributed under the terms of the Yale University    *)
(*  Non-Commercial License Agreement.                                  *)
(*                                                                     *)
(* *********************************************************************)
(* *********************************************************************)
(*                                                                     *)
(*              Layers of VMM                                          *)
(*                                                                     *)
(*          Refinement proof for MALInit layer                         *)
(*                                                                     *)
(*          Ronghui Gu <ronghui.gu@yale.edu>                           *)
(*                                                                     *)
(*          Yale Flint Group                                           *)
(*                                                                     *)
(* *********************************************************************)

(** This file provide the contextual refinement proof between MBoot layer and MALInit layer*)
Require Import BootGenDef.
Require Import BootGenLemma.
Require Import BootGenAccessorDef.
Require Import GuestAccessIntelRef0.

(** * Definition of the refinement relation*)
Section Refinement.

  Section WITHMEM.

    Context `{Hstencil: Stencil}.
    Context `{Hmem: Mem.MemoryModel}.
    Context `{Hmwd: UseMemWithData mem}.

    Ltac pattern2_refinement_simpl:=
      pattern2_refinement_simpl' (@relate_AbData).

    Notation hStore := (fun F V => exec_storeex1 (flatmem_store := flatmem_store') (F:=F) (V:=V)).

    Notation lStore := (fun F V => exec_storeex0 (F:=F) (V:=V)).

    Require Import XOmega.
    Require Import HostAccess0.
    Require Import HostAccess1.
    Require Import LoadStoreGeneral.

    Opaque align_chunk Z.mul Z.div Z.sub.

    Lemma exec_flatmem_store_correct0:
      forall {F V: Type} (ge2: Genv.t F V) (s: stencil) ι (m1 m2 m1': mem) rs1 rs2 rs1' (d1 d1': HDATAOps) d2 r chunk n ds,
        exec_flatmem_store (flatmem_store:= flatmem_store') chunk (m1, d1) n rs1 r ds =
        Next rs1' (m1', d1') ->
        MatchPrimcallStates (one_crel (CompatRelOps0:= rel_ops) HDATAOps LDATAOps) s ι rs1 m1 d1 rs2 m2 d2 ->
        stencil_matches s ge2 ->
        0<= n <= adr_max - size_chunk chunk ->
        (align_chunk chunk | n) ->
        exists rs2' m2' d2',
          Asm.exec_store (mem:= mwd LDATAOps) ge2 chunk (m2, d2)
                         (Addrmode None None (inr (FlatMem_LOC, Int.repr n)))
                         rs2 r ds = Next rs2' (m2', d2') /\
          MatchPrimcallStates (one_crel (CompatRelOps0:= rel_ops) HDATAOps LDATAOps) s ι rs1' m1' d1' rs2' m2' d2'.
    Proof.
      intros. inv H0. pose proof match_extcall_states as Hmatch_ext.
      inv match_extcall_states.
      inv match_match. inv H0.
      pose proof H3 as Hmatch.
      unfold Asm.exec_store. simpl.
      assert (Hsym': Genv.find_symbol ge2 FlatMem_LOC = Some b).
      {
        inv H1. congruence.
      }
      unfold symbol_offset. rewrite Hsym'. simpl.
      Opaque Z.sub.
      lift_trivial.
      repeat rewrite Int.add_zero.
      unfold exec_flatmem_store in *.
      assert (HOS1: n + size_chunk chunk <= adr_max).
      {
        revert H2; clear; intros.
        Transparent Z.sub.
        omega.
      }
      assert (HOS2: n >= 0) by omega.
      pose proof (size_chunk_pos chunk) as HOS3.
      rewrite Int.unsigned_repr; [|rewrite_omega].
      subdestruct.
      exploit (flatmem_store_correct0 (rs1 r) (rs2 r)); eauto.
      intros (m2' & Hstore & Hmatch_ext').
      rewrite Hstore. unfold set; simpl. inv H.
      refine_split'; eauto 1.
      constructor; eauto.
      val_inject_simpl.
    Qed.

    Opaque Z.sub.

    Lemma store_correct:
      store_accessor_sim_def HDATAOps LDATAOps (one_crel HDATAOps LDATAOps) hStore lStore.
    Proof.
      unfold store_accessor_sim_def. intros.
      pose proof H2 as Hmatch.
      inv H2. inv match_extcall_states.

      unfold exec_storeex1 in *.
      unfold exec_storeex0.
      unfold exec_host_store0, exec_host_store1 in *.
      unfold exec_host_store_snd0.
      inv H4.
      exploit (eval_addrmode_correct ge1 ge2 a); eauto. simpl; intros HW.
      simpl in *; revert H1.
      inv match_related. subrewrite''. intros HLoad.
      destruct (eval_addrmode ge1 a rs1) eqn: H1; contra_inv.
      - (* addr is Vint*)
        inv HW.
        destruct (ihost d2) eqn: HPH; contra_inv.
        destruct (pg d2) eqn: HPE; contra_inv.
        + (* host *)
          destruct (CR3 d2); contra_inv.
          destruct (Genv.find_symbol ge1 b) eqn:Hsymol; contra_inv.
          assert (HFB: Genv.find_symbol ge2 b = Some b0).
          {
            inv H. inv H0. congruence.
          }
          rewrite HFB.
          revert HLoad. lift_trivial. intros HLoad.
          exploit (stencil_find_symbol_inject (ge:= ge1)); eauto. intros HF0.
          destruct (Mem.load Mint32 m1 b0 (Int.unsigned (Int.repr (Int.unsigned ofs + PDX (Int.unsigned i) * 4))))
                   eqn: HLD; contra_inv.
          exploit Mem.load_inject; eauto.
          rewrite Z.add_0_r; intros [v1[HLD1 HVAL]].
          rewrite HLD1. clear HLD HLD1.
          destruct v; contra_inv. inv HVAL.
          inv match_match. inv H2.
          assert (HFB': Genv.find_symbol ge2 FlatMem_LOC = Some b1).
          {
            inv H. inv H0. congruence.
          }
          rewrite HFB'.
          destruct (FlatMem.load Mint32 (HP d1)
                                 (Int.unsigned i0 / 4096 * 4096 + PTX (Int.unsigned i) * 4))
                   eqn: HLD; contra_inv.
          pose proof (PTX_Addr_range i0 i) as HPTX_Range.
          pose proof (PTX_Addr_divide i0 i) as HPTX_Divide.
          exploit flatmem_load_correct0; eauto.
          simpl; lift_trivial.
          intros (v' & HLD' & HVAL). inv HVAL.
          pose proof (PTX_Addr_range' i0 i) as HPTX_Range'.
          rewrite Int.unsigned_repr; trivial.
          rewrite HLD'.
          destruct (zle (Int.unsigned i mod 4096) (4096 - size_chunk chunk)); contra_inv.
          destruct (Zdivide_dec (align_chunk chunk) (Int.unsigned i mod 4096)
                                (Memdata.align_chunk_pos chunk)); contra_inv.
          pose proof (PTADDR_range (Int.unsigned i) i1 chunk l) as HOS1.
          pose proof (PTADDR_divide (Int.unsigned i) i1 chunk d) as HOS2.
          subdestruct.
          * eapply exec_flatmem_store_correct0; eauto 1.
          * eapply exec_flatmem_store_correct0; eauto 1.
          * eapply pagefault_correct; eauto.
        + eapply guest_intel_correct1; eauto.
          unfold GuestAccessIntel1.store_accessor1, GuestAccessIntel0.store_accessor0.
          intros. subdestruct.
          eapply exec_flatmem_store_correct0; eauto 1.
          * eapply PTADDR_range; assumption.
          * eapply PTADDR_divide; assumption.

      - (* adr is (b,ofs) *)
        inv HW; subdestruct; eapply storel_correct; eauto.
    Qed.

  End WITHMEM.

End Refinement.