Require Import
        Coq.Strings.String
        Coq.Vectors.Vector
        Coq.ZArith.ZArith.

Require Import
        Fiat.Common.SumType
        Fiat.Common.EnumType
        Fiat.Common.BoundedLookup
        Fiat.Common.ilist
        Fiat.Computation
        Fiat.QueryStructure.Specification.Representation.Notations
        Fiat.QueryStructure.Specification.Representation.Heading
        Fiat.QueryStructure.Specification.Representation.Tuple
        Fiat.Narcissus.BinLib
        Fiat.Narcissus.Common.Specs
        Fiat.Narcissus.Common.WordFacts
        Fiat.Narcissus.Common.ComposeCheckSum
        Fiat.Narcissus.Common.ComposeIf
        Fiat.Narcissus.Common.ComposeOpt
        Fiat.Narcissus.Formats
        Fiat.Narcissus.BaseFormats
        Fiat.Narcissus.Stores.EmptyStore
        Fiat.Narcissus.Automation.Solver
        Fiat.Narcissus.Automation.AlignedAutomation.

Require Import Bedrock.Word.

Import Vectors.Vector.VectorNotations.
Open Scope string_scope.
Open Scope Tuple_scope.

(* Our source data type for IP packets. *)
Record IPv4_Packet :=
  { TotalLength : word 16;
    ID : word 16;
    DF : bool; (* Don't fragment flag *)
    MF : bool; (* Multiple fragments flag *)
    FragmentOffset : word 13;
    TTL : word 8;
    Protocol : EnumType ["ICMP"; "TCP"; "UDP"];
    SourceAddress : word 32;
    DestAddress : word 32;
    Options : list (word 32) }.

(* Protocol Numbers from [RFC5237]*)
Definition ProtocolTypeCodes : Vector.t (word 8) 3 :=
  [WO~0~0~0~0~0~0~0~1;   (* ICMP: 1*)
     WO~0~0~0~0~0~1~1~0; (* TCP:  6*)
     WO~0~0~0~1~0~0~0~1  (* UDP:  17*)
  ].

Definition IPv4_Packet_Format : FormatM IPv4_Packet ByteString :=
  (format_nat 4 ◦ (constant 4)
               ++ format_nat 4 ◦ (plus 5) ◦ @length _ ◦ Options
               ++ format_unused_word 8 (* TOS Field! *)
               ++ format_word ◦ TotalLength
               ++ format_word ◦ ID
               ++ format_unused_word 1 (* Unused flag! *)
               ++ format_bool ◦ DF
               ++ format_bool ◦ MF
               ++ format_word ◦ FragmentOffset
               ++ format_word ◦ TTL
               ++ format_enum ProtocolTypeCodes ◦ Protocol)%format
ThenChecksum IPChecksum_Valid OfSize 16 ThenCarryOn (format_word ◦ SourceAddress
               ++ format_word ◦ DestAddress
               ++ format_list format_word ◦ Options)%format.

Definition IPv4_Packet_OK (ipv4 : IPv4_Packet) :=
  lt (|ipv4.(Options)|) 11 /\
  lt (20 + 4 * |ipv4.(Options)|) (wordToNat ipv4.(TotalLength)).

(* Step One: Synthesize an encoder and a proof that it is correct. *)

Ltac new_encoder_rules ::=
  match goal with
    |- CorrectAlignedEncoder (_ ThenChecksum _ OfSize _ ThenCarryOn _) _ =>
    eapply @CorrectAlignedEncoderForIPChecksumThenC;
    [ normalize_encoder_format
    | normalize_encoder_format
    | repeat calculate_length_ByteString
    | solve_mod_16
    | repeat calculate_length_ByteString
    | solve_mod_8
    ]
  end.

Definition IPv4_encoder :
  CorrectAlignedEncoderFor IPv4_Packet_Format.
Proof.
  synthesize_aligned_encoder.
Defined.

(* Step Two: Extract the encoder function, and have it start encoding
   at the start of the provided ByteString [v]. *)
Definition IPv4_encoder_impl {sz} v r :=
  Eval simpl in (projT1 IPv4_encoder sz v 0 r tt).

Ltac apply_new_combinator_rule ::=
  match goal with
  | H : cache_inv_Property ?mnd _
    |- CorrectDecoder _ _ _ _ (?fmt1 ThenChecksum _ OfSize _ ThenCarryOn ?format2) _ _ _ =>
    eapply compose_IPChecksum_format_correct' with (format1 := fmt1);
    [ exact H
    | repeat calculate_length_ByteString
    | repeat calculate_length_ByteString
    | solve_mod_8
    | solve_mod_8
    | intros; normalize_format; apply_rules
    | normalize_format; apply_rules
    | solve_Prefix_Format
    ]
  end.

(* Step Three: Synthesize a decoder and a proof that /it/ is correct. *)
Definition IPv4_Packet_Header_decoder
  : CorrectAlignedDecoderFor IPv4_Packet_OK IPv4_Packet_Format.
Proof.
  synthesize_aligned_decoder.
Defined.

(* Step Four: Extract the decoder function, and have /it/ start decoding
   at the start of the provided ByteString [v]. *)
Arguments GetCurrentBytes : simpl never.
Definition IPv4_decoder_impl {sz} v :=
  Eval simpl in (projT1 IPv4_Packet_Header_decoder sz v 0 ()).

Section BP.
  Local Opaque ByteBuffer.of_vector.
  Local Transparent weqb.
  Local Transparent natToWord.
  (* Some example uses of the encoder and decoder functions. *)
  (* A binary version of a packet, sourced directly from the web. *)
  Definition bin_pkt : ByteBuffer.t _ :=
    Eval compute in ByteBuffer.of_vector (Vector.map (@natToWord 8) [69;0;100;0;0;0;0;0;38;1;243;159;192;168;222;10;192;168;222;1;0;0;0;0]).

  Definition bin_pkt' : ByteBuffer.t _ :=
    Eval compute in ByteBuffer.of_vector (Vector.map (@natToWord 8) [69;0;100;0;0;0;0;0;38;1;0;0;192;168;222;10;192;168;222;1;0;0;0;0]).
End BP.

(* A source version of a packet, different from binary packet above. *)
Definition pkt :=
  {| TotalLength := WO~0~1~1~1~0~1~0~0~0~0~0~0~0~0~0~0;
     ID := wones _;
     DF := false;
     MF := false;
     FragmentOffset := wzero _;
     TTL := WO~0~0~1~0~0~1~1~0;
     Protocol := Fin.F1;
     SourceAddress := WO~1~0~0~1~1~1~1~1~1~1~0~0~0~0~0~0~1~0~1~0~1~0~0~0~1~1~0~1~1~1~1~0;
     DestAddress := WO~0~0~0~0~1~0~1~0~1~1~0~0~0~0~0~0~1~0~1~0~1~0~0~0~1~1~0~1~1~1~1~0;
     Options := [ ]%list |}.

Definition bad_pkt :=
  {| TotalLength := wzero _; (* length is too short *)
     ID := wones _;
     DF := false;
     MF := false;
     FragmentOffset := wzero _;
     TTL := WO~0~0~1~0~0~1~1~0;
     Protocol := Fin.F1;
     SourceAddress := WO~1~0~0~1~1~1~1~1~1~1~0~0~0~0~0~0~1~0~1~0~1~0~0~0~1~1~0~1~1~1~1~0;
     DestAddress := WO~0~0~0~0~1~0~1~0~1~1~0~0~0~0~0~0~1~0~1~0~1~0~0~0~1~1~0~1~1~1~1~0;
     Options := [ ]%list |}.

Eval vm_compute in (IPv4_decoder_impl bin_pkt).

Local Transparent natToWord.
Local Transparent weqb.
(* This should succeed, *)
Eval compute in
    Ifopt (IPv4_encoder_impl (initialize_Aligned_ByteString 100) pkt)
  as bs Then IPv4_decoder_impl (fst (fst bs))
        Else None.
(* and it does! *)

(* This should fail because the total length field is too short, *)
Eval compute in
    Ifopt (IPv4_encoder_impl (initialize_Aligned_ByteString 100) bad_pkt)
  as bs Then IPv4_decoder_impl (fst (fst bs))
        Else None.
(* and it does! *)

(* Some additional checksum sanity checks. *)
Compute
  match IPv4_decoder_impl bin_pkt with
  | Some (p, _, _) => Some ((wordToN p.(SourceAddress)), wordToN p.(DestAddress))
  | None => None
  end.

Goal match AlignedIPChecksum.calculate_IPChecksum bin_pkt' 0 ()() with
     | Some (p, _, _) => p = bin_pkt
     | None => True
     end.
Proof.
  reflexivity.
Qed.

Definition pkt' := {|
                    TotalLength := WO~0~1~1~0~0~1~0~0~0~0~0~0~0~0~0~0;
                    ID := WO~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0;
                    DF := false;
                    MF := false;
                    FragmentOffset := WO~0~0~0~0~0~0~0~0~0~0~0~0~0;
                    TTL := WO~0~0~1~0~0~1~1~0;
                    Protocol := Fin.F1;
                    SourceAddress := WO~1~1~0~0~0~0~0~0~1~0~1~0~1~0~0~0~1~1~0~1~1~1~1~0~0~0~0~0~1~0~1~0;
                    DestAddress := WO~1~1~0~0~0~0~0~0~1~0~1~0~1~0~0~0~1~1~0~1~1~1~1~0~0~0~0~0~0~0~0~1;
                    Options := [] |}.

Goal match IPv4_encoder_impl (initialize_Aligned_ByteString 24) pkt' with
     | Some (p, _, _) => p = bin_pkt
     | None => True
     end.
Proof.
  compute.
  reflexivity.
Qed.


Require Import Omega.
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.

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 RAStep.

Set Implicit Arguments.

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

    (* normal *)

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

    Inductive 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.

    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.

    (* stable *)

    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: ReleaseWrites.t) (mem: Memory.t): Prop :=
      forall loc from to val released
        (LOC: ~ L loc \/ List.In (loc, to) rels)
        (GET: Memory.get loc to mem = Some (from, Message.concrete val (Some released))),
        stable_view mem released.

    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. 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 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_tview 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
          loc to rels mem
          (STABLE: stable_memory ((loc, to) :: rels) mem):
      stable_memory rels mem.
    Proof.
      ii. des.
      - eapply STABLE; eauto.
      - eapply STABLE; eauto. right. s. right. ss.
    Qed.

    (* step *)

    Lemma promise
          rels tview1 promises1 mem1 loc from to msg promises2 mem2 kind
          (TVIEW1: TView.closed tview1 mem1)
          (MEM1: Memory.closed mem1)
          (NORMAL_TVIEW1: normal_tview tview1)
          (NORMAL_MEM1: normal_memory mem1)
          (STABLE_TVIEW1: stable_tview mem1 tview1)
          (STABLE_MEM1: stable_memory rels mem1)
          (MSG: forall val released
                  (MSG: msg = Message.concrete val (Some released)),
              normal_view released /\ stable_view mem2 released)
          (PROMISE: Memory.promise promises1 mem1 loc from to msg promises2 mem2 kind):
      <<NORMAL_MEM2: normal_memory mem2>> /\
      <<STABLE_TVIEW2: stable_tview mem2 tview1>> /\
      <<STABLE_MEM2: stable_memory rels mem2>>.
    Proof.
      inv PROMISE; ss.
      { (* add *)
        splits.
        - ii. revert GET.
          erewrite Memory.add_o; eauto. condtac; ss; i.
          + des. subst. inv GET.
            exploit MSG; eauto. i. des. eauto.
          + eapply NORMAL_MEM1; eauto.
        - inv STABLE_TVIEW1. econs; ss; ii; revert GET.
          + erewrite Memory.add_o; eauto. condtac; ss; i.
            * des. subst. inv GET.
              exploit Memory.add_get0; try exact MEM. i. des.
              inv TVIEW1. specialize (REL0 loc0). inv REL0.
              specialize (RLX loc). des. congr.
            * eapply REL; eauto.
          + erewrite Memory.add_o; eauto. condtac; ss; i; eauto.
            des. subst. inv GET.
            exploit Memory.add_get0; try exact MEM. i. des.
            inv TVIEW1. inv CUR0.
            specialize (RLX loc). des. congr.
          + erewrite Memory.add_o; eauto. condtac; ss; i; eauto.
            des. subst. inv GET.
            exploit Memory.add_get0; try exact MEM. i. des.
            inv TVIEW1. inv ACQ0.
            specialize (RLX loc). des. congr.
        - ii. revert GET.
          erewrite Memory.add_o; eauto. condtac; ss; i.
          + guardH LOC. des. subst. inv GET.
            exploit MSG; eauto. i. des. eauto.
          + guardH LOC. guardH o. inv MEM1. exploit CLOSED; eauto. i. des.
            inv MSG_CLOSED. inv CLOSED0. inv CLOSED1.
            specialize (RLX loc1). des.
            exploit Memory.add_get1; try exact RLX; eauto. i.
            rewrite x0 in *. inv GET0.
            eapply STABLE_MEM1; eauto.
      }

      { (* split *)
        des. subst.
        splits; ss.
        - ii. revert GET.
          erewrite Memory.split_o; eauto. repeat condtac; ss; i.
          + des. subst. inv GET.
            exploit MSG; eauto. i. des. eauto.
          + guardH o. des. subst. inv GET.
            exploit Memory.split_get0; try exact MEM. i. des.
            eapply NORMAL_MEM1; eauto.
          + eapply NORMAL_MEM1; eauto.
        - inv STABLE_TVIEW1. econs; ss; ii; revert GET.
          + erewrite Memory.split_o; eauto. repeat condtac; ss; i.
            * des. subst. inv GET.
              exploit Memory.split_get0; try exact MEM. i. des.
              inv TVIEW1. specialize (REL0 loc0). inv REL0.
              specialize (RLX loc). des. congr.
            * guardH o. des. subst. inv GET.
              exploit Memory.split_get0; try exact MEM. i. des.
              eapply REL; eauto.
            * eapply REL; eauto.
          + erewrite Memory.split_o; eauto. repeat condtac; ss; i; eauto.
            * des. subst. inv GET.
              exploit Memory.split_get0; try exact MEM. i. des.
              inv TVIEW1. inv CUR0.
              specialize (RLX loc). des. congr.
            * guardH o. des. subst. inv GET.
              exploit Memory.split_get0; try exact MEM. i. des. eauto.
          + erewrite Memory.split_o; eauto. repeat condtac; ss; i; eauto.
            * des. subst. inv GET.
              exploit Memory.split_get0; try exact MEM. i. des.
              inv TVIEW1. inv ACQ0.
              specialize (RLX loc). des. congr.
            * guardH o. des. subst. inv GET.
              exploit Memory.split_get0; try exact MEM. i. des. eauto.
        - ii. revert GET.
          erewrite Memory.split_o; eauto. repeat condtac; ss; i.
          + guardH LOC. des. subst. inv GET.
            exploit MSG; eauto. i. des. eauto.
          + guardH LOC. guardH o. des. subst. inv GET.
            exploit Memory.split_get0; try exact MEM. i. des.
            inv MEM1. exploit CLOSED; try exact GET1. i. des.
            inv MSG_CLOSED. inv CLOSED0. inv CLOSED1.
            specialize (RLX loc1). des.
            exploit Memory.split_get1; try exact RLX; eauto. i. des.
            rewrite GET4 in *. inv GET0.
            eapply STABLE_MEM1; eauto.
          + guardH LOC. guardH o. guardH o0.
            inv MEM1. exploit CLOSED; eauto. i. des.
            inv MSG_CLOSED. inv CLOSED0. inv CLOSED1.
            specialize (RLX loc1). des.
            exploit Memory.split_get1; try exact RLX; eauto. i. des.
            rewrite GET2 in *. inv GET0.
            eapply STABLE_MEM1; eauto.
      }

      { (* lower *)
        splits; ss.
        - ii. revert GET.
          erewrite Memory.lower_o; eauto. condtac; ss; i.
          + des. subst. inv GET.
            exploit MSG; eauto. i. des. eauto.
          + eapply NORMAL_MEM1; eauto.
        - inv STABLE_TVIEW1. econs; ss; ii; revert GET.
          + erewrite Memory.lower_o; eauto. condtac; ss; i.
            * des. subst. inv GET.
              exploit Memory.lower_get0; try exact MEM. i. des.
              inv MSG_LE. inv RELEASED. etrans; eauto.
              eapply REL; eauto.
            * eapply REL; eauto.
          + erewrite Memory.lower_o; eauto. condtac; ss; i; eauto.
            des. subst. inv GET.
            exploit Memory.lower_get0; try exact MEM. i. des.
            inv MSG_LE. inv RELEASED. etrans; eauto.
          + erewrite Memory.lower_o; eauto. condtac; ss; i; eauto.
            des. subst. inv GET.
            exploit Memory.lower_get0; try exact MEM. i. des.
            inv MSG_LE. inv RELEASED. etrans; eauto.
        - ii. revert GET.
          erewrite Memory.lower_o; eauto. condtac; ss; i.
          + guardH LOC. des. subst. inv GET.
            exploit MSG; eauto. i. des. eauto.
          + guardH LOC. guardH o. inv MEM1. exploit CLOSED; eauto. i. des.
            inv MSG_CLOSED. inv CLOSED0. inv CLOSED1.
            specialize (RLX loc1). des.
            exploit Memory.lower_get1; try exact RLX; eauto. i. des.
            rewrite GET2 in *. inv GET0. inv MSG_LE. inv RELEASED.
            etrans; eauto.
            eapply STABLE_MEM1; eauto.
      }

      { (* cancel *)
        splits; ss.
        - ii. revert GET.
          erewrite Memory.remove_o; eauto. condtac; ss; i.
          eapply NORMAL_MEM1; eauto.
        - inv STABLE_TVIEW1. econs; ss; ii; revert GET.
          + erewrite Memory.remove_o; eauto. condtac; ss; i.
            eapply REL; eauto.
          + erewrite Memory.remove_o; eauto. condtac; ss; i; eauto.
          + erewrite Memory.remove_o; eauto. condtac; ss; i; eauto.
        - ii. revert GET.
          erewrite Memory.remove_o; eauto. condtac; ss; i.
          guardH LOC. guardH o. inv MEM1. exploit CLOSED; eauto. i. des.
          inv MSG_CLOSED. inv CLOSED0. inv CLOSED1.
          specialize (RLX loc1). des.
          exploit Memory.remove_get1; try exact RLX; eauto. i. des.
          { subst. exploit Memory.remove_get0; try exact MEM. i. des. congr. }
          rewrite GET2 in *. inv GET0.
          eapply STABLE_MEM1; eauto.
      }
    Qed.

    Lemma promise_step
          rels lc1 mem1 loc from to msg lc2 mem2 kind
          (WF1: Local.wf lc1 mem1)
          (MEM1: Memory.closed mem1)
          (NORMAL_TVIEW1: normal_tview (Local.tview lc1))
          (NORMAL_MEM1: normal_memory mem1)
          (STABLE_TVIEW1: stable_tview mem1 (Local.tview lc1))
          (STABLE_MEM1: stable_memory rels mem1)
          (RELS_WF1: ReleaseWrites.wf rels (Local.promises lc1) mem1)
          (MSG: forall val released
                  (MSG: msg = Message.concrete val (Some released)),
              normal_view released /\ stable_view mem2 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>> /\
      <<STABLE_TVIEW2: stable_tview mem2 (Local.tview lc2)>> /\
      <<STABLE_MEM2: stable_memory rels mem2>> /\
      <<RELS_WF2: ReleaseWrites.wf rels (Local.promises lc2) mem2>>.
    Proof.
      inv STEP. exploit promise; try apply WF1; eauto. i. des.
      splits; auto. ii. ss.
      exploit RELS_WF1; eauto. i. des. split.
      - inv PROMISE.
        + erewrite Memory.add_o; eauto. condtac; ss.
          des. subst. exploit Memory.add_get0; try exact MEM. i. des. congr.
        + erewrite Memory.split_o; eauto. repeat condtac; ss.
          * des. subst. exploit Memory.split_get0; try exact MEM. i. des. congr.
          * guardH o. des. subst.
            exploit Memory.split_get0; try exact PROMISES. i. des. congr.
        + erewrite Memory.lower_o; eauto. condtac; ss.
          des. subst. exploit Memory.lower_get0; try exact PROMISES. i. des. congr.
        + erewrite Memory.remove_o; eauto. condtac; ss.
      - destruct (Memory.op_kind_is_cancel kind) eqn:KIND.
        + destruct kind; ss. inv PROMISE.
          erewrite Memory.remove_o; eauto. condtac; ss; eauto.
          des. subst. exploit Memory.remove_get0; try exact MEM. i. des. congr.
        + exploit Memory.promise_get1; eauto. i. des. inv MSG_LE. eauto.
    Qed.

    Lemma read_step_loc_cur
          rels lc1 mem1 loc to val released ord lc2
          (WF1: Local.wf lc1 mem1)
          (MEM1: Memory.closed mem1)
          (NORMAL_TVIEW1: normal_tview (Local.tview lc1))
          (NORMAL_MEM1: normal_memory mem1)
          (STABLE_TVIEW1: stable_tview mem1 (Local.tview lc1))
          (STABLE_MEM1: stable_memory rels mem1)
          (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.
      unnw. inv STEP. destruct lc1. f_equal; ss.
      unfold TView.read_tview. condtac; ss; [|condtac; [|destruct ord]; ss].
      - condtac; [|destruct ord]; ss.
        destruct tview; ss. f_equal; ss.
        + repeat rewrite View.le_join_l; ss.
          * eapply View.singleton_ur_spec; try apply WF1.
            inv NORMAL_TVIEW1. rewrite CUR; ss. refl.
          * destruct released; try apply View.bot_spec. ss.
            inv STABLE_TVIEW1. eauto.
          * eapply View.singleton_ur_spec; try apply WF1.
            inv NORMAL_TVIEW1. rewrite CUR; ss. refl.
        + repeat rewrite View.le_join_l; ss.
          * inv WF1. ss. inv TVIEW_WF. ss. etrans; eauto.
            eapply View.singleton_ur_spec; ss.
            inv NORMAL_TVIEW1. rewrite CUR0; ss. refl.
          * inv WF1. ss. inv TVIEW_WF. ss. etrans; eauto.
            destruct released; try apply View.bot_spec. ss.
            inv STABLE_TVIEW1. eauto.
          * inv WF1. ss. inv TVIEW_WF. ss. etrans; eauto.
            eapply View.singleton_ur_spec; ss.
            inv NORMAL_TVIEW1. rewrite CUR0; ss. refl.
      - destruct tview; ss. f_equal; ss.
        + repeat rewrite View.le_join_l; ss.
          * eapply View.singleton_ur_spec; try apply WF1.
            inv NORMAL_TVIEW1. rewrite CUR; ss. refl.
          * destruct released; try apply View.bot_spec.
          * eapply View.singleton_ur_spec; try apply WF1.
            inv NORMAL_TVIEW1. rewrite CUR; ss. refl.
        + repeat rewrite View.le_join_l; ss.
          * inv WF1. ss. inv TVIEW_WF. ss. etrans; eauto.
            eapply View.singleton_ur_spec; ss.
            inv NORMAL_TVIEW1. rewrite CUR0; ss. refl.
          * inv WF1. ss. inv TVIEW_WF. ss. etrans; eauto.
            destruct released; try apply View.bot_spec. ss.
            inv STABLE_TVIEW1. eauto.
          * inv WF1. ss. inv TVIEW_WF. ss. etrans; eauto.
            eapply View.singleton_ur_spec; ss.
            inv NORMAL_TVIEW1. rewrite CUR0; ss. refl.
      - destruct tview; ss. f_equal; ss.
        + repeat rewrite View.le_join_l; ss.
          * eapply View.singleton_rw_spec; try apply WF1.
            inv NORMAL_TVIEW1. rewrite CUR; ss. refl.
          * destruct released; try apply View.bot_spec.
          * eapply View.singleton_rw_spec; try apply WF1.
            inv NORMAL_TVIEW1. rewrite CUR; ss. refl.
        + repeat rewrite View.le_join_l; ss.
          * inv WF1. ss. inv TVIEW_WF. ss. etrans; eauto.
            eapply View.singleton_rw_spec; ss.
            inv NORMAL_TVIEW1. rewrite CUR0; ss. refl.
          * inv WF1. ss. inv TVIEW_WF. ss. etrans; eauto.
            destruct released; try apply View.bot_spec.
          * inv WF1. ss. inv TVIEW_WF. ss. etrans; eauto.
            eapply View.singleton_rw_spec; ss.
            inv NORMAL_TVIEW1. rewrite CUR0; ss. refl.
    Qed.

    Lemma read_step_loc_ra
          rels lc1 mem1 loc to val released ord lc2
          (WF1: Local.wf lc1 mem1)
          (MEM1: Memory.closed mem1)
          (NORMAL_TVIEW1: normal_tview (Local.tview lc1))
          (NORMAL_MEM1: normal_memory mem1)
          (STABLE_TVIEW1: stable_tview mem1 (Local.tview lc1))
          (STABLE_MEM1: stable_memory rels mem1)
          (RELS_WF1: ReleaseWrites.wf rels (Local.promises lc1) mem1)
          (LOC: L loc)
          (REL: List.In (loc, to) rels)
          (ORD: Ordering.le Ordering.acqrel ord)
          (STEP: Local.read_step lc1 mem1 loc to val released ord lc2):
      <<NORMAL_TVIEW2: normal_tview (Local.tview lc2)>> /\
      <<STABLE_TVIEW2: stable_tview mem1 (Local.tview lc2)>> /\
      <<RELS_WF2: ReleaseWrites.wf rels (Local.promises lc2) mem1>>.
    Proof.
      inv STEP. ss. splits; ss.
      - inv NORMAL_TVIEW1. econs; ss.
        + repeat eapply join_normal_view; ss.
          { destruct ord; ss. }
          { condtac; ss. destruct released; ss; eauto. }
        + repeat eapply join_normal_view; ss.
          { destruct ord; ss. }
          { condtac; ss. destruct released; ss; eauto. }
      - 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)
          (NORMAL_TVIEW1: normal_tview (Local.tview lc1))
          (NORMAL_MEM1: normal_memory mem1)
          (STABLE_TVIEW1: stable_tview mem1 (Local.tview lc1))
          (STABLE_MEM1: stable_memory rels mem1)
          (RELS_WF1: ReleaseWrites.wf rels (Local.promises lc1) mem1)
          (LOC: ~ L loc)
          (STEP: Local.read_step lc1 mem1 loc to val released ord lc2):
      <<NORMAL_TVIEW2: normal_tview (Local.tview lc2)>> /\
      <<STABLE_TVIEW2: stable_tview mem1 (Local.tview lc2)>> /\
      <<RELS_WF2: ReleaseWrites.wf rels (Local.promises lc2) mem1>>.
    Proof.
      inv STEP. ss. splits; ss.
      - inv NORMAL_TVIEW1. econs; ss.
        + repeat apply join_normal_view; ss.
          * apply singleton_ur_if_normal_view. ss.
          * condtac; ss. destruct released; ss. eauto.
        + repeat apply join_normal_view; ss.
          * apply singleton_ur_if_normal_view. ss.
          * condtac; ss. destruct released; ss. eauto.
      - 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_step_loc
          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: ReleaseWrites.wf rels (Local.promises lc1) mem1)
          (NORMAL_TVIEW1: normal_tview (Local.tview lc1))
          (NORMAL_MEM1: normal_memory mem1)
          (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)
          (NORMAL_RELEASEDM: normal_view (View.unwrap releasedm))
          (RELEASEDM: View.le (View.unwrap releasedm) (TView.cur (Local.tview lc1)))
          (LOC: L loc)
          (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>> /\
      <<STABLE_TVIEW2: stable_tview mem2 (Local.tview lc2)>> /\
      <<STABLE_MEM2: stable_memory (if Ordering.le Ordering.acqrel ord then (loc, to) :: rels else rels) mem2>> /\
      <<RELS_WF2: ReleaseWrites.wf (if Ordering.le Ordering.acqrel ord then (loc, to) :: rels else rels)
                                   (Local.promises lc2) mem2>>.
    Proof.
      exploit Local.write_step_future; eauto. i. des.
      inv STEP. inv WRITE. ss.
      assert (NORMAL_TVIEW2: normal_tview (TView.write_tview (Local.tview lc1) sc1 loc to ord)).
      { inv NORMAL_TVIEW1.
        econs; ss; i; try by (apply join_normal_view; ss).
        unfold LocFun.add. condtac; eauto. subst.
        condtac; apply join_normal_view; ss. }
      assert (STABLE_TVIEW2: stable_tview mem2 (TView.write_tview (Local.tview lc1) sc1 loc to ord)).
      { inv STABLE_TVIEW1. econs; ss; i.
        - condtac; ss.
          { unfold LocFun.add, LocFun.find.
            condtac; ss; subst; ii; ss.
            inv WF1. inv TVIEW_WF. inv TVIEW_CLOSED.
            destruct (REL1 loc0). specialize (RLX loc1). des.
            exploit Memory.promise_get1; try exact RLX; eauto.
            { inv PROMISE; ss. }
            i. des.
            rewrite GET0 in *. inv GET. inv MSG_LE. inv RELEASED.
            etrans; eauto. eapply REL; eauto.
          }
          { unfold LocFun.add, LocFun.find.
            condtac; ss; subst; ii; ss.
            inv WF1. inv TVIEW_WF. inv TVIEW_CLOSED.
            destruct (REL1 loc0). specialize (RLX loc1). des.
            exploit Memory.promise_get1; try exact RLX; eauto.
            { inv PROMISE; ss. }
            i. des.
            rewrite GET0 in *. inv GET. inv MSG_LE. inv RELEASED.
            etrans; eauto. eapply REL; eauto.
          }
        - ii. revert GET. ss.
          unfold TimeMap.join, TimeMap.singleton, LocFun.add, LocFun.init, LocFun.find.
          condtac; ss; subst; i.
          + rewrite TimeFacts.le_join_r in GET; cycle 1.
            { inv WRITABLE. econs. ss. }
            exploit Memory.promise_get0; try exact PROMISE.
            { inv PROMISE; ss. }
            i. des.
            rewrite GET in *. inv GET_MEM.
            revert H2. unfold TView.write_released. condtac; ss.
            unfold LocFun.add. repeat condtac; ss.
            * i. inv H2.
              repeat eapply View.join_spec; eauto using View.join_l, View.join_r.
            * i. inv H2.
              repeat eapply View.join_spec; eauto using View.join_l, View.join_r.
              etrans; try eapply WF1. apply View.join_l.
          + rewrite TimeFacts.le_join_l in GET; try by apply Time.bot_spec.
            etrans; [|apply View.join_l].
            revert GET. inv PROMISE.
            { erewrite Memory.add_o; eauto. condtac; ss; i; eauto.
              des. subst. inv GET. ss. }
            { erewrite Memory.split_o; eauto. repeat condtac; ss; i; eauto.
              - des. subst. inv GET. ss.
              - guardH o. des. subst. inv GET. ss. }
            { erewrite Memory.lower_o; eauto. condtac; ss; i; eauto.
              des. subst. inv GET. ss. }
            { exploit Memory.remove_get0; try exact PROMISES. i. des.
              exploit Memory.remove_get0; try exact REMOVE. i. des.
              congr. }
        - ii.  revert GET. ss.
          unfold TimeMap.join, TimeMap.singleton, LocFun.add, LocFun.init, LocFun.find.
          condtac; ss; subst; i.
          + exploit Time.join_cases. i. des.
            * erewrite x0 in GET.
              inv WF1. inv TVIEW_CLOSED. inv ACQ0.
              destruct (RLX loc). des.
              exploit Memory.promise_get1; try exact H; eauto.
              { inv PROMISE; ss. }
              i. des.
              rewrite GET0 in *. inv GET. inv MSG_LE. inv RELEASED.
              etrans; eauto.
              etrans; [|apply View.join_l].
              eauto.
            * erewrite x0 in GET.
              exploit Memory.promise_get0; try exact PROMISE.
              { inv PROMISE; ss. }
              i. des.
              rewrite GET in *. inv GET_MEM.
              revert H2. unfold TView.write_released. condtac; ss.
              unfold LocFun.add. repeat condtac; ss.
              { i. inv H2.
                repeat eapply View.join_spec; try apply View.join_r.
                - etrans; eauto.
                  etrans; try eapply WF1. apply View.join_l.
                - etrans; try eapply WF1. apply View.join_l. }
              { i. inv H2.
                repeat eapply View.join_spec; try apply View.join_r.
                - etrans; eauto.
                  etrans; try eapply WF1. apply View.join_l.
                - etrans; try eapply WF1. etrans; try eapply WF1. apply View.join_l. }
          + rewrite TimeFacts.le_join_l in GET; try by apply Time.bot_spec.
            etrans; [|apply View.join_l].
            revert GET. inv PROMISE.
            { erewrite Memory.add_o; eauto. condtac; ss; i; eauto.
              des. subst. inv GET. ss. }
            { erewrite Memory.split_o; eauto. repeat condtac; ss; i; eauto.
              - des. subst. inv GET. ss.
              - guardH o. des. subst. inv GET. ss. }
            { erewrite Memory.lower_o; eauto. condtac; ss; i; eauto.
              des. subst. inv GET. ss. }
            { exploit Memory.remove_get0; try exact PROMISES. i. des.
              exploit Memory.remove_get0; try exact REMOVE. i. des.
              congr. }
      }

      assert (NORMAL_RELEASED: forall released,
                 TView.write_released (Local.tview lc1) sc1 loc to releasedm ord = Some released ->
                 normal_view released).
      { unfold TView.write_released. repeat (condtac; ss).
        unfold LocFun.add. condtac; ss.
        - i. inv H. repeat apply join_normal_view; ss. apply NORMAL_TVIEW1.
        - i. inv H. unfold LocFun.add. condtac; ss.
          repeat apply join_normal_view; ss. apply NORMAL_TVIEW1. }

      condtac; ss.
      { assert (RELEASED: TView.write_released (Local.tview lc1) sc1 loc to releasedm ord =
                          Some (View.join (View.singleton_ur loc to) (TView.cur (Local.tview lc1)))).
        { unfold TView.write_released. repeat (condtac; ss); cycle 1.
          { destruct ord; ss. }
          f_equal.
          unfold LocFun.add. condtac; ss.
          rewrite (View.join_comm (View.singleton_ur loc to)).
          apply View.antisym; cycle 1.
          { etrans; [|eapply View.join_r]. refl. }
          apply View.join_spec; try refl.
          etrans; [|eapply View.join_l]. ss.
        }
        assert (STABLE_RELEASED:
                  stable_view mem2 (View.join (View.singleton_ur loc to) (TView.cur (Local.tview lc1)))).
        { rewrite RELEASED in *. ii. revert GET. ss.
          unfold TimeMap.join, TimeMap.singleton, LocFun.add, LocFun.init, LocFun.find. condtac; ss.
          - subst. replace (Time.join to (View.rlx (TView.cur (Local.tview lc1)) loc)) with to; cycle 1.
            { rewrite TimeFacts.le_join_l; ss.
              inv WRITABLE. econs. ss. }
            exploit Memory.promise_get0; try exact PROMISE; try by (inv PROMISE; ss). i. des.
            rewrite GET_MEM in *. inv GET. refl.
          - rewrite TimeFacts.le_join_r; try by apply Time.bot_spec. i.
            inv WF1. inv TVIEW_CLOSED. inv CUR. specialize (RLX loc0). des.
            exploit Memory.promise_get1; try exact RLX; eauto; try by (inv PROMISE; ss). i. des.
            rewrite GET0 in *. inv GET. inv MSG_LE. inv RELEASED0.
            etrans; eauto. etrans; [|apply View.join_r].
            eapply STABLE_TVIEW1; eauto.
        }
        exploit promise; try exact PROMISE; try apply WF1; eauto.
        { i. inv MSG. rewrite RELEASED in *. inv H1. split; ss.
          apply join_normal_view.
          eauto using singleton_ur_normal_view.
          apply NORMAL_TVIEW1. }
        i. des. splits; auto.
        - ii. ss. des.
          + eapply STABLE_MEM2; eauto.
          + inv LOC0. exploit Memory.promise_get0; try exact PROMISE; try by (inv PROMISE; ss). i. des.
            rewrite GET in *. inv GET_MEM.
            rewrite RELEASED in *. inv H2.
            eapply STABLE_RELEASED; eauto.
          + eapply STABLE_MEM2; eauto.
        - ii. ss. des.
          + inv IN. exploit Memory.promise_get2; eauto; try by (inv PROMISE; ss). i. des.
            exploit Memory.remove_get0; eauto. i. des. eauto.
          + exploit RELS_WF1; eauto. i. des.
            exploit Memory.promise_get1; try exact x0; eauto; try by (inv PROMISE; ss). i. des.
            inv MSG_LE. esplits; eauto.
            erewrite Memory.remove_o; eauto. condtac; ss.
            guardH o. inv PROMISE; ss.
            * erewrite Memory.add_o; eauto. condtac; ss.
            * erewrite Memory.split_o; eauto. repeat condtac; ss.
              guardH o0. des. subst.
              exploit Memory.split_get0; try exact PROMISES. i. des. congr.
            * erewrite Memory.lower_o; eauto. condtac; ss.
      }

      splits; auto.
      - ii. revert GET. inv PROMISE; ss.
        + erewrite Memory.add_o; eauto. condtac; ss.
          * i. des. subst. inv GET.
            eapply NORMAL_RELEASED; eauto.
          * i. eapply NORMAL_MEM1; eauto.
        + erewrite Memory.split_o; eauto. repeat condtac; ss.
          * i. des. subst. inv GET.
            eapply NORMAL_RELEASED; eauto.
          * guardH o. des. subst. i. inv GET.
            exploit Memory.split_get0; try exact MEM. i. des.
            eapply NORMAL_MEM1; eauto.
          * i. eapply NORMAL_MEM1; eauto.
        + erewrite Memory.lower_o; eauto. condtac; ss.
          * i. des. subst. inv GET.
            eapply NORMAL_RELEASED; eauto.
          * i. eapply NORMAL_MEM1; eauto.
      - ii. guardH LOC0. revert GET. inv PROMISE; ss.
        + erewrite Memory.add_o; eauto. condtac; ss.
          * i. des. subst. inv GET. unguard. des; ss. subst.
            exploit RELS_WF1; eauto. i. des.
            exploit Memory.add_get0; try exact MEM. i. des. congr.
          * guardH o. i. inv MEM1. exploit CLOSED; eauto. i. des.
            inv MSG_CLOSED. inv CLOSED0. inv CLOSED1.
            specialize (RLX loc1). des.
            exploit Memory.add_get1; try exact RLX; eauto. i.
            rewrite x0 in *. inv GET0. eapply STABLE_MEM1; eauto.
        + erewrite Memory.split_o; eauto. repeat condtac; ss.
          * i. des. subst. inv GET. unguard. des; ss.
            exploit RELS_WF1; eauto. i. des.
            exploit Memory.split_get0; try exact MEM. i. des. congr.
          * guardH o. i. des. subst. inv GET.
            exploit Memory.split_get0; try exact MEM. i. des.
            inv MEM1. exploit CLOSED; try exact GET1. i. des.
            inv MSG_CLOSED. inv CLOSED0. inv CLOSED1.
            specialize (RLX loc1). des.
            exploit Memory.split_get1; try exact RLX; eauto. i. des.
            rewrite GET4 in *. inv GET0.
            eapply STABLE_MEM1; eauto.
          * guardH o. guardH o0. i.
            inv MEM1. exploit CLOSED; eauto. i. des.
            inv MSG_CLOSED. inv CLOSED0. inv CLOSED1.
            specialize (RLX loc1). des.
            exploit Memory.split_get1; try exact RLX; eauto. i. des.
            rewrite GET2 in *. inv GET0. eapply STABLE_MEM1; eauto.
        + erewrite Memory.lower_o; eauto. condtac; ss.
          * i. des. subst. inv GET. unguard. des; ss.
            exploit RELS_WF1; eauto. i. des.
            exploit Memory.lower_get0; try exact PROMISES. i. des. congr.
          * guardH o. i. inv MEM1. exploit CLOSED; eauto. i. des.
            inv MSG_CLOSED. inv CLOSED0. inv CLOSED1.
            specialize (RLX loc1). des.
            exploit Memory.lower_get1; try exact RLX; eauto. i. des. inv MSG_LE.
            rewrite GET2 in *. inv GET0. inv RELEASED.
            etrans; eauto. eapply STABLE_MEM1; eauto.
      - ii. ss. exploit RELS_WF1; eauto. i. des.
        exploit Memory.promise_get1; try exact x0; eauto; try by (inv PROMISE; ss). i. des.
        inv MSG_LE. esplits; eauto.
        erewrite Memory.remove_o; eauto. condtac; ss. guardH o.
        inv PROMISE; ss.
        + erewrite Memory.add_o; eauto. condtac; ss.
        + erewrite Memory.split_o; eauto. repeat condtac; ss.
          guardH o0. des. subst.
          exploit Memory.split_get0; try exact PROMISES. i. des. congr.
        + erewrite Memory.lower_o; eauto. condtac; ss.
    Qed.

    Lemma write_step_loc_None
          rels lc1 sc1 mem1 loc from to val released ord lc2 sc2 mem2 kind
          (WF1: Local.wf lc1 mem1)
          (SC1: Memory.closed_timemap sc1 mem1)
          (MEM1: Memory.closed mem1)
          (NORMAL_TVIEW1: normal_tview (Local.tview lc1))
          (NORMAL_MEM1: normal_memory mem1)
          (STABLE_TVIEW1: stable_tview mem1 (Local.tview lc1))
          (STABLE_MEM1: stable_memory rels mem1)
          (RELS_WF1: ReleaseWrites.wf rels (Local.promises lc1) mem1)
          (LOC: L loc)
          (STEP: Local.write_step lc1 sc1 mem1 loc from to val None released ord lc2 sc2 mem2 kind):
      <<NORMAL_TVIEW2: normal_tview (Local.tview lc2)>> /\
      <<NORMAL_MEM2: normal_memory mem2>> /\
      <<STABLE_TVIEW2: stable_tview mem2 (Local.tview lc2)>> /\
      <<STABLE_MEM2: stable_memory (if Ordering.le Ordering.acqrel ord then (loc, to) :: rels else rels) mem2>> /\
      <<RELS_WF2: ReleaseWrites.wf (if Ordering.le Ordering.acqrel ord then (loc, to) :: rels else rels)
                                   (Local.promises lc2) mem2>>.
    Proof.
      eapply write_step_loc; eauto; ss.
      - apply View.bot_spec.
    Qed.

    Lemma write_step_other
          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)
          (NORMAL_TVIEW1: normal_tview (Local.tview lc1))
          (NORMAL_MEM1: normal_memory mem1)
          (STABLE_TVIEW1: stable_tview mem1 (Local.tview lc1))
          (STABLE_MEM1: stable_memory rels mem1)
          (RELS_WF1: ReleaseWrites.wf rels (Local.promises lc1) mem1)
          (LOC: ~ L loc)
          (WF_RELEASEDM: View.opt_wf releasedm)
          (CLOSED_RELEASEDM: Memory.closed_opt_view releasedm mem1)
          (NORMAL_RELEASEDM: normal_view (View.unwrap releasedm))
          (STABLE_RELEASEDM: stable_view mem1 (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>> /\
      <<STABLE_TVIEW2: stable_tview mem2 (Local.tview lc2)>> /\
      <<STABLE_MEM2: stable_memory rels mem2>> /\
      <<RELS_WF2: ReleaseWrites.wf rels (Local.promises lc2) mem2>>.
    Proof.
      exploit Local.write_step_future; eauto. i. des.
      inv STEP. inv WRITE. ss.
      assert (NORMAL_TVIEW2: normal_tview (TView.write_tview (Local.tview lc1) sc1 loc to ord)).
      { inv NORMAL_TVIEW1.
        econs; ss; i; try by (apply join_normal_view; ss).
        unfold LocFun.add. condtac; eauto. subst.
        condtac; apply join_normal_view; ss. }
      assert (STABLE_TVIEW2: stable_tview mem2 (TView.write_tview (Local.tview lc1) sc1 loc to ord)).
      { inv STABLE_TVIEW1. econs; ss; i.
        { condtac; ss.
          - unfold LocFun.add, LocFun.find.
            condtac; ss; subst; ii; ss.
            + revert GET.
              unfold TimeMap.join, TimeMap.singleton, LocFun.add, LocFun.init, LocFun.find.
              condtac; ss; i.
              * subst. congr.
              * rewrite TimeFacts.le_join_l in GET; try by apply Time.bot_spec.
                etrans; [|eapply View.join_l].
                revert GET. inv PROMISE.
                { erewrite Memory.add_o; eauto. condtac; ss; i; eauto.
                  des. subst. inv GET. ss. }
                { erewrite Memory.split_o; eauto. repeat condtac; ss; i; eauto.
                  - des. subst. inv GET. ss.
                  - guardH o. des. subst. inv GET. ss. }
                { erewrite Memory.lower_o; eauto. condtac; ss; i; eauto.
                  des. subst. inv GET. ss. }
                { exploit Memory.remove_get0; try exact PROMISES. i. des.
                  exploit Memory.remove_get0; try exact REMOVE. i. des.
                  congr. }
            + inv WF1. inv TVIEW_WF. inv TVIEW_CLOSED.
              destruct (REL1 loc0). specialize (RLX loc1). des.
              exploit Memory.promise_get1; try exact RLX; eauto.
              { inv PROMISE; ss. }
              i. des.
              rewrite GET0 in *. inv GET. inv MSG_LE. inv RELEASED.
              etrans; eauto. eapply REL; eauto.
          - unfold LocFun.add, LocFun.find.
            condtac; ss; subst; ii; ss.
            + revert GET.
              unfold TimeMap.join, TimeMap.singleton, LocFun.add, LocFun.init, LocFun.find.
              condtac; ss; i.
              * subst. congr.
              * rewrite TimeFacts.le_join_l in GET; try by apply Time.bot_spec.
                etrans; [|eapply View.join_l].
                revert GET. inv PROMISE.
                { erewrite Memory.add_o; eauto. condtac; ss; i.
                  - des. subst. inv GET. ss.
                  - eapply REL; eauto. }
                { erewrite Memory.split_o; eauto. repeat condtac; ss; i; eauto.
                  - des. subst. inv GET. ss.
                  - guardH o. des. subst. inv GET. ss.
                  - eapply REL; eauto. }
                { erewrite Memory.lower_o; eauto. condtac; ss; i.
                  - des. subst. inv GET. ss.
                  - eapply REL; eauto. }
                { exploit Memory.remove_get0; try exact PROMISES. i. des.
                  exploit Memory.remove_get0; try exact REMOVE. i. des.
                  congr. }
            + inv WF1. inv TVIEW_WF. inv TVIEW_CLOSED.
              destruct (REL1 loc0). specialize (RLX loc1). des.
              exploit Memory.promise_get1; try exact RLX; eauto.
              { inv PROMISE; ss. }
              i. des.
              rewrite GET0 in *. inv GET. inv MSG_LE. inv RELEASED.
              etrans; eauto. eapply REL; eauto.
        }
        { ii. revert GET. ss.
          unfold TimeMap.join, TimeMap.singleton, LocFun.add, LocFun.init, LocFun.find.
          condtac; ss; subst; i; try congr.
          rewrite TimeFacts.le_join_l in GET; try by apply Time.bot_spec.
          etrans; [|apply View.join_l].
          revert GET. inv PROMISE.
          { erewrite Memory.add_o; eauto. condtac; ss; i; eauto.
            des. subst. inv GET. ss. }
          { erewrite Memory.split_o; eauto. repeat condtac; ss; i; eauto.
            - des. subst. inv GET. ss.
            - guardH o. des. subst. inv GET. ss. }
          { erewrite Memory.lower_o; eauto. condtac; ss; i; eauto.
            des. subst. inv GET. ss. }
          { exploit Memory.remove_get0; try exact PROMISES. i. des.
            exploit Memory.remove_get0; try exact REMOVE. i. des.
            congr. }
        }
        { ii.  revert GET. ss.
          unfold TimeMap.join, TimeMap.singleton, LocFun.add, LocFun.init, LocFun.find.
          condtac; ss; subst; i; try congr.
          rewrite TimeFacts.le_join_l in GET; try by apply Time.bot_spec.
          etrans; [|apply View.join_l].
          revert GET. inv PROMISE.
          { erewrite Memory.add_o; eauto. condtac; ss; i; eauto.
            des. subst. inv GET. ss. }
          { erewrite Memory.split_o; eauto. repeat condtac; ss; i; eauto.
            - des. subst. inv GET. ss.
            - guardH o. des. subst. inv GET. ss. }
          { erewrite Memory.lower_o; eauto. condtac; ss; i; eauto.
            des. subst. inv GET. ss. }
          { exploit Memory.remove_get0; try exact PROMISES. i. des.
            exploit Memory.remove_get0; try exact REMOVE. i. des.
            congr. }
        }
      }

      exploit promise; try exact PROMISE; try apply WF1; eauto.
      { unfold TView.write_released. repeat (condtac; ss).
        - unfold LocFun.add. condtac; ss.
          i. inv MSG. split.
          + repeat apply join_normal_view; ss. apply NORMAL_TVIEW1.
          + ii. revert GET.
            destruct (Loc.eq_dec loc loc0); subst; try congr.
            ss. unfold TimeMap.join, TimeMap.singleton, LocFun.add, LocFun.init, LocFun.find.
            condtac; ss; try congr.
            rewrite (@TimeFacts.le_join_l _ Time.bot); try by apply Time.bot_spec. i.
            rewrite <- View.join_assoc.
            etrans; [|apply View.join_l].
            eapply future_stable_view; try eapply GET; try eapply join_stable_view; eauto.
            * eapply Memory.join_closed_view; ss.
              { inv CLOSED_RELEASEDM; ss.
                apply Memory.closed_view_bot. apply MEM1. }
              { apply WF1. }
            * apply STABLE_TVIEW1.
        - unfold LocFun.add. condtac; ss.
          i. inv MSG. split.
          + repeat apply join_normal_view; ss. apply NORMAL_TVIEW1.
          + ii. revert GET.
            destruct (Loc.eq_dec loc loc0); subst; try congr.
            ss. unfold TimeMap.join, TimeMap.singleton, LocFun.add, LocFun.init, LocFun.find.
            condtac; ss; try congr.
            rewrite (@TimeFacts.le_join_l _ Time.bot); try by apply Time.bot_spec. i.
            rewrite <- View.join_assoc.
            etrans; [|apply View.join_l].
            eapply future_stable_view; try eapply GET; try eapply join_stable_view; eauto.
            * eapply Memory.join_closed_view; ss.
              { inv CLOSED_RELEASEDM; ss.
                apply Memory.closed_view_bot. apply MEM1. }
              { apply WF1. }
            * apply STABLE_TVIEW1. ss.
      }

      i. des. splits; auto.
      ii. exploit RELS_WF1; eauto. i. des.
      exploit Memory.promise_get1; try exact x0; eauto; try by (inv PROMISE; ss). i. des. inv MSG_LE.
      esplits; eauto. s.
      erewrite Memory.remove_o; eauto. condtac; ss. guardH o.
      inv PROMISE; ss.
      - erewrite Memory.add_o; eauto. condtac; ss.
      - erewrite Memory.split_o; eauto. repeat condtac; ss.
        guardH o0. des. subst.
        exploit Memory.split_get0; try exact PROMISES. i. des. congr.
      - erewrite Memory.lower_o; eauto. condtac; ss.
    Qed.

    Lemma write_step_other_None
          rels lc1 sc1 mem1 loc from to val released ord lc2 sc2 mem2 kind
          (WF1: Local.wf lc1 mem1)
          (SC1: Memory.closed_timemap sc1 mem1)
          (MEM1: Memory.closed mem1)
          (NORMAL_TVIEW1: normal_tview (Local.tview lc1))
          (NORMAL_MEM1: normal_memory mem1)
          (STABLE_TVIEW1: stable_tview mem1 (Local.tview lc1))
          (STABLE_MEM1: stable_memory rels mem1)
          (RELS_WF1: ReleaseWrites.wf rels (Local.promises lc1) mem1)
          (LOC: ~ L loc)
          (STEP: Local.write_step lc1 sc1 mem1 loc from to val None released ord lc2 sc2 mem2 kind):
      <<NORMAL_TVIEW2: normal_tview (Local.tview lc2)>> /\
      <<NORMAL_MEM2: normal_memory mem2>> /\
      <<STABLE_TVIEW2: stable_tview mem2 (Local.tview lc2)>> /\
      <<STABLE_MEM2: stable_memory rels mem2>> /\
      <<RELS_WF2: ReleaseWrites.wf rels (Local.promises lc2) mem2>>.
    Proof.
      eapply write_step_other; eauto; ss.
      apply bot_stable_view. apply MEM1.
    Qed.

    Lemma fence_step
          rels lc1 sc1 mem1 ordr ordw lc2 sc2
          (WF1: Local.wf lc1 mem1)
          (NORMAL_TVIEW1: normal_tview (Local.tview lc1))
          (STABLE_TVIEW1: stable_tview mem1 (Local.tview lc1))
          (STABLE_SC1: stable_timemap mem1 sc1)
          (RELS_WF1: ReleaseWrites.wf rels (Local.promises lc1) mem1)
          (STEP: Local.fence_step lc1 sc1 ordr ordw lc2 sc2):
      <<NORMAL_TVIEW2: normal_tview (Local.tview lc2)>> /\
      <<STABLE_TVIEW2: stable_tview mem1 (Local.tview lc2)>> /\
      <<STABLE_SC2: stable_timemap mem1 sc2>> /\
      <<RELS_WF2: ReleaseWrites.wf rels (Local.promises lc2) mem1>>.
    Proof.
      inv STEP. ss. splits; ss.
      - inv NORMAL_TVIEW1.
        econs; ss; i; repeat (condtac; ss).
        + apply join_normal_view; ss.
        + apply join_normal_view; 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_memory mem1):
      normal_memory 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.


Require Import Coq.Strings.String.
Require Import Coq.Strings.Ascii.
Require Import Coq.NArith.BinNat.
Require Import Coq.Arith.Compare.
Require Import Coq.Logic.JMeq.
Require Import Coq.Program.Equality.
Require Import ZArith.
Require Import Coq.Logic.Eqdep_dec.

Require Import Helpers.

Open Scope string_scope.
Open Scope N_scope.

Inductive error : Set :=
| NotDefined : error
| NotFound : error
| AccessViolation : error
| DiskFull : error
| IllegalOP : error
| UnknownTID : error
| FileExists : error
| NoSuchUser : error
.

Definition error_code (e : error) : N :=
  match e with
  | NotDefined => 0
  | NotFound => 1
  | AccessViolation => 2
  | DiskFull => 3
  | IllegalOP => 4
  | UnknownTID => 5
  | FileExists => 6
  | NoSuchUser => 7
  end.

Definition error_from_code (n : N) : (option error):=
  match n with
  | 0 => Some NotDefined
  | 1 => Some NotFound
  | 2 => Some AccessViolation
  | 3 => Some DiskFull
  | 4 => Some IllegalOP
  | 5 => Some UnknownTID
  | 6 => Some FileExists
  | 7 => Some NoSuchUser
  | _ => None
  end.

Fact error_code_range : forall (E : error), error_code(E) <= 7 /\ error_code(E) >= 0.
Proof.
  intros.
  destruct E; simpl; zify; omega.
Qed.

Theorem error_code_embedding : forall (e : error), error_from_code (error_code e) = Some e.
Proof.
  destruct e; trivial.
Qed.

Theorem code_error_embedding : forall (n : N),
    option_prop (fun e => error_code e = n) (error_from_code n).
Proof.
  destruct n; simpl; auto.
  do 3 (destruct p; simpl; auto).
Qed.

Inductive packet : sender -> mode -> Set :=
| RRQ : string -> packet Client Read
| WRQ : string -> packet Client Write
| DATA : forall (s : sender),
    N16 -> string -> packet s ( match s with
                              | Server => Read
                              | Client => Write
                              end )
| ACK : forall (s : sender),
    N16 -> packet s ( match s with
                     | Server => Write
                     | Client => Read
                     end )
| ERROR : forall (s:sender) (m:mode),
    error -> string -> packet s m
.

Definition opcode {s:sender} {m : mode} (p : packet s m) : N :=
  match p with
  | RRQ _ => 1
  | WRQ _ => 2
  | DATA _ _ _ => 3
  | ACK _ _ => 4
  | ERROR _ _ _ _ => 5
  end.

Fact opcode_range : forall (s : sender) (m : mode) (P : packet s m), opcode P <= 5 /\ opcode P >= 1.
Proof.
  intros.
  destruct P; simpl; zify; omega.
Qed.

Definition serialize_opcode {m : mode} (p : packet Client m) : string -> string :=
  fun s => String zero (String (ascii_of_N (opcode p)) s).

Fixpoint string_append (s1 : string) (s2 : string) : string :=
  match s1 with
  | EmptyString => s2
  | String c rest => String c (string_append rest s2)
  end.

Local Open Scope nat_scope.
Theorem string_append_length : forall (s1 : string) (s2 : string),
    String.length (string_append s1 s2) = String.length s1 + String.length s2.
Proof.
  intros.
  induction s1; simpl; auto.
Qed.
Local Close Scope nat_scope.

Theorem string_append_empty : forall (s : string), string_append s EmptyString = s.
Proof.
  intros.
  induction s.
  * trivial.
  * simpl.
    rewrite IHs.
    trivial.
Qed.

Definition serialize_string (ss : string) : string -> string :=
  fun s => string_append ss (String zero s).

Theorem extended_serialize_string : forall (c : ascii) (s : string),
    serialize_string (String c s) "" = String c (serialize_string s "").
  intros. induction s; trivial.
Qed.

Definition serialize_N16 (n : N16) : string -> string :=
  fun s => String (ascii_of_N (N16_to_N n / 256)) (String (ascii_of_N (N16_to_N n)) s).

Definition serialize_packet {m : mode} (p : packet Client m) : string :=
  serialize_opcode p
                   match p with
                   | RRQ file => serialize_string file (serialize_string "octet" "")
                   | WRQ file => serialize_string file (serialize_string "octet" "")
                   | DATA Client block data =>
                     serialize_N16 block data
                   | ACK Client block => serialize_N16 block (String zero "")
                   | ERROR Client _ code msg =>
                     String zero (String (ascii_of_N (error_code code)) (serialize_string msg ""))
                   end.

Definition deserializer (a : Set): Set := string -> (option a * string).

Definition bind_deserializer {a : Set} {b : Set}
           (ds : deserializer a) (cont : a -> deserializer b) : deserializer b :=
  fun s => match ds s with
        | (Some res, ss) => cont res ss
        | (None, ss) => (None, ss)
        end.
Notation "A >>= R ~> B" :=
  (bind_deserializer A (fun R => B)) (at level 80, right associativity).

Definition deserializer_fail {a : Set} : deserializer a := fun s => (None, s).

Definition deserializer_success {a : Set} : a -> deserializer a := fun x s => (Some x, s).

Definition finalize_deserializer {a : Set} (d : deserializer a) : deserializer a :=
  fun s => match d s with
        | (x, EmptyString) => (x, EmptyString)
        | (_, rest) => (None, rest)
        end.

Definition run_deserializer {a : Set} (s : string) (d : deserializer a): option a :=
  match d s with
  | (x, _) => x
  end.

Definition deserializer_ascii : deserializer ascii :=
  fun s => match s with
        | EmptyString => (None, s)
        | String c rest => (Some c, rest)
end.

Lemma N_of_ascii_range : forall (a : ascii), N_of_ascii a < 256.
Proof.
  destruct a as [[|][|][|][|][|][|][|][|]].
  all: simpl; zify; omega.
Qed.

Definition deserialize_N8 : deserializer N8 :=
 fun s => match s with
       | EmptyString => (None, s)
       | String c rest => (Some (exist _ (N_of_ascii c) (N_of_ascii_range c)), rest)
       end.

Definition deserialize_N16 : deserializer N16 :=
  deserialize_N8 >>= a ~> deserialize_N8 >>= b ~> deserializer_success (N16_of_two_N8 a b).

Fixpoint deserialize_data (s : string) : (option string * string) :=
  match s with
  | String c rest => match deserialize_data rest with
                    | (otail, finito) => (
                        match otail with
                        | None => None
                        | Some tail => Some (String c tail) end, finito)
                    end
  | _ => (Some EmptyString, EmptyString)
  end.

Fixpoint deserialize_string (s : string) : (option string * string) :=
  match s with
  | EmptyString => (None, s)
  | String "000" rest => (Some EmptyString, rest)
  | String c rest => match deserialize_string rest with
                    | (otail, finito) => (
                        match otail with
                        | None => None
                        | Some tail => Some (String c tail) end, finito)
                    end
  end.

Definition deserialize_packet {m : mode} : deserializer (packet Server m) :=
  let chuj m x := deserializer_success (ERROR Server m NotDefined x) in
  deserialize_N16 >>= op ~>
                  match N16_to_N op with
                  | 3 => match m with
                        | Read => deserialize_N16 >>= block ~> deserialize_data >>= data ~>
                                                 deserializer_success (DATA Server block data)
                        | Write => deserializer_fail
                        end
                  | 4 => match m with
                        | Write => deserialize_N16 >>= block ~>
                                                  deserializer_success (ACK Server block)
                        | Read => deserializer_fail
                        end
                  | 5 => deserialize_N16 >>= err ~> finalize_deserializer deserialize_string >>= msg ~>
                                        match error_from_code (N16_to_N err) with
                                        | Some type => deserializer_success (ERROR Server m type msg)
                                        | _ => deserializer_fail
                                        end
                  | _ => deserializer_fail
                  end.

Theorem embedding_opcode : forall (m : mode) (p : packet Client m),
    run_deserializer (serialize_opcode p "") (finalize_deserializer deserialize_N16) =
    N_to_N16 (opcode p).
Proof.
  intros.
  destruct m.
  all: (dependent destruction p;
       unfold serialize_opcode;
       unfold run_deserializer;
       unfold finalize_deserializer;
       unfold deserialize_N16;
       unfold N_to_N16;
       unfold N16_of_two_N8;
       simpl;
       apply f_equal;
       apply f_equal;
       apply UIP_dec;
       intros;
       destruct x;
       destruct y;
       intuition;
       right;
       discriminate).
Qed.


Require Import Coq.Init.Byte List.
Import ListNotations.

From Minirust.def Require Import ty encoding thm wf.
From Minirust.proof Require Import defs lemma.le.

Section bool.

Context {memory: Memory}.

Inductive BoolCases1 : list AbstractByte -> Type :=
  | BC1True (p: option P) : BoolCases1 [Init x01 p]
  | BC1False (p: option P) : BoolCases1 [Init x00 p]
  | BC1Invalid (l: list AbstractByte) (H: decode TBool l = None) : BoolCases1 l.

Lemma mk_bool_cases1 (l: list AbstractByte) : BoolCases1 l.
Proof.
destruct l.
- apply BC1Invalid. auto.
- destruct l.
-- destruct a.
--- apply BC1Invalid. auto.
--- destruct b; try (apply BC1Invalid; reflexivity).
---- apply BC1False.
---- apply BC1True.
-- apply BC1Invalid. simpl.
   destruct a.
--- reflexivity.
--- destruct b; reflexivity.
Qed.

Lemma valid_bool (v: Value) : is_valid_for TBool v -> exists b, v = VBool b.
Proof.
unfold is_valid_for.
unfold decode.
unfold decode_bool.
intros Hl.
destruct Hl as [l].
destruct (mk_bool_cases1 l).
- inversion H. exists true. reflexivity.
- inversion H. exists false. reflexivity.
- unfold decode in H0.
  unfold decode_bool in H0.
  rewrite H in H0. discriminate H0.
Qed.

Lemma bool_mono1 : mono1 TBool.
Proof.
unfold mono1.
intros v1 v2 HLe valid1 valid2.
destruct (valid_bool v1 valid1) as [b1 H1].
destruct (valid_bool v2 valid2) as [b2 H2].
rewrite H1,H2 in HLe. simpl in HLe.
rewrite <- HLe in H2.
rewrite H1,H2.
destruct b1.
- do 2 exists [Init x01 None]. simpl. split; auto.
- do 2 exists [Init x00 None]. simpl. split; auto.
Qed.

Lemma bool_mono2 : mono2 TBool.
Proof.
unfold mono2.
intros l1 l2 HLe.
destruct (mk_le_list _ _ HLe).
- auto.
- destruct l.
-- destruct l0.
--- simpl. auto.
--- destruct x; simpl; auto.
--- destruct x; simpl; auto.
-- unfold decode.
   unfold decode_bool.
   destruct b1;
   destruct b2;
   simpl;
   auto;
   destruct b;
   auto.
Qed.

Lemma bool_rt1 : rt1 TBool.
Proof.
unfold rt1.
intros v valid.
destruct (valid_bool v valid) as [b H].
rewrite H. clear H valid v.
destruct b.
- exists [Init x01 None]. auto.
- exists [Init x00 None]. auto.
Qed.

Lemma bool_rt2 : rt2 TBool.
Proof.
unfold rt2.
intros l v H.
destruct (mk_bool_cases1 l).
- inversion H. clear v H H1.
  exists [Init x01 None]. simpl. split; reflexivity || auto.
- inversion H. clear v H H1.
  exists [Init x00 None]. simpl. split; reflexivity || auto.
- rewrite H in H0. discriminate H0.
Qed.

Lemma bool_encode_len : encode_len TBool.
intros v l Henc.
destruct v; try inversion Henc.
destruct b; inversion Henc; auto.
Qed.

Lemma bool_props (Hwf: wf TBool) : Props TBool.
Proof.
split.
- auto.
- apply bool_rt1.
- apply bool_rt2.
- apply bool_mono1.
- apply bool_mono2.
- apply bool_encode_len.
Qed.

End bool.


Require Import Coq.Strings.String.
Require Import ExtLib.Structures.Applicative.
Require Import ExtLib.Data.Fun.
Require Import Charge.Logics.ILogic.
Require Import Charge.Logics.BILogic.
Require Import Charge.Logics.ILEmbed.
Require Import Charge.Logics.ILInsts.
Require Import Charge.Logics.BILInsts.

Set Implicit Arguments.
Set Strict Implicit.

Definition var := string.
Definition value := nat.

Parameter iexpr : Type.
Parameter iConst : value -> iexpr.
Parameter iVar : var -> iexpr.
Parameter iPlus : iexpr -> iexpr -> iexpr.
Parameter iEq : iexpr -> iexpr -> iexpr.
Parameter iLt : iexpr -> iexpr -> iexpr.

Parameter icmd : Type.

Parameter locals : Type.
Parameter locals_upd : var -> value -> locals -> locals.
Parameter locals_get : var -> locals -> value.
Parameter HProp : Type.
Parameter SProp : Type.
Instance ILogicOps_HProp : ILogicOps HProp. Admitted.
Instance ILogic_HProp : ILogic HProp. Admitted.
Instance BILogicOps_HProp : BILOperators HProp. Admitted.
Instance ILogicOps_SProp : ILogicOps SProp. Admitted.
Instance ILogic_SProp : ILogic SProp. Admitted.
Instance BILogicOps_SProp : BILOperators SProp. Admitted.

Definition lprop := locals -> HProp.

Local Instance Applicative_Fun A : Applicative (Fun A) :=
{ pure := fun _ x _ => x
; ap := fun _ _ f x y => (f y) (x y)
}.

Local Instance ILogicOps_lprop : ILogicOps lprop :=
  @ILFun_Ops locals HProp _.
Local Instance ILogic_lprop : ILogic lprop. Admitted.
Local Instance BILOps : BILOperators lprop :=
  @BILFun_Ops _ _ _.
Local Instance BILogic : BILogic lprop. Admitted.
Local Instance EmbedOp_Prop_HProp : EmbedOp Prop HProp. Admitted.
Local Instance Embed_Prop_HProp : Embed Prop HProp. Admitted.
Local Instance EmbedOp_HProp_lprop : EmbedOp HProp lprop :=
  @EmbedILFunDropOp HProp _ (@EmbedOpId _) _.
Local Instance Embed_HProp_lprop : Embed HProp lprop. Admitted.
Local Instance EmbedOp_Prop_SProp : EmbedOp Prop SProp. Admitted.
Local Instance Embed_Prop_SProp : Embed Prop SProp. Admitted.

Parameter eval_iexpr : iexpr -> locals -> value.

Parameter triple : lprop -> icmd -> lprop -> SProp.

(** Quantifier Rules **)
Axiom triple_exL
: forall G P c Q,
    (G |-- Forall x : value, triple (P x) c Q) ->
    G |-- triple (Exists x : value, P x) c Q.

Axiom triple_pureL
: forall (P : Prop) G c Q R,
    (G //\\ embed P |-- triple Q c R) ->
    G |-- triple (land (embed (embed P)) Q) c R.

(** Skip **)
Parameter Skip : icmd.

Axiom Skip_rule
: forall G P Q,
    G |-- embed (P |-- Q) ->
    G |-- triple P Skip Q.

(** Sequence **)
Parameter Seq : icmd -> icmd -> icmd.

Axiom Seq_rule
: forall G P Q R c1 c2,
    G |-- triple P c1 Q ->
    G |-- triple Q c2 R ->
    G |-- triple P (Seq c1 c2) R.

Axiom SeqA_rule
: forall G P Q c1 c2 c3,
    G |-- triple P (Seq c1 (Seq c2 c3)) Q ->
    G |-- triple P (Seq (Seq c1 c2) c3) Q.

(** Assignment **)
Parameter Assign : var -> iexpr -> icmd.

Axiom Assign_rule
: forall G P x e,
    G |-- triple P
                 (Assign x e)
                 (fun l => Exists v' : value,
                             embed (locals_get x l = eval_iexpr e l)
                       //\\  P  (locals_upd x v' l)).

(** Read **)
Parameter Read : var -> iexpr -> icmd.

Parameter PtsTo : value -> value -> HProp.

Axiom Read_rule
: forall G (P : lprop) x e (v : locals -> value),
    (G |-- embed (P |-- ap (T := Fun locals) (ap (pure PtsTo) (eval_iexpr e)) v ** ltrue)) ->
    G |-- triple P
                 (Read x e)
                 (fun l =>
                    Exists v' : value,
                          embed (locals_get x l = v (locals_upd x v' l))
                    //\\  P (locals_upd x v' l)).

(** Write **)
Parameter Write : iexpr -> iexpr -> icmd.

Axiom Write_rule
: forall G (P Q : lprop) p v,
    (P |-- Exists v', ap (T := Fun locals) (ap (pure PtsTo) (eval_iexpr p)) (pure v') ** Q) ->
    G |-- triple P
           (Write p v)
           (ap (T := Fun locals) (ap (pure PtsTo) (eval_iexpr p)) (eval_iexpr v) ** Q).

(** If **)
Parameter If : iexpr -> icmd -> icmd -> icmd.

Definition local_Prop_lprop (P : Fun locals Prop) : lprop :=
  fun l => embed (P l).

Definition exprProp (P : value -> Prop) (e : locals -> value) : lprop :=
  local_Prop_lprop (fun l => P (e l)).

Axiom If_rule
: forall G (P Q : lprop) x c1 c2,
    G |-- triple (P //\\ exprProp (fun v => v <> 0) (eval_iexpr x)) c1 Q ->
    G |-- triple (P //\\ exprProp (fun v => v = 0) (eval_iexpr x)) c2 Q ->
    G |-- triple P (If x c1 c2) Q.

(** While **)
Parameter While : iexpr -> icmd -> icmd.

Axiom While_rule
: forall G (P Q I : lprop) t c,
    G |-- embed (P |-- I) ->
    G |-- triple (I //\\ exprProp (fun v => v <> 0) (eval_iexpr t)) c I ->
    G |-- embed (I //\\ exprProp (fun v => v = 0) (eval_iexpr t) |-- Q) ->
    G |-- triple P (While t c) Q.

(** Function Calls **)

Definition function_name := string.

Parameter Call : function_name -> iexpr -> icmd.

Axiom function_spec : function_name -> (nat -> lprop) -> (nat -> lprop) -> SProp.

Axiom Call_rule
: forall G (P Q : lprop) (P' Q' : nat -> lprop) F f e v,
    G |-- embed (P |-- ap (T := Fun locals) (ap (pure PtsTo) (eval_iexpr e)) v ** ltrue) ->
    G |-- function_spec f P' Q' -> (** Get the method spec **)
    G |-- embed (P |-- ap (T := Fun locals) (fun l v => P' v l) v ** F) -> (* P |- P' ** F *)
    G |-- embed (ap (T := Fun locals) (fun l v => Q' v l) v ** F |-- Q) -> (* Q' ** F |- Q *)
    G |-- triple P
                 (Call f e)
                 Q.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

Theorem pipo_6 : (forall A B C P Q I : Universe, ((wd_ I B /\ (wd_ B A /\ (wd_ I A /\ (wd_ P Q /\ (wd_ A B /\ (wd_ A C /\ (wd_ B C /\ (wd_ A P /\ (wd_ A Q /\ (wd_ B P /\ (wd_ B Q /\ (wd_ C P /\ (wd_ C Q /\ (wd_ C I /\ (col_ I B A /\ (col_ A B I /\ col_ A C I)))))))))))))))) -> col_ A B C)).
Proof.
  time tac.
Qed.

End FOFProblem.


Set Warnings "-notation-overridden".

Require Import Coq.Program.Basics.
Require Import Coq.Lists.List.
Require Import Coq.Logic.Eqdep_dec.

From Equations Require Import Equations.
Unset Equations With Funext.

Require Import Category.Lib.
Require Import Category.Theory.

(* Not main module *)
Require Import Category.Instance.Coq.

Require Import Embed.Theory.Btree.
Require Import Embed.Theory.Btree.Functor.
Require Import Embed.Theory.Btree.Monad.
Require Import Embed.Theory.Btree.Leaves.
Require Import Embed.Theory.Btree.Zip.
Require Import Embed.Theory.Btree.Lattice.

Require Import Embed.Theory.Bforest.Zip.
Require Import Embed.Theory.Bforest.Is.
Require Import Embed.Theory.Bforest.

Require Import Embed.Theory.Utils.
Require Import Embed.Theory.Datatypes.List.

Generalizable All Variables.
Set Universe Polymorphism.
Set Nested Proofs Allowed.

Definition ble {A : Type} (x : @btree 1) (y : @btree A) : Type :=
  { xy : @bforest A (num_leaves x) (num_leaves y)
  | run_bforest x xy = y
  }.

Lemma eq_ble {A : Type} {eqDecA : EqDec A} (x : @btree 1) (y : @btree A)
  (xs : ble x y)
  (ys : ble x y)
  (pfx : proj1_sig xs = proj1_sig ys) :
    xs = ys.
destruct xs, ys.
refine (eq_sig
  (exist (λ xy : bforest (num_leaves x) (num_leaves y), run_bforest x xy = y) x0 e)
  (exist (λ xy : bforest (num_leaves x) (num_leaves y), run_bforest x xy = y) x1 e0)
  pfx
  _
).
simpl in *.
destruct pfx.
simpl.
exact (UIP_dec dec_eq_btree _ _).
Qed.

Equations ble_id (x : @btree 1) : ble x x :=
ble_id x :=
  @exist _ _
    (id_bforest tt (num_leaves x))
    (run_bforest_id x).

Equations trans_ble {x y z : @btree 1} (xy : ble x y) (yz : ble y z) : ble x z :=
trans_ble (@exist _ _ xs pfx) (@exist _ _ ys pfy) :=
  @exist _ _ (trans_bforest xs ys) (run_bforest_trans xs pfx ys pfy).

Program Instance BextensionC : Category := {
  obj     := @btree 1 ;

  hom     := ble ;

  homset  := fun _ _ => {| equiv := eq |} ;

  id      := ble_id ;

  compose := fun _ _ _ => Basics.flip trans_ble
}.
Next Obligation.
destruct f.
rewrite ble_id_equation_1.
unfold Basics.flip.
rewrite trans_ble_equation_1.
refine (eq_ble _ _ _ _ _).
simpl.
exact (id_left _).
Qed.

Next Obligation.
destruct f.
rewrite ble_id_equation_1.
unfold Basics.flip.
rewrite trans_ble_equation_1.
refine (eq_ble _ _ _ _ _).
simpl.
exact (id_right _).
Qed.

Next Obligation.
destruct f, g, h.
unfold Basics.flip.
repeat (rewrite trans_ble_equation_1).
refine (eq_ble _ _ _ _ _).
simpl.
exact (comp_assoc _ _ _).
Qed.

Next Obligation.
destruct f, g, h.
unfold Basics.flip.
repeat (rewrite trans_ble_equation_1).
refine (eq_ble _ _ _ _ _).
simpl.
exact (comp_assoc_sym _ _ _).
Qed.

(* This is an isomorphism, since ble is Affine *)
(* See Embed.Theory.Btree.Segment.Affine for an (incomplete) proof *)
Lemma ble_cons (x y z w : @btree 1) :
  ble (bcons x y) (bcons z w) ↔ ble x z * ble y w.
split.
{
  intro.
  destruct H.
  destruct x0.
  rewrite run_bforest_equation_1 in e.
  rewrite zip_btree_equation_2 in e.
  rewrite fmap_btree_equation_2 in e.
  rewrite join_btree_equation_2 in e.
  inversion e.
  destruct i.
  rewrite H1.

  assert (H : list_num_leaves [x; y] = length x0).
  {
    do 2 (rewrite list_num_leaves_equation_2).
    rewrite list_num_leaves_equation_1.
    rewrite <- plus_n_O.
    rewrite <- e0.
    rewrite num_leaves_equation_2.
    reflexivity.
  }
  split.
  {
    assert (xz :
      is_bforest (num_leaves x) (num_leaves z) (firstn (num_leaves x) x0)
    ).
    {
      split.
      {
        exact (list_num_leaves_firstn H).
      }
      {
        rewrite <- H0.
        rewrite num_leaves_join.
        rewrite leaves_fmap.
        rewrite leaves_zip_btree.
        rewrite list_map_snd_combine.
        rewrite eq_num_leaves.
        rewrite firstn_firstn.
        rewrite PeanoNat.Nat.min_id.
        reflexivity.
      }
    }
    {
      refine (@exist _ _ (@exist _ _ (firstn (num_leaves x) x0) xz) _).
      rewrite run_bforest_equation_1.
      rewrite <- H0.
      do 2 (rewrite <- (zip_btree_err_correct _ _ _ (bnil tt))).
      reflexivity.
    }
  }
  {
    (* Same proof, but H0 -> H1, firstn -> skipn *)
    assert (yw :
      is_bforest (num_leaves y) (num_leaves w) (skipn (num_leaves x) x0)
    ).
    {
      split.
      {
        rewrite <- (list_num_leaves_skipn H).
        rewrite list_num_leaves_equation_2.
        rewrite list_num_leaves_equation_1.
        rewrite <- plus_n_O.
        reflexivity.
      }
      {
        (* Almost the same proof as above *)
        rewrite <- H1.
        rewrite num_leaves_join.
        rewrite leaves_fmap.
        rewrite leaves_zip_btree.
        rewrite list_map_snd_combine.
        rewrite eq_num_leaves.
        rewrite firstn_skipn_comm.
        rewrite <- num_leaves_equation_2.
        refine (eq_trans (f_equal
          (fun xx =>
            list_num_leaves (skipn (num_leaves x) (firstn xx x0))
          )
          e0
        ) _).
        rewrite firstn_all.
        reflexivity.
      }
    }
    {
      refine (@exist _ _ (@exist _ _ (skipn (num_leaves x) x0) yw) _).
      rewrite run_bforest_equation_1.
      rewrite <- H1.
      do 2 (rewrite <- (zip_btree_err_correct _ _ _ (bnil tt))).
      reflexivity.
    }
  }
}

{
  intro.
  destruct H.
  destruct b, b0.
  destruct x0, x1.
  destruct i, i0.
  rewrite run_bforest_equation_1 in e, e0.
  assert (xy :
    is_bforest (num_leaves (bcons x y)) (num_leaves (bcons z w)) (x0 ++ x1)
  ).
  {
    split.
    {
      rewrite num_leaves_equation_2.
      rewrite app_length.
      rewrite (nat_plus_eq e1 e3).
      reflexivity.
    }
    {
      (* Almost the same proof as above *)
      rewrite num_leaves_equation_2.
      rewrite <- list_num_leaves_app.
      rewrite (nat_plus_eq e2 e4).
      reflexivity.
    }
  }
  {
    refine (@exist _ _ (@exist _ _ (x0 ++ x1) xy) _).
    rewrite run_bforest_equation_1.
    rewrite zip_btree_equation_2.
    rewrite fmap_btree_equation_2.
    rewrite join_btree_equation_2.
    refine (bcons_eq _ _).
    {
      rewrite <- (zip_btree_err_correct _ _ _ (bnil tt)).
      rewrite <- (zip_btree_err_correct _ _ _ (bnil tt)) in e.
      rewrite (firstn_app (num_leaves x) x0 x1).
      rewrite e1.
      rewrite firstn_all.
      rewrite PeanoNat.Nat.sub_diag.
      simpl.
      rewrite app_nil_r.
      exact e.
    }
    {
      (* The same proof, with e -> e0 and firstn -> skipn *)
      rewrite <- (zip_btree_err_correct _ _ _ (bnil tt)).
      rewrite <- (zip_btree_err_correct _ _ _ (bnil tt)) in e0.
      rewrite (skipn_app (num_leaves x) x0 x1).
      rewrite e1.
      rewrite skipn_all.
      rewrite PeanoNat.Nat.sub_diag.
      simpl.
      exact e0.
    }
  }
}
Qed.

Fixpoint ble_nil (x : @btree 1) : ble (bnil tt) x.
assert (xs :
  is_bforest (num_leaves (bnil ())) (num_leaves x) [x]
).
{
  rewrite num_leaves_equation_1.
  split.
  {
    reflexivity.
  }
  {
    rewrite list_num_leaves_equation_2.
    rewrite list_num_leaves_equation_1.
    rewrite <- plus_n_O.
    reflexivity.
  }
}
{
  refine (@exist _ _ (@exist _ _ (cons x nil) xs) _).
  destruct xs.
  rewrite run_bforest_equation_1.
  rewrite zip_btree_equation_1.
  rewrite fmap_btree_equation_1.
  rewrite join_btree_equation_1.
  simpl.
  rewrite dep_hd_equation_2.
  reflexivity.
}
Qed.

Fixpoint ble_consistent (x y : @btree 1) :
  ble x y ↔ and_btree x y = x.
split.
{
  intro.
  destruct x, y.
  {
    destruct t.
    reflexivity.
  }
  {
    destruct t.
    reflexivity.
  }
  {
    simpl.
    destruct H.
    destruct x.
    destruct i.
    rewrite run_bforest_equation_1 in e.
    rewrite zip_btree_equation_2 in e.
    rewrite fmap_btree_equation_2 in e.
    rewrite join_btree_equation_2 in e.
    discriminate.
  }
  {
    simpl.
    destruct (fst (ble_cons _ _ _ _) H).
    refine (bcons_eq _ _).
    {
      exact (fst (ble_consistent x1 y1) b).
    }
    {
      exact (fst (ble_consistent x2 y2) b0).
    }
  }
}
{
  intro.
  destruct x, y.
  {
    destruct t.
    exact (ble_nil _).
  }
  {
    exact (ble_nil _).
  }
  {
    discriminate.
  }
  {
    refine (snd (ble_cons _ _ _ _) _).
    rewrite and_btree_equation_4 in H.
    inversion H.
    rewrite H1, H2.
    split.
    {
      exact (snd (ble_consistent x1 y1) H1).
    }
    {
      exact (snd (ble_consistent x2 y2) H2).
    }
  }
}
Qed.


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

Require Import prelude ssreflect prop equality.

(** [unit] is a singleton datatype with sole inhabitant [tt] *)

Variant unit : Set :=
  tt : unit.

Lemma unitE : all_equal_to tt. Proof. by case. Qed.

(** [option A] is the extension of [A] with an extra element [None] *)

Variant option (A : Type) : Type :=
  | Some of A
  | None.

Arguments Some {A} _.
Arguments None {A}.

Register option as core.option.type.
Register Some as core.option.Some.
Register None as core.option.None.

Module Option.

Definition apply aT rT (f : aT -> rT) x u := if u is Some y then f y else x.

Definition default T := apply (fun x : T => x).

Definition bind aT rT (f : aT -> option rT) := apply f None.

Definition map aT rT (f : aT -> rT) := bind (fun x => Some (f x)).

End Option.

Notation oapp := Option.apply.
Notation odflt := Option.default.
Notation obind := Option.bind.
Notation omap := Option.map.
Notation some := (@Some _) (only parsing).

(** Inversion principles *)
Definition optionI A (oa oa': option A) (e: oa = oa') :
  if oa is Some a then if oa' is Some a' then a = a' else False else if oa' is Some _ then False else True
  :=
    let: eq_refl := e in
    if oa is Some a then eq_refl else I.

(** [prod A B], written [A * B], is the product of [A] and [B];
    the pair [pair A B a b] of [a] and [b] is abbreviated [(a,b)] *)

#[universes(template)]
Record prod (A B : Type) : Type :=
  pair { fst : A; snd : B }.

Arguments pair {A B} _ _.

Declare Scope pair_scope.
Delimit Scope pair_scope with PAIR.
Open Scope pair_scope.

Reserved Notation "x * y" (at level 40, left associativity).
Notation "x * y" := (prod x y) : type_scope.

Reserved Notation "( x , y , .. , z )" (at level 0).
Notation "( x , y , .. , z )" := (pair .. (pair x y) .. z) : pair_scope.

Notation "p .1" := (fst p)
  (at level 2, left associativity, format "p .1") : pair_scope.
Notation "p .2" := (snd p)
  (at level 2, left associativity, format "p .2") : pair_scope.

Coercion pair_of_and P Q (PandQ : P /\ Q) := (and_proj1 PandQ, and_proj2 PandQ).

Definition all_pair I T U (w : forall i : I, T i * U i) :=
  (fun i => (w i).1, fun i => (w i).2).

Definition prod_rect (A B: Type) (T: prod A B -> Type) (h: forall (a: A) (b: B), T (a, b)) p : T p :=
  let: (a, b) := p in h a b.

Register prod as core.prod.type.
Register pair as core.prod.intro.
Register prod_rect as core.prod.rect.

Register fst as core.prod.proj1.
Register snd as core.prod.proj2.

(** [(sig A P)], or more suggestively [{x:A | P x}], denotes the subset
    of elements of the type [A] which satisfy the predicate [P].
    Similarly [(sig2 A P Q)], or [{x:A | P x & Q x}], denotes the subset
    of elements of the type [A] which satisfy both [P] and [Q]. *)

Record sig (A : Type) (P : A -> Type) : Type :=
  exist { sig_proj1 : A;  sig_proj2 : P sig_proj1 }.

Arguments exist {A} _.

Record sig2 (A : Type) (P Q : A -> Type) : Type :=
  exist2 { sig2_proj1 : A; sig2_proj2 : P sig2_proj1; sig2_proj3 : Q sig2_proj1 }.

Arguments exist2 {A} _ _.

Reserved Notation "{ x  |  P }" (at level 0, x at level 99).
Reserved Notation "{ x  |  P  & Q }" (at level 0, x at level 99).

Reserved Notation "{ x : A  |  P }" (at level 0, x at level 99).
Reserved Notation "{ x : A  |  P  & Q }" (at level 0, x at level 99).

Notation "{ x  |  P }" := (sig (fun x => P)) : type_scope.
Notation "{ x  |  P  & Q }" := (sig2 (fun x => P) (fun x => Q)) : type_scope.
Notation "{ x : A  |  P }" := (sig (A:=A) (fun x => P)) : type_scope.
Notation "{ x : A  |  P  & Q }" := (sig2 (A:=A) (fun x => P) (fun x => Q)) :
  type_scope.

(** [sum A B], also noted [A + B] is the disjoint sum of datatypes [A] and [B]. *)
Variant sum A B : Type :=
| Left of A
| Right of B.

Infix "+" := sum (at level 50, left associativity) : type_scope.

Arguments Left {A B} _.
Arguments Right {A B} _.