Require Export List.
Require Export Bool.
Require Export Arith.
Require Export Peano_dec.
Require Export Coq.Arith.PeanoNat.
Require Export Coq.Program.Wf.
Require Export Coq.Program.Tactics.
Require Export Coq.Logic.FunctionalExtensionality.
Require Export Recdef.

Require Import common.CpdtTactics.
Require Import common.wyv_common.
Require Import common.rhs_mat_tree.

Require Export common.lhs_sel_upp_reduce.rhs_sel_equ_reduce.
Require Export common.lhs_sel_upp_reduce.rhs_sel_upp_reduce.
Require Export common.lhs_sel_upp_reduce.rhs_sel_low_reduce.
Require Export common.lhs_sel_upp_reduce.rhs_sel_nom_reduce.
Require Export common.lhs_sel_upp_reduce.rhs_sel_bnd_reduce.

Require Export common.lhs_sel_upp_reduce.rhs_bot_reduce.

Require Export common.lhs_sel_upp_reduce.rhs_all_reduce.

Require Export common.lhs_sel_upp_reduce.rhs_sha_sel_reduce.
Require Export common.lhs_sel_upp_reduce.rhs_sha_top_reduce.
Require Export common.lhs_sel_upp_reduce.rhs_rfn_sel_reduce.
Require Export common.lhs_sel_upp_reduce.rhs_rfn_top_reduce.

Require Export common.lhs_sel_upp_reduce.rhs_upp_reduce.
Require Export common.lhs_sel_upp_reduce.rhs_nom_reduce.
Require Export common.lhs_sel_upp_reduce.rhs_equ_reduce.
Require Export common.lhs_sel_upp_reduce.rhs_low_reduce.

Require Export common.lhs_sel_upp_reduce.rhs_nil_reduce.
Require Export common.lhs_sel_upp_reduce.rhs_con_reduce.

Import WfExtensionality.

Lemma subtype_sel_upp_reduce :
  forall T1 x1 L1 T1',
    T1 = (t_sel_upp x1 L1 T1') ->
    forall T2, subtype T1 T2 = match T2 with
                          | t_top => true
                          | t_sel_low x2 L2 T2' => orb (andb (eq_var x1 x2) (eq_label L1 L2)) (orb (subtype T1' T2) (subtype T1 T2'))
                          | t_sel_equ x2 L2 T2' => orb (andb (eq_var x1 x2) (eq_label L1 L2)) (orb (subtype T1' T2) (subtype T1 T2'))
                          | t_sel_upp x2 L2 _ => orb (andb (eq_var x1 x2) (eq_label L1 L2)) (subtype T1' T2)
                          | t_sel_nom x2 L2 _ => orb (andb (eq_var x1 x2) (eq_label L1 L2)) (subtype T1' T2)
                          | t_sel_bnd x2 L2 => orb (andb (eq_var x1 x2) (eq_label L1 L2)) (subtype T1' T2)
                          | t_upp L2 T2' => false
                          | t_low L2 T2' => false
                          | t_equ L2 T2' => false
                          | t_nom L2 T2' => false

                          | t_nil => false
                          | t_con _ _ => false

                          | _ => subtype T1' T2
                          end.
Proof.
  intros.

  destruct T2.

  apply subtype_top;
    subst;
    intros;
    intro Hcontra;
    inversion Hcontra.

  subst;
    apply subtype_sel_upp_bot_reduce
      with (x1:=x1)(L1:=L1);
    auto.

  subst;
    apply subtype_sel_upp_sel_upp_reduce
      with (x1:=x1)(L1:=L1)(T2':=T2);
    auto.

  subst;
    apply subtype_sel_upp_sel_low_reduce
      with (x1:=x1)(L1:=L1)(T2':=T2);
    auto.

  subst;
    apply subtype_sel_upp_sel_equ_reduce
      with (x1:=x1)(L1:=L1)(T2':=T2);
    auto.

  subst;
    apply subtype_sel_upp_sel_nom_reduce
      with (x1:=x1)(L1:=L1)(T2':=T2);
    auto.

  subst;
    apply subtype_sel_upp_sel_bnd_reduce
      with (x1:=x1)(L1:=L1);
    auto.

  subst;
    apply subtype_sel_upp_rfn_top_reduce
      with (x1:=x1)(L1:=L1)(Ts:=T2);
    auto.

  subst;
    apply subtype_sel_upp_rfn_sel_reduce
      with (x1:=x1)(L1:=L1)(x2:=v)(L2:=l)(Ts:=T2_1)(T':=T2_2);
    auto.

  subst;
    apply subtype_sel_upp_sha_top_reduce
      with (x1:=x1)(L1:=L1)(x2:=v)(L2:=l)(ss2:=d);
    auto.

  subst;
    apply subtype_sel_upp_sha_sel_reduce
      with (x1:=x1)(L1:=L1)(x2:=v)(L2:=l)(T':=T2)(ss2:=d);
    auto.

  subst;
    apply subtype_sel_upp_all_reduce
      with (x1:=x1)(L1:=L1)(T:=T2_1)(T':=T2_2);
    auto.

  subst;
    apply subtype_sel_upp_upp_reduce
      with (x1:=x1)(L1:=L1)(T1':=T1')(L2:=l)(T2':=T2);
    auto.

  subst;
    apply subtype_sel_upp_low_reduce
      with (x1:=x1)(L1:=L1)(T1':=T1')(L2:=l)(T2':=T2);
    auto.

  subst;
    apply subtype_sel_upp_equ_reduce
      with (x1:=x1)(L1:=L1)(T1':=T1')(L2:=l)(T2':=T2);
    auto.

  subst;
    apply subtype_sel_upp_nom_reduce
      with (x1:=x1)(L1:=L1)(T1':=T1')(L2:=l)(T2':=T2);
    auto.

  subst T1; erewrite subtype_sel_upp_nil_reduce; eauto.

  subst T1; erewrite subtype_sel_upp_con_reduce; eauto.

Qed.


(*Require Import Coq.Logic.FunctionalExtensionality.*)
(*Require Import Coq.Logic.Eqdep.*)

Require Export CatSem.RPCF.RPCF_rep.
Require Export CatSem.CAT.eq_fibre.

Set Implicit Arguments.
Unset Strict Implicit.
Set Transparent Obligations.
Unset Automatic Introduction.

Notation "M [( s )]" := (FIB_RMOD_HOM M s) (at level 30).
Notation "f 'X' g" := (product_mor _ f g)(at level 30).
Notation "f ** rho" := (colax_PbRMod_Hom f rho)(at level 34).

Notation "'IsoPF'" := (colax_Pb_Fib _ _ _).
Notation "'IsoFP'" := (colax_Fib_Pb _ _ _).
Notation "'IsoXP'" := (colax_PROD_PM _ _ _ _ ).

(*Notation "f 'D' r [( s )] " := (DerFib_RMod_Hom f s r) (at level 33).*)

Notation "*--->*" := (unit_rmod _ ).

(** morphisms of representations *)

(*

Section arrow_lemmata.

Variables U U': Type.
Variable Uar : U -> U -> U.
Variable U'ar : U' -> U' -> U'.

Notation "u >>> v" := (U'ar u v) (at level 60, right associativity).
Notation "u >> v" := (Uar u v) (at level 60, right associativity).

Variable g : U -> U'.
Hypothesis H : forall u v, g (u >> v) = g u >>> g v.

Lemma arrow_distrib3 : forall u v w,
   g (u >> v >> w) =
   g u >>> g v >>> g w.
Proof.
  intros u v w.
  repeat rewrite H.
  reflexivity.
Defined.

Lemma arrow_distrib4 : forall u v y z,
   g (u >> v >> y >> z) =
   g u >>> g v >>> g y >>> g z.
Proof.
  intros u v y z.
  repeat rewrite H.
  reflexivity.
Defined.

Variable Ubool : U.
Variable Unat : U.
Variable U'bool : U'.
Variable U'nat : U'.

Hypothesis gnat : g Unat = U'nat.
Hypothesis gbool : g Ubool = U'bool.

Lemma n_ar_n : g (Unat >> Unat) = U'nat >>> U'nat.
Proof.
  rewrite <- gnat.
  apply H.
Defined.

(*
Lemma arrow_dist_ct2 : forall r s,
  g (f r >> f s) =
  f' r >>> f' s.
Proof.
  intros.
  repeat rewrite H.
  repeat rewrite H'.
  reflexivity.
Defined.

Lemma arrow_dist_ct3 : forall r s t ,
  g (f r >> f s >> f t) =
  f' r >>> f' s >>> f' t.
Proof.
  intros.
  repeat rewrite H.
  repeat rewrite H'.
  reflexivity.
Defined.

Lemma arrow_dist_ct4 : forall r s t u,
  g (f r >> f s >> f t >> f u) =
  f' r >>> f' s >>> f' t >>> f' u.
Proof.
  intros.
  repeat rewrite H.
  repeat rewrite H'.
  reflexivity.
Defined.
*)
(*
Variable U'' : Type.
Variable f'' : T -> U''.
Variable g' : U' -> U''.
Variable U''ar : U'' -> U'' -> U''.

Notation "u >>>> v" := (U''ar u v)
       (at level 60, right associativity).

Hypothesis Hg' : forall u v,
       g' (u >>> v) = g' u >>>> g' v.

Lemma comp_arrow_dist:
forall u v : U,
  (fun t => g' (g t)) (u >> v) =
  (fun t => g' (g t)) u >>>>
  (fun t => g' (g t) ) v.
Proof.
  simpl.
  intros.
  rewrite H.
  rewrite Hg'.
  reflexivity.
Defined.

Hypothesis Hgf : forall t, g' (f' t) = f'' t.

Lemma comp_arrow_commute :
   forall t, g' (g (f t)) = f'' t.
Proof.
  intros.
  rewrite H'.
  rewrite Hgf.
  reflexivity.
Defined.
*)
End arrow_lemmata.
*)

Section rep_hom.

Variables P R : PCFPO_rep.

Section Rep_Hom_Class.

(** a morphism of representations
        - (U, f, P, Rep)
        - (U', f', Q, Rep')
   is given by
        - g : U -> U'
        - H : f ; g = f'
        - generalized monad morphism P -> Q (with F = RETYPE g)
        - properties
*)

Variable Sorts_map : Sorts P -> Sorts R.
(*Hypothesis H : forall t, f (type_mor P t) = type_mor R t.*)
Hypothesis HArrow : forall u v, Sorts_map (u ~~> v) = Sorts_map u ~~> Sorts_map v.
Hypothesis HBool : Sorts_map (Bool _ ) = Bool _ .
Hypothesis HNat : Sorts_map (Nat _ ) = Nat _ .

Variable f : colax_RMonad_Hom P R
    (G1:=RETYPE (fun t => Sorts_map t))
    (G2:=RETYPE_PO (fun t => Sorts_map t))
  (RT_NT (fun t => Sorts_map t)).

(*
Definition MM := gen_PbRMod_ind_Hom M.
Check FFib_Mod_Hom. Check FIB_RMOD_HOM.
Print FIB_RMOD_eq.
*)

(*
Check (fun r s => FIB_RMOD_eq (gen_PbRMod M R) (H (r ~> s))).
Check (fun r s => app (P:=P) r s).
Check (fun r s => app (P:=P) r s ;;
                  FIB_RMOD_HOM M _  ).
Check (fun r s => app (P:=P) r s ;;
                  FIB_RMOD_HOM M _  ;;
                  gen_pb_fib _ _ _ ).

Check FIB_RMOD_HOM.

Check (fun u v =>

               gen_PROD_PM _ _ _ _ ;;
               gen_PbRMod_Hom M (app (f u) (f v))).

Check (fun u v => FIB_RMOD_HOM M (u ~~> v);;
                  FIB_RMOD_eq _ (H' _ _ );;
                  gen_pb_fib M _ _ ).

Check (fun u =>  (FIB_RMOD_HOM M (u) ;;
              gen_pb_fib _ _ _ )).

Check (fun u v =>
          product_mor _
             (FIB_RMOD_HOM M ((u ~~> v)) ;;
              FIB_RMOD_eq _ (H' _ _);;
              gen_pb_fib M _ _ )
             (FIB_RMOD_HOM M (u) ;;
              gen_pb_fib M _ _ )).

Check (fun (u v : type_type P) => app u v;;
             FIB_RMOD_HOM M _ ).

Check (fun u v =>

           product_mor _
             (FIB_RMOD_HOM M ((u ~~> v)) ;;
              FIB_RMOD_eq _ (H' _ _);;
              gen_pb_fib _ _ _ )
             (FIB_RMOD_HOM M (u) ;;
              gen_pb_fib _ _ _ )
            ;;
           gen_PROD_PM _ _ _ _
            ;;
           gen_PbRMod_Hom _ (app (f u) (f v))
           ==
           app u v;;
             FIB_RMOD_HOM M _ ;;
             gen_pb_fib _ _ _ ).
*)
(* this is the correct diag for app *)

(*
Check (fun u v : type_type P => abs u v ;;
             FIB_RMOD_HOM M _ ;;
             FIB_RMOD_eq _ (H' _ _ ) ;;
             gen_pb_fib _ _ _ ).

Check (der_fib_hom).
Check (fun u v => der_fib_hom_noeq _ _ _ ;;
                gen_pb_fib _ _ _ ;;
                gen_PbRMod_Hom M (abs (f u) (f v))).

Check (fun u v =>  abs u v ;;
             FIB_RMOD_HOM M _ ;;
             FIB_RMOD_eq _ (H' _ _ ) ;;
             gen_pb_fib _ _ _
             ==
             der_fib_hom_noeq _ _ _ ;;
                gen_pb_fib _ _ _ ;;
                gen_PbRMod_Hom M (abs (f u) (f v))).

Check FFib_DER_Mod_Hom_eqrect.
Check der_fib_hom.
*)

(*
Print gen_pb_fib.
Check (fun s => gen_pb_fib M s R).
Check (der_fib_hom).

Check (fun r s =>   der_fib_hom M _ (H _ ) ;;
                    FIB_RMOD_eq _ (H _ ) ;;
                    gen_pb_fib M (type_mor R s) (d R // type_mor R r) ;;
                    gen_PbRMod_Hom M (abs r s)).
*)
(*
Check (fun r  s => der_fib_hom _ _ (H r ) ;;
                  FIB_RMOD_eq M (H s) ). ;;
                  gen_PbRMod_Hom M (abs r s)).
  *)
(*
Check (fun r s => abs r s ;;
                  FIB_RMOD_HOM M _ ;;
                  FIB_RMOD_eq _ (H _ );;
                  gen_pb_fib _ _ _ ).

Check (fun t => unit_rmod M  ;; gen_PbRMod_Hom _ (bottom t )).
Check (fun t => bottom t ;;
                FIB_RMOD_HOM M _ ;;
                FIB_RMOD_eq _ (H _ );;
                gen_pb_fib _ _ _ ).

Check (tttt (PCFPO_rep_struct := P) ;; FIB_RMOD_HOM M _ ).

Check Term.

Print gen_pb_fib.

*)
(*
Check True.
Check (CondB (PCFPO_rep_struct := P)).

Check (arrow_dist_ct4 H' H).

Check (CondB  (PCFPO_rep_struct := P) ;;
          FIB_RMOD_HOM M _  ;;
          FIB_RMOD_eq _ (arrow_dist_ct4 H' H _ _ _ _)).

Check FIB_RMOD_small_eq.
*)
(*
Check FIB_RMOD_HOM.
Check (CondB (PCFPO_rep_struct := P)).
*)

Obligation Tactic :=
        intros; simpl; repeat (rew_all || auto).

(*Print Succ.*)
Implicit Arguments Succ [Sorts P Arrow Bool Nat PCFPO_rep_struct].
(*Print Succ.*)
Implicit Arguments CondB [Sorts P Arrow Bool Nat PCFPO_rep_struct].
Implicit Arguments CondN [Sorts P Arrow Bool Nat PCFPO_rep_struct].
Implicit Arguments Pred [Sorts P Arrow Bool Nat PCFPO_rep_struct].
Implicit Arguments Zero [Sorts P Arrow Bool Nat PCFPO_rep_struct].
Implicit Arguments ffff [Sorts P Arrow Bool Nat PCFPO_rep_struct].
Implicit Arguments tttt [Sorts P Arrow Bool Nat PCFPO_rep_struct].
Implicit Arguments Nat [p].
Implicit Arguments Bool [p].
(*Print nats.*)
(*
Implicit Arguments bottom [U P Arrow Bool Nat].
Implicit Arguments nats [U P Arrow Bool Nat].
Implicit Arguments bottom [U P Arrow Bool Nat].
*)

(*Print app.*)

Program Definition Succ_hom' :=
  Succ  (*PCFPO_rep_struct := P*) ;; f [(Nat ~~> Nat)] ;;
(*                FIB_RMOD_HOM M _ ;; *)
                Fib_eq_RMod _ ( _ );;
(*                colax_Pb_Fib f _ _ *)
                IsoPF
           ==
           *--->* ;;
(*           unit_rmod f  ;; *)
           f ** (Succ  (*PCFPO_rep_struct := R*)).

Program Definition CondB_hom' := CondB (*PCFPO_rep_struct := P*) ;;
                f [( _ )] ;;
                Fib_eq_RMod _ ( _ );;
(*                colax_Pb_Fib _ _ _ *)
                IsoPF
           ==
           *--->* ;;
(*           unit_rmod f  ;; *)
           f ** (CondB (*PCFPO_rep_struct := R*)).

Program Definition CondN_hom' := CondN (*PCFPO_rep_struct := P*) ;;
                f [( _ )] ;;
                Fib_eq_RMod _ _ ;;
                IsoPF
           ==
           *--->* ;;
(*           unit_rmod f  ;; *)
           f ** (CondN (*PCFPO_rep_struct := R*)).

Program Definition Pred_hom' := Pred (*PCFPO_rep_struct := P*) ;;
                f [( _ )] ;;
                Fib_eq_RMod _ _ ;;
                IsoPF
           ==
           *--->* ;;
(*           unit_rmod f  ;; *)
           f ** (Pred (*PCFPO_rep_struct := R*)) .

Program Definition Zero_hom' := Zero (*PCFPO_rep_struct := P*) ;;
                f [( _ )] ;;
                Fib_eq_RMod _ _;;
                IsoPF
           ==
           *--->* ;;
(*           unit_rmod f  ;; *)
           f ** (Zero (*PCFPO_rep_struct := R*)).

Program Definition fff_hom' := ffff (*PCFPO_rep_struct := P*) ;;
                f [( _ )] ;;
                Fib_eq_RMod _ _ ;;
                IsoPF
           ==
           *--->* ;;
(*           unit_rmod f  ;; *)
           f ** (ffff (*PCFPO_rep_struct := R*)).

Program Definition ttt_hom' := tttt (*PCFPO_rep_struct := P*) ;;
                f [( _ )] ;;
                Fib_eq_RMod _ _ ;;
                IsoPF
           ==
           *--->*  ;;
(*           unit_rmod f ;; *)
           f ** (tttt (*PCFPO_rep_struct := R*)).

Program Definition bottom_hom' := forall u,
           bottom u ;;
                f [( _ )] ;;
(*                FIB_RMOD_eq _ (H _ );; *)
             IsoPF
           ==
           *--->*  ;;
(*           unit_rmod f  ;; *)
           f ** (bottom (_)).

Program Definition nats_hom' := forall m,
           nats m ;;
                f [( _ )] ;;
                Fib_eq_RMod _ ( _ );;
                IsoPF
           ==
           *--->*  ;;
(*           unit_rmod f  ;; *)
           f ** (nats m).

Program Definition app_hom' := forall u v,
(*          product_mor _ *)
             (f [(u ~~> v)] ;;
              Fib_eq_RMod _ (HArrow _ _);;
              (*colax_Pb_Fib _ _ _ )*) IsoPF ) X
             (f [(u)] ;;
              (*colax_Pb_Fib _ _ _ )*)
              IsoPF )
            ;;
(*           colax_PROD_PM _ _ _ _ *)
             IsoXP
            ;;
(*           colax_PbRMod_Hom _ (app (_ u) (_ v)) *)
           f ** (app _ _ )
           ==
           app u v;;
             f [( _ )] ;; IsoPF.
(*             colax_Pb_Fib _ _ _ .*)

 (* abs_hom : forall u v,
       abs u v ;;
             FIB_RMOD_HOM M _ ;;
             FIB_RMOD_small_eq _ (H' _ _ ) ;;
             gen_pb_fib _ _ _
             ==
             der_fib_hom_noeq _ _ _ ;;
                gen_pb_fib _ _ _ ;;
                gen_PbRMod_Hom M (abs (f u) (f v))
;*)

Program Definition rec_hom' := forall t,
      rec t ;;
         f [( _ )] ;; IsoPF
(*        colax_Pb_Fib f _ _ *)
      ==
      f [( _ )] ;;
      Fib_eq_RMod _  (HArrow _ _) ;;
(*      colax_Pb_Fib f _ _ ;; *)
        IsoPF ;;
      f ** (rec (_ t)) .

Program Definition  abs_hom' := forall u v,
     abs u v ;;
         f [( _ )]
(*        FIB_RMOD_small_eq _ (H' _ _ ) ;;
        gen_pb_fib _ _ _  *)
             ==
        DerFib_RMod_Hom _ _ _ ;;
(*        D f d u [( v )]  ;; *)
(*        colax_Pb_Fib _ _ _ ;; *)
        IsoPF ;;
        f ** (abs (_ u) (_ v)) ;;
(*	colax_Fib_Pb _ _ _  ;;*)
        IsoFP ;;
	Fib_eq_RMod _ (eq_sym (HArrow _ _ )) .

Class PCFPO_rep_Hom_struct := {

  CondB_hom :  CondB_hom'
;
  CondN_hom : CondN_hom'
;
  Pred_hom : Pred_hom'
;
  Zero_hom : Zero_hom'
;
  Succ_hom : Succ_hom'
;
  fff_hom : fff_hom'

;
  ttt_hom : ttt_hom'
;
  bottom_hom : bottom_hom'
;
  nats_hom : nats_hom'
;

  app_hom : app_hom'
;
 (* abs_hom : forall u v,
       abs u v ;;
             FIB_RMOD_HOM M _ ;;
             FIB_RMOD_small_eq _ (H' _ _ ) ;;
             gen_pb_fib _ _ _
             ==
             der_fib_hom_noeq _ _ _ ;;
                gen_pb_fib _ _ _ ;;
                gen_PbRMod_Hom M (abs (f u) (f v))
;*)
  rec_hom : rec_hom'
;
  abs_hom : abs_hom'
}.

End Rep_Hom_Class.

(** the type of morphismes of representations P -> R *)

Record PCFPO_rep_Hom := {
  Sorts_map : Sorts P -> Sorts R ;
  HArrow : forall u v, Sorts_map (u ~~> v) = Sorts_map u ~~> Sorts_map v;
  HNat : Sorts_map (Nat _ ) = Nat R ;
  HBool : Sorts_map (Bool _ ) = Bool R ;
  rep_Hom_monad :> colax_RMonad_Hom P R (RT_NT (fun t => Sorts_map t));
  rep_colax_Hom_monad_struct :> PCFPO_rep_Hom_struct
                 HArrow HBool HNat rep_Hom_monad
}.

End rep_hom.

Existing Instance rep_colax_Hom_monad_struct.


Require Import Syntax.
Require Import SemanticsStatic.
Require Import SemanticsDynamic.

Lemma transmission : forall program Psi Delta Delta' Gamma Gamma' P P' theta v T,
  value_t v ->
  transmittable_type T ->
  peers_tied program P' P ->
  List.incl theta (peer_instances_of_type program P) ->
  program :: Psi; Delta; Gamma; P |- v : T ->
  program :: Psi; Delta'; Gamma'; P' |- zeta P theta v T : T.
Proof.
intros until T.
intros H_value H_transmittable H_tied H_instance H_typing.
generalize dependent T.
induction v; intros; inversion H_value; inversion H_typing; subst.
- inversion H_transmittable.
- apply T_Unit.
- apply T_None.
- inversion H_transmittable.
  simpl.
  apply T_Some.
  apply IHv; assumption.
- apply T_Nil.
- inversion H_transmittable.
  simpl.
  apply T_Cons.
  + apply IHv1; assumption.
  + apply IHv2; assumption.
- apply T_Peer. assumption.
- destruct H7; subst.
  + simpl.
    apply T_Signal.
    apply T_ComFrom with (T0 := Unit).
    * inversion H_transmittable.
      assumption.
    * apply U_Unit.
    * apply T_Unit.
    * apply T_Now with (T0 := Signal T1); try (left; reflexivity).
      apply T_Reactive with (T1 := T1); try (left; reflexivity).
      assumption.
    * assumption.
    * apply T_Peer.
      assumption.
  + inversion H_transmittable.
- apply T_Nat.
Qed.


From LogRel.AutoSubst Require Import core unscoped Ast Extra.
From LogRel Require Import Utils BasicAst Notations Context NormalForms UntypedReduction Weakening GenericTyping LogicalRelation DeclarativeInstance.
From LogRel.LogicalRelation Require Import Induction Reflexivity Irrelevance Escape.

Set Universe Polymorphism.

Section Neutral.
Context `{GenericTypingProperties}.

Definition neu {l Γ A} : Ne[Γ |- A] -> [Γ |- A] -> [ Γ |- A ~ A : U] -> [Γ ||-<l> A].
Proof.
  intros neA wtyA reflA. apply LRne_.
  exists A; [gen_typing|..]; assumption.
Defined.

Lemma neU {l Γ A n} (h : [Γ ||-U<l> A]) :
  Ne[Γ |- n : A] ->
  [Γ |- n : A] ->
  [Γ |- n ~ n : A] ->
  [LogRelRec l | Γ ||-U n : A | h].
Proof.
  assert [Γ |- A ≅ U] by (destruct h; gen_typing).
  intros; exists n.
  * eapply redtmwf_conv; tea; now eapply redtmwf_refl.
  * now eapply NeType, tm_ne_whne.
  * eapply tm_nf_conv; [|gen_typing|eassumption].
    now eapply tm_ne_nf.
  * eapply convtm_conv; tea; gen_typing.
  * eapply RedTyRecBwd, neu. 2,3: gen_typing.
    eapply ty_ne_term, tm_ne_conv; now gen_typing.
Defined.

Lemma neElim {Γ l K} : [Γ ||-<l> K] -> whne K -> [Γ ||-ne K].
Proof.
  intros h; pattern l,Γ,K,h; eapply LR_rect_TyUr;
  clear l Γ K h.
  - intros ??? [??? r] ne; pose proof (redtywf_whne r  ne); subst; inversion ne.
  - intros; assumption.
  - intros ??? [?? red] ?? ne ; cbn in *.
    rewrite (redtywf_whne red ne) in ne.
    inversion ne.
  - intros ??? [red] ne.
    rewrite (redtywf_whne red ne) in ne.
    inversion ne.
  - intros ??? [red] ne.
    rewrite (redtywf_whne red ne) in ne.
    inversion ne.
Qed.

Set Printing Primitive Projection Parameters.

Lemma neuEq {l Γ A B} (RA : [Γ ||-<l> A]) :
  Ne[Γ |- A] -> Ne[Γ |- B] ->
  [Γ |- A] -> [Γ |- B] ->
  [Γ |- A ~ B : U] ->
  [Γ ||-<l> A ≅ B | RA].
Proof.
  intros neA neB wtyA wtyB eqAB.
  unshelve irrelevance0. 1: assumption. 3: reflexivity.
  1: apply neu; try assumption; now eapply lrefl.
  econstructor.
  1: now apply redtywf_refl.
  all: cbn; assumption.
Qed.

Lemma ty_app_ren {Γ Δ A f a dom cod} (ρ : Δ ≤ Γ) :
  [Γ |- f : A] -> [Γ |- A ≅ tProd dom cod] -> [Δ |- a : dom⟨ρ⟩] -> [Δ |- tApp f⟨ρ⟩ a : cod[a .: ρ >> tRel]].
Proof.
  intros.
  replace (cod[a .: ρ >> tRel]) with (cod⟨wk_up dom ρ⟩[a..]) by (now bsimpl).
  unshelve eapply ty_app. 3: eassumption.
  replace (tProd _ _) with (tProd dom cod)⟨ρ⟩ by now bsimpl.
  gen_typing.
Qed.

Lemma convneu_app_ren {Γ Δ A f g a b dom cod} (ρ : Δ ≤ Γ) :
  [Γ |- f ~ g : A] ->
  [Γ |- A ≅ tProd dom cod] ->
  [Δ |- a ≅ b : dom⟨ρ⟩] ->
  [Δ |- tApp f⟨ρ⟩ a ~ tApp g⟨ρ⟩ b : cod[a .: ρ >> tRel]].
Proof.
  intros.
  replace (cod[a .: ρ >> tRel]) with (cod⟨wk_up dom ρ⟩[a..]) by (now bsimpl).
  unshelve eapply convneu_app. 3: eassumption.
  replace (tProd _ _) with (tProd dom cod)⟨ρ⟩ by now bsimpl.
  gen_typing.
Qed.

Lemma neu_app_ren {Γ Δ A n a dom cod} (ρ : Δ ≤ Γ) :
  [|- Δ] ->
  [Γ |- tProd dom cod] ->
  Ne[Γ |- n : A] -> [Γ |- A ≅ tProd dom cod] -> Nf[Δ |- a : dom⟨ρ⟩] -> Ne[Δ |- tApp n⟨ρ⟩ a : cod[a .: ρ >> tRel]].
Proof.
  intros.
  replace (cod[a .: ρ >> tRel]) with (cod⟨wk_up dom ρ⟩[a..]) by (now bsimpl).
  eapply tm_ne_app; [|eassumption].
  change (Ne[Δ |- n⟨ρ⟩ : (tProd dom cod)⟨ρ⟩]).
  eapply tm_ne_conv; [| |now eapply convty_wk].
  + now eapply tm_ne_wk.
  + now eapply wft_wk.
Qed.

Record complete {l Γ A} (RA : [Γ ||-<l> A]) := {
  reifyTyConv : forall B, [Γ ||-<l> A ≅ B | RA] -> Nf[Γ |- B];
  reflect : forall n n',
    Ne[Γ |- n : A] ->
    Ne[Γ |- n' : A] ->
    [Γ |- n : A] ->
    [Γ |- n' : A] ->
    [Γ |- n ~ n' : A] ->
    [Γ ||-<l> n : A | RA] × [Γ ||-<l> n ≅ n' : A| RA];
  reify : forall a, [Γ ||-<l> a : A | RA] -> Nf[ Γ |- a : A];
}.

Lemma complete_reflect_simpl {l Γ A} (RA : [Γ ||-<l> A]) (c : complete RA) :
  forall n, Ne[Γ |- n : A] -> [Γ |- n : A] -> [Γ |- n ~ n : A] -> [Γ ||-<l> n : A | RA].
Proof.
intros; eapply c.
5: eassumption.
all: assumption.
Qed.

Lemma complete_var0 {l Γ A A'} (RA : [Γ ,, A ||-<l> A']) :
  complete RA ->
  [Γ ,, A |- A⟨↑⟩ ≅ A'] ->
  [Γ |- A] ->
  [Γ ,, A ||-<l> tRel 0 : A' | RA].
Proof.
  intros cRA conv HA.
  assert [Γ ,, A |- tRel 0 : A']
  by (eapply ty_conv; tea; escape; eapply (ty_var (wfc_wft EscRA) (in_here _ _))).
  eapply complete_reflect_simpl; tea.
  - eapply tm_ne_conv; tea.
    2: now escape.
    now eapply tm_ne_rel.
  - eapply convneu_var; tea.
Qed.

Lemma complete_U : forall l Γ A (RA : [Γ ||-U< l > A]), complete (LRU_ RA).
Proof.
intros l Γ A h0; split.
- intros ? [].
  eapply ty_nf_red, ty_nf_sort; gen_typing.
- intros ?? ???? h; pose proof (lrefl h); pose proof (urefl h).
  assert [Γ |- A ≅ U] by (destruct h0; gen_typing); split.
  2: unshelve econstructor.
  1-3: now apply neU.
  + eapply RedTyRecBwd, neu. 2,3: try gen_typing.
    eapply ty_ne_term, tm_ne_conv; tea; gen_typing.
  + cbn. gen_typing.
  + eapply RedTyRecBwd; apply neu. 2, 3: gen_typing.
    eapply ty_ne_term, tm_ne_conv; tea; gen_typing.
  + eapply TyEqRecBwd. eapply neuEq. all: try gen_typing.
    all: eapply ty_ne_term, tm_ne_conv; tea; gen_typing.
- intros a [a' Hr Ha].
  assert ([Γ |-[ ta ] U ≅ A]).
  { destruct h0; gen_typing. }
  eapply tm_nf_conv; [| |eassumption].
  + eapply tm_nf_red; [eapply tmr_wf_red|]; eassumption.
  + now eapply escape, LRU_.
Qed.

Lemma complete_ne : forall l Γ A (RA : [Γ ||-ne A]), complete (LRne_ l RA).
Proof.
intros l Γ A h0; split.
- intros ? [].
  eapply ty_nf_red; [|now apply ty_ne_nf].
  gen_typing.
- destruct h0 as [B []]; intros ** ; assert ([Γ |- A ≅ B]) by gen_typing ; split.
  + exists n; cbn.
    * eapply redtmwf_refl ; gen_typing.
    * now eapply tm_ne_conv.
    * eapply lrefl; eapply convneu_conv; eassumption.
  + exists n n'; cbn.
    1,2: eapply redtmwf_refl ; eapply ty_conv; gen_typing.
    1,2: now eapply tm_ne_conv.
    gen_typing.
- intros a [a' Hr Hne].
  assert ([Γ |-[ ta ] neRedTy.ty h0 ≅ A]).
  { destruct h0; simpl in *; symmetry.
    eapply convty_exp; [now apply tyr_wf_red| |].
    all: gen_typing. }
  eapply tm_nf_conv; [| |eassumption].
  + eapply tm_nf_red; [now apply tmr_wf_red|].
    now apply tm_ne_nf.
  + now eapply escape, LRne_ with (l := l).
Qed.

Lemma complete_Pi : forall l Γ A (RA : [Γ ||-Π< l > A]),
  (forall (Δ : context) (ρ : Δ ≤ Γ) (h : [ |-[ ta ] Δ]),
        complete (PiRedTyPack.domRed RA ρ h)) ->
  (forall (Δ : context) (a : term) (ρ : Δ ≤ Γ) (h : [ |-[ ta ] Δ])
          (ha : [PiRedTyPack.domRed RA ρ h | Δ ||- a : (PiRedTyPack.dom RA)⟨ρ⟩]),
        complete (PiRedTyPack.codRed RA ρ h ha)) ->
  complete (LRPi' RA).
Proof.
intros l Γ A ΠA0 ihdom ihcod; split.
- intros B ΠB.
  assert (tΓ : [|- Γ]) by (destruct ΠA0; gen_typing).
  eapply ty_nf_red; [apply tyr_wf_red, ΠB|].
  assert [PiRedTyPack.domRed ΠA0 wk_id tΓ | Γ ||- (PiRedTyPack.dom ΠA0)⟨wk_id⟩ ≅ PiRedTyEq.dom ΠB].
  1: erewrite <- wk_id_ren_on; eapply (PiRedTyEq.domRed ΠB).
  eapply ty_nf_prod.
  + now eapply ihdom.
  + destruct ΠB as [dom cod ?? domRed codRed] ; cbn in *.
    assert [|- Γ ,, dom]. 1:{
      apply wfc_cons; tea.
      now eapply escapeConv.
    }
    eapply ihcod.
    replace cod with cod[tRel 0 .: @wk1 Γ dom >> tRel].
    2: bsimpl ; rewrite scons_eta' ; now bsimpl.
    eapply codRed.
    Unshelve.  1: tea.
    eapply complete_var0.
      * eapply ihdom.
      * symmetry; eapply escapeEq; erewrite <- wk1_ren_on.
        unshelve eapply domRed. tea.
      * now eapply escapeConv.
- set (ΠA := ΠA0); destruct ΠA0 as [dom cod].
  simpl in ihdom, ihcod.
  assert [Γ |- A ≅ tProd dom cod] by gen_typing.
  unshelve refine ( let funred : forall n, Ne[Γ |- n : A] -> [Γ |- n : A] -> [Γ |- n ~ n : A] -> [Γ ||-Π n : A | PiRedTyPack.toPiRedTy ΠA] := _ in _).
  {
    intros. exists n; cbn.
    * eapply redtmwf_refl ; gen_typing.
    * now eapply NeFun, tm_ne_whne.
    * eapply tm_nf_conv; [| |eassumption].
      + now eapply tm_ne_nf.
      + now eapply wft_prod.
    * gen_typing.
    * intros; apply complete_reflect_simpl; [apply ihcod| |..].
      { eapply neu_app_ren; try eassumption.
        + now apply wft_prod.
        + now apply (ihdom _ ρ h). }
      1: escape ; now eapply ty_app_ren.
      eapply convneu_app_ren. 1,2: eassumption.
      eapply LREqTermRefl_ in ha.
      now escape.
    * intros. apply ihcod.
      + eapply neu_app_ren; try eassumption.
        -- now apply wft_prod.
        -- now apply (ihdom _ ρ h).
      + eapply tm_ne_conv.
        - eapply neu_app_ren; try eassumption.
          -- now apply wft_prod.
          -- now apply (ihdom _ ρ h).
        - now eapply escape, codRed.
        - symmetry. now unshelve eapply escapeEq, codExt.
      + apply escapeTerm in ha; now eapply ty_app_ren.
      + pose proof (cv := escapeEq _ (codExt _ _ _ ρ _ ha hb eq0)).
        symmetry in cv; unshelve eapply (ty_conv _ cv).
        apply escapeTerm in hb; now eapply ty_app_ren.
      + apply escapeEqTerm in eq0; now eapply convneu_app_ren.
  }
  intros ?????? h.
  pose proof (lrefl h); pose proof (urefl h).
  split. 1: now apply funred.
  unshelve econstructor.
  1,2: now apply funred.
  all: cbn; clear funred.
  * gen_typing.
  * intros. apply ihcod; cbn.
    + eapply neu_app_ren; try eassumption.
      -- now apply wft_prod.
      -- now eapply (ihdom _ ρ).
    + eapply neu_app_ren; try eassumption.
      -- now apply wft_prod.
      -- now eapply (ihdom _ ρ).
    + apply escapeTerm in ha; now eapply ty_app_ren.
    + apply escapeTerm in ha; now eapply ty_app_ren.
    + eapply convneu_app_ren. 1,2: eassumption.
    eapply escapeEqTerm; eapply LREqTermRefl_; eassumption.
- intros a [a' Hr Ha].
  destruct ΠA0 as [dom codom]; simpl in *.
  assert ([Γ |- tProd dom codom ≅ A ]) by gen_typing.
  eapply tm_nf_conv; [| |eassumption].
  * eapply tm_nf_red; [now apply tmr_wf_red|].
    assumption.
  * destruct red; gen_typing.
Qed.

Lemma complete_Nat {l Γ A} (NA : [Γ ||-Nat A]) : complete (LRNat_ l NA).
Proof.
  split.
  - intros ? [].
    eapply ty_nf_red, ty_nf_nat; gen_typing.
  - intros.
    assert [Γ |- A ≅ tNat] by (destruct NA; gen_typing).
    assert [Γ |- n : tNat] by now eapply ty_conv.
    split; econstructor.
    1,4,5: eapply redtmwf_refl; tea; now eapply ty_conv.
    2,4: do 2 constructor; tea.
    1,7: eapply convtm_convneu.
    1,4: eapply lrefl.
    4-6: now (eapply tm_ne_conv; gen_typing).
    all: eapply convneu_conv; tea.
  - simpl in *.
    assert [Γ |- tNat ≅ A] by (destruct NA; gen_typing).
    assert [Γ |- A] by now (destruct NA; gen_typing).
    intros a Ha; eapply tm_nf_conv; [|eassumption|eassumption]; revert a Ha.
    let T := match goal with |- ?P => P end in
    enough (IH : T × (forall (a : term) (n : NatProp NA a), Nf[ Γ |-[ ta ] a : tNat])); [apply IH|].
    apply NatRedInduction.
    + intros.
      eapply tm_nf_red; [now apply tmr_wf_red|eassumption].
    + eapply tm_nf_zero; gen_typing.
    + intros; now eapply tm_nf_succ.
    + intros ne []. apply tm_ne_nf. assumption.
Qed.

Lemma complete_Empty {l Γ A} (NA : [Γ ||-Empty A]) : complete (LREmpty_ l NA).
Proof.
  split.
  - intros ? [].
    eapply ty_nf_red, ty_nf_empty; gen_typing.
  - intros.
    assert [Γ |- A ≅ tEmpty] by (destruct NA; gen_typing).
    assert [Γ |- n : tEmpty] by now eapply ty_conv.
    split; econstructor.
    1,4,5: eapply redtmwf_refl; tea; now eapply ty_conv.
    2,4: do 2 constructor; tea.
    1,7: eapply convtm_convneu.
    1,4: eapply lrefl.
    4-6: now (eapply tm_ne_conv; gen_typing).
    all: eapply convneu_conv; tea.
  - simpl in *.
    assert [Γ |- tEmpty ≅ A] by (destruct NA; gen_typing).
    intros a Ha; eapply tm_nf_conv; [| |eassumption].
    + destruct Ha.
      destruct prop.
      destruct r.
      eapply tm_nf_red. exact red.
      now apply tm_ne_nf.
    + destruct NA as [[]]; gen_typing.
Qed.

Lemma completeness {l Γ A} (RA : [Γ ||-<l> A]) : complete RA.
Proof.
revert l Γ A RA; eapply LR_rect_TyUr; cbn; intros.
- now apply complete_U.
- now apply complete_ne.
- now apply complete_Pi.
- now apply complete_Nat.
- now apply complete_Empty.
Qed.

Lemma neuTerm {l Γ A} (RA : [Γ ||-<l> A]) {n} :
  Ne[Γ |- n : A] ->
  [Γ |- n : A] ->
  [Γ |- n ~ n : A] ->
  [Γ ||-<l> n : A | RA].
Proof.
  intros.  now eapply completeness.
Qed.

Lemma neuTermEq {l Γ A} (RA : [Γ ||-<l> A]) {n n'} :
  Ne[Γ |- n : A] ->
  Ne[Γ |- n' : A] ->
  [Γ |- n : A] ->
  [Γ |- n' : A] ->
  [Γ |- n ~ n' : A] ->
  [Γ ||-<l> n ≅ n' : A| RA].
Proof.
  intros; now eapply completeness.
Qed.

Lemma var0conv {l Γ A A'} (RA : [Γ ,, A ||-<l> A']) :
  [Γ,, A |- A⟨↑⟩ ≅ A'] ->
  [Γ |- A] ->
  [Γ ,, A ||-<l> tRel 0 : A' | RA].
Proof.
  apply complete_var0 ; now eapply completeness.
Qed.

Lemma var0 {l Γ A A'} (RA : [Γ ,, A ||-<l> A']) :
  A⟨↑⟩ = A' ->
  [Γ |- A] ->
  [Γ ,, A ||-<l> tRel 0 : A' | RA].
Proof.
  intros eq.
  apply var0conv.
  rewrite eq.
  unshelve eapply escapeEq; tea.
  eapply LRTyEqRefl_.
Qed.

Lemma reifyTerm {l Γ A} (RA : [Γ ||-<l> A]) {t} : [Γ ||-<l> t : A | RA] -> Nf[Γ |- t : A].
Proof.
intros; now eapply completeness.
Qed.

Lemma reifyType {l Γ A} (RA : [Γ ||-<l> A]) : Nf[Γ |- A].
Proof.
  unshelve eapply reifyTyConv; tea.
  1: now eapply completeness.
  apply LRTyEqRefl_.
Qed.

End Neutral.


Require Import SpecDeps.
Require Import RData.
Require Import EventReplay.
Require Import MoverTypes.
Require Import Constants.
Require Import CommonLib.
Require Import TableDataOpsIntro.Spec.
Require Import TableDataOpsRef2.Spec.

Local Open Scope Z_scope.

Section SpecLow.

  Definition table_create3_spec0 (g_rd: Pointer) (map_addr: Z64) (level: Z64) (g_rtt: Pointer) (rtt_addr: Z64) (adt: RData) : option (RData * Z64) :=
    match g_rd, map_addr, level, g_rtt, rtt_addr with
    | (_g_rd_base, _g_rd_ofst), VZ64 _map_addr, VZ64 _level, (_g_rtt_base, _g_rtt_ofst), VZ64 _rtt_addr =>
      rely is_int64 _map_addr;
      rely is_int64 _level;
      rely is_int64 _rtt_addr;
      when' _t'1, adt == table_create2_spec (_g_rd_base, _g_rd_ofst) (VZ64 _map_addr) (VZ64 _level) (_g_rtt_base, _g_rtt_ofst) (VZ64 _rtt_addr) adt;
      rely is_int64 _t'1;
      Some (adt, (VZ64 _t'1))
     end
    .

End SpecLow.


Require Import Lia.
Require Import Classical Peano_dec.
From hahn Require Import Hahn.
Require Import AuxDef.
Require Import Events.

Set Implicit Arguments.

(** Definition of an execution *)
Record execution :=
  { acts_set : actid -> Prop ;
    threads_set : thread_id -> Prop;
    lab : actid -> label;
    rmw : actid -> actid -> Prop ;
    data : actid -> actid -> Prop ;   (** data dependency *)
    addr : actid -> actid -> Prop ;   (** address dependency *)
    ctrl : actid -> actid -> Prop ;   (** control dependency *)

    (** Representation of a data dependency to CAS.
        It goes from a read to an exclusive read.
        Consider the example:

        a := [x];
        CAS(y, a, 1);

        In the execution, there is an rmw_dep edge between a read event representing `a := [x]'
        and a read event representing `CAS(y, a, 1)'.
     *)
    rmw_dep : actid -> actid -> Prop ;

    rf : actid -> actid -> Prop ;
    co : actid -> actid -> Prop ;
  }.

Section Execution.

Variable G : execution.

Notation "'Tid_' t" := (fun x => tid x = t) (at level 1).
Notation "'NTid_' t" := (fun x => tid x <> t) (at level 1).

Notation "'E'" := (acts_set G).
Notation "'threads_set'" := (threads_set G).
Notation "'lab'" := (lab G).
Notation "'rf'" := (rf G).
Notation "'co'" := (co G).
Notation "'rmw'" := (rmw G).
Notation "'data'" := (data G).
Notation "'addr'" := (addr G).
Notation "'ctrl'" := (ctrl G).
Notation "'rmw_dep'" := (rmw_dep G).

Notation "'loc'" := (loc lab).
Notation "'val'" := (val lab).
Notation "'mod'" := (Events.mod lab).
Notation "'same_loc'" := (same_loc lab).

Notation "'R'" := (fun a => is_true (is_r lab a)).
Notation "'W'" := (fun a => is_true (is_w lab a)).
Notation "'F'" := (fun a => is_true (is_f lab a)).
Notation "'RW'" := (R ∪₁ W).
Notation "'FR'" := (F ∪₁ R).
Notation "'FW'" := (F ∪₁ W).
Notation "'R_ex'" := (fun a => is_true (R_ex lab a)).

Notation "'Pln'" := (is_only_pln lab).
Notation "'Rlx'" := (is_rlx lab).
Notation "'Rel'" := (is_rel lab).
Notation "'Acq'" := (is_acq lab).
Notation "'Acqrel'" := (is_acqrel lab).
Notation "'Acq/Rel'" := (is_ra lab).
Notation "'Sc'" := (is_sc lab).

Definition sb := ⦗E⦘ ⨾ ext_sb ⨾  ⦗E⦘.

Record Wf :=
  { wf_index : forall a b,
      E a /\ E b /\ a <> b /\ tid a = tid b /\ ~ is_init a -> index a <> index b ;
    data_in_sb : data ⊆ sb ;
    wf_dataD : data ≡ ⦗R⦘ ⨾ data ⨾ ⦗W⦘ ;
    addr_in_sb : addr ⊆ sb ;
    wf_addrD : addr ≡ ⦗R⦘ ⨾ addr ⨾ ⦗RW⦘ ;
    ctrl_in_sb : ctrl ⊆ sb ;
    wf_ctrlD : ctrl ≡ ⦗R⦘ ⨾ ctrl ;
    ctrl_sb : ctrl ⨾ sb ⊆ ctrl ;
    wf_rmwD : rmw ≡ ⦗R⦘ ⨾ rmw ⨾ ⦗W⦘ ;
    wf_rmwl : rmw ⊆ same_loc ;
    wf_rmwi : rmw ⊆ immediate sb ;
    wf_rfE : rf ≡ ⦗E⦘ ⨾ rf ⨾ ⦗E⦘ ;
    wf_rfD : rf ≡ ⦗W⦘ ⨾ rf ⨾ ⦗R⦘ ;
    wf_rfl : rf ⊆ same_loc ;
    wf_rfv : funeq val rf ;
    wf_rff : functional rf⁻¹ ;
    wf_coE : co ≡ ⦗E⦘ ⨾ co ⨾ ⦗E⦘ ;
    wf_coD : co ≡ ⦗W⦘ ⨾ co ⨾ ⦗W⦘ ;
    wf_col : co ⊆ same_loc ;
    co_trans : transitive co ;
    wf_co_total : forall ol, is_total (E ∩₁ W ∩₁ (fun x => loc x = ol)) co ;
    co_irr : irreflexive co ;
    wf_init : forall l, (exists b, E b /\ loc b = Some l) -> E (InitEvent l) ;
    wf_init_lab : forall l, lab (InitEvent l) = Astore Xpln Opln l 0 ;

    rmw_dep_in_sb : rmw_dep ⊆ sb ;
    wf_rmw_depD : rmw_dep ≡ ⦗R⦘ ⨾ rmw_dep ⨾ ⦗R_ex⦘ ;
(*     failed_rmw_fail : rmw_dep ⨾ rmw ⊆ ∅₂ ; *)

    wf_threads : forall e (EE : E e), threads_set (tid e);
  }.
(*   ⟪  wf_rmw_deps : rmw ⊆ data ∪ addr ∪ ctrl ⟫ /\
  ⟪  wf_rmw_ctrl : rmw ⨾ sb ⊆ ctrl ⟫. *)

Implicit Type WF : Wf.

(******************************************************************************)
(** ** Derived relations  *)
(******************************************************************************)

(* reads-before, aka from-read *)
Definition fr := rf⁻¹ ⨾ co.

Definition deps := data ∪ addr ∪ ctrl.

(******************************************************************************)
(** ** Consistency definitions  *)
(******************************************************************************)

Definition complete := E ∩₁ R  ⊆₁ codom_rel rf.
Definition rmw_atomicity := rmw ∩ ((fr \ sb) ⨾ (co \ sb)) ⊆ ∅₂.

(******************************************************************************)
(** ** Basic transitivity properties *)
(******************************************************************************)

Lemma sb_trans : transitive sb.
Proof using.
unfold sb; unfolder; ins; desf; splits; auto.
eby eapply ext_sb_trans.
Qed.

Lemma sb_sb : sb ⨾ sb ⊆ sb.
Proof using.
generalize sb_trans; basic_solver 21.
Qed.

Lemma sb_same_loc_trans: transitive (sb ∩ same_loc).
Proof using.
apply transitiveI.
unfold Events.same_loc.
unfolder; ins; desf; eauto.
splits.
generalize sb_trans; basic_solver 21.
congruence.
Qed.

Lemma sb_same_loc_W_trans : transitive (sb ∩ same_loc ⨾ ⦗W⦘).
Proof using.
  generalize sb_same_loc_trans; unfold transitive.
  basic_solver 21.
Qed.

(******************************************************************************)
(** ** Basic properties *)
(******************************************************************************)

Lemma E_in_RW_F_AcqRel (FACQREL : E ∩₁ F ⊆₁ Acq/Rel) :
  E ⊆₁ R ∪₁ W ∪₁ F ∩₁  Acq/Rel.
Proof using.
  arewrite (E ⊆₁ E ∩₁ E).
  arewrite (E ⊆₁ R ∪₁ W ∪₁ F) at 2 by type_solver.
  rewrite set_inter_union_r.
  generalize FACQREL. clear. basic_solver 10.
Qed.

Lemma sb_neq_loc_in_sb : sb \ same_loc ⊆ sb.
Proof using. basic_solver. Qed.

Lemma fr_co WF : fr ⨾ co ⊆ fr.
Proof using. by unfold fr; rewrite seqA, rewrite_trans; [|apply WF]. Qed.

Lemma rmw_in_sb WF: rmw ⊆ sb.
Proof using. rewrite wf_rmwi; basic_solver. Qed.

Lemma deps_in_sb WF: deps ⊆ sb.
Proof using. unfold deps; unionL; apply WF. Qed.

(******************************************************************************)
(** ** Same Location relations  *)
(******************************************************************************)

Lemma loceq_rf WF : funeq loc rf.
Proof using. apply WF. Qed.

Lemma loceq_co WF : funeq loc co.
Proof using. apply WF. Qed.

Lemma loceq_rmw WF : funeq loc rmw.
Proof using. apply WF. Qed.

Lemma loceq_fr WF : funeq loc fr.
Proof using.
unfold funeq.
unfold fr; unfolder; ins; desf.
generalize (loceq_co WF), (loceq_rf WF).
transitivity (loc z); [symmetry; eauto|eauto].
Qed.

Lemma wf_frl WF : fr ⊆ same_loc.
Proof using.
unfold fr.
rewrite (wf_rfl WF), (wf_col WF).
unfold Events.same_loc.
unfolder; ins; desc; congruence.
Qed.

(******************************************************************************)
(** ** Relations in graph *)
(******************************************************************************)

Lemma wf_sbE : sb ≡ ⦗E⦘ ⨾ sb ⨾ ⦗E⦘.
Proof using.
split; [|basic_solver].
unfold sb; basic_solver 42.
Qed.

Lemma wf_dataE WF: data ≡ ⦗E⦘ ⨾ data ⨾ ⦗E⦘.
Proof using.
split; [|basic_solver].
arewrite (data ⊆ data ∩ data) at 1.
rewrite (data_in_sb WF) at 1.
rewrite wf_sbE at 1.
basic_solver.
Qed.

Lemma wf_addrE WF: addr ≡ ⦗E⦘ ⨾ addr ⨾ ⦗E⦘.
Proof using.
split; [|basic_solver].
arewrite (addr ⊆ addr ∩ addr) at 1.
rewrite (addr_in_sb WF) at 1.
rewrite wf_sbE at 1.
basic_solver.
Qed.

Lemma wf_ctrlE WF: ctrl ≡ ⦗E⦘ ⨾ ctrl ⨾ ⦗E⦘.
Proof using.
split; [|basic_solver].
arewrite (ctrl ⊆ ctrl ∩ ctrl) at 1.
rewrite (ctrl_in_sb WF) at 1.
rewrite wf_sbE at 1.
basic_solver.
Qed.

Lemma wf_rmw_depE WF: rmw_dep ≡ ⦗E⦘ ⨾ rmw_dep ⨾ ⦗E⦘.
Proof using.
split; [|basic_solver].
arewrite (rmw_dep ⊆ rmw_dep ∩ rmw_dep) at 1.
rewrite (rmw_dep_in_sb WF) at 1.
rewrite wf_sbE at 1.
basic_solver.
Qed.

Lemma wf_depsE WF: deps ≡ ⦗E⦘ ⨾ deps ⨾ ⦗E⦘.
Proof using.
split; [|basic_solver].
unfold deps.
rewrite (wf_dataE WF) at 1.
rewrite (wf_ctrlE WF) at 1.
rewrite (wf_addrE WF) at 1.
basic_solver.
Qed.

Lemma wf_rmwE WF : rmw ≡ ⦗E⦘ ⨾ rmw ⨾ ⦗E⦘.
Proof using.
split; [|basic_solver].
arewrite (rmw ⊆ rmw ∩ rmw) at 1.
rewrite (wf_rmwi WF) at 1.
arewrite (immediate sb ⊆ sb).
rewrite wf_sbE.
basic_solver.
Qed.

Lemma wf_frE WF : fr ≡ ⦗E⦘ ⨾ fr ⨾ ⦗E⦘.
Proof using.
split; [|basic_solver].
unfold fr.
rewrite (wf_rfE WF) at 1.
rewrite (wf_coE WF) at 1.
basic_solver.
Qed.

(******************************************************************************)
(** ** Domains and codomains  *)
(******************************************************************************)

Lemma wf_frD WF : fr ≡ ⦗R⦘ ⨾ fr ⨾ ⦗W⦘.
Proof using.
split; [|basic_solver].
unfold fr.
rewrite (wf_rfD WF) at 1.
rewrite (wf_coD WF) at 1.
basic_solver.
Qed.

Lemma wf_depsD WF : deps ≡ ⦗R⦘ ⨾ deps.
Proof using.
split; [|basic_solver].
unfold deps.
rewrite (wf_dataD WF) at 1.
rewrite (wf_ctrlD WF) at 1.
rewrite (wf_addrD WF) at 1.
basic_solver.
Qed.

(******************************************************************************)
(** ** Irreflexive relations *)
(******************************************************************************)

Lemma sb_irr : irreflexive sb.
Proof using.
unfold sb; unfolder; ins; desf.
eby eapply ext_sb_irr.
Qed.

Lemma fr_irr WF : irreflexive fr.
Proof using.
rewrite (wf_frD WF); type_solver.
Qed.

(******************************************************************************)
(** ** Acyclic relations *)
(******************************************************************************)

Lemma sb_acyclic : acyclic sb.
Proof using.
apply trans_irr_acyclic; [apply sb_irr| apply sb_trans].
Qed.

Lemma co_acyclic WF: acyclic co.
Proof using.
by apply trans_irr_acyclic; [apply co_irr| apply co_trans].
Qed.

Lemma wf_sb : well_founded sb.
Proof using.
  unfold Execution.sb.
  rewrite <- restr_relE. eapply wf_mon; [by apply inclusion_restr| ].
  apply Wf_nat.well_founded_lt_compat
    with (f := fun (e: actid) => if e then 0 else index e + 1).
  intros x y SB. destruct x, y; simpl in *; lia.
Qed.

(******************************************************************************)
(** ** init *)
(******************************************************************************)

Lemma init_w WF: is_init ⊆₁ W.
Proof using.
unfolder; ins.
unfold is_init in *; destruct x; desf.
specialize (wf_init_lab WF l); unfold is_w; desf.
Qed.

Lemma init_pln WF: is_init ⊆₁ Pln.
Proof using.
unfolder; ins.
unfold is_init in *; destruct x; desf.
specialize (wf_init_lab WF l); unfold is_only_pln, Events.mod; desf.
Qed.

Lemma read_or_fence_is_not_init WF a (A: R a \/ F a) : ~ is_init a.
Proof using.
generalize ((init_w WF) a).
type_solver.
Qed.

Lemma no_sb_to_init : sb ≡ sb ⨾  ⦗fun x => ~ is_init x⦘.
Proof using.
split; [|basic_solver].
unfold sb; rewrite ext_sb_to_non_init at 1; basic_solver.
Qed.

Lemma no_sb_cr_to_init :
  ⦗set_compl is_init⦘ ⨾ sb^? ⊆ ⦗set_compl is_init⦘ ⨾ sb^? ⨾ ⦗set_compl is_init⦘.
Proof using. rewrite no_sb_to_init at 1. clear. basic_solver. Qed.

Lemma no_rf_to_init WF : rf ≡ rf ⨾  ⦗fun x => ~ is_init x⦘.
Proof using.
split; [|basic_solver].
rewrite (wf_rfD WF) at 1.
generalize (read_or_fence_is_not_init WF).
basic_solver 42.
Qed.

Lemma rmw_from_non_init WF : rmw ≡ ⦗fun x => ~ is_init x⦘ ⨾ rmw.
Proof using.
split; [|basic_solver].
rewrite (wf_rmwD WF).
generalize (read_or_fence_is_not_init WF).
basic_solver 42.
Qed.

Lemma rmw_non_init_lr WF : rmw ≡ ⦗set_compl is_init⦘ ⨾ rmw ⨾ ⦗set_compl is_init⦘.
Proof using.
  split; [|basic_solver].
  rewrite (rmw_from_non_init WF) at 1.
  rewrite <- seqA.
  apply codom_rel_helper.
  rewrite (rmw_in_sb WF).
  rewrite no_sb_to_init.
  basic_solver.
Qed.

Lemma init_same_loc WF a b (A: is_init a) (B: is_init b) (LOC: loc a = loc b):
  a = b.
Proof using.
destruct a, b; desf.
cut (l = l0); [by ins; subst|].
unfold Events.loc in LOC.
rewrite (wf_init_lab WF l), (wf_init_lab WF l0) in LOC; desf.
Qed.

Lemma Rel_not_init WF : Rel ⊆₁ set_compl is_init.
Proof using. rewrite (init_pln WF). mode_solver. Qed.

(******************************************************************************)
(** ** More properties *)
(******************************************************************************)

Lemma sb_semi_total_l x y z
  WF (N: ~ is_init x) (NEQ: y <> z) (XY: sb x y) (XZ: sb x z):
  sb y z \/ sb z y.
Proof using.
unfold sb in *; unfolder in *; desf.
cut (ext_sb y z \/ ext_sb z y); [basic_solver 12|].
eapply ext_sb_semi_total_l; eauto.
eapply WF; splits; eauto.
by unfold ext_sb in *; destruct y,z; ins; desf; desf.
by unfold ext_sb in *; destruct y,z; ins; desf; desf.
Qed.

Lemma sb_semi_total_r x y z
  WF (N: ~ is_init z) (NEQ: y <> z) (XY: sb y x) (XZ: sb z x):
  sb y z \/ sb z y.
Proof using.
cut ((sb ∪ sb⁻¹) y z); [basic_solver|].
unfold sb in *; unfolder in *; desf.
destruct (classic (is_init y)).
unfold ext_sb; basic_solver.
cut (ext_sb y z \/ ext_sb z y); [basic_solver|].
eapply ext_sb_semi_total_r; eauto.
eapply WF; splits; eauto.
unfold ext_sb in *; destruct y,z; ins; desf; desf.
Qed.

Lemma sb_tid_init x y (SB : sb x y): tid x = tid y \/ is_init x.
Proof using.
generalize ext_sb_tid_init; unfold sb in *.
unfolder in *; basic_solver.
Qed.

Lemma E_ntid_sb_prcl thread :
  dom_rel (⦗set_compl is_init⦘ ⨾ sb ⨾ ⦗E ∩₁ NTid_ thread⦘) ⊆₁ E ∩₁ NTid_ thread.
Proof using.
  rewrite (dom_l wf_sbE).
  unfolder. ins. desf. splits; auto.
  match goal with
  | H : sb _ _ |- _ => rename H into SB
  end.
  apply sb_tid_init in SB. desf.
  intros BB. rewrite BB in *. desf.
Qed.

Lemma sb_tid_init': sb ≡ sb ∩ same_tid ∪ ⦗is_init⦘ ⨾ sb.
Proof using.
split; [|basic_solver].
unfold sb.
rewrite ext_sb_tid_init' at 1.
basic_solver 42.
Qed.

Lemma ninit_sb_same_tid : ⦗ set_compl is_init ⦘ ⨾ sb ⊆ same_tid.
Proof using.
  rewrite sb_tid_init'.
  basic_solver.
Qed.

Lemma same_tid_trans : transitive same_tid.
Proof using.
  red. unfold same_tid. ins.
  etransitivity; eauto.
Qed.

Lemma tid_sb: ⦗E⦘ ⨾ same_tid ⨾  ⦗E⦘ ⊆ sb^? ∪ sb^{-1} ∪ (is_init × is_init).
Proof using.
unfold sb.
rewrite tid_ext_sb.
basic_solver 21.
Qed.

Lemma tid_n_init_sb: ⦗E⦘ ⨾ same_tid ⨾ ⦗set_compl is_init⦘  ⨾  ⦗E⦘ ⊆ sb^? ∪ sb^{-1}.
Proof using.
unfold sb.
sin_rewrite tid_n_init_ext_sb.
basic_solver 21.
Qed.

Lemma init_ninit_sb (WF : Wf) x y (INIT : is_init x) (ININE : E x) (INE : E y)
      (NINIT : ~ is_init y): sb x y.
Proof using.
unfold sb, ext_sb; basic_solver.
Qed.

Lemma same_thread x y (X : E x) (Y : E y)
      (NINIT : ~ is_init x) (ST : tid x = tid y):
  sb^? x y \/ sb y x.
Proof using.
cut (sb^? y x \/ sb x y); [basic_solver|].
generalize tid_n_init_sb.
unfold same_tid; basic_solver 10.
Qed.

Lemma sb_immediate_adjacent WF:
 ⦗fun a => ~ is_init a⦘ ⨾ immediate sb ≡ ⦗fun a => ~ is_init a⦘ ⨾ (adjacent sb ∩ sb).
Proof using.
apply immediate_adjacent.
- unfolder; ins; desf; destruct (classic (x=y)); auto.
  forward (apply (@sb_semi_total_r z y x)); eauto; tauto.
- unfolder; ins; desf; destruct (classic (x=y)); auto.
  forward (apply (@sb_semi_total_l z y x)); eauto; tauto.
- apply sb_trans.
- apply sb_irr.
Qed.

Lemma sb_total t:
  is_total ((E \₁ is_init) ∩₁ Tid_ t) sb.
Proof using.
  red. ins. unfolder in IWa. unfolder in IWb. desc. subst.
  destruct a, b; try by vauto. simpl in *. subst.
  pose proof (NPeano.Nat.lt_trichotomy index index0) as LT.
  des; [left | congruence | right].
  all: red; apply seq_eqv_lr; splits; vauto.
Qed.

Lemma sb_transp_rmw  WF : sb ⨾ rmw ^{-1} ⊆ sb^?.
Proof using.
rewrite (rmw_from_non_init WF).
rewrite (wf_rmwi WF); clear -WF.
rewrite (sb_immediate_adjacent WF).
unfold adjacent; basic_solver.
Qed.

Lemma transp_rmw_sb  WF :  rmw ^{-1} ⨾ sb ⊆ sb^?.
Proof using.
rewrite (rmw_from_non_init WF).
rewrite (wf_rmwi WF); clear -WF.
rewrite (sb_immediate_adjacent WF).
unfold adjacent; basic_solver.
Qed.

Lemma rf_rf WF : rf ⨾ rf ≡ ∅₂.
Proof using. rewrite (wf_rfD WF); type_solver. Qed.
Lemma rf_co WF : rf ⨾ co ≡ ∅₂.
Proof using. rewrite (wf_rfD WF), (wf_coD WF); type_solver. Qed.
Lemma co_transp_rf WF : co ⨾  rf⁻¹ ≡ ∅₂.
Proof using. rewrite (wf_rfD WF), (wf_coD WF); type_solver. Qed.
Lemma co_fr WF : co ⨾ fr ≡ ∅₂.
Proof using. rewrite (wf_coD WF), (wf_frD WF); type_solver. Qed.
Lemma fr_fr WF : fr ⨾ fr ≡ ∅₂.
Proof using. rewrite (wf_frD WF); type_solver. Qed.
Lemma rf_transp_rf WF: rf ⨾ rf⁻¹ ⊆ ⦗fun _ => True⦘.
Proof using. by apply functional_alt, WF. Qed.
Lemma rf_fr WF : rf ⨾ fr ⊆ co.
Proof using. unfold fr; sin_rewrite rf_transp_rf; rels. Qed.
Lemma rmw_in_sb_loc WF: rmw ⊆ sb ∩ same_loc.
Proof using. by rewrite (loceq_same_loc (loceq_rmw WF)), (rmw_in_sb WF). Qed.
Lemma rf_irr WF: irreflexive rf.
Proof using. rewrite (wf_rfD WF); type_solver. Qed.
Lemma co_co WF: co ⨾ co ⊆ co.
Proof using. apply rewrite_trans, WF. Qed.

(*
Lemma rmw_sb_ct WF: (rmw ⨾ sb)⁺ ⊆ rmw ⨾ sb.
Proof using.
rewrite ct_begin.
hahn_frame. rewrite (rmw_in_sb WF).
generalize sb_trans; ins; relsf.
Qed.

Lemma rmw_sb_rt WF: (rmw ⨾ sb)＊ ⊆ (rmw ⨾ sb)^?.
Proof using.
rewrite rtE, (rmw_sb_ct WF); basic_solver.
Qed.

Lemma rmw_sb_trans WF: transitive (rmw ⨾ sb).
Proof using.
apply transitiveI.
arewrite (rmw ⨾ sb ⊆ (rmw ⨾ sb)＊) at 2.
rewrite <- seqA; rewrite <- ct_begin.
by rewrite (rmw_sb_ct WF).
Qed.
*)

Lemma wf_rmwt WF: rmw ⊆ same_tid.
Proof using.
rewrite (rmw_from_non_init WF).
rewrite (rmw_in_sb WF), sb_tid_init'.
basic_solver.
Qed.

Lemma wf_rmwf WF: functional rmw.
Proof using.
rewrite (rmw_from_non_init WF).
rewrite (wf_rmwi WF).
rewrite (sb_immediate_adjacent WF).
unfolder; ins; desc.
eapply adjacent_unique1; eauto.
apply sb_acyclic.
Qed.

Lemma wf_rmw_invf WF: functional (rmw)⁻¹.
Proof using.
rewrite (rmw_from_non_init WF).
rewrite (wf_rmwi WF).
rewrite (sb_immediate_adjacent WF).
unfolder; ins; desc.
eapply adjacent_unique2; eauto.
apply sb_acyclic.
Qed.

(******************************************************************************)
(** ** external-internal restrictions *)
(******************************************************************************)

Definition rfe := rf \ sb.
Definition coe := co \ sb.
Definition fre := fr \ sb.
Definition rfi := rf ∩ sb.
Definition coi := co ∩ sb.
Definition fri := fr ∩ sb.

Lemma ri_union_re r : r ≡ r ∩ sb ∪ r \ sb.
Proof using. unfolder; split; ins; desf; tauto. Qed.

Lemma rfi_union_rfe : rf ≡ rfi ∪ rfe.
Proof using. apply ri_union_re. Qed.
Lemma coi_union_coe : co ≡ coi ∪ coe.
Proof using. apply ri_union_re. Qed.
Lemma fri_union_fre : fr ≡ fri ∪ fre.
Proof using. apply ri_union_re. Qed.

Lemma ri_dom r d1 d2 (DOM: r ≡ ⦗d1⦘ ⨾ r ⨾ ⦗d2⦘) : r ∩ sb ⊆ ⦗d1⦘ ⨾ r ∩ sb ⨾ ⦗d2⦘.
Proof using. rewrite DOM at 1; basic_solver. Qed.
Lemma re_dom r d1 d2 (DOM: r ≡ ⦗d1⦘ ⨾ r ⨾ ⦗d2⦘) : r \ sb ⊆ ⦗d1⦘ ⨾ (r \ sb) ⨾ ⦗d2⦘.
Proof using. rewrite DOM at 1; basic_solver. Qed.

Lemma wf_rfiE WF: rfi ≡ ⦗E⦘ ⨾ rfi ⨾ ⦗E⦘.
Proof using. split; [|basic_solver]. apply (ri_dom (wf_rfE WF)). Qed.
Lemma wf_coiE WF: coi ≡ ⦗E⦘ ⨾ coi ⨾ ⦗E⦘.
Proof using. split; [|basic_solver]. apply (ri_dom (wf_coE WF)). Qed.
Lemma wf_friE WF: fri ≡ ⦗E⦘ ⨾ fri ⨾ ⦗E⦘.
Proof using. split; [|basic_solver]. apply (ri_dom (wf_frE WF)). Qed.
Lemma wf_rfeE WF: rfe ≡ ⦗E⦘ ⨾ rfe ⨾ ⦗E⦘.
Proof using. split; [|basic_solver]. apply (re_dom (wf_rfE WF)). Qed.
Lemma wf_coeE WF: coe ≡ ⦗E⦘ ⨾ coe ⨾ ⦗E⦘.
Proof using. split; [|basic_solver]. apply (re_dom (wf_coE WF)). Qed.
Lemma wf_freE WF: fre ≡ ⦗E⦘ ⨾ fre ⨾ ⦗E⦘.
Proof using. split; [|basic_solver]. apply (re_dom (wf_frE WF)). Qed.
Lemma wf_rfiD WF : rfi ≡ ⦗W⦘ ⨾ rfi ⨾ ⦗R⦘.
Proof using. split; [|basic_solver]. apply (ri_dom (wf_rfD WF)). Qed.
Lemma wf_coiD WF : coi ≡ ⦗W⦘ ⨾ coi ⨾ ⦗W⦘.
Proof using. split; [|basic_solver]. apply (ri_dom (wf_coD WF)). Qed.
Lemma wf_friD WF : fri ≡ ⦗R⦘ ⨾ fri ⨾ ⦗W⦘.
Proof using. split; [|basic_solver]. apply (ri_dom (wf_frD WF)). Qed.
Lemma wf_rfeD WF : rfe ≡ ⦗W⦘ ⨾ rfe ⨾ ⦗R⦘.
Proof using. split; [|basic_solver]. apply (re_dom (wf_rfD WF)). Qed.
Lemma wf_coeD WF : coe ≡ ⦗W⦘ ⨾ coe ⨾ ⦗W⦘.
Proof using. split; [|basic_solver]. apply (re_dom (wf_coD WF)). Qed.
Lemma wf_freD WF : fre ≡ ⦗R⦘ ⨾ fre ⨾ ⦗W⦘.
Proof using. split; [|basic_solver]. apply (re_dom (wf_frD WF)). Qed.

Lemma rfi_in_sb : rfi ⊆ sb.
Proof using. unfold rfi; basic_solver. Qed.

Lemma rfi_in_rf : rfi ⊆ rf.
Proof using. unfold rfi; basic_solver. Qed.

Lemma rfe_in_rf : rfe ⊆ rf.
Proof using. unfold rfe; basic_solver. Qed.

Lemma coi_in_sb : coi ⊆ sb.
Proof using. unfold coi; basic_solver. Qed.

Lemma coi_in_co : coi ⊆ co.
Proof using. unfold coi; basic_solver. Qed.

Lemma coe_in_co : coe ⊆ co.
Proof using. unfold coe; basic_solver. Qed.

Lemma ninit_rfi_same_tid : ⦗ set_compl is_init ⦘ ⨾ rfi ⊆ same_tid.
Proof using.
  arewrite (rfi ⊆ sb).
  apply ninit_sb_same_tid.
Qed.

Lemma coi_trans WF : transitive coi.
Proof using.
  apply transitiveI.
  generalize sb_trans (co_trans WF). intros SB CO.
  unfold coi.
  unfolder. ins. desf.
  split; [eapply CO|eapply SB]; eauto.
Qed.

Lemma fri_in_sb : fri ⊆ sb.
Proof using. unfold fri; basic_solver. Qed.

Lemma fri_in_fr : fri ⊆ fr.
Proof using. unfold fri; basic_solver. Qed.

Lemma fre_in_fr : fre ⊆ fr.
Proof using. unfold fre; basic_solver. Qed.

Lemma fri_coi WF : fri ⨾ coi ⊆ fri.
Proof using.
  unfold fri, coi.
  unfolder. ins. desf.
  split.
  { apply fr_co; auto. basic_solver. }
  eapply sb_trans; eauto.
Qed.

Lemma codom_rfi_rfe_empty WF : codom_rel rfi ∩₁ codom_rel rfe ⊆₁ ∅.
Proof using.
  unfold rfi, rfe.
  unfolder. ins. desf.
  assert (x0 = x1); subst; eauto.
  eapply (wf_rff WF); eauto.
Qed.

(******************************************************************************)
(** ** properties of external/internal relations *)
(******************************************************************************)

Lemma seq_ii r1 r2 r3 (A: r1 ⨾ r2 ⊆ r3): r1 ∩ sb ⨾ r2 ∩ sb ⊆ r3 ∩ sb.
Proof using.
generalize sb_trans.
unfolder in *; basic_solver 21.
Qed.

Lemma re_ri WF  r r' (IRR: irreflexive r)  (IRR2: irreflexive (r ⨾ sb))
  (N: r ⊆ r ⨾  ⦗ fun x => ~ is_init x ⦘): (r \ sb) ⨾ (r' ∩ sb) ⊆ r ⨾  r' \ sb.
Proof using.
rewrite N at 1.
unfolder; ins; desf; splits; eauto.
intro.
eapply sb_semi_total_r with (x:=y) (y:=x) in H1; eauto.
by desf; revert IRR2; basic_solver.
eby intro; subst; eapply IRR.
Qed.

Lemma ri_re WF  r r' (IRR: irreflexive r')  (IRR2: irreflexive (r' ⨾ sb)):
 ⦗ fun x => ~ is_init x ⦘ ⨾ (r ∩ sb) ⨾ (r' \ sb) ⊆ r ⨾  r' \ sb.
Proof using.
unfolder; ins; desf; splits; eauto.
intro.
eapply sb_semi_total_l with (x:=x) (y:=z) (z:=y) in H4; eauto.
by desf; revert IRR2; basic_solver.
eby intro; subst; eapply IRR.
Qed.

Lemma rfi_in_sbloc WF : rf ∩ sb ⊆ restr_eq_rel loc sb.
Proof using. rewrite wf_rfl; basic_solver 12. Qed.
Lemma coi_in_sbloc WF : co ∩ sb ⊆ restr_eq_rel loc sb.
Proof using. rewrite wf_col; basic_solver 12. Qed.
Lemma fri_in_sbloc WF : fr ∩ sb ⊆ restr_eq_rel loc sb.
Proof using. rewrite (loceq_same_loc (loceq_fr WF)).
unfolder; unfold Events.same_loc in *.
ins; desf; splits; eauto; congruence.
Qed.
Lemma rfi_in_sbloc' WF : rfi ⊆ sb ∩ same_loc.
Proof using. generalize (wf_rfl WF); unfold rfi; basic_solver 12. Qed.
Lemma coi_in_sbloc' WF : coi ⊆ sb ∩ same_loc.
Proof using. generalize (wf_col WF); unfold coi; basic_solver 12. Qed.
Lemma fri_in_sbloc' WF : fri ⊆ sb ∩ same_loc.
Proof using. generalize (wf_frl WF); unfold fri; basic_solver 12. Qed.

Lemma rf_rmw_sb_minus_sb WF: (rf ⨾ rmw ⨾ sb^? ⨾ ⦗W⦘) \ sb ⊆ rfe ⨾ rmw ⨾ sb^? ⨾ ⦗W⦘.
Proof using.
rewrite (seq_minus_transitive sb_trans).
unionL; [by unfold rfe; basic_solver 12|].
rewrite (rmw_in_sb WF) at 1.
arewrite (sb ⨾ sb^? ⨾ ⦗W⦘ ⊆ sb) by generalize sb_trans; basic_solver 21.
relsf.
Qed.

Lemma rf_rmw_sb_rt_rf WF: ((rf ⨾ rmw ⨾ sb^? ⨾ ⦗W⦘)＊ ⨾ rf) \ sb ⊆ sb^? ⨾ rfe ⨾ (rmw ⨾ sb^? ⨾ ⦗W⦘ ⨾ rf)＊.
Proof using.
rewrite rtE; relsf.
rewrite rtE, minus_union_l.
relsf; unionL; [by unfold rfe; basic_solver 12|].
rewrite (seq_minus_transitive sb_trans).
unionL; [|by unfold rfe; basic_solver 12].
unionR right.
rewrite (ct_minus_transitive sb_trans).
arewrite ((rf ⨾ rmw ⨾ sb^? ⨾ ⦗W⦘) ∩ sb ⊆ sb).
generalize sb_trans; ins; relsf.
rewrite (rf_rmw_sb_minus_sb WF).
rewrite !seqA.
arewrite (rmw ⨾ sb^? ⨾ ⦗W⦘ ⨾ (rf ⨾ rmw ⨾ sb^? ⨾ ⦗W⦘)＊ ⨾ rf ⊆ (rmw ⨾ sb^? ⨾ ⦗W⦘ ⨾ rf )⁺); [|done].
rewrite rtE; relsf; unionL; [by econs|].
rewrite ct_seq_swap, !seqA.
rewrite ct_begin at 2.
by rewrite inclusion_t_rt, !seqA.
Qed.

Lemma rmw_rf_ct WF : (rmw ⨾ sb^? ⨾ ⦗W⦘ ⨾ rf)⁺ ⊆ (rmw ⨾ sb^? ⨾ ⦗W⦘ ∪ rfe)⁺ ⨾ rf.
Proof using.
  apply inclusion_t_ind_left.
  { hahn_frame; vauto. }
  rewrite ct_begin; hahn_frame; relsf.
  arewrite (rfe ⊆ rf) at 2.
  seq_rewrite (rf_rf WF).
  relsf.
  rewrite rfi_union_rfe; relsf; unionL.
  { arewrite (rfi ⊆ sb).
    rewrite (rmw_in_sb WF) at 2.
    arewrite (sb^? ⨾ ⦗W⦘ ⨾ sb ⨾ sb ⨾ sb^? ⊆ sb^?).
    generalize sb_trans; basic_solver 21.
    basic_solver 21. }
  rewrite rt_begin at 2.
  rewrite rt_begin at 2.
  basic_solver 42.
Qed.

Lemma rmw_rf_rt_1 WF : (rmw ⨾ sb^? ⨾ ⦗W⦘ ⨾ rf)＊ ⊆ (rmw ⨾ sb^? ⨾ ⦗W⦘ ∪ rfe)＊ ⨾ rfi^?.
Proof using.
rewrite rtE; unionL; [basic_solver 12|].
rewrite (rmw_rf_ct WF).
rewrite rfi_union_rfe; relsf.
rewrite inclusion_t_rt.
relsf; unionL.
basic_solver 12.
rewrite rt_end at 2; basic_solver 12.
Qed.

(******************************************************************************)
(** ** detour *)
(******************************************************************************)

Definition detour := (coe ⨾ rfe) ∩ sb.

Lemma wf_detourE WF: detour ≡ ⦗E⦘ ⨾ detour ⨾ ⦗E⦘.
Proof using.
split; [|basic_solver].
unfold detour.
sin_rewrite (wf_coeE WF).
sin_rewrite (wf_rfeE WF).
basic_solver 42.
Qed.

Lemma wf_detourD WF: detour ≡ ⦗W⦘ ⨾ detour ⨾ ⦗R⦘.
Proof using.
split; [|basic_solver].
unfold detour.
sin_rewrite (wf_coeD WF).
sin_rewrite (wf_rfeD WF).
basic_solver 42.
Qed.

Lemma detour_fr_in_co WF: detour ⨾ fr ⊆ co.
Proof using.
unfold detour, coe, rfe.
generalize (rf_fr WF) (co_trans WF).
basic_solver 42.
Qed.

Lemma detour_transp_rfi WF: detour ⨾ rfi^{-1} ⊆ ∅₂.
Proof using.
unfold detour, rfe, rfi.
unfolder; ins; desf.
assert (y=z0); subst; auto.
eapply WF; basic_solver.
Qed.

Lemma detour_in_sb : detour ⊆ sb.
Proof using. unfold detour; basic_solver. Qed.

Lemma detour_to_codom_rfe WF: detour ⊆ detour ⨾ ⦗ codom_rel rfe ⦘.
Proof using.
unfold detour, rfe, rfi.
unfolder; ins; desf; eauto 20.
Qed.

(******************************************************************************)
(** ** exclusive reads/writes *)
(******************************************************************************)

Definition W_ex := codom_rel rmw.

Lemma W_ex_not_init WF : W_ex ⊆₁ set_compl is_init.
Proof using.
  unfolder. ins. desf.
  match goal with
  | H : W_ex _ |- _ => rename H into WEX
  end.
  destruct WEX as [z WEX].
  apply (rmw_in_sb WF) in WEX.
  apply no_sb_to_init in WEX. unfolder in WEX. desf.
Qed.

Lemma W_ex_in_W WF : W_ex ⊆₁ W.
Proof using.
unfold W_ex; rewrite (dom_r (wf_rmwD WF)); basic_solver.
Qed.

Lemma W_ex_in_E WF : W_ex ⊆₁ E.
Proof using.
  unfold W_ex. rewrite (dom_r (wf_rmwE WF)). basic_solver.
Qed.

Lemma W_ex_eq_EW_W_ex WF : W_ex ≡₁ E ∩₁ W ∩₁ W_ex.
Proof using.
  generalize (W_ex_in_E WF).
  generalize (W_ex_in_W WF).
  clear. basic_solver 10.
Qed.

Notation "'W_ex_acq'" := (W_ex ∩₁ (fun a => is_true (is_xacq lab a))).

Lemma W_ex_acq_in_W WF : W_ex_acq ⊆₁ W.
Proof using.
  rewrite (W_ex_in_W WF); basic_solver.
Qed.

Lemma rmw_W_ex : rmw ⊆ rmw ⨾ ⦗W_ex⦘.
Proof using.
unfold W_ex; basic_solver.
Qed.

Lemma W_ex_acq_not_init WF : W_ex_acq ⊆₁ set_compl is_init.
Proof using.
  unfolder. ins. desf.
  match goal with
  | H : W_ex _ |- _ => rename H into WEX
  end.
  destruct WEX as [z WEX].
  apply (rmw_in_sb WF) in WEX.
  apply no_sb_to_init in WEX. unfolder in WEX. desf.
Qed.

(******************************************************************************)
(** ** rf ⨾ rmw *)
(******************************************************************************)

Lemma wf_rfrmwE WF: rf ⨾ rmw ≡ ⦗ E ⦘ ⨾ (rf ⨾ rmw) ⨾ ⦗ E ⦘.
Proof using.
split; [|basic_solver].
rewrite (wf_rfE WF) at 1.
rewrite (wf_rmwE WF) at 1.
basic_solver.
Qed.

Lemma wf_rfrmwD WF: rf ⨾ rmw ≡ ⦗ W ⦘ ⨾ (rf ⨾ rmw) ⨾ ⦗ W ⦘.
Proof using.
split; [|basic_solver].
rewrite (wf_rfD WF) at 1.
rewrite (wf_rmwD WF) at 1.
basic_solver.
Qed.

Lemma wf_rfrmwl WF: rf ⨾ rmw ⊆ same_loc.
Proof using.
rewrite (wf_rfl WF), (wf_rmwl WF).
generalize same_loc_trans; basic_solver.
Qed.

Lemma wf_rfrmwf WF: functional (rf ⨾ rmw)⁻¹.
Proof using.
hahn_rewrite transp_seq.
by apply functional_seq; [apply wf_rmw_invf|apply WF].
Qed.

Lemma wf_rfirmwf WF : functional (rfi ⨾ rmw)⁻¹.
Proof using. arewrite (rfi ⊆ rf). eapply wf_rfrmwf; eauto. Qed.

Lemma wf_rfermwf WF : functional (rfe ⨾ rmw)⁻¹.
Proof using. arewrite (rfe ⊆ rf). eapply wf_rfrmwf; eauto. Qed.

Lemma rt_rf_rmw : (rf ⨾ rmw)＊ ⊆ (rfi ⨾ rmw)＊ ⨾ (rfe ⨾ rmw ⨾ (rfi ⨾ rmw)＊)＊.
Proof using.
  eapply rt_ind_left with (P:=fun r=> r); eauto with hahn.
  basic_solver 12.
  intros k H.
  rewrite !seqA, H.
  rewrite rfi_union_rfe; relsf; unionL.
  { rewrite rt_begin at 3.
    basic_solver 21. }
  rewrite (rt_begin (rfe ⨾ rmw ⨾ (rfi ⨾ rmw)＊)) at 2.
  basic_solver 21.
Qed.

Lemma ninit_rfi_rmw_same_tid WF : ⦗ set_compl is_init ⦘ ⨾ rfi ⨾ rmw ⊆ same_tid.
Proof using.
  rewrite (wf_rmwt WF).
  sin_rewrite ninit_rfi_same_tid.
  apply transitiveI. apply same_tid_trans.
Qed.

Lemma ninit_rfi_rmw_rt_same_tid WF : ⦗ set_compl is_init ⦘ ⨾ (rfi ⨾ rmw)＊ ⊆ same_tid.
Proof using.
  apply rt_ind_left with (P:= fun r => ⦗set_compl is_init⦘ ⨾ r).
  { by eauto with hahn. }
  { unfold same_tid. basic_solver 12. }
  intros k AA. rewrite !seqA.
  rewrite (dom_r (rmw_non_init_lr WF)). rewrite !seqA.
  rewrite AA.
  sin_rewrite ninit_rfi_rmw_same_tid; auto.
  apply transitiveI. apply same_tid_trans.
Qed.

Lemma sw_in_ar_helper WF:
  ((sb ∩ same_loc)^? ⨾ rf ⨾ rmw)＊ ⊆
  (sb ∩ same_loc ⨾ ⦗W⦘)^? ∪ (sb ∩ same_loc)^? ⨾ (rfe ⨾ rmw ⨾ (sb ∩ same_loc)^? ⨾ ⦗W⦘)⁺.
Proof using.
  rewrite rtE at 1; relsf; unionL; [basic_solver 21|].
  rewrite rfi_union_rfe; relsf.
  rewrite path_union.
  unionL.
  { rewrite (dom_r (wf_rmwD WF)) at 1.
    rewrite (rfi_in_sbloc' WF) at 1.
    rewrite (rmw_in_sb_loc WF) at 1.
    generalize sb_same_loc_trans; ins; relsf.
    assert (transitive (sb ∩ same_loc ⨾ ⦗W⦘)).
    2: by relsf.
    generalize sb_same_loc_trans; unfold transitive.
    basic_solver 21. }
  rewrite ct_seq_swap, !seqA.
  rewrite (dom_r (wf_rmwD WF)) at 3.
  rewrite (rfi_in_sbloc' WF) at 1 2.
  rewrite (rmw_in_sb_loc WF) at 1 3.
  generalize sb_same_loc_trans; intros HH; relsf.
  unionR right.
  rewrite (dom_l (wf_rfeD WF)), !seqA.
  rewrite <- seqA with (r2:= ⦗W⦘).
  rewrite ct_rotl, !seqA.
  arewrite ((sb ∩ same_loc)^? ⨾ (sb ∩ same_loc)^? ⊆ (sb ∩ same_loc)^?).
  { generalize HH. basic_solver 10. }
  hahn_frame.
  arewrite (((sb ∩ same_loc) ⨾ ⦗W⦘)＊ ⨾ (sb ∩ same_loc)^? ⊆ (sb ∩ same_loc)^?).
  { arewrite_id ⦗W⦘. rewrite seq_id_r. rewrite rt_of_trans.
    2: by apply sb_same_loc_trans.
    generalize sb_same_loc_trans.
    basic_solver 10. }
  arewrite (rmw ⨾ (sb ∩ same_loc ⨾ ⦗W⦘)＊ ⊆ rmw ⨾ (sb ∩ same_loc)^? ⨾ ⦗W⦘).
  2: { rewrite (dom_l (wf_rfeD WF)) at 1 2; rewrite !seqA.
       arewrite_id ⦗W⦘ at 1. rewrite seq_id_l.
       apply ct_end. }
  rewrite rtE, seq_union_r.
  unionL.
  { rewrite (dom_r (wf_rmwD WF)) at 1. basic_solver 10. }
  rewrite ct_of_trans.
  { basic_solver 10. }
  generalize sb_trans, same_loc_trans. basic_solver 20.
Qed.

Lemma s_sw_in_ar_helper WF:
  (rf ⨾ rmw)＊ ⊆ (sb ∩ same_loc ⨾ ⦗W⦘)^? ∪ (sb ∩ same_loc)^? ⨾ (rfe ⨾ rmw ⨾ (sb ∩ same_loc)^? ⨾ ⦗W⦘)⁺.
Proof using.
  arewrite (rf ⨾ rmw ⊆ (sb ∩ same_loc)^? ⨾ rf ⨾ rmw).
  { basic_solver 10. }
  apply (sw_in_ar_helper WF).
Qed.

Lemma sb_co_trans WF :
  transitive ((⦗F⦘ ⨾ sb)^? ⨾ co).
Proof using.
  apply transitiveI. rewrite !seqA.
  rewrite (dom_r (wf_coD WF)). rewrite !seqA.
  arewrite_id (⦗W⦘ ⨾ (⦗F⦘ ⨾ sb)^?).
  { type_solver. }
  rewrite seq_id_l. by sin_rewrite (co_co WF).
Qed.

Lemma rel_sb_co_trans WF :
  transitive (⦗Rel⦘ ⨾ (⦗F⦘ ⨾ sb)^? ⨾ co).
Proof using.
  apply transitiveI. rewrite !seqA.
  rewrite (dom_r (wf_coD WF)). rewrite !seqA.
  arewrite_id (⦗W⦘ ⨾ ⦗Rel⦘ ⨾ (⦗F⦘ ⨾ sb)^?).
  { type_solver. }
  rewrite seq_id_l. by sin_rewrite (co_co WF).
Qed.

Lemma sb_co_irr WF :
  irreflexive ((⦗F⦘ ⨾ sb)^? ⨾ co).
Proof using.
  rewrite crE. rewrite seq_union_l, !seq_id_l.
  apply irreflexive_union. split.
  { by apply co_irr. }
  rewrite (wf_coD WF).
  type_solver.
Qed.

Lemma rel_sb_co_irr WF :
  irreflexive (⦗Rel⦘ ⨾ (⦗F⦘ ⨾ sb)^? ⨾ co).
Proof using. arewrite_id ⦗Rel⦘. rewrite seq_id_l. by apply sb_co_irr. Qed.

Notation "'Loc_' l" := (fun x => loc x = l) (at level 1).

Lemma co_E_W_Loc WF l x y (CO : co x y): (E ∩₁ W ∩₁ Loc_ l) x <-> (E ∩₁ W ∩₁ Loc_ l) y.
Proof using.
  apply (wf_coE WF) in CO.
  apply seq_eqv_l in CO. destruct CO as [EX CO].
  apply seq_eqv_r in CO. destruct CO as [CO EY].
  apply (wf_coD WF) in CO.
  apply seq_eqv_l in CO. destruct CO as [WX CO].
  apply seq_eqv_r in CO. destruct CO as [CO WY].
  apply (wf_col WF) in CO.
  split; intros [_ LL].
  all: by split; [split|rewrite <- LL].
Qed.

Lemma rfi_rmw_in_sb_same_loc_W WF : rfi ⨾ rmw ⊆ (sb ∩ same_loc) ⨾ ⦗W⦘.
Proof using.
  rewrite (dom_r (wf_rmwD WF)).
  rewrite rfi_in_sbloc', rmw_in_sb_loc; auto.
  sin_rewrite rewrite_trans; [done|].
  apply sb_same_loc_trans.
Qed.

Lemma rfi_rmw_in_sb_loc WF : rfi ⨾ rmw ⊆ sb ∩ same_loc.
Proof using.
  rewrite (rfi_rmw_in_sb_same_loc_W WF). basic_solver.
Qed.

(******************************************************************************)
(** ** co *)
(******************************************************************************)
Lemma wf_immcof WF : functional (immediate co).
Proof using.
  intros x y z ICOXY ICOXZ.
  assert (co x y) as COXY by apply ICOXY.
  assert (co x z) as COXZ by apply ICOXZ.
  apply (wf_coD WF) in COXY. destruct_seq COXY as [BB1 BB2].
  apply (wf_coE WF) in COXY. destruct_seq COXY as [BB3 BB4].
  apply (wf_coD WF) in COXZ. destruct_seq COXZ as [AA1 AA2].
  apply (wf_coE WF) in COXZ. destruct_seq COXZ as [AA3 AA4].
  apply is_w_loc in AA1. desf.
  set (CC:=COXY). apply (wf_col WF) in CC. red in CC.
  set (DD:=COXZ). apply (wf_col WF) in DD. red in DD.
  destruct (classic (y = z)); auto.
  edestruct (wf_co_total WF); eauto.
  1,2: split; [split|]; eauto.
  { by etransitivity; [|by eauto]. }
  { exfalso. by apply ICOXZ with (c:=y). }
  exfalso. by apply ICOXY with (c:=z).
Qed.

Lemma wf_immcotf WF : functional (immediate co)⁻¹.
Proof using.
  intros x y z ICOXY ICOXZ. red in ICOXY. red in ICOXZ.
  assert (co y x) as COXY by apply ICOXY.
  assert (co z x) as COXZ by apply ICOXZ.
  apply (wf_coD WF) in COXY. destruct_seq COXY as [BB1 BB2].
  apply (wf_coE WF) in COXY. destruct_seq COXY as [BB3 BB4].
  apply (wf_coD WF) in COXZ. destruct_seq COXZ as [AA1 AA2].
  apply (wf_coE WF) in COXZ. destruct_seq COXZ as [AA3 AA4].
  apply is_w_loc in AA2. desf.
  set (CC:=COXY). apply (wf_col WF) in CC. red in CC.
  set (DD:=COXZ). apply (wf_col WF) in DD. red in DD.
  destruct (classic (y = z)); auto.
  edestruct (wf_co_total WF); eauto.
  1,2: split; [split|]; eauto.
  { exfalso. by apply ICOXY with (c:=z). }
  exfalso. by apply ICOXZ with (c:=y).
Qed.

Lemma wf_immcoPtf WF P : functional (immediate (⦗P⦘ ⨾ co))⁻¹.
Proof using.
  intros x y z ICOXY ICOXZ. red in ICOXY. red in ICOXZ.
  assert (co y x /\ P y) as [COXY PY].
  { destruct ICOXY as [AA BB]. generalize AA. basic_solver. }
  assert (co z x /\ P z) as [COXZ PZ].
  { destruct ICOXZ as [AA BB]. generalize AA. basic_solver. }
  apply (wf_coD WF) in COXY. destruct_seq COXY as [BB1 BB2].
  apply (wf_coE WF) in COXY. destruct_seq COXY as [BB3 BB4].
  apply (wf_coD WF) in COXZ. destruct_seq COXZ as [AA1 AA2].
  apply (wf_coE WF) in COXZ. destruct_seq COXZ as [AA3 AA4].
  apply is_w_loc in AA2. desf.
  set (CC:=COXY). apply (wf_col WF) in CC. red in CC.
  set (DD:=COXZ). apply (wf_col WF) in DD. red in DD.
  destruct (classic (y = z)); auto.
  edestruct (wf_co_total WF); eauto.
  1,2: split; [split|]; eauto.
  { exfalso. apply ICOXY with (c:=z).
    all: apply seq_eqv_l; split; auto. }
  exfalso. apply ICOXZ with (c:=y).
  all: apply seq_eqv_l; split; auto.
Qed.

Lemma P_co_nP_co_P_imm WF P
      (P_in_E : P ⊆₁ E)
      (P_in_W : P ⊆₁ W) :
  immediate (⦗P⦘ ⨾ co) ⨾ ⦗set_compl P⦘ ⨾ immediate (co ⨾ ⦗P⦘) ⊆
            immediate (⦗P⦘ ⨾ co ⨾ ⦗P⦘).
Proof using.
  intros x y [z [AA BB]].
  destruct_seq_l BB as CC.
  set (DD := AA). destruct DD as [DD _]. destruct_seq_l DD as PX.
  set (EE := BB). destruct EE as [EE _]. destruct_seq_r EE as PY.
  assert (co x y) as CO.
  { eapply (co_trans WF); eauto. }
  apply (wf_coD WF) in CO. destruct_seq CO as [WX WY].
  apply (wf_coE WF) in CO. destruct_seq CO as [EX EY].
  apply (wf_coD WF) in DD. destruct_seq DD as [XLOC WZ].
  apply (wf_coE WF) in DD. destruct_seq DD as [EX' EZ].
  apply is_w_loc in XLOC. desf.
  assert (loc y = Some l /\ loc z = Some l) as [YLOC ZLOC].
  { split; rewrite <- XLOC; symmetry; by apply (wf_col WF). }

  split.
  { apply seq_eqv_lr. by splits. }
  ins.
  destruct_seq R1 as [A1 B1].
  destruct_seq R2 as [A2 B2].
  destruct (classic (c = z)) as [|CNEQ]; desf.
  assert (loc c = Some l) as LOCC.
  { rewrite <- YLOC. by apply (wf_col WF). }
  assert (E c) as EC.
  { by apply P_in_E. }
  assert (W c) as WC.
  { by apply P_in_W. }

  assert (c <> x /\ c <> y) as [CNNEXT CNPREV].
  { split; intros HH; subst; eapply (co_irr WF); eauto. }

  assert (co c z \/ co z c) as [QQ|QQ].
  { eapply (wf_co_total WF); eauto; unfolder; eauto. }
  { eapply AA with (c:=c); apply seq_eqv_l; eauto. }
  eapply BB with (c:=c); apply seq_eqv_r; eauto.
Qed.

Lemma P_co_immediate_P_co_transp_in_co_cr WF P
      (P_in_E : P ⊆₁ E)
      (P_in_W : P ⊆₁ W) :
  (⦗P⦘ ⨾ co) ⨾ (immediate (⦗P⦘⨾ co))⁻¹ ⊆ co^?.
Proof using.
  intros x y [z [AA [BB CC]]].
  destruct_seq_l AA as PZ.
  destruct_seq_l BB as DD.
  destruct (classic (x = y)) as [|NEQ]; subst; [by left|right].
  apply (wf_coD WF) in AA. destruct_seq AA as [WX WZ].
  apply (wf_coE WF) in AA. destruct_seq AA as [EX EZ].
  apply (wf_coD WF) in BB. destruct_seq BB as [WY ZLOC].
  apply (wf_coE WF) in BB. destruct_seq BB as [EY FF].
  apply is_w_loc in ZLOC. desf.
  assert (loc x = Some l /\ loc y = Some l) as [XLOC YLOC].
  { rewrite <- !ZLOC. split; by apply (wf_col WF). }
  edestruct (wf_co_total WF); eauto.
  1,2: by split; [split|]; eauto.
  exfalso.
  apply CC with (c:=x).
  all: apply seq_eqv_l; split; auto.
Qed.

Lemma co_immediate_co_in_co_cr WF : co ⨾ (immediate co)⁻¹ ⊆ co^?.
Proof using.
  assert (co ≡ ⦗E∩₁W⦘ ⨾ co) as AA.
  { split; [|basic_solver].
    rewrite (wf_coE WF) at 1. rewrite (wf_coD WF) at 1.
    basic_solver. }
  rewrite AA at 1 2.
  apply P_co_immediate_P_co_transp_in_co_cr.
  all: basic_solver.
Qed.

Lemma immediate_co_P_transp_co_P_in_co_cr WF P
      (P_in_E : P ⊆₁ E)
      (P_in_W : P ⊆₁ W) :
  (immediate (co ⨾ ⦗P⦘))⁻¹ ⨾ (co ⨾ ⦗P⦘) ⊆ co^?.
Proof using.
  intros x y [z [[BB CC] AA]].
  destruct_seq_r AA as PZ.
  destruct_seq_r BB as DD.
  destruct (classic (x = y)) as [|NEQ]; subst; [by left|right].
  apply (wf_coD WF) in AA. destruct_seq AA as [WZ WY].
  apply (wf_coE WF) in AA. destruct_seq AA as [EZ EY].
  apply (wf_coD WF) in BB. destruct_seq BB as [ZLOC WX].
  apply (wf_coE WF) in BB. destruct_seq BB as [FF EX].
  apply is_w_loc in ZLOC. desf.
  assert (loc x = Some l /\ loc y = Some l) as [XLOC YLOC].
  { rewrite <- !ZLOC. split; symmetry; by apply (wf_col WF). }
  edestruct (wf_co_total WF); eauto.
  1,2: by split; [split|]; eauto.
  exfalso.
  apply CC with (c:=y).
  all: apply seq_eqv_r; split; auto.
Qed.

End Execution.

(******************************************************************************)
(** ** Tactics *)
(******************************************************************************)

#[global]
Hint Unfold rfe coe fre rfi coi fri : ie_unfolderDb.
Tactic Notation "ie_unfolder" :=  repeat autounfold with ie_unfolderDb in *.


Require Import VST.floyd.proofauto.
Require Import VST.progs.load_demo.

#[export] Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs.  mk_varspecs prog. Defined.

Definition pair_pair_t := (Tstruct _pair_pair noattr).

Definition array_size := 100.

Definition get22_spec :=
 DECLARE _get22
  WITH pps: val, i: Z, x11: int, x12: int, x21: int, x22: int, sh : share
  PRE [ tptr pair_pair_t, tint ]
    PROP  (readable_share sh; 0 <= i < array_size)
    PARAMS (pps; Vint (Int.repr i))
    SEP   (field_at sh (tarray pair_pair_t array_size) [ArraySubsc i]
                    ((Vint x11, Vint x12), (Vint x21, Vint x22)) pps)
  POST [ tint ]
        PROP () RETURN (Vint x22)
    SEP   (field_at sh (tarray pair_pair_t array_size) [ArraySubsc i]
                    ((Vint x11, Vint x12), (Vint x21, Vint x22)) pps).

Definition uint_sum (contents : list Z) : int :=
  fold_right (fun el sum => Int.add sum (Int.repr el)) Int.zero contents.

Definition fiddle_spec :=
 DECLARE _fiddle
  WITH p: val, n: Z, tag: Z, contents: list Z
  PRE [ tptr tuint ]
          PROP  (Int.unsigned (Int.shru (Int.repr tag) (Int.repr 10)) = n)
          PARAMS (p)
          SEP (data_at Ews (tarray tuint (1+n))
                      (map Vint (map Int.repr (tag::contents)))
                      (offset_val (-sizeof tuint) p))
  POST [ tint ]
          PROP ( )
          RETURN (Vint (Int.add (Int.repr (Z.land tag 255)) (uint_sum contents)))
          SEP (data_at Ews (tarray tuint (1+n))
                      (map Vint (map Int.repr (tag::contents)))
                      (offset_val (-sizeof tuint) p)).

Definition get_uint32_le (arr: list Z) : int :=
 (Int.or (Int.or (Int.or
            (Int.repr (Znth 0 arr))
   (Int.shl (Int.repr (Znth 1 arr)) (Int.repr  8)))
   (Int.shl (Int.repr (Znth 2 arr)) (Int.repr 16)))
   (Int.shl (Int.repr (Znth 3 arr)) (Int.repr 24))).

Definition get_little_endian_spec :=
  DECLARE _get_little_endian
  WITH input : val, in_sh : share, arr : list Z
  PRE [ tptr tuchar ]
    PROP (Zlength arr = 4;
          readable_share in_sh;
          forall i, 0 <= i < 4 -> 0 <= Znth i arr <= Byte.max_unsigned)
    PARAMS (input)
    SEP (data_at in_sh (tarray tuchar 4) (map Vint (map Int.repr arr)) input)
  POST [ tuint ]
    PROP() RETURN (Vint (get_uint32_le arr))
    SEP (data_at in_sh (tarray tuchar 4) (map Vint (map Int.repr arr)) input).

Definition Gprog : funspecs := ltac:(with_library prog
  [get22_spec; fiddle_spec; get_little_endian_spec]).

Ltac solve_arr_range H :=
 match goal with |- context [Znth ?i _] =>
   specialize (H i); spec H; [ computable | ];
   rewrite Int.unsigned_repr; rep_lia
 end.

Lemma body_get_little_endian: semax_body Vprog Gprog f_get_little_endian get_little_endian_spec.
Proof.
start_function.
assert (BMU: Byte.max_unsigned=255) by reflexivity.
forward.
entailer!!. solve_arr_range H0.
forward.
forward.
entailer!!. solve_arr_range H0.
forward.
forward.
entailer!!. solve_arr_range H0.
forward.
entailer!. solve_arr_range H0.
forward.
Qed.

Lemma uint_sum_app: forall a b, uint_sum (a++b) = Int.add (uint_sum a) (uint_sum b).
Proof.
  intros. induction a; simpl.
  - symmetry. apply Int.add_zero_l.
  - rewrite IHa. rewrite !Int.add_assoc. f_equal. apply Int.add_commut.
Qed.

Lemma body_fiddle: semax_body Vprog Gprog f_fiddle fiddle_spec.
Proof.
start_function. simpl map.
rename H into Htag.
assert_PROP (Zlength contents = n) as LEN. {
  entailer!.
  forget (Int.unsigned (Int.shru (Int.repr tag) (Int.repr 10))) as n.
  clear - H0.
  rewrite Zlength_cons, !Zlength_map in H0.
  destruct (zlt n 0); [exfalso | ].
  rewrite Z.max_l in H0 by lia.
  pose proof (Zlength_nonneg contents).
  lia.
  rewrite Z.max_r in H0 by lia. lia.
}
assert (Zlength (tag :: contents) = 1 + n) as LEN1. {
  rewrite Zlength_cons. lia.
}
assert (N0: 0 <= n). {
  pose proof (Zlength_nonneg contents). lia.
}
assert_PROP (isptr p) as P by entailer!.

(* forward fails, but tells us to prove this: *)
assert_PROP (force_val (sem_add_ptr_int tuint Signed p (eval_unop Oneg tint (Vint (Int.repr 1))))
  = field_address (tarray tuint (1+n)) [ArraySubsc 0] (offset_val (-sizeof tuint) p)). {
  entailer!.
  destruct p; inversion P. simpl.
  rewrite field_compatible_field_address by auto with field_compatible.
  simpl.
  rewrite ptrofs_add_repr_0_r. reflexivity.
}
forward.
(* sum = tagword & 0xff; *)
forward.
(* size = tagword >> 10; *)
forward.
(* rewrite !Znth_0_cons. *)
forward_for_simple_bound (Int.unsigned (Int.shru (Int.repr tag) (Int.repr 10))) (EX i: Z,
  PROP ( )
  LOCAL (
    temp _size (Vint (Int.shru (Int.repr tag) (Int.repr 10)));
    temp _sum (Vint (Int.add (Int.and (Int.repr tag) (Int.repr 255))
                             (uint_sum (sublist 0 i contents))));
    temp _tagword (Vint (Int.repr tag));
    temp _p p
  )
  SEP (data_at Ews (tarray tuint (1 + n)) (map Vint (map Int.repr (tag :: contents)))
          (offset_val (- sizeof tuint) p))).
- (* precondition implies invariant: *)
  entailer!!.
- (* body preserves invariant: *)
  (* forward fails, but tells us to prove this: *)
  assert_PROP (force_val (sem_add_ptr_int tuint Unsigned p (Vint (Int.repr i)))
    = field_address (tarray tuint (1 + n)) [ArraySubsc (1 + i)] (offset_val (- sizeof tuint) p)). {
    entailer!.
    destruct p; inversion P. simpl.
    rewrite field_compatible_field_address by auto with field_compatible.
    simpl.
    rewrite Ptrofs.add_assoc, ptrofs_add_repr.
    f_equal. f_equal. f_equal. unfold sizeof; simpl. lia.
  }
  forward.
  forward.
  entailer!.
  rewrite Znth_pos_cons by lia.
  autorewrite with sublist. simpl.
  f_equal. rewrite Int.add_assoc. f_equal.
  rewrite (sublist_split 0 i (i+1)) by lia.
  rewrite sublist_len_1 by lia.
  replace (1 + i - 1) with i by lia.
  rewrite uint_sum_app. f_equal. simpl. apply Int.add_zero_l.
- (* return sum; *)
  forward. rewrite sublist_same by auto. entailer!!.
Qed.

Lemma body_get22_root_expr: semax_body Vprog Gprog f_get22 get22_spec.
 Proof.
 start_function.
 (* int_pair_t* p = &pps[i].right; *)
 forward.
 simpl (temp _p _).
 (* Assert_PROP what forward asks us for (only for the root expression "p"):  *)
 assert_PROP (offset_val 8 (force_val (sem_add_ptr_int (Tstruct _pair_pair noattr) Signed pps (Vint (Int.repr i))))
   = field_address (tarray pair_pair_t array_size) [StructField _right; ArraySubsc i] pps) as E. {
   entailer!. rewrite field_compatible_field_address by auto with field_compatible.
  simpl. normalize.
 }
 (* int res = p->snd; *)
 forward.
 (* return res; *)
 forward.
 Qed.

Lemma body_get22_full_expr: semax_body Vprog Gprog f_get22 get22_spec.
Proof.
start_function.
(* int_pair_t* p = &pps[i].right; *)
forward.
simpl (temp _p _).

(* Assert_PROP what forward asks us for (for the full expression "p->snd"): *)
assert_PROP (
  offset_val 4 (offset_val 8 (force_val
    (sem_add_ptr_int (Tstruct _pair_pair noattr) Signed pps (Vint (Int.repr i)))))
  = (field_address (tarray pair_pair_t array_size)
                   [StructField _snd; StructField _right; ArraySubsc i] pps)). {
  entailer!. rewrite field_compatible_field_address by auto with field_compatible.
  simpl. f_equal. unfold sizeof; simpl. lia.
}
(* int res = p->snd; *)
forward.
(* return res; *)
forward.
Qed.

Lemma body_get22_alt: semax_body Vprog Gprog f_get22 get22_spec.
Proof.
start_function.
(* int_pair_t* p = &pps[i].right; *)
forward.
simpl (temp _p _).

(* Alternative: Make p nice enough so that no hint is required: *)
assert_PROP (offset_val 8 (force_val (sem_add_ptr_int (Tstruct _pair_pair noattr) Signed pps (Vint (Int.repr i))))
  = field_address (tarray pair_pair_t array_size) [StructField _right; ArraySubsc i] pps) as E. {
  entailer!. rewrite field_compatible_field_address by auto with field_compatible.
  simpl.
  normalize.
}
rewrite E. clear E.
(* int res = p->snd; *)
forward.
(* return res; *)
forward.
Qed.


From iris.algebra Require Import numbers.
From iris.proofmode Require Import proofmode.
From lrust.typing Require Export type.
From lrust.typing Require Import type_context lft_contexts product own uniq_bor.
From lrust.typing Require Import shr_bor.
From iris.prelude Require Import options.

Section product_split.
  Context `{!typeGS Σ}.

  (** General splitting / merging for pointer types *)
  Fixpoint hasty_ptr_offsets (p : path) (ptr: type → type) tyl (off : nat) : tctx :=
    match tyl with
    | [] => []
    | ty :: tyl =>
      (p +ₗ #off ◁ ptr ty) :: hasty_ptr_offsets p ptr tyl (off + ty.(ty_size))
    end.

  Lemma hasty_ptr_offsets_offset (l : loc) p (off1 off2 : nat) ptr tyl tid :
    eval_path p = Some #l →
    tctx_interp tid $ hasty_ptr_offsets (p +ₗ #off1) ptr tyl off2 ≡
    tctx_interp tid $ hasty_ptr_offsets p ptr tyl (off1 + off2)%nat.
  Proof.
    intros Hp.
    revert off1 off2; induction tyl as [|ty tyl IH]; intros off1 off2; simpl; first done.
    rewrite !tctx_interp_cons. f_equiv; last first.
    { by rewrite IH assoc_L. }
    apply tctx_elt_interp_hasty_path. clear Hp. simpl.
    clear. destruct (eval_path p) as [v|]; last done. destruct v as [l|]; try done.
    destruct l; try done. rewrite shift_loc_assoc Nat2Z.inj_add //.
  Qed.

  Lemma tctx_split_ptr_prod E L ptr tyl :
    (∀ p ty1 ty2,
        tctx_incl E L [p ◁ ptr $ product2 ty1 ty2]
                      [p ◁ ptr ty1; p +ₗ #ty1.(ty_size) ◁ ptr ty2]) →
    (∀ tid ty vl, (ptr ty).(ty_own) tid vl -∗ ⌜∃ l : loc, vl = [(#l) : val]⌝) →
    ∀ p, tctx_incl E L [p ◁ ptr $ product tyl] (hasty_ptr_offsets p ptr tyl 0).
  Proof.
    iIntros (Hsplit Hloc p tid qmax qL) "#LFT #HE HL H".
    iInduction tyl as [|ty tyl IH] "IH" forall (p).
    { rewrite tctx_interp_nil. auto. }
    rewrite product_cons. iMod (Hsplit with "LFT HE HL H") as "(HL & H)".
    cbn -[tctx_elt_interp].
    iDestruct "H" as "[Hty Htyl]". iDestruct "Hty" as (v) "[Hp Hty]". iDestruct "Hp" as %Hp.
    iDestruct (Hloc with "Hty") as %[l [=->]].
    iAssert (tctx_elt_interp tid (p +ₗ #0 ◁ ptr ty)) with "[Hty]" as "$".
    { iExists #l. iSplit; last done. simpl; by rewrite Hp shift_loc_0. }
    iMod ("IH" with "HL [Htyl]") as "($ & Htyl)".
    { auto. }
    iClear "IH". rewrite (hasty_ptr_offsets_offset l) // -plus_n_O //.
  Qed.

  Lemma tctx_merge_ptr_prod E L ptr tyl :
    (Proper (eqtype E L ==> eqtype E L ) ptr) → tyl ≠ [] →
    (∀ p ty1 ty2,
        tctx_incl E L [p ◁ ptr ty1; p +ₗ #ty1.(ty_size) ◁ ptr ty2]
                      [p ◁ ptr $ product2 ty1 ty2]) →
    (∀ tid ty vl, (ptr ty).(ty_own) tid vl -∗ ⌜∃ l : loc, vl = [(#l) : val]⌝) →
    ∀ p, tctx_incl E L (hasty_ptr_offsets p ptr tyl 0) [p ◁ ptr $ product tyl].
  Proof.
    iIntros (Hptr Htyl Hmerge Hloc p tid qmax qL) "#LFT #HE HL H".
    iInduction tyl as [|ty tyl IH] "IH" forall (p Htyl); first done.
    rewrite product_cons. rewrite /= tctx_interp_singleton tctx_interp_cons.
    iDestruct "H" as "[Hty Htyl]". iDestruct "Hty" as (v) "[Hp Hty]".
    iDestruct "Hp" as %Hp. iDestruct (Hloc with "Hty") as %[l [=->]].
    assert (eval_path p = Some #l) as Hp'.
    { move:Hp. simpl. clear. destruct (eval_path p) as [v|]; last done.
      destruct v as [l'|]; try done. destruct l'; try done. rewrite shift_loc_0. done. }
    clear Hp. destruct tyl.
    { assert (eqtype E L (ptr ty) (ptr (product2 ty unit))) as [Hincl _].
      { rewrite right_id. done. }
      iDestruct (Hincl with "HL HE") as "#(_ & #Heq & _)".
      iFrame. iClear "IH Htyl". iExists #l. rewrite product_nil. iSplitR; first done.
      by iApply "Heq". }
    iMod ("IH" with "[] HL [Htyl]") as "(HL & Htyl)"; first done.
    { change (ty_size ty) with (0+ty_size ty)%nat at 1.
      rewrite plus_comm -hasty_ptr_offsets_offset //. }
    iClear "IH". iMod (Hmerge with "LFT HE HL [Hty Htyl]") as "($ & ?)";
                   last by rewrite tctx_interp_singleton.
    rewrite tctx_interp_singleton tctx_interp_cons tctx_interp_singleton. iFrame.
    iExists #l. iSplit; done.
  Qed.

  (** Owned pointers *)
  Lemma tctx_split_own_prod2 E L p n ty1 ty2 :
    tctx_incl E L [p ◁ own_ptr n $ product2 ty1 ty2]
                  [p ◁ own_ptr n ty1; p +ₗ #ty1.(ty_size) ◁ own_ptr n ty2].
  Proof.
    iIntros (tid qmax qL) "#LFT _ $ H".
    rewrite tctx_interp_singleton tctx_interp_cons tctx_interp_singleton.
    iDestruct "H" as ([[]|]) "[#Hp H]"; try done.
    iDestruct "H" as "[H >H†]". iDestruct "H" as (vl) "[>H↦ H]".
    iDestruct "H" as (vl1 vl2) "(>% & H1 & H2)". subst.
    rewrite heap_mapsto_vec_app -freeable_sz_split.
    iDestruct "H†" as "[H†1 H†2]". iDestruct "H↦" as "[H↦1 H↦2]".
    iDestruct (ty_size_eq with "H1") as "#>EQ".
    iDestruct "EQ" as %->. iSplitL "H↦1 H†1 H1".
    + iExists _. iFrame "#∗". iExists _. by iFrame.
    + iExists _. iSplitR; first (by simpl; iDestruct "Hp" as %->).
      iFrame. iExists _. by iFrame.
  Qed.

  Lemma tctx_merge_own_prod2 E L p n ty1 ty2 :
    tctx_incl E L [p ◁ own_ptr n ty1; p +ₗ #ty1.(ty_size) ◁ own_ptr n ty2]
                  [p ◁ own_ptr n $ product2 ty1 ty2].
  Proof.
    iIntros (tid qmax qL) "#LFT _ $ H".
    rewrite tctx_interp_singleton tctx_interp_cons tctx_interp_singleton.
    iDestruct "H" as "[H1 H2]". iDestruct "H1" as ([[|l|]|]) "(Hp1 & H1)"; try done.
    iDestruct "H1" as "(H↦1 & H†1)".
    iDestruct "H2" as (v2) "(Hp2 & H2)". simpl. iDestruct "Hp1" as %Hρ1.
    rewrite Hρ1. iDestruct "Hp2" as %[=<-]. iDestruct "H2" as "[H↦2 H†2]".
    iExists #l. iSplitR; first done. rewrite /= -freeable_sz_split. iFrame.
    iDestruct "H↦1" as (vl1) "[H↦1 H1]". iDestruct "H↦2" as (vl2) "[H↦2 H2]".
    iExists (vl1 ++ vl2). rewrite heap_mapsto_vec_app. iFrame.
    iDestruct (ty_size_eq with "H1") as "#>EQ". iDestruct "EQ" as %->.
    rewrite {3}/ty_own /=. auto 10 with iFrame.
  Qed.

  Lemma tctx_split_own_prod E L n tyl p :
    tctx_incl E L [p ◁ own_ptr n $ product tyl] (hasty_ptr_offsets p (own_ptr n) tyl 0).
  Proof.
    apply tctx_split_ptr_prod.
    - intros. apply tctx_split_own_prod2.
    - iIntros (??[|[[]|][]]) "?"; eauto.
  Qed.

  Lemma tctx_merge_own_prod E L n tyl :
    tyl ≠ [] →
    ∀ p, tctx_incl E L (hasty_ptr_offsets p (own_ptr n) tyl 0)
                   [p ◁ own_ptr n $ product tyl].
  Proof.
    intros. apply tctx_merge_ptr_prod; try done.
    - apply _.
    - intros. apply tctx_merge_own_prod2.
    - iIntros (??[|[[]|][]]) "?"; eauto.
  Qed.

  (** Unique borrows *)
  Lemma tctx_split_uniq_prod2 E L p κ ty1 ty2 :
    tctx_incl E L [p ◁ &uniq{κ}(product2 ty1 ty2)]
                  [p ◁ &uniq{κ} ty1; p +ₗ #ty1.(ty_size) ◁ &uniq{κ} ty2].
  Proof.
    iIntros (tid qmax qL) "#LFT _ $ H".
    rewrite tctx_interp_singleton tctx_interp_cons tctx_interp_singleton.
    iDestruct "H" as ([[]|]) "[Hp H]"; try done. iDestruct "Hp" as %Hp.
    rewrite /= split_prod_mt. iMod (bor_sep with "LFT H") as "[H1 H2]"; first solve_ndisj.
    rewrite /tctx_elt_interp /=.
    iSplitL "H1"; iExists _; (iSplitR; first by rewrite Hp); auto.
  Qed.

  Lemma tctx_merge_uniq_prod2 E L p κ ty1 ty2 :
    tctx_incl E L [p ◁ &uniq{κ} ty1; p +ₗ #ty1.(ty_size) ◁ &uniq{κ} ty2]
                  [p ◁ &uniq{κ}(product2 ty1 ty2)].
  Proof.
    iIntros (tid qmax qL) "#LFT _ $ H".
    rewrite tctx_interp_singleton tctx_interp_cons tctx_interp_singleton.
    iDestruct "H" as "[H1 H2]". iDestruct "H1" as ([[|l|]|]) "[Hp1 H1]"; try done.
    iDestruct "Hp1" as %Hp1. iDestruct "H2" as (v2) "(Hp2 & H2)". rewrite /= Hp1.
    iDestruct "Hp2" as %[=<-]. iExists #l. iFrame "%".
    iMod (bor_combine with "LFT H1 H2") as "H"; first solve_ndisj. by rewrite /= split_prod_mt.
  Qed.

  Lemma uniq_is_ptr κ ty tid (vl : list val) :
    ty_own (&uniq{κ}ty) tid vl -∗ ⌜∃ l : loc, vl = [(#l) : val]⌝.
  Proof. iIntros "H". destruct vl as [|[[]|][]]; eauto. Qed.

  Lemma tctx_split_uniq_prod E L κ tyl p :
    tctx_incl E L [p ◁ &uniq{κ}(product tyl)]
                  (hasty_ptr_offsets p (uniq_bor κ) tyl 0).
  Proof.
    apply tctx_split_ptr_prod.
    - intros. apply tctx_split_uniq_prod2.
    - intros. apply uniq_is_ptr.
  Qed.

  Lemma tctx_merge_uniq_prod E L κ tyl :
    tyl ≠ [] →
    ∀ p, tctx_incl E L (hasty_ptr_offsets p (uniq_bor κ) tyl 0)
                   [p ◁ &uniq{κ}(product tyl)].
  Proof.
    intros. apply tctx_merge_ptr_prod; try done.
    - apply _.
    - intros. apply tctx_merge_uniq_prod2.
    - intros. apply uniq_is_ptr.
  Qed.

  (** Shared borrows *)
  Lemma tctx_split_shr_prod2 E L p κ ty1 ty2 :
    tctx_incl E L [p ◁ &shr{κ}(product2 ty1 ty2)]
                  [p ◁ &shr{κ} ty1; p +ₗ #ty1.(ty_size) ◁ &shr{κ} ty2].
  Proof.
    iIntros (tid qmax qL) "#LFT _ $ H".
    rewrite tctx_interp_singleton tctx_interp_cons tctx_interp_singleton.
    iDestruct "H" as ([[]|]) "[Hp H]"; try iDestruct "H" as "[]".
    iDestruct "H" as "[H1 H2]". iDestruct "Hp" as %Hp.
    by iSplitL "H1"; iExists _; (iSplitR; first by rewrite /= Hp).
  Qed.

  Lemma tctx_merge_shr_prod2 E L p κ ty1 ty2 :
    tctx_incl E L [p ◁ &shr{κ} ty1; p +ₗ #ty1.(ty_size) ◁ &shr{κ} ty2]
                  [p ◁ &shr{κ}(product2 ty1 ty2)].
  Proof.
    iIntros (tid qmax qL) "#LFT _ $ H".
    rewrite tctx_interp_singleton tctx_interp_cons tctx_interp_singleton.
    iDestruct "H" as "[H1 H2]". iDestruct "H1" as ([[|l|]|]) "[Hp1 Hown1]"; try done.
    iDestruct "Hp1" as %Hp1. iDestruct "H2" as ([[]|]) "[Hp2 Hown2]"; try done.
    rewrite /= Hp1. iDestruct "Hp2" as %[=<-]. iExists #l. by iFrame.
  Qed.

  Lemma shr_is_ptr κ ty tid (vl : list val) :
    ty_own (&shr{κ} ty) tid vl -∗ ⌜∃ l : loc, vl = [(#l) : val]⌝.
  Proof. iIntros "H". destruct vl as [|[[]|][]]; eauto. Qed.

  Lemma tctx_split_shr_prod E L κ tyl p :
    tctx_incl E L [p ◁ &shr{κ}(product tyl)]
                  (hasty_ptr_offsets p (shr_bor κ) tyl 0).
  Proof.
    apply tctx_split_ptr_prod.
    - intros. apply tctx_split_shr_prod2.
    - intros. apply shr_is_ptr.
  Qed.

  Lemma tctx_merge_shr_prod E L κ tyl :
    tyl ≠ [] →
    ∀ p, tctx_incl E L (hasty_ptr_offsets p (shr_bor κ) tyl 0)
                   [p ◁ &shr{κ}(product tyl)].
  Proof.
    intros. apply tctx_merge_ptr_prod; try done.
    - apply _.
    - intros. apply tctx_merge_shr_prod2.
    - intros. apply shr_is_ptr.
  Qed.

  (* Splitting with [tctx_extract]. *)

  (* We do not state the extraction lemmas directly, because we want the
     automation system to be able to perform e.g., borrowing or splitting after
     splitting. *)
  Lemma tctx_extract_split_own_prod E L p p' n ty tyl T T' :
    tctx_extract_hasty E L p' ty (hasty_ptr_offsets p (own_ptr n) tyl 0) T' →
    tctx_extract_hasty E L p' ty ((p ◁ own_ptr n $ Π tyl) :: T) (T' ++ T).
  Proof.
    intros. apply (tctx_incl_frame_r T [_] (_::_)). by rewrite tctx_split_own_prod.
  Qed.

  Lemma tctx_extract_split_uniq_prod E L p p' κ ty tyl T T' :
    tctx_extract_hasty E L p' ty (hasty_ptr_offsets p (uniq_bor κ) tyl 0) T' →
    tctx_extract_hasty E L p' ty ((p ◁ &uniq{κ}(Π tyl)) :: T) (T' ++ T).
  Proof.
    intros. apply (tctx_incl_frame_r T [_] (_::_)). by rewrite tctx_split_uniq_prod.
  Qed.

  Lemma tctx_extract_split_shr_prod E L p p' κ ty tyl T T' :
    tctx_extract_hasty E L p' ty (hasty_ptr_offsets p (shr_bor κ) tyl 0) T' →
    tctx_extract_hasty E L p' ty ((p ◁ &shr{κ}(Π tyl)) :: T) ((p ◁ &shr{κ}(Π tyl)) :: T).
  Proof.
    intros. apply (tctx_incl_frame_r _ [_] [_;_]).
    rewrite {1}copy_tctx_incl. apply (tctx_incl_frame_r _ [_] [_]).
    rewrite tctx_split_shr_prod -(contains_tctx_incl _ _ [p' ◁ ty]) //.
    apply submseteq_skip, submseteq_nil_l.
  Qed.

  (* Merging with [tctx_extract]. *)

  Fixpoint extract_tyl E L p (ptr: type → type) tyl (off : nat) T T' : Prop :=
    match tyl with
    | [] => T = T'
    | ty :: tyl => ∃ T'',
        tctx_extract_hasty E L (p +ₗ #off) (ptr ty) T T'' ∧
        extract_tyl E L p ptr tyl (off + ty.(ty_size)) T'' T'
    end.

  Lemma tctx_extract_merge_ptr_prod E L p ptr tyl T T' :
    tctx_incl E L (hasty_ptr_offsets p ptr tyl 0) [p ◁ ptr $ product tyl] →
    extract_tyl E L p ptr tyl 0 T T' →
    tctx_extract_hasty E L p (ptr (Π tyl)) T T'.
  Proof.
    rewrite /extract_tyl /tctx_extract_hasty=>Hi Htyl.
    etrans; last by eapply (tctx_incl_frame_r T' _ [_]). revert T Htyl. clear.
    generalize 0%nat. induction tyl=>[T n /= -> //|T n /= [T'' [-> Htyl]]]. f_equiv. auto.
  Qed.

  Lemma tctx_extract_merge_own_prod E L p n tyl T T' :
    tyl ≠ [] →
    extract_tyl E L p (own_ptr n) tyl 0 T T' →
    tctx_extract_hasty E L p (own_ptr n (Π tyl)) T T'.
  Proof. auto using tctx_extract_merge_ptr_prod, tctx_merge_own_prod. Qed.

  Lemma tctx_extract_merge_uniq_prod E L p κ tyl T T' :
    tyl ≠ [] →
    extract_tyl E L p (uniq_bor κ) tyl 0 T T' →
    tctx_extract_hasty E L p (&uniq{κ}(Π tyl)) T T'.
  Proof. auto using tctx_extract_merge_ptr_prod, tctx_merge_uniq_prod. Qed.

  Lemma tctx_extract_merge_shr_prod E L p κ tyl T T' :
    tyl ≠ [] →
    extract_tyl E L p (shr_bor κ) tyl 0 T T' →
    tctx_extract_hasty E L p (&shr{κ}(Π tyl)) T T'.
  Proof. auto using tctx_extract_merge_ptr_prod, tctx_merge_shr_prod. Qed.
End product_split.

(* We do not want unification to try to unify the definition of these
   types with anything in order to try splitting or merging. *)
Global Hint Opaque own_ptr uniq_bor shr_bor tctx_extract_hasty : lrust_typing lrust_typing_merge.

(* We make sure that splitting is tried before borrowing, so that not
   the entire product is borrowed when only a part is needed. *)
Global Hint Resolve tctx_extract_split_own_prod tctx_extract_split_uniq_prod tctx_extract_split_shr_prod
    | 5 : lrust_typing.

(* Merging is also tried after everything, except
   [tctx_extract_hasty_further]. Moreover, it is placed in a
   difference hint db. The reason is that it can make the proof search
   diverge if the type is an evar.

   Unfortunately, priorities are not taken into account accross hint
   databases with [typeclasses eauto], so this is useless, and some
   solve_typing get slow because of that. See:
     https://coq.inria.fr/bugs/show_bug.cgi?id=5304
*)
Global Hint Resolve tctx_extract_merge_own_prod tctx_extract_merge_uniq_prod tctx_extract_merge_shr_prod
    | 40 : lrust_typing_merge.
Global Hint Unfold extract_tyl : lrust_typing.


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

#
        The double time redundancy (DTR) transformation
#
#
-  ctr block properties during odd(0) cycles

          Dmitry Burlyaev - Pascal Fradet - 2015
#
#                                           *)
(* ------------------------------------------------------- *)
(* Add LoadPath "..\..\Common\".
Require Import CirReflect .
Add LoadPath "..\..\TMRProof\".
Require Import tmrMainTh.
Add LoadPath "..\".
Require Import dtrTransform.
Add LoadPath "..\memoryBlocks".
*)

Add LoadPath "..\..\Common\".
Add LoadPath "..\..\TMRProof\".
Add LoadPath "..\Transf\".
Add LoadPath "..\memoryBlocks\".

Require Import dtrTransform controlFsmStep.

Set Implicit Arguments.

(* ########################################################## *)
(** Properties of DTR control block during the odd(0) cycles  *)
(* ########################################################## *)

(*Property: from the state '000' the control block goes to the states '001'*)
(*No glitches*)
(*by reflection*)
Lemma step0_tcbv_R : forall p t c, ((fun p => pure_bset p) p) ->
                            step ((fun p =>(ctrBlockTMR false false false)) p)
                                ((fun p =>
                                     let f3_I :=   (fstS(fstS p)) in
                                     let f2_I :=   (sndS(fstS p)) in
                                     let f1_I :=   (sndS p) in

                                     {f1_I, f2_I, f3_I} ) p) t c

                  -> (fun e => let p := fst(fst e) in
                               let t := snd(fst e) in
                               let c := snd e in

                     t={~0,~0,~0,~0,~0} /\ (c= (ctrBlockTMR false false true))) (p,t,c).
Proof. introv. Reflect_step_g. Qed.

(** The aforementioned property in a more useable form  *)
Lemma step0_tcbv : forall (f1 f2 f3:bool) f1_I f2_I f3_I t c ,
f1_I = bool2bset f1 -> f2_I= bool2bset f2 ->  f3_I= bool2bset f3
                    -> step (ctrBlockTMR false false false) {f1_I, f2_I, f3_I} t c
                    -> t={~0,~0,~0,~0,~0} /\ c = (ctrBlockTMR false false true).
Proof.
introv G1 G2 G3 H. set (p := {bool2bset f3, bool2bset f2,bool2bset f1}).
assert (X0: f1_I= (sndS p)) by
(replace p with {bool2bset f3, bool2bset f2,bool2bset f1}; destruct f1 ; easy).
assert (X1: f2_I= (sndS(fstS p))) by
(replace p with {bool2bset f3, bool2bset f2,bool2bset f1}; destruct f2 ; easy).
assert (X2: f3_I =   (fstS(fstS p))) by
(replace p with {bool2bset f3, bool2bset f2,bool2bset f1}; destruct f3 ; easy).
rewrite X0 in H. rewrite X1 in H. rewrite  X2 in H.
apply step0_tcbv_R with (t:=t) (c:=c) in H.
Simpl. CheckPure.
Qed.

(*Recovery from internal control block corruption during during the normal mode:
if one of three redundant parts of the control block is corrupted then
the error disappears the next clock cycle thanks to TMR*)
Lemma step0_tcbv_C: forall fI t ctrTMR c, pure_bset fI->
                     corrupt_1in3_cir (ctrBl_dtr false false false) ctrTMR
                     ->  step (ctrTMR -o- ctrVoting)  {fI,fI,fI}  t  c
                     -> t={~0,~0,~0,~0,~0} /\ c=(ctrBlockTMR false false true).
Proof.
introv H H0 H1. unfold ctrBlockTMR. split; Inverts H1.
 - apply tmr_corruptc  with (c':=(ctrBl_dtr false false true)) (s:=fI) (t:={~0,~0,~0,~0,~0}) in H0.
    + apply  det_step_res with (c1:=c1') (t1:=t0 )  in H0. Inverts H0.
      * assert (F:  fstep ctrVoting {~ 0, ~ 0, ~ 0, ~ 0, ~ 0,
                                    {~ 0, ~ 0, ~ 0, ~ 0, ~ 0},
                                    {~ 0, ~ 0, ~ 0, ~ 0, ~ 0}}  =
                    Some ({~0,~0,~0,~0,~0} ,  ctrVoting)) by
        (vm_compute; try easy). eapply fstep_imp_detstep in F; Simpl.
      * apply H6.
    + Checkpure.
    + assert ( exists t, exists c', step (ctrBl_dtr false false false) fI t c' ). apply step_all_ex.
      Simpl. assert (HA :=  H1). apply fact_stepCtrBl_12 in H1. destruct H1; Simpl.
 - apply tmr_corruptc  with (c':=(ctrBl_dtr false false true)) (s:=fI) (t:={~0,~0,~0,~0,~0}) in H0.
    + apply  det_step_cod with (c1:=c1') (t1:=t0 ) in H0. Inverts H0.
      * apply step_comb_cir in H11; Simpl. repeat constructor.
      * Checkpure.
      * apply H6.
    + Checkpure.
    + assert ( exists t, exists c', step (ctrBl_dtr false false false) fI t c' ). apply step_all_ex.
      Simpl. assert (HA :=  H1). apply fact_stepCtrBl_12 in H1. destruct H1; Simpl.
Qed.