(* -*- company-coq-local-symbols: (("|=" . ?⊨) ("=|" . ?⫤) ("->>" . ?↠) ("=~" . ?≈) ("<|" . ?⟨) ("|>" . ?⟩) ); -*- *)
Set Warnings "-notation-overridden".

Require Import Prelude.Prelude.

Require Import Defs.Set.

(*** Notation, tactics etc*)
Ltac listind a := induction a as [|?exA ?a].
Ltac instnil := instantiate (1 := nil).

Theorem list_rev_destr : forall {X : Type} (xs : list X), xs = nil \/ exists (x : X) (xs' : list X), xs = xs' ++ [x].
Proof. intros. destruct xs. crush. forwards: exists_last (x :: xs). crush. destruct H. destruct s. right. exists. rewrite e. reflexivity. Qed.

Definition one {X:Type} (x:X) : list X := x :: nil.

Notation "[ ]" := nil (format "[ ]").
Notation "[ x ]" := (one x).
Notation "[ x ; y ; .. ; z ]" :=  (cons x (cons y .. (cons z nil) ..)) : list_scope.
Notation "[ x ; y ; .. ; z ]" :=  (cons x (cons y .. (cons z nil) ..)) : list_scope.

(*** Stuff from modules *)
Theorem fold_singleton_varl : forall (a : A),
    fold_right (union ∘ singleton) empty a [=] varl a.
Proof. unfold varl. intros a. listind a; crush. Qed.
#[export] Hint Rewrite fold_singleton_varl : core.

(*** Inversion *)
Ltac inv_list :=
  repeat match goal with
    | [ H : _ = [] ++ _ |- _ ] => inverts H
    | [ H : _ = _ :: _ |- _ ] => inverts H
  end.

(*** Simplification *)
(** Associativity *)
Theorem app_assoc' : forall [X:Type] (l m n: list X),
    (l ++ m) ++ n = l ++ m ++ n.
Proof. symmetry. auto using app_assoc. Qed.
#[export] Hint Rewrite app_assoc' : core.
Ltac rep_app_assoc := repeat (rewrite app_assoc).
Tactic Notation "rep_app_assoc" "in" hyp(H) := repeat (rewrite app_assoc in H).
Tactic Notation "rep_app_assoc*" := repeat (rewrite app_assoc in *).

(** app-empty simplifications *)
#[export] Hint Rewrite app_nil_r app_nil_l : core.

(** one *)
Theorem one_rewrite : forall [X:Type] (x : X),
    x :: nil = [x].
Proof. reflexivity. Qed.
#[export] Hint Rewrite one_rewrite : core.

(** cons-app comm *)
Lemma cons_app_comm : forall [X:Type] (l1 a2 : list X) (x : X),
  (x :: l1) ++ a2 = x :: l1 ++ a2.
Proof. reflexivity. Qed.
#[export] Hint Rewrite cons_app_comm : core.

(** empty-to-one rewrites *)
Theorem list_one : forall [X:Type] (x:X),
    x :: [] = [x].
Proof. reflexivity. Qed.
#[export] Hint Rewrite list_one : core.

(** Cons-to-one rewrites (norm) *)
Lemma list_cons_one [X:Type] (l:list X) (x:X) :
    x :: l = one x ++ l.
Proof. reflexivity. Qed.
#[export] Hint Rewrite list_cons_one : norm.

(** Unsorted simplification*)
Theorem list_in_cons : forall (X : Type) (elem x : X) (xs : list X),
    In elem (x :: xs) = (x = elem \/ In elem xs).
Proof. reflexivity. Qed.
#[export] Hint Rewrite list_in_cons : core.

(*** Resoning over app *)
Theorem list_app_eq_share_head : forall (da1 da2 da1' da2' : DA),
    da1 ++ da2 = da1' ++ da2'
  -> (exists da1__rest, da1 = da1' ++ da1__rest) \/ (exists da1'__rest, da1' = da1 ++ da1'__rest).
Proof.
  intros. gen da1' da2 da2'. induction da1.
  - intros. right. exists. crush.
  - intros. destruct da1'.
    + rewr in H. subst. left. exists. crush.
    + rewr in H. inverts H.
      forwards: IHda1. eassumption. destr.
      * left. exists. crush.
      * right. exists. crush.
Qed.

(*** Membership *)
(** In *)
#[export] Hint Rewrite in_app_or : in_disj.
#[export] Hint Resolve in_or_app : core.

(*** Remove *)
Theorem remove_list_set_remove : forall (exA : exvar) (a : A),
    varl (remove eq_exvar exA a) [=] AtomSetImpl.remove exA (varl a).
Proof.
  introv. induction a. crush. simpl. ifdec.
  - subst. rewrite IHa. rewr. fsetdec.
  - simpl. rewrite IHa. rewr. fsetdec.
Qed.
#[export] Hint Rewrite remove_list_set_remove : core.

Theorem list_remove_notin : forall (exA : exvar) (a : A),
    exA \notin varl a
  -> remove eq_exvar exA a = a.
Proof. introv NIA. listind a. crush. simpl. ifdec; crush. Qed.

(*** NonNil *)
Definition NonNil (xs : list skvar) := xs <> [].

(*** List_rels *)

Module Type list_rel.
  Parameter elt : Type.
  Parameter R : list elt -> list elt -> Prop.

  Parameter refl : Reflexive R.
  Parameter trans : Transitive R.

  Parameter proper : Proper (R ==> R ==> R) (app (A := elt)).
End list_rel.

Module Type list_subrel.
  Include list_rel.
  Parameter R_empty : forall (l : list elt), R [] l.
End list_subrel.

Module Type list_eqrel.
  Include list_rel.
  Parameter symm : Symmetric R.
End list_eqrel.

Module Type atomlist_rel.
  Parameter R : list atom -> list atom -> Prop.
End atomlist_rel.
Module Type atomlist_subrel.
  Include atomlist_rel.
  Parameter R_empty : forall (l : list atom), R [] l.
End atomlist_subrel.

(** Trivial list rel *)
Module Trivial_List_rel <: atomlist_subrel.
  Definition R : list atom -> list atom -> Prop := const (const True).

  Definition refl : Reflexive R. unfold Reflexive, R. crush. Qed.
  Definition trans : Transitive R. unfold Transitive, R. crush. Qed.

  Definition proper : Proper (R ==> R ==> R) (app (A := atom)). autounfold. unfold R. crush. Qed.

  Definition R_empty : forall (l : list atom), R [] l. unfold R, const. crush. Qed.
End Trivial_List_rel.

(*** list_rel facts *)
(** list_subrel_facts *)
Module list_subrel_facts  (Import Rel : list_subrel).
  #[export] Hint Resolve refl : core.
  #[export] Hint Resolve R_empty : core.

  #[export] Instance list_subrel_preorder : PreOrder R :=
    { PreOrder_Reflexive  := refl
    ; PreOrder_Transitive := trans
    }.

  #[export] Instance list_subrel_cons_proper : Proper (eq ==> R ==> R) (cons (A:=elt)).
  Proof. autounfold. intros. subst. norm. apply proper. reflexivity. assumption. Qed.

  Corollary list_subrel_app : forall (l1 l1' l2 l2' : list elt),
      R l1 l1'
    -> R l2 l2'
    -> R (l1 ++ l2) (l1' ++ l2').
  Proof. intros. apply proper; auto. Qed.
  #[export] Hint Resolve list_subrel_app: core.

  Theorem list_subrel_app_r : forall (l1 l1' l2 : list elt),
      R l1 l1'
    -> R l1 (l1' ++ l2).
  Proof. intros. rewrite <- (app_nil_r l1). apply proper. assumption. apply R_empty. Qed.
  Theorem list_subrel_app_l : forall (l1 l2 l2': list elt),
      R l2 l2'
    -> R l2 (l1 ++ l2').
  Proof. intros. rewrite <- (app_nil_l l2). apply proper. apply R_empty. assumption. Qed.
  #[export] Hint Resolve list_subrel_app_r list_subrel_app_l : core.

  Corollary list_subrel_app_r' : forall (l1 l2 : list elt),
      R l1 (l1 ++ l2).
  Proof. intros. apply list_subrel_app_r. reflexivity. Qed.
  Corollary list_subrel_app_l' : forall (l1 l2 : list elt),
      R l2 (l1 ++ l2).
  Proof. intros. apply list_subrel_app_l. reflexivity. Qed.
  #[export] Hint Resolve list_subrel_app_r' list_subrel_app_l' : core.

  Theorem list_subrel_cons : forall (l1 l2 : list elt) (x : elt),
      R l1 l2
    -> R l1 (x :: l2).
  Proof. intros. norm. rewrite <- app_nil_l at 1. apply proper. apply R_empty. assumption. Qed.
  #[export] Hint Resolve list_subrel_cons : core.

  Corollary list_subrel_cons' : forall (l : list elt) (x : elt),
      R l (x :: l).
  Proof. intros. apply list_subrel_cons. reflexivity. Qed.
  #[export] Hint Resolve list_subrel_cons' : core.
End list_subrel_facts.

(** list_eqrel_facts *)
Module list_eqrel_facts  (Import Rel : list_eqrel).
  #[export] Hint Resolve refl : core.
  #[export] Hint Resolve symm : core.

  #[export] Instance list_subrel_preorder : Equivalence R :=

    { Equivalence_Reflexive  := refl
    ; Equivalence_Transitive := trans
    ; Equivalence_Symmetric  := symm
    }.

  #[export] Instance list_subrel_cons_proper : Proper (eq ==> R ==> R) (cons (A:=elt)).
  Proof. autounfold. intros. subst. norm. apply proper. reflexivity. assumption. Qed.

  Theorem list_eqrel_app : forall (l1 l1' l2 l2' : list elt),
      R l1 l1'
    -> R l2 l2'
    -> R (l1 ++ l2) (l1' ++ l2').
  Proof. intros. apply proper; assumption. Qed.
  #[export] Hint Resolve list_eqrel_app : core.

  Corollary list_eqrel_app_r : forall (l1 l1' l2 : list elt),
      R l1 l1'
    -> R (l1 ++ l2) (l1' ++ l2).
  Proof. intros. apply list_eqrel_app. assumption. reflexivity. Qed.
  Corollary list_eqrel_app_l : forall (l1 l2 l2' : list elt),
      R l2 l2'
    -> R (l1 ++ l2) (l1 ++ l2').
  Proof. intros. apply list_eqrel_app. reflexivity. assumption. Qed.
  #[export] Hint Resolve list_eqrel_app_r list_eqrel_app_l : core.

  Theorem list_eqrel_cons : forall (x : elt) (l l' : list elt),
      R l l'
    -> R (x :: l) (x :: l').
  Proof. intros. norm. apply proper. reflexivity. assumption. Qed.
  #[export] Hint Resolve list_eqrel_cons : core.

End list_eqrel_facts.

(*** list_(sub/eq) *)
(** list_sub *)
(* Def *)
Definition list_sub (a1 a2 : A) :=
    varl a1 [<=] varl a2.
#[export] Hint Unfold list_sub : core.

Notation "A [<=]l B" := (list_sub A B) (at level 65, format "A  [<=]l  B").

Theorem list_sub_inv : forall (a1 a2 : A),
    a1 [<=]l a2
  -> varl a1 [<=] varl a2.
Proof. auto. Qed.
#[export] Hint Resolve list_sub_inv : core.

(* Instance *)
Lemma list_sub_refl : Reflexive list_sub.
Proof. autounfold. crush. Qed.
#[export] Hint Resolve list_sub_refl : core.
Lemma list_sub_trans : Transitive list_sub.
Proof. autounfold. crush. Qed.

Theorem list_sub_app : forall (a1 a1' a2 a2' : A),
    a1 [<=]l a1'
  -> a2 [<=]l a2'
  -> a2 ++ a1 [<=]l a2' ++ a1'.
Proof. autounfold. intros. rewr. fsetdec. Qed.
#[export] Hint Resolve list_sub_app : core.
#[export] Instance list_sub_app_proper : Proper (list_sub ==> list_sub ==> list_sub) (app (A:=var)).
Proof. crush. Qed.

Module list_sub_subrel <: list_subrel.
  Definition elt : Type := atom.
  Definition R : list atom -> list atom -> Prop := list_sub.

  Definition refl  : Reflexive  R := list_sub_refl.
  Definition trans : Transitive R := list_sub_trans.

  Theorem R_empty : forall (l : list atom), R [] l. unfold R. crush. Qed.

  Definition proper : Proper (R ==> R ==> R) (app (A := atom)) := list_sub_app_proper.
End list_sub_subrel.

Module Export list_sub_subrel_facts := list_subrel_facts list_sub_subrel.
#[export]Hint Extern 1 (list_sub _ _) => fold list_sub_subrel.R : core.

(** list_eq *)
Definition list_eq (a1 a2 : A) :=
    varl a1 [=] varl a2.
#[export] Hint Unfold list_eq : core.

Notation "A [=]l B" := (list_eq A B) (at level 65, format "A  [=]l  B").

Theorem list_eq_sub : forall (a1 a2 : A),
    a1 [=]l a2
  -> a1 [<=]l a2.
Proof. autounfold. crush. Qed.
#[export] Hint Resolve list_eq_sub : core.

(* Instance *)
Lemma list_eq_refl : Reflexive list_eq.
Proof. autounfold. crush. Qed.
Lemma list_eq_trans : Transitive list_eq.
Proof. autounfold. crush. Qed.
Lemma list_eq_symm : Symmetric list_eq.
Proof. autounfold. crush. Qed.
#[export] Hint Resolve list_eq_refl list_eq_symm : core.

Theorem list_eq_app : forall (a1 a1' a2 a2' : A),
    a1 [=]l a1'
  -> a2 [=]l a2'
  -> a2 ++ a1 [=]l a2' ++ a1'.
Proof. autounfold. intros. rewr. fsetdec. Qed.
#[export] Hint Resolve list_eq_app : core.
#[export] Instance list_eq_app_proper : Proper (list_eq ==> list_eq ==> list_eq) (app (A:=var)).
Proof. crush. Qed.

Module list_eq_eqrel <: list_eqrel.
  Definition elt := atom.
  Definition R : list elt -> list elt -> Prop := list_eq.

  Definition refl  : Reflexive  R := list_eq_refl.
  Definition trans : Transitive R := list_eq_trans.
  Definition symm  : Symmetric  R := list_eq_symm.

  Definition proper : Proper (R ==> R ==> R) (app (A := elt)) := list_eq_app_proper.
End list_eq_eqrel.

Module Export list_eq_eqrel_facts := list_eqrel_facts list_eq_eqrel.
#[export]Hint Extern 1 (list_eq _ _) => fold list_eq_eqrel.R : core.

(* (*** list_uni_(sub/eq) *) *)
(* (** list_uni_sub *) *)
(* (* Def *) *)
(* Definition list_uni_sub (a1 a2 : A) := *)
(*     varl a1 [<=] varl a2. *)
(* #[export] Hint Unfold list_sub : core. *)

(* Notation "A [<=]l B" := (list_sub A B) (at level 65, format "A  [<=]l  B"). *)

(* (* Instance *) *)
(* Lemma list_sub_refl : Reflexive list_sub. *)
(* Proof. autounfold. crush. Qed. *)
(* #[export] Hint Resolve list_sub_refl : core. *)
(* Lemma list_sub_trans : Transitive list_sub. *)
(* Proof. autounfold. crush. Qed. *)

(* #[export] Instance list_sub_app_proper : Proper (list_sub ==> list_sub ==> list_sub) (app (A:=var)). *)
(* Proof. autounfold. intros. rewr. fsetdec. Qed. *)

(* Module list_sub_subrel <: list_subrel. *)
(*   Definition elt : Type := atom. *)
(*   Definition R : list atom -> list atom -> Prop := list_sub. *)

(*   Definition refl  : Reflexive  R := list_sub_refl. *)
(*   Definition trans : Transitive R := list_sub_trans. *)

(*   Theorem R_empty : forall (l : list atom), R [] l. unfold R. crush. Qed. *)

(*   Definition proper : Proper (R ==> R ==> R) (app (A := atom)) := list_sub_app_proper. *)
(* End list_sub_subrel. *)

(* Module Export list_sub_subrel_facts := list_subrel_facts list_sub_subrel. *)
(* #[export]Hint Extern 1 (list_sub _ _) => fold list_sub_subrel.R : core. *)

(* (** list_eq *) *)
(* Definition list_eq (a1 a2 : A) := *)
(*     varl a1 [=] varl a2. *)
(* #[export] Hint Unfold list_eq : core. *)

(* Notation "A [=]l B" := (list_eq A B) (at level 65, format "A  [=]l  B"). *)

(* Theorem list_eq_sub : forall (a1 a2 : A), *)
(*     a1 [=]l a2 *)
(*   -> a1 [<=]l a2. *)
(* Proof. autounfold. crush. Qed. *)
(* #[export] Hint Resolve list_eq_sub : core. *)

(* (* Instance *) *)
(* Lemma list_eq_refl : Reflexive list_eq. *)
(* Proof. autounfold. crush. Qed. *)
(* Lemma list_eq_trans : Transitive list_eq. *)
(* Proof. autounfold. crush. Qed. *)
(* Lemma list_eq_symm : Symmetric list_eq. *)
(* Proof. autounfold. crush. Qed. *)
(* #[export] Hint Resolve list_eq_refl list_eq_symm : core. *)

(* #[export] Instance list_eq_app_proper : Proper (list_eq ==> list_eq ==> list_eq) (app (A:=var)). *)
(* Proof. autounfold. intros. rewr. fsetdec. Qed. *)

(* Module list_eq_eqrel <: list_eqrel. *)
(*   Definition elt := atom. *)
(*   Definition R : list elt -> list elt -> Prop := list_eq. *)

(*   Definition refl  : Reflexive  R := list_eq_refl. *)
(*   Definition trans : Transitive R := list_eq_trans. *)
(*   Definition symm  : Symmetric  R := list_eq_symm. *)

(*   Definition proper : Proper (R ==> R ==> R) (app (A := elt)) := list_eq_app_proper. *)
(* End list_eq_eqrel. *)

(* Module Export list_eq_eqrel_facts := list_eqrel_facts list_eq_eqrel. *)
(* #[export]Hint Extern 1 (list_eq _ _) => fold list_eq_eqrel.R : core. *)

(*** list_unique *)
(* (* Inductive NoDup : list A -> Prop := *) *)
(* (*   | NoDup_nil : NoDup nil *) *)
(* (*   | NoDup_cons : forall x l, ~ In x l -> NoDup l -> NoDup (x::l). *) *)
(* #[export] Hint Constructors NoDup : core. *)

(* (** Refactor these to use NoDup lemmas *) *)
(* Theorem list_unique_inv : forall (exA : var) (a : A), *)
(*     list_unique (exA :: a) *)
(*   -> exA \notin varl a *)
(*   /\ list_unique a. *)
(* Proof. inversion 1. crush. Qed. *)
(* Corollary list_unique_inv1 : forall (x : var) (a : A), *)
(*     list_unique (x :: a) *)
(*   -> x \notin varl a. *)
(* Proof. apply list_unique_inv. Qed. *)
(* Corollary list_unique_inv2 : forall (x : var) (a : A), *)
(*     list_unique (x :: a) *)
(*   -> list_unique a. *)
(* Proof. apply list_unique_inv. Qed. *)
(* #[export] Hint Resolve list_unique_inv1 list_unique_inv2 : core. *)

(* Theorem list_unique_list_remove: forall (exA : atom) (a1 a2 : list atom), *)
(*     list_unique (a2 ++ a1) *)
(*   -> list_unique (remove eq_exvar exA a2 ++ a1). *)
(* Proof. *)
(*   introv LU. induction a2. crush. *)
(*   simpl. ifdec. *)
(*   - apply IHa2. eauto. *)
(*   - simpl in *. inverts LU. constructor. rewr*. fsetdec. crush. *)
(* Qed. *)

(* Theorem list_unique_app : forall (a1 a2 : A), *)
(*     list_unique (a1 ++ a2) *)
(*   -> list_unique a1 /\ list_unique a2. *)
(* Proof. *)
(*   introv UNI. listind a1. rewr*. split; simpl; auto. rewr*. *)
(*   forwards: IHa1. eauto. *)
(*   split; jauto. constructor. inverts UNI. rewr*. eauto. *)
(*   crush. *)
(* Qed. *)
(* Corollary list_unique_app1 : forall (a1 a2 : A), *)
(*     list_unique (a1 ++ a2) *)
(*   -> list_unique a1. *)
(* apply list_unique_app. Qed. *)
(* Corollary list_unique_app2 : forall (a1 a2 : A), *)
(*     list_unique (a1 ++ a2) *)
(*   -> list_unique a2. *)
(* apply list_unique_app. Qed. *)
(* #[export] Hint Resolve list_unique_app1 list_unique_app2 : core. *)

(*** NoDup' *)
Inductive NoDup' : A -> Prop :=
  | NoDup'_nil : NoDup' nil
  | NoDup'_cons : forall (exA : exvar) (a : A), exA \notin varl a -> NoDup' a -> NoDup' (exA :: a).
#[export] Hint Constructors NoDup' : core.

Theorem NoDup'_inv : forall (exA : exvar) (a : A),
    NoDup' (exA :: a)
  -> exA \notin varl a
  /\ NoDup' a.
Proof. inversion 1. crush. Qed.
Corollary NoDup'_inv1 : forall (exA : exvar) (a : A),
    NoDup' (exA :: a)
  -> exA \notin varl a.
Proof. apply NoDup'_inv. Qed.
Corollary NoDup'_inv2 : forall (exA : exvar) (a : A),
    NoDup' (exA :: a)
  -> NoDup' a.
Proof. apply NoDup'_inv. Qed.
#[export] Hint Resolve NoDup'_inv1 NoDup'_inv2 : core.

Theorem NoDup'_app : forall (a1 a2 : A),
    NoDup' (a1 ++ a2)
  -> NoDup' a1
  /\ NoDup' a2.
Proof.
  introv UNI. listind a1. rewr*. split; simpl; auto. rewr*.
  forwards: IHa1. eauto.
  split; jauto. constructor. inverts UNI. rewr*. eauto.
  crush.
Qed.
Corollary NoDup'_app1 : forall (a1 a2 : A),
    NoDup' (a1 ++ a2)
  -> NoDup' a1.
Proof. apply NoDup'_app. Qed.
Corollary NoDup'_app2 : forall (a1 a2 : A),
    NoDup' (a1 ++ a2)
  -> NoDup' a2.
Proof. apply NoDup'_app. Qed.
#[export] Hint Resolve NoDup'_app1 NoDup'_app2 : core.

Theorem NoDup'_twice_in : forall (a1 a2 : A) (exA : exvar),
    NoDup' (a2 ++ a1)
  -> exA \in varl a1
  -> exA \in varl a2
  -> False.
Proof.
  introv UNI NI1 NI2. listind a2. crush. rewr*.
  inverts UNI. rewr*. crush. fsetdec.
Qed.

Theorem NoDup'_remove: forall (exA : atom) (a1 a2 : list atom),
    NoDup' (a2 ++ a1)
  -> NoDup' (remove eq_exvar exA a2 ++ a1).
Proof.
  introv LU. induction a2. crush.
  simpl. ifdec.
  - apply IHa2. eauto.
  - simpl in *. inverts LU. constructor. rewr. rewrite remove_subset. rewr*. fsetdec.
    eauto.
Qed.

Lemma list_uni_sub_rem_helper : forall (exA : atom) (a1 a2 : A),
    a1 [<=]l a2
  -> remove eq_exvar exA a1 [<=]l remove eq_exvar exA a2.
Proof. autounfold. introv SL. autounfold. rewr. fsetdec. Qed.

Theorem list_uni_sub_rem : forall (exA : atom) (a1 a2 : A),
    (exA :: a1) [<=]l a2
  -> NoDup' (exA :: a1)
  -> a1 [<=]l remove eq_exvar exA a2.
Proof.
  introv SL UNI. forwards SL': list_uni_sub_rem_helper exA. eassumption.
  simpl in SL'. if_taut. rewrite list_remove_notin in SL'. assumption.
  inverts UNI. assumption.
Qed.

(*** list_uni_(sub/eq) *)
(** list_uni_subque *)
(* Def *)
Definition list_uni_sub (a1 a2 : list var) :=
    a1 [<=]l a2
  /\ (NoDup' a2 -> NoDup' a1).
#[export] Hint Unfold list_uni_sub : core.

Notation "A [<=]lu B" := (list_uni_sub A B) (at level 65, format "A  [<=]lu  B").

(*Conversion to list_sub *)
Theorem list_uni_sub_list_sub : forall (a1 a2 : A),
    a1 [<=]lu a2
  -> a1 [<=]l a2.
Proof. autounfold. crush. Qed.
#[export] Hint Resolve list_uni_sub_list_sub : core.

Theorem list_uni_sub_NoDup' : forall (a1 a2 : A),
    a1 [<=]lu a2
  -> NoDup' a2
  -> NoDup' a1.
Proof. autounfold. crush. Qed.
#[export] Hint Resolve list_uni_sub_NoDup' : core.

(* Instance *)
Lemma list_uni_sub_refl : Reflexive list_uni_sub.
Proof. autounfold. crush. Qed.
Lemma list_uni_sub_trans : Transitive list_uni_sub.
Proof. autounfold. crush. Qed.
#[export] Hint Resolve list_uni_sub_refl : core.

Theorem list_uni_sub_app : forall (a1 a1' a2 a2' : A),
    a1 [<=]lu a1'
  -> a2 [<=]lu a2'
  -> a2 ++ a1 [<=]lu a2' ++ a1'.
Proof.
  autounfold. introv [SL1 LU1] [SL2 LU2]. split. rewr. fsetdec.
  introv LU. gen a2'. listind a2; intros. rewr. eauto.
  rewr. constructor.
  - rewr. unfold not. intros. indestr.
    + forwards NIA: LU2. eauto. inverts NIA. crush.
    + eapply NoDup'_twice_in. apply LU. rewrite <- SL1. eassumption. rewrite <- SL2. rewr. fsetdec.
  - forwards SL': list_uni_sub_rem. apply SL2. eauto.
    apply (IHa2 (remove eq_exvar exA a2')). eauto. intros. eauto.
    eauto using NoDup'_remove.
Qed.
#[export] Hint Resolve list_uni_sub_app : core.

#[export] Instance list_uni_sub_app_proper : Proper (list_uni_sub ==> list_uni_sub ==> list_uni_sub) (app (A:=var)).
Proof. crush. Qed.

Module list_uni_sub_subrel <: list_subrel.
  Definition elt : Type := atom.
  Definition R : list atom -> list atom -> Prop := list_uni_sub.

  Definition refl  : Reflexive  R := list_uni_sub_refl.
  Definition trans : Transitive R := list_uni_sub_trans.

  Theorem R_empty : forall (l : list atom), R [] l. unfold R. crush. Qed.

  Definition proper : Proper (R ==> R ==> R) (app (A := atom)) := list_uni_sub_app_proper.
End list_uni_sub_subrel.

Module Export list_uni_subrel_facts := list_subrel_facts list_sub_subrel.
#[export] Hint Extern 1 (list_uni_sub _ _) => fold list_sub_subrel.R : core.

(** list_uni_eq *)
Definition list_uni_eq (a1 a2 : A) :=
    varl a1 [=] varl a2
  /\ (NoDup' a1 <-> NoDup' a2).
#[export] Hint Unfold list_uni_eq : core.

Notation "A [=]lu B" := (list_uni_eq A B) (at level 65, format "A  [=]lu  B").

Theorem list_uni_eq_sub : forall (a1 a2 : A),
    a1 [=]lu a2
  -> a1 [<=]lu a2.
Proof. autounfold. crush. Qed.
#[export] Hint Resolve list_uni_eq_sub : core.

Theorem list_uni_eq_eq : forall (a1 a2 : A),
    a1 [=]lu a2
  -> a1 [=]l a2.
Proof. intros. unfold list_uni_eq in H. jauto. Qed.
#[export] Hint Resolve list_uni_eq_eq : core.

(* Instance *)
Lemma list_uni_eq_refl : Reflexive list_uni_eq.
Proof. autounfold. crush. Qed.
Lemma list_uni_eq_trans : Transitive list_uni_eq.
Proof. autounfold. crush. Qed.
Lemma list_uni_eq_symm : Symmetric list_uni_eq.
Proof. autounfold. crush. Qed.
#[export] Hint Resolve list_uni_eq_refl list_uni_eq_symm : core.

Theorem list_uni_eq_app : forall (a1 a1' a2 a2' : A),
    a1 [=]lu a1'
  -> a2 [=]lu a2'
  -> a2 ++ a1 [=]lu a2' ++ a1'.
Proof.
  introv SUB1 SUB2. split. apply list_eq_app; auto. split.
  forwards: list_uni_sub_app a1' a1 a2' a2. auto. auto. unfold list_uni_sub in H. crush.
  forwards: list_uni_sub_app a1 a1' a2 a2'. auto. auto. unfold list_uni_sub in H. crush.
Qed.
#[export] Hint Resolve list_uni_eq_app : core.
#[export] Instance list_uni_eq_app_proper : Proper (list_uni_eq ==> list_uni_eq ==> list_uni_eq) (app (A:=var)).
Proof. crush. Qed.

Module list_uni_eq_eqrel <: list_eqrel.
  Definition elt := atom.
  Definition R : list elt -> list elt -> Prop := list_uni_eq.

  Definition refl  : Reflexive  R := list_uni_eq_refl.
  Definition trans : Transitive R := list_uni_eq_trans.
  Definition symm  : Symmetric  R := list_uni_eq_symm.

  Definition proper : Proper (R ==> R ==> R) (app (A := elt)) := list_uni_eq_app_proper.
End list_uni_eq_eqrel.

Module Export list_uni_eq_eqrel_facts := list_eqrel_facts list_uni_eq_eqrel.
#[export]Hint Extern 1 (list_uni_eq _ _) => fold list_uni_eq_eqrel.R : core.

(*** Unsorted *)
Theorem fold_right_varl : forall (a : list atom),
    (fold_right (compose AtomSetImpl.union AtomSetImpl.singleton) AtomSetImpl.empty a) [=] varl a.
Proof. intros. induction a. crush. rewr. fsetdec. Qed.


Require Import FP.Classes.Monad.
Require Import FP.Data.Unit.
Require Import FP.Data.List.
Require Import FP.Data.Product.
Require Import FP.Data.Option.
Require Import FP.Core.

Definition env N L := list (N × L).

Class MonadEnvState N L m `{! Monad m } :=
  { getEnv : dom (m (env N L))
  ; putEnv : dom (env N L ⇒ m unit)
  }.

Section MonadEnvState.
  Context {N L m} `{! Monad m ,! MonadEnvState N L m }.

  Definition modifyEnv : dom ((env N L ⇒ env N L) ⇒ m unit) := λ f →
    e ← getEnv ;;
    putEnv $ f ∙ e.

  Definition lookupEnv `{! DecEqv (dom N) ,! MonadPlus m } : dom (N ⇒ m L) := λ n →
    (liftOption ⊙ llookup ∙ n) =<< getEnv.
End MonadEnvState.


Require Export Iron.Language.SystemF2Effect.Store.Bind.

(******************************************************************************)
(* Types of store bindings. *)
Inductive TypeB : kienv -> tyenv -> stenv -> stprops -> stbind -> ty -> Prop :=
 (* A store binding that contains a live value.
    Requiring that the region handle is well kinded ensures that it's
    mentioned in the store properties. *)
 | TbValue
   :  forall ke te se sp p v t
   ,  In (SRegion p) sp
   -> TypeV  ke te se sp v t
   -> TypeB  ke te se sp (StValue p v) (TRef (TRgn p) t)

 (* After a store binding has been dealloated,
    we can treat the location has having any type we want.
    The progress theorem guarantees these dead bindings will never be read,
    so there is no opportunity to treat it has having the wrong type. *)
 | TbDead
   :  forall ke te se sp p t
   ,  In (SRegion p) sp
   -> TypeB  ke te se sp (StDead p)    (TRef (TRgn p) t).

Hint Constructors TypeB.

(******************************************************************************)
(* Weakening store environment in type of store binding *)
Lemma typeB_stenv_snoc
 :  forall ke te se sp v t1 t2
 ,  TypeB  ke te se sp v t1
 -> ClosedT t2
 -> TypeB  ke te (t2 <: se) sp v t1.
Proof.
 intros.
 inverts H; eauto.
Qed.
Hint Resolve typeB_stenv_snoc.

(* Weakening store properties  in type of store binding *)
Lemma typeB_stprops_snoc
 :  forall ke te se sp v t p
 ,  TypeB  ke te se sp v t
 -> TypeB  ke te se (p <: sp) v t.
Proof.
 intros.
 inverts H; eauto using kind_stprops_snoc.
Qed.
Hint Resolve typeB_stprops_snoc.

Lemma typeB_stprops_cons
 :  forall ke te se sp v t p
 ,  TypeB  ke te se sp v t
 -> TypeB  ke te se (sp :> p) v t.
Proof.
 intros.
 inverts H; eauto using kind_stprops_cons.
Qed.
Hint Resolve typeB_stprops_snoc.

Lemma typeB_mergeT
 :  forall ke te se sp b t p1 p2
 ,  In (SRegion p1) sp
 -> TypeB  ke te se sp b t
 -> TypeB  ke (mergeTE p1 p2 te) (mergeTE p1 p2 se) sp
              (mergeB p1 p2 b) (mergeT p1 p2 t).
Proof.
 intros.
 destruct b.

 Case "StValue".
 { have (p2 = n \/ ~(p2 = n)) as HN.
   inverts HN.
   - inverts H0.
     + snorm; subst.
       * eapply TbValue; eauto.
         eapply TxVal in H9.
         eapply mergeX_typeX in H9.
         inverts H9. eauto.
         inverts_kind. auto.
       * nope.
   - inverts H0.
     + snorm; subst.
       * nope.
       * eapply TbValue; eauto.
         eapply TxVal in H10.
         eapply mergeX_typeX in H10.
         inverts H10. eauto. auto.
 }

 Case "StDead".
 { have (p2 = n \/ ~(p2 = n)) as HN.
   inverts HN.
   - inverts H0.
     snorm.
   - inverts H0.
     snorm.
 }
Qed.


Set Warnings "-notation-overridden".

Require Import Category.Theory.
Require Import Category.Structure.Monoidal.
Require Import Category.Lib.

Require Import Enriched.Category.
Require Import Enriched.Functor.
Require Import Enriched.Natural.Transformation.
Require Import Enriched.TwoCategory.
Require Import Enriched.Instance.VCat.
Require Import Enriched.Instance.TwoCat.
Require Import Enriched.Forget.Lib.
Require Import Enriched.Fun.

Generalizable All Variables.
Set Primitive Projections.
Set Universe Polymorphism.
Unset Transparent Obligations.

Section ForgetfulFunctor.

Program Definition Forget_0cell {V0: Category} {V : Monoidal} (C : EnrichedCategory) : Category := {|
  obj := eobj;
  hom := ehom0;
  homset := fun x y => homset I (ehom x y);
  id := fun _ => eid;
  Category.compose := fun _ _ _ => ecompose0
|}.
Next Obligation.
  apply ecompose0_respects.
Qed.
Next Obligation.
  apply ecomp0_id_left.
Qed.
Next Obligation.
  apply ecomp0_id_right.
Qed.
Next Obligation.
  symmetry.
  apply ecomp0_assoc.
Qed.
Next Obligation.
  apply ecomp0_assoc.
Qed.

Program Definition Forget_1cell {V0: Category} {V : Monoidal} {C D : EnrichedCategory} (F : C ⟶ D) : ((Forget_0cell C) ⟶ (Forget_0cell D))%functor_type := {|
  fobj := fun X => F X;
  fmap := fun _ _ f => efmap0 _ _ f;
|}.
Next Obligation.
  proper.
  unfold efmap0.
  rewrite X.
  reflexivity.
Qed.
Next Obligation.
  apply efmap_id0.
Qed.
Next Obligation.
  apply efmap_comp0.
Qed.

Program Definition Forget_2cell {V0: Category} {V : Monoidal} {C D : EnrichedCategory} {F G : C ⟶ D} (f : F ⟹ G) : (Forget_1cell F ⟹ Forget_1cell G)%transform_type := {|
  transform := f;
|}.
Next Obligation.
  rewrite ecompose0_precompose.
  rewrite ecompose0_postcompose.
  unfold efmap0.
  normal.
  rewrite enaturality.
  reflexivity.
Qed.
Next Obligation.
  symmetry.
  apply Forget_2cell_obligation_1.
Qed.

Program Definition Forget_efmap {V0: Category} {V : Monoidal} {C D : EnrichedCategory} : (Fun C D ⟶ @Fun.Fun (Forget_0cell C) (Forget_0cell D))%functor_type := {|
  fobj := Forget_1cell;
  fmap := fun _ _ => Forget_2cell;
|}.
Next Obligation.
  symmetry.
  apply efmap_id0.
Qed.

Program Definition Forget {V0: Category} {V : Monoidal} : TwoFunctor VCat TwoCat := {|
  efobj := Forget_0cell;
  efmap := fun _ _ => Forget_efmap;
|}.
Next Obligation.
  unfold Forget_1cell.
  unfold efmap0.
  simpl.
  unshelve eexists (fun _ => _).
  {
    isomorphism.
    + transform.
      - intro.
        simpl.
        apply eid.
      - simpl.
        rewrite ecomp0_id_left.
        rewrite ecomp0_id_right.
        normal.
        reflexivity.
      - rewrite ecomp0_id_left.
        rewrite ecomp0_id_right.
        normal.
        reflexivity.
    + transform.
      - intro.
        simpl.
        apply eid.
      - simpl.
        rewrite ecomp0_id_left.
        rewrite ecomp0_id_right.
        normal.
        reflexivity.
      - rewrite ecomp0_id_left.
        rewrite ecomp0_id_right.
        normal.
        reflexivity.
    + simpl.
      apply ecomp0_id_left.
    + simpl.
      normal.
      apply ecomp0_id_left.
  }
  intros.
  simpl.
  do 2 rewrite ecomp0_id_right.
  reflexivity.
Qed.
Next Obligation.
  unshelve eexists (fun _ => _).
  {
  isomorphism.
  + destruct y0 as [F G].
    simpl.
    transform.
    - intro.
      simpl.
      apply eid.
    - simpl.
      rewrite ecomp0_id_right.
      rewrite ecomp0_id_left.
      unfold efmap0.
      simpl.
      normal.
      reflexivity.
    - simpl.
      rewrite ecomp0_id_right.
      rewrite ecomp0_id_left.
      unfold efmap0.
      simpl.
      normal.
      reflexivity.
  + destruct y0 as [F G].
    simpl.
    transform.
    - intro.
      simpl.
      apply eid.
    - simpl.
      rewrite ecomp0_id_right.
      rewrite ecomp0_id_left.
      unfold efmap0.
      simpl.
      normal.
      reflexivity.
    - simpl.
      rewrite ecomp0_id_right.
      rewrite ecomp0_id_left.
      unfold efmap0.
      simpl.
      normal.
      reflexivity.
  + destruct y0 as [F G].
    simpl.
    rewrite ecomp0_id_right.
    unfold efmap0.
    symmetry.
    rewrite efmap_id.
    reflexivity.
  + destruct y0 as [F G].
    simpl.
    rewrite ecomp0_id_right.
    unfold efmap0.
    do 2 rewrite efmap_id.
    reflexivity.
  }
  intros [F0 F1] [G0 G1].
  simpl.
  intros [f g] A.
  simpl.
  rewrite ecomp0_id_right.
  rewrite ecomp0_id_left.
  unfold efmap0.
  rewrite ecompose0_precompose.
  rewrite ecompose0_postcompose.
  normal.
  rewrite enaturality.
  reflexivity.
Qed.

End ForgetfulFunctor.


Require Export concurrency.paco.src.paconotation concurrency.paco.src.pacotac concurrency.paco.src.pacodef concurrency.paco.src.pacotacuser.
Set Implicit Arguments.

(** ** Predicates of Arity 0
*)

(** 1 Mutual Coinduction *)

Section Arg0_1.

Definition monotone0 (gf: rel0 -> rel0) :=
  forall r r' (IN: gf r) (LE: r <0= r'), gf r'.

Variable gf : rel0 -> rel0.
Implicit Arguments gf [].

Theorem paco0_acc: forall
  l r (OBG: forall rr (INC: r <0= rr) (CIH: l <_paco_0= rr), l <_paco_0= paco0 gf rr),
  l <0= paco0 gf r.
Proof.
  intros; assert (SIM: paco0 gf (r \0/ l)) by eauto.
  clear PR; repeat (try left; do 1 paco_revert; paco_cofix_auto).
Qed.

Theorem paco0_mon: monotone0 (paco0 gf).
Proof. paco_cofix_auto; repeat (left; do 1 paco_revert; paco_cofix_auto). Qed.

Theorem paco0_mult_strong: forall r,
  paco0 gf (upaco0 gf r) <0= paco0 gf r.
Proof. paco_cofix_auto; repeat (left; do 1 paco_revert; paco_cofix_auto). Qed.

Corollary paco0_mult: forall r,
  paco0 gf (paco0 gf r) <0= paco0 gf r.
Proof. intros; eapply paco0_mult_strong, paco0_mon; eauto. Qed.

Theorem paco0_fold: forall r,
  gf (upaco0 gf r) <0= paco0 gf r.
Proof. intros; econstructor; [ |eauto]; eauto. Qed.

Theorem paco0_unfold: forall (MON: monotone0 gf) r,
  paco0 gf r <0= gf (upaco0 gf r).
Proof. unfold monotone0; intros; destruct PR; eauto. Qed.

End Arg0_1.

Hint Unfold monotone0.
Hint Resolve paco0_fold.

Implicit Arguments paco0_acc            [ ].
Implicit Arguments paco0_mon            [ ].
Implicit Arguments paco0_mult_strong    [ ].
Implicit Arguments paco0_mult           [ ].
Implicit Arguments paco0_fold           [ ].
Implicit Arguments paco0_unfold         [ ].

Instance paco0_inst  (gf : rel0->_) r : paco_class (paco0 gf r) :=
{ pacoacc    := paco0_acc gf;
  pacomult   := paco0_mult gf;
  pacofold   := paco0_fold gf;
  pacounfold := paco0_unfold gf }.

(** 2 Mutual Coinduction *)

Section Arg0_2.

Definition monotone0_2 (gf: rel0 -> rel0 -> rel0) :=
  forall r_0 r_1 r'_0 r'_1 (IN: gf r_0 r_1) (LE_0: r_0 <0= r'_0)(LE_1: r_1 <0= r'_1), gf r'_0 r'_1.

Variable gf_0 gf_1 : rel0 -> rel0 -> rel0.
Implicit Arguments gf_0 [].
Implicit Arguments gf_1 [].

Theorem paco0_2_0_acc: forall
  l r_0 r_1 (OBG: forall rr (INC: r_0 <0= rr) (CIH: l <_paco_0= rr), l <_paco_0= paco0_2_0 gf_0 gf_1 rr r_1),
  l <0= paco0_2_0 gf_0 gf_1 r_0 r_1.
Proof.
  intros; assert (SIM: paco0_2_0 gf_0 gf_1 (r_0 \0/ l) r_1) by eauto.
  clear PR; repeat (try left; do 1 paco_revert; paco_cofix_auto).
Qed.

Theorem paco0_2_1_acc: forall
  l r_0 r_1 (OBG: forall rr (INC: r_1 <0= rr) (CIH: l <_paco_0= rr), l <_paco_0= paco0_2_1 gf_0 gf_1 r_0 rr),
  l <0= paco0_2_1 gf_0 gf_1 r_0 r_1.
Proof.
  intros; assert (SIM: paco0_2_1 gf_0 gf_1 r_0 (r_1 \0/ l)) by eauto.
  clear PR; repeat (try left; do 1 paco_revert; paco_cofix_auto).
Qed.

Theorem paco0_2_0_mon: monotone0_2 (paco0_2_0 gf_0 gf_1).
Proof. paco_cofix_auto; repeat (left; do 1 paco_revert; paco_cofix_auto). Qed.

Theorem paco0_2_1_mon: monotone0_2 (paco0_2_1 gf_0 gf_1).
Proof. paco_cofix_auto; repeat (left; do 1 paco_revert; paco_cofix_auto). Qed.

Theorem paco0_2_0_mult_strong: forall r_0 r_1,
  paco0_2_0 gf_0 gf_1 (upaco0_2_0 gf_0 gf_1 r_0 r_1) (upaco0_2_1 gf_0 gf_1 r_0 r_1) <0= paco0_2_0 gf_0 gf_1 r_0 r_1.
Proof. paco_cofix_auto; repeat (left; do 1 paco_revert; paco_cofix_auto). Qed.

Theorem paco0_2_1_mult_strong: forall r_0 r_1,
  paco0_2_1 gf_0 gf_1 (upaco0_2_0 gf_0 gf_1 r_0 r_1) (upaco0_2_1 gf_0 gf_1 r_0 r_1) <0= paco0_2_1 gf_0 gf_1 r_0 r_1.
Proof. paco_cofix_auto; repeat (left; do 1 paco_revert; paco_cofix_auto). Qed.

Corollary paco0_2_0_mult: forall r_0 r_1,
  paco0_2_0 gf_0 gf_1 (paco0_2_0 gf_0 gf_1 r_0 r_1) (paco0_2_1 gf_0 gf_1 r_0 r_1) <0= paco0_2_0 gf_0 gf_1 r_0 r_1.
Proof. intros; eapply paco0_2_0_mult_strong, paco0_2_0_mon; eauto. Qed.

Corollary paco0_2_1_mult: forall r_0 r_1,
  paco0_2_1 gf_0 gf_1 (paco0_2_0 gf_0 gf_1 r_0 r_1) (paco0_2_1 gf_0 gf_1 r_0 r_1) <0= paco0_2_1 gf_0 gf_1 r_0 r_1.
Proof. intros; eapply paco0_2_1_mult_strong, paco0_2_1_mon; eauto. Qed.

Theorem paco0_2_0_fold: forall r_0 r_1,
  gf_0 (upaco0_2_0 gf_0 gf_1 r_0 r_1) (upaco0_2_1 gf_0 gf_1 r_0 r_1) <0= paco0_2_0 gf_0 gf_1 r_0 r_1.
Proof. intros; econstructor; [ | |eauto]; eauto. Qed.

Theorem paco0_2_1_fold: forall r_0 r_1,
  gf_1 (upaco0_2_0 gf_0 gf_1 r_0 r_1) (upaco0_2_1 gf_0 gf_1 r_0 r_1) <0= paco0_2_1 gf_0 gf_1 r_0 r_1.
Proof. intros; econstructor; [ | |eauto]; eauto. Qed.

Theorem paco0_2_0_unfold: forall (MON: monotone0_2 gf_0) (MON: monotone0_2 gf_1) r_0 r_1,
  paco0_2_0 gf_0 gf_1 r_0 r_1 <0= gf_0 (upaco0_2_0 gf_0 gf_1 r_0 r_1) (upaco0_2_1 gf_0 gf_1 r_0 r_1).
Proof. unfold monotone0_2; intros; destruct PR; eauto. Qed.

Theorem paco0_2_1_unfold: forall (MON: monotone0_2 gf_0) (MON: monotone0_2 gf_1) r_0 r_1,
  paco0_2_1 gf_0 gf_1 r_0 r_1 <0= gf_1 (upaco0_2_0 gf_0 gf_1 r_0 r_1) (upaco0_2_1 gf_0 gf_1 r_0 r_1).
Proof. unfold monotone0_2; intros; destruct PR; eauto. Qed.

End Arg0_2.

Hint Unfold monotone0_2.
Hint Resolve paco0_2_0_fold.
Hint Resolve paco0_2_1_fold.

Implicit Arguments paco0_2_0_acc            [ ].
Implicit Arguments paco0_2_1_acc            [ ].
Implicit Arguments paco0_2_0_mon            [ ].
Implicit Arguments paco0_2_1_mon            [ ].
Implicit Arguments paco0_2_0_mult_strong    [ ].
Implicit Arguments paco0_2_1_mult_strong    [ ].
Implicit Arguments paco0_2_0_mult           [ ].
Implicit Arguments paco0_2_1_mult           [ ].
Implicit Arguments paco0_2_0_fold           [ ].
Implicit Arguments paco0_2_1_fold           [ ].
Implicit Arguments paco0_2_0_unfold         [ ].
Implicit Arguments paco0_2_1_unfold         [ ].

Instance paco0_2_0_inst  (gf_0 gf_1 : rel0->_) r_0 r_1 : paco_class (paco0_2_0 gf_0 gf_1 r_0 r_1) :=
{ pacoacc    := paco0_2_0_acc gf_0 gf_1;
  pacomult   := paco0_2_0_mult gf_0 gf_1;
  pacofold   := paco0_2_0_fold gf_0 gf_1;
  pacounfold := paco0_2_0_unfold gf_0 gf_1 }.

Instance paco0_2_1_inst  (gf_0 gf_1 : rel0->_) r_0 r_1 : paco_class (paco0_2_1 gf_0 gf_1 r_0 r_1) :=
{ pacoacc    := paco0_2_1_acc gf_0 gf_1;
  pacomult   := paco0_2_1_mult gf_0 gf_1;
  pacofold   := paco0_2_1_fold gf_0 gf_1;
  pacounfold := paco0_2_1_unfold gf_0 gf_1 }.

(** 3 Mutual Coinduction *)

Section Arg0_3.

Definition monotone0_3 (gf: rel0 -> rel0 -> rel0 -> rel0) :=
  forall r_0 r_1 r_2 r'_0 r'_1 r'_2 (IN: gf r_0 r_1 r_2) (LE_0: r_0 <0= r'_0)(LE_1: r_1 <0= r'_1)(LE_2: r_2 <0= r'_2), gf r'_0 r'_1 r'_2.

Variable gf_0 gf_1 gf_2 : rel0 -> rel0 -> rel0 -> rel0.
Implicit Arguments gf_0 [].
Implicit Arguments gf_1 [].
Implicit Arguments gf_2 [].

Theorem paco0_3_0_acc: forall
  l r_0 r_1 r_2 (OBG: forall rr (INC: r_0 <0= rr) (CIH: l <_paco_0= rr), l <_paco_0= paco0_3_0 gf_0 gf_1 gf_2 rr r_1 r_2),
  l <0= paco0_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2.
Proof.
  intros; assert (SIM: paco0_3_0 gf_0 gf_1 gf_2 (r_0 \0/ l) r_1 r_2) by eauto.
  clear PR; repeat (try left; do 1 paco_revert; paco_cofix_auto).
Qed.

Theorem paco0_3_1_acc: forall
  l r_0 r_1 r_2 (OBG: forall rr (INC: r_1 <0= rr) (CIH: l <_paco_0= rr), l <_paco_0= paco0_3_1 gf_0 gf_1 gf_2 r_0 rr r_2),
  l <0= paco0_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2.
Proof.
  intros; assert (SIM: paco0_3_1 gf_0 gf_1 gf_2 r_0 (r_1 \0/ l) r_2) by eauto.
  clear PR; repeat (try left; do 1 paco_revert; paco_cofix_auto).
Qed.

Theorem paco0_3_2_acc: forall
  l r_0 r_1 r_2 (OBG: forall rr (INC: r_2 <0= rr) (CIH: l <_paco_0= rr), l <_paco_0= paco0_3_2 gf_0 gf_1 gf_2 r_0 r_1 rr),
  l <0= paco0_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2.
Proof.
  intros; assert (SIM: paco0_3_2 gf_0 gf_1 gf_2 r_0 r_1 (r_2 \0/ l)) by eauto.
  clear PR; repeat (try left; do 1 paco_revert; paco_cofix_auto).
Qed.

Theorem paco0_3_0_mon: monotone0_3 (paco0_3_0 gf_0 gf_1 gf_2).
Proof. paco_cofix_auto; repeat (left; do 1 paco_revert; paco_cofix_auto). Qed.

Theorem paco0_3_1_mon: monotone0_3 (paco0_3_1 gf_0 gf_1 gf_2).
Proof. paco_cofix_auto; repeat (left; do 1 paco_revert; paco_cofix_auto). Qed.

Theorem paco0_3_2_mon: monotone0_3 (paco0_3_2 gf_0 gf_1 gf_2).
Proof. paco_cofix_auto; repeat (left; do 1 paco_revert; paco_cofix_auto). Qed.

Theorem paco0_3_0_mult_strong: forall r_0 r_1 r_2,
  paco0_3_0 gf_0 gf_1 gf_2 (upaco0_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2) (upaco0_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2) (upaco0_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2) <0= paco0_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2.
Proof. paco_cofix_auto; repeat (left; do 1 paco_revert; paco_cofix_auto). Qed.

Theorem paco0_3_1_mult_strong: forall r_0 r_1 r_2,
  paco0_3_1 gf_0 gf_1 gf_2 (upaco0_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2) (upaco0_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2) (upaco0_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2) <0= paco0_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2.
Proof. paco_cofix_auto; repeat (left; do 1 paco_revert; paco_cofix_auto). Qed.

Theorem paco0_3_2_mult_strong: forall r_0 r_1 r_2,
  paco0_3_2 gf_0 gf_1 gf_2 (upaco0_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2) (upaco0_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2) (upaco0_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2) <0= paco0_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2.
Proof. paco_cofix_auto; repeat (left; do 1 paco_revert; paco_cofix_auto). Qed.

Corollary paco0_3_0_mult: forall r_0 r_1 r_2,
  paco0_3_0 gf_0 gf_1 gf_2 (paco0_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2) (paco0_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2) (paco0_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2) <0= paco0_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2.
Proof. intros; eapply paco0_3_0_mult_strong, paco0_3_0_mon; eauto. Qed.

Corollary paco0_3_1_mult: forall r_0 r_1 r_2,
  paco0_3_1 gf_0 gf_1 gf_2 (paco0_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2) (paco0_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2) (paco0_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2) <0= paco0_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2.
Proof. intros; eapply paco0_3_1_mult_strong, paco0_3_1_mon; eauto. Qed.

Corollary paco0_3_2_mult: forall r_0 r_1 r_2,
  paco0_3_2 gf_0 gf_1 gf_2 (paco0_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2) (paco0_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2) (paco0_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2) <0= paco0_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2.
Proof. intros; eapply paco0_3_2_mult_strong, paco0_3_2_mon; eauto. Qed.

Theorem paco0_3_0_fold: forall r_0 r_1 r_2,
  gf_0 (upaco0_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2) (upaco0_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2) (upaco0_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2) <0= paco0_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2.
Proof. intros; econstructor; [ | | |eauto]; eauto. Qed.

Theorem paco0_3_1_fold: forall r_0 r_1 r_2,
  gf_1 (upaco0_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2) (upaco0_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2) (upaco0_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2) <0= paco0_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2.
Proof. intros; econstructor; [ | | |eauto]; eauto. Qed.

Theorem paco0_3_2_fold: forall r_0 r_1 r_2,
  gf_2 (upaco0_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2) (upaco0_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2) (upaco0_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2) <0= paco0_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2.
Proof. intros; econstructor; [ | | |eauto]; eauto. Qed.

Theorem paco0_3_0_unfold: forall (MON: monotone0_3 gf_0) (MON: monotone0_3 gf_1) (MON: monotone0_3 gf_2) r_0 r_1 r_2,
  paco0_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2 <0= gf_0 (upaco0_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2) (upaco0_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2) (upaco0_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2).
Proof. unfold monotone0_3; intros; destruct PR; eauto. Qed.

Theorem paco0_3_1_unfold: forall (MON: monotone0_3 gf_0) (MON: monotone0_3 gf_1) (MON: monotone0_3 gf_2) r_0 r_1 r_2,
  paco0_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2 <0= gf_1 (upaco0_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2) (upaco0_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2) (upaco0_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2).
Proof. unfold monotone0_3; intros; destruct PR; eauto. Qed.

Theorem paco0_3_2_unfold: forall (MON: monotone0_3 gf_0) (MON: monotone0_3 gf_1) (MON: monotone0_3 gf_2) r_0 r_1 r_2,
  paco0_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2 <0= gf_2 (upaco0_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2) (upaco0_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2) (upaco0_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2).
Proof. unfold monotone0_3; intros; destruct PR; eauto. Qed.

End Arg0_3.

Hint Unfold monotone0_3.
Hint Resolve paco0_3_0_fold.
Hint Resolve paco0_3_1_fold.
Hint Resolve paco0_3_2_fold.

Implicit Arguments paco0_3_0_acc            [ ].
Implicit Arguments paco0_3_1_acc            [ ].
Implicit Arguments paco0_3_2_acc            [ ].
Implicit Arguments paco0_3_0_mon            [ ].
Implicit Arguments paco0_3_1_mon            [ ].
Implicit Arguments paco0_3_2_mon            [ ].
Implicit Arguments paco0_3_0_mult_strong    [ ].
Implicit Arguments paco0_3_1_mult_strong    [ ].
Implicit Arguments paco0_3_2_mult_strong    [ ].
Implicit Arguments paco0_3_0_mult           [ ].
Implicit Arguments paco0_3_1_mult           [ ].
Implicit Arguments paco0_3_2_mult           [ ].
Implicit Arguments paco0_3_0_fold           [ ].
Implicit Arguments paco0_3_1_fold           [ ].
Implicit Arguments paco0_3_2_fold           [ ].
Implicit Arguments paco0_3_0_unfold         [ ].
Implicit Arguments paco0_3_1_unfold         [ ].
Implicit Arguments paco0_3_2_unfold         [ ].

Instance paco0_3_0_inst  (gf_0 gf_1 gf_2 : rel0->_) r_0 r_1 r_2 : paco_class (paco0_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2) :=
{ pacoacc    := paco0_3_0_acc gf_0 gf_1 gf_2;
  pacomult   := paco0_3_0_mult gf_0 gf_1 gf_2;
  pacofold   := paco0_3_0_fold gf_0 gf_1 gf_2;
  pacounfold := paco0_3_0_unfold gf_0 gf_1 gf_2 }.

Instance paco0_3_1_inst  (gf_0 gf_1 gf_2 : rel0->_) r_0 r_1 r_2 : paco_class (paco0_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2) :=
{ pacoacc    := paco0_3_1_acc gf_0 gf_1 gf_2;
  pacomult   := paco0_3_1_mult gf_0 gf_1 gf_2;
  pacofold   := paco0_3_1_fold gf_0 gf_1 gf_2;
  pacounfold := paco0_3_1_unfold gf_0 gf_1 gf_2 }.

Instance paco0_3_2_inst  (gf_0 gf_1 gf_2 : rel0->_) r_0 r_1 r_2 : paco_class (paco0_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2) :=
{ pacoacc    := paco0_3_2_acc gf_0 gf_1 gf_2;
  pacomult   := paco0_3_2_mult gf_0 gf_1 gf_2;
  pacofold   := paco0_3_2_fold gf_0 gf_1 gf_2;
  pacounfold := paco0_3_2_unfold gf_0 gf_1 gf_2 }.


From iris.proofmode Require Import tactics.
From iris.program_logic Require Import adequacy.
From iris_examples.logrel.F_mu Require Export fundamental.

Theorem soundness Σ `{invPreG Σ} e τ e' thp σ σ' :
  (∀ `{irisG F_mu_lang Σ}, [] ⊨ e : τ) →
  rtc erased_step ([e], σ) (thp, σ') → e' ∈ thp → not_stuck e' σ'.
Proof.
  intros Hlog ??.
  cut (adequate NotStuck e σ (λ _ _, True));
    first by intros [_ Hsafe]; eapply Hsafe; eauto.
  eapply (wp_adequacy Σ); eauto.
  iIntros (Hinv ?). iModIntro. iExists (λ _ _, True%I), (λ _, True%I). iSplit=> //.
  replace e with e.[env_subst[]] by by asimpl.
  set (HΣ := IrisG _ _ Hinv (λ _ _ _, True)%I (λ _, True)%I).
  iApply (wp_wand with "[]"). iApply Hlog; eauto. by iApply interp_env_nil. auto.
Qed.

Corollary type_soundness e τ e' thp σ σ' :
  [] ⊢ₜ e : τ →
  rtc erased_step ([e], σ) (thp, σ') → e' ∈ thp → not_stuck e' σ'.
Proof.
  intros ??. set (Σ := invΣ).
  eapply (soundness Σ); eauto using fundamental.
Qed.


Require Export Bedrock.Word.

Require Import
        Fiat.Narcissus.Examples.NetworkStack.EthernetHeader
        Fiat.Narcissus.Examples.NetworkStack.ARPPacket
        Fiat.Narcissus.Examples.NetworkStack.IPv4Header
        Fiat.Narcissus.Examples.NetworkStack.TCP_Packet
        Fiat.Narcissus.Examples.NetworkStack.UDP_Packet.

Require Coq.Vectors.Vector.
Export Coq.Vectors.Vector.VectorNotations.

(* Require Export *)
(*         Fiat.Common.SumType *)
(*         Fiat.Common.EnumType *)
(*         Fiat.Common.BoundedLookup *)
(*         Fiat.Common.ilist *)
(*         Fiat.Computation *)
(*         Fiat.QueryStructure.Specification.Representation.Notations *)
(*         Fiat.QueryStructure.Specification.Representation.Heading *)
(*         Fiat.QueryStructure.Specification.Representation.Tuple *)
(*         Fiat.Narcissus.BinLib.Core *)
(*         Fiat.Narcissus.BinLib.AlignedByteString *)
(*         Fiat.Narcissus.Common.Specs *)
(*         Fiat.Narcissus.Common.WordFacts *)
(*         Fiat.Narcissus.Common.ComposeCheckSum *)
(*         Fiat.Narcissus.Common.ComposeIf *)
(*         Fiat.Narcissus.Common.ComposeOpt *)
(*         Fiat.Narcissus.Formats.FixListOpt *)
(*         Fiat.Narcissus.Stores.EmptyStore *)
(*         Fiat.Narcissus.Formats.WordOpt *)
(*         Fiat.Narcissus.Formats.Bool *)
(*         Fiat.Narcissus.Formats.NatOpt *)
(*         Fiat.Narcissus.Formats.Vector *)
(*         Fiat.Narcissus.Formats.EnumOpt *)
(*         Fiat.Narcissus.Formats.SumTypeOpt *)
(*         Fiat.Narcissus.Formats.IPChecksum. *)

Definition InjectEnum {n A}
           (gallina_constructors: Vector.t A n)
           (enum_member: Fin.t n) : A :=
  Vector.nth gallina_constructors enum_member.

Require Import AlignedByteString.

Definition WrapDecoder {A B} sz
           (impl: forall {sz}, ByteBuffer.t sz -> option (A * nat * B))
           (bs: ByteBuffer.t sz) : option A :=
  match impl bs with
  | Some (pkt, _, _) => Some pkt
  | None => None
  end.

Definition WrapEncoder {A B} sz
           (impl: forall {sz}, ByteBuffer.t sz -> A -> option (ByteBuffer.t sz * nat * B))
           (pkt: A) (out: ByteBuffer.t sz) : option (ByteBuffer.t sz) :=
  match impl out pkt with
  | Some (out, _, _) => Some out
  | None => None
  end.

Definition IsSome {A} (x: option A) :=
  match x with Some _ => True | None => False end.

Definition must {A} (x: option A) (pr: IsSome x) : A :=
  match x as xx return (IsSome xx -> A) with
  | Some a => fun _ => a
  | None => fun pr => False_rect _ pr
  end pr.

Definition MakeBuffer sz := AlignedByteString.initialize_Aligned_ByteString sz.
Definition FreshBuffer {sz} (len: nat) (v: ByteBuffer.t sz) := AlignedByteString.initialize_Aligned_ByteString len.

Definition fiat_ethernet_encode {sz} :=
  WrapEncoder sz (fun sz v pkt => @EthernetHeader_encoder_impl pkt sz v).
Definition fiat_ethernet_decode {sz} v packet_length :=
  WrapDecoder sz (@Ethernet_decoder_impl packet_length) v.

Definition fiat_arp_decode {sz} :=
  WrapDecoder sz (@ARP_decoder_impl).
Definition fiat_arp_encode {sz} :=
  WrapEncoder sz (@ARP_encoder_impl).

Definition fiat_ipv4_decode {sz} :=
  WrapDecoder sz (@IPv4_decoder_impl).
Definition fiat_ipv4_encode {sz} :=
  WrapEncoder sz (@IPv4_encoder_impl).

Definition fiat_tcp_encode {sz} v srcAddress dstAddress tcpLength :=
  WrapEncoder sz (fun sz v pkt => @TCP_encoder_impl srcAddress dstAddress tcpLength pkt sz v) v.
Definition fiat_tcp_decode {sz} v (srcAddress dstAddress: ByteBuffer.t 4) tcpLength :=
  WrapDecoder sz (@TCP_decoder_impl srcAddress dstAddress tcpLength) v.

Definition fiat_udp_encode {sz} v srcAddress dstAddress udpLength :=
  WrapEncoder sz (fun sz v pkt => @UDP_encoder_impl srcAddress dstAddress udpLength pkt sz v) v.
Definition fiat_udp_decode {sz} v (srcAddress dstAddress: ByteBuffer.t 4) (udpLength: word 16) :=
  WrapDecoder sz (@UDP_decoder_impl srcAddress dstAddress udpLength) v.


(*
 * Copyright (c) 2020-23 BedRock Systems, Inc.
 * This software is distributed under the terms of the BedRock Open-Source License.
 * See the LICENSE-BedRock file in the repository root for details.
 *)
(**
   Semantics of arithmetic operators on primitives.
   This does not include the semantics of pointer operations because they
   require side conditions on the abstract machine state.
 *)

From bedrock.prelude Require Import base numbers.
From bedrock.lang.cpp.arith Require Export operator.
From bedrock.lang.cpp Require Import ast semantics.values semantics.promotion semantics.cast.

#[local] Open Scope Z_scope.

(** ** Binary Operator Static Semantics

    The static (type-level) promotion semantics of binary operators
  *)
Notation Tptrdiff_t := Tlonglong (only parsing).

Definition convert_type_op {σ : genv} (tu : translation_unit) (b : BinOp) (ty1 ty2 : type)
  : option (type * type * type) :=
  if is_pointer ty1 && is_pointer ty2 then
    (* pointer-pointer operations *)
    match b with
    | Bsub => Some (ty1, ty2, Tptrdiff_t)
    | _ => None
    end
  else if is_pointer ty1 && is_arithmetic ty2 then
    (* pointer-integer operations *)
    match b with
    | Bsub | Badd =>
      match promote_integral tu ty2 with
      | Some ty2 => Some (ty1, ty2, ty1)
      | _ => None
      end
    | _ => None
    end
  else if is_arithmetic ty1 && is_pointer ty2 then
    (* integer-pointer operations *)
    match b with
    | Bsub | Badd =>
      match promote_integral tu ty1 with
      | Some ty1 => Some (ty1, ty2, ty2)
      | _ => None
      end
    | _ => None
    end
  else if is_arithmetic ty1 && is_arithmetic ty2 then
    (* integer-integer operations *)
    match promote_integral tu ty1 , promote_integral tu ty2 with
    | Some ity1 , Some ity2 =>
      match b with
      | Bshl | Bshr =>
        (* heterogeneous operators *)
        Some (ity1, ity2, ity1)
      | Badd | Bsub | Bmul | Bdiv | Bmod
      | Band | Bor | Bxor =>
        (* homogeneous operators *)
        match promote_arith ity1 ity2 with
        | Some to => Some (to, to, to)
        | _ => None
        end
      | Beq | Bneq
      | Blt | Ble | Bgt | Bge =>
        let same_enum :=
          match drop_qualifiers ty1 , drop_qualifiers ty2 with
          | Tenum nm1 , Tenum nm2 => if bool_decide (nm1 = nm2) then true else false
          | _ , _ => false
          end
        in
        if same_enum then
          (* Technically, this is only permitted for unscoped enumerations;
             however, the dynamic semantics lines up with the comparison on
             scoped enumerations so we do not test.
           *)
          Some (drop_qualifiers ty1, drop_qualifiers ty2, Tbool)
        else
          (* homogeneous operators *)
          match promote_arith ity1 ity2 with
          | Some to => Some (to, to, to)
          | _ => None
          end
      | Bcmp => None
      | Bdotp
      | Bdotip
      | Bunsupported _ => None
      end
    | _ , _ => None
    end
  else None.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj22synthconj5 : forall  (lv0 : natural) (lv1 : natural), (@eq natural (plus lv0 lv1) (plus lv0 lv1)).
Admitted.
QuickChick conj22synthconj5.


(************************************************************
* Language of commands                                      *
* Pretty-big-step semantics                                 *
*************************************************************)

Set Implicit Arguments.
Require Export Command_Syntax.

Implicit Types h : heap.
Implicit Types s : stack.
Implicit Types n : int.
Implicit Types v : word.
Implicit Types e : exp.
Implicit Types a : act.
Implicit Types c : cmd.
Implicit Types p : prog.

Definition novar := O.

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

(************************************************************)
(* ** Trace semantics *)

(** Grammar of observable effects *)

Inductive obs :=
  | obs_none : obs
  | obs_load : word -> word -> obs
  | obs_store : word -> word -> obs
  | obs_cas : word -> word -> word -> word -> obs
  | obs_fence : obs.

Implicit Types k : obs.

(** Grammar of traces *)

Definition fintrace := list obs.
Definition inftrace := stream obs.
Definition trace := colist obs.
Definition traces := list trace.

Implicit Types f : fintrace.
Implicit Types i : inftrace.
Implicit Types t : trace.

(** Grammar of outcomes *)

Inductive out :=
  | out_ter : stack -> fintrace -> out
  | out_div : inftrace -> out.

Implicit Types o : out.

(** Prefixing of an outcome with a trace *)

Definition out_prepend f o :=
  match o with
  | out_ter s f' => out_ter s (f ++ f')
  | out_div i => out_div (stream_prepend f i)
  end.

(** Outcomes that abort *)

Inductive abort : out -> Prop :=
  | abort_div : forall i, abort (out_div i).

(** Grammar of extended commands *)

Inductive ext :=
  | ext_cmd : cmd -> ext
  | ext_seq_1 : out -> cmd -> ext.

Implicit Types d : ext.
Coercion ext_cmd : cmd >-> ext.

(** Evaluation of effectful actions *)

Inductive exec : stack -> act -> word -> obs -> Prop :=
  | exec_comp : forall e v s a,
      eval s e = v ->
      exec s (act_comp e) v obs_none
  | exec_load : forall v1 v2 s e,
      eval s e = v1 ->
      exec s (act_load e) v2 (obs_load v1 v2)
  | exec_store : forall v1 v2 s e1 e2,
      eval s e1 = v1 ->
      eval s e2 = v2 ->
      exec s (act_store e1 e2) v2 (obs_store v1 v2)
  | exec_cas : forall v1 v2 v3 v4 s e1 e2 e3,
      eval s e1 = v1 ->
      eval s e2 = v2 ->
      eval s e3 = v3 ->
      exec s (act_cas e1 e2 e3) v4 (obs_cas v1 v2 v3 v4)
  | exec_fence : forall s,
      exec s (act_fence) 0 obs_fence.

(** Prefixing the trace with a [obs_none] *)

Definition step o :=
  out_prepend (obs_none::nil) o.

(** Evaluation of commands *)

Inductive red : stack -> ext -> out -> Prop :=
  | red_bind : forall v k s' s x a,
      exec s a v k ->
      s' = (If x = novar then s else Heap.write s x v) ->
      red s (cmd_bind x a) (out_ter s' (k::nil))
  | red_seq : forall o1 s c1 c2 o,
      red s c1 o1 ->
      red s (ext_seq_1 o1 c2) o ->
      red s (cmd_seq c1 c2) (step o)
  | red_seq_1_abort : forall s o c2,
      abort o ->
      red s (ext_seq_1 o c2) (step o)
  | red_seq_1 : forall s s' f o c2,
      red s c2 o ->
      red s' (ext_seq_1 (out_ter s f) c2) (step (out_prepend f o))
  | red_if : forall c3 s e o c1 c2,
      c3 = (If (eval s e = 0) then c1 else c2) ->
      red s c3 o ->
      red s (cmd_if e c1 c2) (step o)
  | red_while_exit : forall s e c1,
      eval s e = 0 ->
      red s (cmd_while e c1) (out_ter s (obs_none::nil))
  | red_while_step : forall s e c1 o,
      red s (cmd_seq c1 (cmd_while e c1)) o ->
      red s (cmd_while e c1) (step o).

(** Same as above, except co-inductive *)

CoInductive cored : stack -> ext -> out -> Prop :=
  | cored_bind : forall v k s' s x a,
      exec s a v k ->
      s' = (If x = novar then s else Heap.write s x v) ->
      cored s (cmd_bind x a) (out_ter s' (k::nil))
  | cored_seq : forall o1 s c1 c2 o,
      cored s c1 o1 ->
      cored s (ext_seq_1 o1 c2) o ->
      cored s (cmd_seq c1 c2) (step o)
  | cored_seq_1_abort : forall s o c2,
      abort o ->
      cored s (ext_seq_1 o c2) (step o)
  | cored_seq_1 : forall s s' f o c2,
      cored s c2 o ->
      cored s' (ext_seq_1 (out_ter s f) c2) (step (out_prepend f o))
  | cored_if : forall c3 s e o c1 c2,
      c3 = (If (eval s e = 0) then c1 else c2) ->
      cored s c3 o ->
      cored s (cmd_if e c1 c2) (step o)
  | cored_while_exit : forall s e c1,
      eval s e = 0 ->
      cored s (cmd_while e c1) (out_ter s (obs_none::nil))
  | cored_while_step : forall s e c1 o,
      cored s (cmd_seq c1 (cmd_while e c1)) o ->
      cored s (cmd_while e c1) (step o).

(** Same as above, except in Type *)

CoInductive tcored : stack -> ext -> out -> Type :=
  | tcored_bind : forall v k s' s x a,
      exec s a v k ->
      s' = (If x = novar then s else Heap.write s x v) ->
      tcored s (cmd_bind x a) (out_ter s' (k::nil))
  | tcored_seq : forall o1 s c1 c2 o,
      tcored s c1 o1 ->
      tcored s (ext_seq_1 o1 c2) o ->
      tcored s (cmd_seq c1 c2) (step o)
  | tcored_seq_1_abort : forall s o c2,
      abort o ->
      tcored s (ext_seq_1 o c2) (step o)
  | tcored_seq_1 : forall s s' f o c2,
      tcored s c2 o ->
      tcored s' (ext_seq_1 (out_ter s f) c2) (step (out_prepend f o))
  | tcored_if : forall c3 s e o c1 c2,
      c3 = (If (eval s e = 0) then c1 else c2) ->
      tcored s c3 o ->
      tcored s (cmd_if e c1 c2) (step o)
  | tcored_while_exit : forall s e c1,
      eval s e = 0 ->
      tcored s (cmd_while e c1) (out_ter s (obs_none::nil))
  | tcored_while_step : forall s e c1 o,
      tcored s (cmd_seq c1 (cmd_while e c1)) o ->
      tcored s (cmd_while e c1) (step o).

(** should be generated by coq *)

Inductive branches (A : Type) (P : A -> Prop) : Type :=
  | branches_witness : sig P -> branches P
  | branches_none : (forall x, ~ P x) -> branches P.

Lemma branches_intro : forall A (P:A->Prop), branches P.
Proof.
  intros. destruct (classicT (ex P)) as [C|C].
  applys branches_witness. applys~ indefinite_description.
  applys branches_none. rewrite <- not_exists. intros [x M].
   applys C. applys ex_intro M.
Qed.

Lemma cored_tcored : forall s d o,
  cored s d o -> tcored s d o.
Proof.
  cofix IH. introv H. destruct d as [ [x a|c1 c2|e c1 c2|e c1] |o1 c2].
  destruct (branches_intro (fun z => let '(s',v,k) := z in
    exec s a v k /\ s' = (If x = novar then s else Heap.write s x v)
    /\  o = out_ter s' (k::nil)))
  as [[[[s' v'] k] (?&?&?)]|N].
   subst. constructors*.
   false. invert H. intros. applys N (s',v,k). subst. splits*.
  destruct (branches_intro (fun z => let '(o1,o') := z in
    cored s c1 o1 /\ cored s (ext_seq_1 o1 c2) o' /\ o = step o'))
  as [[[o1 o'] (?&?&?)]|N].
   subst. constructors*.
   false. inverts H. applys* N (o1,o0).
  destruct (branches_intro (fun z => let '(c3,o') := z in
      c3 = (If (eval s e = 0) then c1 else c2) /\
      cored s c3 o' /\ o = step o'))
  as [[[c4 o'] (?&?&?)]|N].
   subst. constructors*.
   false. invert H. intros. applys* N (c3,o0).
  destruct (branches_intro (fun z:unit =>
      eval s e = 0 /\ o = (out_ter s (obs_none::nil))))
  as [[[] (?&?)]|N].
   subst. constructors*.
    destruct (branches_intro (fun o' =>
      cored s (cmd_seq c1 (cmd_while e c1)) o' /\ o = step o'))
    as [[o' (?&?)]|N2].
      subst. constructors*.
   false. inverts H; intros. applys* N tt. applys* N2 o0.
  destruct (branches_intro (fun o' =>
      o1 = o' /\ abort o' /\ o = step o'))
  as [[o' (?&?&?)]|N].
   subst. constructors*.
    destruct (branches_intro (fun z => let '(s0,f,o') := z in
      cored s0 c2 o' /\
      o1 = out_ter s0 f /\
      o = step (out_prepend f o')))
    as [[[[s0 f] o'] (?&?&?)]|N2].
      subst. constructors*.
   false. inverts H; intros. applys* N. applys* N2 (s0,f,o0).
Qed.

Hint Constructors cored.

Theorem red_cored : forall s d o,
  red s d o -> cored s d o.
Proof. introv H. induction* H. Qed.

CoFixpoint dummy := obs_none ::: dummy.

Definition stream_step_eq A (s1 s2 : stream A) :=
  match s1,s2 with
  | stream_intro x1 s1', stream_intro x2 s2' => x1 = x2 /\ s1' = s2'
  end.

Lemma stream_step_eq_inj : forall A (s1 s2 : stream A),
  stream_step_eq s1 s2 -> s1 = s2.
Proof.
  introv H. destruct s1; destruct s2; simpls; inverts~ H.
Qed.

Lemma dummy_unfold : dummy = obs_none ::: dummy.
Proof.
  applys stream_step_eq_inj. simpl. auto.
Qed.

Definition get_out_trace o :=
  match o with
  | out_ter _ _ => dummy
  | out_div i => i
  end.

Ltac testi H :=
  match type of H with tcored ?s ?d ?o => tests: (red s d o) end.

Hint Constructors  red abort.

Lemma get_out_trace_step : forall o,
  out_div (get_out_trace (step o)) = step (out_div (get_out_trace o)).
Proof.
  intros. destruct~ o. simpl. rewrite dummy_unfold at 1. auto.
Qed.

(*
Lemma get_out_trace_self : forall o,
  out_div (get_out_trace o) = o.
Proof.
  intros. destruct~ o. simpl. rewrite dummy_unfold at 1. auto.
Qed.
*)

Definition cored_not_red_trace : forall s d o,
  tcored s d o -> ~ red s d o -> inftrace.
Proof.
  cofix IH. introv R N. inverts R as.
  introv E. false* N.
  introv R1 R2. testi R1.
     forwards i2: IH R2. eauto. exact (obs_none:::i2).
     forwards i2: IH R1. eauto. exact (obs_none:::i2).
  skip.
  skip.
  skip.
  skip.
  skip.
Defined.

Lemma cored_not_red_not_ter' : forall s d o
  (R:tcored s d o) (N: ~ red s d o),
  cored s d (out_div (cored_not_red_trace R N)).
Proof.
  cofix IH. intros. destruct R.
  skip.
  skip.

  skip.
  skip.
  skip.
  skip.
  skip.
Qed.

Lemma cored_not_red_not_ter : forall s d o,
  cored s d o -> ~ red s d o -> exists i, cored s d (out_div i).
Proof.
  introv R N. exists (cored_not_red_trace (cored_tcored R) N).
  applys cored_not_red_not_ter'.
Qed.

Lemma cored_red_or_div : forall s d o,
  cored s d o -> red s d o \/ exists i, cored s d (out_div i).
Proof.
  introv C. applys classic_right. intros N.
  applys* cored_not_red_not_ter.
Qed.

(************************************************************)
(* ** Auxiliary definition for the semantics of a program *)

(** Grammar of the results of a program *)

Inductive res :=
  | res_ter : heap -> res
  | res_div.

Implicit Types r : res.

(** Trace of a process execution *)

Inductive process_trace : cmd -> trace -> Prop :=
  | process_trace_ter : forall s c f,
      red stack_init c (out_ter s f) ->
      process_trace c (colist_of_list f)
  | process_trace_div : forall c i,
      cored stack_init c (out_div i) ->
      process_trace c (colist_of_stream i).

(** Extracting one observation from a list of traces *)

Inductive extract_obs : nat -> obs -> traces -> traces -> Prop :=
  | extract_obs_here : forall k t ts ts',
      extract_obs 0 k ((k::::t)::ts) (t::ts')
  | extract_obs_next : forall id k t ts ts',
      extract_obs id k ts ts' ->
      extract_obs (S id) k (t::ts) (t::ts').

(************************************************************)
(* ** Semantics w.r.t. sequential consistency *)

(** Transition of an observation over the heap *)

Inductive sc_heap_update : obs -> heap -> heap -> Prop :=
  | sc_heap_update_none : forall h,
      sc_heap_update obs_none h h
  | sc_heap_update_load : forall h v1 v2,
      Heap.binds h v1 v2 ->
      sc_heap_update (obs_load v1 v2) h h
  | sc_heap_update_store : forall h h' v1 v2,
      h' = Heap.write h v1 v2 ->
      sc_heap_update (obs_store v1 v2) h h'
  | sc_heap_update_cas : forall E h' v2' h v1 v2 v3 v4,
      Heap.binds h v1 v2' ->
      E = (v2 = v2') ->
      h' = (If E then (Heap.write h v1 v3) else h) ->
      v4 = int_of_prop E ->
      sc_heap_update (obs_cas v1 v2 v3 v4) h h'
  | sc_heap_update_fence : forall h,
      sc_heap_update obs_fence h h.

(** Interleaving of traces *)

CoInductive sc_observable : heap -> traces -> res -> Prop :=
  | sc_observable_nil : forall h ts,
      Forall (eq colist_nil) ts ->
      sc_observable h ts (res_ter h)
  | sc_observable_cons : forall id h' ts' k h ts r,
      extract_obs id k ts ts' ->
      sc_heap_update k h h' ->
      sc_observable h' ts' r ->
      sc_observable h ts r.

(** Possible behavior of a program *)

Definition sc_behavior p r :=
  exists ts, Forall2 process_trace p ts
    /\ sc_observable heap_init ts r
    /\ (r <> res_div -> Forall colist_finite ts).

(** More direct definitions for behaviros *)

Definition sc_returns p h := sc_behavior p (res_ter h).
Definition sc_diverge p := sc_behavior p res_div.

(************************************************************)
(* ** Semantics w.r.t. x86-TSO memory model *)

(** Write buffer *)

Definition buffer := list (word*word).

Implicit Types b : buffer.

Definition buffers := list buffer.

Definition buffers_init p : buffers :=
  LibList.map (fun _ => nil) p.

(** Updating a given buffer inside a list of buffers *)

Inductive buffers_replace : nat -> buffer -> buffer -> buffers -> buffers -> Prop :=
  | buffers_replace_here : forall b b' bs,
      buffers_replace O b b' (b::bs) (b'::bs)
  | buffers_replace_next : forall id b b' bs bs' b0,
      buffers_replace id b b' bs bs' ->
      buffers_replace (S id) b b' (b0::bs) (b0::bs').

(** Reading from the buffer then the store *)

Definition x86tso_lookup h b v1 v2 :=
  match assoc_option v1 b with
  | Some v => v = v2
  | None => Heap.binds h v1 v2
  end.

(** Transition of an observation over the heap *)

Inductive x86tso_heap_update : obs -> heap -> heap -> buffer -> buffer -> Prop :=
  | x86tso_heap_update_none : forall h b,
      x86tso_heap_update obs_none h h b b
  | x86tso_heap_update_load_buffer : forall h b v1 v2,
      x86tso_lookup h b v1 v2 ->
      x86tso_heap_update (obs_load v1 v2) h h b b
  | x86tso_heap_update_store : forall h h' v1 v2 b b',
      b' = b ++ ((v1,v2)::nil) ->
      x86tso_heap_update (obs_store v1 v2) h h b b'
  | x86tso_heap_update_cas : forall E h' v2' h v1 v2 v3 v4,
      Heap.binds h v1 v2' ->
      E = (v2 = v2') ->
      h' = (If E then (Heap.write h v1 v3) else h) ->
      v4 = int_of_prop E ->
      x86tso_heap_update (obs_cas v1 v2 v3 v4) h h' nil nil
  | x86tso_heap_update_fence : forall h,
      x86tso_heap_update obs_fence h h nil nil.

(** Interleaving of traces *)

CoInductive x86tso_observable : heap -> buffers -> traces -> res -> Prop :=
  | x86tso_observable_nil : forall h bs ts,
      Forall (eq nil) bs ->
      Forall (eq colist_nil) ts ->
      x86tso_observable h bs ts (res_ter h)
  | x86tso_observable_cons : forall id h' b b' bs' ts' k h ts bs r,
      extract_obs id k ts ts' ->
      buffers_replace id b b' bs bs' ->
      x86tso_heap_update k h h' b b' ->
      x86tso_observable h' bs' ts' r ->
      x86tso_observable h bs ts r
  | x86tso_observable_write : forall id b h' bs bs' v1 v2 h ts r,
      buffers_replace id ((v1,v2)::b) b bs bs' ->
      h' = Heap.write h v1 v2 ->
      x86tso_observable h' bs' ts r ->
      x86tso_observable h bs ts r.

(** Possible behavior of a program *)

Definition x86tso_behavior p r :=
  exists ts, Forall2 process_trace p ts
    /\ x86tso_observable heap_init (buffers_init p) ts r
    /\ (r <> res_div -> Forall colist_finite ts).

(** More direct definitions for behaviros *)

Definition x86tso_returns p h := x86tso_behavior p (res_ter h).
Definition x86tso_diverge p := x86tso_behavior p res_div.

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

(************************************************************)
(* ** Permutations *)

Inductive is_cmd_fence : cmd -> Prop :=
  | is_cmd_fence_intro : is_cmd_fence (cmd_bind novar act_fence).

Inductive is_cmd_cas : cmd -> Prop :=
  | is_cmd_cas_intro : forall x e1 e2 e3,
      is_cmd_cas (cmd_bind x (act_cas e1 e2 e3)).

Inductive is_cmd_load : cmd -> exp -> Prop :=
  | is_cmd_load_intro : forall x e,
      is_cmd_load (cmd_bind x (act_load e)) e.

Inductive is_cmd_store : cmd -> exp -> Prop :=
  | is_cmd_store_intro : forall x e1 e2,
      is_cmd_store (cmd_bind x (act_store e1 e2)) e1.

Definition is_cmd_load_or_store c e :=
  is_cmd_load c e \/ is_cmd_store c e.

Inductive cmd_permut : cmd -> cmd -> Prop :=
  | cmd_permut_refl : forall c,
      cmd_permut c c
  | cmd_permut_ctx_seq_1 : forall c1 c2 c1',
      cmd_permut c1 c1' ->
      cmd_permut (cmd_seq c1 c2) (cmd_seq c1' c2)
(*
  | cmd_permut_ctx_seq_2 : forall c1 c2 c2',
      cmd_permut c2 c2' ->
      cmd_permut (cmd_seq c1 c2) (cmd_seq c1 c2')
  | cmd_permut_ctx_if_1 : forall e c1 c2 c1',
      cmd_permut c1 c1' ->
      cmd_permut (cmd_if e c1 c2) (cmd_if e c1' c2)
  | cmd_permut_ctx_if_2 : forall e c1 c2 c2',
      cmd_permut c2 c2' ->
      cmd_permut (cmd_if e c1 c2) (cmd_if e c1 c2')
  | cmd_permut_ctx_while : forall e c1 c1',
      cmd_permut c1 c1' ->
      cmd_permut (cmd_while e c1) (cmd_while e c1')
*)
  | cmd_permut_seq_assoc_1 : forall c1 c2 c3,
      cmd_permut (cmd_seq c1 (cmd_seq c2 c3)) (cmd_seq (cmd_seq c1 c2) c3)
(*
  | cmd_permut_seq_assoc_2 : forall c1 c2 c3,
      cmd_permut (cmd_seq (cmd_seq c1 c2) c3) (cmd_seq c1 (cmd_seq c2 c3))
*)
  | cmd_permut_fence_fence : forall c1 c2,
      is_cmd_fence c1 ->
      is_cmd_fence c2 ->
      cmd_permut (cmd_seq c1 c2) c1
(*
  | cmd_permut_fence_cas : forall c1 c2,
      is_cmd_fence c1 ->
      is_cmd_cas c2 ->
      cmd_permut (cmd_seq c1 c2) c2
  | cmd_permut_cas_fence : forall c1 c2,
      is_cmd_cas c1 ->
      is_cmd_fence c2 ->
      cmd_permut (cmd_seq c1 c2) c1
  | cmd_permut_load_load :forall x1 e1 x2 e2,
      is_cmd_load c1 e1 ->
      is_cmd_load c2 e2 ->
      cmd_permut (cmd_seq c1 c2) (cmd_seq c2 c1)
  | cmd_permut_neq : forall c1 c2,
      is_cmd_load_or_store c1 e1 ->
      is_cmd_load_or_store c2 e2 ->
      (forall s, eval s e1 <> eval s e2) ->
      cmd_permut (cmd_seq c1 c2) (cmd_seq c2 c1)
  *)
  .

Definition is_obs_cas k :=
  match k with obs_cas _ _ _ _ => True | _ => False end.

Definition is_obs_load k v :=
  match k with obs_load v _ => True | _ => False end.

Definition is_obs_store k v :=
  match k with obs_load v _ => True | _ => False end.

Definition is_obs_load_or_store k v :=
  is_obs_load k v \/ is_obs_store k v.

Inductive trace_permut : trace -> trace -> Prop :=
  | trace_permut_refl : forall t,
      trace_permut t t
  | trace_permut_append_l : forall t1 t2 t,
      trace_permut t1 t2 ->
      trace_permut (t+++t1) (t+++t2)
  | trace_permut_append_r : forall t1 t2 t,
      trace_permut t1 t2 ->
      trace_permut (t1+++t) (t2+++t)
  | trace_permut_none_l : forall t1 t2,
      trace_permut t1 t2 ->
      trace_permut (obs_none::::t1) t2
  | trace_permut_none_r : forall t1 t2,
      trace_permut t1 t2 ->
      trace_permut t1 (obs_none::::t2)
  | trace_permut_fence_fence :
      trace_permut (obs_fence::::obs_fence::::cnil) (obs_fence::::cnil)
(*
  | trace_permut_fence_cas : forall k,
      is_obs_cas k ->
      trace_permut (obs_fence::::obs_none::::k::::cnil) k
  | trace_permut_cas_fence : forall k,
      is_obs_cas k ->
      trace_permut (k::::obs_none::::obs_fence::::cnil) k
  | trace_permut_load_load :forall x1 e1 x2 e2,
      is_obs_load k1 v1 ->
      is_obs_load k2 v2 ->
      trace_permut (k1::::obs_none::::k2::::cnil) (k2::::obs_none::::k1::::cnil)
  | trace_permut_neq : forall v1 v2,
      is_obs_load_or_store k1 v1 ->
      is_obs_load_or_store k2 v2 ->
      v1 <> v2 ->
      trace_permut (k1::::obs_none::::k2::::cnil) (k2::::obs_none::::k1::::cnil)
*)
      .

Hint Constructors trace_permut.

Lemma trace_permut_cons : forall k t1 t2,
  trace_permut t1 t2 ->
  trace_permut (k::::t1) (k::::t2).
Proof.
  introv H. forwards M: trace_permut_append_l (k::::cnil) H.
  rew_colist~ in M.
Qed.

Hint Resolve trace_permut_cons.

Lemma trace_permut_prepend : forall f t1 t2,
  trace_permut t1 t2 ->
  trace_permut (colist_prepend f t1) (colist_prepend f t2).
Proof. introv H. induction f; simple*. Qed.

(*
Lemma trace_permut_append : forall t t1 t2,
  trace_permut t1 t2 ->
  colist_finite t1 ->
  trace_permut (t1 +++ t) (t2 +++ t).
Proof.
  introv P. induction P; introv T.
  auto.
  inverts T. rew_colist*.
  inverts T. rew_colist*.
  rew_colist*.
  rew_colist*.
  inverts~ P. rew_colist.

trace_permut (colist_of_list f +++ colist_of_list f0)
  (colist_of_list t2' +++ colist_of_list f0)

*)
(*

Proof.
  Qed.

  | trace_permut_append : forall t t1 t2, eauto.

      trace_permut t1 t2 ->
      trace_permut (t1 +++ t) (t2 +++ t)
*)

Lemma colist_finite_append_inv : forall A (s1 s2 : colist A),
  colist_finite (s1 +++ s2) ->
  colist_finite s1 /\ colist_finite s2.
Proof.
  introv H. inductions H.
  destruct s1; destruct s2; rew_colist in *; auto_false.
  destruct s1.
    rew_colist in *. destruct s2; tryfalse. inverts~ x.
    rew_colist in *. inverts x. forwards*: IHcolist_finite.
Qed.

Lemma trace_permut_finite : forall t1 t2,
  trace_permut t1 t2 ->
  colist_finite t1 ->
  colist_finite t2.
Proof.
  introv P. induction P; introv F.
  auto.
  lets* (?&?): colist_finite_append_inv F.
  lets* (?&?): colist_finite_append_inv F.
  inverts~ F.
  auto.
  auto.
Qed.

Lemma colist_prove_eq : forall A (s1 s2 : colist A),
  colist_step s1 = colist_step s2 -> s1 = s2.
Proof. intros. destruct s1; destruct~ s2. Qed.

(* bin
Lemma trace_simpl : forall s f1 f2,
    step (out_prepend f1 (out_ter s f2))
  = out_ter s (obs_none :: f1 ++ f2).
Proof. auto. Qed.
*)
(*
  intros. auto. unfold step, colist_one, out_prepend.
  fequals. rew_colist~.
*)

Lemma colist_of_list_append : forall A (l1 l2 : list A),
   colist_of_list (l1 ++ l2)
 = colist_append (colist_of_list l1) (colist_of_list l2).
Proof.
  intros. induction l1; rew_list; simpl; rew_colist; fequals.
Qed.

Hint Rewrite colist_of_list_append : rew_colist.

Ltac trace_simpl_base :=
  simpl; idtac.
Tactic Notation "trace_simpl" :=
  trace_simpl_base; rew_colist.
Tactic Notation "trace_simpl" "in" hyp(H) :=
  trace_simpl_base; rew_colist in H.
Tactic Notation "trace_simpl" "in" "*" :=
  trace_simpl_base; rew_colist in *.

Hint Constructors exec.

Lemma red_bind_novar : forall v k s a,
  exec s a v k ->
  red s (cmd_bind novar a) (out_ter s (k::nil)).
Proof. introv H. constructors*. case_if*. Qed.

Lemma cored_bind_novar : forall v k s a,
  exec s a v k ->
  cored s (cmd_bind novar a) (out_ter s (k::nil)).
Proof. introv H. constructors*. case_if*. Qed. (* or red_cored *)

Hint Constructors trace_permut.

(* bin
Axiom red_trace_finite : forall s c o,
  red s c o ->
  exists s t, o = out_ter s t /\ colist_finite t /\ t <> colist_nil.

Lemma red_cmd_trace_finite : forall s c t s',
  red s c (out_ter s' t) -> colist_finite t.
Proof. introv R. lets (?&?&E&?&?): red_trace_finite R. inverts~ E. Qed.
Hint Resolve red_cmd_trace_finite.
*)

Lemma red_cmd_permut_trace_permut : forall c1 c2 f1 s s',
  cmd_permut c1 c2 ->
  red s c1 (out_ter s' f1) ->
  exists f2, red s c2 (out_ter s' f2)
          /\ trace_permut (colist_of_list f1) (colist_of_list f2).
Proof.
  introv P. gen f1 s s'. induction P; introv R.
  (* refl *)
  eauto.
  (* ctx_seq_1 *)
  inverts R as R1 R2 M. inverts R2 as.
  introv A. inverts A. trace_simpl in M. false.
  introv R2. destruct o0; trace_simpl in M; [| false ].
  inverts M. forwards* (t2'&S1&E1): IHP R1.
  esplit. split. applys_eq red_seq 1. eauto.
  applys* red_seq_1. simpl. fequals.
  trace_simpl. eauto.
  (* seq_assoc_1 *)
  inverts R as R1 R2 M. inverts R2 as.
  introv A. inverts A. trace_simpl in M. false.
  introv R2. destruct o0; trace_simpl in M; [| false ].
  inverts M. inverts R2 as R2 R3 M. inverts R3 as.
  introv A. inverts A. trace_simpl in M. false.
  introv R3. destruct o0; trace_simpl in M; [| false ].
  inverts M. esplit. split. applys_eq red_seq 1.
  applys* red_seq. simpl. applys* red_seq_1.
  trace_simpl. fequals.
  rew_list. trace_simpl.
  repeat applys trace_permut_none_l.
  repeat applys trace_permut_none_r.
  applys trace_permut_append_l.
  trace_simpl. eauto.
  (* fence_fence *)
  inverts H. inverts H0. inverts R as R1 R2 M.
  inverts R1 as R1. inverts R1.
  inverts R2 as R2 R3. inverts R2. inverts R2 as R2. inverts R2.
  case_if. trace_simpl in M. inverts M.
  esplit. split. applys* red_bind_novar.
  rew_list. trace_simpl. eauto.
Qed.

Lemma colist_of_stream_cons : forall A x (s : stream A),
   colist_of_stream (x:::s) = x::::(colist_of_stream s).
Proof. intros. applys~ colist_prove_eq. Qed.

Hint Rewrite colist_of_stream_cons : rew_colist.

Hint Constructors cored.
Hint Constructors abort.

Lemma cored_cmd_permut_trace_permut : forall c1 c2 i1 s,
  cmd_permut c1 c2 ->
  cored s c1 (out_div i1) ->
  exists i2, cored s c2 (out_div i2)
          /\ trace_permut (colist_of_stream i1) (colist_of_stream i2).
Proof.
  introv P. gen i1 s. induction P; introv R.
  (* refl *)
  eauto.
  (* ctx_seq_1 *)
(*
Focus 1.
  inverts R as R1 R2 M. inverts R2 as.
  introv A. inverts A. inverts M.
   forwards* (i2&?&?): IHP. exists (obs_none:::(obs_none:::i2)). splits*.
   applys* cored_seq (out_div (obs_none:::i2)).
   applys* cored_seq_1_abort (out_div i2).
   trace_simpl. eauto.
  introv R2. destruct o0; trace_simpl in M; [false|].
  inverts M. forwards [M1|(i1&M1)]: (cored_red_or_div R1).
  applys red_cored.

 exists (obs_none:::i). splits.

  cored s d o -> red s d o \/ exists i, cored s d (out_div i).
*)
skip.
skip.
(*
   applys_eq cored_seq 1.

  applys* cored_seq_1. simpl. fequals.
  trace_simpl. eauto.
  (* seq_assoc_1 *)
  inverts R as R1 R2 M. inverts R2 as.
  introv A. inverts A. trace_simpl in M. false.
  introv R2. destruct o0; trace_simpl in M; [| false ].
  inverts M. inverts R2 as R2 R3 M. inverts R3 as.
  introv A. inverts A. trace_simpl in M. false.
  introv R3. destruct o0; trace_simpl in M; [| false ].
  inverts M. esplit. split. applys_eq cored_seq 1.
  applys* cored_seq. simpl. applys* cored_seq_1.
  trace_simpl. fequals.
  rew_list. trace_simpl.
  repeat applys trace_permut_none_l.
  repeat applys trace_permut_none_r.
  applys trace_permut_append_l.
  trace_simpl. eauto.
*)
  (* fence_fence *)
  inverts H. inverts H0. inverts R as R1 R2 M.
  inverts R1 as R1. inverts R1.
  inverts R2 as R2 R3. inverts R2. inverts R2 as R2. inverts R2.
  case_if.
Qed.

Hint Constructors process_trace.

Lemma process_cmd_permut_trace_permut : forall c1 c2 t1,
  cmd_permut c1 c2 ->
  process_trace c1 t1 ->
  exists t2, process_trace c2 t2
          /\ trace_permut t1 t2.
Proof.
  introv P T. inverts T as R.
  forwards* (f2&?&?): red_cmd_permut_trace_permut.
    exists* (colist_of_list f2).
  forwards* (i2&?&?): cored_cmd_permut_trace_permut.
    exists* (colist_of_stream i2).
Qed.

Lemma trace_permut_keep_x86tso_behavior : forall h bs ts1 ts2 r,
  Forall2 trace_permut ts1 ts2 ->
  x86tso_observable h bs ts1 r ->
  x86tso_observable h bs ts2 r.
Proof.
  cofix IH. introv P M. inverts P. skip.

Qed.
(* process_cmd_permut_trace_permut *)

Lemma cmd_permut_keep_x86tso_behavior : forall p1 p2 r,
  Forall2 cmd_permut p1 p2 ->
  x86tso_behavior p1 r ->
  x86tso_behavior p2 r.
Proof.
  introv F (ts&TS&OS&FS).
  asserts (ts'&M): (exists ts',
    Forall3 (fun c t t' => process_trace c t' /\ trace_permut t t') p2 ts ts').
    clear OS FS. gen p2. induction TS; intros; inverts F.
    esplit. applys Forall3_nil.
    forwards* (t'&?&?): process_cmd_permut_trace_permut.
    forwards* (?&?): IHTS.
     esplit. applys* Forall3_cons.
  exists ts'. splits.
  gen M. clears_all. introv M. induction M; constructors*.
  applys trace_permut_keep_x86tso_behavior ts.
    gen M. clears_all. introv M. induction M; constructors*.
    applys_eq OS 3. gen F. clears_all. introv F.
     unfold buffers_init. induction F; intros; rew_list; fequals.
  gen M F FS. clears_all. introv M. gen p1. induction M; introv P FS N.
    constructors.
    forwards~ FS': FS. inverts~ FS'.  inverts H as N1 N2. inverts P.
     constructors.
       applys~ trace_permut_finite N2.
       applys* IHM.
Qed.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

Theorem pipo_6 : (forall A B C X Cprime Cprimeprime P T : Universe, ((wd_ X C /\ (wd_ A P /\ (wd_ A X /\ (wd_ A B /\ (wd_ B C /\ (wd_ A C /\ (wd_ A Cprime /\ (wd_ C Cprimeprime /\ (wd_ A Cprimeprime /\ (wd_ C Cprime /\ (wd_ X Cprime /\ (col_ A B X /\ (col_ A T X /\ (col_ P T C /\ (col_ P Cprime Cprimeprime /\ (col_ A C Cprimeprime /\ col_ X C Cprime)))))))))))))))) -> col_ A B T)).
Proof.
  time tac.
Qed.

End FOFProblem.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

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

End FOFProblem.


(* fails by default, will work with -impredicative-set option                   *)
Definition id : Set := forall (x:Set), x -> x.


Require Import Crypto.Reflection.Syntax.
Require Import Crypto.Reflection.Wf.
Require Import Crypto.Reflection.SmartMap.
Require Import Crypto.Reflection.Relations.
Require Import Crypto.Reflection.Z.MapCastByDeBruijnInterp.
Require Import Crypto.Reflection.Z.Syntax.
Require Import Crypto.Reflection.Z.Syntax.Util.
Require Import Crypto.Reflection.Z.Bounds.Interpretation.
Require Import Crypto.Reflection.Z.Bounds.InterpretationLemmas.
Require Import Crypto.Reflection.Z.Bounds.MapCastByDeBruijn.

Lemma MapCastCorrect
      {t} (e : Expr base_type op t)
      (Hwf : Wf e)
      (input_bounds : interp_flat_type Bounds.interp_base_type (domain t))
  : forall {b} e' (He':MapCast e input_bounds = Some (existT _ b e'))
           v v' (Hv : Bounds.is_bounded_by input_bounds v /\ cast_back_flat_const v' = v),
    Interp (@Bounds.interp_op) e input_bounds = b
    /\ Bounds.is_bounded_by b (Interp interp_op e v)
    /\ cast_back_flat_const (Interp interp_op e' v') = (Interp interp_op e v).
Proof.
  apply MapCastCorrect; auto.
  { apply is_bounded_by_interp_op. }
  { apply pull_cast_genericize_op. }
Qed.


From Undecidability.L Require Import Functions.Encoding Datatypes.LOptions Datatypes.LNat LTerm.

Print nat_unenc.

Instance term_nat_unenc : computable nat_unenc.
Proof.
  extract.
Qed.


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

Require Import Orders BinInt Zcompare Zorder.

(** THIS FILE IS DEPRECATED. *)

(*begin hide*)
(* Compatibility with names of the old Zminmax file *)
Notation Zmin_max_absorption_r_r := Z.min_max_absorption (only parsing).
Notation Zmax_min_absorption_r_r := Z.max_min_absorption (only parsing).
Notation Zmax_min_distr_r := Z.max_min_distr (only parsing).
Notation Zmin_max_distr_r := Z.min_max_distr (only parsing).
Notation Zmax_min_modular_r := Z.max_min_modular (only parsing).
Notation Zmin_max_modular_r := Z.min_max_modular (only parsing).
Notation max_min_disassoc := Z.max_min_disassoc (only parsing).
(*end hide*)