(* ************************************************************************** *)
(*                                                                            *)
(* Verified Flash Translation Layer                                           *)
(*                                                                            *)
(*                                                                            *)
(*   Author: Yu Guo <guoyu@ustc.edu.cn>                                       *)
(*                          School of Computer Science and Technology, USTC   *)
(*                                                                            *)
(*           Hui Zhang <sa512073@mail.ustc.edu.cn>                            *)
(*                                     School of Software Engineering, USTC   *)
(*                                                                            *)
(* ************************************************************************** *)

Require Import List.
Require Import ListEx.
Require Import LibEx.
Require Import Monad.
Require Import Data.

Require Import Params.
Require Import Nand.
Require Import NandLems.

Require Import Bast0.
Require Import FTLProp.
Require Import FTLLems.

Require Import Inv.

(* == I_inv == lemmas =========================== *)

Lemma I_pbn_bit_valid_preserv_bit_update :
  forall pbn bit bi bit',
    valid_block_no pbn
    -> I_pbn_bit_valid bit
    -> bit_update bit pbn bi = Some bit'
    -> I_pbn_bit_valid bit'.
Proof.
  intros pbn bit bi bit' Hv HI1 Hup.
  unfold I_pbn_bit_valid in * .
  intros pbn'.
  destruct (block_no_eq_dec pbn pbn').
    subst pbn'.
    destruct (HI1 pbn) as [H1 H2].
    split.
      intro Hx.
      exists bi.
      rewrite (bit_update_bit_get_eq _ _ _ _ Hup).
      trivial.
    intros [bi' Hget'].
    trivial.
  destruct (HI1 pbn') as [H1 H2].
  split.
    intro Hx.
    destruct (H1 Hx) as [bi' Hg'].
    exists bi'.
    rewrite (bit_update_bit_get_neq _ _ _ _ _ Hup (neq_sym H)).
    trivial.
  intros [bi' Hg'].
  apply H2.
  exists bi'.
  rewrite <- (bit_update_bit_get_neq _ _ _ _ _ Hup (neq_sym H)).
  trivial.
Qed.

Lemma I_pbn_fbq_valid_preserv_fbq_deq :
  forall fbq pbn fbq',
    I_pbn_fbq_valid fbq
    -> fbq_deq fbq = Some (pbn, fbq')
    -> I_pbn_fbq_valid fbq'.
Proof.
  induction fbq.
    intros.
    discriminate.
  intros pbn' fbq' Hv.
  simpl.
  intros H.
  injection H.
  intros.
  subst fbq' a.
  unfold I_pbn_fbq_valid in Hv.
  unfold I_pbn_fbq_valid.
  intros pbn Hin.
  apply Hv.
  unfold fbq_in.
  simpl.
  destruct (beq_nat pbn pbn').
  trivial.
  trivial.
Qed.

Lemma I_pbn_fbq_state_preserv_fbq_deq :
  forall bit fbq pbn fbq',
    I_pbn_fbq_state bit fbq
    -> fbq_deq fbq = Some (pbn, fbq')
    -> I_pbn_fbq_state bit fbq'.
Proof.
  induction fbq.
    intros.
    discriminate.
  intros pbn' fbq' HI4.
  simpl.
  intros H.
  injection H.
  intros.
  subst fbq' a.
  unfold I_pbn_fbq_state in HI4.
  unfold I_pbn_fbq_state.
  intros pbn bi Hin Hg.
  apply HI4 with pbn.
  unfold fbq_in.
  simpl.
  destruct (beq_nat pbn pbn').
  trivial.
  trivial.
  trivial.
Qed.

Lemma I_pbn_fbq_state_preserv_bit_update :
  forall bit fbq pbn bi bit',
    I_pbn_fbq_state bit fbq
    -> bit_update bit pbn bi = Some bit'
    -> fbq_in fbq pbn = false
    -> I_pbn_fbq_state bit' fbq.
Proof.
  intros. unfold I_pbn_fbq_state. unfold I_pbn_fbq_state in H.
  intros pbn' bi' Hin' Hg'.
  apply (H pbn' bi'); trivial.
  destruct (block_no_eq_dec pbn pbn').
    subst pbn'.
    rewrite H1 in Hin'.
    discriminate.
  rewrite <- (bit_update_bit_get_neq _ _ _ _ _ H0); auto.
Qed.

Lemma allocated_pbn_not_in_fbq :
  forall fbq pbn fbq',
    I_pbn_fbq_distinguishable fbq
    -> fbq_deq fbq = Some (pbn, fbq')
    -> fbq_in fbq' pbn = false.
Proof.
  intros fbq pbn fbq' HI8 Hdeq.
  assert (Hin : fbq_in fbq pbn = true).
    unfold fbq_deq, fbq_in in * .
    destruct fbq.
      discriminate.
    injection Hdeq.
    intros; subst fbq' b.
    simpl.
    simplbnat.
    trivial.
  destruct (fbq_in fbq' pbn) eqn:Hin'.
  destruct (fbq_in_fbq_get _ _ Hin') as [i Hg].
  assert (Hx:=fbq_get_fbq_rdeq_fbq_get _ _ _ _ _ Hg Hdeq).
  assert (Hy : fbq_get fbq 0 = Some pbn).
    eapply fbq_deq_fbq_get; eauto.
  assert (Hm : 0 <> S i).
    auto with arith.
  assert (HF:= HI8 0 (S i) pbn pbn Hm Hy Hx).
  destruct (HF (refl_equal)).
  trivial.
Qed.

Lemma I_pbn_habitation_in_fbq_implies_not_in_bmt :
  forall pbn bmt fbq,
    valid_block_no pbn
    -> I_pbn_habitation bmt fbq
    -> fbq_in fbq pbn = true
    -> ~ pbn_in_bmt bmt pbn.
Proof.
  intros.
  destruct (H0 pbn H).
    destruct H2 as [[lbn H3] H4].
    rewrite H1 in H4.
    discriminate.
  unfold pbn_in_bmt.
  intro Hx.
  destruct Hx as [lbn Hx].
  destruct H2 as [H3 H4].
  apply (H3 lbn Hx); trivial.
Qed.

Lemma I_pbn_habitation_in_bmt_implies_not_in_fbq :
  forall pbn bmt fbq,
    valid_block_no pbn
    -> I_pbn_habitation bmt fbq
    -> pbn_in_bmt bmt pbn
    -> fbq_in fbq pbn = false.
Proof.
  intros.
  destruct (H0 pbn H).
    destruct H2 as [[lbn H3] H4].
    trivial.
  unfold pbn_in_bmt in H1.
  destruct H1 as [lbn H1].
  destruct H2 as [H3 H4].
  destruct (H3 _ H1).
Qed.

Lemma I_pbn_bmt_valid_preserv_bmt_update_data_none :
  forall bmt lbn pbn bmt',
    valid_block_no pbn
    -> I_pbn_bmt_valid bmt
    -> bmt_update bmt lbn (Some pbn, None) = Some bmt'
    -> I_pbn_bmt_valid bmt'.
Proof.
  unfold I_pbn_bmt_valid.
  intros bmt lbn pbn bmt' Hv HI2 Hup.
  intros lbn' pbn' Hin.
  destruct (block_no_eq_dec lbn lbn') as [Hlbn | Hlbn].
    subst lbn'.
    assert (Hx:= bmt_update_bmt_get_eq _ _ _ _  Hup).
    destruct Hin as [Hin | Hin].
      destruct Hin as [x Hin].
      rewrite Hin in Hx.
      injection Hx.
      intros; subst x pbn'.
      trivial.
    destruct Hin as [x Hin].
    rewrite Hin in Hx.
    discriminate.
  assert (Hx := bmt_update_pbn_in_bmt_lbn_neq_rev _ _ _ _ _ _ Hup Hlbn Hin).
  apply HI2 with lbn'; trivial.
Qed.

(* Lemma I_pbn_bmt_valid_preserv_bmt_update :  *)
(*   forall bmt lbn pbn bmt', *)
(*     valid_block_no pbn *)
(*     -> I_pbn_bmt_valid bmt *)
(*     -> (bmt_update bmt lbn (Some pbn, None) = Some bmt'  *)
(*         \/  bmt_update bmt lbn (None, Some pbn) = Some bmt') *)
(*     -> I_pbn_bmt_valid bmt'. *)
(* Proof. *)
(*   intros bmt lbn pbn bmt' Hv HI2 H *)
(* Qed. *)

Lemma I_pbn_bmt_valid_preserv_bmt_update_log :
  forall bmt lbn pbn bmt',
    valid_block_no pbn
    -> I_pbn_bmt_valid bmt
    -> bmt_update_log bmt lbn pbn = Some bmt'
    -> I_pbn_bmt_valid bmt'.
Proof.
  unfold bmt_update_log.
  intros bmt lbn pbn bmt' Hv HI2 Hul.
  destruct (bmt_get bmt lbn) as [[bmrdata bmrlog] | ] eqn:Hget; try discriminate.
  destruct (bmt_update bmt lbn (bmrdata, Some pbn)) as [bmt'' | ] eqn:Hu; try discriminate.
  injection Hul; intro; subst bmt''.
  unfold I_pbn_bmt_valid in * .
  intros lbn' pbn' Hin.
  destruct (block_no_eq_dec lbn lbn') as [Heq | Hneq].
    subst lbn'; trivial.
    unfold pbn_in_bmt_lbn in Hin.
    destruct Hin as [Hin | Hin].
      destruct Hin as [x Hin].
      rewrite (bmt_update_bmt_get_eq _ _ _ _ Hu) in Hin.
      injection Hin; intros; subst bmrdata x.
      assert (pbn_in_bmt_lbn bmt lbn pbn').
        left.
        exists bmrlog.
        trivial.
      eapply HI2; eauto.
    destruct Hin as [x Hin].
    rewrite (bmt_update_bmt_get_eq _ _ _ _ Hu) in Hin.
    injection Hin; intros; subst x pbn'.
    trivial.
  apply HI2 with lbn'.
  unfold pbn_in_bmt_lbn in Hin |- * .
  destruct Hin as [Hin | Hin].
    left.
    unfold pbn_in_bmt_data in Hin.
    destruct Hin as [x Hin].
    exists x.
    rewrite <- (bmt_update_bmt_get_neq _ _ _ _ _ Hu Hneq).
    trivial.
  right.
  unfold pbn_in_bmt_log in Hin.
  destruct Hin as [x Hin].
  exists x.
  rewrite <- (bmt_update_bmt_get_neq _ _ _ _ _ Hu Hneq).
  trivial.
Qed.

Lemma I_pbn_bmt_valid_preserv_bmt_update_data :
  forall bmt lbn pbn bmt',
    valid_block_no pbn
    -> I_pbn_bmt_valid bmt
    -> bmt_update_data bmt lbn pbn = Some bmt'
    -> I_pbn_bmt_valid bmt'.
Proof.
  unfold bmt_update_data.
  intros bmt lbn pbn bmt' Hv HI2 Hud.
  destruct (bmt_get bmt lbn) as [[bmrdata bmrlog] | ] eqn:Hget; try discriminate.
  destruct (bmt_update bmt lbn (Some pbn, bmrlog)) as [bmt'' | ] eqn:Hu; try discriminate.
  injection Hud; intro; subst bmt''.
  unfold I_pbn_bmt_valid in * .
  intros lbn' pbn' Hin.
  destruct (block_no_eq_dec lbn lbn') as [Heq | Hneq].
    subst lbn'; trivial.
    unfold pbn_in_bmt_lbn in Hin.
    destruct Hin as [Hin | Hin].
      destruct Hin as [x Hin].
      rewrite (bmt_update_bmt_get_eq _ _ _ _ Hu) in Hin.
      injection Hin; intros; subst pbn' x.
      trivial.
    destruct Hin as [x Hin].
    rewrite (bmt_update_bmt_get_eq _ _ _ _ Hu) in Hin.
    injection Hin; intros; subst bmrlog x.
    assert (pbn_in_bmt_lbn bmt lbn pbn').
      right.
      exists bmrdata.
      trivial.
    eapply HI2; eauto.
  apply HI2 with lbn'.
  unfold pbn_in_bmt_lbn in Hin |- * .
  destruct Hin as [Hin | Hin].
    left.
    unfold pbn_in_bmt_data in Hin.
    destruct Hin as [x Hin].
    exists x.
    rewrite <- (bmt_update_bmt_get_neq _ _ _ _ _ Hu Hneq).
    trivial.
  right.
  unfold pbn_in_bmt_log in Hin.
  destruct Hin as [x Hin].
  exists x.
  rewrite <- (bmt_update_bmt_get_neq _ _ _ _ _ Hu Hneq).
  trivial.
Qed.

Lemma I_pbn_freebq_valid_preserv_fbq_enq :
  forall fbq pbn fbq',
    valid_block_no pbn
    -> I_pbn_fbq_valid fbq
    -> fbq_enq fbq pbn = Some fbq'
    -> I_pbn_fbq_valid fbq'.
Proof.
  unfold I_pbn_fbq_valid.
  intros fbq pbn fbq' Hv HI3 Hen.
  intros pbn' Hin'.
  destruct (block_no_eq_dec pbn pbn') as [Heq | Hneq].
    subst pbn'.
    trivial.
  apply HI3.
  rewrite <- (fbq_in_preserv_fbq_enq pbn' fbq pbn fbq'); eauto.
Qed.

Lemma I_pbn_freebq_state_preserv_fbq_enq :
  forall bit fbq pbn bi bit' fbq',
    valid_block_no pbn
    -> bit_update bit pbn bi = Some bit'
    -> bi_state bi = bs_invalid
    -> I_pbn_fbq_state bit fbq
    -> fbq_enq fbq pbn = Some fbq'
    -> I_pbn_fbq_state bit' fbq'.
Proof.
  intros bit fbq pbn bi bit' fbq' Hv Hu Hbi HI4 Hen.
  unfold I_pbn_fbq_state in * .
  intros pbn' bi' Hin' Hget'.
  destruct (block_no_eq_dec pbn pbn') as [Heq | Hneq].
    subst pbn'.
    rewrite (bit_update_bit_get_eq _ _ _ _ Hu) in Hget'.
    injection Hget'; intro; subst bi'.
    left; trivial.
  assert (fbq_in fbq pbn' = true).
    rewrite <- (fbq_in_preserv_fbq_enq _ _ _ _ (neq_sym Hneq) Hen) .
    trivial.
  assert (bit_get bit pbn' = Some bi').
    rewrite <- (bit_update_bit_get_neq _ _ _ _ _ Hu (neq_sym Hneq)).
    trivial.
  eapply HI4; eauto.
Qed.

Lemma pbn_not_in_bmt_bmt_update :
  forall bmt lbn pbn (bmr: bmt_record) bmt',
    pbn_in_bmt_lbn bmt lbn pbn
    -> I_pbn_bmt_distinguishable bmt
    -> I_pbn_bmt_distinguishable_2 bmt
    -> bmt_update bmt lbn bmr = Some bmt'
    -> pbn_not_in_bmr pbn bmr
    -> pbn_not_in_bmt bmt' pbn.
Proof.
  intros bmt lbn pbn bmr bmt'.
  intros Hin HI71 HI72 Hup Hnot.
  unfold pbn_not_in_bmt.
  intro HF.
  unfold pbn_in_bmt in HF.
  destruct HF as [lbn' Hlbn'in].
  assert (Hx: lbn' = lbn \/ lbn' <> lbn).
    destruct (block_no_eq_dec lbn lbn').
      left; auto.
    right; auto.
  destruct Hx as [Heq | Hneq].
    subst lbn'.
    unfold I_pbn_bmt_distinguishable in HI71.
    unfold I_pbn_bmt_distinguishable_2 in HI72.
    unfold pbn_in_bmt_lbn in Hlbn'in.
    assert (H1 := bmt_update_bmt_get_eq _ _ _ _ Hup).
    destruct Hlbn'in as [H2 | H3].
      unfold pbn_in_bmt_data in H2.
      destruct H2 as [x Hx].
      unfold pbn_not_in_bmr in Hnot.
      destruct bmr as [bmr1 bmr2].
      destruct bmr1 as [b1 | ].
      rewrite H1 in Hx.
      injection Hx.
      intros.
      subst pbn.
      destruct bmr2.
      destruct Hnot.
      apply H0; trivial.
      apply Hnot; trivial.
      rewrite H1 in Hx.
      discriminate.
    unfold pbn_in_bmt_log in H3.
    destruct H3 as [x Hx].
    unfold pbn_not_in_bmr in Hnot.
    destruct bmr as [bmr1 bmr2].
    destruct bmr1 as [b1 | ].
    destruct bmr2 as [b2 | ].
    rewrite H1 in Hx.
    injection Hx.
    intros.
    subst pbn.
    destruct Hnot.
    apply H2; trivial.
    rewrite H1 in Hx.
    discriminate.
    destruct bmr2 as [b2 | ].
    rewrite H1 in Hx.
    injection Hx.
    intros.
    subst pbn.
    apply Hnot; trivial.
    rewrite H1 in Hx.
    discriminate.
  unfold I_pbn_bmt_distinguishable in HI71.
  unfold pbn_in_bmt_lbn in Hlbn'in.
  destruct Hlbn'in.
  unfold pbn_in_bmt_data in H.
  destruct H as [x Hx].
  rewrite (bmt_update_bmt_get_neq _ _ _ _ _ Hup (neq_sym Hneq)) in Hx.
  assert (H1 : pbn_in_bmt_lbn bmt lbn' pbn).
    unfold pbn_in_bmt_lbn.
    left.
    unfold pbn_in_bmt_data.
    exists x; trivial.
  assert (Hy:= HI71 lbn lbn' pbn pbn (neq_sym Hneq) Hin H1).
  apply Hy; trivial.
  unfold pbn_in_bmt_log in H.
  destruct H as [x Hx].
  rewrite (bmt_update_bmt_get_neq _ _ _ _ _ Hup (neq_sym Hneq)) in Hx.
  assert (H1 : pbn_in_bmt_lbn bmt lbn' pbn).
    unfold pbn_in_bmt_lbn.
    right.
    unfold pbn_in_bmt_log.
    exists x; trivial.
  assert (Hy:= HI71 lbn lbn' pbn pbn (neq_sym Hneq) Hin H1).
  apply Hy; trivial.
Qed.

Lemma pbn_in_bmt_implies_pbn_in_bmt_again :
  forall bmt lbn pbn lbn',
    I_pbn_bmt_distinguishable bmt
    -> pbn_in_bmt_lbn bmt lbn pbn
    -> lbn' <> lbn
    -> ~ pbn_in_bmt_lbn bmt lbn' pbn.
Proof.
  intros bmt lbn pbn lbn'.
  intros HI71 Hin Hneq.
  unfold I_pbn_bmt_distinguishable in HI71.
  intro Hin2.
  apply (HI71 lbn' lbn pbn pbn Hneq Hin2 Hin); trivial.
Qed.

(*
 Lemmas for I7

 *)

Lemma I_pbn_bmt_distinguishable_preserv_bmt_update_data_none:
  forall bmt lbn pbn bmt',
  I_pbn_bmt_distinguishable bmt
  -> bmt_update bmt lbn (Some pbn, None) = Some bmt'
  -> ~ pbn_in_bmt bmt pbn
  -> I_pbn_bmt_distinguishable bmt'.
Proof.
  intros bmt lbn pbn bmt'.
  intros HI71 Hup Hnin.
  unfold I_pbn_bmt_distinguishable in * .
  intros lbn1 lbn2 pbn1 pbn2 Hneq12 Hin11 Hin22.
  destruct (pbn_eq_dec lbn lbn1) as [Heq1 | Hneq1].
  destruct (pbn_eq_dec lbn lbn2) as [Heq2 | Hneq2].

  subst lbn1.
  destruct (Hneq12 Heq2).
  subst lbn1.
  assert (pbn1 = pbn).
    assert (bmt_get bmt' lbn = Some (Some pbn, None)).
      rewrite (bmt_update_bmt_get_eq _ _ _ _ Hup); trivial.
    unfold pbn_in_bmt_lbn in Hin11.
    unfold pbn_in_bmt_data, pbn_in_bmt_log in Hin11.
    destruct Hin11 as [Hin11 | Hin11].
    destruct Hin11 as [x Hin11].
    rewrite Hin11 in H .
    injection H; intros; subst; trivial.
    destruct Hin11 as [x Hin11].
    rewrite Hin11 in H .
    discriminate.
  subst pbn1.
  apply (bmt_update_pbn_in_bmt_lbn_neq_rev _ _ _ _ _ _ Hup Hneq2) in Hin22.
  intro HF.
  subst pbn2.
  unfold pbn_in_bmt in Hnin.
  apply Hnin.
  exists lbn2; trivial.

  destruct (pbn_eq_dec lbn lbn2) as [Heq2 | Hneq2].
  subst lbn2.
  assert (pbn2 = pbn).
    assert (bmt_get bmt' lbn = Some (Some pbn, None)).
      rewrite (bmt_update_bmt_get_eq _ _ _ _ Hup); trivial.
    unfold pbn_in_bmt_lbn in Hin22.
    unfold pbn_in_bmt_data, pbn_in_bmt_log in Hin22.
    destruct Hin22 as [Hin22 | Hin22].
    destruct Hin22 as [x Hin22].
    rewrite Hin22 in H .
    injection H; intros; subst; trivial.
    destruct Hin22 as [x Hin22].
    rewrite Hin22 in H .
    discriminate.
  subst pbn2.
  apply (bmt_update_pbn_in_bmt_lbn_neq_rev _ _ _ _ _ _ Hup Hneq1) in Hin11.
  intro HF.
  subst pbn1.
  unfold pbn_in_bmt in Hnin.
  apply Hnin.
  exists lbn1; trivial.

  apply (bmt_update_pbn_in_bmt_lbn_neq_rev _ _ _ _ _ _ Hup Hneq2) in Hin22.
  apply (bmt_update_pbn_in_bmt_lbn_neq_rev _ _ _ _ _ _ Hup Hneq1) in Hin11.
  apply (HI71 lbn1 lbn2); eauto.
Qed.

Lemma I_pbn_bmt_distinguishable_preserv_bmt_update_log:
  forall bmt lbn pbn bmt',
  I_pbn_bmt_distinguishable bmt
  -> bmt_update_log bmt lbn pbn = Some bmt'
  -> ~ pbn_in_bmt bmt pbn
  -> I_pbn_bmt_distinguishable bmt'.
Proof.
  intros bmt lbn pbn bmt'.
  unfold bmt_update_log, I_pbn_bmt_distinguishable, pbn_in_bmt.
  intros HI71 Hul Hnin.
  intros lbn1 lbn2 pbn1 pbn2 Hlbn12 Hpbn1 Hpbn2.
  destruct (bmt_get bmt lbn) as [bmr | ] eqn:Hbmt; try discriminate.
  destruct bmr as [bmrd bmrl].
  destruct (bmt_update bmt lbn (bmrd, Some pbn)) as [bmt'' | ] eqn:Hu; try discriminate.
  injection Hul; intros; subst bmt''.
  destruct (block_no_eq_dec lbn lbn1) as [Heq | Hneq ].
    subst lbn1.
    destruct Hpbn1 as [Hin1 | Hin1].
      destruct Hin1 as [x Hin1].
      assert (Hx := bmt_update_bmt_get_eq _ _ _ _ Hu).
      rewrite Hin1 in Hx.
      injection Hx.
      intros.
      subst x bmrd.
      assert (Hy := bmt_update_pbn_in_bmt_lbn_neq_rev _ _ _ _ _ _ Hu Hlbn12 Hpbn2).
      eapply HI71; eauto.
      left.
      exists bmrl.
      trivial.
    destruct Hin1 as [x Hin1].
    rewrite (bmt_update_bmt_get_eq _ _ _ _ Hu) in Hin1.
    injection Hin1; intros; subst x pbn.
    clear Hin1.
    intro Hx.
    subst pbn2.
    assert (Hy := bmt_update_pbn_in_bmt_lbn_neq_rev _ _ _ _ _ _ Hu Hlbn12 Hpbn2).
    apply Hnin.
    exists lbn2; trivial.
  destruct (block_no_eq_dec lbn lbn2) as [Heq | Hneq2 ].
    subst lbn2.
    destruct Hpbn2 as [Hin2 | Hin2].
      destruct Hin2 as [x Hin2].
      assert (Hx := bmt_update_bmt_get_eq _ _ _ _ Hu).
      rewrite Hin2 in Hx.
      injection Hx.
      intros.
      subst x bmrd.
      assert (Hy := bmt_update_pbn_in_bmt_lbn_neq_rev _ _ _ _ _ _ Hu (neq_sym Hlbn12) Hpbn1).
      eapply HI71; eauto.
      left.
      exists bmrl.
      trivial.
    destruct Hin2 as [x Hin2].
    rewrite (bmt_update_bmt_get_eq _ _ _ _ Hu) in Hin2.
    injection Hin2; intros; subst x pbn.
    clear Hin2.
    intro Hx.
    subst pbn1.
    assert (Hy := bmt_update_pbn_in_bmt_lbn_neq_rev _ _ _ _ _ _ Hu (neq_sym Hlbn12) Hpbn1).
    apply Hnin.
    exists lbn1; trivial.
  assert (Hx := bmt_update_pbn_in_bmt_lbn_neq_rev _ _ _ _ _ _ Hu Hneq Hpbn1).
  assert (Hy := bmt_update_pbn_in_bmt_lbn_neq_rev _ _ _ _ _ _ Hu Hneq2 Hpbn2).
  apply (HI71 _ _ _ _ Hlbn12); eauto.
Qed.

Lemma I_pbn_bmt_distinguishable_2_preserv_bmt_update_data_none:
  forall bmt lbn pbn bmt',
  I_pbn_bmt_distinguishable_2 bmt
  -> bmt_update bmt lbn (Some pbn, None) = Some bmt'
  -> I_pbn_bmt_distinguishable_2 bmt'.
Proof.
  intros bmt lbn pbn bmt' HI72 Hu.
  unfold I_pbn_bmt_distinguishable_2 in * .
  intros lbn' pbn1 pbn2 Hget.
  destruct (block_no_eq_dec lbn lbn') as [Heq | Hneq ].
    subst lbn'.
    rewrite (bmt_update_bmt_get_eq _ _ _ _ Hu) in Hget.
    discriminate Hget.
  rewrite (bmt_update_bmt_get_neq _ _ _ _ _ Hu Hneq) in Hget.
  eapply HI72; eauto.
Qed.

Lemma I_pbn_bmt_distinguishable_2_preserv_bmt_update_log:
  forall bmt lbn pbn bmt',
  I_pbn_bmt_distinguishable_2 bmt
  -> bmt_update_log bmt lbn pbn = Some bmt'
  -> ~ pbn_in_bmt bmt pbn
  -> I_pbn_bmt_distinguishable_2 bmt'.
Proof.
  intros bmt lbn pbn bmt' HI72 Hu Hnin.
  unfold I_pbn_bmt_distinguishable_2 in * .
  intros lbn' pbn1 pbn2 Hget.
  unfold bmt_update_log in Hu.
  destruct (bmt_get bmt lbn) as [[bmrd bmrl] | ] eqn:Hg; [ | try discriminate].
  destruct (bmt_update bmt lbn (bmrd, Some pbn)) as [bmt'x | ] eqn:Hbu ; [ | try discriminate].
  injection Hu; intros; subst bmt'x.
  clear Hu.
  destruct (block_no_eq_dec lbn lbn') as [Heq | Hneq ].
    subst lbn'.
    rewrite (bmt_update_bmt_get_eq _ _ _ _ Hbu) in Hget.
    injection Hget; intros; subst bmrd pbn.
    clear Hget.
    intros He.
    subst pbn2.
    apply Hnin.
    exists lbn.
    left.
    exists bmrl.
    trivial.
  rewrite (bmt_update_bmt_get_neq _ _ _ _ _ Hbu Hneq) in Hget.
  eapply HI72; eauto.
Qed.

(*
 Lemmas for I5

 *)

Lemma I_pbn_bmt_used_preserv_bit_update_irre :
  forall bit bmt pbn bi bit',
    I_pbn_bmt_used bit bmt
    -> bit_update bit pbn bi = Some bit'
    -> (~ pbn_in_bmt bmt pbn)
    -> I_pbn_bmt_used bit' bmt.
Proof.
  intros bit bmt pbn bi bit' HI5 Hup Hnin.
  unfold I_pbn_bmt_used in * .
  intros lbn pbn' bi' Hget'.
  destruct (pbn_eq_dec pbn pbn') as [Heq | Hneq].
    subst pbn'.
    rewrite (bit_update_bit_get_eq _ _ _ _ Hup) in Hget'.
    injection Hget'.
    intro H; subst bi'; clear Hget'.
    split.
      intros H.
      unfold pbn_in_bmt in Hnin.
      apply False_ind.
      apply Hnin.
      exists lbn.
      unfold pbn_in_bmt_lbn.
      left; trivial.
    intros H.
    unfold pbn_in_bmt in Hnin.
    apply False_ind.
    apply Hnin.
    exists lbn.
    unfold pbn_in_bmt_lbn.
    right; trivial.
  rewrite (bit_update_bit_get_neq _ _ _ _ _ Hup (neq_sym Hneq)) in Hget'.
  apply HI5; auto.
Qed.

Lemma I_pbn_bmt_used_preserv_bmt_update_data_none :
  forall bit bmt pbn lbn bi bit' bmt',
    I_pbn_bmt_used bit bmt
    -> I_pbn_bmt_distinguishable bmt
    -> pbn_not_in_bmt bmt pbn
    -> bmt_update bmt lbn (Some pbn, None) = Some bmt'
    -> bit_update bit pbn bi = Some bit'
    -> bi_state bi = bs_data lbn
    -> I_pbn_bmt_used bit' bmt'.
Proof.
  intros bit bmt pbn lbn bi bit' bmt'.
  intros HI5 HI71 Hnin Hbmtup Hup Hbs.
  assert (HI71' : I_pbn_bmt_distinguishable bmt').
    eapply I_pbn_bmt_distinguishable_preserv_bmt_update_data_none; eauto.
  unfold I_pbn_bmt_used in * .
  intros lbn' pbn' bi' Hget'.
  destruct (pbn_eq_dec pbn pbn') as [Heq | Hneq].
    subst pbn'.
    rewrite (bit_update_bit_get_eq _ _ _ _ Hup) in Hget'.
    injection Hget'.
    intro H; subst bi'; clear Hget'.
    split.
      intros H.
      assert (H1: pbn_in_bmt_lbn bmt' lbn' pbn).
        left; trivial.
      assert (H2: pbn_in_bmt_lbn bmt' lbn pbn).
        eapply (bmt_update_pbn_in_bmt_lbn_eq _ _ _ _ _ Hbmtup); eauto.
        simpl; trivial.
      assert (lbn' = lbn).
        destruct (pbn_eq_dec lbn' lbn) as [Hx | Hx]; trivial.
        apply False_ind.
        eapply HI71'; eauto.
      subst lbn'.
      trivial.
    intro H.
    assert (H1: pbn_in_bmt_lbn bmt' lbn' pbn).
      right; trivial.
    assert (H2: pbn_in_bmt_lbn bmt' lbn pbn).
      eapply (bmt_update_pbn_in_bmt_lbn_eq _ _ _ _ _ Hbmtup); eauto.
      simpl; trivial.
    assert (lbn' = lbn).
      destruct (pbn_eq_dec lbn' lbn) as [Hx | Hx]; trivial.
      apply False_ind.
      eapply HI71'; eauto.
    subst lbn'.
    unfold pbn_in_bmt_log in H.
    assert (H3: bmt_get bmt' lbn = Some (Some pbn, None)).
      eapply bmt_update_bmt_get_eq; eauto.
    destruct H as [x H].
    rewrite H in H3.
    discriminate.
  (* pbn <> pbn' *)
  assert (bit_get bit pbn' = Some bi').
    rewrite (bit_update_bit_get_neq _ _ _ _ _ Hup (neq_sym Hneq)) in Hget'.
    trivial.
  destruct (HI5 lbn' pbn' bi' H) as [H1 H2].
  split.
    intro Hx.
    apply H1.
    destruct (pbn_eq_dec lbn lbn') as [Heq1 | Hneq1].
      subst lbn'.
      assert (pbn_in_bmt_data bmt' lbn pbn).
        exists None.
        apply (bmt_update_bmt_get_eq _ _ _ _ Hbmtup).
      assert (pbn = pbn').
        eapply pbn_in_bmt_data_inj; eauto.
      destruct (Hneq H3).

    unfold pbn_in_bmt_data in Hx |- * .
    destruct Hx as [x Hx].
    exists x.
    rewrite <- (bmt_update_bmt_get_neq _ _ _ _ _ Hbmtup Hneq1).
    trivial.
  intro Hx.
  apply H2.
  destruct (pbn_eq_dec lbn lbn') as [Heq1 | Hneq1].
    subst lbn'.
    unfold pbn_in_bmt_log in Hx.
    destruct Hx as [x Hx].
    assert (bmt_get bmt' lbn = Some (Some pbn, None)).
      eapply bmt_update_bmt_get_eq; eauto.
    rewrite H0 in Hx.
    discriminate.
  unfold pbn_in_bmt_log in Hx |- * .
  destruct Hx as [x Hx].
  exists x.
  rewrite <- (bmt_update_bmt_get_neq _ _ _ _ _ Hbmtup Hneq1).
  trivial.
Qed.

Lemma I_pbn_bmt_used_preserv_bmt_update_log :
  forall bit bmt pbn lbn bi pmt bit' bmt',
    I_pbn_bmt_used bit bmt
    -> ~ pbn_in_bmt bmt pbn
    -> bmt_update_log bmt lbn pbn = Some bmt'
    -> bit_update bit pbn bi = Some bit'
    -> bi_state bi = bs_log lbn pmt
    -> I_pbn_bmt_used bit' bmt'.
Proof.
  unfold I_pbn_bmt_used.
  intros bit bmt pbn lbn bi pmt bit' bmt' HI5 Hnin Hbmtul Hbitu Hbi.
  intros lbn' pbn' bi' Hget'.
  split.
    intros Hin'.
    destruct (pbn_eq_dec pbn pbn') as [Heq | Hneq].
      subst pbn'.
      assert (Hin'x := bmt_update_log_pbn_in_bmt_data_preserv_rev _ _ _ _ _ _ Hbmtul Hin').
      apply False_ind.
      apply Hnin.
      exists lbn'.
      left; trivial.
    rewrite (bit_update_bit_get_neq _ _ _ _ _ Hbitu (neq_sym Hneq)) in Hget'.
    assert (Hin'x := bmt_update_log_pbn_in_bmt_data_preserv_rev _ _ _ _ _ _ Hbmtul Hin').
    destruct (HI5 lbn' _ _ Hget') as [HI5_1 HI5_2].
    apply HI5_1; trivial.
  intro Hin'.
  destruct (pbn_eq_dec pbn pbn') as [Heq | Hneq].
    subst pbn'.
    destruct (pbn_eq_dec lbn lbn') as [Heq2 | Hneq2].
      subst lbn'.
      rewrite (bit_update_bit_get_eq _ _ _ _ Hbitu) in Hget'.
      injection Hget'; intro; subst bi'; clear Hget'.
      exists pmt; trivial.
    assert (Hin'x := bmt_update_log_pbn_in_bmt_log_preserv_rev _ _ _ _ _ _ Hbmtul Hneq2 Hin').
    apply False_ind.
    apply Hnin.
    exists lbn'.
    right.
    trivial.
  rewrite (bit_update_bit_get_neq _ _ _ _ _ Hbitu (neq_sym Hneq)) in Hget'.
  destruct (pbn_eq_dec lbn lbn') as [Heq2 | Hneq2].
    subst lbn'.
    assert (Hin'' := bmt_update_log_pbn_in_bmt_log_eq _ _ _ _ Hbmtul).
    assert (pbn = pbn').
      unfold pbn_in_bmt_log in Hin', Hin''.
      destruct Hin' as [x1 Hin'].
      destruct Hin'' as [x2 Hin''].
      rewrite Hin' in Hin''.
      injection Hin''; intro; subst pbn'; trivial.
    subst pbn'.
    destruct (Hneq (refl_equal _)).
  destruct (HI5 lbn' pbn' bi' Hget') as [Hx Hy].
  apply Hy.
  eapply bmt_update_log_pbn_in_bmt_log_preserv_rev; eauto.
Qed.

Lemma I_pbn_bmt_used_preserv_bmt_update_none_log :
  forall bit bmt pbn lbn bi pmt bit' bmt',
    I_pbn_bmt_used bit bmt
    -> ~ pbn_in_bmt bmt pbn
    -> bmt_update bmt lbn (None, Some pbn) = Some bmt'
    -> bit_update bit pbn bi = Some bit'
    -> bi_state bi = bs_log lbn pmt
    -> I_pbn_bmt_used bit' bmt'.
Proof.
  unfold I_pbn_bmt_used.
  intros bit bmt pbn lbn bi pmt bit' bmt' HI5 Hnin Hbmtu Hbitu Hbi.
  intros lbn' pbn' bi' Hget'.
  split.
    intros Hin'.
    destruct (pbn_eq_dec pbn pbn') as [Heq | Hneq].
      subst pbn'.
      destruct (pbn_eq_dec lbn lbn') as [Heq2 | Hneq2].
        subst lbn'.
        destruct Hin' as [x Hbmtget'].
        rewrite (bmt_update_bmt_get_eq _ _ _ _ Hbmtu) in Hbmtget'.
        discriminate Hbmtget'.
      assert (Hin'x := bmt_update_pbn_in_bmt_lbn_neq_rev _ _ _ _ pbn _ Hbmtu Hneq2).
      assert (Hinl : pbn_in_bmt_lbn bmt' lbn' pbn).
        left; trivial.
      apply Hin'x in Hinl.
      apply False_ind.
      apply Hnin.
      exists lbn'.
      trivial.
    rewrite (bit_update_bit_get_neq _ _ _ _ _ Hbitu (neq_sym Hneq)) in Hget'.
      destruct (pbn_eq_dec lbn lbn') as [Heq2 | Hneq2].
        subst lbn'.
        destruct Hin' as [x Hbmtget'].
        rewrite (bmt_update_bmt_get_eq _ _ _ _ Hbmtu) in Hbmtget'.
        discriminate Hbmtget'.
    assert (Hin'2: pbn_in_bmt_lbn bmt' lbn' pbn').
      left; trivial.
    assert (Hin'x := bmt_update_pbn_in_bmt_lbn_neq_rev _ _ _ _ _ _ Hbmtu Hneq2 Hin'2).
    destruct (HI5 lbn' _ _ Hget') as [HI5_1 HI5_2].
    apply HI5_1; trivial.
    unfold pbn_in_bmt_data in Hin' .
    destruct Hin' as [x Hin'].
    rewrite (bmt_update_bmt_get_neq _ _ _ _ _ Hbmtu Hneq2) in Hin'.
    exists x; trivial.
  intro Hinl'.
  destruct (pbn_eq_dec pbn pbn') as [Heq | Hneq].
    subst pbn'.
    destruct (pbn_eq_dec lbn lbn') as [Heq2 | Hneq2].
      subst lbn'.
      rewrite (bit_update_bit_get_eq _ _ _ _ Hbitu) in Hget'.
      injection Hget'; intro; subst bi'; clear Hget'.
      exists pmt; trivial.
    assert (Hin'x := bmt_update_pbn_in_bmt_lbn_neq_rev _ _ _ _ pbn _ Hbmtu Hneq2).
    assert (Hin' : pbn_in_bmt_lbn bmt' lbn' pbn).
      right; trivial.
    apply Hin'x in Hin'.
    apply False_ind.
    apply Hnin.
    exists lbn'.
    trivial.
  rewrite (bit_update_bit_get_neq _ _ _ _ _ Hbitu (neq_sym Hneq)) in Hget'.
  destruct (pbn_eq_dec lbn lbn') as [Heq2 | Hneq2].
    subst lbn'.
    destruct Hinl' as [x Hinl'].
    rewrite (bmt_update_bmt_get_eq _ _ _ _ Hbmtu) in Hinl'.
    injection Hinl'; intros; subst pbn'; clear Hinl'.
    destruct (Hneq (refl_equal _)).
  destruct (HI5 lbn' pbn' bi' Hget') as [Hx Hy].
  apply Hy.
  destruct Hinl' as [x Hinl'].
  rewrite (bmt_update_bmt_get_neq _ _ _ _ _ Hbmtu Hneq2) in Hinl'.
  exists x; trivial.
Qed.

Lemma I_pbn_bmt_used_preserv_write_log_block:
  forall bit bmt pbn lbn bi bit',
    I_pbn_bmt_used bit bmt
    -> I_pbn_bmt_distinguishable bmt
    -> I_pbn_bmt_distinguishable_2 bmt
    -> bit_update bit pbn bi = Some bit'
    -> pbn_in_bmt_log bmt lbn pbn
    -> (exists pmt, bi_state bi = bs_log lbn pmt)
    -> I_pbn_bmt_used bit' bmt.
Proof.
  intros bit bmt pbn lbn bi bit' HI5 HI7_1 HI7_2 Hup Hin Hbs.
  unfold I_pbn_bmt_used in * .
  intros lbn' pbn' bi' Hget'.
  assert (pbn' = pbn \/ pbn' <> pbn).
    destruct (block_no_eq_dec pbn pbn').
      left; auto.
    right; auto.
  destruct H.
    subst pbn'.
    split.
      destruct (block_no_eq_dec lbn lbn').
        subst lbn'.
        intro Hx.
        unfold pbn_in_bmt_data in Hx.
        destruct Hx as [x Hx].
        destruct Hin as [y Hy].
        rewrite Hy in Hx.
        injection Hx.
        intros; subst x y.
        destruct (HI7_2 lbn pbn pbn Hy (refl_equal _)).
      intros Hx.
      destruct (HI7_1 lbn lbn' pbn pbn H (or_intror Hin) (or_introl Hx) (refl_equal _)).
    intros Hx.
    assert (bi = bi').
      rewrite (bit_update_bit_get_eq _ _ _ _ Hup) in Hget'.
      injection Hget'; auto.
    subst bi'.
    assert (lbn' = lbn \/ lbn <> lbn').
      destruct (block_no_eq_dec lbn lbn'); auto.
    destruct H.
      subst lbn'.
      trivial.
    assert (HF := HI7_1 lbn lbn' pbn pbn H).
    apply False_ind.
    apply HF.
    right; trivial.
    right; trivial.
    trivial.
  apply HI5.
  erewrite <- bit_update_bit_get_neq; eauto.
Qed.

(* Lemma lbn_pbn_in_bmt_after_bmt_update_lbn : *)
Lemma pbn_in_bmt_after_bmt_update_lbn :
  forall bmt lbn pbn bmr bmt',
    pbn_in_bmt_lbn bmt lbn pbn
    -> I_pbn_bmt_distinguishable bmt
    -> bmt_update bmt lbn bmr = Some bmt'
    -> ~ pbn_in_bmr pbn bmr
    -> ~ pbn_in_bmt bmt' pbn.
Proof.
  intros bmt lbn pbn bmr bmt' Hin HI71 Hu Hnin.
  intro Hnin'.
  unfold pbn_in_bmt in * .
  destruct Hnin' as [lbn' Hnin'].
  destruct (pbn_eq_dec lbn lbn') as [Heq | Hneq].
  subst lbn'.
    apply Hnin.
    destruct (pbn_in_bmt_lbn_bmt_get _ _ _ Hnin') as [bmrx [Hget' Hxin]].
    rewrite (bmt_update_bmt_get_eq _ _ _ _ Hu) in Hget'.
    injection Hget'; intro; subst bmrx; clear Hget'.
    trivial.
  assert (Hin':= bmt_update_pbn_in_bmt_lbn_neq_rev _ _ _ _ _ _ Hu Hneq Hnin').
  assert (Hx := HI71  _ _ _ _ Hneq Hin Hin').
  apply Hx; trivial.
Qed.

(* ---------------------------------------------------------------- *)

Lemma I_pbn_habitation_implies_I_bmt_fbq_distinguiable:  (* Admissible Invariant *)
  forall bmt fbq ,
    I_pbn_habitation bmt fbq
    -> I_bmt_fbq_distinguiable bmt fbq.
Proof.
  intros bmt fbq HI6 pbn pbn' lbn Hpbn Hpbn' Hinbmt Hinfbq.
  assert (Hx := I_pbn_habitation_in_fbq_implies_not_in_bmt pbn' bmt fbq Hpbn' HI6 Hinfbq); trivial.
  intro Heq.
  subst pbn'.
  apply Hx.
  exists lbn.
  destruct Hinbmt.
  left; trivial.
  right; trivial.
Qed.

(* ---------------------------------------------------------------- *)
(* I8 Lemmas *)

Lemma I_pbn_fbq_distinguishable_implies_fbq_deq_fbq_not_in :
  forall fbq pbn fbq',
    I_pbn_fbq_distinguishable fbq
    -> fbq_deq fbq = Some (pbn, fbq')
    -> fbq_in fbq' pbn = false.
Proof.
  unfold I_pbn_fbq_distinguishable.
  intros fbq pbn fbq' HI8 Hdeq.
  assert (Hg1 : fbq_get fbq 0 = Some pbn).
    apply fbq_deq_fbq_get with fbq'; trivial.
  destruct (fbq_in fbq' pbn) eqn:HF; trivial.
  destruct (fbq_in_fbq_get _ _ HF) as [i Hgi].
  assert (Hg2:= fbq_get_fbq_rdeq_fbq_get _ _ _ _ _ Hgi Hdeq).
  apply False_ind.
  apply (HI8 0 (S i) pbn pbn); trivial.
Qed.

Lemma I_pbn_fbq_distinguishable_preserv_fbq_enq :
  forall fbq pbn fbq',
    I_pbn_fbq_distinguishable fbq
    -> fbq_in fbq pbn = false
    -> fbq_enq fbq pbn = Some fbq'
    -> I_pbn_fbq_distinguishable fbq'.
Proof.
  unfold I_pbn_fbq_distinguishable.
  intros fbq pbn fbq' HI8 Hin Henq.
  intros i1 i2 pbn1 pbn2 Hi1i2  Hg1 Hg2.

  destruct (fbq_get_fbq_enq_fbq_get_rev fbq fbq' i1 pbn1 pbn Henq Hg1) as [[Hpbn1  Hi1] | Hg1' ].
    destruct (fbq_get_fbq_enq_fbq_get_rev fbq fbq' i2 pbn2 pbn Henq Hg2) as [[Hpbn2  Hi2] | Hg2' ].
      subst i1 i2.
      destruct (Hi1i2 (refl_equal _)).
    subst pbn1.
    intro HF.
    subst pbn2.
    apply (fbq_not_in_fbq_get_some_implies_false _ _ Hin _ Hg2').
  destruct (fbq_get_fbq_enq_fbq_get_rev fbq fbq' i2 pbn2 pbn Henq Hg2) as [[Hpbn2  Hi2] | Hg2' ].
    subst pbn2.
    intro HF.
    subst pbn1.
    apply (fbq_not_in_fbq_get_some_implies_false _ _ Hin _ Hg1').
  apply (HI8 i1 i2); trivial.
Qed.

Lemma I_pbn_fbq_distinguishable_preserv_fbq_deq:
  forall fbq pbn fbq',
    I_pbn_fbq_distinguishable fbq
    -> fbq_deq fbq = Some (pbn, fbq')
    -> I_pbn_fbq_distinguishable fbq'.
Proof.
  unfold I_pbn_fbq_distinguishable.
  intros fbq pbn fbq' HI8 Hdeq.
  intros i1 i2 pbn1 pbn2 Hi1i2  Hg1 Hg2.
  apply (HI8 (S i1) (S i2) pbn1 pbn2).
    auto with arith.
    apply (fbq_get_fbq_deq_fbq_get_rev _ _ _ _ _ Hdeq); trivial.
  apply (fbq_get_fbq_deq_fbq_get_rev _ _ _ _ _ Hdeq); trivial.
Qed.

(* ---------------------------------------------------------------- *)
(* I6 Lemmas *)
Lemma I_pbn_habitation_alloc_merge : (* an ad hoc lemma *)
  forall bmt fbq lbn pbnx pbn1 pbn2 bmt' fbq' fbq'' fbq''',
    I_pbn_habitation bmt fbq
    -> I_pbn_bmt_distinguishable bmt
    -> I_pbn_bmt_distinguishable_2 bmt
    -> I_pbn_fbq_distinguishable fbq
    -> valid_block_no pbn1
    -> valid_block_no pbn2
    -> valid_block_no pbnx
    -> bmt_get bmt lbn = Some (Some pbn1, Some pbn2)
    -> fbq_deq fbq = Some (pbnx, fbq')
    -> bmt_update bmt lbn (Some pbnx, None) = Some bmt'
    -> fbq_enq fbq' pbn2 = Some fbq''
    -> fbq_enq fbq'' pbn1 = Some fbq'''
    -> I_pbn_habitation bmt' fbq'''.
Proof.
  intros bmt fbq lbn pbnx pbn1 pbn2 bmt' fbq' fbq'' fbq'''.
  intros HI6 HI7_1 HI7_2 HI8 Hpbn1 Hpbn2 Hpbnx Hlbn Hdeq Hbmtup Henq1 Henq2.
  unfold I_pbn_habitation in * .
  intros pbn Hpbnv.
  assert (Hn12 : pbn1<>pbn2).
     apply (HI7_2 lbn pbn1 pbn2); trivial.
  assert (Hn1x : pbn1<>pbnx).
    intro HF.
    subst pbnx.
    destruct (HI6 pbn1 Hpbn1) as [Hx | Hx].
      destruct Hx as [[lbn' Hy1] Hy2].
      rewrite (fbq_deq_fbq_in fbq pbn1 fbq') in Hy2; trivial.
      discriminate.
    destruct Hx as [Hx1 Hx2].
    apply (Hx1 lbn).
    left.
    exists (Some pbn2).
    trivial.
  assert (Hn2x : pbn2<>pbnx).
    intro HF.
    subst pbnx.
    destruct (HI6 pbn2 Hpbn2) as [Hx | Hx].
      destruct Hx as [[lbn' Hy1] Hy2].
      rewrite (fbq_deq_fbq_in fbq pbn2 fbq') in Hy2; trivial.
      discriminate.
    destruct Hx as [Hx1 Hx2].
    apply (Hx1 lbn).
    right.
    exists (Some pbn1).
    trivial.
  destruct (block_no_eq_dec pbn pbn1)  as [H1 | H2].
    subst pbn.
    right.
    assert (Hx : pbn_not_in_bmt bmt' pbn1).
      assert (Hin : pbn_in_bmt_lbn bmt lbn pbn1).
        left.
        exists (Some pbn2).
        trivial.
      assert (Hnin: ~ pbn_in_bmr pbn1 (Some pbnx, None)).
        unfold pbn_in_bmr.
        trivial.
      apply (pbn_in_bmt_after_bmt_update_lbn _ _ _ _ _ Hin HI7_1 Hbmtup Hnin).
    split.
      intro lbn'.
      unfold pbn_not_in_bmt in Hx.
      unfold pbn_in_bmt in Hx.
      intro HF.
      apply Hx.
      exists lbn'; trivial.
      apply fbq_enq_fbq_in with fbq''; trivial.
  destruct (pbn_eq_dec pbn pbn2) as [H21 | H22].
    subst pbn.
    right.
    assert (Hx : pbn_not_in_bmt bmt' pbn2).
      assert (Hin : pbn_in_bmt_lbn bmt lbn pbn2).
        right.
        exists (Some pbn1).
        trivial.
      assert (Hnin: ~ pbn_in_bmr pbn2 (Some pbnx, None)).
        unfold pbn_in_bmr.
        trivial.
      apply (pbn_in_bmt_after_bmt_update_lbn _ _ _ _ _ Hin HI7_1 Hbmtup Hnin).
    split.
      intro lbn'.
      unfold pbn_not_in_bmt in Hx.
      unfold pbn_in_bmt in Hx.
      intro HF.
      apply Hx.
      exists lbn'; trivial.
      rewrite (fbq_in_preserv_fbq_enq pbn2 fbq'' pbn1 fbq'''); eauto.
      apply fbq_enq_fbq_in with fbq'; trivial.
  assert (Hdec : pbn = pbnx \/ pbn <> pbnx).
    apply (pbn_eq_dec pbn pbnx); trivial.
  destruct Hdec as [H31 | H32].
    subst pbnx.
    left.
    split.
      exists lbn.
      unfold pbn_in_bmt_lbn.
      left.
      exists None.
      apply bmt_update_bmt_get_eq with bmt; trivial.
    apply (fbq_not_in_preserv_fbq_enq fbq'' pbn fbq''' pbn1); auto.
    apply (fbq_not_in_preserv_fbq_enq fbq' pbn fbq'' pbn2); auto.
    apply (I_pbn_fbq_distinguishable_implies_fbq_deq_fbq_not_in fbq pbn fbq'); trivial.

  destruct (HI6 pbn Hpbnv) as [H | H].
    destruct H as [[lbn' Hlbn'] Hqnin].
    assert (lbn' <> lbn).
      intro HF.
      subst lbn'.
      unfold pbn_in_bmt_lbn in Hlbn'.
      destruct Hlbn' as [Hlbn' | Hlbn'].
        destruct Hlbn' as [x Hlbn'].
        rewrite Hlbn in Hlbn'.
        injection Hlbn'.
        intros Hx1 Hx2.
        apply H2.
        auto.
      destruct Hlbn' as [x Hlbn'].
      rewrite Hlbn in Hlbn'.
      injection Hlbn'.
      intros Hx1 Hx2.
      apply H22.
      subst pbn2.
      trivial.
    left.
    split.
      exists lbn'.
      apply (bmt_update_pbn_in_bmt_lbn_neq bmt lbn _ bmt' lbn' pbn Hbmtup H) in Hlbn'; eauto.
    apply (fbq_not_in_preserv_fbq_enq fbq'' pbn fbq''' pbn1); auto.
    apply (fbq_not_in_preserv_fbq_enq fbq' pbn fbq'' pbn2); auto.
    apply (fbq_not_in_preserv_fbq_deq fbq pbn fbq' pbnx); auto.
  right.
  destruct H as [Hx1 Hx2].
  split.
    intros lbn'.
    intro HF.
    apply (Hx1 lbn').
    assert (lbn' <> lbn).
      intros Hy.
      subst lbn'.
      assert (bmt_get bmt' lbn = Some (Some pbnx, None)).
        apply (bmt_update_bmt_get_eq bmt lbn _ bmt' Hbmtup); trivial.
      unfold pbn_in_bmt_lbn in HF.
      destruct HF as [HF | HF].
        unfold pbn_in_bmt_data in HF.
        destruct HF as [x Hg].
        rewrite Hg in H.
        injection H.
        intros.
        apply H32.
        trivial.
      unfold pbn_in_bmt_log in HF.
      destruct HF as [x Hg].
      rewrite Hg in H.
      discriminate.
    apply (bmt_update_pbn_in_bmt_lbn_neq_rev bmt bmt' lbn lbn' pbn _ Hbmtup) in HF; eauto.

  rewrite (fbq_in_preserv_fbq_enq pbn fbq'' pbn1 fbq'''); auto.
  rewrite (fbq_in_preserv_fbq_enq pbn fbq' pbn2 fbq''); auto.
  rewrite (fbq_in_preserv_fbq_deq fbq pbn fbq' pbnx ); auto.
Qed.

Lemma I_pbn_habitation_alloc_merge_2 : (* an ad hoc lemma *)
  forall bmt fbq lbn pbnx pbn2 bmt' fbq' fbq'',
    I_pbn_habitation bmt fbq
    -> I_pbn_bmt_distinguishable bmt
    -> I_pbn_bmt_distinguishable_2 bmt
    -> I_pbn_fbq_distinguishable fbq
    -> valid_block_no pbn2
    -> valid_block_no pbnx
    -> bmt_get bmt lbn = Some (None, Some pbn2)
    -> fbq_deq fbq = Some (pbnx, fbq')
    -> bmt_update bmt lbn (Some pbnx, None) = Some bmt'
    -> fbq_enq fbq' pbn2 = Some fbq''
    -> I_pbn_habitation bmt' fbq''.
Proof.
  intros bmt fbq lbn pbnx pbn2 bmt' fbq' fbq''.
  intros HI6 HI7_1 HI7_2 HI8 Hpbn2 Hpbnx Hlbn Hdeq Hbmtup Henq.
  unfold I_pbn_habitation in * .
  intros pbn Hpbnv.
  assert (Hn2x : pbn2<>pbnx).
    intro HF.
    subst pbnx.
    destruct (HI6 pbn2 Hpbn2) as [Hx | Hx].
      destruct Hx as [[lbn' Hy1] Hy2].
      rewrite (fbq_deq_fbq_in fbq pbn2 fbq') in Hy2; trivial.
      discriminate.
    destruct Hx as [Hx1 Hx2].
    apply (Hx1 lbn).
    right.
    exists (None).
    trivial.
  destruct (pbn_eq_dec pbn pbn2) as [H21 | H22].
    subst pbn.
    right.
    assert (Hx : pbn_not_in_bmt bmt' pbn2).
      assert (Hin : pbn_in_bmt_lbn bmt lbn pbn2).
        right.
        exists None.
        trivial.
      assert (Hnin: ~ pbn_in_bmr pbn2 (Some pbnx, None)).
        unfold pbn_in_bmr.
        trivial.
      apply (pbn_in_bmt_after_bmt_update_lbn _ _ _ _ _ Hin HI7_1 Hbmtup Hnin).
    split.
      intro lbn'.
      unfold pbn_not_in_bmt in Hx.
      unfold pbn_in_bmt in Hx.
      intro HF.
      apply Hx.
      exists lbn'; trivial.
      apply fbq_enq_fbq_in with fbq'; trivial.
  assert (Hdec : pbn = pbnx \/ pbn <> pbnx).
    apply (pbn_eq_dec pbn pbnx); trivial.
  destruct Hdec as [H31 | H32].
    subst pbnx.
    left.
    split.
      exists lbn.
      unfold pbn_in_bmt_lbn.
      left.
      exists None.
      apply bmt_update_bmt_get_eq with bmt; trivial.
    apply (fbq_not_in_preserv_fbq_enq fbq' pbn fbq'' pbn2); auto.

    apply (I_pbn_fbq_distinguishable_implies_fbq_deq_fbq_not_in fbq pbn fbq'); trivial.

  destruct (HI6 pbn Hpbnv) as [H | H].
    destruct H as [[lbn' Hlbn'] Hqnin].
    assert (lbn' <> lbn).
      intro HF.
      subst lbn'.
      unfold pbn_in_bmt_lbn in Hlbn'.
      destruct Hlbn' as [Hlbn' | Hlbn'].
        destruct Hlbn' as [x Hlbn'].
        rewrite Hlbn in Hlbn'.
        discriminate.
      destruct Hlbn' as [x Hlbn'].
      rewrite Hlbn in Hlbn'.
      injection Hlbn'.
      intros Hx1 Hx2.
      apply H22.
      subst pbn2.
      trivial.
    left.
    split.
      exists lbn'.
      apply (bmt_update_pbn_in_bmt_lbn_neq bmt lbn _ bmt' lbn' pbn Hbmtup H) in Hlbn'; eauto.
    apply (fbq_not_in_preserv_fbq_enq fbq' pbn fbq'' pbn2); auto.
    apply (fbq_not_in_preserv_fbq_deq fbq pbn fbq' pbnx); auto.
  right.
  destruct H as [Hx1 Hx2].
  split.
    intros lbn'.
    intro HF.
    apply (Hx1 lbn').
    assert (lbn' <> lbn).
      intros Hy.
      subst lbn'.
      assert (bmt_get bmt' lbn = Some (Some pbnx, None)).
        apply (bmt_update_bmt_get_eq bmt lbn _ bmt' Hbmtup); trivial.
      unfold pbn_in_bmt_lbn in HF.
      destruct HF as [HF | HF].
        unfold pbn_in_bmt_data in HF.
        destruct HF as [x Hg].
        rewrite Hg in H.
        injection H.
        intros.
        apply H32.
        trivial.
      unfold pbn_in_bmt_log in HF.
      destruct HF as [x Hg].
      rewrite Hg in H.
      discriminate.
    apply (bmt_update_pbn_in_bmt_lbn_neq_rev bmt bmt' lbn lbn' pbn _ Hbmtup) in HF; eauto.

  rewrite (fbq_in_preserv_fbq_enq pbn fbq' pbn2 fbq''); auto.
  rewrite (fbq_in_preserv_fbq_deq fbq pbn fbq' pbnx ); auto.
Qed.

Lemma I_pbn_habitation_preserv_bmt_update_log:
  forall bmt fbq lbn pbn1 pbn2 bmt' fbq',
    I_pbn_habitation bmt fbq
    -> I_pbn_bmt_distinguishable bmt
    -> I_pbn_bmt_distinguishable_2 bmt
    -> I_pbn_fbq_distinguishable fbq
    -> valid_block_no pbn1
    -> valid_block_no pbn2
    -> bmt_get bmt lbn = Some (Some pbn1, None)
    -> fbq_deq fbq = Some (pbn2, fbq')
    -> bmt_update_log bmt lbn pbn2 = Some bmt'
    -> I_pbn_habitation bmt' fbq'.
Proof.
  intros bmt fbq lbn pbn1 pbn2 bmt' fbq'.
  intros HI6 HI7_1 HI7_2 HI8 Hpbn1 Hpbn2 Hget Hdeq Hul.
  unfold I_pbn_habitation in * .
  intros pbn Hpbnv.
  assert (Hn1x : pbn1<>pbn2).
    intro HF.
    subst pbn2.
    destruct (HI6 pbn1 Hpbn1) as [Hx | Hx].
      destruct Hx as [[lbn' Hy1] Hy2].
      rewrite (fbq_deq_fbq_in fbq pbn1 fbq') in Hy2; trivial.
      discriminate.
    destruct Hx as [Hx1 Hx2].
    apply (Hx1 lbn).
    left.
    exists (None).
    trivial.
  destruct (pbn_eq_dec pbn pbn1) as [H11 | H12].
    subst pbn.
    left.
    split.
      exists lbn.
      left.
      apply (bmt_update_log_pbn_in_bmt_data_preserv _ _ _ _ _ _ Hul).
      exists None; trivial.
    apply (fbq_not_in_preserv_fbq_deq fbq pbn1 fbq' pbn2); auto.
    destruct (HI6 pbn1 Hpbn1).
      destruct H as [[lbn' H1] H2]; trivial.
    destruct H as [H1 H2].
    apply False_ind.
    apply (H1 lbn).
    left; exists (None); trivial.
  destruct (pbn_eq_dec pbn pbn2) as [H21 | H22].
    subst pbn.
    left.
    split.
      exists lbn.
      right.
      apply (bmt_update_log_pbn_in_bmt_log_eq _ _ _ _ Hul).
    apply (I_pbn_fbq_distinguishable_implies_fbq_deq_fbq_not_in fbq pbn2 fbq'); trivial.

  destruct (HI6 pbn Hpbnv) as [H | H].
    destruct H as [[lbn' Hlbn'] Hqnin].
    assert (lbn' <> lbn).
      intro HF.
      subst lbn'.
      unfold pbn_in_bmt_lbn in Hlbn'.
      destruct Hlbn' as [Hlbn' | Hlbn'].
        destruct Hlbn' as [x Hlbn'].
        rewrite Hget in Hlbn'.
        apply H12.
        injection Hlbn'; auto.
      destruct Hlbn' as [x Hlbn'].
      rewrite Hget in Hlbn'.
      discriminate.
    left.
    split.
      exists lbn'.
      apply (bmt_update_log_pbn_in_bmt_lbn_neq bmt lbn _ bmt' lbn' pbn Hul (neq_sym H)) in Hlbn'; eauto.
    apply (fbq_not_in_preserv_fbq_deq fbq pbn fbq' pbn2); auto.
  right.
  destruct H as [Hx1 Hx2].
  split.
    intros lbn'.
    intro HF.
    apply (Hx1 lbn').
    assert (lbn' <> lbn).
      intros Hy.
      subst lbn'.
      destruct HF.
        apply (Hx1 lbn).
        left.
        apply (bmt_update_log_pbn_in_bmt_data_preserv_rev _ _ _ _ _ _ Hul H); auto.
      apply H22.
      apply pbn_in_bmt_log_inj with bmt' lbn; trivial.
      apply bmt_update_log_pbn_in_bmt_log_eq with bmt; auto.
    apply (bmt_update_log_pbn_in_bmt_lbn_neq_rev _ _ _ _ _ _ Hul (neq_sym H)) in HF; eauto.
  rewrite (fbq_in_preserv_fbq_deq fbq pbn fbq' pbn2 ); auto.
Qed.

Lemma I_pbn_habitation_preserv_bmt_update_log_case2:
  forall bmt fbq lbn pbn2 bmt' fbq',
    I_pbn_habitation bmt fbq
    -> I_pbn_bmt_distinguishable bmt
    -> I_pbn_bmt_distinguishable_2 bmt
    -> I_pbn_fbq_distinguishable fbq
    -> valid_block_no pbn2
    -> bmt_get bmt lbn = Some (None, None)
    -> fbq_deq fbq = Some (pbn2, fbq')
    -> bmt_update_log bmt lbn pbn2 = Some bmt'
    -> I_pbn_habitation bmt' fbq'.
Proof.
  intros bmt fbq lbn pbn2 bmt' fbq'.
  intros HI6 HI7_1 HI7_2 HI8 Hpbn2 Hget Hdeq Hul.
  unfold I_pbn_habitation in * .
  intros pbn Hpbnv.
  destruct (pbn_eq_dec pbn pbn2) as [H21 | H22].
    subst pbn.
    left.
    split.
      exists lbn.
      right.
      apply (bmt_update_log_pbn_in_bmt_log_eq _ _ _ _ Hul).
    apply (I_pbn_fbq_distinguishable_implies_fbq_deq_fbq_not_in fbq pbn2 fbq'); trivial.

  destruct (HI6 pbn Hpbnv) as [H | H].
    destruct H as [[lbn' Hlbn'] Hqnin].
    assert (lbn' <> lbn).
      intro HF.
      subst lbn'.
      unfold pbn_in_bmt_lbn in Hlbn'.
      destruct Hlbn' as [Hlbn' | Hlbn'].
        destruct Hlbn' as [x Hlbn'].
        rewrite Hget in Hlbn'.
        discriminate.
      destruct Hlbn' as [x Hlbn'].
      rewrite Hget in Hlbn'.
      discriminate.
    left.
    split.
      exists lbn'.
      apply (bmt_update_log_pbn_in_bmt_lbn_neq bmt lbn _ bmt' lbn' pbn Hul (neq_sym H)) in Hlbn'; eauto.
    apply (fbq_not_in_preserv_fbq_deq fbq pbn fbq' pbn2); auto.
  right.
  destruct H as [Hx1 Hx2].
  split.
    intros lbn'.
    intro HF.
    apply (Hx1 lbn').
    assert (lbn' <> lbn).
      intros Hy.
      subst lbn'.
      destruct HF.
        apply (Hx1 lbn).
        left.
        apply (bmt_update_log_pbn_in_bmt_data_preserv_rev _ _ _ _ _ _ Hul H); auto.
      apply H22.
      apply pbn_in_bmt_log_inj with bmt' lbn; trivial.
      apply bmt_update_log_pbn_in_bmt_log_eq with bmt; auto.
    apply (bmt_update_log_pbn_in_bmt_lbn_neq_rev _ _ _ _ _ _ Hul (neq_sym H)) in HF; eauto.
  rewrite (fbq_in_preserv_fbq_deq fbq pbn fbq' pbn2 ); auto.
Qed.

Lemma I_valid_lbn_has_entry_in_bmt_preserv_bmt_update :
  forall bmt lbn bmr bmt',
    I_valid_lbn_has_entry_in_bmt bmt
    -> bmt_update bmt lbn bmr = Some bmt'
    -> I_valid_lbn_has_entry_in_bmt bmt'.
Proof.
  unfold I_valid_lbn_has_entry_in_bmt.
  intros bmt lbn bmr bmt' HI10 Hu.
  intros lbn'.
  destruct (pbn_eq_dec lbn lbn') as [Heq | Hneq ].
    subst lbn'.
    destruct (HI10 lbn) as [H1 H2].
    split.
      intro Hlbn.
      rewrite (bmt_update_bmt_get_eq _ _ _ _ Hu).
      exists bmr; trivial.
    intros [bme Hlbn].
    apply H2; trivial.
    apply (bmt_update_bmt_get_eq_rev _ _ _ _ Hu); trivial.
  split.
    intro Hlbn'.
    destruct (HI10 lbn') as [H1 H2].
    rewrite (bmt_update_bmt_get_neq _ _ _ _ _ Hu Hneq).
    apply H1; trivial.
  intros [bmr' H'].
  destruct (HI10 lbn') as [H1 H2].
  apply H2.
  rewrite (bmt_update_bmt_get_neq _ _ _ _ _ Hu Hneq) in H'.
  exists bmr'; trivial.
Qed.

Lemma I_valid_lbn_has_entry_in_bmt_preserv_bmt_update_log :
  forall bmt lbn pbn bmt',
    I_valid_lbn_has_entry_in_bmt bmt
    -> bmt_update_log bmt lbn pbn = Some bmt'
    -> I_valid_lbn_has_entry_in_bmt bmt'.
Proof.
  unfold I_valid_lbn_has_entry_in_bmt.
  intros bmt lbn pbn bmt' HI10 Hul.
  intros lbn'.
  destruct (pbn_eq_dec lbn lbn') as [Heq | Hneq ].
    subst lbn'.
    destruct (HI10 lbn) as [H1 H2].
    split.
      intro Hlbn.
      assert (Hx := bmt_update_log_pbn_in_bmt_log_eq _ _ _ _ Hul).
      destruct Hx as [x Hl].
      rewrite Hl.
      eexists; eauto.
    intros [bme Hlbn].
    apply H2; trivial.
    apply (bmt_update_log_bmt_get_eq_rev _ _ _ _ Hul); trivial.
  split.
    intro Hlbn'.
    destruct (HI10 lbn') as [H1 H2].
    rewrite (bmt_update_log_bmt_get_neq _ _ _ _ _ Hul Hneq).
    apply H1; trivial.
  intros [bmr' H'].
  destruct (HI10 lbn') as [H1 H2].
  apply H2.
  rewrite (bmt_update_log_bmt_get_neq _ _ _ _ _ Hul Hneq) in H'.
  exists bmr'; trivial.
Qed.

(* ---------------------------------------------------------------- *)

Lemma I_pbn_bmt_used_implies_pbn_is_used :
  forall bit bmt pbn lbn bi,
  I_pbn_bmt_used bit bmt
  -> bit_get bit pbn = Some bi
  -> pbn_in_bmt_lbn bmt lbn pbn
  -> check_used_block bi = true.
Proof.
  intros.
  unfold I_pbn_bmt_used in H.
  destruct (H lbn pbn bi H0) as [Hx Hy].
  unfold pbn_in_bmt_lbn in H1.
  destruct H1.
    unfold check_used_block.
    rewrite (Hx H1). trivial.
  destruct (Hy H1) as [pmt Hbs].
  unfold check_used_block.
  rewrite Hbs; trivial.
Qed.

Lemma J_bi_block_coherent_preserv_used_set_invalid :
  forall bit c pbn bi bit',
    J_bi_block_coherent c bit
    -> bit_get bit pbn = Some bi
    -> check_used_block bi = true
    -> bit_update bit pbn (bi_set_state bi bs_invalid) = Some bit'
    -> J_bi_block_coherent c bit'.
Proof.
  intros bit c pbn bi bit' HJ Hget Hck Hup.
  unfold J_bi_block_coherent in * .
  intros pbn' bi' Hget'.
  unfold chip_bi_coherent.
  assert (Hdec: pbn = pbn' \/ pbn <> pbn').
    apply (pbn_eq_dec pbn pbn'); trivial.
  destruct Hdec as [Heq | Hneq].
    subst pbn'.
    assert (bi' = bi_set_state bi bs_invalid).
      rewrite (bit_update_bit_get_eq bit pbn (bi_set_state bi bs_invalid) bit') in Hget'; trivial.
      injection Hget'.
      intros; auto.
    assert (Hx := HJ pbn bi Hget).
    unfold chip_bi_coherent in Hx.
    destruct Hx as [b [Hb Hx]].
    exists b.
    split; trivial.
    rewrite H.
    unfold bi_set_state.
    simpl.
    destruct (check_used_implies_check_data_log Hck) as [Hck1 | Hck2].
      unfold check_data_block in Hck1.
      destruct (bi_state bi); try discriminate.
      unfold block_coherent_data in Hx.
      destruct Hx as [lbn' [_ [_ [Hx _]]]].
      trivial.
    unfold check_log_block in Hck2.
    destruct (bi_state bi); try discriminate.
    unfold block_coherent_log in Hx.
    destruct Hx as [pmt' [lbn' [_ [_ [Hx _]]]]].
    trivial.
  apply HJ.
  rewrite <- (bit_update_bit_get_neq bit pbn' bit' (bi_set_state bi bs_invalid) pbn) ; eauto.
Qed.

Lemma J_bi_block_coherent_preserv_write_block_log :
  forall c bit pbn bi b' c' bit',
    J_bi_block_coherent c bit
    -> bit_update bit pbn bi = Some bit'
    -> chip_get_block c' pbn = Some b'
    -> (forall pbn' : block_no,
          pbn' <> pbn -> chip_get_block c' pbn' = chip_get_block c pbn')
    -> block_coherent_log bi b'
    -> J_bi_block_coherent c' bit'.
Proof.
  intros.
  unfold J_bi_block_coherent in * .
  intros pbn'  bi' Hgetbi'.
  unfold chip_bi_coherent in * .
  assert (Hdec: pbn' = pbn \/ pbn' <> pbn).
    destruct (nat_eq_dec pbn' pbn).
    left; trivial.
    right; trivial.
  destruct Hdec as [Heq | Hneq].
    subst pbn'.
    assert (bi = bi').
      erewrite bit_update_bit_get_eq in Hgetbi'; eauto.
      injection Hgetbi'.
      trivial.
    subst bi'.
    exists b'.
    split; trivial.
    unfold block_coherent_log in H3.
    destruct ((fun x => x) H3) as [pmt [lbn [H4 [H5 H6]]]].
    rewrite H4.
    trivial.
  assert (H4: bit_get bit pbn' = Some bi').
    erewrite <- (bit_update_bit_get_neq bit pbn' bit' bi pbn); eauto.
  destruct (H pbn' bi' H4) as [b [Hb Hx]].
  exists b.
  split; trivial.
  erewrite H2; eauto.
Qed.

Lemma J_bi_block_coherent_preserv_bit_update_merge :
  forall c' bit' pbn_free bi' c'' bit'' lbn,
    J_bi_block_coherent c' bit'
    -> (exists b' : block,
          chip_get_block c'' pbn_free = Some b' /\
          block_coherent_data_partial PAGES_PER_BLOCK b')
    -> (forall pbn' : block_no,
        pbn' <> pbn_free -> chip_get_block c'' pbn' = chip_get_block c' pbn')
    -> bit_get bit' pbn_free = Some bi'
    -> bit_update bit' pbn_free (mk_bi (bs_data lbn) PAGES_PER_BLOCK (bi_erase_count bi')) = Some bit''
    -> J_bi_block_coherent c'' bit''.
Proof.
  intros c bit pbn bi c' bit' lbn.
  intros HJ Hm1 Hm2 Hget Hup.
  unfold J_bi_block_coherent in * .
  intros pbn' bi' Hget'.
  destruct (nat_eq_dec pbn pbn') as [Heq | Hneq].
  subst pbn'.
  rewrite (bit_update_bit_get_eq bit pbn _ bit' Hup) in Hget'.
  inversion Hget'.
  subst bi'.
  unfold chip_bi_coherent.
  simpl.
  destruct Hm1 as [b [Hb Hco]].
  exists b.
  split; trivial.
  unfold block_coherent_data.
  simpl.
  exists lbn.
  split; trivial.
  unfold block_coherent_data_partial in Hco.
  destruct Hco as [Hnb [Hbs Hco]].
  split; auto.
  split; auto.
  split; auto.
  intros loc Hloc.
  destruct (Hco loc Hloc) as [Hco1 Hco2].
  apply Hco1.
  unfold valid_page_off in Hloc.
  exact Hloc.

  assert (pbn' <> pbn).
    auto.
  unfold chip_bi_coherent.
  rewrite (bit_update_bit_get_neq bit pbn' bit' _ pbn Hup H) in Hget'.
  assert (chip_bi_coherent c pbn' bi').
    apply HJ; trivial.
  unfold chip_bi_coherent in H0.
  destruct H0 as [b [Hb Hx]].
  exists b.
  split; trivial.
  rewrite Hm2; trivial.
Qed.

(* used in the 2nd case of alloc_block *)
Lemma J_bi_block_coherent_preserv_erased_set_erased:
  forall c bit pbn bi bit' bi',
    J_bi_block_coherent c bit
    -> bit_get bit pbn = Some bi
    -> bi_state bi = bs_erased
    -> bi' = mk_bi bs_erased 0 (bi_erase_count bi)
    -> bit_update bit pbn bi' = Some bit'
    -> J_bi_block_coherent c bit'.
Proof.
  intros c bit pbn bi bit' bi' HJ Hget Hbis Hbi' Hup.
  unfold J_bi_block_coherent in * .
  rename bi' into bix.
  intros pbn' bi' Hget'.
  destruct (pbn_eq_dec pbn pbn') as [Heq | Hneq].
    subst pbn'.
    rewrite (bit_update_bit_get_eq _ _ _ _ Hup) in Hget'.
    injection Hget'.
    intro; subst bix.
    subst bi'.
    unfold chip_bi_coherent.
    simpl.
    clear Hget'.
    assert (Hx := HJ pbn bi Hget).
    unfold chip_bi_coherent in Hx.
    destruct Hx as [b [Hb Hx]].
    exists b.
    split; trivial.
    rewrite Hbis in Hx.
    unfold block_coherent_erased in * .
    simpl.
    destruct Hx as [H1 [H2 [H3 [H4 H5]]]].
    rewrite H4.
    rewrite H3.
    split; trivial.
    split; trivial.
    split; trivial.
    split; trivial.
  rewrite (bit_update_bit_get_neq bit pbn' bit' _ pbn Hup (neq_sym Hneq)) in Hget'.
  apply HJ; trivial.
Qed.

Lemma J_bi_block_coherent_preserv_bit_update_chip_erase:
  forall c bit pbn bi b c' bit' bi',
    J_bi_block_coherent c bit
    -> bit_get bit pbn = Some bi
    -> bi' = mk_bi bs_erased 0 (S (bi_erase_count bi))
    -> bit_update bit pbn bi' = Some bit'
    -> chip_get_block c pbn = Some b
    -> chip_set_block c pbn (erased_block (block_erase_count b)) = Some c'
    -> J_bi_block_coherent c' bit'.
Proof.
  intros c bit pbn bi b c' bit' bix.
  unfold J_bi_block_coherent.
  intros HJ Hget Hbi' Hup Hgetc Hsetc.
  intros pbn' bi' Hget'.
  destruct (chip_set_block_elim c pbn _ c' Hsetc) as [Hbv [Hgetc'1 Hgetc'2]].
  destruct (pbn_eq_dec pbn pbn') as [Heq | Hneq].
    subst pbn'.
    rewrite (bit_update_bit_get_eq _ _ _ _ Hup) in Hget'.
    injection Hget'.
    intro H; subst bi'; clear Hget'.
    unfold chip_bi_coherent.
    exists (erased_block (block_erase_count b)).
    split; trivial.
    subst bix; simpl.
    unfold block_coherent_erased.
    simpl.
    split; trivial.
    split; trivial.
    split; trivial.
    split; trivial.
    intros loc Hloc.
    unfold erased_block.
    unfold block_get_page.
    rewrite Hloc.
    unfold block_pages.
    exists init_page.
    split.
    assert (Hx: loc < PAGES_PER_BLOCK).
      unfold valid_page_off in Hloc.
      unfold bvalid_page_off in Hloc.
      desbnat.
      trivial.
    rewrite (@list_get_list_repeat_list _ _ _ _ Hx).
    trivial.
    unfold init_page.
    simpl; trivial.
  rewrite (bit_update_bit_get_neq bit pbn' bit' _ pbn Hup (neq_sym Hneq)) in Hget'.
  unfold chip_bi_coherent.
  destruct (HJ pbn' bi' Hget') as [bx [Hbx Hx]].
  exists bx.
  split; trivial.
  rewrite (Hgetc'2 pbn' Hneq).
  trivial.
Qed.

Lemma blank_pmt_shape:
  forall loc,
    (bvalid_page_off loc = true
    -> pmt_get blank_pmt loc = Some pmte_empty)
    /\ (bvalid_page_off loc = false
        -> pmt_get blank_pmt loc = None).
Proof.
  intros.
  split.
    intros.
    unfold bvalid_page_off in H.
    unfold pmt_get.
    unfold blank_pmt.
    desbnat.
    rewrite (@list_get_list_repeat_list _ loc pmte_empty PAGES_PER_BLOCK H).
    trivial.
  intros.
  unfold bvalid_page_off in H.
  unfold pmt_get, blank_pmt.
  desbnat.
  rewrite (@list_get_list_repeat_list_none _ loc pmte_empty PAGES_PER_BLOCK H).
  trivial.
Qed.

Lemma blank_pmt_shape':
  pmt_shape blank_pmt 0.
Proof.
  unfold pmt_shape.
  intros.
  destruct (blank_pmt_shape loc) as [H1 H2].
  split.
    intro Hloc.
    simplbnat.
  intro Hloc.
  rewrite (H1 H).
  trivial.
Qed.

Lemma blank_pmt_is_domain_complete :
  pmt_domain_is_complete blank_pmt.
Proof.
  unfold pmt_domain_is_complete.
  intros.
  unfold pmt_len.
  simpl.
  trivial.
Qed.

Lemma pmt_update_pmt_find_rev :
  forall pmt loc off pmt',
  pmt_domain_is_complete pmt
  -> pmt_shape pmt loc
  -> pmt_update pmt loc off = Some pmt'
  -> pmt_find_rev pmt' (pmte_log off) = Some loc.
Proof.
  intros pmt loc off pmt' Hpd Hps Hu.
  unfold pmt_find_rev.
  assert (Hg:= pmt_update_pmt_get_eq _ _ _ _ Hu).
  unfold pmt_shape in Hps.
  assert (Hlen: pmt_len pmt' = PAGES_PER_BLOCK).
    unfold pmt_domain_is_complete in Hpd.
    rewrite (pmt_update_pmt_len _ _ _ _ Hu).
    trivial.
  assert (forall loc' pmte,
            loc' > loc
            -> pmt_get pmt' loc' = Some pmte
            -> pmte_log off <> pmte).
    intros loc' pmte Hneq Hgloc'.
    intros HF.
    subst pmte.
    assert (valid_page_off loc').
      unfold valid_page_off.
      unfold bvalid_page_off.
      destruct (blt_nat loc' PAGES_PER_BLOCK) eqn:Hloc'b; trivial.
      destruct (pmt_len_pmt_get _ _ Hlen loc') as [H1 H2].
      rewrite (H2 Hloc'b) in Hgloc'.
      discriminate.
    destruct (Hps loc' H) as [H1 H2].
    assert (Hx : blt_nat loc' loc = false).
      clear - Hneq.
      solvebnat.
    apply H2 in Hx.
    assert (Hy : loc' <> loc).
      clear - Hneq.
      omega.
    rewrite (pmt_update_pmt_get_neq _ _ _ _ _ Hu Hy) in Hgloc'.
    rewrite Hgloc' in Hx.
    discriminate.
  apply list_get_list_find_rev; trivial.
  apply beq_pmt_entry_eq_true; trivial.
  apply beq_pmt_entry_true_eq; trivial.
Qed.


Require Import Coq.Strings.String.
Require Import Fiat.Parsers.GenericBaseTypes.
Require Import Fiat.Parsers.ContextFreeGrammar.Carriers.
Require Import Fiat.Parsers.ContextFreeGrammar.PreNotations.

Section with_actions.
  Context {Char T : Type}
          (G : pregrammar_with_actions Char T).

  Definition option_cons {A}
    : option A -> option (list A) -> option (list A)
    := fun pit pits
       => match pit, pits with
          | Some pit', Some pits' => Some (cons pit' pits')
          | None, _ => None
          | _, None => None
          end.

  Definition option_orb {A} (x y : option A) : option A
    := match x, y with
       | Some x', _ => Some x'
       | None, Some y' => Some y'
       | None, None => None
       end.

  Fixpoint fuse_production (res : list (Char + T)) (pat : rproduction_with_action Char T) : option T
    := match res, projT1 pat as pat' return action_of_rproduction T pat' -> option T with
       | nil, nil => @Some _
       | inl v :: res', Reflective.RTerminal _ :: pats'
       | inr v :: res', Reflective.RNonTerminal _ :: pats'
         => fun f => @fuse_production res' (existT _ pats' (f v))
       | inl _ :: _, Reflective.RNonTerminal _ :: _
       | inr _ :: _, Reflective.RTerminal _ :: _
       | nil, _::_ | _::_, nil => fun _ => None
       end%list (projT2 pat).

  Fixpoint fuse_productions (res : list (option (list (Char + T)))) (pats : rproductions_with_actions Char T) : option T
    := match res, pats with
       | nil, nil => None
       | Some pact :: res', pat :: pats'
         => match fuse_production pact pat with
            | Some t => Some t
            | None => fuse_productions res' pats'
            end
       | None :: res', pat :: pats'
         => fuse_productions res' pats'
       | _::_, nil | nil, _::_ => None
       end%list.

  Global Instance generic_parser_data_from_actions : generic_parser_dataT Char
    := { parse_nt_T := option T;
         parse_item_T := option (Char + T);
         parse_production_T := option (list (Char + T));
         parse_productions_T := list (option (list (Char + T)));
         ret_Terminal_false ch := None;
         ret_Terminal_true ch := Some (inl ch);
         ret_NonTerminal_false nt := None;
         ret_NonTerminal_true nt v := option_map (@inr _ _) v;
         ret_production_cons := option_cons;
         ret_orb_production := option_orb;
         ret_orb_production_base := None;
         ret_production_nil_true := Some nil;
         ret_production_nil_false := None;
         ret_orb_productions := cons;
         ret_orb_productions_base := nil;
         ret_nt nt v := fuse_productions v (List.nth (default_of_nonterminal (G:=G) nt) (List.map snd (pregrammar_arproductions G)) nil);
         ret_nt_invalid := None }.
End with_actions.


Load LFindLoad.
Load LFindLoad.
From adtind Require Import goal50.

From lfind Require Import LFind.
Require Import Arith.
Require Import Extraction.
Extract Inductive nat => nat [ "(O)" "S" ].
Extract Inductive list => list [ "Nil" "Cons" ].
Extraction "/home/yousef/lemmafinder/benchmark/_lfind_clam_lf_goal50_count_cons_102_eqb_refl/goal50_lfind_orig.ml"  adtind.goal50.count adtind.goal50.eqb.
Success.


Require Driver.

Cd "extracted".

Set Extraction AccessOpaque.

Extraction Blacklist String List.

Extract Inductive bool => bool [ true false ].
Extract Inductive option => option [ Some None ].
Extract Inductive unit => unit [ "()" ].
Extract Inductive list => list [ "[]" "( :: )" ].
Extract Inductive prod => "( * )" [ "" ].

(** NB: The "" above is a hack, but produce nicer code than "(,)" *)

(** Mapping sumbool to bool and sumor to option is not always nicer,
    but it helps when realizing stuff like [lt_eq_lt_dec] *)

Extract Inductive sumbool => bool [ true false ].
Extract Inductive sumor => option [ Some None ].

(** Restore lazyness of andb, orb.
    NB: without these Extract Constant, andb/orb would be inlined
    by extraction in order to have lazyness, producing inelegant
    (if ... then ... else false) and (if ... then true else ...).
*)

Extract Inlined Constant andb => "(&&)".
Extract Inlined Constant orb => "(||)".

Extract Inductive nat => int [ "0" "Pervasives.succ" ]
 "(fun fO fS n -> if n=0 then fO () else fS (n-1))".

(** Efficient (but uncertified) versions for usual [nat] functions *)

Extract Constant plus => "(+)".
Extract Constant pred => "fun n -> max 0 (n-1)".
Extract Constant minus => "fun n m -> max 0 (n-m)".
Extract Constant mult => "( * )".
Extract Inlined Constant max => max.
Extract Inlined Constant min => min.
(*Extract Inlined Constant nat_beq => "(=)".*)
Extract Inlined Constant EqNat.beq_nat => "(=)".
Extract Inlined Constant EqNat.eq_nat_decide => "(=)".

Extract Inlined Constant Peano_dec.eq_nat_dec => "(=)".

Extract Constant Compare_dec.nat_compare =>
 "fun n m -> if n=m then Eq else if n<m then Lt else Gt".
Extract Inlined Constant Compare_dec.leb => "(<=)".
Extract Inlined Constant Compare_dec.le_lt_dec => "(<=)".
Extract Constant Compare_dec.lt_eq_lt_dec =>
 "fun n m -> if n>m then None else Some (n<m)".

Extract Constant Even.even_odd_dec => "fun n -> n mod 2 = 0".
Extract Constant Div2.div2 => "fun n -> n/2".

Separate Extraction Driver.


From iris.proofmode Require Import tactics.
From iris.algebra Require Import auth excl excl_auth gmap.
From iris.base_logic.lib Require Import own.

Lemma excl_auth_eq A `{inG Σ (excl_authR (leibnizO A))} γ (x y: A):
  own γ (◯E (x:leibnizO A)) -∗ own γ (●E (y:leibnizO A)) -∗ ⌜x = y⌝.
Proof.
  iIntros "H1 H2". iDestruct (own_op with "[$H1 $H2]") as "H".
  iDestruct (own_valid with "H") as %HH%excl_auth_agree. done.
Qed.

Lemma excl_auth_upd A `{inG Σ (excl_authR (leibnizO A))} γ (x y z: A):
  own γ (◯E (x:leibnizO A)) -∗ own γ (●E (y:leibnizO A)) ==∗
  own γ (◯E (z:leibnizO A)) ∗ own γ (●E (z:leibnizO A)).
Proof.
  iIntros "H1 H2".
  iDestruct (own_update_2 with "H1 H2") as ">[? ?]".
  apply excl_auth_update. iModIntro. iFrame.
Qed.

Lemma excl_auth_alloc A `{inG Σ (excl_authR (leibnizO A))} (x: A):
  ⊢ |==> ∃ γ, own γ (◯E (x:leibnizO A)) ∗ own γ (●E (x:leibnizO A)).
Proof.
  iIntros.
  iMod (own_alloc (●E (x:leibnizO A) ⋅ ◯E (x:leibnizO A))) as (γ) "[? ?]".
  apply excl_auth_valid. iModIntro. iExists _. iFrame.
Qed.


From Mtac2 Require Import Datatypes Logic intf.Sorts.
Import Sorts.S.

Set Universe Polymorphism.
Unset Universe Minimization ToSet.
Set Polymorphic Inductive Cumulativity.

Inductive Hyp : Type :=
| ahyp : forall {A}, A -> moption A -> Hyp.

Inductive goal_state := | gs_open | gs_any.

Inductive goal@{U131 U132} : goal_state -> Type :=
  | Metavar' : forall gs (s : Sort) (A : stype_of@{U131 U132} s), selem_of@{U131 U132} A -> goal gs
  | AHyp : forall {A : Type@{U132}}, (A -> goal gs_any) -> goal gs_any
  | HypLet : Type@{U132} -> goal gs_any -> goal gs_any
  | HypRem : forall {A : Type@{U132}}, A -> goal gs_any -> goal gs_any
  | HypReplace : forall {A B : Type@{U132}},  A -> meq@{U131} A B -> goal gs_any -> goal gs_any.

Notation "'Metavar'" := (Metavar' gs_open).
Notation "'AnyMetavar'" := (Metavar' gs_any).


(******************************************************************************)
(** * Domains of the Power memory model *)
(******************************************************************************)

Require Import Classical List Relations Peano_dec Omega.
Require Import Hahn.
Require Import Basic Power_Events Power_Model.

Set Implicit Arguments.

Section Power_Domains.

Variable G : power_execution.

(* Basic *)
Notation "'acts'" := G.(acts).
Notation "'lab'" := G.(lab).
Notation "'sb'" := G.(sb).
Notation "'rf'" := G.(rf).
Notation "'mo'" := G.(mo).
Notation "'rmw'" := G.(rmw).
Notation "'data'" := G.(data).
Notation "'addr'" := G.(addr).
Notation "'ctrl'" := G.(ctrl).
Notation "'ctrl_isync'" := G.(ctrl_isync).
(* Events *)
Notation "'E'" := G.(E).
Notation "'R'" := G.(R).
Notation "'W'" := G.(W).
Notation "'F_sync'" := G.(F_sync).
Notation "'F_lwsync'" := G.(F_lwsync).
Notation "'RW'" := G.(RW).
Notation "'_WF'" := G.(_WF).
Notation "'F'" := G.(F).
(* Relations *)
Notation "'same_loc'" := G.(same_loc).
Notation "'deps'" := G.(deps).
Notation "'rb'" := G.(rb).
Notation "'rdw'" := G.(rdw).
Notation "'detour'" := G.(detour).
Notation "'ii0'" := G.(ii0).
Notation "'ci0'" := G.(ci0).
Notation "'cc0'" := G.(cc0).
Notation "'ii'" := G.(ii).
Notation "'ic'" := G.(ic).
Notation "'ci'" := G.(ci).
Notation "'cc'" := G.(cc).
Notation "'L'" := G.(L).
Notation "'Li'" := G.(Li).
Notation "'ii_alt'" := G.(ii_alt).
Notation "'ic_alt'" := G.(ic_alt).
Notation "'ci_alt'" := G.(ci_alt).
Notation "'cc_alt'" := G.(cc_alt).
Notation "'ppo'" := G.(ppo).
Notation "'sync'" := G.(sync).
Notation "'lwsync'" := G.(lwsync).
Notation "'fence'" := G.(fence).
Notation "'hb'" := G.(hb).
Notation "'prop1'" := G.(prop1).
Notation "'prop2'" := G.(prop2).
Notation "'prop'" := G.(prop).
Notation "'psbloc'" := G.(psbloc).
Notation "'eco'" := G.(eco).
(* Well-formed axioms *)
Notation "'WfDEPS'" := G.(WfDEPS).
Notation "'WfACTS'" := G.(WfACTS).
Notation "'WfSB'" := G.(WfSB).
Notation "'WfRF'" := G.(WfRF).
Notation "'WfMO'" := G.(WfMO).
Notation "'WfRMW'" := G.(WfRMW).
Notation "'Wf'" := G.(Wf).
(* Consistency *)
Notation "'PowerConsistent'" := G.(PowerConsistent).
(* Notation *)
Notation "'restrict_location'" := G.(restrict_location).
Notation "s ⌇ x" := (restrict_location s x) (at level 1).
Notation "rel |loc" := (rel ∩ same_loc) (at level 1).
Notation "a ∙" := (a ∩ same_thread) (at level 1, format "a ∙").
Notation "a ∘" := (a \ same_thread) (at level 1, format "a ∘").

Lemma rewrite_internal (r : relation event) : r∙ ⊆ r.
Proof. unfolder; ins; desf. Qed.

Lemma eqv_doma A (S: A -> Prop) :  doma ⦗S⦘  S.
Proof. apply doma_helper; unfolder; ins; desf; eexists; splits; eauto. Qed.

Lemma eqv_domb A (S: A -> Prop) :  domb ⦗S⦘  S.
Proof. apply domb_helper; unfolder; ins; desf; eexists; splits; eauto. Qed.

Lemma trivial_doma A (r: relation A) (S: A -> Prop) :
  doma (⦗S⦘ ⨾ r) S.
Proof. apply doma_helper; rels. Qed.

Lemma trivial_domb A (r: relation A) (S: A -> Prop) :
  domb (r ⨾ ⦗S⦘) S.
Proof. apply domb_helper; rewrite seqA; rels.  Qed.

Lemma rewrite_doma A (r: relation A) (S: A -> Prop) :
  doma r S <-> r ⊆ ⦗S⦘ ⨾ r.
Proof. split; apply doma_helper. Qed.

Lemma rewrite_domb A (r: relation A) (S: A -> Prop) :
  domb r S <-> r ⊆ r ⨾ ⦗S⦘.
Proof. split; apply domb_helper. Qed.

Lemma rewrite_dom A (r: relation A) (a b : A -> Prop) (H: r ⊆ a ✕ b) :
  r ⊆ ⦗a⦘ ⨾ r ⨾ ⦗b⦘.
Proof.
  unfolder in *; ins.
  specialize (H x y H0).
  desf; eexists; splits; desf; eexists; splits; eauto.
Qed.

Lemma transp_doma A (r: relation A) (d : A -> Prop) : domb r d ->  doma r⁻¹ d.
Proof. unfolder; unfold domb, doma; ins; eapply H, REL. Qed.

Lemma transp_domb A (r: relation A) (d : A -> Prop) : doma r d ->  domb r⁻¹ d.
Proof. unfolder; unfold domb, doma; ins; eapply H, REL. Qed.

Lemma union_doma A (r r' : relation A) (S: A -> Prop) :
  doma r S /\ doma r' S <-> doma (r ∪ r') S.
Proof.
  split; ins; unfolder in *; unfold doma in *; try split; ins; desf;
  try (by eapply H; eauto);
  try (by eapply H0; eauto).
Qed.

Lemma union_domb A (r r' : relation A) (S: A -> Prop) :
  domb r S /\ domb r' S <-> domb (r ∪ r') S.
Proof.
  split; ins; unfolder in *; unfold domb in *; try split; ins; desf;
  try (by eapply H; eauto);
  try (by eapply H0; eauto).
Qed.

Lemma set_union_doma A (r: relation A) (S S' : A -> Prop) :
  doma r S \/ doma r S' -> doma r (S ∪₁ S').
Proof.
  ins; desf.
  - by apply doma_implies with (r:=r) (d:=S); try (by ins; red; auto).
  - by apply doma_implies with (r:=r) (d:=S'); try (by ins; red; auto).
Qed.

Lemma set_union_domb A (r: relation A) (S S' : A -> Prop) :
  domb r S \/ domb r S' -> domb r (S ∪₁ S').
Proof.
  ins; desf.
  - by apply domb_implies with (r:=r) (d:=S); try (by ins; red; auto).
  - by apply domb_implies with (r:=r) (d:=S'); try (by ins; red; auto).
Qed.

Lemma inter_doma A (r r' : relation A) (S: A -> Prop) :
  doma r S \/ doma r' S -> doma (r ∩ r') S.
Proof.
  unfolder; ins; desf; unfold doma in *; ins; desf; eapply H; eauto.
Qed.

Lemma inter_domb A (r r' : relation A) (S: A -> Prop) :
  domb r S \/ domb r' S -> domb (r ∩ r') S.
Proof.
  unfolder; ins; desf; unfold domb in *; ins; desf; eapply H; eauto.
Qed.

Lemma seq_doma A (r r' : relation A) (S: A -> Prop) :
  doma r S -> doma (r ⨾ r') S.
Proof.
  ins; apply doma_helper.
  arewrite (r ⊆ ⦗S⦘ ⨾ r) at 1.
    by apply rewrite_doma.
  done.
Qed.

Lemma seq_domb A (r r' : relation A) (S: A -> Prop) :
  domb r' S -> domb (r ⨾ r') S.
Proof.
  ins; apply domb_helper.
  arewrite (r' ⊆ r' ⨾ ⦗S⦘) at 1.
    by apply rewrite_domb.
  done.
Qed.

Lemma restr_doma A B (r: relation A) (f: A -> B) (S: A -> Prop) :
  doma r S -> doma (restr_eq_rel f r) S.
Proof.
  unfolder; unfold doma.
  ins; desf; eapply H; eauto.
Qed.

Lemma restr_domb A B (r: relation A) (f: A -> B) (S: A -> Prop) :
  domb r S -> domb (restr_eq_rel f r) S.
Proof.
  unfolder; unfold domb.
  ins; desf; eapply H; eauto.
Qed.

Lemma only_doma A (r: relation A) (S S' : A -> Prop) :
  r ⊆ ⦗S⦘ ⨾ r ⨾ ⦗S'⦘ -> r ⊆ ⦗S⦘ ⨾ r.
Proof.
  ins; unfolder in *; desf. ins; desf. eexists; splits; eauto.
  specialize (H x y H0); desf.
Qed.

Lemma only_domb A (r: relation A) (S S' : A -> Prop) :
  r ⊆ ⦗S⦘ ⨾ r ⨾ ⦗S'⦘ -> r ⊆ r ⨾ ⦗S'⦘.
Proof.
  ins; unfolder in *; desf. ins; desf. eexists; splits; eauto.
  specialize (H x y H0); desf.
Qed.

Lemma internal_doma (r : relation event) (S : event -> Prop) :
  r ⊆ ⦗S⦘ ⨾ r -> r∙ ⊆ ⦗S⦘ ⨾ r∙.
Proof. by ins; rewrite H at 1; unfolder; ins; desf; eexists; splits. Qed.

Lemma internal_domb (r : relation event) (S : event -> Prop) :
  r ⊆ r ⨾ ⦗S⦘ -> r∙ ⊆ r∙ ⨾ ⦗S⦘.
Proof. by ins; rewrite H at 1; unfolder; ins; desf; eexists; splits. Qed.

Lemma external_doma (r : relation event) (S : event -> Prop) :
  r ⊆ ⦗S⦘ ⨾ r -> r∘ ⊆ ⦗S⦘ ⨾ r∘.
Proof. by ins; rewrite H at 1; unfolder; ins; desf; eexists; splits. Qed.

Lemma external_domb (r : relation event) (S : event -> Prop) :
  r ⊆ r ⨾ ⦗S⦘ -> r∘ ⊆ r∘ ⨾ ⦗S⦘.
Proof. by ins; rewrite H at 1; unfolder; ins; desf; eexists; splits. Qed.

Hint Resolve minus_doma minus_domb transp_doma transp_domb seq_doma seq_domb
  only_doma only_domb internal_doma internal_domb external_doma external_domb
  restr_doma restr_domb trivial_doma trivial_domb eqv_doma eqv_domb inter_doma inter_domb
  set_union_doma set_union_domb
: domains.

Hint Rewrite rewrite_doma rewrite_domb rewrite_dom union_doma union_domb
  doma_helper domb_helper domab_helper
: domains.

Ltac unfold_wf :=
  match goal with [WF:Wf |- _] => cdes WF;
    match goal with [D:WfDEPS,A:WfACTS,S:WfSB,RF:WfRF,M:WfMO,RM:WfRMW |- _] =>
      cdes D; cdes A; cdes S; cdes RF; cdes M; cdes RM; clear D A S RF M RM
    end
  end.

Ltac rewrite_cartesian_products :=
  repeat match goal with [DOM:_ ⊆ _ ✕ _ |- _] => apply rewrite_dom in DOM end.

Ltac simplify_domains :=
  try match goal with
  (* Union *)
  | [ |- doma (_ ∪ _) _] => apply union_doma; splits
  | [ |- domb (_ ∪ _) _] => apply union_domb; splits
  (* Inter *)
  | [ |- doma (_ ∩ _) _] => apply inter_doma
  | [ |- domb (_ ∩ _) _] => apply inter_domb
  (* Transp *)
  | [ |- doma _⁻¹ _] => apply transp_doma
  | [ |- domb _⁻¹ _] => apply transp_domb
  (* Minus *)
  | [ |- doma (_ \ _) _] => apply minus_doma
  | [ |- domb (_ \ _) _] => apply minus_domb
  (* Restr *)
  | [ |- doma (restr_eq_rel _ _) _] => apply restr_doma
  | [ |- domb (restr_eq_rel _ _) _] => apply restr_domb
  (* Seq *)
  | [ |- doma (_ ⨾ _) _] => apply seq_doma
  | [ |- domb (_ ⨾ _) _] => apply seq_domb
  end.

Ltac domain_solver :=
  idtac + autounfold with composite_type_unfold;
  try (unfold_wf; rewrite_cartesian_products);
  idtac + unfold set_union;
  idtac + simplify_domains + (do 2 simplify_domains) + (do 3 simplify_domains);
  idtac + rewrite seqA + rewrite <- seqA;
  let apply_dom := (fun d => autorewrite with domains using apply d) in
  match goal with
  | |- _ \/ _ => left + right; domain_solver
  (* trivial *)
  | [ |- domb (_ ⨾ ⦗?b⦘) ?b] => apply trivial_domb
  | [ |- domb (⦗?a⦘ ⨾ _) ?a] => apply trivial_doma
  | [ |- doma ⦗?a⦘ ?a] => apply eqv_doma
  | [ |- domb ⦗?b⦘ ?b] => apply eqv_domb
  (* doma *)
  | |- ?r⁺ ⊆ ⦗_⦘ ⨾ ?r⁺ => apply doma_helper, ct_doma; domain_solver
  | [DOM:?r ⊆ ⦗?a⦘ ⨾ ?r ⨾ _ |- doma ?r ?a] => apply_dom (only_doma DOM)
  | [DOM:?r ⊆ ⦗?a⦘ ⨾ ?r ⨾ _ |- ?r ⊆ ⦗?a⦘ ⨾ ?r] => apply (only_doma DOM)
  | [DOM:?r ⊆ ⦗?a⦘ ⨾ ?r |- doma ?r ?a] => apply_dom (only_doma DOM)
  | [DOM:doma ?r ?a |- ?r ⊆ ⦗?a⦘ ⨾ ?r] => by apply doma_helper
  (* domb *)
  | |- ?r⁺ ⊆ ?r⁺ ⨾ ⦗_⦘ => apply domb_helper, ct_domb; domain_solver
  | [DOM:?r ⊆ _ ⨾ ?r ⨾ ⦗?b⦘ |- domb ?r ?b] => apply_dom (only_domb DOM)
  | [DOM:?r ⊆ _ ⨾ ?r ⨾ ⦗?b⦘ |- ?r ⊆ ?r ⨾ ?b] => apply (only_domb DOM)
  | [DOM:?r ⊆ ?r ⨾ ⦗?b⦘ |- domb ?r ?b] => apply_dom (only_domb DOM)
  | [DOM:domb ?r ?a |- ?r ⊆ ?r ⨾ ⦗?a⦘] => by apply domb_helper
  (* left_union *)
  | |- (?r ∪ ?r') ⊆ ⦗?A⦘ ⨾ (?r ∪ ?r') =>
    (arewrite (r ⊆ ⦗A⦘ ⨾ r) at 1 by domain_solver);
    (arewrite (r' ⊆ ⦗A⦘ ⨾ r') at 1 by domain_solver);
    by rewrite !seq_union_r
  (* dom -> incl *)
  | |- ?r ⊆ ⦗_⦘ ⨾ ?r => apply doma_helper; domain_solver
  | |- ?r ⊆ ?r ⨾ ⦗_⦘  => apply domb_helper; domain_solver
  | |- ?r ⊆ ⦗_⦘ ⨾ ?r ⨾ ⦗_⦘  => apply domab_helper; split; domain_solver
  (* db *)
  | |- doma _ _ => by eauto with domains
  | |- domb _ _ => by eauto with domains
  (* set_union *)
  | |- ?r ⊆ ⦗?A ∪₁ ?B⦘ ⨾?r =>
    apply doma_helper, set_union_doma; (left + right); domain_solver
  | |- ?r ⊆ ?r ⨾ ⦗?A ∪₁ ?B⦘ =>
    apply domb_helper, set_union_domb; (left + right); domain_solver
  end.

(*============================================================================*)

Hypothesis WF: Wf.

Lemma rf_doma : doma rf W.
Proof. domain_solver. Qed.

Lemma rf_domb : domb rf R.
Proof. domain_solver. Qed.

Lemma mo_doma : doma mo W.
Proof. domain_solver. Qed.

Lemma mo_domb : domb mo W.
Proof. domain_solver. Qed.

Lemma rmw_doma : doma rmw R.
Proof. domain_solver. Qed.

Lemma rmw_domb : domb rmw W.
Proof. domain_solver. Qed.

Lemma data_doma : doma data R.
Proof. domain_solver. Qed.

Lemma data_domb : domb data W.
Proof. domain_solver. Qed.

Lemma ctrl_doma : doma ctrl R.
Proof. by unfold_wf; apply doma_helper. Qed.

Lemma ctrli_doma : doma ctrl_isync R.
Proof. by unfold_wf; apply doma_helper. Qed.

Lemma addr_doma : doma addr R.
Proof. domain_solver. Qed.

Lemma addr_domb : domb addr RW.
Proof. domain_solver. Qed.

Lemma deps_doma : doma deps R.
Proof. unfold Power_Model.deps; auto using data_doma, addr_doma, ctrl_doma with rel. Qed.

Lemma rb_doma : doma rb R.
Proof. unfold Power_Model.rb; domain_solver. Qed.

Lemma rb_domb : domb rb W.
Proof. unfold Power_Model.rb; domain_solver. Qed.

Lemma rdw_doma : doma rdw R.
Proof.
  unfold Power_Model.rdw; repeat (simplify_domains; try left).
  unfold Power_Model.rb; domain_solver.
Qed.

Lemma rdw_domb : domb rdw R.
Proof.
  unfold Power_Model.rdw; repeat (simplify_domains; try left); domain_solver.
Qed.

Hint Resolve rf_doma rf_domb mo_doma mo_domb rmw_doma rmw_domb data_doma
  data_domb ctrl_doma ctrli_doma addr_doma deps_doma rb_doma rb_domb rdw_doma
  rdw_domb
: domains.

Lemma rel_doma (r: relation event) : doma r (R ∪₁ W ∪₁ F).
Proof.
  red; ins.
  repeat autounfold with type_unfold; unfold set_union.
  unfold is_r, is_w, is_f_sync, is_f_lwsync.
  destruct (lab x); auto.
Qed.

Lemma rel_domb (r: relation event) : domb r (R ∪₁ W ∪₁ F).
Proof.
  red; ins.
  repeat autounfold with type_unfold; unfold set_union.
  unfold is_r, is_w, is_f_sync, is_f_lwsync.
  destruct (lab y); auto.
Qed.

Hint Resolve rel_doma rel_domb : domains.

Lemma loc_not_f a : loc lab a <> None -> ~ F a.
Proof.
  repeat autounfold with type_unfold; unfold set_union.
  ins; unfold is_f_sync, is_f_lwsync.
  apply and_not_or; split; unfold loc in H; destruct (lab a); desf.
Qed.

Lemma same_loc_doma : doma same_loc (R ∪₁ W).
Proof.
  apply doma_helper.
  arewrite (same_loc ⊆ ⦗R ∪₁ W ∪₁ F⦘ ⨾ same_loc) at 1 by domain_solver.
  unfold Power_Model.same_loc.
  repeat autounfold with type_unfold; unfold set_union; unfolder; ins; desf;
  repeat (eexists; splits; eauto); apply loc_not_f in H0;
  repeat autounfold with type_unfold in H0; unfold set_union in H0; desf;
  apply not_or_and in H0; desf.
Qed.

Lemma same_loc_domb : domb same_loc (R ∪₁ W).
Proof.
  apply domb_helper.
  arewrite (same_loc ⊆ same_loc ⨾ ⦗R ∪₁ W ∪₁ F⦘) at 1 by domain_solver.
  unfold Power_Model.same_loc.
  repeat autounfold with type_unfold; unfolder; ins; desf;
  splits; auto; rewrite H1 in H; apply loc_not_f in H;
  repeat autounfold with type_unfold in *; unfolder in *; intuition.
Qed.

Lemma sblocR_doma : doma (sb|loc ⨾ ⦗R⦘) (R ∪₁ W).
Proof. apply seq_doma, inter_doma; right; apply same_loc_doma. Qed.

Lemma psbloc_doma : doma psbloc (R ∪₁ W).
Proof.
  unfold Power_Model.psbloc; simplify_domains.
  clear_equivs ⦗I⦘.
  by apply sblocR_doma.
Qed.

Lemma psbloc_domb : domb psbloc R.
Proof. unfold Power_Model.psbloc; domain_solver. Qed.

Lemma addrsb_doma : doma (addr ⨾ sb) R.
Proof. domain_solver. Qed.

Lemma depsUaddrsb_doma : doma (deps ∪ addr ⨾ sb) R.
Proof. domain_solver. Qed.

Lemma detour_doma : doma detour W.
Proof.
  apply doma_helper.
  unfold Power_Model.detour.
  arewrite (mo∘ ⊆ ⦗W⦘ ⨾ mo∘) at 1.
    by apply external_doma, doma_helper, mo_doma.
  unfolder in *; ins; desf; eexists; splits; eauto.
Qed.

Lemma detour_domb : domb detour R.
Proof.
  apply domb_helper.
  unfold Power_Model.detour.
  arewrite (mo∘ ⊆ mo∘ ⨾ ⦗W⦘) at 1.
    by apply external_domb, domb_helper, mo_domb.
  unfolder in *; ins; desf; eexists; splits; eauto.
  eapply rf_domb; eauto.
Qed.

Lemma ppo_doma : doma ppo R.
Proof. unfold Power_Model.ppo. domain_solver. Qed.

Lemma ppo_domb : domb ppo RW.
Proof. unfold Power_Model.ppo, Power_Model.RW; basic_solver. Qed.

Lemma fence_domb : domb fence RW.
Proof.
  unfold Power_Model.fence.
  apply domb_helper.
  arewrite (sync ⊆ sync ⨾ ⦗RW⦘) by unfold Power_Model.sync; domain_solver.
  arewrite (lwsync ⊆ lwsync ⨾ ⦗RW⦘) by unfold Power_Model.lwsync; domain_solver.
  basic_solver 10.
Qed.

Hint Resolve sblocR_doma psbloc_doma psbloc_domb addrsb_doma depsUaddrsb_doma
  detour_doma detour_domb ppo_doma ppo_domb fence_domb
: domains.

Lemma R_in_I : R ⊆₁ I.
Proof.
  repeat red; ins; unfold Power_Model.R, is_r, is_init in *; desf.
  cdes WF; cdes WF_ACTS; rewrite LAB_INIT in Heq.
  unfold init_label in Heq; desf.
Qed.

Lemma F_in_I : F ⊆₁ I.
Proof.
  red; ins; repeat autounfold with type_unfold in *.
  red; ins; unfold set_union, is_f_sync, is_f_lwsync, is_init in *; desf;
  cdes WF; cdes WF_ACTS; rewrite LAB_INIT in *; unfold init_label in *; desf.
Qed.

Lemma hb_domb : domb hb RW.
Proof.
  unfold Power_Model.hb.
  do 2 simplify_domains.
  - domain_solver.
  - domain_solver.
  - autounfold with composite_type_unfold; domain_solver.
Qed.

Lemma fence_doma : doma fence RW.
Proof.
  unfold Power_Model.fence.
  apply doma_helper.
  arewrite (sync ⊆ ⦗RW⦘ ⨾ sync) by unfold Power_Model.sync; domain_solver.
  arewrite (lwsync ⊆ ⦗RW⦘ ⨾ lwsync) by unfold Power_Model.lwsync; domain_solver.
  basic_solver 10.
Qed.

Hint Resolve hb_domb fence_doma : domains.

Lemma rfe_hb_domb : domb (rf∘ ⨾ hb＊) RW.
Proof.
  apply domb_helper.
  rewrite rtE; relsf; unionL.
  - unionR left; domain_solver.
  - unionR right; arewrite (hb⁺ ⊆ hb⁺ ⨾ ⦗RW⦘) at 1 by domain_solver.
Qed.

Lemma eco_doma : doma eco RW.
Proof. unfold Power_Model.eco; domain_solver. Qed.

Lemma eco_domb : domb eco RW.
Proof.
  unfold Power_Model.eco.
  rewrite crE; relsf.
  domain_solver.
Qed.

End Power_Domains.

Hint Resolve rf_doma rf_domb mo_doma mo_domb rmw_doma rmw_domb data_doma
  data_domb ctrl_doma ctrli_doma addr_doma deps_doma rb_doma rb_domb rdw_doma
  rdw_domb minus_doma minus_domb transp_doma transp_domb seq_doma seq_domb
  only_doma only_domb external_doma external_domb restr_doma restr_domb
  trivial_doma trivial_domb eqv_doma eqv_domb inter_doma inter_domb
  set_union_doma set_union_domb sblocR_doma psbloc_doma psbloc_domb addrsb_doma
  depsUaddrsb_doma detour_doma detour_domb ppo_doma hb_domb fence_doma
  rfe_hb_domb rel_doma rel_domb same_loc_doma same_loc_domb eco_doma eco_domb
: domains.

Hint Rewrite rewrite_doma rewrite_domb rewrite_dom union_doma union_domb
  doma_helper domb_helper domab_helper
: domains.


(* Distributed under the terms of the MIT license. *)
From Coq Require Import Morphisms.
From MetaCoq.Template Require Import config utils.
From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils PCUICCases PCUICInduction
  PCUICLiftSubst PCUICUnivSubst
  PCUICSigmaCalculus PCUICTyping.

Require Import ssreflect ssrbool.
From Equations Require Import Equations.
Require Import Equations.Prop.DepElim.
Set Equations With UIP.

(** * Type preservation for σ-calculus operations *)

Open Scope sigma_scope.
Set Keyed Unification.

Set Default Goal Selector "!".

Section Renaming.

Context `{cf : checker_flags}.

(* Notion of valid renaming without typing information. *)

(** We might want to relax this to allow "renamings" that change e.g.
  the universes or names, but should generalize the renaming operation at
  the same time *)
(** Remark: renaming allows instantiating an assumption with a well-typed body *)

Definition urenaming (P : nat -> bool) Γ Δ f :=
  forall i decl, P i ->
    nth_error Δ i = Some decl ->
    ∑ decl', (nth_error Γ (f i) = Some decl') ×
    (eq_binder_annot decl.(decl_name) decl'.(decl_name) ×
    ((rename (f ∘ rshiftk (S i)) decl.(decl_type) =
     rename (rshiftk (S (f i))) decl'.(decl_type)) ×
      on_Some_or_None (fun body => Some (rename (f ∘ rshiftk (S i)) body) =
         option_map (rename (rshiftk (S (f i)))) decl'.(decl_body)) decl.(decl_body))).

(* Definition of a good renaming with respect to typing *)
Definition renaming P Σ Γ Δ f :=
  wf_local Σ Γ × urenaming P Γ Δ f.

End Renaming.


From Undecidability.L Require Import L Tactics.LTactics.

From Complexity.L.AbstractMachines Require Import FunctionalDefinitions AbstractHeapMachineDef.
From Undecidability.L.AbstractMachines Require Import Programs.

From Undecidability.L.Datatypes Require Import Lists LOptions LProd LTerm.

From Undecidability.L Require Import Tactics.GenEncode.

(** * Computability in L *)

(** *** Encoding Heaps *)
Import AbstractHeapMachineDef.

MetaCoq Run (tmGenEncode "heapEntry_enc" heapEntry).
#[export]
Hint Resolve heapEntry_enc_correct : Lrewrite.

#[export]
Instance term_heapEntryC : computableTime' heapEntryC (fun _ _ => (1,fun _ _ => (1,tt))).
Proof.
extract constructor. solverec.
Qed.

(** *** Primitive functions with Heaps*)

#[export]
Instance term_get : computableTime' get (fun A _ => (1,fun n _ => (min n (length A)*15+21,tt))).
Proof.
extract. solverec. unfold nth_error_time, c__ntherror. solverec.
Qed.

Import Datatypes.
#[export]
Instance put_get : computableTime' put (fun A _ => (1,fun _ _ => (length A * 27 + 37,tt))).
Proof.
extract. solverec. unfold c__app, c__length. lia.
Qed.


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

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

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

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

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

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

Lemma AddrRegionRange_region_addrs b e :
  AddrRegionRange (region_addrs b e) b e.
Proof.
  intros a ?%elem_of_region_addrs. solve_addr.
Qed.
Hint Resolve AddrRegionRange_region_addrs : disj_regions.

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

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

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

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

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

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

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

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

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

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

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