(**
 * QueueData.v
 *
 * Definitions and properties of queue and node data.
 *)

(** Compcert helper lib *)
Require Import Coqlib.
Require Import Maps.
(** Compcert types and semantics *)
Require Import AST.
Require Import Integers.
Require Import Values.
(** CertiKOS layer library *)
Require Import Structures.
Require Import AbstractData.
Require Import AbstractionRelation.
Require Import SimulationRelation.
Require Import CPrimitives.
Require Import MemWithData.
Require Import Decision.

Require Import TutoLib.

(** This file contains the definitions of the abstract data for the queue
  layers as well as some auxiliary lemmas. The queue is represented at the low
  level by a doubly-linked list where indices into a fixed-size array are used
  instead of pointers. This is then abstracted in the top layer to a
  Coq [list]. This example differs from the other two by having two layers at
  the same level ([Node] and [QueueIntro]), and then building on top of their
  composition. One consequence of this is that the both the abstract data as
  well as the [match_data] and [relate_data] relations must be the same for
  both layers. For this reason, these definitions are in this file instead of
  their usual places. *)

Open Scope Z_scope.

Definition MAX_NODES : Z := 1024.
Fact MAX_NODES_range : 0 < 12 * MAX_NODES <= Int.max_unsigned.
Proof. cbv. intuition. Qed.

Global Opaque MAX_NODES.

(** ** Node Representations *)
Section NODE_DATA.

  (** *** Low Level Definition *)

  (** The low level node represents a node in a typical C doubly-linked list *)
  Inductive node_low : Type :=
  | NodeUndef
  | Node (data: Z) (next: Z) (prev: Z).

  Definition node_pool := ZMap.t node_low.

  (** Struct offsets *)
  Definition data_off := 0.
  Definition next_off := 4.
  Definition prev_off := 8.
  Definition node_sz := 12.

  (** A node is valid if it only points to nodes in the appropriate range. *)
  Inductive node_valid : node_low -> Prop :=
  | NodeOk: forall d nxt prv,
      0 <= nxt <= MAX_NODES ->
      0 <= prv <= MAX_NODES ->
      node_valid (Node d nxt prv).

  (** Sanity check. *)
  Remark node_undef_not_valid : ~node_valid NodeUndef.
  Proof. red; intros; inv H. Qed.

  (** *** Abstract Definition *)

  (** The high level node just stores data and keeps track of whether it is
    currently in the queue. *)
  Inductive abs_node : Type :=
  | AbsNodeUndef
  | AbsNode (data: Z) (inQ: bool).

  Definition abs_node_pool := ZMap.t abs_node.

  (** All non-undef nodes are valid here. *)
  Inductive abs_node_valid : abs_node -> Prop :=
  | AbsNodeOk: forall d inq,
      abs_node_valid (AbsNode d inq).

  Remark abs_node_undef_not_valid : ~abs_node_valid AbsNodeUndef.
  Proof. red; intros; inv H. Qed.

End NODE_DATA.

Ltac unfold_node_fields :=
  unfold node_sz, data_off, next_off, prev_off in *.

(** ** Queue Representations *)
Section QUEUE_DATA.

  (** *** Low Level Definition *)

  (** The low level queue is also essentially a C-style doubly-linked list. *)
  Inductive queue_low : Type :=
  | QueueUndef
  | Queue (head: Z) (tail: Z).

  (** Struct offsets. *)
  Definition head_off := 0.
  Definition tail_off := 4.
  Definition queue_sz := 8.

  (** A queue is valid if its head and tail are in the appropriate range. *)
  Inductive queue_valid : queue_low -> Prop :=
  | QVOk: forall hd tl,
      0 <= hd <= MAX_NODES ->
      0 <= tl <= MAX_NODES ->
      queue_valid (Queue hd tl).

  Remark queue_undef_not_valid : ~queue_valid QueueUndef.
  Proof. red; intros; inv H. Qed.

  (** ** Abstract Definition *)

  (** The high level queue is just a Coq [list]. *)
  Inductive abs_queue : Type :=
  | AbsQueueUndef
  | AbsQueue (q: list Z).

  (** Here a queue is valid if all of its nodes are in the right range. *)
  Inductive abs_queue_valid : abs_queue -> Prop :=
  | AQVQOk: forall q,
      Forall (fun nd => 0 <= nd < MAX_NODES) q ->
      abs_queue_valid (AbsQueue q).

  Remark abs_queue_undef_not_valid : ~abs_queue_valid AbsQueueUndef.
  Proof. red; intros; inv H. Qed.

  (** The elements of a queue are unique if each appears exactly once. *)
  Inductive abs_queue_unique : abs_queue -> Prop :=
  | AQUOk: forall q,
      Forall (fun nd => count_occ zeq q nd = 1%nat) q ->
      abs_queue_unique (AbsQueue q).

  (** The [inQ] flag of [abs_node] should actually mean the node is in the
    queue. *)
  Inductive In_Q_inQ : abs_queue -> Z -> abs_node_pool -> Prop :=
  | IQOk: forall q nd anpool dat inQ,
      ZMap.get nd anpool = AbsNode dat inQ ->
      (inQ = true <-> In nd q) ->
      In_Q_inQ (AbsQueue q) nd anpool.

End QUEUE_DATA.

Ltac unfold_queue_fields :=
  unfold queue_sz, head_off, tail_off in *.

(** ** Abstract Data *)
Section ABS_DATA.

  Context `{Hmem: BaseMemoryModel}.

  (** The abstract data tracks both the low level and high level queue
    representations, but each layer will only place invariants on one
    of them. *)
  Record abs_data : Type := {
    init_flag: bool;
    npool: node_pool;
    queue: queue_low;
    anpool: abs_node_pool;
    aqueue: abs_queue
  }.

  Definition abs_data_init : abs_data :=
    {|
      init_flag := false;
      npool := ZMap.init NodeUndef;
      queue := QueueUndef;
      anpool := ZMap.init AbsNodeUndef;
      aqueue := AbsQueueUndef
    |}.

  Instance boot_data_ops : AbstractDataOps unit :=
    {|
      init_data := tt;
      data_inv := fun _ => True;
      data_inject := fun _ _ _ => True
    |}.

  Instance boot_data_data : AbstractData unit.
  Proof. repeat constructor. Qed.

  Definition boot_layerdata : layerdata :=
    {|
      ldata_type := unit;
      ldata_ops  := boot_data_ops;
      ldata_prf  := boot_data_data
    |}.

  Definition boot_L : clayer boot_layerdata := ∅.

  (** The [Intro] layer represents the composition of the [Node] and
    [QueueIntro] layers. *)
  Record intro_inv (d: abs_data) : Prop := {
    npool_valid: forall node,
      let n := ZMap.get node (npool d) in
      0 <= node < MAX_NODES ->
      (n = NodeUndef \/ node_valid n);
    preinit_q: init_flag d = false -> queue d = QueueUndef;
    q_valid: init_flag d = true -> queue_valid (queue d)
  }.

  Instance intro_data_ops : AbstractDataOps abs_data :=
    {|
      init_data := abs_data_init;
      data_inv := intro_inv;
      data_inject := fun _ _ _ => True
    |}.

  Instance intro_data_data : AbstractData abs_data.
  Proof.
    constructor; constructor; cbn; intros; try congruence.
    rewrite ZMap.gi. auto.
  Qed.

  Definition intro_layerdata : layerdata :=
    {|
      ldata_type := abs_data;
      ldata_ops  := intro_data_ops;
      ldata_prf  := intro_data_data
    |}.

  (** Some functions to allow us to fake a record update syntax. *)
  Definition update_init_flag new abs :=
    {|
      init_flag := new;
      npool := npool abs;
      queue := queue abs;
      anpool := anpool abs;
      aqueue := aqueue abs
    |}.

  Definition update_npool new abs :=
    {|
      init_flag := init_flag abs;
      npool := new;
      queue := queue abs;
      anpool := anpool abs;
      aqueue := aqueue abs
    |}.

  Definition update_queue new abs :=
    {|
      init_flag := init_flag abs;
      npool := npool abs;
      queue := new;
      anpool := anpool abs;
      aqueue := aqueue abs
    |}.

  Definition update_anpool new abs :=
    {|
      init_flag := init_flag abs;
      npool := npool abs;
      queue := queue abs;
      anpool := new;
      aqueue := aqueue abs
    |}.

  Definition update_aqueue new abs :=
    {|
      init_flag := init_flag abs;
      npool := npool abs;
      queue := queue abs;
      anpool := anpool abs;
      aqueue := new
    |}.

End ABS_DATA.

(** Shorthand for updating one field of a record. *)
Notation "abs {init_flag : new }" := (update_init_flag new abs) (at level 1).
Notation "abs {npool : new }" := (update_npool new abs) (at level 1).
Notation "abs {queue : new }" := (update_queue new abs) (at level 1).
Notation "abs {anpool : new }" := (update_anpool new abs) (at level 1).
Notation "abs {aqueue : new }" := (update_aqueue new abs) (at level 1).

(** ** Node Properties *)
Section NODE_DATA_PROPS.

  Context `{Hmem: BaseMemoryModel}.

  (** Just like in the container example, we write some general lemmas to
    allow us to rewrite the [Ptrofs] expressions into something simpler. *)
  Lemma node_fields_off_rewrite : forall foff i,
    0 <= Int.unsigned i < MAX_NODES ->
    0 <= foff < node_sz ->
    (Ptrofs.unsigned
      (Ptrofs.add
        (Ptrofs.add Ptrofs.zero
          (Ptrofs.mul (Ptrofs.repr node_sz) (Ptrofs.of_intu i)))
        (Ptrofs.repr foff))) = node_sz * Int.unsigned i + foff.
  Proof.
    intros ? ? Hi_range Hoff_range.
    pose proof MAX_NODES_range as Hmn_range.
    pose proof int_ptrofs_max as Hint_ptr.
    rewrite Ptrofs.add_zero_l.
    unfold Ptrofs.add, Ptrofs.mul, Ptrofs.zero, Ptrofs.of_intu, Ptrofs.of_int.
    unfold_node_fields.
    repeat rewrite Ptrofs.unsigned_repr; omega.
  Qed.

  Corollary node_fields_store_ok : forall foff m m' b i v,
    0 <= Int.unsigned i < MAX_NODES ->
    0 <= foff < node_sz ->
    Mem.store Mint32 m b (node_sz * Int.unsigned i + foff) v = Some m' ->
    Mem.store Mint32 m b
      (Ptrofs.unsigned
        (Ptrofs.add
          (Ptrofs.add Ptrofs.zero
            (Ptrofs.mul (Ptrofs.repr node_sz) (Ptrofs.of_intu i)))
          (Ptrofs.repr foff))) v = Some m'.
  Proof. intros; rewrite node_fields_off_rewrite; auto. Qed.

  Corollary node_fields_load_ok : forall foff m b i v,
    0 <= Int.unsigned i < MAX_NODES ->
    0 <= foff < node_sz ->
    Mem.load Mint32 m b (node_sz * Int.unsigned i + foff) = Some v ->
    Mem.load Mint32 m b
      (Ptrofs.unsigned
        (Ptrofs.add
          (Ptrofs.add Ptrofs.zero
            (Ptrofs.mul (Ptrofs.repr node_sz) (Ptrofs.of_intu i)))
          (Ptrofs.repr foff))) = Some v.
  Proof. intros; rewrite node_fields_off_rewrite; auto. Qed.

  Lemma node_fields_align : forall i off,
    (off = data_off \/ off = next_off \/ off = prev_off) ->
    (4 | node_sz * i + off).
  Proof.
    intros; unfold_node_fields.
    replace (12 * i) with (4 * (3 * i)) by omega.
    apply Z.divide_add_r; [apply Z.divide_factor_l |].
    destruct H as [? | [? | ? ]]; subst.
    - now exists 0.
    - now exists 1.
    - now exists 2.
  Qed.

End NODE_DATA_PROPS.

(** Queue Properties *)
Section QUEUE_DATA_PROPS.

  Context `{Hmem: BaseMemoryModel}.

  Lemma queue_fields_off_rewrite : forall foff,
    0 <= foff < queue_sz ->
    (Ptrofs.unsigned (Ptrofs.add Ptrofs.zero (Ptrofs.repr foff))) = foff.
  Proof.
    intros ? Hoff_range.
    pose proof int_ptrofs_max as Hint_ptr.
    rewrite Ptrofs.add_zero_l.
    unfold_queue_fields.
    rewrite Ptrofs.unsigned_repr; cbn in *; omega.
  Qed.

  Corollary queue_fields_store_ok : forall foff m m' b v,
    0 <= foff < queue_sz ->
    Mem.store Mint32 m b foff v = Some m' ->
    Mem.store Mint32 m b
      (Ptrofs.unsigned (Ptrofs.add Ptrofs.zero (Ptrofs.repr foff))) v = Some m'.
  Proof. intros; rewrite queue_fields_off_rewrite; auto. Qed.

  Corollary queue_fields_load_ok : forall foff m b v,
    0 <= foff < queue_sz ->
    Mem.load Mint32 m b foff = Some v ->
    Mem.load Mint32 m b
      (Ptrofs.unsigned (Ptrofs.add Ptrofs.zero (Ptrofs.repr foff))) = Some v.
  Proof. intros; rewrite queue_fields_off_rewrite; auto. Qed.

  Lemma queue_fields_align : forall off,
    (off = head_off \/ off = tail_off) ->
    (4 | off).
  Proof.
    intros; unfold_queue_fields; destruct H.
    - now exists 0.
    - now exists 1.
  Qed.

  (** Some additional lemmas about the uniqueness property. *)
  Lemma unique_unique : forall nd q,
    abs_queue_unique (AbsQueue (nd :: q)) ->
    abs_queue_unique (AbsQueue q).
  Proof.
    intros ? ? Hunique.
    inv Hunique; constructor.
    rewrite Forall_forall in *.
    intros ? Hin.
    assert (Hin': In x (nd :: q)) by (cbn; auto).
    apply H0 in Hin'. cbn in Hin'.
    destruct (zeq nd x); subst; auto.
    inv Hin'.
    rewrite <- count_occ_not_In in H1.
    contradiction.
  Qed.

  Lemma unique_not_in : forall nd q,
    abs_queue_unique (AbsQueue (nd :: q)) ->
    ~In nd q.
  Proof.
    red; intros ? ? Hunique Hin.
    pose proof Hunique as Hunique'. apply unique_unique in Hunique'.
    inv Hunique; inv Hunique'. rewrite Forall_forall in *.
    assert (Hin': In nd (nd :: q)) by (cbn; auto).
    apply H1 in Hin; apply H0 in Hin'.
    cbn in Hin'. rewrite zeq_true in Hin'.
    congruence.
  Qed.

  Lemma unique_not_in_unique : forall nd q,
    abs_queue_unique (AbsQueue q) ->
    ~In nd q ->
    abs_queue_unique (AbsQueue (nd :: q)).
  Proof.
    intros ? ? Hunique Hnin.
    inv Hunique; constructor.
    rewrite Forall_forall in *.
    intros ? Hin; cbn.
    destruct (zeq nd x); subst.
    - rewrite count_occ_not_In in Hnin; eauto.
    - destruct Hin; [contradiction | auto].
  Qed.

  (** A property about nodes not in the queue. *)
  Lemma NIn_Q_inQ : forall q nd anpool dat,
    In_Q_inQ (AbsQueue q) nd anpool ->
    ZMap.get nd anpool = AbsNode dat false ->
    ~In nd q.
  Proof.
    red; intros ? ? ? ? Hinq Hnode Hin.
    inv Hinq. rewrite Hnode in H0; inv H0.
    destruct H1. apply H0 in Hin. discriminate.
  Qed.

End QUEUE_DATA_PROPS.

(** ** Composite Environments *)

(** The [Node] and [QueueIntro] layers also have to have the same
  [composite_env] so these definitions have to be somewhere that both files can
  import from. *)

Definition node_t : ident := 7%positive.
Definition node_t_data : ident := 8%positive.
Definition node_t_next : ident := 9%positive.
Definition node_t_prev : ident := 10%positive.
Notation node_t_struct := (Tstruct node_t noattr).

Definition node_t_comp : composite_definition :=
  Composite node_t Struct
    ((node_t_data, tuint) ::
     (node_t_next, tuint) ::
     (node_t_prev, tuint) ::
     nil)
    noattr.

Definition queue_t : ident := 25%positive.
Definition queue_t_head : ident := 26%positive.
Definition queue_t_tail : ident := 27%positive.
Notation queue_t_struct := (Tstruct queue_t noattr).

Definition queue_t_comp : composite_definition :=
  Composite queue_t Struct
    ((queue_t_head, tuint) ::
     (queue_t_tail, tuint) ::
     nil)
    noattr.

(** ** Intro Layer Relations *)
Section ABS_REL.

  Context `{Hmem: BaseMemoryModel}.

  (** We must combine the [Node] and [QueueIntro] layers together so we can
    build the [Queue] layer on top. In particular, this means defining a
    new abstraction relation where the components are combinations of the
    corresponding components in the [Node] and [QueueIntro] relations. *)

  (** *** Node *)

  Definition NODE_POOL : ident := 6%positive.

  Inductive match_node : node_low -> val -> val -> val -> Prop :=
  | match_node_undef: forall dv nv pv,
      match_node NodeUndef dv nv pv
  | match_node_intro: forall d n p,
      match_node (Node d n p) (Vint (Int.repr d)) (Vint (Int.repr n)) (Vint (Int.repr p)).

  Inductive node_match_data : intro_layerdata -> mem -> Prop :=
  | node_match_data_intro:
      forall m (abs: intro_layerdata) npb
             (Hnpb: find_symbol NODE_POOL = Some npb),
        (forall node, 0 <= node < MAX_NODES ->
          (exists dat nxt prv,
            Mem.load Mint32 m npb (node_sz * node + data_off) = Some (Vint dat) /\
            Mem.load Mint32 m npb (node_sz * node + next_off) = Some (Vint nxt) /\
            Mem.load Mint32 m npb (node_sz * node + prev_off) = Some (Vint prv) /\
            Mem.valid_access m Mint32 npb (node_sz * node + data_off) Writable /\
            Mem.valid_access m Mint32 npb (node_sz * node + next_off) Writable /\
            Mem.valid_access m Mint32 npb (node_sz * node + prev_off) Writable /\
            match_node (ZMap.get node (npool abs))
                       (Vint dat) (Vint nxt) (Vint prv))) ->
        node_match_data abs m.

  Definition node_relate_data (hadt: intro_layerdata) (ladt: boot_layerdata) := True.

  (** *** QueueIntro *)

  Definition QUEUE : ident := 24%positive.

  Inductive match_queue : queue_low -> val -> val -> Prop :=
  | match_queue_undef: forall hv tv,
      match_queue QueueUndef hv tv
  | match_queue_intro: forall h t,
      match_queue (Queue h t) (Vint (Int.repr h)) (Vint (Int.repr t)).

  Inductive queue_intro_match_data : intro_layerdata -> mem -> Prop :=
  | queue_intro_match_data_intro:
      forall m (abs: intro_layerdata) qb
             (Hqb: find_symbol QUEUE = Some qb),
        (exists hd tl,
          Mem.load Mint32 m qb head_off = Some (Vint hd) /\
          Mem.load Mint32 m qb tail_off = Some (Vint tl) /\
          Mem.valid_access m Mint32 qb head_off Writable /\
          Mem.valid_access m Mint32 qb tail_off Writable /\
          match_queue (queue abs)
                      (Vint hd) (Vint tl)) ->
        queue_intro_match_data abs m.

  Definition queue_intro_relate_data (hadt: intro_layerdata) (ladt: boot_layerdata) := True.

  (** Define [match] and [relate] relations by and-ing together the
    corresponding [Node] and [QueueIntro] definitions. *)
  Definition abrel_components_intro_boot :
    abrel_components intro_layerdata boot_layerdata :=
    {|
      abrel_relate :=
        fun D1 D2 =>
          node_relate_data D1 D2 /\ queue_intro_relate_data D1 D2;
      abrel_match  :=
        fun D1 D2 =>
          node_match_data D1 D2 /\ queue_intro_match_data D1 D2;
      abrel_new_glbl :=
        (NODE_POOL, Init_space (MAX_NODES * node_sz) :: nil) ::
        (QUEUE, Init_space queue_sz :: nil) ::
        nil
    |}.

  Global Instance intro_rel_ops :
    AbstractionRelation _ _ abrel_components_intro_boot.
  Proof.
    constructor.
    - split; constructor.
    - intros. split.
      + (** Node match_data *)
        inv_abrel_init_props.
        econstructor; eauto; intros.
        pose MAX_NODES_range as Hmn_range.
        cbn -[Z.mul] in *; unfold_node_fields.
        rewrite Zmax_left in aip_perm by omega.
        destruct aip_load as [aip_load _].
        pose node_fields_align as Halign.
        do 3 eexists.
        repeat match goal with
        | |- _ /\ _ => split
        | |- Mem.load _ _ _ _ = Some _ =>
          apply aip_load; [omega | try omega | auto]
        | |- (4 | 12 * ?x + 0) => exists (3*x); omega
        | |- (4 | ?x * 12) => exists (3*x); omega
        | |- (4 | 12 * ?x + 4) => exists (3*x + 1); omega
        | |- (4 | 12 * ?x + 8) => exists (3*x + 2); omega
        | |- Mem.valid_access _ _ _ (12 * node + ?off) _ =>
            split; cbn -[Z.mul];
            [red; intros; apply aip_perm; omega | auto]
        end.
        rewrite ZMap.gi.
        constructor.
      + (** QueueIntro match_data *)
        inv_abrel_init_props.
        econstructor; eauto; intros.
        (** pose MAX_NODES_range as Hmn_range. *)
        cbn in *; unfold_queue_fields.
        destruct aip_load as [aip_load _].
        pose queue_fields_align as Halign.
        do 2 eexists.
        repeat match goal with
        | |- _ /\ _ => split
        | |- Mem.load _ _ _ _ = Some _ =>
          apply aip_load0; [omega | try omega | auto]
        | |- (4 | 0) => exists 0; omega
        | |- (4 | 4) => exists 1; omega
        | |- (4 | 8) => exists 2; omega
        | |- Mem.valid_access _ _ _ ?off _ =>
            split; cbn;
            [red; intros; apply aip_perm0; omega | auto]
        end.
        constructor.
    - repeat red; cbn. intros d m1 m2 Hunchange [Hnode_match Hqueue_match].
      split.
      + (** Node relate_data *)
        inv Hnode_match; econstructor; eauto.
        intros ? Hnode; specialize (H _ Hnode).
        destruct H as (dat & nxt & prv & ?).
        repeat match goal with
        | H: _ /\ _ |- _ => destruct H
        | H: Mem.valid_access _ _ _ _ _ |- _ => destruct H; red in H
        end.
        do 3 eexists.
        repeat match goal with
        | |- _ /\ _ => split
        | |- Mem.load _ _ _ _ = Some _ =>
            eapply Mem.load_unchanged_on; eauto; red; cbn; eauto
        | |- Mem.valid_access _ _ _ _ _ =>
            split;
            [red; intros; eapply Mem.perm_unchanged_on; eauto; red; cbn |];
            eauto
        end.
        assumption.
      + (** QueueIntro relate_data *)
        inv Hqueue_match; econstructor; eauto.
        destruct H as (hd & tl & ?).
        repeat match goal with
        | H: _ /\ _ |- _ => destruct H
        | H: Mem.valid_access _ _ _ _ _ |- _ => destruct H; red in H
        end.
        do 2 eexists.
        repeat match goal with
        | |- _ /\ _ => split
        | |- Mem.load _ _ _ _ = Some _ =>
            eapply Mem.load_unchanged_on; eauto; red; cbn; eauto
        | |- Mem.valid_access _ _ _ _ _ =>
            split;
            [red; intros; eapply Mem.perm_unchanged_on; eauto; red; cbn |];
            eauto
        end; intros; repeat eexists; eauto.
    - repeat constructor.
  Qed.

  Definition abrel_intro_boot : abrel intro_layerdata boot_layerdata :=
    {|
      abrel_ops := abrel_components_intro_boot;
      abrel_prf := intro_rel_ops
    |}.

  Definition intro_R : simrel _ _ :=
    abrel_simrel _ _ abrel_intro_boot.

End ABS_REL.

(** ** Helper Lemmas *)
Section AUX_LEMMAS.

  (** Some additional properties of Coq [list] functions and how they
    interact with the queue properties. *)

  Lemma remove_nin : forall x xs,
    ~In x xs -> remove zeq x xs = xs.
  Proof.
    induction xs; auto; cbn; intros.
    destruct (zeq x a); [subst |]; try tauto.
    f_equal. auto.
  Qed.

  Lemma remove_neq : forall x y xs,
    x <> y -> In x (remove zeq y xs) <-> In x xs.
  Proof.
    induction xs; cbn; intros; try tauto.
    destruct (zeq y a); [subst |]; cbn; try tauto.
    split; intros; try tauto.
    destruct H0; [congruence | tauto].
  Qed.

  Lemma count_occ_remove_neq : forall x y xs,
    x <> y -> count_occ zeq (remove zeq y xs) x = count_occ zeq xs x.
  Proof.
    induction xs; cbn; intros; try tauto.
    destruct (zeq y a); [subst |]; cbn.
    - rewrite zeq_false; auto.
    - destruct (zeq a x); [subst |]; cbn; try tauto.
      f_equal. tauto.
  Qed.

  Lemma count_occ_app : forall xs ys z,
    count_occ zeq (xs ++ ys) z = (count_occ zeq xs z + count_occ zeq ys z)%nat.
  Proof.
    induction xs.
    - simpl; intros; auto.
    - simpl; intros.
      destruct (zeq a z); simpl; f_equal; apply IHxs.
  Qed.

  Lemma last_In : forall x (q: list Z),
    (q = nil \/ In (last q x) q).
  Proof.
    induction q; auto.
    simpl.
    destruct q; auto.
    destruct IHq; [congruence | auto].
  Qed.

  Lemma remove_last : forall z q,
    ~ In z q ->
    List.remove zeq z (q ++ z :: nil) = q.
  Proof.
    induction q.
    - simpl. rewrite zeq_true. auto.
    - simpl in *.
      intros HNin.
      rewrite zeq_false by (contradict HNin; left; congruence).
      rewrite IHq by tauto.
      reflexivity.
  Qed.

  Lemma last_nonempty_dummy : forall {A} y z xs (x: A),
    last (x :: xs) y = last (x :: xs) z.
  Proof.
    induction xs; simpl in *; try rewrite IHxs; reflexivity.
  Qed.

  Lemma app_last : forall {A} (xs ys : list A) z,
    ys <> nil -> last (xs ++ ys) z = last ys z.
  Proof.
    induction xs.
    - simpl; auto.
    - intros.
      specialize (IHxs ys z H).
      simpl.
      destruct (xs ++ ys) eqn:?; auto; destruct xs; simpl in *; congruence.
  Qed.

  Lemma tail_last : forall dummy (q: list Z),
    q = nil \/  exists q', q = q' ++ (last q dummy :: nil).
  Proof.
    induction q.
    - left; congruence.
    - destruct q.
      + right. exists nil. reflexivity.
      + destruct IHq as [? |[ q' IH]]; [congruence|].
        right. exists (a :: q').
        simpl in *.
        congruence.
  Qed.

   Lemma last_nin_default : forall {A} xs (x y: A),
     ~In x xs -> last xs y = x -> xs = nil.
   Proof.
     intros.
     induction xs.
     - reflexivity.
     - cbn in H0.
       destruct xs.
       + rewrite <- H0 in H.
         contradict H.
         constructor.
         reflexivity.
       + discriminate IHxs.
         * rewrite not_in_cons in H.
           destruct H.
           exact H1.
         * exact H0.
  Qed.

  Lemma Forall_app_inv2 : forall (A: Type) (P: A -> Prop) (xs ys: list A),
    Forall P (xs ++ ys) -> Forall P ys.
  Proof.
    induction xs.
    - simpl; auto.
    - inversion 1. eauto.
  Qed.

  Lemma unique_not_In : forall xs y ys,
    abs_queue_unique (AbsQueue (xs ++ y :: ys)) ->
    ~ In y xs /\ ~In y ys.
  Proof.
    inversion 1 as [q Hcount Hq]. subst.
    repeat rewrite (count_occ_not_In zeq).
    apply Forall_app_inv2 in Hcount.
    inversion Hcount as [| ? ? Hcount' _]. subst.
    rewrite count_occ_app in Hcount'.
    destruct (count_occ zeq xs y); simpl in *;
      rewrite zeq_true in Hcount'; auto; omega.
  Qed.

End AUX_LEMMAS.


(** * Facts about the Sitpn Semantics  *)

Require Import common.CoqLib.
Require Import common.ListLib.
Require Import common.GlobalFacts.
Require Import sitpn.Sitpn.
Require Import sitpn.SitpnSemanticsDefs.
Require Import sitpn.SitpnFacts.

Lemma PInputsOf_ex : forall sitpn (t : T sitpn), exists pinputs_of_t, PInputsOf t pinputs_of_t.
  intros sitpn t; unfold PInputsOf.
Admitted.

Lemma TOutputsOf_ex : forall sitpn (p : P sitpn), exists toutputs_of_p, TOutputsOf p toutputs_of_p.
Admitted.

Lemma NoDup_tfilter :
  forall {A B : Type} (l : list A) (f : { a : A | List.In a l } -> bool)
         (InA2sigInA : forall a : A, List.In a l -> { a : A | List.In a l }),
    List.NoDup l -> SetoidList.NoDupA P1SigEq (tfilter f l InA2sigInA).
Admitted.

Lemma pinputs_correct :
  forall sitpn (t : T sitpn) inputs_of_t,
    pinputs t = inputs_of_t -> PInputsOf t inputs_of_t.
Proof.
  intros * EQ.
  unfold PInputsOf. unfold Set_in_ListA.
  split.
  2: { rewrite <- EQ; eapply NoDup_tfilter; exact (nodup_pls sitpn). }
Admitted.


From Hammer Require Import Hammer.

From WeakUpTo Require Export Theory.
Set Implicit Arguments.

Section RelaxedExpansion.

Variables A X Y: Type.
Variable TX: reduction_t A X.
Variable TY: reduction_t A Y.

Variable B: relation X.
Hypothesis HB: wexpansion1 TX TX B.

Let wexpansion1_ctrl_t:
forall R, evolve_t TX TY R (comp (star B) R) -> simulation_t TX TY (comp (star B) R).
Proof. hammer_hook "Controlled" "Controlled.RelaxedExpansion.wexpansion1_ctrl_t".
intros R HR x x' y Hxx' xRy; destruct xRy as [ w xRw wRy ].
cgen Hxx'; cgen x'; induction xRw as [ x | z x w xRz zRw IH ]; intros x' Hxx'.
apply (HR _ _ _ Hxx' wRy).
destruct (HB Hxx' xRz) as [ z' Hzz' x'Rz' ].
celim Hzz'; intro Hzz'.
destruct Hzz'; exists y; auto; exists w; auto; apply star_trans with z; auto.
destruct (IH wRy _ Hzz') as [ y' Hyy' z'Ry' ] ; destruct z'Ry' as [ w' ].
exists y'; auto; exists w'; auto; apply S_star with z'; auto.
Qed.

Theorem wexpansion1_ctrl: wexpansion1 TX TX B -> controlled TX TY B.
Proof. hammer_hook "Controlled" "Controlled.wexpansion1_ctrl".
split; auto.
intros R S HR HS HRS HRS' a x x' y Hxx' xRy; destruct xRy as [ w xRw wRy ].
cgen Hxx'; cgen x'; induction xRw as [ x | z x w xRz zRw IH ]; intros x' Hxx'.
destruct (HRS _ _ _ _ Hxx' wRy) as [ y' Hyy' w'Ry' ]; exists y'; auto; exists x'; auto.
destruct (HB Hxx' xRz) as [ z' Hzz' x'Rz' ].
destruct Hzz' as [ z1 Hzz1 Hz1z' ].
destruct (IH wRy _ Hzz1) as [ y1 Hyy1 z1Ry1 ].
cut (simulation_t TX TY (comp (star B) S)).
intro HS'; destruct (weak_strong_t HS' _ Hz1z' z1Ry1) as [ y' Hy1y' z'Ry' ]; exists y'.
apply weak_taus with y1; auto.
destruct z'Ry' as [ w' ]; exists w'; auto; apply S_star with z'; auto.
apply wexpansion1_ctrl_t; auto.
unfold evolve_t; eapply evolve_incl; try apply HS; intros u v K; exists u; auto.
Qed.

End RelaxedExpansion.

Section PlusWf.

Variable A: Type.
Variable X: Set.
Variable Y: Type.
Variable TX: reduction_t A X.
Variable TY: reduction_t A Y.

Variable B: relation X.
Hypothesis HB: evolve TX TX B (plus B).
Hypothesis HB': well_founded (trans B).

Theorem plus_wf_controlled: controlled TX TY B.
Proof. hammer_hook "Controlled" "Controlled.plus_wf_controlled".
split.
intros R HR x x' y Hxx' xRy; destruct xRy as [ w xRw wRy ]; destar xRw z.
apply (HR _ _ _ Hxx' wRy).
elim (diagram_plus_wf_2 (HB (l:=T _)) HB') with (eq (A:=X)) Y R R (TY (T A)) (eq (A:=Y)) x x' y; auto.
intros y' Hyy' x'Ry'; exists y'; auto; destruct Hyy' as [ y1 Hyy1 Hy1y' ]; destruct Hy1y'; auto.
intros u u' v Huu' uRv; destruct Huu'; exists v; auto; exists v; auto.
intros u u' v Huu' uRv; destruct Huu'; exists v; auto; (exists v || exists u); auto.
exists x'; auto.
exists w; auto.

intros R S HR HS HRS HRS' a x x' y Hxx' xRy.
elim (diagram_plus_wf_2 (HB (l:=T _)) HB') with
(comp (TX (L a)) (star (TX (T _)))) Y R S (TY (T _))
(comp (TY (L a)) (star (TY (T _)))) x x' y; auto.
intros y' Hyy' x'Ry'; exists y'; auto.
clear Hxx' xRy x x' y; intros x x' y Hxx' xRy; destruct Hxx' as [ x1 Hxx1 Hx1x' ].
destruct (HB Hxx1 xRy) as [ y1 Hyy1 x1Ry1 ].
destruct (diagram_plus_wf (HB (l:=T _)) HB' Hx1x' x1Ry1) as [ y' Hy1y' x'Ry' ].
exists y'; auto; fold (Weak TX (L a)); apply weak_taus with y1; auto.
clear Hxx' xRy x x' y; intros x x' y Hxx' xRy; destruct Hxx' as [ x1 Hxx1 Hx1x' ].
destruct (HRS _ _ _ _ Hxx1 xRy) as [ y1 Hyy1 x1Ry1 ].
destruct (weak_strong_t HS _ Hx1x' x1Ry1) as [ y' Hy1y' x'Ry' ]; exists y'.
fold (Weak TY (L a)); apply weak_taus with y1; auto.
exists x'; auto.
exists x; auto; exists x'; auto.
Qed.

End PlusWf.

Section StarWf.

Variable A: Type.
Variable X: Set.
Variable Y: Type.
Variable TX: reduction_t A X.
Variable TY: reduction_t A Y.

Variable B: relation X.
Hypothesis HB: evolve TX TX B (star B).
Hypothesis HB': well_founded (trans (comp (plus B) (plus (TX (T _))))).

Theorem star_wf_controlled: controlled TX TY B.
Proof. hammer_hook "Controlled" "Controlled.star_wf_controlled".
split.
intros R HR; unfold simulation_t, evolve_t, evolve_1, Weak.
apply diagram_reverse; apply diagram_incl with (star (TX (T _))) (star (TY (T _))); auto; apply diagram_reverse.
apply diagram_star_wf_1; auto; exact (HB (l:=T _)).

intros R S HR HS HRS HRS' a; unfold evolve_1.
apply diagram_reverse; apply diagram_incl with (Weak TX (L a)) (Weak TY (L a)); auto; apply diagram_reverse.
unfold Weak; apply diagram_star_wf_2; auto; try exact (HB (l:=T _));
intros x x' y Hxx' xRy; destruct Hxx' as [ x1 Hxx1 Hx1x' ].
destruct (HB Hxx1 xRy) as [ y1 Hyy1 x1Ry1 ].
destruct (diagram_star_wf (HB (l:=T _)) HB' Hx1x' x1Ry1) as [ y' Hy1y' x'Ry' ].
exists y'; auto; fold (Weak TX (L a)); apply weak_taus with y1; auto.
destruct (HRS _ _ _ _ Hxx1 xRy) as [ y1 Hyy1 x1Ry1 ].
destruct (weak_strong_t HS _ Hx1x' x1Ry1) as [ y' Hy1y' x'Ry' ]; exists y'.
fold (Weak TY (L a)); apply weak_taus with y1; auto.
exists x'; auto.
Qed.

End StarWf.


(**
/A module for “displayed categories”, based over UniMath’s [CategoryTheory] library.

Roughly, a “displayed category _D_ over a category _C_” is analogous to “a family of types _Y_ indexed over a type _X_”.  A displayed category has a “total category” ∑ _C_ _D_, with a functor to _D_; and indeed displayed categories should be equivalent to categories over _D_, by taking fibers.

In a little more detail: if [D] is a displayed category over [C], then [D] has a type of objects indexed over [ob C], and for each [x y : C, f : x --> y, xx : D x, yy : D y], a type of “morphisms over [f] from [xx] to [yy]”.  The identity and composition (and axioms) for [D] all overlie the corresponding structure on [C].

Two major motivations for displayed categories:

- Pragmatically, they give a convenient tool for building categories of “structured objects”, and functors into such categories, encapsulating a lot of frequently-used constructions, and allowing for very modular proofs of e.g. saturation of such categories.
- More conceptually, they give a setting for defining Grothendieck fibrations and isofibrations without mentioning equality of objects.

Contents:

- Displayed categories: [disp_cat C]
  - various access functions, etc.
  - utility lemmas
  - isomorphisms
  - saturation
- Total categories (and their forgetful functors)
  - [total_category D]
  - [pr1_category D]
- Functors between displayed categories, over functors between their bases
  - [functor_lifting], [lifted_functor]
  - [disp_functor], [total_functor]
  - properties of functors: [disp_functor_ff], …
  - natural transformations: [disp_nat_trans], …
*)

(* TODO: this file has become large and unwieldy; should probably be split up.  Displayed functors can certainly be happily split off.  Should total cats stay here, or also be split out? *)

Require Import UniMath.Foundations.Sets.
Require Import UniMath.Foundations.PartD.
Require Import UniMath.MoreFoundations.PartA.
Require Import UniMath.MoreFoundations.AxiomOfChoice.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.Core.Univalence.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.whiskering.
Local Open Scope cat.
Local Open Scope type_scope.

(* Undelimit Scope transport. *)

(** * Displayed categories *)

(*
  Here is an iterated ∑-type that displays a logical structure equivalent to the
  type called disp_cat defined below.
*)

Definition disp_cat' (C : category) : UU :=
  ∑ (ob_disp : C -> UU)
    (mor_disp : ∏ {x y : C}, (x --> y) -> ob_disp x -> ob_disp y -> UU)
    (id_disp : ∏ {x : C} (xx : ob_disp x), mor_disp (identity x) xx xx)
    (comp_disp : ∏ {x y z : C} {f : x --> y} {g : y --> z}
                   {xx : ob_disp x} {yy : ob_disp y} {zz : ob_disp z},
                 mor_disp f xx yy -> mor_disp g yy zz -> mor_disp (f · g) xx zz)
    (id_left_disp : ∏ {x y} {f : x --> y} {xx} {yy} (ff : mor_disp f xx yy),
                    comp_disp (id_disp xx) ff
                    = transportb (λ g, mor_disp g xx yy) (id_left _) ff)
    (id_right_disp : ∏ {x y} {f : x --> y} {xx} {yy} (ff : mor_disp f xx yy),
                     comp_disp ff (id_disp yy)
                     = transportb (λ g, mor_disp g xx yy) (id_right _) ff)
    (assoc_disp : ∏ {x y z w} {f : x --> y} {g : y --> z} {h : z --> w}
                    {xx} {yy} {zz} {ww}
                    (ff : mor_disp f xx yy) (gg : mor_disp g yy zz) (hh : mor_disp h zz ww),
                  comp_disp ff (comp_disp gg hh)
                  = transportb (λ k, mor_disp k _ _) (assoc _ _ _)
                               (comp_disp (comp_disp ff gg) hh)),
  (* homsets_disp : *) ∏ x y (f : x --> y) xx yy, isaset (mor_disp f xx yy).

(** ** Definition *)

(** The actual definition is structured analogously to [category], as an iterated ∑-type:

- [disp_cat]
  - [disp_cat_data]
    - [disp_cat_ob_mor]
      - [ob_disp]
      - [mod_disp]
    - [disp_cat_id_comp]
      - [id_disp]
      - [comp_disp]
  - [disp_cat_axioms]
    - [id_left_disp]
    - [id_right_disp]
    - [assoc_disp]
    - [homsets_disp]

*)

Section Disp_Cat.

Definition disp_cat_ob_mor (C : precategory_ob_mor)
  := ∑ (obd : C -> UU), (∏ x y:C, obd x -> obd y -> (x --> y) -> UU).

Definition make_disp_cat_ob_mor
           (C : precategory_ob_mor)
           (obd : C -> UU)
           (mord : ∏ x y:C, obd x -> obd y -> (x --> y) -> UU)
  : disp_cat_ob_mor C
  := obd,, mord.

Definition ob_disp {C: precategory_ob_mor} (D : disp_cat_ob_mor C) : C -> UU := pr1 D.
Coercion ob_disp : disp_cat_ob_mor >-> Funclass.

Definition mor_disp {C: precategory_ob_mor} {D : disp_cat_ob_mor C}
  {x y} xx yy (f : x --> y)
:= pr2 D x y xx yy f : UU.

Local Notation "xx -->[ f ] yy" := (mor_disp xx yy f) (at level 50, left associativity, yy at next level).

Definition disp_cat_id_comp (C : precategory_data)
  (D : disp_cat_ob_mor C)
  : UU
:= (forall (x:C) (xx : D x), xx -->[identity x] xx)
  × (forall (x y z : C) (f : x --> y) (g : y --> z) (xx:D x) (yy:D y) (zz:D z),
           (xx -->[f] yy) -> (yy -->[g] zz) -> (xx -->[f · g] zz)).

Definition disp_cat_data C := total2 (disp_cat_id_comp C).

Definition disp_cat_ob_mor_from_disp_cat_data {C: precategory_data}
  (D : disp_cat_data C)
  : disp_cat_ob_mor C
:= pr1 D.

Coercion disp_cat_ob_mor_from_disp_cat_data :
 disp_cat_data >-> disp_cat_ob_mor.

Definition id_disp {C: precategory_data} {D : disp_cat_data C} {x:C} (xx : D x)
  : xx -->[identity x] xx
:= pr1 (pr2 D) x xx.

Definition comp_disp {C: precategory_data} {D : disp_cat_data C}
  {x y z : C} {f : x --> y} {g : y --> z}
  {xx : D x} {yy} {zz} (ff : xx -->[f] yy) (gg : yy -->[g] zz)
  : xx -->[f · g] zz
:= pr2 (pr2 D) _ _ _ _ _ _ _ _ ff gg.

Declare Scope mor_disp_scope.
Local Notation "ff ;; gg" := (comp_disp ff gg)
  (at level 50, left associativity, format "ff  ;;  gg")
  : mor_disp_scope.
Delimit Scope mor_disp_scope with mor_disp.
Bind Scope mor_disp_scope with mor_disp.
Local Open Scope mor_disp_scope.

Definition disp_cat_axioms (C : category) (D : disp_cat_data C)
  : UU
:= (∏ x y (f : x --> y) (xx : D x) yy (ff : xx -->[f] yy),
     id_disp _ ;; ff
     = transportb _ (id_left _) ff)
   × (∏ x y (f : x --> y) (xx : D x) yy (ff : xx -->[f] yy),
     ff ;; id_disp _
     = transportb _ (id_right _) ff)
   × (∏ x y z w f g h (xx : D x) (yy : D y) (zz : D z) (ww : D w)
        (ff : xx -->[f] yy) (gg : yy -->[g] zz) (hh : zz -->[h] ww),
     ff ;; (gg ;; hh)
     = transportb _ (assoc _ _ _) ((ff ;; gg) ;; hh))
   × (∏ x y f (xx : D x) (yy : D y), isaset (xx -->[f] yy)).

Definition disp_cat (C : category) := total2 (disp_cat_axioms C).

Definition disp_cat_data_from_disp_cat {C} (D : disp_cat C)
 := pr1 D : disp_cat_data C.
Coercion disp_cat_data_from_disp_cat : disp_cat >-> disp_cat_data.

(** All the axioms are given in two versions, [foo : T1 = transportb e T2] and [foo_var : T2 = transportf e T1], so that either direction can be invoked easily in “compute left-to-right” style. *)

(* TODO: consider naming conventions? *)
(* TODO: maybe would be better to have a single [pathsinv0_dep] lemma, or something. *)

Definition id_left_disp {C} {D : disp_cat C}
  {x y} {f : x --> y} {xx : D x} {yy} (ff : xx -->[f] yy)
: id_disp _ ;; ff = transportb _ (id_left _) ff
:= pr1 (pr2 D) _ _ _ _ _ _.

Definition id_left_disp_var {C} {D : disp_cat C}
  {x y} {f : x --> y} {xx : D x} {yy} (ff : xx -->[f] yy)
: ff = transportf _ (id_left _) (id_disp _ ;; ff).
Proof.
  apply transportf_transpose_right.
  apply @pathsinv0, id_left_disp.
Qed.

Definition id_right_disp {C} {D : disp_cat C}
  {x y} {f : x --> y} {xx : D x} {yy} (ff : xx -->[f] yy)
  : ff ;; id_disp _ = transportb _ (id_right _) ff
:= pr1 (pr2 (pr2 D)) _ _ _ _ _ _.

Definition id_right_disp_var {C} {D : disp_cat C}
  {x y} {f : x --> y} {xx : D x} {yy} (ff : xx -->[f] yy)
  : ff = transportf _ (id_right _) (ff ;; id_disp _).
Proof.
  apply transportf_transpose_right.
  apply @pathsinv0, id_right_disp.
Qed.

Definition assoc_disp {C} {D : disp_cat C}
  {x y z w} {f} {g} {h} {xx : D x} {yy : D y} {zz : D z} {ww : D w}
  (ff : xx -->[f] yy) (gg : yy -->[g] zz) (hh : zz -->[h] ww)
: ff ;; (gg ;; hh) = transportb _ (assoc _ _ _) ((ff ;; gg) ;; hh)
:= pr1 (pr2 (pr2 (pr2 D))) _ _ _ _ _ _ _ _ _ _ _ _ _ _.

Definition assoc_disp_var {C} {D : disp_cat C}
  {x y z w} {f} {g} {h} {xx : D x} {yy : D y} {zz : D z} {ww : D w}
  (ff : xx -->[f] yy) (gg : yy -->[g] zz) (hh : zz -->[h] ww)
: (ff ;; gg) ;; hh = transportf _ (assoc _ _ _) (ff ;; (gg ;; hh)).
Proof.
  apply pathsinv0, transportf_pathsinv0.
  apply pathsinv0, assoc_disp.
Defined.

Definition homsets_disp {C} {D : disp_cat C} {x y} (f : x --> y) (xx : D x) (yy : D y)
  : isaset (xx -->[f] yy) := pr2 (pr2 (pr2 (pr2 D))) _ _ _ _ _.

(** ** Utility lemmas *)
Section Lemmas.

(** [etrans_disp]: a version of [etrans_dep] for use when the equality transport in the RHS of the goal is already present, and not of the form produced by [etrans_dep], so [etrans_dep] doesn’t apply.  Where possible, [etrans_dep] should still be used, since it *produces* a RHS, whereas this does not (and so leads to lots of unsolved existentials if used where not needed).

NOTE: as with [etrans_dep], proofs using [etrans_disp] seem to typecheck more slowly than proofs using [etrans] plus other lemmas directly. *)
Lemma pathscomp0_disp {C} {D : disp_cat C}
  {x y} {f f' f'' : x --> y} (e : f' = f) (e' : f'' = f') (e'' : f'' = f)
  {xx : D x} {yy}
  (ff : xx -->[f] yy) (ff' : xx -->[f'] yy) (ff'' : xx -->[f''] yy)
: (ff = transportf _ e ff') -> (ff' = transportf _ e' ff'')
  -> ff = transportf _ e'' ff''.
Proof.
  intros ee ee'.
  etrans. eapply pathscomp0_dep. apply ee. apply ee'.
  apply maponpaths_2, homset_property.
Qed.

Tactic Notation "etrans_disp" := eapply @pathscomp0_disp.

Lemma isaprop_disp_cat_axioms (C : category) (D : disp_cat_data C)
  : isaprop (disp_cat_axioms C D).
Proof.
  apply isofhlevelsn.
  intro X.
  set (XR := ( _ ,, X) : disp_cat C).
  apply isofhleveltotal2.
  - repeat (apply impred; intro).
    apply (@homsets_disp _ XR).
  - intros x.
    repeat (apply isofhleveldirprod); repeat (apply impred; intro).
    + apply (@homsets_disp _ XR).
    + apply (@homsets_disp _ XR).
    + apply isapropiscontr.
Qed.

(* TODO: consider naming of following few transport lemmas *)
Lemma mor_disp_transportf_postwhisker
    {C : precategory} {D : disp_cat_data C}
    {x y z : C} {f f' : x --> y} (ef : f = f') {g : y --> z}
    {xx : D x} {yy} {zz} (ff : xx -->[f] yy) (gg : yy -->[g] zz)
  : (transportf _ ef ff) ;; gg
  = transportf _ (cancel_postcomposition _ _ g ef) (ff ;; gg).
Proof.
  destruct ef; apply idpath.
Qed.

Lemma mor_disp_transportf_prewhisker
    {C : precategory} {D : disp_cat_data C}
    {x y z : C} {f : x --> y} {g g' : y --> z} (eg : g = g')
    {xx : D x} {yy} {zz} (ff : xx -->[f] yy) (gg : yy -->[g] zz)
  : ff ;; (transportf _ eg gg)
  = transportf _ (maponpaths (compose f) eg) (ff ;; gg).
Proof.
  destruct eg; apply idpath.
Qed.

(* TODO: use the following lemmas in more of the displayed category proofs. Most instances of [mor_disp_transportf_Xwhisker] are places that can be simplified with these. *)
(* TODO: consider naming of [cancel_Xcomposition_disp].  Currently follows the UniMath base lemmas, but those are bad names — cancellation properties traditionally mean things like like [ ax = ay -> x = y ], whereas these lemmas are the converse of that. *)
Lemma cancel_postcomposition_disp {C} {D : disp_cat C}
  {x y z} {f f' : x --> y} {e : f' = f} {g : y --> z}
  {xx : D x} {yy} {zz}
  {ff : xx -->[f] yy} {ff' : xx -->[f'] yy} (gg : yy -->[g] zz)
  (ee : ff = transportf _ e ff')
: ff ;; gg = transportf _ (cancel_postcomposition _ _ g e) (ff' ;; gg).
Proof.
  etrans. apply maponpaths_2, ee.
  apply mor_disp_transportf_postwhisker.
Qed.

Lemma cancel_precomposition_disp {C} {D : disp_cat C}
  {x y z} {f : x --> y} {g g' : y --> z} {e : g' = g}
  {xx : D x} {yy} {zz}
  (ff : xx -->[f] yy) {gg : yy -->[g] zz} {gg' : yy -->[g'] zz}
  (ee : gg = transportf _ e gg')
: ff ;; gg = transportf _ (cancel_precomposition _ _ _ _ _ _ f e) (ff ;; gg').
Proof.
  etrans. apply maponpaths, ee.
  apply mor_disp_transportf_prewhisker.
Qed.

End Lemmas.

End Disp_Cat.

(** Redeclare sectional notations globally. *)
Notation "xx -->[ f ] yy" := (mor_disp xx yy f) (at level 50, left associativity, yy at next level).

Declare Scope mor_disp_scope.
Notation "ff ;; gg" := (comp_disp ff gg)
  (at level 50, left associativity, format "ff  ;;  gg")
  : mor_disp_scope.
Delimit Scope mor_disp_scope with mor_disp.
Bind Scope mor_disp_scope with mor_disp.
Local Open Scope mor_disp_scope.

(** A useful notation for hiding the huge irrelevant equalities that occur in algebra of displayed categories.  For individual proofs, use [Open Scope hide_transport_scope.] at the start, and then [Close Scope hide_transport_scope.] afterwards.  For whole files/sections, use [Local Open Scope hide_transport_scope.]

Level is chosen to bind *tighter* than categorical composition, for readability. *)
(* TODO: consider symbol(s) used. *)
Declare Scope hide_transport_scope.
Notation "#? x" := (transportf _ _ x) (at level 45) : hide_transport_scope.
Notation "#?' x" := (transportb _ _ x) (at level 45) : hide_transport_scope.

(** * Functors

- Reindexing of displayed cats along functors: [reindex_disp_cat]
- Functors into displayed cats, lifting functors into the base: [functor_lifting]
- Functors between displayed cats, over functors between the bases: [disp_functor]
- Natural transformations between these: [disp_nat_trans] *)

(** some TODOs for the displayed-cats library:

- add lemmas connecting with products of cats (as required for displayed bicats)
- add more applications of the displayed arrow category: slices; equalisers, inserters; hence groups etc.

 *)


Require Import Undecidability.Synthetic.Definitions Undecidability.Synthetic.Undecidability.
Require Import Undecidability.PCP.PCP_undec.
From Undecidability.FOL.Undecidability Require Import binZF_undec FOL.
From Undecidability.FOL.Sets Require Import binZF.
Require Import Undecidability.FOL.Syntax.Core.
Require Import Undecidability.FOL.Syntax.BinSig.
Require Import Undecidability.FOL.Semantics.Tarski.FullFacts.
Require Import Undecidability.FOL.Deduction.FullNDFacts.

Lemma binZF_binFOL_valid :
  entailment_binZF ⪯ binFOL_valid.
Proof.
  exists (impl binZF). intros phi. unfold binFOL_valid, valid, entailment_binZF.
  setoid_rewrite impl_sat. reflexivity.
Qed.

Lemma binFOL_valid_undec :
  undecidable binFOL_valid.
Proof.
  apply (undecidability_from_reducibility undecidable_entailment_binZF), binZF_binFOL_valid.
Qed.

Lemma binZF_binFOL_prv_intu :
  deduction_binZF ⪯ binFOL_prv_intu.
Proof.
  exists (impl binZF). intros phi. unfold binFOL_prv_intu, deduction_binZF.
  setoid_rewrite <- impl_prv. rewrite List.app_nil_r.
  split; intros H; apply (Weak H); unfold List.incl; apply List.in_rev.
Qed.

Lemma binFOL_prv_intu_undec :
  undecidable binFOL_prv_intu.
Proof.
  apply (undecidability_from_reducibility undecidable_deduction_binZF), binZF_binFOL_prv_intu.
Qed.


Require Import Lia.
Require Import Bool.
Require Import RelationClasses.

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

From PromisingLib Require Import Axioms.
From PromisingLib Require Import Basic.
From PromisingLib Require Import DataStructure.
From PromisingLib Require Import DenseOrder.
From PromisingLib Require Import Loc.
From PromisingLib Require Import Language.

From PromisingLib Require Import Event.
Require Import Time.
Require Import View.
Require Import Cell.
Require Import Memory.
Require Import TView.
Require Import Local.
Require Import Thread.

Require Import OrdStep.
Require Import Writes.

Set Implicit Arguments.

Module Normal.
  Section Normal.
    Variable L: Loc.t -> bool.

    Definition normal_view (view: View.t): Prop :=
      forall loc (LOC: L loc), (View.rlx view) loc = (View.pln view) loc.

    Variant normal_tview (tview:TView.t): Prop :=
    | normal_tview_intro
        (REL: forall loc, normal_view ((TView.rel tview) loc))
        (CUR: normal_view (TView.cur tview))
        (ACQ: normal_view (TView.acq tview))
    .

    Definition normal_memory (mem: Memory.t): Prop :=
      forall loc from to val released
        (GET: Memory.get loc to mem = Some (from, Message.concrete val (Some released))),
        normal_view released.

    Inductive normal_thread {lang: language} (e: Thread.t lang): Prop :=
    | normal_thread_intro
        (NORMAL_TVIEW: normal_tview (Local.tview (Thread.local e)))
        (NORMAL_MEMORY: normal_memory (Thread.memory e))
    .
    Hint Constructors normal_thread: core.

    Lemma join_normal_view
          view1 view2
          (NORMAL1: normal_view view1)
          (NORMAL2: normal_view view2):
      normal_view (View.join view1 view2).
    Proof.
      ii. unfold normal_view in *.
      destruct view1, view2. ss.
      unfold TimeMap.join.
      rewrite NORMAL1, NORMAL2; ss.
    Qed.

    Lemma singleton_ur_normal_view loc ts:
      normal_view (View.singleton_ur loc ts).
    Proof. ss. Qed.

    Lemma singleton_rw_normal_view
          loc ts
          (LOC: ~ L loc):
      normal_view (View.singleton_rw loc ts).
    Proof.
      ii. ss.
      unfold TimeMap.singleton, LocFun.add, LocFun.init, LocFun.find.
      condtac; ss. subst. ss.
    Qed.

    Lemma singleton_ur_if_normal_view
          b loc ts
          (LOC: ~ L loc):
      normal_view (View.singleton_ur_if b loc ts).
    Proof.
      unfold View.singleton_ur_if. condtac.
      - apply singleton_ur_normal_view.
      - apply singleton_rw_normal_view. ss.
    Qed.

    Lemma get_normal_view
          mem loc from to val released
          (MEM: normal_memory mem)
          (GET: Memory.get loc to mem = Some (from, Message.concrete val released)):
      normal_view (View.unwrap released).
    Proof.
      destruct released; ss. eapply MEM; eauto.
    Qed.

    Lemma promise
          promises1 mem1 loc from to msg promises2 mem2 kind
          (NORMAL_MEM1: normal_memory mem1)
          (MSG: forall val released
                  (MSG: msg = Message.concrete val (Some released)),
              normal_view released)
          (PROMISE: Memory.promise promises1 mem1 loc from to msg promises2 mem2 kind):
      <<NORMAL_MEM2: normal_memory mem2>>.
    Proof.
      ii. revert GET. inv PROMISE; ss.
      - erewrite Memory.add_o; eauto. condtac; ss; i.
        + inv GET. eapply MSG; eauto.
        + eapply NORMAL_MEM1; eauto.
      - erewrite Memory.split_o; eauto. repeat condtac; ss; i.
        + inv GET. eapply MSG; eauto.
        + guardH o. des. inv GET.
          exploit Memory.split_get0; try exact MEM. i. des.
          eapply NORMAL_MEM1; eauto.
        + eapply NORMAL_MEM1; eauto.
      - erewrite Memory.lower_o; eauto. condtac; ss; i.
        + inv GET. eapply MSG; eauto.
        + eapply NORMAL_MEM1; eauto.
      - erewrite Memory.remove_o; eauto. condtac; ss; i.
        eapply NORMAL_MEM1; eauto.
    Qed.

    Lemma write
          promises1 mem1 loc from to msg promises2 mem2 kind
          (NORMAL_MEM1: normal_memory mem1)
          (MSG: forall val released
                  (MSG: msg = Message.concrete val (Some released)),
              normal_view released)
          (WRITE: Memory.write promises1 mem1 loc from to msg promises2 mem2 kind):
      <<NORMAL_MEM2: normal_memory mem2>>.
    Proof.
      inv WRITE. eauto using promise.
    Qed.

    Lemma write_na
          ts promises1 mem1 loc from to msg promises2 mem2 msgs kinds kind
          (NORMAL_MEM1: normal_memory mem1)
          (WRITE: Memory.write_na ts promises1 mem1 loc from to msg promises2 mem2 msgs kinds kind):
      <<NORMAL_MEM2: normal_memory mem2>>.
    Proof.
      induction WRITE.
      - eapply write; eauto; ss.
      - apply IHWRITE. eapply write; eauto.
        unguard. des; subst; ss.
    Qed.

    Lemma promise_step
          lc1 mem1 loc from to msg lc2 mem2 kind
          (NORMAL_TVIEW1: normal_tview (Local.tview lc1))
          (NORMAL_MEM1: normal_memory mem1)
          (MSG: forall val released
                  (MSG: msg = Message.concrete val (Some released)),
              normal_view released)
          (STEP: Local.promise_step lc1 mem1 loc from to msg lc2 mem2 kind):
      <<NORMAL_TVIEW2: normal_tview (Local.tview lc2)>> /\
      <<NORMAL_MEM2: normal_memory mem2>>.
    Proof.
      inv STEP. splits; ss. eapply promise; eauto.
    Qed.

    Lemma read_step
          lc1 mem1 loc to val released ord lc2
          (WF1: Local.wf lc1 mem1)
          (NORMAL_TVIEW1: normal_tview (Local.tview lc1))
          (NORMAL_MEM1: normal_memory mem1)
          (STEP: Local.read_step lc1 mem1 loc to val released ord lc2)
          (TO: L loc -> Ordering.le ord Ordering.plain ->
               to = (TView.cur (Local.tview lc1)).(View.rlx) loc):
      <<NORMAL_TVIEW2: normal_tview (Local.tview lc2)>>.
    Proof.
      destruct lc1. inv NORMAL_TVIEW1. inv STEP. ss.
      hexploit get_normal_view; eauto. i.
      destruct (classic (L loc /\ Ordering.le ord Ordering.plain)).
      { des. exploit TO; eauto. i. subst.
        econs; ss.
        - apply join_normal_view.
          + rewrite View.le_join_l; ss.
            apply View.singleton_ur_if_spec; try apply WF1.
            condtac; try refl. rewrite CUR; ss. refl.
          + condtac; ss.
        - apply join_normal_view.
          + rewrite View.le_join_l; ss.
            apply View.singleton_ur_if_spec; try apply WF1.
            condtac; try apply WF1. rewrite CUR; ss. apply WF1.
          + condtac; ss.
      }
      { econs; ss.
        - repeat apply join_normal_view; try condtac; ss.
          unfold View.singleton_ur_if.
          condtac; eauto using singleton_ur_normal_view.
          destruct (L loc) eqn:LOC.
          + exfalso. apply H0. destruct ord; ss.
          + apply singleton_rw_normal_view; eauto. rewrite LOC. ss.
        - condtac; repeat eapply join_normal_view; eauto; ss.
          destruct (L loc) eqn:LOC.
          + exfalso. apply H0. destruct ord; ss.
          + apply singleton_rw_normal_view; eauto. rewrite LOC. ss.
      }
    Qed.

    Lemma write_step
          lc1 sc1 mem1 loc from to val releasedm released ord lc2 sc2 mem2 kind
          (NORMAL_TVIEW1: normal_tview (Local.tview lc1))
          (NORMAL_MEM1: normal_memory mem1)
          (RELEASEDM: normal_view (View.unwrap releasedm))
          (STEP: Local.write_step lc1 sc1 mem1 loc from to val releasedm released ord lc2 sc2 mem2 kind):
      (<<NORMAL_TVIEW2: normal_tview (Local.tview lc2)>>) /\
      (<<NORMAL_MEM2: normal_memory mem2>>).
    Proof.
      destruct lc1. inv NORMAL_TVIEW1. inv STEP. ss.
      hexploit write; eauto.
      { i. revert MSG. unfold TView.write_released.
        condtac; ss. i. inv MSG.
        condtac; repeat apply join_normal_view; eauto.
        - unfold LocFun.add. condtac; ss.
          apply join_normal_view; ss.
        - unfold LocFun.add. condtac; ss.
          apply join_normal_view; ss.
      }
      i. des. splits; ss.
      econs; repeat apply join_normal_view; ss;
        try apply singleton_ur_normal_view. i.
      unfold LocFun.add.
      repeat condtac; ss; eauto;
        repeat apply join_normal_view; ss.
    Qed.

    Lemma write_na_step
          lc1 sc1 mem1 loc from to val ord lc2 sc2 mem2 msgs kinds kind
          (NORMAL_TVIEW1: normal_tview (Local.tview lc1))
          (NORMAL_MEM1: normal_memory mem1)
          (STEP: Local.write_na_step lc1 sc1 mem1 loc from to val ord lc2 sc2 mem2 msgs kinds kind):
      (<<NORMAL_TVIEW2: normal_tview (Local.tview lc2)>>) /\
      (<<NORMAL_MEM2: normal_memory mem2>>).
    Proof.
      destruct lc1. inv NORMAL_TVIEW1. inv STEP. ss.
      hexploit write_na; eauto. i. des. splits; ss.
      econs; repeat apply join_normal_view; ss;
        try apply singleton_ur_normal_view. i.
      unfold LocFun.add.
      repeat condtac; ss; eauto;
        repeat apply join_normal_view; ss.
    Qed.

    Lemma fence_step
          lc1 sc1 ordr ordw lc2 sc2
          (NORMAL_TVIEW1: normal_tview (Local.tview lc1))
          (STEP: Local.fence_step lc1 sc1 ordr ordw lc2 sc2):
      (<<NORMAL_TVIEW2: normal_tview (Local.tview lc2)>>).
    Proof.
      inv NORMAL_TVIEW1. inv STEP. ss.
      econs; ss; i; repeat condtac; ss;
        repeat apply join_normal_view; ss.
    Qed.

    Lemma ord_program_step
          ordcr ordcw e lc1 sc1 mem1 lc2 sc2 mem2
          (WF1: Local.wf lc1 mem1)
          (NORMAL_TVIEW1: normal_tview (Local.tview lc1))
          (NORMAL_MEM1: normal_memory mem1)
          (STEP: OrdLocal.program_step L ordcr ordcw e lc1 sc1 mem1 lc2 sc2 mem2)
          (READ: forall loc to val released ord
                   (EVENT: ThreadEvent.is_reading e = Some (loc, to, val, released, ord))
                   (LOC: L loc)
                   (ORD: Ordering.le ord Ordering.plain),
              to = (TView.cur (Local.tview lc1)).(View.rlx) loc):
      (<<NORMAL_TVIEW2: normal_tview (Local.tview lc2)>>) /\
      (<<NORMAL_MEM2: normal_memory mem2>>).
    Proof.
      inv STEP; ss.
      - inv LOCAL. hexploit read_step; eauto.
        i. exploit READ; eauto.
        revert H0. condtac; ss. destruct ord, ordcr; ss.
      - inv LOCAL. hexploit write_step; eauto. ss.
      - inv LOCAL1. inv LOCAL2.
        hexploit read_step; eauto.
        { i. exploit READ; eauto.
          revert H0. condtac; ss. destruct ordr, ordcr; ss.
        }
        i. des.
        hexploit write_step; eauto.
        inv STEP. ss. eapply get_normal_view; eauto.
      - hexploit fence_step; eauto.
      - hexploit fence_step; eauto.
      - inv LOCAL.
        + hexploit write_na_step; eauto.
        + hexploit write_step; eauto. ss.
    Qed.

    Lemma future_normal_thread
          lang e sc' mem'
          (NORMAL: @normal_thread lang e)
          (NORMAL_MEM: normal_memory mem'):
      normal_thread (Thread.mk _ (Thread.state e) (Thread.local e) sc' mem').
    Proof.
      inv NORMAL. econs; ss.
    Qed.
  End Normal.
End Normal.

Module Stable.
  Section Stable.
    Variable L: Loc.t -> bool.

    Definition stable_view (mem: Memory.t) (view: View.t): Prop :=
      forall loc from val released
        (LOC: L loc)
        (GET: Memory.get loc ((View.rlx view) loc) mem =
              Some (from, Message.concrete val (Some released))),
        View.le released view.

    Definition stable_timemap (mem: Memory.t) (tm: TimeMap.t): Prop :=
      stable_view mem (View.mk tm tm).

    Inductive stable_tview (mem: Memory.t) (tview: TView.t): Prop :=
    | stable_tview_intro
        (REL: forall loc (LOC: ~ L loc), stable_view mem ((TView.rel tview) loc))
        (CUR: stable_view mem (TView.cur tview))
        (ACQ: stable_view mem (TView.acq tview))
    .

    Definition stable_memory (rels: Writes.t) (mem: Memory.t): Prop :=
      forall loc from to val released
        (LOC: ~ L loc \/
              exists ord, List.In (loc, to, ord) rels /\ Ordering.le Ordering.acqrel ord)
        (GET: Memory.get loc to mem = Some (from, Message.concrete val (Some released))),
        stable_view mem released.

    Inductive stable_thread {lang: language} (rels: Writes.t) (e: Thread.t lang): Prop :=
    | stable_thread_intro
        (STABLE_TVIEW: Stable.stable_tview (Thread.memory e) (Local.tview (Thread.local e)))
        (STABLE_SC: Stable.stable_timemap (Thread.memory e) (Thread.sc e))
        (STABLE_MEMORY: Stable.stable_memory rels (Thread.memory e))
    .
    Hint Constructors stable_thread: core.

    Lemma future_stable_view
          mem1 mem2 view
          (CLOSED: Memory.closed_view view mem1)
          (STABLE: stable_view mem1 view)
          (MEM_FUTURE: Memory.future mem1 mem2):
      stable_view mem2 view.
    Proof.
      ii. inv CLOSED. specialize (RLX loc). des.
      exploit Memory.future_get1; try exact RLX; eauto; ss. i. des.
      rewrite GET0 in *. inv GET. inv MSG_LE. inv RELEASED.
      exploit STABLE; eauto.
    Qed.

    Lemma future_stable_tview
          mem1 mem2 tview
          (CLOSED: TView.closed tview mem1)
          (STABLE: stable_tview mem1 tview)
          (MEM_FUTURE: Memory.future mem1 mem2):
      stable_tview mem2 tview.
    Proof.
      destruct tview. inv CLOSED. inv STABLE. ss.
      econs; ss; eauto using future_stable_view.
    Qed.

    Lemma future_stable_thread
          lang rels e sc' mem'
          (WF: Local.wf (Thread.local e) (Thread.memory e))
          (STABLE: stable_thread rels e)
          (SC: TimeMap.le (Thread.sc e) sc')
          (MEM: Memory.future (Thread.memory e) mem')
          (STABLE_SC: Stable.stable_timemap mem' sc')
          (STABLE_MEM: Stable.stable_memory rels mem'):
      stable_thread rels (Thread.mk lang (Thread.state e) (Thread.local e) sc' mem').
    Proof.
      destruct e, local. inv STABLE. inv WF. ss.
      econs; i; ss; eauto using Stable.future_stable_tview.
    Qed.

    Lemma join_stable_view
          mem view1 view2
          (STABLE1: stable_view mem view1)
          (STABLE2: stable_view mem view2):
      stable_view mem (View.join view1 view2).
    Proof.
      ii. unfold stable_view in *.
      unfold View.join, TimeMap.join in GET. ss.
      exploit Time.join_cases. i. des.
      - erewrite x0 in GET.
        exploit STABLE1; eauto. i.
        etrans; eauto. apply View.join_l.
      - erewrite x0 in GET.
        exploit STABLE2; eauto. i.
        etrans; eauto. apply View.join_r.
    Qed.

    Lemma bot_stable_view
          mem
          (MEM: Memory.closed mem):
      stable_view mem View.bot.
    Proof.
      ii. inv MEM. rewrite INHABITED in *. inv GET.
    Qed.

    Lemma singleton_ur_stable_view
          mem loc ts
          (MEM: Memory.closed mem)
          (LOC: ~ L loc):
      stable_view mem (View.singleton_ur loc ts).
    Proof.
      ii. revert GET. ss.
      unfold TimeMap.singleton, LocFun.add, LocFun.init, LocFun.find.
      condtac; subst; ss. i.
      inv MEM. rewrite INHABITED in *. inv GET.
    Qed.

    Lemma singleton_rw_stable_view
          mem loc ts
          (MEM: Memory.closed mem)
          (LOC: ~ L loc):
      stable_view mem (View.singleton_rw loc ts).
    Proof.
      ii. revert GET. ss.
      unfold TimeMap.singleton, LocFun.add, LocFun.init, LocFun.find.
      condtac; subst; ss. i.
      inv MEM. rewrite INHABITED in *. inv GET.
    Qed.

    Lemma singleton_ur_if_stable_view
          mem b loc ts
          (MEM: Memory.closed mem)
          (LOC: ~ L loc):
      stable_view mem (View.singleton_ur_if b loc ts).
    Proof.
      unfold View.singleton_ur_if. condtac.
      - apply singleton_ur_stable_view; ss.
      - apply singleton_rw_stable_view; ss.
    Qed.

    Lemma stable_view_stable_timemap
          mem view
          (VIEW: View.wf view)
          (STABLE: stable_view mem view):
      stable_timemap mem (View.rlx view).
    Proof.
      ii. etrans; [eapply STABLE|]; eauto.
      econs; ss; try refl. apply VIEW.
    Qed.

    Lemma join_stable_timemap
          mem tm1 tm2
          (STABLE1: stable_timemap mem tm1)
          (STABLE2: stable_timemap mem tm2):
      stable_timemap mem (TimeMap.join tm1 tm2).
    Proof.
      unfold stable_timemap in *.
      hexploit join_stable_view; [exact STABLE1|exact STABLE2|]. ss.
    Qed.

    Lemma stable_tview_read_tview
          mem tview
          loc from val released ord
          (WF: TView.wf tview)
          (NORMAL: Normal.normal_tview L tview)
          (STABLE: stable_tview mem tview)
          (LOC: L loc)
          (GET: Memory.get loc ((View.rlx (TView.cur tview)) loc) mem =
                Some (from, Message.concrete val released)):
      TView.read_tview tview loc ((View.rlx (TView.cur tview)) loc) released ord = tview.
    Proof.
      inv STABLE. inv NORMAL.
      destruct tview. unfold TView.read_tview. ss. f_equal.
      - rewrite (@View.le_join_l cur); cycle 1.
        { unfold View.singleton_ur_if. condtac; ss.
          - unfold View.singleton_ur. econs; ss.
            + ii. unfold TimeMap.singleton, LocFun.add, LocFun.find, LocFun.init.
              condtac; try apply Time.bot_spec. subst.
              rewrite CUR0; ss. refl.
            + ii. unfold TimeMap.singleton, LocFun.add, LocFun.find, LocFun.init.
              condtac; try apply Time.bot_spec. subst. refl.
          - unfold View.singleton_rw. econs; ss; try apply TimeMap.bot_spec.
            ii. unfold TimeMap.singleton, LocFun.add, LocFun.find, LocFun.init.
            condtac; try apply Time.bot_spec. subst. refl.
        }
        condtac; try apply View.join_bot_r.
        apply View.le_join_l.
        destruct released; eauto. apply View.bot_spec.
      - rewrite (@View.le_join_l acq); cycle 1.
        { etrans; [|eapply WF]. ss.
          unfold View.singleton_ur_if. condtac; ss.
          - unfold View.singleton_ur. econs; ss.
            + ii. unfold TimeMap.singleton, LocFun.add, LocFun.find, LocFun.init.
              condtac; try apply Time.bot_spec. subst.
              rewrite CUR0; ss. refl.
            + ii. unfold TimeMap.singleton, LocFun.add, LocFun.find, LocFun.init.
              condtac; try apply Time.bot_spec. subst. refl.
          - unfold View.singleton_rw. econs; ss; try apply TimeMap.bot_spec.
            ii. unfold TimeMap.singleton, LocFun.add, LocFun.find, LocFun.init.
            condtac; try apply Time.bot_spec. subst. refl.
        }
        condtac; try apply View.join_bot_r.
        apply View.le_join_l.
        etrans; [|eapply WF]. ss.
        destruct released; eauto. apply View.bot_spec.
    Qed.

    Lemma stable_memory_tail
          a rels mem
          (STABLE: stable_memory (a :: rels) mem):
      stable_memory rels mem.
    Proof.
      ii. des.
      - eapply STABLE; eauto.
      - eapply STABLE; eauto. ss.
        right. esplits; eauto.
    Qed.

    Lemma promise_stable_view
          view promises1 mem1 loc from to msg promises2 mem2 kind
          (CLOSED1: Memory.closed_view view mem1)
          (STABLE1: stable_view mem1 view)
          (PROMISE: Memory.promise promises1 mem1 loc from to msg promises2 mem2 kind):
      stable_view mem2 view.
    Proof.
      ii. revert GET. inv PROMISE; ss.
      { erewrite Memory.add_o; eauto. condtac; ss; eauto.
        i. des. inv GET.
        exploit Memory.add_get0; try exact MEM. i. des.
        inv CLOSED1. specialize (RLX loc). des. congr.
      }
      { erewrite Memory.split_o; eauto. repeat condtac; ss; eauto.
        - i. des. inv GET.
          exploit Memory.split_get0; try exact MEM. i. des.
          inv CLOSED1. specialize (RLX loc). des. congr.
        - guardH o. i. des. inv GET.
          exploit Memory.split_get0; try exact MEM. i. des. eauto.
      }
      { erewrite Memory.lower_o; eauto. condtac; ss; eauto.
        i. des. inv GET.
        exploit Memory.lower_get0; try exact MEM. i. des.
        inv MSG_LE. inv RELEASED. etrans; eauto.
      }
      { erewrite Memory.remove_o; eauto. condtac; ss; eauto. }
    Qed.

    Lemma write_stable_view
          view promises1 mem1 loc from to msg promises2 mem2 kind
          (CLOSED1: Memory.closed_view view mem1)
          (STABLE1: stable_view mem1 view)
          (WRITE: Memory.write promises1 mem1 loc from to msg promises2 mem2 kind):
      stable_view mem2 view.
    Proof.
      inv WRITE. eauto using promise_stable_view.
    Qed.

    Lemma write_na_stable_view
          view ts promises1 mem1 loc from to msg promises2 mem2 msgs kinds kind
          (CLOSED1: Memory.closed_view view mem1)
          (STABLE1: stable_view mem1 view)
          (WRITE: Memory.write_na ts promises1 mem1 loc from to msg promises2 mem2 msgs kinds kind):
      stable_view mem2 view.
    Proof.
      induction WRITE; eauto using write_stable_view.
      hexploit write_stable_view; try exact WRITE_EX; eauto. i.
      hexploit Memory.write_closed_view; try exact WRITE_EX; eauto.
    Qed.

    Lemma promise_stable_tview
          tview promises1 mem1 loc from to msg promises2 mem2 kind
          (CLOSED1: TView.closed tview mem1)
          (STABLE1: stable_tview mem1 tview)
          (PROMISE: Memory.promise promises1 mem1 loc from to msg promises2 mem2 kind):
      stable_tview mem2 tview.
    Proof.
      inv CLOSED1. inv STABLE1.
      econs; eauto using promise_stable_view.
    Qed.

    Lemma write_stable_tview
          tview promises1 mem1 loc from to msg promises2 mem2 kind
          (CLOSED1: TView.closed tview mem1)
          (STABLE1: stable_tview mem1 tview)
          (WRITE: Memory.write promises1 mem1 loc from to msg promises2 mem2 kind):
      stable_tview mem2 tview.
    Proof.
      inv CLOSED1. inv STABLE1.
      econs; eauto using write_stable_view.
    Qed.

    Lemma write_na_stable_tview
          tview ts promises1 mem1 loc from to msg promises2 mem2 msgs kinds kind
          (CLOSED1: TView.closed tview mem1)
          (STABLE1: stable_tview mem1 tview)
          (WRITE: Memory.write_na ts promises1 mem1 loc from to msg promises2 mem2 msgs kinds kind):
      stable_tview mem2 tview.
    Proof.
      inv CLOSED1. inv STABLE1.
      econs; eauto using write_na_stable_view.
    Qed.

    Lemma promise_stable_memory
          rels promises1 mem1 loc from to msg promises2 mem2 kind
          (MEM1: Memory.closed mem1)
          (STABLE_MEM1: stable_memory rels mem1)
          (MSG: forall val released
                  (MSG: msg = Message.concrete val (Some released)),
              stable_view mem2 released)
          (PROMISE: Memory.promise promises1 mem1 loc from to msg promises2 mem2 kind):
      stable_memory rels mem2.
    Proof.
      unfold stable_memory in *. i. revert GET. guardH LOC.
      dup PROMISE. inv PROMISE0; ss.
      { (* add *)
        erewrite Memory.add_o; eauto. condtac; ss; i.
        - des. inv GET. eauto.
        - guardH o.
          inv MEM1. exploit CLOSED; eauto. i. des. inv MSG_CLOSED. inv CLOSED0.
          hexploit STABLE_MEM1; eauto. i.
          eapply promise_stable_view; eauto.
      }
      { (* split *)
        erewrite Memory.split_o; eauto. repeat condtac; ss; i.
        - des. inv GET. eauto.
        - guardH o. des. inv GET.
          exploit Memory.split_get0; try exact MEM. i. des.
          inv MEM1. exploit CLOSED; try exact GET0. i. des. inv MSG_CLOSED. inv CLOSED0.
          hexploit STABLE_MEM1; try exact GET0; eauto. i.
          eapply promise_stable_view; eauto.
        - guardH o. guardH o0.
          inv MEM1. exploit CLOSED; eauto. i. des. inv MSG_CLOSED. inv CLOSED0.
          hexploit STABLE_MEM1; eauto. i.
          eapply promise_stable_view; eauto.
      }
      { (* lower *)
        erewrite Memory.lower_o; eauto. condtac; ss; i.
        - des. inv GET. eauto.
        - guardH o.
          inv MEM1. exploit CLOSED; eauto. i. des. inv MSG_CLOSED. inv CLOSED0.
          hexploit STABLE_MEM1; eauto. i.
          eapply promise_stable_view; eauto.
      }
      { (* cancel *)
        erewrite Memory.remove_o; eauto. condtac; ss; i.
        guardH o.
        inv MEM1. exploit CLOSED; eauto. i. des. inv MSG_CLOSED. inv CLOSED0.
        hexploit STABLE_MEM1; eauto. i.
        eapply promise_stable_view; eauto.
      }
    Qed.

    Lemma write_stable_memory
          ord
          rels promises1 mem1 loc from to msg promises2 mem2 kind
          (MEM1: Memory.closed mem1)
          (STABLE_MEM1: stable_memory rels mem1)
          (WRITES1: Writes.wf L rels mem1)
          (RESERVE_ONLY1: OrdLocal.reserve_only L promises1)
          (MSG: forall val released
                  (LOC: ~ L loc \/ Ordering.le Ordering.acqrel ord)
                  (MSG: msg = Message.concrete val (Some released)),
              stable_view mem2 released)
          (WRITE: Memory.write promises1 mem1 loc from to msg promises2 mem2 kind):
      stable_memory (if L loc then (loc, to, ord) :: rels else rels) mem2.
    Proof.
      destruct (L loc) eqn:LOC; cycle 1.
      { inv WRITE. eauto using promise_stable_memory. }
      exploit OrdLocal.reserve_only_write_add; eauto. i. subst.
      inv WRITE. dup PROMISE. inv PROMISE0.
      unfold stable_memory in *. i. revert GET.
      erewrite Memory.add_o; eauto. condtac; ss; i.
      - des; clarify; eauto.
        inv WRITES1. exploit SOUND; eauto. i. des.
        exploit Memory.add_get0; try exact MEM. i. des. congr.
      - guardH o.
        hexploit STABLE_MEM1; eauto; i.
        { des; eauto. clarify. unguard. des; ss. }
        clear LOC0.
        inv MEM1. exploit CLOSED; eauto. i. des. inv MSG_CLOSED. inv CLOSED0.
        eapply promise_stable_view; eauto.
    Qed.

    Lemma write_na_stable_memory
          rels ts promises1 mem1 loc from to val promises2 mem2 msgs kinds kind
          (MEM1: Memory.closed mem1)
          (STABLE_MEM1: stable_memory rels mem1)
          (WRITE: Memory.write_na ts promises1 mem1 loc from to val promises2 mem2 msgs kinds kind):
      stable_memory rels mem2.
    Proof.
      induction WRITE.
      - inv WRITE. eapply promise_stable_memory; eauto; ss.
      - exploit Memory.write_closed; try exact WRITE_EX; ss.
        { unguard. des; subst; ss. econs. ss. }
        { unguard. des; subst; ss. econs. apply Time.bot_spec. }
        i. inv WRITE_EX.
        hexploit promise_stable_memory; try exact PROMISE; eauto.
        i. subst. unguard. des; ss.
    Qed.

    Lemma stable_memory_strong_relaxed
          rels mem loc to ord
          (ORD: Ordering.le ord Ordering.strong_relaxed):
      stable_memory rels mem <-> stable_memory ((loc, to, ord) :: rels) mem.
    Proof.
      split; ii.
      - eapply H; eauto. des; eauto.
        inv LOC; eauto. inv H0. destruct ord0; ss.
      - eapply H; eauto. des; eauto.
        right. esplits; eauto. right. ss.
    Qed.

    Lemma stable_memory_le
          rels mem loc to ord1 ord2
          (STABLE_MEM1: stable_memory ((loc, to, ord1) :: rels) mem)
          (ORD: Ordering.le ord2 ord1):
      stable_memory ((loc, to, ord2) :: rels) mem.
    Proof.
      ii. eapply STABLE_MEM1; eauto. des; eauto. inv LOC.
      - inv H. right. esplits; [left; eauto|]. etrans; eauto.
      - right. esplits; [right; eauto|]. ss.
    Qed.

    (* step *)

    Lemma promise_step
          rels lc1 mem1 loc from to msg lc2 mem2 kind
          (WF1: Local.wf lc1 mem1)
          (MEM1: Memory.closed mem1)
          (STABLE_TVIEW1: stable_tview mem1 (Local.tview lc1))
          (STABLE_MEM1: stable_memory rels mem1)
          (MSG: forall val released
                  (MSG: msg = Message.concrete val (Some released)),
              stable_view mem2 released)
          (STEP: Local.promise_step lc1 mem1 loc from to msg lc2 mem2 kind):
      <<STABLE_TVIEW2: stable_tview mem2 (Local.tview lc2)>> /\
      <<STABLE_MEM2: stable_memory rels mem2>>.
    Proof.
      inv STEP.
      hexploit promise_stable_tview; eauto; try apply WF1. i.
      hexploit promise_stable_memory; eauto.
    Qed.

    Lemma read_step_loc_cur
          lc1 mem1 loc to val released ord lc2
          (WF1: Local.wf lc1 mem1)
          (NORMAL_TVIEW1: Normal.normal_tview L (Local.tview lc1))
          (STABLE_TVIEW1: stable_tview mem1 (Local.tview lc1))
          (LOC: L loc)
          (TO: to = (TView.cur (Local.tview lc1)).(View.rlx) loc)
          (STEP: Local.read_step lc1 mem1 loc to val released ord lc2):
      <<LC2: lc2 = lc1>>.
    Proof.
      inv STEP. destruct lc1. f_equal; ss.
      erewrite stable_tview_read_tview; eauto. apply WF1.
    Qed.

    Lemma read_step_loc_ra
          rels ordw lc1 mem1 loc to val released ord lc2
          (WF1: Local.wf lc1 mem1)
          (MEM1: Memory.closed mem1)
          (STABLE_TVIEW1: stable_tview mem1 (Local.tview lc1))
          (STABLE_MEM1: stable_memory rels mem1)
          (LOC: L loc)
          (IN: List.In (loc, to, ordw) rels)
          (ORDW: Ordering.le Ordering.acqrel ordw)
          (ORD: Ordering.le Ordering.acqrel ord)
          (STEP: Local.read_step lc1 mem1 loc to val released ord lc2):
      <<STABLE_TVIEW2: stable_tview mem1 (Local.tview lc2)>>.
    Proof.
      inv STEP. ss.
      inv STABLE_TVIEW1. econs; ss.
      - unfold View.singleton_ur_if.
        repeat (condtac; [|destruct ord; ss]). ii.
        destruct (Loc.eq_dec loc loc0); subst; ss.
        + unfold TimeMap.join, View.singleton_ur_if,
            TimeMap.singleton, LocFun.add, LocFun.init, LocFun.find in GET0.
          revert GET0. condtac; ss. i.
          rewrite TimeFacts.le_join_l in GET0; cycle 1.
          { etrans; [|eapply Time.join_r].
            inv MEM1. exploit CLOSED; try exact GET. i. des.
            inv MSG_TS. ss.
          }
          rewrite TimeFacts.le_join_r in GET0; cycle 1.
          { inv READABLE. auto. }
          rewrite GET0 in *. inv GET. ss.
          etrans; [|apply View.join_r]. refl.
        + unfold TimeMap.join, View.singleton_ur_if,
            TimeMap.singleton, LocFun.add, LocFun.init, LocFun.find in GET0.
          revert GET0. condtac; try congr; ss. i.
          rewrite (@TimeFacts.le_join_l _ Time.bot) in GET0; try apply Time.bot_spec.
          exploit Time.join_cases. i. des.
          { rewrite x0 in GET0.
            exploit CUR; eauto. i. etrans; eauto.
            etrans; [|apply View.join_l].
            etrans; [|apply View.join_l].
            refl.
          }
          { rewrite x0 in GET0. destruct released; ss; cycle 1.
            { unfold TimeMap.bot in *.
              inv MEM1. rewrite INHABITED in GET0. ss. }
            exploit STABLE_MEM1; try exact GET; eauto. i.
            etrans; eauto.
            etrans; [|apply View.join_r].
            refl.
          }
      - unfold View.singleton_ur_if.
        repeat (condtac; [|destruct ord; ss]). ii.
        destruct (Loc.eq_dec loc loc0); subst; ss.
        + unfold TimeMap.join, View.singleton_ur_if,
            TimeMap.singleton, LocFun.add, LocFun.init, LocFun.find in GET0.
          revert GET0. condtac; ss. i.
          rewrite Time.join_assoc in GET0.
          rewrite (@TimeFacts.le_join_l to) in GET0; cycle 1.
          { inv MEM1. exploit CLOSED; try exact GET. i. des.
            inv MSG_TS. ss. }
          exploit Time.join_cases. i. des.
          { rewrite x0 in GET0.
            exploit ACQ; eauto. i. etrans; eauto.
            etrans; [|apply View.join_l].
            etrans; [|apply View.join_l].
            refl.
          }
          { rewrite x0 in GET0. rewrite GET0 in *. inv GET. ss.
            etrans; [|apply View.join_r].
            refl.
          }
        + unfold TimeMap.join, View.singleton_ur_if,
            TimeMap.singleton, LocFun.add, LocFun.init, LocFun.find in GET0.
          revert GET0. condtac; try congr; ss. i.
          rewrite (@TimeFacts.le_join_l _ Time.bot) in GET0; try apply Time.bot_spec.
          exploit Time.join_cases. i. des.
          { rewrite x0 in GET0.
            exploit ACQ; eauto. i. etrans; eauto.
            etrans; [|apply View.join_l].
            etrans; [|apply View.join_l].
            refl.
          }
          { rewrite x0 in GET0. destruct released; ss; cycle 1.
            { unfold TimeMap.bot in *.
              inv MEM1. rewrite INHABITED in GET0. ss. }
            exploit STABLE_MEM1; try exact GET; eauto. i.
            etrans; eauto.
            etrans; [|apply View.join_r]. refl.
          }
    Qed.

    Lemma read_step_other
          rels lc1 mem1 loc to val released ord lc2
          (WF1: Local.wf lc1 mem1)
          (MEM1: Memory.closed mem1)
          (STABLE_TVIEW1: stable_tview mem1 (Local.tview lc1))
          (STABLE_MEM1: stable_memory rels mem1)
          (LOC: ~ L loc)
          (STEP: Local.read_step lc1 mem1 loc to val released ord lc2):
      <<STABLE_TVIEW2: stable_tview mem1 (Local.tview lc2)>>.
    Proof.
      inv STEP. ss. splits; ss.
      inv STABLE_TVIEW1. econs; ss.
      + repeat apply join_stable_view; ss.
        * apply singleton_ur_if_stable_view; ss.
        * condtac; ss.
          { destruct released; ss.
            - eapply STABLE_MEM1; eauto.
            - apply bot_stable_view; ss. }
          { apply bot_stable_view; ss. }
      + repeat apply join_stable_view; ss.
        * apply singleton_ur_if_stable_view; ss.
        * condtac; ss.
          { destruct released; ss.
            - eapply STABLE_MEM1; eauto.
            - apply bot_stable_view; ss. }
          { apply bot_stable_view; ss. }
    Qed.

    Lemma write_tview_stable
          mem tview sc loc to ord
          (WF: TView.wf tview)
          (MEM: Memory.closed mem)
          (STABLE: stable_tview mem tview)
          (WRITABLE: TView.writable (TView.cur tview) sc loc to ord)
          (TO: forall from val released
                 (LOC: L loc)
                 (GET: Memory.get loc to mem = Some (from, Message.concrete val (Some released))),
              View.le released (TView.cur (TView.write_tview tview sc loc to ord))):
      stable_tview mem (TView.write_tview tview sc loc to ord).
    Proof.
      inv WRITABLE. inv STABLE. econs; ss; i.
      { condtac; ss.
        - unfold LocFun.add, LocFun.find.
          condtac; ss; eauto. subst.
          apply join_stable_view; eauto.
          apply singleton_ur_stable_view; eauto.
        - unfold LocFun.add, LocFun.find.
          condtac; ss; eauto. subst.
          apply join_stable_view; eauto.
          apply singleton_ur_stable_view; eauto.
      }
      { ii. ss. revert GET.
        unfold TimeMap.join, TimeMap.singleton, LocFun.add, LocFun.init, LocFun.find.
        condtac; ss.
        - subst. rewrite TimeFacts.le_join_r; [|econs; ss]. eauto.
        - rewrite TimeFacts.le_join_l; try apply Time.bot_spec. i.
          exploit CUR; eauto. i.
          etrans; eauto. apply View.join_l.
      }
      { ii. ss. revert GET.
        unfold TimeMap.join, TimeMap.singleton, LocFun.add, LocFun.init, LocFun.find.
        condtac; ss.
        - subst. exploit Time.join_cases. intro JOIN. des; rewrite JOIN; i.
          + exploit ACQ; eauto. i.
            etrans; eauto. apply View.join_l.
          + exploit TO; eauto. i.
            etrans; eauto.
            eapply View.join_spec; try apply View.join_r.
            etrans; [|apply View.join_l]. apply WF.
        - rewrite TimeFacts.le_join_l; try apply Time.bot_spec. i.
          exploit ACQ; eauto. i.
          etrans; eauto. apply View.join_l.
      }
    Qed.

    Lemma write_step
          rels lc1 sc1 mem1 loc from to val releasedm released ord lc2 sc2 mem2 kind
          (WF1: Local.wf lc1 mem1)
          (SC1: Memory.closed_timemap sc1 mem1)
          (MEM1: Memory.closed mem1)
          (RELS_WF1: Writes.wf L rels mem1)
          (RESERVE_ONLY1: OrdLocal.reserve_only L (Local.promises lc1))
          (STABLE_TVIEW1: stable_tview mem1 (Local.tview lc1))
          (STABLE_MEM1: stable_memory rels mem1)
          (WF_RELEASEDM: View.opt_wf releasedm)
          (CLOSED_RELEASEDM: Memory.closed_opt_view releasedm mem1)
          (STABLE_RELEASEDM: ~ L loc -> stable_view mem1 (View.unwrap releasedm))
          (RELEASEDM: L loc -> View.le (View.unwrap releasedm) (TView.cur (Local.tview lc1)))
          (STEP: Local.write_step lc1 sc1 mem1 loc from to val releasedm released ord lc2 sc2 mem2 kind):
      <<STABLE_TVIEW2: stable_tview mem2 (Local.tview lc2)>> /\
      <<STABLE_MEM2: stable_memory (if L loc then (loc, to, ord) :: rels else rels) mem2>>.
    Proof.
      exploit Local.write_step_future; try exact STEP; eauto. i. des.
      inv STEP. ss.
      hexploit write_stable_tview; eauto; try apply WF1. i.
      assert (REL: forall released
                     (LOC: L loc)
                     (REL: Some released = TView.write_released (Local.tview lc1) sc1 loc to releasedm ord),
                 View.le released (TView.cur (TView.write_tview (Local.tview lc1) sc1 loc to ord))).
      { unfold TView.write_released. condtac; ss. i. inv REL.
        unfold LocFun.add. repeat condtac; ss.
        - apply View.join_spec; try refl.
          etrans; eauto. apply View.join_l.
        - apply View.join_spec.
          + etrans; eauto. apply View.join_l.
          + apply View.join_spec; try by apply View.join_r.
            etrans; [|apply View.join_l]. apply WF1.
      }
      hexploit write_tview_stable; try exact H; eauto; try apply WF1.
      { i. exploit Memory.write_get2; eauto. i. des.
        rewrite GET in *. inv GET_MEM. eauto.
      }
      i. splits; auto.
      eapply write_stable_memory; try exact WRITE; eauto. i.
      revert MSG. unfold TView.write_released. condtac; ss. i. inv MSG.
      unfold LocFun.add. condtac; ss.
      destruct (classic (L loc)).
      - des; ss. condtac; try by destruct ord; ss.
        rewrite View.le_join_r; cycle 1.
        { etrans; [|apply View.join_l]. apply RELEASEDM. ss. }
        ii. ss. revert GET.
        unfold TimeMap.join, TimeMap.singleton, LocFun.add, LocFun.init, LocFun.find.
        condtac; ss.
        + subst. rewrite TimeFacts.le_join_r; cycle 1.
          { inv WRITABLE. econs. ss. }
          exploit Memory.write_get2; eauto. i. des.
          rewrite GET in *. inv GET_MEM. eauto.
        + rewrite TimeFacts.le_join_l; try apply Time.bot_spec. i.
          etrans; [|apply View.join_l].
          inv H. eapply CUR; eauto.
      - guardH LOC. inv STABLE_TVIEW1.
        condtac; ss; repeat apply join_stable_view;
          (try by apply singleton_ur_stable_view);
          try eapply write_stable_view; eauto; try apply WF1.
        + apply Memory.unwrap_closed_opt_view; ss. apply MEM1.
        + apply Memory.unwrap_closed_opt_view; ss. apply MEM1.
    Qed.

    Lemma write_na_get_to
          ts promises1 mem1 loc from to val promsies2 mem2 msgs kinds kind
          (WRITE: Memory.write_na ts promises1 mem1 loc from to val promsies2 mem2 msgs kinds kind):
      Memory.get loc to mem2 = Some (from, Message.concrete val None).
    Proof.
      induction WRITE; eauto.
      exploit Memory.write_get2; eauto. i. des. ss.
    Qed.

    Lemma write_na_step
          rels lc1 sc1 mem1 loc from to val ord lc2 sc2 mem2 msgs kinds kind
          (WF1: Local.wf lc1 mem1)
          (SC1: Memory.closed_timemap sc1 mem1)
          (MEM1: Memory.closed mem1)
          (RELS_WF1: Writes.wf L rels mem1)
          (RESERVE_ONLY1: OrdLocal.reserve_only L (Local.promises lc1))
          (STABLE_TVIEW1: stable_tview mem1 (Local.tview lc1))
          (STABLE_MEM1: stable_memory rels mem1)
          (STEP: Local.write_na_step lc1 sc1 mem1 loc from to val ord lc2 sc2 mem2 msgs kinds kind):
      <<STABLE_TVIEW2: stable_tview mem2 (Local.tview lc2)>> /\
      <<STABLE_MEM2: stable_memory (if L loc then (loc, to, ord) :: rels else rels) mem2>>.
    Proof.
      exploit Local.write_na_step_future; try exact STEP; eauto. i. des.
      inv STEP. ss.
      hexploit write_na_stable_tview; eauto; try apply WF1. i.
      exploit Memory.write_na_times; eauto. i. des.
      hexploit write_tview_stable; try exact H; eauto; try apply WF1.
      { econs. eauto. }
      { i. apply write_na_get_to in WRITE. congr. }
      i. splits; eauto.
      eapply write_na_stable_memory; try exact WRITE; eauto.
      condtac; ss. rewrite <- stable_memory_strong_relaxed; eauto.
    Qed.

    Lemma fence_step
          rels lc1 sc1 mem1 ordr ordw lc2 sc2
          (WF1: Local.wf lc1 mem1)
          (NORMAL_TVIEW1: Normal.normal_tview L (Local.tview lc1))
          (STABLE_TVIEW1: stable_tview mem1 (Local.tview lc1))
          (STABLE_SC1: stable_timemap mem1 sc1)
          (RELS_WF1: Writes.wf L rels mem1)
          (STEP: Local.fence_step lc1 sc1 ordr ordw lc2 sc2):
      <<STABLE_TVIEW2: stable_tview mem1 (Local.tview lc2)>> /\
      <<STABLE_SC2: stable_timemap mem1 sc2>>.
    Proof.
      inv STEP. ss. splits; ss.
      - inv STABLE_TVIEW1.
        econs; ss; i; repeat (condtac; ss); eauto.
        + unfold TView.write_fence_sc. repeat (condtac; ss).
          * hexploit join_stable_view; [apply STABLE_SC1| apply ACQ|]. i.
            unfold View.join in H. ss. ii.
            etrans; [eapply H; eauto|].
            econs; try refl. ss.
            apply TimeMap.join_spec.
            { apply TimeMap.join_l. }
            { etrans; [|apply TimeMap.join_r]. apply WF1. }
          * hexploit join_stable_view; [apply STABLE_SC1| apply CUR|]. i.
            unfold View.join in H. ss. ii.
            etrans; [eapply H; eauto|].
            econs; try refl. ss.
            apply TimeMap.join_spec.
            { apply TimeMap.join_l. }
            { etrans; [|apply TimeMap.join_r]. apply WF1. }
        + unfold TView.write_fence_sc. repeat (condtac; ss).
          * hexploit join_stable_view; [apply STABLE_SC1| apply ACQ|]. i.
            unfold View.join in H. ss. ii.
            etrans; [eapply H; eauto|].
            econs; try refl. ss.
            apply TimeMap.join_spec.
            { apply TimeMap.join_l. }
            { etrans; [|apply TimeMap.join_r]. apply WF1. }
          * hexploit join_stable_view; [apply STABLE_SC1| apply CUR|]. i.
            unfold View.join in H. ss. ii.
            etrans; [eapply H; eauto|].
            econs; try refl. ss.
            apply TimeMap.join_spec.
            { apply TimeMap.join_l. }
            { etrans; [|apply TimeMap.join_r]. apply WF1. }
        + unfold TView.write_fence_sc. repeat (condtac; ss).
          * apply join_stable_view; ss.
            hexploit join_stable_view; [apply STABLE_SC1| apply ACQ|]. i.
            unfold View.join in H. ss. ii.
            etrans; [eapply H; eauto|].
            econs; try refl. ss.
            apply TimeMap.join_spec.
            { apply TimeMap.join_l. }
            { etrans; [|apply TimeMap.join_r]. apply WF1. }
          * apply join_stable_view; ss.
            hexploit join_stable_view; [apply STABLE_SC1| apply CUR|]. i.
            unfold View.join in H. ss. ii.
            etrans; [eapply H; eauto|].
            econs; try refl. ss.
            apply TimeMap.join_spec.
            { apply TimeMap.join_l. }
            { etrans; [|apply TimeMap.join_r]. apply WF1. }
        + rewrite View.le_join_l; try by apply View.bot_spec. ss.
      - unfold TView.write_fence_sc. repeat (condtac; ss).
        + eapply join_stable_timemap; ss.
          apply stable_view_stable_timemap.
          * apply WF1.
          * apply STABLE_TVIEW1.
        + eapply join_stable_timemap; ss.
          apply stable_view_stable_timemap.
          * apply WF1.
          * apply STABLE_TVIEW1.
    Qed.

    (* cap *)

    Lemma max_concrete_timemap_stable
          mem tm
          (CLOSED: Memory.closed mem)
          (MAX: Memory.max_concrete_timemap mem tm):
      stable_timemap mem tm.
    Proof.
      ii. dup CLOSED. inv CLOSED.
      exploit CLOSED1; eauto. i. des. inv MSG_CLOSED. inv CLOSED. inv CLOSED2.
      hexploit Memory.max_concrete_timemap_spec; try exact PLN; eauto. i.
      hexploit Memory.max_concrete_timemap_spec; try exact RLX; eauto. i.
      econs; ss.
    Qed.

    Lemma cap_normal_memory
          mem1 mem2
          (CLOSED: Memory.closed mem1)
          (CAP: Memory.cap mem1 mem2)
          (NORMAL: Normal.normal_memory L mem1):
      Normal.normal_memory L mem2.
    Proof.
      ii. exploit Memory.cap_inv; eauto. i. des; ss.
      eapply NORMAL; eauto.
    Qed.

    Lemma cap_stable_view
          mem1 mem2 view
          (CLOSED: Memory.closed mem1)
          (CAP: Memory.cap mem1 mem2)
          (STABLE: stable_view mem1 view):
      stable_view mem2 view.
    Proof.
      ii. exploit Memory.cap_inv; eauto. i. des; ss.
      eapply STABLE; eauto.
    Qed.

    Lemma cap_stable_timemap
          mem1 mem2 tm
          (CLOSED: Memory.closed mem1)
          (CAP: Memory.cap mem1 mem2)
          (STABLE: stable_timemap mem1 tm):
      stable_timemap mem2 tm.
    Proof.
      eapply cap_stable_view; eauto.
    Qed.

    Lemma cap_stable_tview
          mem1 mem2 tview
          (CLOSED: Memory.closed mem1)
          (CAP: Memory.cap mem1 mem2)
          (STABLE: stable_tview mem1 tview):
      stable_tview mem2 tview.
    Proof.
      inv STABLE. econs; eauto using cap_stable_view.
    Qed.

    Lemma cap_stable_memory
          rels mem1 mem2
          (CLOSED: Memory.closed mem1)
          (CAP: Memory.cap mem1 mem2)
          (STABLE: stable_memory rels mem1):
      stable_memory rels mem2.
    Proof.
      ii. guardH LOC.
      exploit Memory.cap_inv; try exact GET; eauto. i. des; ss.
      exploit Memory.cap_inv; try exact GET0; eauto. i. des; ss.
      eapply STABLE; eauto.
    Qed.
  End Stable.
End Stable.


(*
 * Licensed under the Apache License, Version 2.0 (the "License");
 * you may not use this file except in compliance with the License.
 * You may obtain a copy of the License at
 *
 * http://www.apache.org/licenses/LICENSE-2.0
 *
 * Unless required by applicable law or agreed to in writing, software
 * distributed under the License is distributed on an "AS IS" BASIS,
 * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
 * See the License for the specific language governing permissions and
 * limitations under the License.
 *)

Require Import List.
Require Import ZArith.
Require Import EquivDec.
Require Import RelationClasses.
Require Import Equivalence.
Require Import String.
Require Import Utils.
Require Import DataSystem.
Require Import ForeignReduceOps.

Require Import EnhancedData.

Import ListNotations.
Local Open Scope list_scope.
Local Open Scope string_scope.
Local Open Scope nstring_scope.

Inductive enhanced_numeric_type :=
| enhanced_numeric_int
| enhanced_numeric_float.

Global Instance enhanced_numeric_type_eqdec : EqDec enhanced_numeric_type eq.
Proof.
  red. unfold equiv, complement.
  change (forall x y : enhanced_numeric_type, {x = y} + {x <> y}).
  decide equality.
Defined.

Inductive enhanced_reduce_op
  := RedOpCount : enhanced_reduce_op
   | RedOpSum (typ:enhanced_numeric_type) : enhanced_reduce_op
   | RedOpMin (typ:enhanced_numeric_type) : enhanced_reduce_op
   | RedOpMax (typ:enhanced_numeric_type) : enhanced_reduce_op
   | RedOpArithMean (typ:enhanced_numeric_type) : enhanced_reduce_op
   | RedOpStats (typ:enhanced_numeric_type) : enhanced_reduce_op.

Definition enhanced_numeric_type_prefix
           (typ:enhanced_numeric_type) : string
  := match typ with
     | enhanced_numeric_int => ""%string
     | enhanced_numeric_float => "F"%string
     end.

Definition enhanced_reduce_op_tostring (op:enhanced_reduce_op) : string
  := match op with
     | RedOpCount => "COUNT"%string
     | RedOpSum typ => append (enhanced_numeric_type_prefix typ) "FSUM"%string
     | RedOpMin typ  => append (enhanced_numeric_type_prefix typ) "FMIN"%string
     | RedOpMax typ => append (enhanced_numeric_type_prefix typ) "FMAX"%string
     | RedOpArithMean typ => append (enhanced_numeric_type_prefix typ) "FARITHMEAN"%string
     | RedOpStats typ => append (enhanced_numeric_type_prefix typ) "FSTATS"%string
     end.

Definition enhanced_numeric_sum (typ:enhanced_numeric_type) : unary_op
  := match typ with
     | enhanced_numeric_int
       => OpNatSum
     | enhanced_numeric_float
       => OpFloatSum
     end.

Definition enhanced_numeric_min (typ:enhanced_numeric_type) : unary_op
  := match typ with
     | enhanced_numeric_int
       => OpNatMin
     | enhanced_numeric_float
       => OpFloatBagMin
     end.

Definition enhanced_numeric_max (typ:enhanced_numeric_type) : unary_op
  := match typ with
     | enhanced_numeric_int
       => OpNatMax
     | enhanced_numeric_float
       => OpFloatBagMax
     end.

Definition enhanced_numeric_arith_mean (typ:enhanced_numeric_type) : unary_op
  := match typ with
     | enhanced_numeric_int
       => OpNatMean
     | enhanced_numeric_float
       => OpFloatMean
     end.

Definition enhanced_reduce_op_interp
           (br:brand_relation_t)
           (op:enhanced_reduce_op)
           (dl:list data) : option data
  := match op with
     | RedOpCount | RedOpSum _ | RedOpMin _ | RedOpMax _ | RedOpArithMean _ =>
                                                           let uop :=
                                                               match op with
                                                               | RedOpCount  => OpCount
                                                               | RedOpSum typ => enhanced_numeric_sum typ
                                                               | RedOpMin typ => enhanced_numeric_min typ
                                                               | RedOpMax typ => enhanced_numeric_max typ
                                                               | RedOpArithMean typ => enhanced_numeric_arith_mean typ
                                                               | RedOpStats _ => OpCount (* assert false *)
                                                               end
                                                           in
                                                           unary_op_eval br uop (dcoll dl)
     | RedOpStats typ =>
       let coll := dcoll dl in
       let count := unary_op_eval br OpCount coll in
       let sum := unary_op_eval br (enhanced_numeric_sum typ) coll in
       let min := unary_op_eval br (enhanced_numeric_min typ) coll in
       let max := unary_op_eval br (enhanced_numeric_max typ) coll in
       let v :=
           match (count, sum, min, max) with
           | (Some count, Some sum, Some min, Some max) =>
             Some (drec (("count"%string, count)
                           ::("max"%string, max)
                           ::("min"%string, min)
                           ::("sum"%string, sum)
                           ::nil))
           | _ => None
           end
       in
       v
     end.

Program Instance enhanced_foreign_reduce_op : foreign_reduce_op
  := mk_foreign_reduce_op enhanced_foreign_data enhanced_reduce_op _ _ enhanced_reduce_op_interp _.
Next Obligation.
  red; unfold equiv, complement.
  change (forall x y:enhanced_reduce_op, {x = y} + {x <> y}).
  decide equality; decide equality.
Defined.
Next Obligation.
  constructor.
  apply enhanced_reduce_op_tostring.
Defined.
Next Obligation.
  destruct op; simpl in *; invcs H.
  - constructor.
  - destruct typ; simpl in *.
    + apply some_lift in H2; destruct H2 as [? eqq ?];
        subst; constructor.
    + apply some_lift in H2; destruct H2 as [? eqq ?];
        subst; constructor.
  - destruct typ; simpl in *.
    + unfold lifted_min in *.
      apply some_lift in H2; destruct H2 as [? eqq ?];
        subst; constructor.
    + unfold lifted_fmin in *.
      apply some_lift in H2; destruct H2 as [? eqq ?];
        subst; constructor.
  - destruct typ; simpl in *.
    + unfold lifted_max in * .
      apply some_lift in H2; destruct H2 as [? eqq ?];
        subst; constructor.
    + unfold lifted_fmax in * .
      apply some_lift in H2; destruct H2 as [? eqq ?];
        subst; constructor.
  - destruct typ; simpl in *.
    + unfold lifted_max in * .
      apply some_lift in H2; destruct H2 as [? eqq ?];
        subst; constructor.
    + unfold lifted_fmax in * .
      apply some_lift in H2; destruct H2 as [? eqq ?];
        subst; constructor.
  - destruct typ; simpl in *.
    + destruct (dsum dl); simpl in *; try discriminate.
      unfold lifted_min, lifted_max in *.
      destruct ((lift bnummin (lifted_zbag dl))); simpl in *; try discriminate.
      destruct ((lift bnummax (lifted_zbag dl))); simpl in *; try discriminate.
      invcs H2.
      constructor.
      * repeat constructor.
      * reflexivity.
    + case_eq (lifted_fsum dl); intros; simpl in *; rewrite H in *; try discriminate.
      unfold lifted_fmin, lifted_fmax in *.
      destruct ((lift float_list_min (lifted_fbag dl))); simpl in *; try discriminate.
      destruct ((lift float_list_max (lifted_fbag dl))); simpl in *; try discriminate.
      invcs H2.
      constructor.
      * repeat constructor.
        apply some_lift in H; destruct H as [? eqq ?]; subst.
        constructor.
      * reflexivity.
Qed.