(*********************************************************************)
(*             A Formal Hierarchy of Weak Memory Models              *)
(*                                                                   *)
(*   Jade Alglave INRIA Paris-Rocquencourt, France.                  *)
(*                                                                   *)
(*  Copyright 2010 Institut National de Recherche en Informatique et *)
(*  en Automatique. All rights reserved. This file is distributed    *)
(*  under the terms of the Lesser GNU General Public License.        *)
(*********************************************************************)
Require Import Ensembles.
Require Import Bool.
From dev Require Export util.
From dev Require Export wmm.
From dev Require Export basic.
Set Implicit Arguments.

Module Hierarchy.

Module Weaker (A1 A2 : Archi).

Definition bot_ghb1 (E:Event_struct) (X:Execution_witness) :=
         (rel_union (rel_union (ws X) (fr E X)) (A1.ppo E)).
Definition bot_ghb2 (E:Event_struct) (X:Execution_witness) :=
        (rel_union (rel_union (ws X) (fr E X)) (A2.ppo E)).

Definition bimpl (b1 b2:bool) : Prop:=
  if (negb b1) || b2 then True else False.
Definition rf_impl (rf1 rf2 : bool) :=
  bimpl rf1 rf2.
Definition ppo_incl (ppo1 ppo2 : Event_struct -> Rln Event) :=
  forall E, rel_incl (ppo1 E) (ppo2 E).
Definition weaker := (*A1 incl in A2*)
  ppo_incl (A1.ppo) (A2.ppo) /\
  bimpl (A1.intra) (A2.intra) /\
  bimpl (A1.inter) (A2.inter).

Ltac destruct_wk H :=
  destruct H as [Hppoi [Hrfii Hrfei]].

Import A1. Import A2.
Module A1Basic := Basic A1.
Import A1Basic.
Module A2Basic := Basic A2.
Import A2Basic.
Module A1Wmm := Wmm A1.
Import A1Wmm.
Module A2Wmm := Wmm A2.
Import A2Wmm.

Module A1n <: Archi.
Definition ppo := A1.ppo.
Lemma ppo_valid : forall E, rel_incl (ppo E) (po_iico E).
  apply A1.ppo_valid.
Qed.
Definition inter := A1.inter.
Definition intra := A1.intra.
Definition abc (E:Event_struct) (X:Execution_witness) : Rln Event :=
  fun e1 => fun e2 => False.
Lemma ab_evts : forall (E:Event_struct) (X:Execution_witness),
  forall x y, abc E X x y -> In _ (events E) x /\ In _ (events E) y.
Proof.
intros E X x y Hxy. inversion Hxy.
Qed.
Parameter Cs : Type.
Parameter cs : Event_struct -> Execution_witness -> Location -> Cs -> Prop.
Parameter evts : Cs -> set Event.
Parameter lockc : Event_struct -> Execution_witness -> Location -> Rln Event.
Definition lock E X := fun e1 => fun e2 => exists l, lockc E X l e1 e2.
Parameter stars : Event_struct -> Execution_witness -> set Event.
End A1n.

Module A2n <: Archi.
Definition ppo := A2.ppo.
Lemma ppo_valid : forall E, rel_incl (ppo E) (po_iico E).
  apply A2.ppo_valid.
Qed.
Definition inter := A2.inter.
Definition intra := A2.intra.
Definition abc (E:Event_struct) (X:Execution_witness) : Rln Event :=
  fun e1 => fun e2 => False.
Lemma ab_evts : forall (E:Event_struct) (X:Execution_witness),
  forall x y, abc E X x y -> In _ (events E) x /\ In _ (events E) y.
Proof.
intros E X x y Hxy. inversion Hxy.
Qed.
Parameter Cs : Type.
Parameter cs : Event_struct -> Execution_witness -> Location -> Cs -> Prop.
Parameter evts : Cs -> set Event.
Parameter lockc : Event_struct -> Execution_witness -> Location -> Rln Event.
Definition lock E X := fun e1 => fun e2 => exists l, lockc E X l e1 e2.
Parameter stars : Event_struct -> Execution_witness -> set Event.
End A2n.

Import A1n. Import A2n.
Module A1nBasic := Basic A1n.
Import A1nBasic.
Module A2nBasic := Basic A2n.
Import A2nBasic.
Module A1nWmm := Wmm A1n.
Import A1nWmm.
Module A2nWmm := Wmm A2n.
Import A2nWmm.

Section Char.

Definition check (E:Event_struct) (X:Execution_witness) :=
  acyclic (rel_union (mrf X) (bot_ghb2 E X)).

Lemma bot_ghb_incl :
  forall E X,
  weaker ->
  rel_incl (bot_ghb1 E X) (bot_ghb2 E X).
Proof.
unfold bot_ghb1; unfold bot_ghb2;
intros E X H12 x y Hxy;
destruct_wk H12.
    inversion Hxy as [Hws_fr | Hre].
      left; auto.
      right; apply (Hppoi E x y Hre).
Qed.

Lemma ghb2_is_mhb_ppo2 :
  forall E X,
  ghb E X = rel_union (mhb E X) (A2.ppo E).
Proof.
case_eq inter; case_eq intra; intros Hinter Hintra;
unfold ghb; unfold mhb; rewrite Hinter; rewrite Hintra;
unfold abc; intros E X; apply ext_rel; split; intro Hxy; auto.

  inversion Hxy as [Hrfe | Hr].
    left; left; auto.
    inversion Hr as [Hrfi | Hre].
      left; right; left; auto.
      inversion Hre as [Ht | Hres].
        inversion Ht.
        inversion Hres as [Hws_fr | Hppo].
          left; right; right; auto.
            right; auto.

  inversion Hxy as [Hr | Hppo].
    inversion Hr as [Hrfe | Hre].
      left; auto.
      inversion Hre as [Hrfi | Hws_fr].
        right ; left; auto.
          right; right; right; left; auto.
          right; right; right; right; auto.

  inversion Hxy as [Hrfi | Hr].
      left; left; auto.
      inversion Hr as [Ht | Hre].
        inversion Ht.
        inversion Hre as [Hws_fr | Hppo].
          left; right; auto.
            right; auto.

  inversion Hxy as [Hr | Hppo].
    inversion Hr as [Hrfi | Hre].
      left; auto.
          right; right; left; auto.
          right; right; right; auto.

  inversion Hxy as [Hrfi | Hr].
      left; left; auto.
      inversion Hr as [Ht | Hre].
        inversion Ht.
        inversion Hre as [Hws_fr | Hppo].
          left; right; auto.
            right;auto.

  inversion Hxy as [Hr | Hppo].
    inversion Hr as [Hrfi | Hre].
      left; auto.
          right; right; left; auto.
          right; right; right; auto.

  inversion Hxy as [Ht | Hre].
        inversion Ht.
        inversion Hre as [Hws_fr | Hppo].
          left; auto.
            right; auto.

  inversion Hxy as [Hws_fr | Hppo].
          right; left; auto.
          right; right; auto.
Qed.

Lemma ghb2_eq :
  forall E X,
  ghb E X = rel_union (mrf X) (bot_ghb2 E X).
Proof.
case_eq inter; case_eq intra; intros Hinter Hintra;
unfold ghb; unfold mrf; unfold mrfe; unfold mrfi; rewrite Hinter; rewrite Hintra;
unfold bot_ghb2;
unfold abc; intros E X; apply ext_rel; split; intro Hxy; auto.

  inversion Hxy as [Hrfe | Hr].
    left; simpl; right; auto.
    inversion Hr as [Hrfi | Hre].
      left; simpl; left; auto.
      inversion Hre as [Ht | Hres].
        inversion Ht.
        right; auto.

  inversion Hxy as [Hrf | Hor].
    inversion Hrf as [Hrfi | Hrfe].
      right; simpl; left; auto.
      left; auto.
        right; right; right; auto.

  inversion Hxy as [Hrfi | Hor].
      left; right; auto.
          inversion Hor as [Ht | Hbghb].
            inversion Ht.
            right; auto.

  inversion Hxy as [Hrf | Hr].
    inversion Hrf as [Hrfi | Hrfe].
      inversion Hrfi.
      left; auto.
           right; right;auto.

  inversion Hxy as [Hrfi | Hor].
      left; left; auto.
          inversion Hor as [Ht | Hbghb].
            inversion Ht.
            right; auto.

  inversion Hxy as [Hrf | Hor].
    inversion Hrf as [Hrfi | Hrfe].
      left; auto.
      inversion Hrfe.
          right; right; auto.

  inversion Hxy as [Ht | Hre].
        inversion Ht.
            right; auto.

  inversion Hxy as [Hort | Hor].
    inversion Hort; inversion H.
       right; auto.
Qed.

Lemma ghb_incl :
  forall E X,
  weaker ->
  rel_incl (A1nWmm.ghb E X) (A2nWmm.ghb E X).
Proof.
intros E X; rewrite (ghb2_eq E X).
unfold A1nWmm.ghb; unfold A1n.ppo; unfold mrf; unfold mrfe; unfold mrfi;
intros H12 x y Hxy; case_eq inter; case_eq intra;
intros Hintra2 Hinter2; case_eq A1n.inter; case_eq A1n.intra;
intros Hintra1 Hinter1; rewrite Hintra1 in *; rewrite Hinter1 in *.
  (*A1 : true true ; A2 : true true*)
  inversion Hxy as [Hrfi | Hr].
    left; right; auto.
    inversion Hr as [Hrfi | Hre].
      left; left; auto.
      inversion Hre as [Ht | Hres].
        inversion Ht.
      right; fold (bot_ghb1 E X) in Hres.
      apply bot_ghb_incl; auto.
  (*A1 : false true ; A2 : true true*)
  inversion Hxy as [Hrfe | Hr].
    left; right; auto.
      inversion Hr as [Ht | Hres].
        inversion Ht.
      right; fold (bot_ghb2 E X); fold (bot_ghb1 E X) in Hr;
      apply bot_ghb_incl; auto.
  (*A1 : true false ; A2 : true true*)
  inversion Hxy as [Hrfi | Hr].
    left; left; auto.
      inversion Hr as [Ht | Hres].
        inversion Ht.
      right; fold (bot_ghb2 E X); fold (bot_ghb1 E X) in Hr;
      apply bot_ghb_incl; auto.
  (*A1 : false false ; A2 : true true*)
      inversion Hxy as [Ht | Hres].
        inversion Ht.
      right; fold (bot_ghb2 E X); fold (bot_ghb1 E X) in Hres;
      apply bot_ghb_incl; auto.
  (*A1 : true true ; A2 : false true*)
  destruct H12 as (*[?*) [? [Himpl ?]](*]*).
  unfold A1n.intra in Hintra1; unfold A2n.intra in Hintra2;
  rewrite Hintra1 in Himpl; rewrite Hintra2 in Himpl; inversion Himpl.
  (*A1 : false true ; A2 : false true*)
  inversion Hxy as [Hrfe | Hr].
    left; right; auto.
      inversion Hr as [Ht | Hres].
        inversion Ht.
      right; fold (bot_ghb2 E X); fold (bot_ghb1 E X) in Hres;
      apply bot_ghb_incl; auto.
  (*A1 : true false ; A2 : false true*)
  destruct H12 as (*[?*) [? [Himpl ?]] (*]*).
  unfold A1n.intra in Hintra1; unfold A2n.intra in Hintra2;
  rewrite Hintra1 in Himpl; rewrite Hintra2 in Himpl; inversion Himpl.
  (*A1 : false false ; A2 : false true*)
      inversion Hxy as [Ht | Hres].
        inversion Ht.
      right; fold (bot_ghb2 E X); fold (bot_ghb1 E X) in Hres;
      apply bot_ghb_incl; auto.
  (*A1 : true true ; A2 : true false *)
 destruct_wk H12.
  unfold A1n.inter in Hinter1; unfold A2n.inter in Hinter2;
  rewrite Hinter1 in Hrfei; rewrite Hinter2 in Hrfei; inversion Hrfei.
  (*A1 : false true ; A2 : true false *)
 destruct_wk H12.
  unfold A1n.inter in Hinter1; unfold A2n.inter in Hinter2;
  rewrite Hinter1 in Hrfei; rewrite Hinter2 in Hrfei; inversion Hrfei.
  (*A1 : true false ; A2 : true false *)
  inversion Hxy as [Hrfi | Hr].
    left; left; auto.
      inversion Hr as [Ht | Hres].
        inversion Ht.
      right; fold (bot_ghb2 E X); fold (bot_ghb1 E X) in Hres;
      apply bot_ghb_incl; auto.
  (*A1 : false false ; A2 : true false *)
      inversion Hxy as [Ht | Hres].
        inversion Ht.
      right; fold (bot_ghb2 E X); fold (bot_ghb1 E X) in Hres;
      apply bot_ghb_incl; auto.
  (*A1 : true true ; A2 : false false *)
 destruct_wk H12.
  unfold A1n.inter in Hinter1; unfold A2n.inter in Hinter2;
  rewrite Hinter1 in Hrfei; rewrite Hinter2 in Hrfei; inversion Hrfei.
  (*A1 : false true ; A2 : false false *)
 destruct_wk H12.
  unfold A1n.inter in Hinter1; unfold A2n.inter in Hinter2;
  rewrite Hinter1 in Hrfei; rewrite Hinter2 in Hrfei; inversion Hrfei.
  (*A1 : true false ; A2 : false false *)
  destruct H12 as (*[?*) [? [Himpl ?]](*]*).
  unfold A1n.intra in Hintra1; unfold A2n.intra in Hintra2;
  rewrite Hintra1 in Himpl; rewrite Hintra2 in Himpl; inversion Himpl.
  (*A1 : false false ; A2 : false false*)
      inversion Hxy as [Ht | Hres].
        inversion Ht.
      right; fold (bot_ghb2 E X); fold (bot_ghb1 E X) in Hres;
      apply bot_ghb_incl; auto.
Qed.

Lemma v2_implies_v1 :
  forall E X,
  weaker ->
  A2nWmm.valid_execution E X ->
  A1nWmm.valid_execution E X.
Proof.
intros E X H21 Hv1.
destruct_valid Hv1.
 split; auto; [ |split; auto; split; auto].
split; auto; split; auto.
split.
  auto.
eapply incl_ac; [apply ghb_incl; auto | apply Hvalid].
Qed.

Lemma A2_impl_A1_check :
  forall E X,
  weaker ->
  A2nWmm.valid_execution E X ->
  A1nWmm.valid_execution E X /\ check E X.
Proof.
intros E X Hincl Hv2.
  split; [apply v2_implies_v1; auto |].
    destruct_valid Hv2; unfold check.
    rewrite (ghb2_eq E X) in Hvalid; auto.
Qed.

Lemma A1_check_impl_A2 :
  forall E X,
  weaker ->
  A1nWmm.valid_execution E X /\ check E X ->
  A2nWmm.valid_execution E X.
Proof.
intros E X Hincl [Hv1 Hc2].
  destruct_valid Hv1; split; auto; split; auto; split; auto.
    split.
    auto.
    rewrite (ghb2_eq E X); unfold check in Hc2; auto.
Qed.

Lemma charac :
  forall E X,
  weaker ->
  ((A1nWmm.valid_execution E X /\ check E X) <->
    (A2nWmm.valid_execution E X)).
Proof.
intros E X; split; [intros [Hv1 Hc2] | intro Hv2].
  apply A1_check_impl_A2; auto.
  apply A2_impl_A1_check; auto.
Qed.

End Char.

Module A1b <: Archi.
Definition ppo := A1.ppo.
Lemma ppo_valid : forall E, rel_incl (ppo E) (po_iico E).
  apply A1.ppo_valid.
Qed.
Definition inter := A1.inter.
Definition intra := A1.intra.
Parameter abc : Event_struct -> Execution_witness -> Rln Event.
Hypothesis ab_evts : forall (E:Event_struct) (X:Execution_witness),
  forall x y, abc E X x y -> In _ (events E) x /\ In _ (events E) y.
Parameter Cs : Type.
Parameter cs : Event_struct -> Execution_witness -> Location -> Cs -> Prop.
Parameter evts : Cs -> set Event.
Parameter lockc : Event_struct -> Execution_witness -> Location -> Rln Event.
Definition lock E X := fun e1 => fun e2 => exists l, lockc E X l e1 e2.
Parameter stars : Event_struct -> Execution_witness -> set Event.
End A1b.

Definition ppo_sub E :=
  rel_sub (A1.ppo E) (A2.ppo E).
Definition mrfi2 X :=
  mrel (A2.intra) (rf_intra X).
Definition mrfe2 X :=
  mrel (A2.inter) (rf_inter X).
Definition mrf2 X :=
  rel_union (mrfi2 X) (mrfe2 X).
Definition mrfi1 X :=
  mrel (A1.intra) (rf_intra X).
Definition mrfe1 X :=
  mrel (A1.inter) (rf_inter X).
Definition mrf1 X :=
  rel_union (mrfi1 X) (mrfe1 X).
Definition rf_sub X :=
  rel_sub (mrf1 X) (mrf2 X).

Import A1b.
Module A1bBasic := Basic A1b.
Import A1bBasic.
Module A1bWmm := Wmm A1b.
Import A1bWmm.

Import A2n. Import A2nBasic. Import A2nWmm.

Section Barriers.

Definition fully_barriered (E:Event_struct) (X:Execution_witness) :=
  rel_incl (rel_union (ppo_sub E) (rel_seq (rf_sub X) (A2.ppo E))) (A1b.abc E X).

Lemma ghb1b_eq :
  forall E X,
  A1bWmm.ghb E X = rel_union (rel_union (ws X) (fr E X))
                                        (rel_union (rel_union (mrf1 X) (A1.ppo E))
                                            (A1b.abc E X)) .
Proof.
intros E X; unfold A1bWmm.ghb; unfold mrf1; unfold mrfi1; unfold mrfe1;
  unfold A1b.ppo; unfold A1b.inter; unfold A1b.intra;
  case_eq A1.inter; case_eq A1.intra; intros Hintra Hinter; simpl;
  apply ext_rel; split; intro Hxy.

  inversion Hxy as [Hrfe | Hr].
    right; left; left; right; auto.
    inversion Hr as [Hrfi | Hre].
      right; left; left; left; auto.
      inversion Hre as [Hab | Hres].
        right; right; auto.
        inversion Hres as [Hws_fr | Hppo].
          left; auto.
            right; left; right; auto.

  inversion Hxy as [Hws_fr | Hr].
    right; right; right; left; auto.
    inversion Hr as [Hre | Hab].
      inversion Hre as [Hrf | Hppo].
        inversion Hrf as [Hrfi | Hrfe]; [right; left; auto | left; auto].
        right; right; right; right; auto.
      right; right; left; auto.

  inversion Hxy as [Hrfe | Hr].
    right; left; left; right; auto.
    inversion Hr as [Hab | Hre].
      right; right; auto.
      inversion Hre as [Hws_fr | Hppo].
        left; auto.
          right; left; right; auto.

  inversion Hxy as [Hws_fr | Hr].
    right; right; left; auto.
    inversion Hr as [Hre | Hab].
      inversion Hre as [Hrf | Hppo].
        inversion Hrf as [Ht | Hrfi].
          inversion Ht.
          left; auto.
        right; right; right; auto.
      right; left; auto.

  inversion Hxy as [Hrfi | Hr].
    right; left; left; left; auto.
    inversion Hr as [Hab | Hre].
      right; right; auto.
      inversion Hre as [Hws_fr | Hppo].
        left; auto.
          right; left; right; auto.

  inversion Hxy as [Hws_fr | Hr].
    right; right; left; auto.
    inversion Hr as [Hre | Hab].
      inversion Hre as [Hrf | Hppo].
        inversion Hrf as [Hrfi | Ht].
          left; auto.
          inversion Ht.
        right; right; right; auto.
      right; left; auto.

  inversion Hxy as [Hab | Hr].
    right; right; auto.
    inversion Hr as [Hws_fr | Hppo].
      left; auto.
        right; left; right; auto.

  inversion Hxy as [Hws_fr | Hr].
    right; left; auto.
    inversion Hr as [Hre | Hab].
      inversion Hre as [Ht | Hppo].
        inversion Ht as [Ht1 | Ht2]; [inversion Ht1 | inversion Ht2].
        right; right; auto.
      left; auto.
Qed.

Lemma mhb'2_is_mhb'1_u_rf_sub :
  forall E X,
  weaker ->
  well_formed_event_structure E ->
  (A2nWmm.mhb' E X) =
  rel_union (rel_union (A1bWmm.mhb' E X) (rf_sub X))
    (rel_union (rel_seq (ws X) (rf_sub X)) (rel_seq (fr E X) (rf_sub X))).
Proof.
case_eq A2.inter; case_eq A2.intra; intros Hinter2 Hintra2;
case_eq A1.inter; case_eq A1.intra; intros Hinter1 Hintra1;
unfold mhb'; unfold mhb; unfold rf_sub;
unfold A1bWmm.mhb'; unfold A1bWmm.mhb;
unfold A1bWmm.mrf; unfold mrf; unfold A1bWmm.mrfi; unfold mrfi;
unfold A1bWmm.mrfe; unfold mrfe; unfold inter; unfold intra;
unfold A1b.inter; unfold A1b.intra; unfold mrf1; unfold mrf2;
unfold mrfi1; unfold mrfi2; unfold mrfe1; unfold mrfe2;
rewrite Hinter1; rewrite Hintra1; rewrite Hinter2; rewrite Hintra2;
unfold abc; intros E X Hwk Hwf; apply ext_rel; split; intro Hxy; auto;
simpl in * |- *.

inversion Hxy as [Hr | Hsfr].
  inversion Hr as [Hre | Hsws].
  inversion Hre as [Hrfe | Hres].
  left; left; left; left; auto.
  inversion Hres as [Hrfi | Hws_rf].
    left; left; left; left; auto.
    left; left; left; left; right; auto.
  left; left; left; right; auto.
  left; left; right; auto.

inversion Hxy as [Hu | Hssub].
  inversion Hu as [Hr | Hsub].
    inversion Hr as [Hhbs | Hsfr].
    inversion Hhbs as [Hhb | Hsws].
    left; auto.
      left; right; auto.
      right; auto.
      destruct Hsub as [Hrf ?]; inversion Hrf as [Hrfi | Hrfe].
      left; left; right; left; auto.
      left; left; left; auto.
  inversion Hssub as [Hsws | Hsfr].
    destruct Hsws as [? [? Ht]]; destruct Ht; contradiction.
    destruct Hsfr as [? [? Ht]]; destruct Ht; contradiction.

inversion Hxy as [Hu | Hsfr].
    inversion Hu as [Hhb | Hsws].
      inversion Hhb as [Hrfe | Hr].
        left; left; left; left; left; auto.
        inversion Hr as [Hrfi | Hwsfr].
        left; right; split.
          left; auto.
          intro Hor; inversion Hor as [| Hrfe]; auto.
          destruct Hrfi; destruct Hrfe; contradiction.
        left; left; left; left; right; auto.

      destruct Hsws as [z [Hz Hurf]].
      inversion Hurf as [Hrfi | Hrfe].
      right; left.
      exists z; split; auto.
          split. left; auto.
          intro Hor; inversion Hor as [| Hrfe]; auto.
          destruct Hrfi; destruct Hrfe; contradiction.

      left; left; left; right.
      exists z; split; auto.
          right; auto.

      destruct Hsfr as [z [Hz Hurf]].
      inversion Hurf as [Hrfi | Hrfe].
      right; right.
      exists z; split; auto.
          split. left; auto.
          intro Hor; inversion Hor as [| Hrfe]; auto.
          destruct Hrfi; destruct Hrfe; contradiction.

      left; left; right.
      exists z; split; auto.
          right; auto.

inversion Hxy as [Hu | Hssub].
  inversion Hu as [Hr | Hsub].
    inversion Hr as [Hhbs | Hsfr].
    inversion Hhbs as [Hhb | Hsws].
      inversion Hhb as [Hrfe | Hwsfr].
        left; left; left; auto.
        left; left; right; right; auto.

      left; right; destruct Hsws as [z [Hxz Hzy]]; exists z; split; auto.
        inversion Hzy as [Ht | Hrfe].
          inversion Ht. right; auto.
     right; destruct Hsfr as [z [Hxz Hzy]]; exists z; split; auto.
        inversion Hzy as [Ht | Hrfe].
          inversion Ht. right; auto.

      destruct Hsub as [Hrf ?]; inversion Hrf as [Hrfi | Hrfe].
      left; left; right; left; auto.
      left; left; left; auto.
  inversion Hssub as [Hsws | Hsfr].
    destruct Hsws as [z [Hws [Hrf ?]]].
    left; right; exists z; split; auto.
    destruct Hsfr as [z [Hws [Hrf ?]]].
    right; exists z; split; auto.

inversion Hxy as [Hu | Hsfr].
    inversion Hu as [Hhb | Hsws].
      inversion Hhb as [Hrfe | Hr].
        left; right; split.
          right; auto.
          intro Hor; inversion Hor as [Hrfi | Ht].
            destruct Hrfi; destruct Hrfe; contradiction.
             inversion Ht.
        inversion Hr as [Hrfi | Hwsfr].
        left; left; left; left.
          left; auto.
        left; left; left; left; right; auto.

      destruct Hsws as [z [Hz Hurf]].
      inversion Hurf as [Hrfi | Hrfe].
      left; left; left; right.
      exists z; split; auto.
      left; auto.

      right; left; exists z; split; auto.
      split. right; auto.
      intro Hor; inversion Hor as [Hrfi | Ht].
        destruct Hrfe; destruct Hrfi; contradiction.
        inversion Ht; auto.

      destruct Hsfr as [z [Hz Hurf]].
      inversion Hurf as [Hrfi | Hrfe].
      left; left; right.
      exists z; split; auto.
          left; auto.

      right; right.
      exists z; split; auto.
          split. right; auto.
          intro Hor; inversion Hor as [Hrfi | Ht]; auto.
          destruct Hrfi; destruct Hrfe; contradiction.

inversion Hxy as [Hu | Hssub].
  inversion Hu as [Hr | Hsub].
    inversion Hr as [Hhbs | Hsfr].
    inversion Hhbs as [Hhb | Hsws].
      inversion Hhb as [Hrfe | Hwsfr].
        left; left; right; auto.
        left; left; right; right; auto.

      left; right; destruct Hsws as [z [Hxz Hzy]]; exists z; split; auto.
        inversion Hzy as [Hrfi | Ht].
          left; auto. inversion Ht; auto.
     right; destruct Hsfr as [z [Hxz Hzy]]; exists z; split; auto.
        inversion Hzy as [Hrfi | Ht].
          left; auto. inversion Ht.

      destruct Hsub as [Hrf ?]; inversion Hrf as [Hrfi | Hrfe].
      left; left; right; left; auto.
      left; left; left; auto.
  inversion Hssub as [Hsws | Hsfr].
    destruct Hsws as [z [Hws [Hrf ?]]].
    left; right; exists z; split; auto.
    destruct Hsfr as [z [Hws [Hrf ?]]].
    right; exists z; split; auto.

inversion Hxy as [Hu | Hsfr].
    inversion Hu as [Hhb | Hsws].
      inversion Hhb as [Hrfe | Hr].
        left; right; split.
          right; auto.
          intro Hor; inversion Hor as [Ht | Hrfi].
             inversion Ht.
            destruct Hrfi; destruct Hrfe; contradiction.
        inversion Hr as [Hrfi | Hwsfr].
        left; right.
          split.
          left; auto.
          intro Hor; inversion Hor; auto.
        left; left; left; left; auto.

      destruct Hsws as [z [Hz Hurf]].
        right; left.
      exists z; split; auto.
      split; auto.
      intro Hor; inversion Hor; auto.

      destruct Hsfr as [z [Hz Hurf]].
      right; right.
      exists z; split; auto.
      split; auto.
      intro Hor; inversion Hor; auto.

inversion Hxy as [Hu | Hssub].
  inversion Hu as [Hr | Hsub].
    inversion Hr as [Hhbs | Hsfr].
    inversion Hhbs as [Hwsfr | Hsws].
        left; left; right; right; auto.

      left; right; destruct Hsws as [z [Hxz Hzy]]; exists z; split; auto.
        inversion Hzy as [Ht1 | Ht2].
          inversion Ht1; auto. inversion Ht2; auto.
     right; destruct Hsfr as [z [Hxz Hzy]]; exists z; split; auto.
        inversion Hzy as [Ht1 | Ht2].
          inversion Ht1; auto. inversion Ht2; auto.

      destruct Hsub as [Hrf ?]; inversion Hrf as [Hrfi | Hrfe].
      left; left; right; left; auto.
      left; left; left; auto.
  inversion Hssub as [Hsws | Hsfr].
    destruct Hsws as [z [Hws [Hrf ?]]].
    left; right; exists z; split; auto.
    destruct Hsfr as [z [Hws [Hrf ?]]].
    right; exists z; split; auto.

inversion Hxy as [Hu | Hsfr].
    inversion Hu as [Hhb | Hsws].
      inversion Hhb as [Hrfe | Hr].
        left; left; left; left; left; auto.
        left; left; left; left; right; right; auto.

      destruct Hsws as [z [Hz Hurf]].
        left; left; left; right.
      exists z; split; auto.
      inversion Hurf; auto. inversion H; auto. right; auto.

      destruct Hsfr as [z [Hz Hurf]].
      left; left; right.
      exists z; split; auto.
      inversion Hurf; auto. inversion H; auto. right; auto.

destruct_wk Hwk; rewrite Hinter1 in Hrfii;
  rewrite Hinter2 in Hrfii; inversion Hrfii.
destruct_wk Hwk; rewrite Hinter1 in Hrfii;
  rewrite Hinter2 in Hrfii; inversion Hrfii.

inversion Hxy as [Hu | Hsfr].
  inversion Hu as [Hr | Hsws].
    inversion Hr as [Hrfe | Hwsfr].
        left; left; left; left; left; auto.
        left; left; left; left; right; auto.

      left; left; left; right; auto.
      left; left; right; auto.

inversion Hxy as [Hu | Hssub].
  inversion Hu as [Hr | Hsub].
    inversion Hr as [Hhbs | Hsfr].
    inversion Hhbs as [Huf | Hsws].
      inversion Huf as [Hrfe | Hwsfr].
        left; left; left; auto.
        left; left; right; auto.

      left; right; auto.
      right; auto.

      destruct Hsub as [Hrf ?]; inversion Hrf as [Ht | Hrfe].
      inversion Ht.
      left; left; left; auto.
  inversion Hssub as [Hsws | Hsfr].
    destruct Hsws as [z [Hws [Hrf ?]]].
    left; right; exists z; split; auto.
    destruct Hsfr as [z [Hws [Hrf ?]]].
    right; exists z; split; auto.

destruct_wk Hwk; rewrite Hinter1 in Hrfii;
  rewrite Hinter2 in Hrfii; inversion Hrfii.
destruct_wk Hwk; rewrite Hinter1 in Hrfii;
  rewrite Hinter2 in Hrfii; inversion Hrfii.

inversion Hxy as [Hu | Hsfr].
  inversion Hu as [Hr | Hsws].
    inversion Hr as [Hrfe | Hwsfr].
        left; right; split.
          right; auto.
          intro Hor; inversion Hor; auto.

      left; left; left; left; auto.
       right; left; destruct Hsws as [z [? Hor]]; exists z; split; auto.
         inversion Hor as [Ht | Hrfe].
           inversion Ht.
           split. right; auto.
             intro Hort; inversion Hort as [Ht1 | Ht2]; auto.
       right; right; destruct Hsfr as [z [? Hor]]; exists z; split; auto.
         inversion Hor as [Ht | Hrfe].
           inversion Ht.
           split. right; auto.
             intro Hort; inversion Hort as [Ht1 | Ht2]; auto.

inversion Hxy as [Hu | Hssub].
  inversion Hu as [Hr | Hsub].
    inversion Hr as [Hhbs | Hsfr].
    inversion Hhbs as [Hwsfr | Hsws].
        left; left; right; auto.

      destruct Hsws as [? [? Hor]]; inversion Hor as [t1 | t2].
        inversion t1; auto. inversion t2; auto.
      destruct Hsfr as [? [? Hor]]; inversion Hor as [t1 | t2].
        inversion t1; auto. inversion t2; auto.

      destruct Hsub as [Hrf ?]; inversion Hrf as [Ht | Hrfe].
      inversion Ht.
      left; left; left; auto.
  inversion Hssub as [Hsws | Hsfr].
    destruct Hsws as [z [Hws [Hrf ?]]].
    left; right; exists z; split; auto.
    destruct Hsfr as [z [Hws [Hrf ?]]].
    right; exists z; split; auto.

destruct_wk Hwk; rewrite Hintra1 in Hrfei;
  rewrite Hintra2 in Hrfei; inversion Hrfei.
destruct_wk Hwk; rewrite Hintra1 in Hrfei;
  rewrite Hintra2 in Hrfei; inversion Hrfei.

destruct_wk Hwk; rewrite Hintra1 in Hrfei;
  rewrite Hintra2 in Hrfei; inversion Hrfei.
destruct_wk Hwk; rewrite Hintra1 in Hrfei;
  rewrite Hintra2 in Hrfei; inversion Hrfei.

inversion Hxy as [Hu | Hsfr].
  inversion Hu as [Hr | Hsws].
    inversion Hr as [Hrfi | Hwsfr].
        left; left; left; left; left; auto.
        left; left; left; left; right; auto.

      left; left; left; auto.
      left; left; right; auto.

inversion Hxy as [Hu | Hssub].
  inversion Hu as [Hr | Hsub].
    inversion Hr as [Hhbs | Hsfr].
    inversion Hhbs as [Hwsfr | Hsws].
        left; auto.

      destruct Hsws as [z [? Hor]]; inversion Hor as [Hrfi | t2].
        left; right; exists z; split; auto. inversion t2; auto.
      destruct Hsfr as [z [? Hor]]; inversion Hor as [Hrfi | t2].
        right; exists z; split; auto. inversion t2; auto.

      destruct Hsub as [Hrf ?]; inversion Hrf as [Hrfi | Ht].
      left; left; left; auto.
      inversion Ht.
  inversion Hssub as [Hsws | Hsfr].
    destruct Hsws as [z [Hws [Hor ?]]].
    left; right; exists z; split; auto.
    destruct Hsfr as [z [Hws [Hrf ?]]].
    right; exists z; split; auto.

inversion Hxy as [Hu | Hsfr].
  inversion Hu as [Hr | Hsws].
    inversion Hr as [Hrfi | Hwsfr].
        left; right; split; auto.
          left; auto.
          intro Hor; inversion Hor; auto.

      left; left; left; left; auto.
      right; left; destruct Hsws as [z [? Hor]]; exists z; split; auto.
      split; auto. intro Hort; inversion Hort; auto.
      right; right; destruct Hsfr as [z [? Hor]]; exists z; split; auto.
      split; auto. intro Hort; inversion Hort; auto.

inversion Hxy as [Hu | Hssub].
  inversion Hu as [Hr | Hsub].
    inversion Hr as [Hhbs | Hsfr].
    inversion Hhbs as [Hwsfr | Hsws].
        left; left; right; auto.

      destruct Hsws as [z [? Hor]]; inversion Hor as [t1 | t2].
        inversion t1; auto. inversion t2; auto.
      destruct Hsfr as [z [? Hor]]; inversion Hor as [t1 | t2].
        inversion t1; auto. inversion t2; auto.

      destruct Hsub as [Hrf ?]; inversion Hrf as [Hrfi | Ht].
      left; left; left; auto.
      inversion Ht.
  inversion Hssub as [Hsws | Hsfr].
    destruct Hsws as [z [Hws [Hor ?]]].
    left; right; exists z; split; auto.
    destruct Hsfr as [z [Hws [Hrf ?]]].
    right; exists z; split; auto.

destruct_wk Hwk; rewrite Hintra1 in Hrfei;
  rewrite Hintra2 in Hrfei; inversion Hrfei.
destruct_wk Hwk; rewrite Hintra1 in Hrfei;
  rewrite Hintra2 in Hrfei; inversion Hrfei.

destruct_wk Hwk; rewrite Hintra1 in Hrfei;
  rewrite Hintra2 in Hrfei; inversion Hrfei.
destruct_wk Hwk; rewrite Hintra1 in Hrfei;
  rewrite Hintra2 in Hrfei; inversion Hrfei.

destruct_wk Hwk; rewrite Hinter1 in Hrfii;
  rewrite Hinter2 in Hrfii; inversion Hrfii.
destruct_wk Hwk; rewrite Hinter1 in Hrfii;
  rewrite Hinter2 in Hrfii; inversion Hrfii.

inversion Hxy as [Hu | Hsfr].
  inversion Hu as [Hwsfr | Hsws].
        left; left; left; left; auto.

    destruct Hsws as [? [? Hor]]; inversion Hor as [Ht1 | Ht2].
    inversion Ht1; auto. inversion Ht2; auto.
    destruct Hsfr as [? [? Hor]]; inversion Hor as [Ht1 | Ht2].
    inversion Ht1; auto. inversion Ht2; auto.

inversion Hxy as [Hu | Hssub].
  inversion Hu as [Hr | Hsub].
    inversion Hr as [Hhbs | Hsfr].
    inversion Hhbs as [Hwsfr | Hsws].
        left; left; auto.
        left; right; auto.

      right; auto.

      destruct Hsub as [Hrf ?]; inversion Hrf as [Ht1 | Ht2].
      inversion Ht1.
      inversion Ht2.
  inversion Hssub as [Hsws | Hsfr].
    destruct Hsws as [z [Hws [Ht ?]]].
    inversion Ht as [t1 | t2]. inversion t1; auto. inversion t2; auto.
    destruct Hsfr as [z [Hws [Ht ?]]].
    inversion Ht as [t1 | t2]. inversion t1; auto. inversion t2; auto.
Qed.

Lemma mhb'_ppo2_is_u_seq_int :
  forall E X x y,
  weaker ->
  well_formed_event_structure E ->
  tc (rel_seq (A2nWmm.mhb' E X) (tc (ppo E))) x y ->
  tc (rel_seq (rel_union (rel_union (A1bWmm.mhb' E X) (rf_sub X))
    (rel_union (rel_seq (ws X) (rf_sub X)) (rel_seq (fr E X) (rf_sub X)))) (tc (ppo E))) x y.
Proof.
intros E X x y Hwk Hwf Hxy.
rewrite (mhb'2_is_mhb'1_u_rf_sub X Hwk Hwf) in Hxy; auto.
Qed.

Lemma mhb'_ppo2_is_u_seq :
  forall E X x y,
  weaker ->
  well_formed_event_structure E ->
  tc (rel_seq (maybe (A2nWmm.mhb' E X)) (tc (ppo E))) x y ->
  tc (rel_seq (maybe (rel_union (rel_union (A1bWmm.mhb' E X) (rf_sub X))
    (rel_union (rel_seq (ws X) (rf_sub X)) (rel_seq (fr E X) (rf_sub X))))) (tc (ppo E))) x y.
Proof.
intros E X x y Hwk Hwf Hxy.
rewrite (mhb'2_is_mhb'1_u_rf_sub X Hwk Hwf) in Hxy; auto.
Qed.

Lemma mhb1_eq :
  forall E X x y,
  A1bWmm.mhb E X x y ->
  tc
  (rel_union (rel_union (ws X) (fr E X))
     (rel_union (rel_union (mrf1 X) (A1.ppo E))
     (A1b.abc E X) )) x y.
Proof.
unfold A1bWmm.mhb; case_eq A1.inter; case_eq A1.intra; intros Hintra Hinter;
unfold A1b.inter; unfold A1b.intra; unfold mrf1; unfold mrfi1; unfold mrfe1;
rewrite Hinter; rewrite Hintra; intros E X x y Hxy; apply trc_step; simpl.

inversion Hxy as [Hrfe | Hr].
  right; left; left; right; auto.
  inversion Hr as [Hrfi | Hws_fr].
    right; left; left; left; auto.
    left; auto.

inversion Hxy as [Hrfe | Hws_fr].
  right; left; left; right; auto.
  left; auto.

inversion Hxy as [Hrfi | Hws_fr].
  right; left; left; left; auto.
  left; auto.

left; auto.
Qed.

Lemma mhb'1_eq :
  forall E X x y,
  A1bWmm.mhb' E X x y ->
  tc
  (rel_union (rel_union (ws X) (fr E X))
     (rel_union (rel_union (mrf1 X) (A1.ppo E))
     (A1b.abc E X) )) x y.
Proof.
intros E X x y Hxy;
inversion Hxy as [Hu | Hsfr].
  inversion Hu as [Hmhb | Hsws].
    apply mhb1_eq; auto.

    destruct Hsws as [z [Hxz Hzy]]; apply trc_ind with z; apply trc_step.
      left; left; auto.
      right; left; left; auto.

    destruct Hsfr as [z [Hxz Hzy]]; apply trc_ind with z; apply trc_step.
      left; right; auto.
      right; left; left; auto.
Qed.

Axiom excluded_middle : forall (A:Prop), A \/ ~A.

Lemma ppo2_in_ghb1 :
  forall E X x y,
  fully_barriered E X ->
  ppo E x y ->
  A1bWmm.ghb E X x y.
Proof.
intros E X x y Hfb Hxy.
  generalize (excluded_middle (A1b.ppo E x y)); intro Hor.
  inversion Hor as [Hppo1 | Hnppo1].
   apply A1bBasic.ppo_in_ghb; auto.
   assert (ppo_sub E x y) as Hppos.
     split; auto.

   apply A1bBasic.ab_in_ghb; apply Hfb;
 left; auto.
Qed.

Lemma rf_sub_seq_ppo2_in_ab1 :
  forall E X x z y,
  fully_barriered E X ->
  rf_sub X x z ->
  ppo E z y ->
  A1b.abc E X x y.
Proof.
intros E X x z y Hfb Hxz Hzy; apply Hfb.
right.
exists z; split; auto.
Qed.

Lemma seq_implies_ghb1_int :
  forall E X x y,
  weaker ->
  well_formed_event_structure E ->
 fully_barriered E X ->
  tc (rel_seq (rel_union (rel_union (A1bWmm.mhb' E X) (rf_sub X))
   (rel_union (rel_seq (ws X) (rf_sub X)) (rel_seq (fr E X) (rf_sub X)))) (tc (ppo E))) x y ->
  tc (A1bWmm.ghb E X) x y.
Proof.
intros E X x y Hwk Hwf Hfb Hxy.

induction Hxy.
  destruct H as [z [Hxz Hzy]].
    inversion Hxz as [Hu | Hs].
    inversion Hu as [Hmhb'1 | Hrf_sub].
      apply trc_ind with z.
        rewrite (ghb1b_eq E X).
        apply (mhb'1_eq Hmhb'1).
        assert (rel_incl (ppo E) (A1bWmm.ghb E X)) as Hincl.
          intros e1 e2 H12; apply ppo2_in_ghb1; auto.
        apply (tc_incl Hincl Hzy).

        generalize (tc_dec Hzy); intros [z' [Hzz' Hor]].
        inversion Hor as [Htc | Heq].
          apply trc_ind with z'.
        rewrite (ghb1b_eq E X).
      apply trc_step; right; right.
       apply (rf_sub_seq_ppo2_in_ab1 Hfb Hrf_sub Hzz').
        assert (rel_incl (ppo E) (A1bWmm.ghb E X)) as Hincl.
          intros e1 e2 H12; apply ppo2_in_ghb1; auto.
        apply (tc_incl Hincl Htc).
         subst;        rewrite (ghb1b_eq E X).
      apply trc_step; right; right.
       apply (rf_sub_seq_ppo2_in_ab1 Hfb Hrf_sub Hzz').

  inversion Hs as [Hsws | Hsfr].
    destruct Hsws as [e [Hxe Hez]].
        generalize (tc_dec Hzy); intros [z' [Hzz' Hor]].
        inversion Hor as [Htc | Heq].
          apply trc_ind with z'.
    apply trc_ind with e; apply trc_step.
        rewrite (ghb1b_eq E X).
      left; left; auto.
        rewrite (ghb1b_eq E X).
      right; right. apply rf_sub_seq_ppo2_in_ab1 with z; auto.
        assert (rel_incl (ppo E) (A1bWmm.ghb E X)) as Hincl.
          intros e1 e2 H12; apply ppo2_in_ghb1; auto.
        apply (tc_incl Hincl Htc).

  subst;     apply trc_ind with e; apply trc_step.
        rewrite (ghb1b_eq E X).
      left; left; auto.
        rewrite (ghb1b_eq E X).
      right; right. apply rf_sub_seq_ppo2_in_ab1 with z; auto.

    destruct Hsfr as [e [Hxe Hez]].

        generalize (tc_dec Hzy); intros [z' [Hzz' Hor]].
        inversion Hor as [Htc | Heq].
          apply trc_ind with z'.
    apply trc_ind with e; apply trc_step.
        rewrite (ghb1b_eq E X).
      left; right; auto.
        rewrite (ghb1b_eq E X).
      right; right;  apply rf_sub_seq_ppo2_in_ab1 with z; auto.
        assert (rel_incl (ppo E) (A1bWmm.ghb E X)) as Hincl.
          intros e1 e2 H12; apply ppo2_in_ghb1; auto.
        apply (tc_incl Hincl Htc).

  subst;     apply trc_ind with e; apply trc_step.
        rewrite (ghb1b_eq E X).
      left; right; auto.
        rewrite (ghb1b_eq E X).
      right; right;  apply rf_sub_seq_ppo2_in_ab1 with z; auto.

apply trc_ind with z; auto.
Qed.

Lemma seq_implies_ghb1 :
  forall E X x y,
  weaker ->
  well_formed_event_structure E ->
 fully_barriered E X ->
  tc (rel_seq (maybe (rel_union (rel_union (A1bWmm.mhb' E X) (rf_sub X))
   (rel_union (rel_seq (ws X) (rf_sub X)) (rel_seq (fr E X) (rf_sub X))))) (tc (ppo E))) x y ->
  tc (A1bWmm.ghb E X) x y.
Proof.
intros E X x y Hwk Hwf Hfb Hxy.

induction Hxy.
  destruct H as [z [Hor Hzy]].
    inversion Hor as [Hxz | Heq].
      apply seq_implies_ghb1_int; auto.
        apply trc_step; exists z; auto.
   subst; generalize Hzy; apply tc_incl.
  intros e1 e2 H12; apply ppo2_in_ghb1; auto.

  apply trc_ind with z; auto.
Qed.

Lemma ppo_ac :
  forall E,
  well_formed_event_structure E ->
  ~(exists x, (ppo E) x x).
Proof.
unfold not;
intros E Hwf [x Hppo].
unfold well_formed_event_structure in Hwf.
generalize (ppo_valid Hppo); intro Hpo_iico.
apply (po_ac Hwf Hpo_iico).
Qed.

Lemma mhb_ac :
  forall E X,
  write_serialization_well_formed (events E) (ws X) /\
  rfmaps_well_formed E (events E) (rf X) ->
  ~(exists x, mhb E X x x).
Proof.
unfold not;
intros E X Hs [x Hx].
generalize (mhb_in_hb E X x x Hx); intro Hhb.
apply (hb_ac Hs Hhb).
Qed.

Lemma ghb2_cycle_implies_ghb1_cycle :
  forall E X x,
  weaker ->
  well_formed_event_structure E ->
  write_serialization_well_formed (events E) (ws X) /\
  rfmaps_well_formed E (events E) (rf X) ->
  fully_barriered E X ->
  tc (A2nWmm.ghb E X) x x ->
  exists y, tc (A1bWmm.ghb E X) y y.
Proof.
intros E X x Hwk Hwf Hs Hfb Hx.
rewrite (ghb2_is_mhb_ppo2 E X) in Hx.
assert (exists y, tc (rel_seq (maybe (mhb' E X)) (tc (A2.ppo E))) y y) as Hc.
eapply (mhb_union_ppo_cycle_implies_mhb'_seq_ppo_cycle2 X Hwf Hs Hx); auto; apply Hx.
destruct Hc as [y Hc].
generalize (mhb'_ppo2_is_u_seq Hwk Hwf Hc); intro Hcy.
exists y; apply (seq_implies_ghb1 Hwk Hwf Hfb Hcy).
Qed.

Lemma fb_implies_valid : (*barriers guarantee*)
  forall E X,
  weaker ->
  well_formed_event_structure E ->
  fully_barriered E X ->
  A1bWmm.valid_execution E X ->
  A2nWmm.valid_execution E X.
Proof.
intros E X Hincl Hwf Hfb Hva1.
  destruct_valid Hva1; split; auto; split; auto.
   split; auto; split; auto.
   split; auto.
   split.
    auto.
  unfold acyclic; unfold not; intros x Hx.
  assert (exists x, tc (ghb E X) x x) as Hc.
    exists x; auto.
  assert (write_serialization_well_formed (events E) (ws X) /\
  rfmaps_well_formed E (events E) (rf X)) as Hs.
    split; auto; split; auto.
  generalize (ghb2_cycle_implies_ghb1_cycle Hincl Hwf Hs Hfb Hx); intros [y Hcy].
  apply (Hvalid y Hcy).
Qed.

Inductive AB (E:Event_struct) (X:Execution_witness) (fenb fenc:Rln Event) : Event -> Event -> Prop :=
  | Base : forall e1 e2,
      fenb e1 e2 -> AB E X fenb fenc e1 e2
  | Acumul : forall w1 r1 e2,
      (rf_sub X) w1 r1 /\ fenc r1 e2 -> AB E X fenb fenc w1 e2.

Lemma barriers_placement :
  forall E X,
  weaker ->
  well_formed_event_structure E ->
  A1b.abc E X = AB E X (ppo_sub E) (A2n.ppo E) ->
  A1bWmm.valid_execution E X ->
  A2nWmm.valid_execution E X.
Proof.
intros E X Hwk Hwf Hab; apply fb_implies_valid; auto;
unfold fully_barriered; rewrite Hab.
intros x y Hxy; inversion Hxy as [Hb | Hc].
  apply Base; auto.
  destruct Hc as [z [Hrf Hppo]]; apply Acumul with z; auto.
Qed.

Definition wfb E X := rel_incl (ppo_sub E) (A1b.abc E X).

Lemma mrf_or :
  forall X x y,
  mrf2 X x y -> mrfe2 X x y \/ mrfi2 X x y.
Proof.
intros X x y Hxy.
inversion Hxy; [right; auto | left; auto].
Qed.

Lemma mrfi2_implies_same_proc :
  forall X x y, mrfi2 X x y -> proc_of x = proc_of y.
Proof.
intros X x y Hxy; unfold mrfi2 in Hxy;
case_eq A2.intra; intro Hi; rewrite Hi in Hxy; simpl in Hxy.
destruct Hxy; auto.
inversion Hxy.
Qed.
Lemma mrfe1_implies_diff_proc :
  forall X x y, mrfe1 X x y -> proc_of x <> proc_of y.
Proof.
intros X x y Hxy; unfold mrfe1 in Hxy;
case_eq A1.inter; intro Hi; rewrite Hi in Hxy; simpl in Hxy.
destruct Hxy; auto.
inversion Hxy.
Qed.

Lemma same_rfe_implies_rf_sub_is_rfi_sub :
  forall E X,
  weaker ->
  well_formed_event_structure E ->
  mrfe1 = mrfe2 ->
  rf_sub X = rel_sub (mrfi1 X) (mrfi2 X).
Proof.
intros E X Hwk Hwf Hmrf; apply (ext_rel (rf_sub X) (rel_sub (mrfi1 X) (mrfi2 X))); split; intro Hxy.
  destruct Hxy as [H2 H1].
  generalize (mrf_or H2); intro Hor.
  inversion Hor as [He | Hi].
    rewrite <- Hmrf in He.
    assert (mrf1 X x y) as Hc.
      right; auto.
    contradiction.
    split; auto.
      intro Hc; apply H1; left; auto.
  destruct Hxy as [H2 H1]; split.
    left; auto.
    intro Hc; apply H1.
    inversion Hc as [Hi | He]; auto.
    generalize (mrfi2_implies_same_proc X x y H2); intro Heq.
    generalize (mrfe1_implies_diff_proc X x y He); intro Hdiff.
  contradiction.
Qed.

Lemma wfb_ppo_sub_in_ab1 :
  forall E X x y,
  wfb E X ->
  ppo_sub E x y ->
  A1b.abc E X x y.
Proof.
intros E X x y Hfb Hxy; apply Hfb.
auto.
Qed.

Lemma mhb_incl :
  forall E X x y,
  weaker ->
  wfb E X -> mrfe1 = mrfe2 ->
  (mrfi1 = mrfi2 \/ rel_incl (mrfi X) (ppo E)) ->
  mhb E X x y ->
  tc
    (rel_union (rel_union (ws X) (fr E X))
       (rel_union (rel_union (mrf1 X) (A1.ppo E))
          (A1b.abc E X) )) x y.
Proof.
case_eq A2.inter; case_eq A2.intra; intros Hintra2 Hinter2;
case_eq A1.inter; case_eq A1.intra; intros Hintra1 Hinter1;
unfold mhb; unfold mrf1; unfold mrfi1; unfold mrfe1;
unfold inter; unfold intra;
rewrite Hintra2; rewrite Hinter2; rewrite Hintra1; rewrite Hinter1; simpl;
intros E X x y Hwk Hwfb HmrfX Hrfi_or Hxy.

  apply trc_step; inversion Hxy as [Hrfe | Hr].
    right; left; left; right; auto.
    inversion Hr as [Hrfi | Hre].
      right; left; left; left; auto.
      left; auto.

  apply trc_step; inversion Hxy as [Hrfe | Hr].
    right; left; left; right; auto.
    inversion Hr as [Hrfi | Hre].
      assert (mrfi2 X x y) as Hmrfi.
        unfold mrfi2; unfold intra; rewrite Hintra2; simpl; auto.
      inversion Hrfi_or as [mrfi_eq | mrfi_in_ppo].
        rewrite <- mrfi_eq in Hmrfi; inversion Hmrfi.

      generalize (mrfi_in_ppo x y Hmrfi); intro Hppo.
      generalize (excluded_middle (A1.ppo E x y)); intro Hor.
      inversion Hor as [H1 | Hn1].
        right; left; right; auto.
        right; right; apply Hwfb; split; auto.
      left; auto.

  assert ( (fun  (_ _ : Event) => False) = mrfe2 X) as Hmrf.
    rewrite <- HmrfX; trivial.
  unfold mrfe2 in Hmrf; rewrite Hinter2 in Hmrf; simpl in Hmrf.
  apply trc_step; inversion Hxy as [Hrfe | Hr].
    rewrite <- Hmrf in Hrfe; inversion Hrfe.
    inversion Hr as [Hrfi | Hre].
      right; left; left; left; auto.
      left; auto.

  assert ( (fun  (_ _ : Event) => False) = mrfe2 X) as Hmrf.
    rewrite <- HmrfX; trivial.
  unfold mrfe2 in Hmrf; rewrite Hinter2 in Hmrf; simpl in Hmrf.
  apply trc_step; inversion Hxy as [Hrfe | Hr].
    rewrite <- Hmrf in Hrfe; inversion Hrfe.
    inversion Hr as [Hrfi | Hre].
      assert (mrfi2 X x y) as Hmrfi.
        unfold mrfi2; unfold intra; rewrite Hintra2; simpl; auto.
     inversion Hrfi_or as [mrfi_eq | mrfi_in_ppo].
        rewrite <- mrfi_eq in Hmrfi; inversion Hmrfi.

      generalize (mrfi_in_ppo x y Hmrfi); intro Hppo.
      generalize (excluded_middle (A1.ppo E x y)); intro Hor.
      inversion Hor as [H1 | Hn1].
        right; left; right; auto.
        right; right; apply Hwfb; split; auto.
      left; auto.

 destruct_wk Hwk;
 rewrite Hintra1 in Hrfii;
  rewrite Hintra2 in Hrfii; inversion Hrfii.

  apply trc_step; inversion Hxy as [Hrfe | Hr].
    right; left; left; right; auto.
      left; auto.

 destruct_wk Hwk;
 rewrite Hintra1 in Hrfii;
  rewrite Hintra2 in Hrfii; inversion Hrfii.

  assert ( (fun  (_ _ : Event) => False) = mrfe2 X) as Hmrf.
    rewrite <- HmrfX; trivial.
  unfold mrfe2 in Hmrf; rewrite Hinter2 in Hmrf; simpl in Hmrf.
  apply trc_step; inversion Hxy as [Hrfe | Hr].
    rewrite <- Hmrf in Hrfe; inversion Hrfe.
      left; auto.

 destruct_wk Hwk;
 rewrite Hinter1 in Hrfei;
  rewrite Hinter2 in Hrfei; inversion Hrfei.

 destruct_wk Hwk;
 rewrite Hinter1 in Hrfei;
  rewrite Hinter2 in Hrfei; inversion Hrfei.

    apply trc_step; inversion Hxy as [Hrfi | Hre].
      right; left; left; left; auto.
      left; auto.

    apply trc_step; inversion Hxy as [Hrfi | Hre].
      assert (mrfi2 X x y) as Hmrfi.
        unfold mrfi2; unfold intra; rewrite Hintra2; simpl; auto.
     inversion Hrfi_or as [mrfi_eq | mrfi_in_ppo].
        rewrite <- mrfi_eq in Hmrfi; inversion Hmrfi.
      generalize (mrfi_in_ppo x y Hmrfi); intro Hppo.
      generalize (excluded_middle (A1.ppo E x y)); intro Hor.
      inversion Hor as [H1 | Hn1].
        right; left; right; auto.
        right; right; apply Hwfb; split; auto.
      left; auto.

 destruct_wk Hwk;
 rewrite Hinter1 in Hrfei;
  rewrite Hinter2 in Hrfei; inversion Hrfei.

 destruct_wk Hwk;
 rewrite Hinter1 in Hrfei;
  rewrite Hinter2 in Hrfei; inversion Hrfei.

 destruct_wk Hwk;
 rewrite Hintra1 in Hrfii;
  rewrite Hintra2 in Hrfii; inversion Hrfii.

  apply trc_step; left; auto.
Qed.

Lemma ppo2_in_ghb1' :
  forall E X x y,
  wfb E X ->
  ppo E x y ->
  A1bWmm.ghb E X x y.
Proof.
intros E X x y Hfb Hxy.
  generalize (excluded_middle (A1b.ppo E x y)); intro Hor.
  inversion Hor as [Hppo1 | Hnppo1].
   apply A1bBasic.ppo_in_ghb; auto.
   assert (ppo_sub E x y) as Hppos.
     split; auto.

   apply A1bBasic.ab_in_ghb; apply Hfb; auto.
Qed.

Lemma wfb_seq_implies_ghb1' :
  forall E X x y,
  weaker ->
  well_formed_event_structure E ->
  wfb E X -> mrfe1 = mrfe2 ->
  (mrfi1 = mrfi2 \/ rel_incl (mrfi X) (ppo E)) ->
  tc (rel_seq (A2nWmm.mhb' E X) (tc (A2n.ppo E))) x y ->
  tc (A1bWmm.ghb E X) x y.
Proof.
intros E X x y Hwk Hwf Hfb Hmrf Hrfi_or Hxy.
rewrite (ghb1b_eq E X).
induction Hxy.
  destruct H as [z [Hxz Hzy]].
    inversion Hxz as [Hu | Hs].
    inversion Hu as [Hmhb | Hrf_sub].

     generalize (tc_dec Hzy); intros [z' [Hzz' Horz'y]].
     inversion Horz'y as [Hz'y | Heq].
      apply trc_ind with z'.

      apply trc_ind with z.
      apply (mhb_incl x z Hwk Hfb Hmrf Hrfi_or Hmhb).
        apply trc_step; right.
        generalize (excluded_middle (A1b.ppo E z z')); intro Hor.
        inversion Hor as [H1 | Hn1].
          left; right; auto.
          right; apply wfb_ppo_sub_in_ab1; unfold ppo_sub; unfold rel_sub; auto.

        rewrite <- (ghb1b_eq E X).
        assert (rel_incl (ppo E) (A1bWmm.ghb E X)) as Hincl.
          intros e1 e2 H12; apply ppo2_in_ghb1'; auto.
        apply (tc_incl Hincl Hz'y).

   subst; apply trc_ind with z.
      apply (mhb_incl x z Hwk Hfb Hmrf Hrfi_or Hmhb).

        rewrite <- (ghb1b_eq E X).
        assert (rel_incl (ppo E) (A1bWmm.ghb E X)) as Hincl.
          intros e1 e2 H12; apply ppo2_in_ghb1'; auto.
        apply (tc_incl Hincl Hzy).

     generalize (tc_dec Hzy); intros [z' [Hzz' Horz'y]].
     inversion Horz'y as [Hz'y | Heq].
      apply trc_ind with z'.

      destruct Hrf_sub as [e [Hws Hrf]].
      apply trc_ind with e.
      apply trc_step; left; left; auto.
        generalize (excluded_middle (mrf1 X e z)); intro Hor.
        inversion Hor as [H1 | Hn1].
          apply trc_ind with z.
          apply trc_step; right; left; left; auto.
        generalize (excluded_middle (A1b.ppo E z z')); intro Horp.
        inversion Horp as [H1p | Hn1p].
          apply trc_step; right; left; right; auto.
          apply trc_step; right; right; apply Hfb; unfold ppo_sub; unfold rel_sub; auto.
        assert (rf_sub X e z) as Hrf_sub.
          unfold rf_sub; unfold rel_sub; split; auto.
          apply trc_ind with z; apply trc_step.
        assert (mrfi2 X e z) as Hmrfi.
          rewrite (same_rfe_implies_rf_sub_is_rfi_sub X Hwk Hwf) in Hrf_sub.
          destruct Hrf_sub; auto. apply Hmrf.

          inversion Hrfi_or as [mrfi_eq | mrfi_in_ppo].

          rewrite <- mrfi_eq in Hmrfi; assert False as Ht.
            apply Hn1; left; auto. inversion Ht.

        generalize (mrfi_in_ppo e z Hmrfi); intro Hppo2.
        generalize (excluded_middle (A1b.ppo E e z)); intro Horp.
        inversion Horp as [H1p | Hn1p].
           right; left; right; auto.
            right; right; apply Hfb; split; auto.

        generalize (excluded_middle (A1b.ppo E z z')); intro Horp.
        inversion Horp as [H1p | Hn1p].
            right; left; right; auto.
            right; right; apply Hfb; unfold ppo_sub; unfold rel_sub; auto.

        rewrite <- (ghb1b_eq E X).
        assert (rel_incl (ppo E) (A1bWmm.ghb E X)) as Hincl.
          intros e1 e2 H12; apply ppo2_in_ghb1'; auto.
        apply (tc_incl Hincl Hz'y).

  subst;
      destruct Hrf_sub as [e [Hws Hrf]].
      apply trc_ind with e.
      apply trc_step; left; left; auto.
        generalize (excluded_middle (mrf1 X e z)); intro Hor.
        inversion Hor as [H1 | Hn1].
          apply trc_ind with z.
          apply trc_step; right; left; left; auto.
        generalize (excluded_middle (A1b.ppo E z y)); intro Horp.
        inversion Horp as [H1p | Hn1p].
          apply trc_step; right; left; right; auto.
          apply trc_step; right; right; apply Hfb; unfold ppo_sub; unfold rel_sub; auto.
        assert (rf_sub X e z) as Hrf_sub.
          unfold rf_sub; unfold rel_sub; split; auto.
          apply trc_ind with z; apply trc_step.
        assert (mrfi2 X e z) as Hmrfi.
          rewrite (same_rfe_implies_rf_sub_is_rfi_sub X Hwk Hwf) in Hrf_sub.
          destruct Hrf_sub; auto. apply Hmrf.

          inversion Hrfi_or as [mrfi_eq | mrfi_in_ppo].

          rewrite <- mrfi_eq in Hmrfi; assert False as Ht.
            apply Hn1; left; auto. inversion Ht.

        generalize (mrfi_in_ppo e z Hmrfi); intro Hppo2.
        generalize (excluded_middle (A1b.ppo E e z)); intro Horp.
        inversion Horp as [H1p | Hn1p].
           right; left; right; auto.
            right; right; apply Hfb; split; auto.

        generalize (excluded_middle (A1b.ppo E z y)); intro Horp.
        inversion Horp as [H1p | Hn1p].
            right; left; right; auto.
            right; right; apply Hfb; unfold ppo_sub; unfold rel_sub; auto.

     generalize (tc_dec Hzy); intros [z' [Hzz' Horz'y]].
     inversion Horz'y as [Hz'y | Heq].
      apply trc_ind with z'.

    destruct Hs as [e [Hxe Hez]].
    apply trc_ind with e.
      apply trc_step; left; right; auto.
        generalize (excluded_middle (mrf1 X e z)); intro Hor.
        inversion Hor as [H1 | Hn1].
          apply trc_ind with z.
            apply trc_step; right; left; left; auto.
        generalize (excluded_middle (A1b.ppo E z z')); intro Horp.
        inversion Horp as [H1p | Hn1p].
          apply trc_step; right; left; right; auto.
          apply trc_step; right; right; apply Hfb; unfold ppo_sub; unfold rel_sub; auto.
        assert (rf_sub X e z) as Hrf_sub.
          unfold rf_sub; unfold rel_sub; split; auto.
            rewrite (same_rfe_implies_rf_sub_is_rfi_sub X Hwk Hwf) in Hrf_sub.
          apply trc_ind with z.
          destruct Hrf_sub as [H2 ?].
        generalize (excluded_middle (A1b.ppo E e z)); intro Horp.
        inversion Horp as [H1p | Hn1p].
          apply trc_step; right; left; right; auto.
          apply trc_step; right; right; apply Hfb.
            split; auto.

          inversion Hrfi_or as [mrfi_eq | mrfi_in_ppo].

          rewrite <- mrfi_eq in H2; assert False as Ht.
            apply H; auto. inversion Ht.

        apply (mrfi_in_ppo e z); auto.
        generalize (excluded_middle (A1b.ppo E z z')); intro Horp.
        inversion Horp as [H1p | Hn1p].
          apply trc_step; right; left; right; auto.
          apply trc_step; right; right; apply Hfb; unfold ppo_sub; unfold rel_sub; auto.
      apply Hmrf.

        rewrite <- (ghb1b_eq E X).
        assert (rel_incl (ppo E) (A1bWmm.ghb E X)) as Hincl.
          intros e1 e2 H12; apply ppo2_in_ghb1'; auto.
        apply (tc_incl Hincl Hz'y).

 subst;    destruct Hs as [e [Hxe Hez]].
    apply trc_ind with e.
      apply trc_step; left; right; auto.
        generalize (excluded_middle (mrf1 X e z)); intro Hor.
        inversion Hor as [H1 | Hn1].
          apply trc_ind with z.
            apply trc_step; right; left; left; auto.
        generalize (excluded_middle (A1b.ppo E z y)); intro Horp.
        inversion Horp as [H1p | Hn1p].
          apply trc_step; right; left; right; auto.
          apply trc_step; right; right; apply Hfb; unfold ppo_sub; unfold rel_sub; auto.
        assert (rf_sub X e z) as Hrf_sub.
          unfold rf_sub; unfold rel_sub; split; auto.
            rewrite (same_rfe_implies_rf_sub_is_rfi_sub X Hwk Hwf) in Hrf_sub.
          apply trc_ind with z.
          destruct Hrf_sub as [H2 ?].
        generalize (excluded_middle (A1b.ppo E e z)); intro Horp.
        inversion Horp as [H1p | Hn1p].
          apply trc_step; right; left; right; auto.
          apply trc_step; right; right; apply Hfb.
            split; auto.

          inversion Hrfi_or as [mrfi_eq | mrfi_in_ppo].

          rewrite <- mrfi_eq in H2; assert False as Ht.
            apply H; auto. inversion Ht.

        apply (mrfi_in_ppo e z); auto.
        generalize (excluded_middle (A1b.ppo E z y)); intro Horp.
        inversion Horp as [H1p | Hn1p].
          apply trc_step; right; left; right; auto.
          apply trc_step; right; right; apply Hfb; unfold ppo_sub; unfold rel_sub; auto.
      apply Hmrf.

apply trc_ind with z; auto.
Qed.

Lemma wfb_seq_implies_ghb1 :
  forall E X x y,
  weaker ->
  well_formed_event_structure E ->
  wfb E X -> mrfe1 = mrfe2 ->
  (mrfi1 = mrfi2 \/ rel_incl (mrfi X) (ppo E)) ->
  tc (rel_seq (maybe (A2nWmm.mhb' E X)) (tc (A2n.ppo E))) x y ->
  tc (A1bWmm.ghb E X) x y.
Proof.
intros E X x y Hwk Hwf Hfb Hmrf Hrfi_or Hxy.
induction Hxy.
  destruct H as [e [Hor Hey]].
  inversion Hor.
    apply wfb_seq_implies_ghb1'; auto.
      apply trc_step; exists e; auto.
  subst;
        assert (rel_incl (ppo E) (A1bWmm.ghb E X)) as Hincl.
          intros e1 e2 H12; apply ppo2_in_ghb1'; auto.
        apply (tc_incl Hincl Hey).
apply trc_ind with z; auto.
Qed.

Lemma wfb_ghb2_cycle_implies_ghb1_cycle :
  forall E X x,
  weaker ->
  well_formed_event_structure E ->
  write_serialization_well_formed (events E) (ws X) /\
  rfmaps_well_formed E (events E) (rf X) ->
  wfb E X -> mrfe1 = mrfe2 ->
  (mrfi1 = mrfi2 \/ rel_incl (mrfi X) (ppo E)) ->
  tc (A2nWmm.ghb E X) x x ->
  exists y, tc (A1bWmm.ghb E X) y y.
Proof.
intros E X x Hwk Hwf Hs Hfb Hmrf Hrfi_or Hx.
rewrite (ghb2_is_mhb_ppo2 E X) in Hx.
assert (exists y, tc (rel_seq (maybe (mhb' E X)) (tc (ppo E))) y y) as Hc.
eapply (mhb_union_ppo_cycle_implies_mhb'_seq_ppo_cycle2 X Hwf Hs Hx); auto; apply Hx.
destruct Hc as [y Hc].
exists y; eapply (wfb_seq_implies_ghb1 Hwk Hwf Hfb Hmrf Hrfi_or Hc).
Qed.

Lemma wfb_and_same_rfe_implies_valid :
  forall E X,
  weaker ->
  well_formed_event_structure E ->
  wfb E X -> mrfe1 = mrfe2 ->
  (mrfi1 = mrfi2 \/ rel_incl (mrfi X) (ppo E)) ->
  A1bWmm.valid_execution E X ->
  A2nWmm.valid_execution E X.
Proof.
intros E X Hwk Hwf Hwfb Hmrf Hrfi_or Hv1.
  destruct_valid Hv1; split; auto; split; auto; split; auto.
  split.
    auto.
 unfold acyclic; unfold not; intros x Hx.
  assert (exists x, tc (ghb E X) x x) as Hc.
    exists x; auto.
  assert (write_serialization_well_formed (events E) (ws X) /\
  rfmaps_well_formed E (events E) (rf X)) as Hs.
    split; auto; split; auto.
  generalize (wfb_ghb2_cycle_implies_ghb1_cycle Hwk Hwf Hs Hwfb Hmrf Hrfi_or Hx); intros [y Hcy].
  apply (Hvalid y Hcy).
Qed.

Inductive wAB (E:Event_struct) (X:Execution_witness) (fenced:Rln Event) : Event -> Event -> Prop :=
  | wBase : forall e1 e2,
      fenced e1 e2 -> wAB E X fenced e1 e2.

Lemma wbarriers_placement : (*weaker barriers guarantee*)
  forall E X,
  weaker -> mrfe1 = mrfe2 ->
  (mrfi1 = mrfi2 \/ rel_incl (mrfi X) (ppo E)) ->
  well_formed_event_structure E ->
  A1b.abc E X = wAB E X (ppo_sub E) ->
  A1bWmm.valid_execution E X ->
  A2nWmm.valid_execution E X.
Proof.
intros E X Hwk Hmrf Hrfi_or Hwf Hab; apply wfb_and_same_rfe_implies_valid; auto;
unfold wfb; rewrite Hab.
intros x y Hxy.
  apply wBase; auto.
Qed.

End Barriers.

End Weaker.

End Hierarchy.


Require Import
        Fiat.BinEncoders.Env.Examples.DnsMap.
Require Import
        Fiat.BinEncoders.Env.Common.Specs
        Fiat.BinEncoders.Env.Common.Sig
        Fiat.BinEncoders.Env.Common.Compose
        Fiat.BinEncoders.Env.Automation.Solver.
Require Import
        Fiat.BinEncoders.Env.BinLib.Core
        Fiat.BinEncoders.Env.BinLib.FixInt
        Fiat.BinEncoders.Env.BinLib.Char
        Fiat.BinEncoders.Env.BinLib.Bool
        Fiat.BinEncoders.Env.BinLib.Enum
        Fiat.BinEncoders.Env.Lib.FixList
        Fiat.BinEncoders.Env.Lib.IList
        Fiat.BinEncoders.Env.Lib.SteppingCacheList.

Set Implicit Arguments.

Section DnsExample.
  Context {cache : Cache}.
  Context {cacheAddN : CacheAdd cache N}.
  Context {cacheAddPair : CacheAdd cache (list word_t * position_t)}.
  Context {cachePeek : CachePeek cache position_t}.
  Context {cacheGet : CacheGet cache (list word_t) position_t}.

  Inductive type_t := A | CNAME | NS | MX.
  Inductive class_t := IN | CH | HS.

  Definition halt : word_t.
    refine (Build_word_t (exist _ nil _));
      abstract (rewrite Compare_dec.nat_compare_lt; eauto). Defined.

  Definition halt_dec (a : word_t) : {a = halt} + {a <> halt}.
    unfold halt; destruct a as [[word word_pf]];
      destruct word eqn: eq; subst.
    - left; abstract (f_equal; apply sig_equivalence; eauto).
    - right; abstract (inversion 1).
  Defined. Hint Resolve halt_dec.

  Record name_t :=
    { name : { s : list word_t | length s <= 255 /\ forall x, In x s -> x <> halt } }.

  Record question_t :=
    { qname  : name_t;
      qtype  : type_t;
      qclass : class_t }.

  Record resource_t :=
    { rname  : name_t;
      rtype  : type_t;
      rclass : class_t;
      rttl   : uint 32;
      rdata  : { s : list ascii |  length s < exp2_nat 16 } }.

  Record packet_t :=
    { pid         : { s : list bool | length s = 16 };
      pmask       : { s : list bool | length s = 16 };
      pquestion   : { s : list question_t | length s < exp2_nat 16 };
      panswer     : { s : list resource_t | length s < exp2_nat 16 };
      pauthority  : { s : list resource_t | length s < exp2_nat 16 };
      padditional : { s : list resource_t | length s < exp2_nat 16 } }.

  Open Scope binencoders_scope.

  Definition FixInt_of_branch (b : CacheBranch) : {n | (n < exp2 2)%N}.
    refine (match b with
            | Yes => exist _ 3%N _
            | No  => exist _ 0%N _
            end); abstract (rewrite <- N.compare_lt_iff; eauto).  Defined.

  Definition FixInt_of_type (t : type_t) : {n | (n < exp2 16)%N}.
    refine (match t with
            | A     => exist _ 1%N _
            | CNAME => exist _ 5%N _
            | NS    => exist _ 2%N _
            | MX    => exist _ 15%N _
            end%bencode); abstract (rewrite <- N.compare_lt_iff; eauto).  Defined.

  Definition FixInt_of_class (c : class_t) : {n | (n < exp2 16)%N}.
    refine (match c with
            | IN => exist _ 1%N _
            | CH => exist _ 3%N _
            | HS => exist _ 4%N _
            end); abstract (rewrite <- N.compare_lt_iff; eauto).  Defined.

  (* Commenting out until we patch up with new notations. *)
  (*Definition encode_word (w : word_t) :=
         FixInt_encode (FixList_getlength w.(word))
    ThenC FixList_encode Char_encode w.(word)
    DoneC.

  Definition encode_name (n : name_t) :=
         SteppingList_encode encode_word FixInt_encode (Enum_encode FixInt_of_branch) n.(name)
    DoneC.

  Definition encode_question (q : question_t) :=
         encode_name q.(qname)
    ThenC Enum_encode FixInt_of_type q.(qtype)
    ThenC Enum_encode FixInt_of_class q.(qclass)
    DoneC.

  Definition encode_resource (r : resource_t) :=
         encode_name r.(rname)
    ThenC Enum_encode FixInt_of_type r.(rtype)
    ThenC Enum_encode FixInt_of_class r.(rclass)
    ThenC FixInt_encode r.(rttl)
    ThenC FixInt_encode (FixList_getlength r.(rdata))
    ThenC FixList_encode Char_encode r.(rdata)
    DoneC.

  Definition encode_packet (p : packet_t) :=
         IList_encode Bool_encode p.(pid)
    ThenC IList_encode Bool_encode p.(pmask)
    ThenC FixInt_encode (FixList_getlength p.(pquestion))
    ThenC FixInt_encode (FixList_getlength p.(panswer))
    ThenC FixInt_encode (FixList_getlength p.(pauthority))
    ThenC FixInt_encode (FixList_getlength p.(padditional))
    ThenC FixList_encode encode_question p.(pquestion)
    ThenC FixList_encode encode_resource p.(panswer)
    ThenC FixList_encode encode_resource p.(pauthority)
    ThenC FixList_encode encode_resource p.(padditional)
    DoneC.

  Definition packet_decoder
    : { decode | encode_decode_correct cache btransformer (fun _ => True) encode_packet decode }.
  Proof.
    eexists.
    eapply compose_encode_correct.
    Time solve_decoder.
    Grab Existential Variables.
    eauto. eauto. eauto. eauto.
  Defined.

  Definition packet_decoder'
    : list bool -> CacheDecode -> packet_t * list bool * CacheDecode.
  Proof.
    let p' := eval cbv delta [ proj1_sig packet_decoder ] beta iota in (proj1_sig packet_decoder) in
                                                                        pose p' as p.
    exact p.
  Defined. *)
End DnsExample.

Definition empty :=
  {| eMap := EMap.empty _;
     dMap := DMap.empty _;
     offs := 0 |}.

Lemma empty_Equiv : Equiv empty empty.
Proof.
  unfold Equiv.
  simpl. intuition eauto.
  inversion H. inversion H.  Qed.

(*Definition packet_encode (p : packet_t) : list bool :=
  fst (encode_packet p empty).

Definition packet_decode (b : list bool) : packet_t :=
  fst (fst (packet_decoder' b empty)).

Theorem this_is_correct_and_we_know_it :
  forall p, packet_decode (packet_encode p) = p.
Proof.
  intro p.
  unfold packet_encode, packet_decode.
  pose proof (proj2_sig packet_decoder empty empty
    (snd (encode_packet p empty))
    (snd (packet_decoder' (transform (fst (encode_packet p empty)) transform_id) empty))
    p
    (fst (fst (packet_decoder' (transform (fst (encode_packet p empty)) transform_id) empty)))
    (fst (encode_packet p empty))
    transform_id
    (snd (fst (packet_decoder' (transform (fst (encode_packet p empty)) transform_id) empty)))
    empty_Equiv
    I).
  destruct (@encode_packet cache cacheAddN cacheAddPair cachePeek cacheGet p empty).
  rewrite transform_id_right in H.
  change (proj1_sig packet_decoder) with packet_decoder' in H.
  destruct (@packet_decoder' cache cacheAddN cacheAddPair cachePeek cacheGet
           (fst (l, c)) empty) as [[? ?] ?].
  specialize (H eq_refl eq_refl).
  intuition.
Qed.

Definition packet_uncompressed :=
  true :: true :: false :: true :: true :: false :: true :: true :: false :: true :: false :: false :: false :: false :: true :: false :: false :: false :: false :: false :: false :: false :: false :: true :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: true :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: true :: true :: false :: true :: true :: true :: false :: true :: true :: true :: false :: true :: true :: true :: false :: true :: true :: true :: false :: true :: true :: true :: false :: true :: true :: true :: false :: false :: false :: false :: true :: true :: false :: false :: false :: true :: true :: false :: true :: true :: true :: false :: false :: true :: true :: false :: true :: true :: true :: true :: false :: true :: true :: true :: false :: false :: true :: false :: false :: true :: true :: true :: false :: true :: false :: false :: false :: true :: true :: false :: true :: false :: false :: false :: false :: true :: true :: false :: false :: true :: false :: true :: false :: true :: true :: false :: false :: false :: false :: true :: false :: true :: true :: true :: false :: false :: true :: true :: false :: true :: true :: true :: false :: true :: false :: false :: false :: true :: true :: false :: false :: true :: false :: true :: false :: true :: true :: true :: false :: false :: true :: false :: false :: true :: true :: false :: true :: true :: true :: false :: false :: false :: false :: false :: false :: false :: true :: true :: false :: true :: true :: false :: false :: true :: false :: true :: false :: true :: true :: false :: false :: true :: false :: false :: false :: true :: true :: true :: false :: true :: false :: true :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: true :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: true :: nil.
Definition packet_compressed :=
  true :: true :: false :: true :: true :: false :: true :: true :: false :: true :: false :: false :: false :: false :: true :: false :: true :: false :: false :: false :: false :: false :: false :: true :: true :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: true :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: true :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: true :: true :: false :: true :: true :: true :: false :: true :: true :: true :: false :: true :: true :: true :: false :: true :: true :: true :: false :: true :: true :: true :: false :: true :: true :: true :: false :: false :: false :: false :: true :: true :: false :: false :: false :: true :: true :: false :: true :: true :: true :: false :: false :: true :: true :: false :: true :: true :: true :: true :: false :: true :: true :: true :: false :: false :: true :: false :: false :: true :: true :: true :: false :: true :: false :: false :: false :: true :: true :: false :: true :: false :: false :: false :: false :: true :: true :: false :: false :: true :: false :: true :: false :: true :: true :: false :: false :: false :: false :: true :: false :: true :: true :: true :: false :: false :: true :: true :: false :: true :: true :: true :: false :: true :: false :: false :: false :: true :: true :: false :: false :: true :: false :: true :: false :: true :: true :: true :: false :: false :: true :: false :: false :: true :: true :: false :: true :: true :: true :: false :: false :: false :: false :: false :: false :: false :: true :: true :: false :: true :: true :: false :: false :: true :: false :: true :: false :: true :: true :: false :: false :: true :: false :: false :: false :: true :: true :: true :: false :: true :: false :: true :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: true :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: true :: true :: true :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: true :: true :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: true :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: true :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: true :: false :: false :: true :: false :: true :: true :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: false :: true :: false :: false :: true :: false :: false :: true :: true :: false :: true :: true :: false :: false :: true :: false :: false :: false :: false :: true :: false :: false :: false :: true :: false :: false :: false :: true :: false :: true :: false :: false :: false :: true :: false :: false :: nil.

Goal True.
  pose (packet_decode packet_uncompressed) as goal.
  unfold packet_decode in goal.
  (* Time vm_compute in goal. (* ~ 100 seconds in 8.5 *) *)
Abort.

Goal True.
  pose (packet_decode packet_compressed) as goal.
  unfold packet_decode in goal.
  (* Time simpl in goal. *)
Abort.

Extract Inductive bool => "bool" [ "true" "false" ].
Extract Inductive nat => "int"
                           [ "0" "(fun x -> x + 1)" ]
                           "(fun zero succ n -> if n=0 then zero () else succ (n-1))".
Extract Inductive sumbool => "bool" [ "true" "false" ].
Extract Inductive list => "list" [ "[]" "(::)" ].
Extract Inductive prod => "(*)"  [ "(,)" ].
Extract Inductive ascii => char [
"(fun (b0,b1,b2,b3,b4,b5,b6,b7) -> let f b i = if b then 1 lsl i else 0 in Char.chr (f b0 0 + f b1 1 + f b2 2 + f b3 3 + f b4 4 + f b5 5 + f b6 6 + f b7 7))"
]
"(fun f c -> let n = Char.code c in let h i = (n land (1 lsl i)) <> 0 in f (h 0) (h 1) (h 2) (h 3) (h 4) (h 5) (h 6) (h 7))".  *)

(* Extraction "dns.ml" packet_encode packet_decode packet_uncompressed packet_compressed. *)

(*
#use "dns.ml";;
packet_decode packet_uncompressed;;
packet_decode packet_compressed;;
let p = packet_decode packet_uncompressed;;
let q = {pid = pid p; pmask = pmask p; pquestion = pquestion p; panswer = [{rname = qname (List.hd (pquestion p)); rtype = A; rclass = IN; rttl = Npos XH; rdata = []}]; pauthority = []; padditional = []};;
*)


From stdpp Require Import gmap.

(** Abstraction of the vector clocks. *)

Section Time.

  Class DB_time := {
    Time : Type;
    TM_le : relation Time;
    TM_le_PO :> PartialOrder TM_le;
    TM_lt : relation Time;
    TM_lt_irreflexive : ∀ vc, ¬ TM_lt vc vc;
    TM_lt_trans :> Transitive TM_lt;
    TM_lt_TM_le : ∀ vc vc', TM_lt vc vc' → TM_le vc vc';
    TM_lt_exclusion : ∀ vc vc', TM_lt vc vc' → TM_lt vc' vc → False;
    TM_le_eq_or_lt : ∀ vc vc', TM_le vc vc' → vc = vc' ∨ TM_lt vc vc';
    TM_le_lt_trans :
      ∀ vc vc' vc'', TM_le vc vc' → TM_lt vc' vc'' → TM_lt vc vc'';
    TM_lt_le_trans :
      ∀ vc vc' vc'', TM_lt vc vc' → TM_le vc' vc'' → TM_lt vc vc'';
 }.

  Definition TM_incomparable `{!DB_time} vc vc' :=
    ¬ TM_le vc vc' ∧ ¬ TM_le vc' vc.

  Class Timed {dbt: DB_time} (T : Type) := time : T → Time.

  Notation "s '<ₜ' t" :=
    (TM_lt (time s) (time t)) (at level 70, no associativity).
  Notation "s '≤ₜ' t" :=
    (TM_le (time s) (time t)) (at level 70, no associativity).
  Notation "s '=ₜ' t" :=
    (time s = time t) (at level 70, no associativity).

  Definition IsMaximals {T : Type} `{!DB_time} `{!EqDecision T}
             `{!Countable T} `{!Timed T} (X Y : gset T) :=
    ∀ t : T, t ∈ Y ↔ t ∈ X ∧ ∀ t' : T, t' ∈ X → ¬ (t <ₜ t').

  Definition IsMaximum {T : Type} `{!DB_time} `{!EqDecision T}
             `{!Countable T} `{!Timed T} (X : gset T) (mx : T) :=
    mx ∈ X ∧ ∀ t, t ∈ X → (¬ t = mx) → t <ₜ mx.

  Class Maximals_Computing `{!DB_time} :=
    {
      Maximals : ∀ {T : Type} `{!EqDecision T} `{!Countable T}
           `{!Timed T} (X : gset T), gset T;
      Maximals_correct : ∀ {T : Type} `{!EqDecision T} `{!Countable T}
           `{!Timed T} (X : gset T), IsMaximals X (Maximals X);
      Maximum : ∀ {T : Type} `{!EqDecision T} `{!Countable T}
           `{!Timed T} (X : gset T), option T;
      Maximum_correct : ∀ {T : Type} `{!EqDecision T} `{!Countable T}
           `{!Timed T} (X : gset T),
          (∀ x y, x ∈ X → y ∈ X → x =ₜ y → x = y) →
          (∀ x, Maximum X = Some x ↔ IsMaximum X x);
    }.

  End Time.

Notation "s '<ₜ@{' d '}' t" :=
  (TM_lt (@time d _ _ s) (@time d _ _ t))
    (at level 70, no associativity, format "s  '<ₜ@{' d '}'  t").
Notation "s '≤ₜ@{' d '}' t" :=
  (TM_le (@time d _ _ s) (@time d _ _ t))
    (at level 70, no associativity, format "s  '≤ₜ@{' d '}'  t").
Notation "s '=ₜ@{' d '}' t" :=
  ((@time d _ _ s) = (@time d _ _ t))
    (at level 70, no associativity, format "s  '=ₜ@{' d '}'  t").

Notation "s '<ₜ' t" :=
  (TM_lt (time s) (time t)) (at level 70, no associativity).
Notation "s '≤ₜ' t" :=
  (TM_le (time s) (time t)) (at level 70, no associativity).
Notation "s '=ₜ' t" :=
  (time s = time t) (at level 70, no associativity).


(** This files extends the implementation of finite over [positive] to finite
maps whose keys range over Coq's data type of binary naturals [Z]. *)
From stdpp Require Import pmap mapset.
From stdpp Require Export prelude fin_maps.
From stdpp Require Import options.
Local Open Scope Z_scope.

Record Zmap (A : Type) : Type :=
  ZMap { Zmap_0 : option A; Zmap_pos : Pmap A; Zmap_neg : Pmap A }.
Arguments Zmap_0 {_} _ : assert.
Arguments Zmap_pos {_} _ : assert.
Arguments Zmap_neg {_} _ : assert.
Arguments ZMap {_} _ _ _ : assert.

Instance Zmap_eq_dec `{EqDecision A} : EqDecision (Zmap A).
Proof.
 refine (λ t1 t2,
  match t1, t2 with
  | ZMap x t1 t1', ZMap y t2 t2' =>
     cast_if_and3 (decide (x = y)) (decide (t1 = t2)) (decide (t1' = t2'))
  end); abstract congruence.
Defined.
Instance Zempty {A} : Empty (Zmap A) := ZMap None ∅ ∅.
Instance Zlookup {A} : Lookup Z A (Zmap A) := λ i t,
  match i with
  | Z0 => Zmap_0 t | Zpos p => Zmap_pos t !! p | Zneg p => Zmap_neg t !! p
  end.
Instance Zpartial_alter {A} : PartialAlter Z A (Zmap A) := λ f i t,
  match i, t with
  | Z0, ZMap o t t' => ZMap (f o) t t'
  | Zpos p, ZMap o t t' => ZMap o (partial_alter f p t) t'
  | Zneg p, ZMap o t t' => ZMap o t (partial_alter f p t')
  end.
Instance Zto_list {A} : FinMapToList Z A (Zmap A) := λ t,
  match t with
  | ZMap o t t' => from_option (λ x, [(0,x)]) [] o ++
     (prod_map Zpos id <$> map_to_list t) ++
     (prod_map Zneg id <$> map_to_list t')
  end.
Instance Zomap: OMap Zmap := λ A B f t,
  match t with ZMap o t t' => ZMap (o ≫= f) (omap f t) (omap f t') end.
Instance Zmerge: Merge Zmap := λ A B C f t1 t2,
  match t1, t2 with
  | ZMap o1 t1 t1', ZMap o2 t2 t2' =>
     ZMap (f o1 o2) (merge f t1 t2) (merge f t1' t2')
  end.
Instance Nfmap: FMap Zmap := λ A B f t,
  match t with ZMap o t t' => ZMap (f <$> o) (f <$> t) (f <$> t') end.

Instance: FinMap Z Zmap.
Proof.
  split.
  - intros ? [??] [??] H. f_equal.
    + apply (H 0).
    + apply map_eq. intros i. apply (H (Zpos i)).
    + apply map_eq. intros i. apply (H (Zneg i)).
  - by intros ? [].
  - intros ? f [] [|?|?]; simpl; [done| |]; apply lookup_partial_alter.
  - intros ? f [] [|?|?] [|?|?]; simpl; intuition congruence ||
      intros; apply lookup_partial_alter_ne; congruence.
  - intros ??? [??] []; simpl; [done| |]; apply lookup_fmap.
  - intros ? [o t t']; unfold map_to_list; simpl.
    assert (NoDup ((prod_map Z.pos id <$> map_to_list t) ++
      (prod_map Z.neg id <$> map_to_list t'))).
    { apply NoDup_app; split_and?.
      - apply (NoDup_fmap_2 _), NoDup_map_to_list.
      - intro. rewrite !elem_of_list_fmap. naive_solver.
      - apply (NoDup_fmap_2 _), NoDup_map_to_list. }
    destruct o; simpl; auto. constructor; auto.
    rewrite elem_of_app, !elem_of_list_fmap. naive_solver.
  - intros ? t i x. unfold map_to_list. split.
    + destruct t as [[y|] t t']; simpl.
      * rewrite elem_of_cons, elem_of_app, !elem_of_list_fmap.
        intros [?|[[[??][??]]|[[??][??]]]]; simplify_eq/=; [done| |];
          by apply elem_of_map_to_list.
      * rewrite elem_of_app, !elem_of_list_fmap. intros [[[??][??]]|[[??][??]]];
          simplify_eq/=; by apply elem_of_map_to_list.
    + destruct t as [[y|] t t']; simpl.
      * rewrite elem_of_cons, elem_of_app, !elem_of_list_fmap.
        destruct i as [|i|i]; simpl; [intuition congruence| |].
        { right; left. exists (i, x). by rewrite elem_of_map_to_list. }
        right; right. exists (i, x). by rewrite elem_of_map_to_list.
      * rewrite elem_of_app, !elem_of_list_fmap.
        destruct i as [|i|i]; simpl; [done| |].
        { left; exists (i, x). by rewrite elem_of_map_to_list. }
        right; exists (i, x). by rewrite elem_of_map_to_list.
  - intros ?? f [??] [|?|?]; simpl; [done| |]; apply (lookup_omap f).
  - intros ??? f ? [??] [??] [|?|?]; simpl; [done| |]; apply (lookup_merge f).
Qed.

(** * Finite sets *)
(** We construct sets of [Z]s satisfying extensional equality. *)
Notation Zset := (mapset Zmap).
Instance Zmap_dom {A} : Dom (Zmap A) Zset := mapset_dom.
Instance: FinMapDom Z Zmap Zset := mapset_dom_spec.


From Velus Require Import Common.
From Coq Require Import List.

From Coq Require Import Morphisms.
From Coq Require Import Permutation.

From Velus Require Export ClockDefs.

(** ** Clocks *)

Inductive Is_free_in_clock : ident -> clock -> Prop :=
| FreeCon1:
    forall x ck' xc,
      Is_free_in_clock x (Con ck' x xc)
| FreeCon2:
    forall x y ck' xc,
      Is_free_in_clock x ck'
      -> Is_free_in_clock x (Con ck' y xc).

From Coq Require Import Classes.EquivDec.
Open Scope bool.

Fixpoint clock_eq (ck1 ck2: clock) : bool :=
  match ck1, ck2 with
  | Cbase, Cbase => true
  | Con ck1' x1 b1, Con ck2' x2 b2 =>
    (Pos.eqb x1 x2 && (b1 ==b b2)) && clock_eq ck1' ck2'
  | _, _ => false
  end.

Lemma clock_eq_spec:
  forall ck1 ck2,
    clock_eq ck1 ck2 = true <-> ck1 = ck2.
Proof.
  induction ck1, ck2; split; intro HH; auto;
    try now inversion HH.
  - inversion HH as [Heq].
    apply andb_prop in Heq.
    destruct Heq as (Heq & Hc).
    apply andb_prop in Heq.
    destruct Heq as (Hi & Hb).
    apply Peqb_true_eq in Hi.
    rewrite equiv_decb_equiv in Hb.
    apply IHck1 in Hc.
    subst. rewrite Hb. reflexivity.
  - inversion HH as [Heq].
    subst. simpl.
    rewrite Bool.andb_true_iff.
    split. 2:now apply IHck1.
    rewrite Bool.andb_true_iff.
    split. now apply Pos.eqb_eq.
    now apply equiv_decb_equiv.
Qed.

Instance clock_EqDec : EqDec clock eq.
Proof.
  intros ck1 ck2. compute.
  pose proof (clock_eq_spec ck1 ck2) as Heq.
  destruct (clock_eq ck1 ck2); [left|right].
  now apply Heq.
  intro HH. apply Heq in HH.
  discriminate.
Qed.

Lemma clock_eqb_eq :
  forall (x y: clock), x ==b y = true <-> x = y.
Proof.
  setoid_rewrite equiv_decb_equiv; reflexivity.
Qed.

Lemma clock_eqb_neq :
  forall (x y: clock), x ==b y = false <-> x <> y.
Proof.
  intros *; split; intro H.
  - intro contra. rewrite <- clock_eqb_eq in contra. congruence.
  - destruct (x ==b y) eqn:Hec; auto.
    rewrite clock_eqb_eq in Hec. congruence.
Qed.

Instance nclock_EqDec : EqDec nclock eq.
Proof.
  eapply prod_eqdec.
  - eapply clock_EqDec.
  - unfold EqDec.
    intros x y; destruct x; destruct y; try (right; congruence).
    + specialize (EqDec_instance_0 i i0) as [?|?].
      * left. rewrite e. reflexivity.
      * right. intro contra. inv contra. congruence.
    + left. reflexivity.
Qed.

Lemma nclock_eqb_eq :
  forall (x y: nclock), x ==b y = true <-> x = y.
Proof.
  setoid_rewrite equiv_decb_equiv; reflexivity.
Qed.

Lemma clock_not_in_clock:
  forall ck x b,
    ~(ck = Con ck x b).
Proof.
  intros * Hck.
  induction ck; try discriminate.
  injection Hck; intros.
  apply IHck. now subst b x.
Qed.

(** ** Well-clocking *)

Inductive wc_clock (vars: list (ident * clock)) : clock -> Prop :=
| CCbase:
    wc_clock vars Cbase
| CCon:
    forall ck x b,
      wc_clock vars ck ->
      In (x, ck) vars ->
      wc_clock vars (Con ck x b).

Hint Constructors wc_clock : lclocking.

Definition wc_env vars : Prop :=
  Forall (fun xck => wc_clock vars (snd xck)) vars.

Lemma wc_env_var:
  forall vars x ck,
    wc_env vars
    -> In (x, ck) vars
    -> wc_clock vars ck.
Proof.
  intros vars x ck Hwc Hcv.
  now apply Forall_forall with (2:=Hcv) in Hwc.
Qed.

Lemma wc_clock_add:
  forall x v env ck,
    ~InMembers x env ->
    wc_clock env ck ->
    wc_clock ((x, v) :: env) ck.
Proof.
  induction ck; auto using wc_clock.
  inversion 2.
  auto using wc_clock with datatypes.
Qed.

Lemma wc_env_add:
  forall x env ck,
    ~InMembers x env ->
    wc_clock env ck ->
    wc_env env ->
    wc_env ((x, ck) :: env).
Proof.
  intros * Hnm Hwc Hwce.
  constructor.
  now apply wc_clock_add; auto.
  apply Forall_forall.
  destruct x0 as (x' & ck').
  intro Hin.
  apply Forall_forall with (1:=Hwce) in Hin.
  apply wc_clock_add; auto.
Qed.

Lemma wc_clock_sub:
  forall vars ck x b,
    wc_env vars
    -> wc_clock vars (Con ck x b)
    -> In (x, ck) vars.
Proof.
  intros vars ck x b Hwc Hclock.
  inversion_clear Hclock as [|? ? ? Hclock' Hcv'].
  assumption.
Qed.

Instance wc_clock_Proper:
  Proper (@Permutation (ident * clock) ==> @eq clock ==> iff) wc_clock.
Proof.
  intros env' env Henv ck' ck Hck.
  rewrite Hck; clear Hck ck'.
  induction ck.
  - split; auto using wc_clock.
  - destruct IHck.
    split; inversion_clear 1; constructor;
      try rewrite Henv in *;
      auto using wc_clock.
Qed.

Instance wc_env_Proper:
  Proper (@Permutation (ident * clock) ==> iff) wc_env.
Proof.
  intros env' env Henv.
  unfold wc_env.
  split; intro HH.
  - apply Forall_forall.
    intros x Hin.
    rewrite <-Henv in Hin.
    apply Forall_forall with (1:=HH) in Hin.
    now rewrite Henv in Hin.
  - apply Forall_forall.
    intros x Hin.
    rewrite Henv in Hin.
    apply Forall_forall with (1:=HH) in Hin.
    now rewrite <-Henv in Hin.
Qed.

(** ** Parent relation *)

Inductive clock_parent ck : clock -> Prop :=
| CP0: forall x b,
    clock_parent ck (Con ck x b)
| CP1: forall ck' x b,
    clock_parent ck ck'
    -> clock_parent ck (Con ck' x b).

Lemma clock_parent_parent':
  forall ck' ck i b,
    clock_parent (Con ck i b) ck'
    -> clock_parent ck ck'.
Proof.
  Hint Constructors clock_parent.
  induction ck' as [|? IH]; [now inversion 1|].
  intros ck i' b' Hcp.
  inversion Hcp as [|? ? ? Hcp']; [now auto|].
  apply IH in Hcp'; auto.
Qed.

Lemma clock_parent_parent:
  forall ck' ck i b,
    clock_parent (Con ck i b) ck'
    -> clock_parent ck (Con ck' i b).
Proof.
  Hint Constructors clock_parent.
  destruct ck'; [now inversion 1|].
  intros ck i' b' Hcp.
  inversion Hcp as [|? ? ? Hcp']; [now auto|].
  apply clock_parent_parent' in Hcp'; auto.
Qed.

Lemma clock_parent_trans:
  forall ck1 ck2 ck3,
    clock_parent ck1 ck2 ->
    clock_parent ck2 ck3 ->
    clock_parent ck1 ck3.
Proof.
  induction ck2. now inversion 1.
  intros ck3 H12 H23.
  apply clock_parent_parent' in H23.
  inversion_clear H12; auto.
Qed.

Instance clock_parent_Transitive: Transitive clock_parent.
Proof clock_parent_trans.

Lemma clock_parent_Cbase:
  forall ck i b,
    clock_parent Cbase (Con ck i b).
Proof.
  induction ck as [|? IH]; [now constructor|].
  intros; constructor; apply IH.
Qed.

Lemma clock_parent_not_refl:
  forall ck,
    ~clock_parent ck ck.
Proof.
  induction ck as [|? IH]; [now inversion 1|].
  intro Hp; inversion Hp as [? ? HR|? ? ? Hp'].
  - rewrite HR in Hp; contradiction.
  - apply clock_parent_parent' in Hp'; contradiction.
Qed.

Lemma clock_parent_no_loops:
  forall ck ck',
    clock_parent ck ck'
    -> ck <> ck'.
Proof.
  intros ck ck' Hck Heq.
  rewrite Heq in Hck.
  apply clock_parent_not_refl with (1:=Hck).
Qed.

Lemma clock_no_loops:
  forall ck x b,
    Con ck x b <> ck.
Proof.
  induction ck as [|? IH]; [discriminate 1|].
  injection 1; intros ? Heq.
  apply IH.
Qed.

Lemma clock_parent_Con:
  forall ck ck' i b j c,
    clock_parent (Con ck i b) (Con ck' j c)
    -> clock_parent ck ck'.
Proof.
  destruct ck; induction ck' as [|? IH].
  - inversion 1 as [|? ? ? Hp].
    apply clock_parent_parent' in Hp; inversion Hp.
  - intros; now apply clock_parent_Cbase.
  - inversion 1 as [|? ? ? Hp]; inversion Hp.
  - intros i' b' j  c.
    inversion 1 as [? ? Hck'|? ? ? Hp];
      [rewrite Hck' in IH; now constructor|].
    apply IH in Hp; auto.
Qed.

Lemma clock_parent_strict':
  forall ck' ck,
    ~(clock_parent ck ck' /\ clock_parent ck' ck).
Proof.
  induction ck' as [|? IH]; destruct ck; destruct 1 as [Hp Hp'];
  try now (inversion Hp || inversion Hp').
  apply clock_parent_Con in Hp.
  apply clock_parent_Con in Hp'.
  eapply IH; split; eassumption.
Qed.

Lemma clock_parent_strict:
  forall ck' ck,
    (clock_parent ck ck' -> ~clock_parent ck' ck).
Proof.
  destruct ck'; [now inversion 1|].
  intros ck Hp Hp'.
  eapply clock_parent_strict'; split; eassumption.
Qed.

Lemma Con_not_clock_parent:
  forall ck x b,
    ~clock_parent (Con ck x b) ck.
Proof.
  intros ck x b Hp; apply clock_parent_strict with (1:=Hp); constructor.
Qed.

Lemma Is_free_in_clock_self_or_parent:
  forall x ck,
    Is_free_in_clock x ck
    -> exists ck' b, ck = Con ck' x b \/ clock_parent (Con ck' x b) ck.
Proof.
  Hint Constructors clock_parent.
  induction ck as [|? IH]; [now inversion 1|].
  intro Hfree.
  inversion Hfree as [|? ? ? ? Hfree']; clear Hfree; subst.
  - exists ck, b; now auto.
  - specialize (IH Hfree'); clear Hfree'.
    destruct IH as [ck' [b' Hcp]].
    exists ck', b'; right.
    destruct Hcp as [Hcp|Hcp]; [rewrite Hcp| inversion Hcp]; now auto.
Qed.

Lemma Is_free_in_clock_parent: forall vars x ck ck',
    NoDupMembers vars ->
    In (x, ck') vars ->
    wc_clock vars ck ->
    Is_free_in_clock x ck ->
    clock_parent ck' ck.
Proof.
  induction ck as [|? IH]; intros ck' Hndup Hin Hwc Hfree;
    inv Hfree; inv Hwc.
  - clear IH.
    eapply NoDupMembers_det with (t:=ck) (t':=ck') in Hndup; eauto; subst.
    constructor.
  - constructor; auto.
Qed.

Lemma wc_clock_parent:
  forall C ck' ck,
    wc_env C
    -> clock_parent ck ck'
    -> wc_clock C ck'
    -> wc_clock C ck.
Proof.
  Hint Constructors wc_clock.
  induction ck' as [|ck' IH]; destruct ck as [|ck i' ty'];
  try now (inversion 3 || auto).
  intros Hwc Hp Hck.
  inversion Hp as [j c [HR1 HR2 HR3]|ck'' j c Hp' [HR1 HR2 HR3]].
  - rewrite <-HR1 in *; clear HR1 HR2 HR3.
    now inversion_clear Hck.
  - subst.
    apply IH with (1:=Hwc) (2:=Hp').
    now inversion Hck.
Qed.

Lemma instck_parent:
  forall bk sub ck ck',
    instck bk sub ck = Some ck' ->
    ck' = bk \/ clock_parent bk ck'.
Proof.
  induction ck.
  now inversion_clear 1; auto.
  simpl. intros ck' Hi. right.
  destruct (instck bk sub ck). 2:discriminate.
  destruct (sub i). 2:discriminate.
  specialize (IHck c eq_refl).
  inversion_clear Hi.
  destruct IHck; subst; auto.
Qed.

Lemma instck_subclock_not_clock_eq:
  forall ck isub xck c x b,
    instck ck isub xck = Some c ->
    clock_eq ck (Con c x b) = false.
Proof.
  intros * Hck.
  apply Bool.not_true_is_false.
  intro Heq. apply clock_eq_spec in Heq.
  apply instck_parent in Hck as [Hck|Hck].
  now subst c; apply clock_not_in_clock in Heq.
  now subst ck; apply Con_not_clock_parent in Hck.
Qed.

Lemma clock_parent_dec : forall ck ck',
    clock_parent ck ck' \/ ~clock_parent ck ck'.
Proof.
  intros ck; induction ck'.
  - right. intro contra; inv contra.
  - destruct IHck'.
    + left. constructor; auto.
    + destruct (clock_EqDec ck ck') as [Heq|Hneq].
      * rewrite Heq. left. constructor.
      * right. intro contra. inv contra; try congruence.
Qed.

Lemma exists_child_clock : forall (vars : list (ident * clock)),
    vars = nil \/
    exists id, exists ck,
        In (id, ck) vars /\
        Forall (fun '(_, ck') => ~clock_parent ck ck') vars.
Proof.
  induction vars; auto.
  right. destruct a as [id ck]. destruct IHvars as [?|[id' [ck' [HIn cl]]]]; subst.
  - exists id. exists ck. split; constructor; auto.
    intro contra. apply clock_parent_no_loops in contra; auto.
  - destruct (clock_parent_dec ck' ck).
    + exists id. exists ck. split.
      * left; auto.
      * constructor; auto.
        intro contra.
        eapply clock_parent_strict; eauto.
        eapply Forall_impl; eauto.
        intros [id'' ck''] Hpar; simpl in Hpar.
        intro contra. apply Hpar. etransitivity; eauto.
    + exists id'. exists ck'. split.
      * right; auto.
      * constructor; auto.
Qed.

Corollary exists_child_clock' : forall (vars : list (ident * clock)),
    NoDupMembers vars ->
    wc_env vars ->
    vars = nil \/
    exists id, exists ck,
        In (id, ck) vars /\
        Forall (fun '(_, ck') => ~Is_free_in_clock id ck') vars.
Proof.
  intros vars Hndup Hwc.
  destruct (exists_child_clock vars) as [?|[id [ck [Hin Hclock]]]]; auto.
  right. exists id. exists ck. split; auto.
  eapply Forall_impl_In; eauto.
  intros [id' ck'] Hin' H; simpl in H.
  intro contra. apply H; clear H.
  eapply Is_free_in_clock_parent; eauto.
  unfold wc_env in Hwc. rewrite Forall_forall in Hwc. eapply Hwc in Hin'; eauto.
Qed.

Lemma wc_clock_nparent_remove : forall vars id ck ck',
    ~clock_parent ck' ck ->
    wc_clock ((id, ck')::vars) ck ->
    wc_clock vars ck.
Proof.
  induction ck; intros ck' Hnpar Hwc; constructor; inv Hwc.
  - eapply IHck; eauto.
  - destruct H3; eauto.
    inv H.
    exfalso. apply Hnpar. constructor.
Qed.

Corollary wc_clock_no_loops_remove : forall vars id ck,
    wc_clock ((id, ck)::vars) ck ->
    wc_clock vars ck.
Proof.
  intros vars id ck Hwc.
  apply wc_clock_nparent_remove in Hwc; auto.
  intro contra. apply clock_parent_no_loops in contra. congruence.
Qed.

Lemma instck_inv :
  forall bck sub ck ck' x,
    instck bck sub ck = Some ck' ->
    Is_free_in_clock x ck' ->
    Is_free_in_clock x bck \/
    (exists x', sub x' = Some x /\ Is_free_in_clock x' ck).
Proof.
  induction ck; intros * Hinst Hfree.
  - inv Hinst. auto.
  - inversion Hinst as [Hins]. cases_eqn Hins. inv Hins.
    inversion_clear Hfree as [| ???? Hfr].
    right. exists i. split. auto. constructor.
    apply IHck in Hfr as [|[y []]] ; auto. right.
    exists y. split; auto. now constructor.
Qed.

Lemma instck_free_bck :
  forall bck sub ck ck' x,
    instck bck sub ck = Some ck' ->
    Is_free_in_clock x bck ->
    Is_free_in_clock x ck'.
Proof.
  induction ck; intros * Hinst Hfree.
  - inv Hinst. auto.
  - inversion Hinst as [Hins]. cases_eqn Hins. inv Hins.
    specialize (IHck c x eq_refl Hfree). now constructor.
Qed.

Lemma instck_free_sub :
  forall bck sub ck ck' x x',
    instck bck sub ck = Some ck' ->
    Is_free_in_clock x ck ->
    sub x = Some x' ->
    Is_free_in_clock x' ck'.
Proof.
  induction ck; intros * Hinst Hfree Hsub.
  - inv Hfree.
  - inv Hfree.
    + inversion Hinst as [Hins]. cases_eqn Hins. inv Hsub. inv Hins.
      constructor.
    + inversion Hinst as [Hins]. cases_eqn Hins. inv Hins.
      specialize (IHck c x x' eq_refl H1 Hsub). now constructor.
Qed.


(** * Episode 03: Syntax *)

Require Import List.

(** Backus Naur Form (BNF) Grammars.

A BNF is a concise way of describing a set of objects.
<<
  bit ::= 0 | 1

  binary_string ::= bit | binary_string bit

  parens ::= () | ( parens ) | parens parens

  x ::= x
>>
 *)

Definition name := nat.

Inductive expr : Set :=
| const : nat -> expr
| var : name -> expr
| add : expr -> expr -> expr
| mul : expr -> expr -> expr.

Fixpoint nconsts (e: expr) : nat :=
  match e with
    | const _ => 1
    | var _ => 0
    | add l r => (nconsts l) + (nconsts r)
    | mul l r => (nconsts l) + (nconsts r)
  end.

Lemma has_3_consts:
  exists e, nconsts e = 3.
Proof.
  exists (add (const 1) (add (const 2) (const 3))). simpl. reflexivity.
Qed.

Print orb.

Fixpoint has_const (e: expr) : bool :=
  match e with
    | const _ => true
    | var _ => false
    | add l r => orb (has_const l) (has_const r)
    | mul l r => orb (has_const l) (has_const r)
  end.

Fixpoint has_var (e: expr) : bool :=
  match e with
    | const _ => false
    | var _ => true
    | add l r => orb (has_var l) (has_var r)
    | mul l r => orb (has_var l) (has_var r)
  end.

Lemma bottom_out:
  forall e, has_const e = true \/
            has_var e = true.
Proof.
  intro. induction e.
  { firstorder. }
  { firstorder. }
  { simpl. firstorder. }
  { simpl. firstorder. }
Qed.

Inductive yo: Type :=
| yolo : yo -> yo.

Lemma whack:
  yo -> False.
Proof.
  intro. induction H. destruct IHyo.
Qed.

(* we'll think very carefully about this function soon... *)
Print expr_ind.


Require Import Kami.AllNotations FpuKami.Definitions.

Section Definitions.
  Variable expWidthMinus2 sigWidthMinus2: nat.

  Local Notation expWidthMinus1 := (expWidthMinus2 + 1).
  Local Notation expWidth := (expWidthMinus1 + 1).

  Local Notation sigWidthMinus1 := (sigWidthMinus2 + 1).
  Local Notation sigWidth := (sigWidthMinus1 + 1).

  Local Notation FN := (FN expWidthMinus2 sigWidthMinus2).
  Local Notation RawFloat := (RawFloat expWidthMinus2 sigWidthMinus2).
  Local Notation RecFN := (RecFN expWidthMinus2 sigWidthMinus2).

  Section Ty.
    Variable ty: Kind -> Type.

    Variable fn: FN @# ty.

    Section classify.
      Variable lenMinus10: nat.

      Definition classify_spec: Bit (10 + lenMinus10) @# ty :=
        ZeroExtend _
                   ({<
                     pack (isNaN fn && !isSNaN fn),
                     pack (isSNaN fn),
                     pack (!sign fn && infOrNaN fn && isZeroFractIn fn),
                     pack (!sign fn && !infOrNaN fn && !isZeroExpIn fn),
                     pack (!sign fn && isZeroExpIn fn && !isZeroFractIn fn),
                     pack (!sign fn && isZeroExpIn fn && isZeroFractIn fn),
                     pack (sign fn && isZeroExpIn fn && isZeroFractIn fn),
                     pack (sign fn && isZeroExpIn fn && !isZeroFractIn fn),
                     pack (sign fn && !infOrNaN fn && !isZeroExpIn fn),
                     pack (sign fn && infOrNaN fn && isZeroFractIn fn)
                     >})%kami_expr.

      Section RawFloat.
        Variable rawFloat: RawFloat @# ty.

        Let minNormExp := 2 ^ expWidthMinus1 + 2.

        Open Scope kami_expr.

        Definition isFiniteNonzero := ! (rawFloat @% "isNaN") && ! (rawFloat @% "isInf") && ! (rawFloat @% "isZero").

        Definition isSubnormal := (rawFloat @% "sExp") < {< $$ WO~0, $$ WO~1, $ 2 >}.

        Definition isSigNaNRawFloat_frac :=
          UniBit (TruncMsb sigWidthMinus2 1) (rawFloat @% "sig") == $ 0.

        Definition isSigNaNRawFloat :=
          rawFloat @% "isNaN" && isSigNaNRawFloat_frac.

        Definition classifyRawFloat: Bit (10 + lenMinus10) @# ty :=
          ZeroExtend _ ({<
                         pack ((rawFloat @% "isNaN") && ! isSigNaNRawFloat ),
                         pack isSigNaNRawFloat,
                         pack (! (rawFloat @% "sign") && (rawFloat @% "isInf")),
                         pack (! (rawFloat @% "sign") && isFiniteNonzero && ! isSubnormal),
                         pack (! (rawFloat @% "sign") && isFiniteNonzero &&   isSubnormal),
                         pack (! (rawFloat @% "sign") && (rawFloat @% "isZero")),
                         pack (  (rawFloat @% "sign") && (rawFloat @% "isZero")),
                         pack (  (rawFloat @% "sign") && isFiniteNonzero &&   isSubnormal),
                         pack (  (rawFloat @% "sign") && isFiniteNonzero && ! isSubnormal),
                         pack (  (rawFloat @% "sign") && (rawFloat @% "isInf")) >}).
      End RawFloat.

      Section RecFN.
        Variable recFN: RecFN @# ty.

        Definition classifyRecFN: Bit (10 + lenMinus10) @# ty :=
          classifyRawFloat (getRawFloat_from_RecFN recFN).
      End RecFN.

      Definition classify_impl: Bit (10 + lenMinus10) @# ty :=
        classifyRecFN (getRecFN_from_FN fn).

    End classify.
  End Ty.
End Definitions.


Require Import Crypto.Reflection.SmartMap.
Require Import Crypto.Reflection.Named.Syntax.
Require Import Crypto.Reflection.Named.MapCast.
Require Import Crypto.Reflection.Named.InterpretToPHOAS.
Require Import Crypto.Reflection.Named.Compile.
Require Import Crypto.Reflection.Named.PositiveContext.
Require Import Crypto.Reflection.Named.PositiveContext.Defaults.
Require Import Crypto.Reflection.Syntax.

(** N.B. This procedure only works when there are no nested lets,
    i.e., nothing like [let x := let y := z in w] in the PHOAS syntax
    tree.  This is a limitation of [compile]. *)

Section language.
  Context {base_type_code : Type}
          {op : flat_type base_type_code -> flat_type base_type_code -> Type}
          (base_type_code_beq : base_type_code -> base_type_code -> bool)
          (base_type_code_bl_transparent : forall x y, base_type_code_beq x y = true -> x = y)
          (failb : forall var t, @Syntax.exprf base_type_code op var (Tbase t))
          {interp_base_type_bounds : base_type_code -> Type}
          (interp_op_bounds : forall src dst, op src dst -> interp_flat_type interp_base_type_bounds src -> interp_flat_type interp_base_type_bounds dst)
          (pick_typeb : forall t, interp_base_type_bounds t -> base_type_code).
  Local Notation pick_type v := (SmartFlatTypeMap pick_typeb v).
  Context (cast_op : forall t tR (opc : op t tR) args_bs,
              op (pick_type args_bs) (pick_type (interp_op_bounds t tR opc args_bs))).

  Local Notation PContext var := (PositiveContext _ var _ base_type_code_bl_transparent).

  Section MapCast.
    Context {t} (e : Expr base_type_code op t)
            (input_bounds : interp_flat_type interp_base_type_bounds (domain t)).

    Definition MapCastCompile
      := compile (e _) (DefaultNamesFor e).
    Definition MapCastDoCast (e' : option (Named.expr base_type_code op BinNums.positive t))
      := option_map
           (fun e'' => map_cast
                         interp_op_bounds pick_typeb cast_op
                         (BoundsContext:=PContext _)
                         empty
                         e''
                         input_bounds)
           e'.
    Definition MapCastDoInterp
               (e' : option
                       (option
                          { output_bounds : interp_flat_type interp_base_type_bounds (codomain t) &
                                           Named.expr _ _ _ (Arrow (pick_type input_bounds) (pick_type output_bounds)) }))
      : option { output_bounds : interp_flat_type interp_base_type_bounds (codomain t)
                                 & Expr base_type_code op (Arrow (pick_type input_bounds) (pick_type output_bounds)) }
      := match e' with
         | Some (Some (existT output_bounds e''))
           => Some (existT _ output_bounds (InterpToPHOAS (Context:=fun var => PContext var) failb e''))
         | Some None | None => None
         end.
    Definition MapCast
      : option { output_bounds : interp_flat_type interp_base_type_bounds (codomain t)
                                 & Expr base_type_code op (Arrow (pick_type input_bounds) (pick_type output_bounds)) }
      := MapCastDoInterp (MapCastDoCast MapCastCompile).
  End MapCast.
End language.