Require Import FcEtt.sigs.

Require Import FcEtt.imports.
Require Import FcEtt.tactics.

Require Import FcEtt.ett_ott.
Require Import FcEtt.ett_inf.
Require Import FcEtt.ett_inf_cs.
Require Import FcEtt.ett_ind.

Require Import FcEtt.ett_par.
Require Import FcEtt.ext_invert.
Require Import FcEtt.ext_red.
Require Import FcEtt.ext_red_one.
Require Import FcEtt.erase_syntax.

Require Import FcEtt.fc_invert FcEtt.fc_unique.

Module fc_preservation (wf : fc_wf_sig) (weak : fc_weak_sig) (subst : fc_subst_sig)
        (e_subst : ext_subst_sig).

Import subst weak wf.

Module e_invert := ext_invert e_subst.
Import e_invert.

Module red := ext_red e_invert.
Import red.

Module red_one := ext_red_one e_invert.
Import red_one.

Module invert := fc_invert wf weak subst.
Module unique := fc_unique wf subst.
Import invert unique.

Set Bullet Behavior "Strict Subproofs".
Set Implicit Arguments.

(* This version is just for "head reduction". *)

Lemma open_a_Conv : forall a b g,
    open_tm_wrt_tm (a_Conv a g) b =
    a_Conv (open_tm_wrt_tm a b) (open_co_wrt_tm g b).
intros.
unfold open_tm_wrt_tm. simpl. auto.
Qed.

Lemma open_a_Conv_co : forall a b g,
    open_tm_wrt_co (a_Conv a g) b =
    a_Conv (open_tm_wrt_co a b) (open_co_wrt_co g b).
intros.
unfold open_tm_wrt_co. simpl. auto.
Qed.

(* Helper tactic for below. Solves lc_tm goals using hypotheses from
   the annotated language. Perhaps it is useful elsewhere? *)
Ltac lc_erase_hyp :=
  match goal with
  | H : AnnTyping ?G ?a ?A0 |- lc_tm (erase_tm ?a) => eapply lc_erase; apply (AnnTyping_lc H)
  | H : AnnTyping ?G ?a ?A0 |- lc_tm ?a => apply (AnnTyping_lc1 H)
  | H : lc_tm ?a |- lc_tm (erase ?a) => eapply lc_erase; eauto
  | H : lc_tm (a_Abs ?r ?a ?b) |- lc_tm ?c => apply lc_erase in H; simpl in H; auto
  | H : lc_tm (a_CAbs ?a ?b) |- lc_tm ?c => apply lc_erase in H; simpl in H; auto
  end.

Lemma binds_toplevel: forall F a A,
  binds F (Ax a A) an_toplevel ->
  binds F (Ax (erase a) (erase A)) toplevel.
Proof.
  intros.
  unfold toplevel. unfold erase_sig.
  eapply binds_map with (f:= erase_csort) in H.
  auto.
Qed.

Ltac do_rho :=
  match goal with
    H : ∀ x : atom, x `notin` ?L → RhoCheck Irrel x (erase_tm (open_tm_wrt_tm ?b (a_Var_f x))) |-
                    ?x `notin` fv_tm_tm_tm (open_tm_wrt_tm (erase ?b) (a_Var_f ?x)) =>
    let h := fresh in
    let F := fresh in
    assert (F : x `notin` L); auto;
    move: (H x F) => h; inversion h; subst;
    replace (a_Var_f x) with (erase (a_Var_f x)); auto;
    rewrite open_tm_erase_tm; auto
  end.

(* A specialized version of eauto that only uses the most common
   lc lemmas to cut down the search space. *)
Ltac eauto_lc := simpl; eauto using AnnTyping_lc1, Value_lc,
                        AnnDefEq_lc3, AnnPropWff_lc.

(* We need to know that the term type checks. But if it does, our annotated
   operational semantics corresponds with reduction_in_one. *)
Lemma head_reduction_in_one : forall G a b,
    head_reduction G a b -> forall A,  AnnTyping G a A ->
    reduction_in_one (erase a) (erase b) \/ erase a = erase b.
Proof.
  move: lc_erase => [lc_er_tm _] G a b H.
  induction H; intros AA TT ; inversion TT; try (simpl; eauto).
  - destruct rho.
    destruct (IHhead_reduction _ H6); subst; simpl.
    left. eauto. simpl in H8. rewrite H8. eauto.
    destruct (IHhead_reduction _ H6); subst; simpl.
    left. eauto. simpl in H8. rewrite H8. eauto.
  - subst. destruct rho; left; simpl_erase.
    ++ eapply E_AppAbs; eauto using lc_er_tm.
       eapply Value_lc in H0. econstructor.
       lc_erase_hyp.
    ++ inversion H6; clear H6; subst.
       pose EB := erase w.
       pick fresh x.
       rewrite (tm_subst_tm_tm_intro x); auto using fv_tm_erase_tm.
       rewrite tm_subst_tm_tm_fresh_eq.
       rewrite -(tm_subst_tm_tm_fresh_eq (open_tm_wrt_tm (erase w) (a_Var_f x)) a_Bullet x).
       rewrite -tm_subst_tm_tm_intro; eauto.
       econstructor. auto.
       eapply Value_erase in H0. auto.
       do_rho.
       do_rho.
  - subst.
    destruct (IHhead_reduction _ H4); simpl.
    eauto.
    simpl in H1. rewrite H1.
    eauto.
  - subst. left. autorewcs.
    erewrite <- open_co_erase_tm2.
    econstructor. apply lc_er_tm in H0. eauto.
  - subst.
    pick fresh x.
    edestruct (H1 x); eauto.
    left. apply E_AbsTerm_exists with (x:=x).
    eauto using fv_tm_erase_tm.
    rewrite <- open_tm_erase_tm in H2.
    rewrite <- open_tm_erase_tm in H2.
    simpl in H2. eauto.
    right. f_equal.
    move: (H9 x ltac:(auto)) => h0. inversion h0. subst.
    rewrite <- open_tm_erase_tm in H2.
    rewrite <- open_tm_erase_tm in H2.
    simpl in H2.
    apply open_tm_wrt_tm_inj in H2.
    auto.
    eauto using fv_tm_erase_tm.
    eauto using fv_tm_erase_tm.
  - left.
    assert (Ax a A = Ax a0 AA).
    { eapply binds_unique; eauto. apply uniq_an_toplevel. } inversion H6. subst.
    apply binds_toplevel in H.
    eauto.
  - subst. destruct rho.
    simpl. eauto.
    simpl. eauto.
Qed.

(* We need to know that the term type checks. But if it does, our annotated
   operational semantics corresponds with parallel reduction. *)
Lemma head_reduction_erased : forall G a b, head_reduction G a b ->
    forall A, AnnTyping G a A ->  Par G (dom G) (erase a) (erase b).
Proof.
  intros G a b H.
  induction H; intros AA TT ; inversion TT; try (simpl; econstructor; eauto).
  + destruct rho; simpl. econstructor; eauto. econstructor.
    eapply lc_erase. eapply AnnTyping_lc with (A := A). eauto.
    econstructor; eauto.
  + destruct rho; simpl_erase.
    econstructor.
    econstructor. apply Value_lc in H0. lc_erase_hyp.
    econstructor. apply Value_lc in H0. lc_erase_hyp.
    match goal with
      H :  AnnTyping ?G (a_Abs Irrel ?A ?b) (a_Pi Irrel ?A0 ?B) |- _ => inversion H; clear H end. subst.
    pose EB := (erase w).
    pick fresh x.
    rewrite (tm_subst_tm_tm_intro x); auto using fv_tm_erase_tm.
    rewrite tm_subst_tm_tm_fresh_eq.
    rewrite -(tm_subst_tm_tm_fresh_eq (open_tm_wrt_tm (erase w) (a_Var_f x)) a_Bullet x).
    rewrite -tm_subst_tm_tm_intro; eauto.
    econstructor. econstructor. apply Value_lc in H0.
    match goal with H : lc_tm (a_Abs Irrel ?A0 ?b) |-
                    lc_tm (a_UAbs Irrel (erase ?b)) => eapply lc_erase in H; simpl in H; auto end.
    econstructor; eauto.
    do_rho.
    do_rho.
  + subst. simpl.
    autorewcs. rewrite -(open_co_erase_tm2 _ _ g_Triv).
    econstructor. econstructor. lc_erase_hyp.
  + intros.
    assert (x `notin` L \u L0). eapply H10.
    replace (a_Var_f x) with (erase (a_Var_f x)); auto.
    rewrite open_tm_erase_tm.
    rewrite open_tm_erase_tm.
    eapply context_Par_irrelevance; eauto.
  + unfold toplevel. unfold erase_sig.
    apply binds_map with (f := erase_csort) in H.
    simpl in H.
    eauto.
  + simpl. eauto.
  + match goal with
      H : AnnTyping ?G (a_Conv ?v ?g1) ?A |- lc_tm (erase_tm ?v) =>
      inversion H end.
    lc_erase_hyp.
  + destruct rho; subst; simpl; eauto using lc_erase.
    econstructor. eapply AnnTyping_lc1 in TT. eapply lc_tm_erase in TT. eauto.
    econstructor. eapply AnnTyping_lc1 in TT. eapply lc_tm_erase in TT. eauto.
  + eapply AnnTyping_lc1 in TT. eapply lc_tm_erase in TT. eauto.
Qed.

Lemma preservation : forall G a A, AnnTyping G a A -> forall a', head_reduction G a a' -> AnnTyping G a' A.
Proof.
  intros G a A H. induction H.
  - intros. inversion H0.
  - intros. inversion H1.
  - intros. inversion H2; subst.
  - intros. inversion H3. subst.
    pick fresh x and apply An_Abs; eauto 3.
    have RC: RhoCheck Irrel x (erase_tm (open_tm_wrt_tm a (a_Var_f x))); eauto.
    inversion RC. subst.
    have HR: head_reduction ([(x, Tm A)] ++ G) (open_tm_wrt_tm a (a_Var_f x))
                            (open_tm_wrt_tm b' (a_Var_f x)); eauto.
    have Ta: AnnTyping ([(x, Tm A)] ++ G) (open_tm_wrt_tm b' (a_Var_f x))
                       (open_tm_wrt_tm B (a_Var_f x)); eauto.
    constructor.
    eapply Par_fv_preservation; eauto.
    eapply head_reduction_erased; eauto.
  - (* application case *)
    intros. inversion H1; subst.
    + eauto.
    + inversion H. subst.
      pick fresh x.
      rewrite (tm_subst_tm_tm_intro x); auto.
      rewrite (tm_subst_tm_tm_intro x B); auto.
      eapply AnnTyping_tm_subst; eauto.
    + (* Push case *)
      inversion H. subst. resolve_unique_subst.
      move: (AnnDefEq_regularity H7)  => [C1 [C2 [g' hyps]]]. split_hyp.
      invert_syntactic_equality.
      inversion H2. inversion H6. subst.
      eapply An_Conv; eauto.
      eapply An_PiSnd; eauto.
      eapply An_EraseEq; eauto.
      eapply AnnTyping_tm_subst_nondep; eauto.
  - intros. inversion H2; subst.
    + eauto.
    + inversion H. subst.
      econstructor; eauto 2.
      eapply An_Trans with (a1 := A); eauto 2 using AnnTyping_regularity.
      eapply An_Refl; eauto with ctx_wff.
  - intros. inversion H2.
  - intros. inversion H2.
  - intros. inversion H1; subst.
    + eauto.
    + inversion H; subst.
      pick fresh c.
      rewrite (co_subst_co_tm_intro c); auto.
      rewrite (co_subst_co_tm_intro c B); auto.
      eapply AnnTyping_co_subst; eauto.
    + (* CPush case *)
      inversion H. subst. resolve_unique_subst.
      move: (AnnDefEq_regularity H5)  => [C1 [C2 [g' hyps]]]. split_hyp.
      invert_syntactic_equality.
      inversion H2. inversion H7. subst. destruct phi1.
      eapply An_Conv; eauto.
      eapply AnnTyping_co_subst_nondep; eauto.
  - move=> a' hr.
    inversion hr. subst.

    assert (Ax a A = Ax a' A0).
    { eapply binds_unique; eauto. apply uniq_an_toplevel. }
    inversion H2. subst. clear H2. clear H0.
    apply an_toplevel_closed in H4.
    eapply AnnTyping_weakening with (F:=nil)(G:=nil)(E:=G) in H4; eauto.
    simpl in H4.
    rewrite app_nil_r in H4.
    auto.
    rewrite app_nil_r. simpl. auto.
Qed. (* preservation *)

End fc_preservation.


Require Import RefProofDeps.
Require Import RData.
Require Import EventReplay.
Require Import MoverTypes.
Require Import Constants.
Require Import CommonLib.
Require Import RefTactics.
Require Import AbsAccessor.Spec.
Require Import TableAux.Specs.invalidate_pages_in_block.
Require Import TableAux.LowSpecs.invalidate_pages_in_block.
Require Import TableAux.RefProof.RefRel.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Opaque Z.add Z.mul Z.div Z.shiftl Z.shiftr Z.land Z.lor.

Section Refine.

  Hint Unfold
       barrier_spec
       stage2_tlbi_ipa_spec
    .

  Lemma invalidate_pages_in_block_spec_exists:
    forall habd habd'  labd addr
      (Hspec: invalidate_pages_in_block_spec addr habd = Some habd')
      (Hrel: relate_RData habd labd),
    exists labd', invalidate_pages_in_block_spec0 addr labd = Some labd' /\ relate_RData habd' labd'.
  Proof.
    intros. destruct Hrel. inv id_rdata.
    unfold invalidate_pages_in_block_spec, invalidate_pages_in_block_spec0 in *. repeat autounfold in *.
    repeat simpl_hyp Hspec; inv Hspec.
    eexists. split. reflexivity. constructor.
    replace (2097152 / 4096) with 512 by reflexivity.
    reflexivity.
  Qed.

End Refine.


From Relational Require Import OrderEnrichedCategory GenericRulesSimple.

Set Warnings "-notation-overridden,-ambiguous-paths".
From mathcomp Require Import all_ssreflect all_algebra reals distr realsum
  ssrnat ssreflect ssrfun ssrbool ssrnum eqtype choice seq.
Set Warnings "notation-overridden,ambiguous-paths".

From Crypt Require Import Axioms ChoiceAsOrd SubDistr Couplings
  UniformDistrLemmas FreeProbProg Theta_dens RulesStateProb UniformStateProb
  pkg_core_definition chUniverse pkg_composition pkg_rhl
  Package Prelude.

From Coq Require Import Utf8.
From extructures Require Import ord fset fmap.

Set Bullet Behavior "Strict Subproofs".
Set Default Goal Selector "!".
Set Primitive Projections.

Import Num.Def.
Import Num.Theory.

Import PackageNotation.

Module Type ROParams.

  Parameter Query : finType.
  Parameter Random : finType.

  Parameter Query_pos : Positive #|Query|.
  Parameter Random_pos : Positive #|Random|.

End ROParams.

Module RO (π : ROParams).

  Import π.

  #[local] Existing Instance Query_pos.
  #[local] Existing Instance Random_pos.

  Definition chQuery := 'fin #|Query|.
  Definition chRandom := 'fin #|Random|.
  Notation " 'query " := chQuery (in custom pack_type at level 2).
  Notation " 'random " := chRandom (in custom pack_type at level 2).

  Definition i_random := #|Random|.
  Definition INIT : nat := 0.
  Definition QUERY : nat := 1.

  Definition queries_loc : Location := (chMap chQuery chRandom ; 2).
  Definition RO_locs : {fset Location} := fset [:: queries_loc].

  Definition RO_exports :=
    [interface
      val #[ INIT ] : 'unit → 'unit ;
      val #[ QUERY ] : 'query → 'random
    ].

  Definition RO : package RO_locs [interface] RO_exports :=
    [package
      def #[ INIT ] (_ : 'unit) : 'unit
      {
        put queries_loc := emptym ;;
        ret Datatypes.tt
      } ;
      def #[ QUERY ] (q : 'query) : 'random
      {
        queries ← get queries_loc ;;
        match queries q with
        | Some r =>
          ret r
        | None =>
          r ← sample uniform i_random ;;
          put queries_loc := setm queries q r ;;
          ret r
        end
      }
    ].

End RO.


Set Warnings "-notation-overridden,-parsing,-deprecated-hint-without-locality".
From Coq Require Import Bool.Bool.
From Coq Require Import Strings.String.
From Coq Require Import Arith.Arith.
From Coq Require Import Arith.EqNat. Import Nat.
From Coq Require Import Arith.PeanoNat.
From Coq Require Import Lia.
From Coq Require Import Strings.String.
From Coq Require Import Logic.Eqdep_dec.
From Coq Require Import Logic.FunctionalExtensionality.
From PFPL Require Import PartialMap_Set.
From PFPL Require Import Definitions.
From PFPL Require Import Lemmas_Vars.
From PFPL Require Import Lemmas_Rename.
From PFPL Require Import Lemmas_Same_Structure.
From PFPL Require Import Induction_Expr.

Lemma alpha_equiv_refl : forall e,
  alpha_equiv_rel e e.
Proof.
  induction e using expr_ind; intros.
  - apply alpha_equiv_rel_id.
  - apply alpha_equiv_rel_let.
    apply H. apply same_structure_refl.
    intros.
    apply H0.
    apply rename_keeps_structure.
  - apply alpha_equiv_rel_num.
  - apply alpha_equiv_rel_str. apply eqb_refl.
  - apply alpha_equiv_rel_plus.
    apply H. apply same_structure_refl.
    apply H0. apply same_structure_refl.
  - apply alpha_equiv_rel_times.
    apply H. apply same_structure_refl.
    apply H0. apply same_structure_refl.
  - apply alpha_equiv_rel_cat.
    apply H. apply same_structure_refl.
    apply H0. apply same_structure_refl.
  - apply alpha_equiv_rel_len.
    apply H. apply same_structure_refl.
Qed.

Lemma alpha_equiv_sym : forall e e',
  alpha_equiv_rel e e' -> alpha_equiv_rel e' e.
Proof.
  intros e e' H. induction H.
  - apply alpha_equiv_rel_id.
  - apply alpha_equiv_rel_let.
    assumption.
    intros. apply H1; assumption.
  - apply alpha_equiv_rel_num.
  - apply alpha_equiv_rel_str.
    rewrite eqb_sym. assumption.
  - apply alpha_equiv_rel_plus; assumption.
  - apply alpha_equiv_rel_times; assumption.
  - apply alpha_equiv_rel_cat; assumption.
  - apply alpha_equiv_rel_len; assumption.
Qed.

Lemma alpha_equiv_have_same_structure : forall e e',
  alpha_equiv_rel e e' -> same_structure e e'.
Proof.
  intros e e' H. induction H; simpl; auto; constructor; auto.
  remember (max (get_fresh_var e2) (get_fresh_var e2')) as z.
  apply (same_structure_trans _ (rename e2 x z) _).
  apply rename_keeps_structure.
  apply (same_structure_trans _ (rename e2' x' z) _).
  apply H1.
  subst z.
  apply (fresh_var_not_in_all_vars_left e2 e2').
  subst z.
  apply (fresh_var_not_in_all_vars_right e2 e2').
  apply same_structure_sym.
  apply rename_keeps_structure.
Qed.

Lemma diff_constructor_not_alpha : forall e e',
  diff_constructor e e' ->
  forall e'' e''',
    same_structure e e'' -> same_structure e' e''' ->
    alpha_equiv_rel e'' e''' -> False.
Proof.
  intros.
  assert (H3 := alpha_equiv_have_same_structure e'' e''' H2).
  assert (H4 := same_structure_trans e e'' e''' H0 H3).
  apply same_structure_sym in H1.
  assert (H5 := same_structure_trans e e''' e' H4 H1).
  clear H0 H1 H2 H3 H4 e'' e'''. rename H5 into H2.
  destruct e.
  all: destruct e'.
  all: inversion H.
  all: inversion H2.
Qed.

Lemma alpha_equiv_same_free_vars : forall e e',
  alpha_equiv_rel e e' -> free_vars e = free_vars e'.
Proof.
  intros e e' H. induction H; simpl; auto.
  - rewrite <- IHalpha_equiv_rel.
    remember (max
      (get_fresh_var (ELet e1 x e2))
      (get_fresh_var (ELet e1' x' e2'))
    ) as z.
    assert (XZ : (x =? z) = false).
    {
      assert (T := fresh_var_not_in_all_vars_left (ELet e1 x e2) (ELet e1' x' e2')).
      rewrite <- Heqz in T.
      simpl in T. unfold unionSet in T.
      apply orb_false_iff in T.
      destruct T.
      unfold updateSet in H3.
      destruct (x =? z). discriminate.
      reflexivity.
    }
    assert (X'Z : (x' =? z) = false).
    {
      assert (T := fresh_var_not_in_all_vars_right (ELet e1 x e2) (ELet e1' x' e2')).
      rewrite <- Heqz in T.
      simpl in T. unfold unionSet in T.
      apply orb_false_iff in T.
      destruct T.
      unfold updateSet in H3.
      destruct (x' =? z). discriminate.
      reflexivity.
    }
    assert (Zfresh : all_vars e2 z = false).
    {
      assert (T := fresh_var_not_in_all_vars_left (ELet e1 x e2) (ELet e1' x' e2')).
      rewrite <- Heqz in T.
      simpl in T. unfold unionSet in T.
      apply orb_false_iff in T. destruct T.
      unfold updateSet in H3.
      destruct (x =? z). discriminate. assumption.
    }
    assert (Zfresh' : all_vars e2' z = false).
    {
      assert (T := fresh_var_not_in_all_vars_right (ELet e1 x e2) (ELet e1' x' e2')).
      rewrite <- Heqz in T.
      simpl in T. unfold unionSet in T.
      apply orb_false_iff in T. destruct T.
      unfold updateSet in H3.
      destruct (x' =? z). discriminate. assumption.
    }
    assert (T2 : alpha_equiv_rel (rename e2 x z) (rename e2' x' z)).
    { apply H0; assumption. }
    assert (T3 : free_vars (rename e2 x z) = free_vars (rename e2' x' z)).
    { apply H1; assumption. }
    assert (T4 := rename_removes_free_vars e2 x z XZ).
    assert (T5 := rename_removes_free_vars e2' x' z X'Z).
    assert (T6 := rename_keeps_other_free_vars e2 x z).
    assert (T7 := rename_keeps_other_free_vars e2' x' z).
    assert (R : removeFromSet (free_vars e2) x = removeFromSet (free_vars e2') x').
    {
      apply functional_extensionality. intros.
      unfold removeFromSet.
      case_eq (x =? x0); case_eq (x' =? x0); intros.
      reflexivity.
      apply Nat.eqb_eq in H3. subst x0.
      rewrite Nat.eqb_sym in H2.
      assert (T8 := T7 x H2 XZ).
      rewrite <- T3 in T8.
      symmetry. rewrite T8. assumption.
      apply Nat.eqb_eq in H2. subst x0.
      rewrite Nat.eqb_sym in H3.
      assert (T9 := T6 x' H3 X'Z).
      rewrite T3 in T9.
      rewrite T5 in T9.
      assumption.
      rewrite Nat.eqb_sym in H2.
      rewrite Nat.eqb_sym in H3.
      case_eq (x0 =? z); intros.
      + apply Nat.eqb_eq in H4. subst x0.
        rewrite not_in_expr_not_free.
        rewrite not_in_expr_not_free.
        all: auto.
      + assert (T8 := T7 x0 H2 H4).
        assert (T9 := T6 x0 H3 H4).
        rewrite T8. rewrite T9.
        rewrite T3. reflexivity.
    }
    rewrite R. reflexivity.
  - rewrite IHalpha_equiv_rel1. rewrite IHalpha_equiv_rel2. auto.
  - rewrite IHalpha_equiv_rel1. rewrite IHalpha_equiv_rel2. auto.
  - rewrite IHalpha_equiv_rel1. rewrite IHalpha_equiv_rel2. auto.
Qed.


(******************************************************************************)
(** * Definition of the Power memory model *)
(******************************************************************************)
From hahn Require Import Hahn.
Require Import Events.
Require Import Execution.

Set Implicit Arguments.

Section Power_ppo.

Variable G : execution.

Notation "'E'" := (acts_set G).
Notation "'lab'" := (lab G).
Notation "'sb'" := (sb 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 "'deps'" := (deps G).
Notation "'fre'" := (fre G).
Notation "'rfe'" := (rfe G).
Notation "'coe'" := (coe G).
Notation "'rfi'" := (rfi G).
Notation "'fri'" := (fri G).
Notation "'fr'" := (fr G).
Notation "'detour'" := (detour G).

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 "'F^isync'" := (F ∩₁ (fun a => is_true (is_rlx lab a))).

Implicit Type WF : Wf G.

(******************************************************************************)
(** ** PPO components *)
(******************************************************************************)

Definition ctrli := ⦗R⦘ ⨾ ctrl ⨾ ⦗F^isync⦘ ⨾  sb.

Definition rdw := (fre ⨾ rfe) ∩ sb.

Definition ii0 := addr ∪ data ∪ rdw ∪ rfi.
Definition ci0 := ctrli ⨾ ⦗RW⦘ ∪ detour.
Definition cc0 := data ∪ ctrl ⨾ ⦗RW⦘ ∪ addr ⨾ sb^? ⨾ ⦗RW⦘.

Inductive ii x y : Prop :=
      II0   : ii0 x y -> ii x y
    | CI    : ci x y -> ii x y
    | IC_CI : forall z, ic x z -> ci z y -> ii x y
    | II_II : forall z, ii x z -> ii z y -> ii x y
with ic x y : Prop :=
    | II    : ii x y -> ic x y
    | CC    : cc x y -> ic x y
    | IC_CC : forall z, ic x z -> cc z y -> ic x y
    | II_IC : forall z, ii x z -> ic z y -> ic x y
with ci x y : Prop :=
      CI0   : ci0 x y -> ci x y
    | CI_II : forall z, ci x z -> ii z y -> ci x y
    | CC_CI : forall z, cc x z -> ci z y -> ci x y
with cc x y : Prop :=
      CC0   : cc0 x y -> cc x y
    | CI_   : ci x y -> cc x y
    | CI_IC : forall z, ci x z -> ic z y -> cc x y
    | CC_CC : forall z, cc x z -> cc z y -> cc x y.

Scheme ii_rec := Minimality for ii Sort Prop
  with ic_rec := Minimality for ic Sort Prop
  with ci_rec := Minimality for ci Sort Prop
  with cc_rec := Minimality for cc Sort Prop.

Combined Scheme ppo_comp_ind from ii_rec, ic_rec, ci_rec, cc_rec.

(* Preserved program order *)
Definition ppo := ⦗R⦘ ⨾ ii ⨾ ⦗R⦘ ∪ ⦗R⦘ ⨾ ic ⨾ ⦗W⦘.

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

Lemma wf_ctrliE WF: ctrli ≡ ⦗E⦘ ⨾ ctrli ⨾ ⦗E⦘.
Proof using.
split; [|basic_solver].
unfold ctrli.
sin_rewrite (wf_ctrlE WF).
sin_rewrite (wf_sbE).
basic_solver 42.
Qed.

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

Lemma wf_ii0E WF: ii0 ≡ ⦗E⦘ ⨾ ii0 ⨾ ⦗E⦘.
Proof using.
split; [|basic_solver].
unfold ii0.
rewrite (wf_addrE WF) at 1.
rewrite (wf_dataE WF) at 1.
rewrite (wf_rdwE WF) at 1.
rewrite (wf_rfiE WF) at 1.
basic_solver 42.
Qed.

Lemma wf_ci0E WF: ci0 ≡ ⦗E⦘ ⨾ ci0 ⨾ ⦗E⦘.
Proof using.
split; [|basic_solver].
unfold ci0.
rewrite (wf_ctrliE WF) at 1.
rewrite (wf_detourE WF) at 1.
basic_solver 42.
Qed.

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

Lemma wf_helperE WF:
forall x y,
(ii x y -> E x /\ E y) /\
(ic x y -> E x /\ E y) /\
(ci x y -> E x /\ E y) /\
(cc x y -> E x /\ E y).
Proof using.
generalize (dom_to_doma (wf_ii0E WF)) (dom_to_domb (wf_ii0E WF)).
generalize (dom_to_doma (wf_ci0E WF)) (dom_to_domb (wf_ci0E WF)).
generalize (dom_to_doma (wf_cc0E WF)) (dom_to_domb (wf_cc0E WF)).
unfolder; intros A1 A2 A3 A4 A5 A6.
apply ppo_comp_ind; basic_solver.
Qed.

Lemma wf_iiE WF: ii ≡ ⦗E⦘ ⨾ ii ⨾ ⦗E⦘.
Proof using.
split; [|basic_solver].
unfolder; ins; splits; try done; eapply wf_helperE in H; desf.
Qed.

Lemma wf_icE WF: ic ≡ ⦗E⦘ ⨾ ic ⨾ ⦗E⦘.
Proof using.
split; [|basic_solver].
unfolder; ins; splits; try done; eapply wf_helperE in H; desf.
Qed.

Lemma wf_ciE WF: ci ≡ ⦗E⦘ ⨾ ci ⨾ ⦗E⦘.
Proof using.
split; [|basic_solver].
unfolder; ins; splits; try done; eapply wf_helperE in H; desf.
Qed.

Lemma wf_ccE WF: cc ≡ ⦗E⦘ ⨾ cc ⨾ ⦗E⦘.
Proof using.
split; [|basic_solver].
unfolder; ins; splits; try done; eapply wf_helperE in H; desf.
Qed.

Lemma wf_ppoE WF: ppo ≡ ⦗E⦘ ⨾ ppo ⨾ ⦗E⦘.
Proof using.
split; [|basic_solver].
unfold ppo.
rewrite (wf_iiE WF) at 1.
rewrite (wf_icE WF) at 1.
basic_solver 42.
Qed.

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

Lemma wf_ctrliD : ctrli ⊆ ⦗R⦘ ⨾ ctrli.
Proof using.
unfold ctrli; basic_solver 12.
Qed.

Lemma wf_rdwD WF : rdw ≡ ⦗R⦘ ⨾ rdw ⨾ ⦗R⦘.
Proof using.
split; [|basic_solver].
unfold rdw.
sin_rewrite (wf_freD WF).
sin_rewrite (wf_rfeD WF).
basic_solver 42.
Qed.

Lemma wf_ppoD WF: ppo ≡ ⦗R⦘ ⨾ ppo ⨾ ⦗RW⦘.
Proof using.
split; [|basic_solver].
unfold ppo.
type_solver 42.
Qed.

Lemma wf_ii0D WF: ii0 ≡ ⦗RW⦘ ⨾ ii0 ⨾ ⦗RW⦘.
Proof using.
split; [|basic_solver].
unfold ii0.
rewrite (wf_addrD WF) at 1.
rewrite (wf_dataD WF) at 1.
rewrite (wf_rdwD WF) at 1.
rewrite (wf_rfiD WF) at 1.
type_solver 42.
Qed.

Lemma wf_ci0D WF: ci0 ≡ ⦗RW⦘ ⨾ ci0 ⨾ ⦗RW⦘.
Proof using.
split; [|basic_solver].
unfold ci0.
rewrite wf_ctrliD at 1.
rewrite (wf_detourD WF) at 1.
basic_solver 42.
Qed.

Lemma wf_cc0D WF: cc0 ≡ ⦗RW⦘ ⨾ cc0 ⨾ ⦗RW⦘.
Proof using.
split; [|basic_solver].
unfold cc0.
rewrite (wf_dataD WF) at 1.
rewrite (wf_ctrlD WF) at 1.
rewrite (wf_addrD WF) at 1.
basic_solver 42.
Qed.

Lemma wf_helperD WF:
forall x y,
(ii x y -> RW x /\ RW y) /\
(ic x y -> RW x /\ RW y) /\
(ci x y -> RW x /\ RW y) /\
(cc x y -> RW x /\ RW y).
Proof using.
generalize (dom_to_doma (wf_ii0D WF)) (dom_to_domb (wf_ii0D WF)).
generalize (dom_to_doma (wf_ci0D WF)) (dom_to_domb (wf_ci0D WF)).
generalize (dom_to_doma (wf_cc0D WF)) (dom_to_domb (wf_cc0D WF)).
unfolder; intros A1 A2 A3 A4 A5 A6.
apply ppo_comp_ind; basic_solver.
Qed.

Lemma wf_iiD WF: ii ≡ ⦗RW⦘ ⨾ ii ⨾ ⦗RW⦘.
Proof using.
split; [|basic_solver].
unfolder; ins; splits; try done; eapply (wf_helperD WF) in H; desc; eauto.
Qed.

Lemma wf_icD WF: ic ≡ ⦗RW⦘ ⨾ ic ⨾ ⦗RW⦘.
Proof using.
split; [|basic_solver].
unfolder; ins; splits; try done; eapply (wf_helperD WF) in H; desc; eauto.
Qed.

Lemma wf_ciD WF: ci ≡ ⦗RW⦘ ⨾ ci ⨾ ⦗RW⦘.
Proof using.
split; [|basic_solver].
unfolder; ins; splits; try done; eapply (wf_helperD WF) in H; desc; eauto.
Qed.

Lemma wf_ccD WF: cc ≡ ⦗RW⦘ ⨾ cc ⨾ ⦗RW⦘.
Proof using.
split; [|basic_solver].
unfolder; ins; splits; try done; eapply (wf_helperD WF) in H; desc; eauto.
Qed.

(******************************************************************************)
(** ** Inclusion *)
(******************************************************************************)
Lemma ctrli_in_sb WF : ctrli ⊆ sb.
Proof using.
unfold ctrli.
rewrite (ctrl_in_sb WF).
generalize (@sb_trans G); basic_solver.
Qed.

Lemma ctrli_sb : ctrli ⨾ sb ⊆ ctrli.
Proof using.
unfold ctrli.
generalize (@sb_trans G); basic_solver 12.
Qed.

Lemma ctrli_in_ctrl WF : ctrli ⊆ ctrl.
Proof using.
unfold ctrli.
generalize (ctrl_sb WF); basic_solver.
Qed.

Lemma ii0_in_ii : ii0 ⊆ ii.
Proof using. vauto. Qed.
Lemma ci0_in_ci : ci0 ⊆ ci.
Proof using. vauto. Qed.
Lemma cc0_in_cc : cc0 ⊆ cc.
Proof using. vauto. Qed.

Lemma ci_in_ii : ci ⊆ ii.
Proof using. vauto. Qed.
Lemma ci_in_ic : ci ⊆ ic.
Proof using. vauto. Qed.
Lemma ii_in_ic : ii ⊆ ic.
Proof using. vauto. Qed.
Lemma ci_in_cc : ci ⊆ cc.
Proof using. vauto. Qed.
Lemma cc_in_ic : cc ⊆ ic.
Proof using. vauto. Qed.

Lemma ic_ci_in_ii : ic ⨾ ci ⊆ ii.
Proof using. unfolder; ins; desf; vauto. Qed.
Lemma ii_ii_in_ii : ii ⨾ ii ⊆ ii.
Proof using. unfolder; ins; desf; vauto. Qed.
Lemma ic_cc_in_ic : ic ⨾ cc ⊆ ic.
Proof using. unfolder; ins; desf; vauto. Qed.
Lemma ii_ic_in_ic : ii ⨾ ic ⊆ ic.
Proof using. unfolder; ins; desf; vauto. Qed.
Lemma ci_ii_in_ci : ci ⨾ ii ⊆ ci.
Proof using. unfolder; ins; desf; vauto. Qed.
Lemma cc_ci_in_ci : cc ⨾ ci ⊆ ci.
Proof using. unfolder; ins; desf; vauto. Qed.
Lemma ci_ic_in_cc : ci ⨾ ic ⊆ cc.
Proof using. unfolder; ins; desf; vauto. Qed.
Lemma cc_cc_in_cc : cc ⨾ cc ⊆ cc.
Proof using. unfolder; ins; desf; vauto. Qed.
Lemma ii_cc_in_ic : ii ⨾ cc ⊆ ic.
Proof using. unfolder; ins; desf; vauto. Qed.

Lemma ii0_in_sb WF: ii0 ⊆ sb.
Proof using.
unfold ii0, rdw; ie_unfolder.
rewrite addr_in_sb, data_in_sb; try done.
basic_solver 42.
Qed.

Lemma ci0_in_sb WF: ci0 ⊆ sb.
Proof using.
unfold ci0, Execution.detour.
rewrite ctrli_in_sb; try done.
basic_solver 42.
Qed.

Lemma cc0_in_sb WF: cc0 ⊆ sb.
Proof using.
unfold cc0.
rewrite addr_in_sb, data_in_sb, ctrl_in_sb; try done.
generalize (@sb_trans G).
basic_solver 42.
Qed.

Lemma in_sb_helper WF:
forall x y,
(ii x y -> sb x y) /\
(ic x y -> sb x y) /\
(ci x y -> sb x y) /\
(cc x y -> sb x y).
Proof using.
generalize (ii0_in_sb WF) (ci0_in_sb WF) (cc0_in_sb WF).
generalize (@sb_trans G).
unfolder; intros A A1 A2 A3.
apply ppo_comp_ind; basic_solver.
Qed.

Lemma ii_in_sb WF: ii ⊆ sb.
Proof using.
unfolder; ins; splits; try done; eapply in_sb_helper in H; desf.
Qed.

Lemma ic_in_sb WF: ic ⊆ sb.
Proof using.
unfolder; ins; splits; try done; eapply in_sb_helper in H; desf.
Qed.

Lemma ci_in_sb WF: ci ⊆ sb.
Proof using.
unfolder; ins; splits; try done; eapply in_sb_helper in H; desf.
Qed.

Lemma cc_in_sb WF: cc ⊆ sb.
Proof using.
unfolder; ins; splits; try done; eapply in_sb_helper in H; desf.
Qed.
Lemma ppo_in_sb WF : ppo ⊆ sb.
Proof using.
unfold ppo.
rewrite ii_in_sb, ic_in_sb; try done.
basic_solver.
Qed.

Lemma rdw_in_ppo WF : rdw ⊆ ppo.
Proof using.
unfold ppo.
rewrite (wf_rdwD WF).
rewrite <- ii0_in_ii.
unfold ii0; basic_solver 42.
Qed.

Lemma rfi_in_ii : rfi ⊆ ii.
Proof using.
rewrite <- ii0_in_ii.
unfold ii0; basic_solver 42.
Qed.

Lemma detour_in_ci : detour ⊆ ci.
Proof using.
rewrite <- ci0_in_ci.
unfold ci0; basic_solver 42.
Qed.

Lemma detour_in_ii : detour ⊆ ii.
Proof using.
by rewrite <- ci_in_ii, detour_in_ci.
Qed.

Lemma data_in_ii : data ⊆ ii.
Proof using.
rewrite <- ii0_in_ii.
unfold ii0; basic_solver 42.
Qed.

Lemma addr_in_ii : addr ⊆ ii.
Proof using.
rewrite <- ii0_in_ii.
unfold ii0; basic_solver 42.
Qed.

Lemma ctrl_in_cc : ctrl ⨾ ⦗RW⦘ ⊆ cc.
Proof using.
rewrite <- cc0_in_cc.
unfold cc0; basic_solver 42.
Qed.

Lemma addr_sb_in_cc : addr ⨾ sb^? ⨾ ⦗RW⦘ ⊆ cc.
Proof using.
rewrite <- cc0_in_cc.
unfold cc0; basic_solver 42.
Qed.

Lemma deps_in_ppo WF: deps ⨾ ⦗W⦘ ⊆ ppo.
Proof using.
unfold Execution.deps, ppo.
rewrite (wf_dataD WF), (wf_addrD WF), (wf_ctrlD WF).
rewrite data_in_ii, addr_in_ii.
generalize ii_in_ic cc_in_ic ctrl_in_cc.
basic_solver 42.
Qed.

Lemma addrsbW_in_ppo WF: addr ⨾ sb ⨾ ⦗W⦘ ⊆ ppo.
Proof using.
unfold ppo.
rewrite <- cc_in_ic, <- cc0_in_cc.
rewrite (wf_addrD WF) at 1.
unfold cc0; basic_solver 42.
Qed.

Lemma rdw_rbi_in_rbi WF: rdw ⨾ fri ⊆ fri.
Proof using.
unfold rdw; ie_unfolder.
generalize (rf_fr WF) (fr_co WF) (@sb_trans G).
basic_solver 42.
Qed.

Lemma ctrli_fri_in_ci0 WF: ctrli ⨾ fri ⊆ ci0.
Proof using.
rewrite (wf_friD WF).
arewrite (⦗R⦘ ⨾ fri ⊆ sb).
by ie_unfolder; basic_solver.
sin_rewrite ctrli_sb.
unfold ci0; type_solver.
Qed.

Lemma ctrli_fri_in_cc0 WF: ctrli ⨾ fri ⊆ cc0.
Proof using.
rewrite (wf_friD WF).
arewrite (⦗R⦘ ⨾ fri ⊆ sb).
by ie_unfolder; basic_solver.
sin_rewrite ctrli_sb.
rewrite (ctrli_in_ctrl WF).
unfold cc0; basic_solver 12.
Qed.

Lemma R_ci0_W_in_ppo : ⦗R⦘ ⨾ ci0 ⨾ ⦗W⦘ ⊆ ppo.
Proof using.
unfold ppo.
rewrite <- ci_in_ic, <- ci0_in_ci.
basic_solver.
Qed.

(******************************************************************************)
(** ** L <-> PPO components *)
(******************************************************************************)
(* Single-transition definition *)
Inductive L x y : Prop :=
  | L_cc      : cc0 x y -> L x y
  | L_Li      : Li x y -> L x y
  | L_L_cc    : forall z, L x z -> cc0 z y -> L x y
with Li x y : Prop :=
  | Li_ci     : ci0 x y -> Li x y
  | Li_ii     : ii0 x y -> Li x y
  | Li_L_ci   : forall z, L x z -> ci0 z y -> Li x y
  | Li_Li_ii  : forall z, Li x z -> ii0 z y -> Li x y.

Scheme L_rec := Minimality for L Sort Prop
  with Li_rec := Minimality for Li Sort Prop.

Combined Scheme L_comb from L_rec, Li_rec.

Lemma L_in_union : L ⊆ ii ∪ ic ∪ ci ∪ cc.
Proof using.
  red; ins.
  apply L_rec with (x:=x)
  (P:=fun y => (ii ∪ ic ∪ ci ∪ cc) x y) (P0:=fun y => (ii ∪ ci) x y);
  auto; ins; try vauto; try (by unfolder in *; desf; (right + left); vauto).
  - left; left; right; unfolder in *; desf; vauto.
    assert (ci ⊆ ic) by (unfolder; vauto).
    apply H3 in H1; vauto.
Qed.

Lemma seq_alt A (r r' r'' : relation A) :
  (forall x y, r' x y -> forall z, r z x -> r'' z y) <->
  r ⨾ r' ⊆ r''.
Proof using.
  split.
  - ins; red; ins; unfold seq in H0; desf; eapply H; eauto; edone.
  - unfolder; ins; apply H; eexists; splits; eauto.
Qed.

Lemma basic_to_transitional :
  (Li^? ⨾ ii ⊆ Li) /\
  (Li^? ⨾ ic ⊆ L) /\
  (L^? ⨾ ci ⊆ Li) /\
  (L^? ⨾ cc ⊆ L).
Proof using.
  rewrite <- !seq_alt.
  cut (forall x y,
    (ii x y -> forall z, Li^? z x -> Li z y) /\
    (ic x y -> forall z, Li^? z x -> L z y) /\
    (ci x y -> forall z, L^? z x -> Li z y) /\
    (cc x y -> forall z, L^? z x -> L z y)).
  { ins; splits; ins; desf;
    specialize (H x y); desf; eauto. }
  apply ppo_comp_ind with
  (*ii*) (P:=fun x y => forall z, (Li^?) z x -> Li z y)
  (*ic*) (P0:=fun x y => forall z, (Li^?) z x -> L z y)
  (*ci*) (P1:=fun x y => forall z, (L^?) z x -> Li z y)
  (*cc*) (P2:=fun x y => forall z, (L^?) z x -> L z y);
  rewrite ?seq_alt;
  (* base cases *)
  try (by unfolder; ins; desf; vauto);
  ins;
  (* single derivations *)
  try (by apply H2; right; apply H0);
  (* double derivations *)
  try (by apply H0; red in H1; desf; (left + right); vauto);
  by apply L_Li, H0.
Qed.

Lemma L_Li_in_ppo_components : Li ⊆ ii ∪ ci /\ L ⊆ ii ∪ ic ∪ ci ∪ cc.
Proof using.
  unfolder.
  assert (forall x y,
    (L x y -> ii x y \/ ic x y \/ ci x y \/ cc x y) /\
    (Li x y -> ii x y \/ ci x y)
  ).
  { ins; apply L_comb with
      (P := fun y => ii x y \/ ic x y \/ ci x y \/ cc x y)
      (P0 := fun y => ii x y \/ ci x y);
    auto; ins.
    all: try by vauto.
    all: try by (desf; by (left + right); vauto).
    all: try by (desf; by repeat right; vauto).
    desf; by (right; left + (repeat right)); vauto.
  }
  split; ins; specialize (H x y); desf; intuition.
Qed.

Lemma Li_is_ii : Li ≡ ii.
Proof using.
  split.
  - arewrite (Li ⊆ ii ∪ ci) by apply L_Li_in_ppo_components.
    rewrite ci_in_ii.
    basic_solver.
  - generalize basic_to_transitional.
basic_solver 12.
Qed.

Lemma L_is_ic : L ≡ ic.
Proof using.
  split.
  - arewrite (L ⊆ ii ∪ ic ∪ ci ∪ cc) by apply L_Li_in_ppo_components.
  rewrite ii_in_ic, ci_in_ic, cc_in_ic; basic_solver.
  - red; ins.
    assert (Li^? ⨾ ic ⊆ L) by apply basic_to_transitional.
    apply H0; eexists; splits; eauto.
Qed.

Lemma wf_LD WF: L ⊆ ⦗RW⦘ ⨾ L ⨾ ⦗RW⦘.
Proof using.
by rewrite L_is_ic; apply wf_icD.
Qed.

Lemma wf_LiD WF: Li ⊆ ⦗RW⦘ ⨾ Li ⨾ ⦗RW⦘.
Proof using.
by rewrite Li_is_ii; apply wf_iiD.
Qed.

Lemma L_in_ppo : ⦗R⦘ ⨾ L ⨾ ⦗W⦘ ⊆ ppo.
Proof using.
rewrite L_is_ic; unfold ppo; basic_solver.
Qed.

Lemma Li_in_ppo WF: ⦗R⦘ ⨾ Li ⊆ ppo.
Proof using.
rewrite Li_is_ii; unfold ppo.
rewrite (wf_iiD WF) at 1.
generalize ii_in_ic.
basic_solver 42.
Qed.

Lemma Li_in_L : Li ⊆ L.
Proof using. vauto. Qed.

Lemma ppo_in_L WF: ppo ⊆ ⦗R⦘ ⨾ L.
Proof using.
unfold ppo.
rewrite L_is_ic, ii_in_ic.
rewrite (wf_icD WF) at 3.
basic_solver.
Qed.

Lemma ppo_R_in_R_Li WF: ppo ⨾ ⦗R⦘ ⊆ ⦗R⦘ ⨾ Li.
Proof using.
rewrite (wf_ppoD WF), Li_is_ii.
unfold ppo; type_solver 12.
Qed.

Lemma ppo_W_in_R_L WF: ppo ⨾ ⦗W⦘ ⊆ ⦗R⦘ ⨾ L.
Proof using.
rewrite (wf_ppoD WF), L_is_ic.
unfold ppo; type_solver 12.
Qed.

(******************************************************************************)
(** ** Extra *)
(******************************************************************************)

Lemma deps_in_cc: deps ⨾ ⦗RW⦘ ⊆ cc.
Proof using.
rewrite <- cc0_in_cc.
unfold Execution.deps, cc0; basic_solver 42.
Qed.

Lemma deps_in_ic : deps ⨾ ⦗RW⦘ ⊆ ic.
Proof using.
rewrite <- cc_in_ic.
by apply deps_in_cc.
Qed.

(*
Lemma ctrl_sb_W_in_ppo WF: ctrl ⨾ sb ⨾ ⦗W⦘ ⊆ ppo ⨾ ⦗W⦘.
Proof using.
unfold ppo.
rewrite (wf_ctrlD WF).
rewrite !seqA.
sin_rewrite (ctrl_sb WF).
rewrite <- cc_in_ic.
rewrite <- ctrl_in_cc.
basic_solver 42.
Qed.
*)

Lemma ctrli_RW_in_ic: ctrli ⨾ ⦗RW⦘ ⊆ ic.
Proof using.
rewrite <- ci_in_ic, <- ci0_in_ci; vauto.
Qed.

Lemma ctrli_R_in_ii: ctrli ⨾ ⦗RW⦘ ⊆ ii.
Proof using.
rewrite <- ci_in_ii, <- ci0_in_ci; vauto.
Qed.

Lemma ctrl_ctrli_in_ii WF: ctrl ⨾ ctrli ⨾ ⦗RW⦘ ⊆ ii.
Proof using.
rewrite wf_ctrliD.
unfolder; ins; desc.
eapply CI, CC_CI.
apply CC0; unfold cc0; basic_solver 12.
apply CI0; unfold ci0; basic_solver 12.
Qed.

Lemma ctrl_ctrli_RW_in_ppo WF: ctrl ⨾ ctrli ⨾ ⦗RW⦘ ⊆ ppo.
Proof using.
rewrite (wf_ctrlD WF).
arewrite (⦗RW⦘ ⊆ ⦗RW⦘ ⨾ ⦗RW⦘) by basic_solver.
sin_rewrite (ctrl_ctrli_in_ii WF).
unfold ppo.
generalize ii_in_ic.
basic_solver 12.
Qed.

Lemma ctrli_RW_in_ppo WF : ctrli ⨾ ⦗RW⦘ ⊆ ppo.
Proof using.
unfold ppo.
rewrite wf_ctrliD.
generalize ctrli_RW_in_ic, ctrli_R_in_ii.
basic_solver 12.
Qed.

(******************************************************************************)
(** ** Propositions *)
(******************************************************************************)

Lemma ppo_trans : transitive ppo.
Proof using.
  unfold transitive, ppo; unfolder.
  ins; desf; try type_solver.
  by left; exists z2; split; auto; exists z; vauto.
  by right; exists z2; split; auto; exists z; splits; vauto.
Qed.

Lemma ct_ppo_ctrli_rw_in_ppo WF : (ppo ∪ ctrli)⁺ ⨾ ⦗RW⦘ ⊆ ppo.
Proof using.
apply ct_ind_left with (P:= fun r => r ⨾ ⦗RW⦘).
- by eauto with hahn.
- generalize ctrli_RW_in_ppo; basic_solver.
- ins; rewrite !seqA, H.
  rewrite (dom_l (wf_ppoD WF)) at 2.
  relsf.
  arewrite (ctrli ⨾ ⦗R⦘ ⊆ ppo).
  by generalize ctrli_RW_in_ppo; basic_solver.
  generalize ppo_trans; basic_solver.
Qed.

Lemma deps_R_in_ppo WF:
  (deps ∪ addr ⨾ sb) ⨾ ⦗R⦘ ⨾ sb ⨾ ⦗W⦘ ⊆ ppo.
Proof using.
 arewrite ((deps ∪ addr ⨾ sb) ⨾ ⦗R⦘ ⊆ ctrl ∪ addr ⨾ sb^?).
  by unfold Execution.deps; rewrite (wf_dataD WF); type_solver 42.
relsf.
sin_rewrite (ctrl_sb WF).
arewrite (ctrl ⊆ deps).
generalize (addrsbW_in_ppo WF) (deps_in_ppo WF).
generalize (@sb_trans G).
basic_solver 42.
Qed.

Lemma ci0_fri WF:  ci0 ⨾ fri ⊆ ppo ∪ co.
Proof using.
unfold ci0.
rewrite wf_ctrliD at 1.
rewrite (wf_friD WF) at 1.
generalize (ctrli_fri_in_ci0 WF), (R_ci0_W_in_ppo).
generalize (detour_fr_in_co WF).
ie_unfolder.
basic_solver 42.
Qed.

Lemma L_ctrli_fri WF:  ⦗R⦘ ⨾  L ⨾ ctrli ⨾ fri ⊆ ppo.
Proof using.
rewrite (dom_r (wf_friD WF)).
rewrite <- L_in_ppo.
rewrite (ctrli_in_ctrl WF).
arewrite (fri ⊆ sb).
sin_rewrite (ctrl_sb WF).
unfolder; splits; auto; desf.
apply L_L_cc with z; auto.
unfold cc0; basic_solver 20.
Qed.

Lemma ppo_fri WF : ppo ⨾ fri ⊆ ppo ∪ ppo ⨾ co ∪ co ∪ fri.
Proof using.
rewrite (wf_friD WF) at 1.
rels.
sin_rewrite ppo_R_in_R_Li; auto.
red; ins. unfolder in H; desf.
unfolder in H; desf; subst.
rename y into c, x into a, z into b.
apply Li_rec with (P:=L a)
 (P0:=(fun b => fri b c -> (ppo ∪ ppo ⨾ co ∪ co ∪ fri) a c)) in H2; eauto; ins; vauto.
- cut ((ppo ∪ co) a c).
  by basic_solver.
  generalize (ci0_fri WF).
  basic_solver.
- (* ii0 *)
  red in H3; unfolder in H3; desf.
  + (* addr *)
    generalize (addrsbW_in_ppo WF).
    ie_unfolder.
    unfolder in *.
    basic_solver 12.
    + (* data *)
    exfalso.
    apply (wf_dataD WF) in H3.
    apply (wf_friD WF) in H4.
    unfolder in *; type_solver.
    + (* rdw *)
    generalize (rdw_rbi_in_rbi WF); basic_solver 12.
    + (* rf∙ *)
    generalize (rf_fr WF).
    ie_unfolder.
    unfolder in *;  basic_solver 12.
- (* ci0 *)
  unfold ci0 in *; unfolder in *; desf.
  + (* ctrli *)
    generalize (L_ctrli_fri WF); basic_solver 12.
  + (* ctrli *)
    generalize (L_ctrli_fri WF); basic_solver 12.
  + (* detour *)
    apply (wf_detourD WF) in H5.
    generalize (detour_fr_in_co WF) L_in_ppo.
    ie_unfolder.
    unfolder in *; basic_solver 42.
- unfold ii0 in *; unfolder in *; desf.
  + (* addr *)
    hahn_rewrite (wf_friD WF) in H6; unfolder in H6; desc.
    do 3 left.
    apply L_in_ppo.
    unfolder. splits; auto.
    apply L_L_cc with z; vauto.
    unfold cc0.
    ie_unfolder.
    unfolder in *; basic_solver 42.
  + (* data *)
    exfalso.
    apply (wf_dataD WF) in H5.
    apply (wf_friD WF) in H6.
    unfolder in *; type_solver.
  + (* rdw *)
    generalize (rdw_rbi_in_rbi WF).
    basic_solver 12.
  + (* rf∙ *)
    do 2 left; right.
    eexists.
    split.
    * generalize L_in_ppo, L_Li.
      apply (wf_rfiD WF) in H5.
      unfolder in *; basic_solver 12.
    * generalize (rf_fr WF).
      ie_unfolder.
      unfolder in *; basic_solver.
Qed.

Lemma deps_rfi WF :
  (data ∪ ctrl ∪ addr ⨾ sb^? ∪ rfi)⁺ ⊆ ctrl ∪ addr ⨾ sb^? ∪ ii ⨾ (ctrl ∪ addr ⨾ sb^?)^?.
Proof using.
eapply ct_ind_left with (P:= fun x : _ => x).
by eauto with hahn.
by rewrite <- ii0_in_ii; unfold ii0; basic_solver 12.
intros k H; desf; rewrite H; clear H.
rewrite rfi_in_ii, data_in_ii at 1.
arewrite (ii ∪ ctrl ∪ addr ⨾ sb^? ∪ ii ⊆ ii ∪ ctrl ∪ addr ⨾ sb^?).
rewrite !seq_union_l; unionL.
- by generalize ii_ii_in_ii; basic_solver 12.
- rewrite (ctrl_in_sb WF) at 2 3.
rewrite (ii_in_sb WF) at 1.
rewrite (addr_in_sb WF) at 1 2.
generalize (ctrl_sb WF) (@sb_trans G); basic_solver 12.
- rewrite (ctrl_in_sb WF) at 1 2.
rewrite (ii_in_sb WF) at 1.
rewrite (addr_in_sb WF) at 2 3.
generalize (@sb_trans G); basic_solver 12.
Qed.

Lemma r_deps_rfi WF: ⦗R⦘ ⨾ (data ∪ ctrl ∪ addr ⨾ sb^? ∪ rfi)⁺ ⨾ ⦗W⦘ ⊆ ppo.
Proof using.
rewrite (deps_rfi WF).
unfold ppo.
rewrite (wf_ctrlD WF) at 1.
rewrite (dom_l (wf_iiD WF)) at 1.
generalize addr_sb_in_cc, ctrl_in_cc, ii_in_ic, ii_cc_in_ic, cc_in_ic; basic_solver 22.
Qed.

(*
Lemma r_deps_rfi_w WF : ⦗R⦘ ⨾ (deps ∪ rfi)⁺ ⨾ ⦗W⦘ ⊆ ppo ⨾ ⦗W⦘.
Proof using.
rewrite (deps_rfi WF).
unfold ppo.
rewrite (wf_ctrlD WF) at 1.
rewrite (dom_l (wf_iiD WF)) at 1.
generalize ctrl_in_cc, ii_in_ic, ii_cc_in_ic, cc_in_ic; basic_solver 22.
Qed.
*)

Lemma ppo_detour_ppo WF : ppo ⨾  detour ⨾  ppo^?  ⊆ ppo.
Proof using.
rewrite (wf_detourD WF).
unfold ppo.
rewrite detour_in_ci.
relsf; rewrite !seqA.
arewrite_false !(⦗R⦘ ⨾ ⦗W⦘); [by type_solver|].
generalize ic_ci_in_ii, ii_ii_in_ii, ii_ic_in_ic; basic_solver 22.
Qed.

Lemma ppo_rt_detour_ppo WF : ppo ⨾ (detour ⨾ ppo^?)⁺ ⊆ ppo.
Proof using.
eapply ct_ind_left.
by eauto with hahn.
apply (ppo_detour_ppo WF).
intros k H; desf; rewrite !seqA.
by sin_rewrite (ppo_detour_ppo WF).
Qed.

Lemma r_ct_ppo_detour_ppo WF: ⦗R⦘ ⨾ (ppo ∪ ctrli ∪ detour)⁺ ⨾ ⦗RW⦘ ⊆ ppo.
Proof using.
rewrite path_union.
rewrite (dom_l (wf_detourD WF)) at 1.
relsf.
rewrite (ct_ppo_ctrli_rw_in_ppo WF).
arewrite (⦗W⦘ ⊆ ⦗RW⦘).
arewrite !((ppo ∪ ctrli)＊ ⨾ ⦗RW⦘ ⊆ ppo^?).
by generalize (ct_ppo_ctrli_rw_in_ppo WF); basic_solver 12.
arewrite !((ppo ∪ ctrli)＊ ⨾ ⦗RW⦘ ⊆ ppo^?).
by generalize (ct_ppo_ctrli_rw_in_ppo WF); basic_solver 12.
apply inclusion_union_l.
by basic_solver.
rewrite ct_seq_swap, ct_begin.
rewrite (dom_l (wf_detourD WF)) at 1; rewrite !seqA.
arewrite (⦗R⦘ ⨾ ppo^? ⨾ ⦗W⦘ ⊆ ppo) by type_solver.
arewrite (detour ⨾ ppo^? ⨾ (detour ⨾ ppo^?)＊ ⊆ (detour ⨾ ppo^?)⁺).
by rewrite <- seqA, <- ct_begin.
apply (ppo_rt_detour_ppo WF).
Qed.

End Power_ppo.


Definition pair@{i} (T:Type@{i}) (t:T): (T*T) := (t,t).

Print pair.

Check (pair True I).

Require Import Template.Template.
Quote Definition ps := pair nat 0.
Require Import String.
Require Import Ascii.
Open Scope string_scope.
Require Import List.
Import ListNotations.
Print ps.

Definition idT@{i} (T:Type@{i}) : Type@{i} := T.

Require Import Template.Ast.
Make Definition ps_from_syntax :=
(Ast.tApp (Ast.tConst "Top.pair")
  [Ast.tInd (Ast.mkInd "Coq.Init.Datatypes.nat" 0);
  Ast.tConstruct (Ast.mkInd "Coq.Init.Datatypes.nat" 0) 0]).

Print ps_from_syntax.

Make Definition idn_from_syntax :=
(Ast.tApp (Ast.tConst "Top.idT")
  [Ast.tInd (Ast.mkInd "Coq.Init.Datatypes.nat" 0)]).

Set Universe Minimization.

Print idn_from_syntax.

(*
Definition pair2@{i} (T:Type) (t:T): (T*T) := (t,t).
Top.6 is unbound.
*)

(*
Definition pair2@{i} (T:Type): Type@{i} := list T.
Error: Universe {Top.18} is unbound.
*)

(*
Definition pair2@{i} (T:Type@{i}): Type := list T.
Error: Universe {Top.22} is unbound.
Can't mix global and local universes?
*)

Definition pair2@{i j} (T:Type@{i}): Type@{j} :=  T.

Definition xx := (pair2 nat).
Print xx.
Unset Universe Minimization.
Definition xxx := (pair2 nat).
Print xxx.
(*
xx = pair2 nat
     : Type@{Top.30}
*)
Print xx.
(*
xx = pair2 nat
     : Type@{Top.30}
why same?
*)

Definition pair4@{i} (T:Type@{i}) (t:T) : (T*(Type@{i}))
  := @Coq.Init.Datatypes.pair T (Type@{i}) t T.

Print Universes.

Check (pair2 nat).


Require Import Bool Omega Setoid Program.
Require Export Schema Category SmallSchema SmallCategory.
Require Import Common EquivalenceClass.
Require Import NaturalEquivalence ComputableCategory SNaturalEquivalence ComputableSchemaCategory SmallFunctor SmallTranslation.

Set Implicit Arguments.

Set Asymmetric Patterns.

Set Universe Polymorphism.

Section Schema_Category_Equivalence.
  Variable C : SmallCategory.
  Variable S : SmallSchema.

  Hint Rewrite concatenate_noedges_p concatenate_p_noedges concatenate_addedge.
  Hint Rewrite <- concatenate_prepend_equivalent.
  Hint Rewrite concatenate_associative.

  Hint Rewrite sconcatenate_noedges_p sconcatenate_p_noedges sconcatenate_addedge.
  Hint Rewrite <- sconcatenate_prepend_equivalent.
  Hint Rewrite sconcatenate_associative.

  Hint Extern 1 (@RelationsEquivalent _ _ _ (PathsEquivalent _) _ _ _ _) => apply addedge_equivalent.
  Hint Extern 1 (@RelationsEquivalent _ _ _ (PathsEquivalent _) _ _ _ _) => apply PreCompose.

  Hint Extern 1 (@RelationsEquivalent _ _ _ (SPathsEquivalent _) _ _ _ _) => apply saddedge_equivalent.
  Hint Extern 1 (@RelationsEquivalent _ _ _ (SPathsEquivalent _) _ _ _ _) => apply SPreCompose.

  Definition path2path' s d (p : path S s d) : path' (Edge S) s d := p.
  Definition spath2spath' s d (p : spath S s d) : spath' (SEdge S) s d := p.

  Hint Rewrite concatenate_p_noedges concatenate_noedges_p concatenate_associative.
  Hint Rewrite sconcatenate_p_noedges sconcatenate_noedges_p sconcatenate_associative.

  Ltac replace_noedges' :=
    match goal with
      | [ H : ?rel NoEdges ?x |- _ ] => rewrite <- H in *; clear H
      | [ H : ?rel ?x NoEdges |- _ ] => rewrite H in *; clear H
      | [ H : ?rel SNoEdges ?x |- _ ] => rewrite <- H in *; clear H
      | [ H : ?rel ?x SNoEdges |- _ ] => rewrite H in *; clear H
    end.

  Ltac replace_noedges :=
        repeat replace_noedges';
          repeat (rewrite concatenate_p_noedges in * || rewrite concatenate_noedges_p in *);
            repeat (rewrite sconcatenate_p_noedges in * || rewrite sconcatenate_noedges_p in *).

  Ltac clear_paths :=
    repeat match goal with
             | [ H : path' _ _ _ |- _ ] => subst H || clear H
             | [ H : spath' _ _ _ |- _ ] => subst H || clear H
           end.

  Ltac replace_paths_equivalent' :=
    try replace_noedges;
      try solve [ assumption || symmetry; assumption ];
        clear_paths;
        repeat match goal with
                 | [ H : context[PathsEquivalent] |- _ ] => rewrite <- H in *; clear H
                 | [ H : context[SPathsEquivalent] |- _ ] => rewrite <- H in *; clear H
               end; clear_paths; repeat rewrite concatenate_associative in *; repeat rewrite sconcatenate_associative in *; try reflexivity || symmetry;
        repeat match goal with
                 | [ H : context[PathsEquivalent] |- _ ] => rewrite H in *; clear H
                 | [ H : context[SPathsEquivalent] |- _ ] => rewrite H in *; clear H
               end; clear_paths; repeat rewrite concatenate_associative in *; repeat rewrite sconcatenate_associative in *; try reflexivity || symmetry.

  (* TODO: Speed this up, automate this better. *)
  Definition saturate : SmallCategory.
    refine {| SObject := S;
      SMorphism := (fun s d => EquivalenceClass (@SPathsEquivalent S s d));
      (* foo := 1; *) (* uncommenting this line gives "Anomaly: uncaught exception Not_found. Please report."  Maybe I should report this?  But I haven't figured out a minimal test case. *)
      SIdentity := (fun _ => @classOf _ (@SPathsEquivalent S _ _) (Reflexive _ _ _) (Symmetric _ _ _) (Transitive _ _ _)
        SNoEdges);
      SCompose := (fun s d d' m1 m2 => @apply2_to_class _ _ _ _ _ (@SPathsEquivalent S _ _) (Reflexive _ _ _) (Symmetric _ _ _) (Transitive _ _ _)
        (@sconcatenate S S.(SEdge) s d d') (@sconcatenate_mor S s d d') m2 m1)
    |}; abstract (
      intros; apply forall__eq; intros; split; intros; simpl in *; destruct_hypotheses; clear_paths; clear_InClass;
        try (replace_noedges; assumption || symmetry; assumption);
          repeat (replace_InClass; try eexists; eauto); clear_InClass; replace_paths_equivalent'
    ).
(* abstract (intros; solve [ t | match goal with
                                          | [ p : path _ _ _ |- _ ] => solve [ induction p; t ]
                                        end ]).*)
  Defined.

  Fixpoint scompose_morphism_path s d (p : spath' C.(SMorphism) s d) : SMorphism _ s d :=
    match p with
      | SNoEdges => SIdentity s
      | SAddEdge _ _ p' E => SCompose E (scompose_morphism_path p')
    end.

  Hint Rewrite SAssociativity.

  Lemma scompose_morphism_path_alt : forall s d d' (E : Morphism C s d) (p : spath' _ d d'),
    scompose_morphism_path (sprepend p E) = SCompose (scompose_morphism_path p) E.
    induction p; simpl; autorewrite with core; auto.
  Qed.

  Hint Rewrite scompose_morphism_path_alt.

  Definition unsaturate : SmallSchema.
    refine {| SVertex := C;
      SEdge := C.(SMorphism);
      SPathsEquivalent' := (fun s d (p p' : _ s d) => scompose_morphism_path p = scompose_morphism_path p')
    |}; abstract (t; etransitivity; eauto).
  Defined.
End Schema_Category_Equivalence.

Section CategorySchemaCategory_RoundTrip.
  Variable C : SmallCategory.

  Hint Rewrite sconcatenate_noedges_p sconcatenate_p_noedges sconcatenate_addedge.
  Hint Rewrite <- sconcatenate_prepend_equivalent.
  Hint Rewrite sconcatenate_associative.

  Hint Extern 1 (@RelationsEquivalent _ _ _ (SPathsEquivalent _) _ _ _ _) => apply addedge_equivalent.
  Hint Extern 1 (@RelationsEquivalent _ _ _ (SPathsEquivalent _) _ _ _ _) => apply PreCompose.

  Hint Rewrite sconcatenate_p_noedges sconcatenate_noedges_p sconcatenate_associative.

  Ltac replace_noedges' :=
    match goal with
      | [ H : ?rel NoEdges ?x |- _ ] => rewrite <- H in *; clear H
      | [ H : ?rel SNoEdges ?x |- _ ] => rewrite <- H in *; clear H
      | [ H : ?rel ?x NoEdges |- _ ] => rewrite H in *; clear H
      | [ H : ?rel ?x SNoEdges |- _ ] => rewrite H in *; clear H
    end.

  Ltac replace_noedges :=
        repeat replace_noedges';
          repeat (rewrite concatenate_p_noedges in * || rewrite concatenate_noedges_p in * ||
            rewrite sconcatenate_p_noedges in * || rewrite sconcatenate_noedges_p in *).

  Ltac clear_paths :=
    repeat match goal with
             | [ H : path' _ _ _ |- _ ] => subst H || clear H
             | [ H : spath' _ _ _ |- _ ] => subst H || clear H
           end.

  Ltac replace_paths_equivalent' :=
    try replace_noedges;
      try solve [ assumption || symmetry; assumption ];
        clear_paths;
        repeat match goal with
                 | [ H : context[PathsEquivalent] |- _ ] => rewrite <- H in *; clear H
                 | [ H : context[SPathsEquivalent] |- _ ] => rewrite <- H in *; clear H
               end; clear_paths; repeat rewrite sconcatenate_associative in *; try reflexivity || symmetry;
        repeat match goal with
                 | [ H : context[PathsEquivalent] |- _ ] => rewrite H in *; clear H
                 | [ H : context[SPathsEquivalent] |- _ ] => rewrite H in *; clear H
               end; clear_paths; repeat rewrite sconcatenate_associative in *; try reflexivity || symmetry.

  Hint Rewrite scompose_morphism_path_alt.

  Hint Rewrite LeftIdentity RightIdentity.

  Lemma scompose_morphism_path_distr s d d' (x : spath' _ s d) (y : spath' _ d d') : scompose_morphism_path C (sconcatenate x y) = SCompose (scompose_morphism_path C y) (scompose_morphism_path C x).
    induction x; t_with t'.
  Qed.

  Hint Rewrite scompose_morphism_path_distr.

  Definition sautrate_unsaturate_functor_to : SmallFunctor C (saturate (unsaturate C)).
    refine {| SObjectOf := (fun x : C => x : (saturate (unsaturate C)));
      SMorphismOf := (fun s d m => @classOf (spath' _ s d) _ (Reflexive _ _ _) (Symmetric _ _ _) (Transitive _ _ _) (SAddEdge SNoEdges m))
    |};
    abstract (t_with t'; unfold RelationsEquivalent in *; apply forall__eq; t_with t'; destruct_hypotheses; subst;
      t_with t'; repeat eexists (AddEdge NoEdges _); eauto; t_with t'; t_rev_with t').
  Defined.

  Definition sautrate_unsaturate_roundtrip_category : Category := ComputableCategory
    (fun b => match b with
                | true => C
                | false => saturate (unsaturate C)
              end).

  Definition sautrate_unsaturate_functor_to_morphism : Morphism sautrate_unsaturate_roundtrip_category true false := sautrate_unsaturate_functor_to.

  Section chooser.
    Variable chooser : forall s d, forall cls : EquivalenceClass (SPathsEquivalent (unsaturate C) s d),
      { m : _ | exists v, m = scompose_morphism_path C v /\ InClass cls v }.

    Ltac simpl_chooser :=
      repeat match goal with
               | [ |- context[proj1_sig (chooser ?m)] ] =>
                 let hyp := constr:(proj2_sig (chooser m)) in
                   let T := type of hyp in
                     match goal with
                       | [ H : T |- _ ] => fail 1
                       | _ => let H := fresh in assert (H := hyp)
                     end
             end; simpl in *.

  (* XXX TODO: Automate this better. *)
    Definition sautrate_unsaturate_functor_from : SmallFunctor (saturate (unsaturate C)) C.
      refine {| SObjectOf := (fun x : saturate (unsaturate C) => x : C);
        SMorphismOf := (fun s d m => proj1_sig (chooser m))
      |};
      abstract (
        repeat simpl in *; intros; unfold RelationsEquivalent in *;
          simpl_chooser; destruct_hypotheses;
          clear_InClass; unfold equiv in *; t_with t'
      ).
    Defined.

    Lemma sautrate_unsaturate_roundtrip_natural_equivalence' : CategoriesNaturallyEquivalent C (saturate (unsaturate C)).
      unfold CategoriesNaturallyEquivalent.
      exists sautrate_unsaturate_functor_to.
      exists sautrate_unsaturate_functor_from.
      split;
        match goal with
          | [ |- FunctorsNaturallyEquivalent ?F ?G ] => cut (F = G);
            try solve [ let H := fresh in intro H; rewrite H; reflexivity ]
        end; functor_eq; simpl_chooser; destruct_hypotheses; try apply forall__eq; repeat split; intros; simpl in *;
        clear_InClass; unfold equiv, RelationsEquivalent in *; simpl in *; t_with t'; t_rev_with t'.
    Qed.

    Lemma sautrate_unsaturate_roundtrip' : @CategoryIsomorphism sautrate_unsaturate_roundtrip_category _ _
      (sautrate_unsaturate_functor_to : Morphism sautrate_unsaturate_roundtrip_category true false).
      simpl; unfold CategoryIsomorphism'.
      exists sautrate_unsaturate_functor_from.
      split; simpl; sfunctor_eq; simpl_chooser;
        destruct_hypotheses; unfold equiv, RelationsEquivalent in *; simpl in *; t_with t';
        apply forall__eq; intros; split; intros; replace_InClass; unfold equiv, RelationsEquivalent in *; simpl in *;
          autorewrite with core in *; assumption.
    Qed.
  End chooser.

  Section chooser'.
    Ltac simpl_chooser chooser :=
      repeat match goal with
               | [ |- context[proj1_sig (chooser ?s ?d ?m)] ] =>
                 let hyp := constr:(proj2_sig (chooser s d m)) in
                   let T := type of hyp in
                     match goal with
                       | [ H : T |- _ ] => fail 1
                       | _ => let H := fresh in assert (H := hyp)
                     end
             end; simpl in *; t_rev_with t'.

    Lemma sautrate_unsaturate_functor_from_unique chooser chooser'
      : sautrate_unsaturate_functor_from chooser = sautrate_unsaturate_functor_from chooser'.
      unfold sautrate_unsaturate_functor_from.
      sfunctor_eq; simpl_chooser chooser; simpl_chooser chooser'; destruct_hypotheses;
      clear_InClass; unfold equiv, RelationsEquivalent in *; t_with t'.
    Qed.

    Lemma sat_unsat_exist_helper'' A B : forall f : A -> B, f = (fun x => f x).
      intros; apply functional_extensionality_dep; intros; reflexivity.
    Qed.

    Lemma sat_unsat_exist_helper' A (f f' : A -> Prop) x x' H H' H'' : f = f' -> exist f x H = exist f x' H' -> exist f x H ~= exist f' x' H''.
      intros H0 H1; etransitivity; eauto.
      subst.
      assert (H' = H'') by (apply proof_irrelevance).
      subst.
      rewrite H1; clear H1.
      reflexivity.
    Qed.

    Lemma sat_unsat_exist_helper A (f : A -> Prop) x x' H H' : exist f x H = exist f x' H' -> exist f x H = exist (fun v => f v) x' H'.
      intros; apply JMeq_eq; eapply sat_unsat_exist_helper'; eauto;
        apply sat_unsat_exist_helper''.
    Qed.

    Lemma sat_unsat_exist_helper2 A (f : A -> Prop) x x' H H' : x = x' -> exist f x H = exist f x' H'.
      intro; repeat subst; f_equal; apply proof_irrelevance.
    Qed.

    (* XXX TODO: Automate this better. *)
    Lemma sautrate_unsaturate_functor_from_exists' :
      forall s d, forall cls : EquivalenceClass (SPathsEquivalent (unsaturate C) s d),
        exists! choice : { m : _ | exists v, m = scompose_morphism_path C v /\ InClass cls v }, True.
      intros s d cls.
      destruct (ClassInhabited cls) as [ x H ].
      simpl.
      eexists (exist _ (scompose_morphism_path C x) (ex_intro _ x (conj (eq_refl _) H))).
      constructor; trivial; intros x' ?.
      destruct x' as [ x' H' ].
      destruct_hypotheses; simpl in *.
      subst x'.
      apply sat_unsat_exist_helper2; replace_InClass; assumption.
    Qed.

    Lemma sautrate_unsaturate_functor_from_chooser_unique
      (chooser chooser' : forall s d
        (cls : EquivalenceClass ((SPathsEquivalent (unsaturate C)) s d)),
        { m : _ | exists v, m = scompose_morphism_path C v /\ InClass cls v}) :
      chooser = chooser'.
    Proof.
      repeat (apply functional_extensionality_dep; intro).
      destruct chooser, chooser'; destruct_hypotheses.
      apply sat_unsat_exist_helper2; clear_InClass;
        unfold equiv, RelationsEquivalent, SPathsEquivalent', unsaturate in *; simpl in *; t_with t'.
    Qed.

    Lemma chooser_helper s d (cls : EquivalenceClass ((SPathsEquivalent (unsaturate C)) s d)) : (exists _ :
      forall s' d' (cls' : EquivalenceClass ((SPathsEquivalent (unsaturate C)) s' d')),
        s = s' -> d = d' -> cls ~= cls' ->
        { m : _ | exists v, m = scompose_morphism_path C v /\ InClass cls' v}, True).
    Proof.
      destruct (ClassInhabited cls) as [ x H ].
      constructor; intros; repeat subst; trivial.
      exists (scompose_morphism_path C x); exists x; split; trivial.
    Qed.

    (* [Require Import] here, because otherwise [sat_unsat_exist_helper2]
       depends on [classic], because [classic |- proof_irrelevance] *)
    Require Import ClassicalUniqueChoice.

    Lemma dependent_unique_choice_unique : forall (A : Type) (B : A -> Type) (R : forall x, B x -> Prop),
      (forall x : A, exists! y, R x y) ->
      exists! f : (forall x, B x), forall x, R x (f x).
      intros A B R H.
      destruct (dependent_unique_choice _ _ _ H) as [ f ].
      exists f; split; try assumption.
      intros f' ?.
      apply functional_extensionality_dep; intro x.
      repeat match goal with
               | [ H : forall _ : A, _ |- _ ] => specialize (H x)
             end.
      destruct H as [ y [ H'0 H'1 ] ].
      pose (H'1 (f x)); pose (H'1 (f' x)).
      intuition.
      etransitivity; symmetry; eauto.
    Qed.

    Lemma dependent_unique_choice_unique_true : forall (A : Type) (B : A -> Type),
      (forall x : A, exists! y : B x, True) ->
      exists! f : (forall x, B x), True.
      intros A B H.
      destruct (dependent_unique_choice _ _ _ H) as [ f ].
      exists f; split; trivial.
      intros f' ?.
      apply functional_extensionality_dep; intro x.
      repeat match goal with
               | [ H : forall _ : A, _ |- _ ] => specialize (H x)
             end.
      destruct H as [ y [ H'0 H'1 ] ].
      pose (H'1 (f x)); pose (H'1 (f' x)).
      intuition.
      etransitivity; symmetry; eauto.
    Qed.

    Lemma chooser_exists : exists! _ : (forall s d
      (cls : EquivalenceClass ((SPathsEquivalent (unsaturate C)) s d)),
      { m : _ | exists v, m = scompose_morphism_path C v /\ InClass cls v }), True.
      repeat match goal with
               | [ |- exists! _ : (forall s : ?T, @?f s), True ] => cut (forall s : T, exists! _ : f s, True);
                 try solve [ let H := fresh in intro H; exact (@dependent_unique_choice_unique_true _ _ H) ];
                   intros
             end.
      apply sautrate_unsaturate_functor_from_exists'.
    Qed.
  End chooser'.

  Theorem sautrate_unsaturate_roundtrip_natrual_equivalence : CategoriesNaturallyEquivalent (saturate (unsaturate C)) C.
    destruct chooser_exists as [ chooser H ].
    symmetry. exact (sautrate_unsaturate_roundtrip_natural_equivalence' chooser).
  Qed.

  Theorem sautrate_unsaturate_roundtrip : @CategoryIsomorphism' sautrate_unsaturate_roundtrip_category _ _
    (sautrate_unsaturate_functor_to : Morphism sautrate_unsaturate_roundtrip_category true false).
    destruct chooser_exists as [ chooser H ].
    apply CategoryIsomorphism2Isomorphism'. exact (sautrate_unsaturate_roundtrip' chooser).
  Qed.
End CategorySchemaCategory_RoundTrip.

Section SchemaCategorySchema_RoundTrip.
  Variable C : SmallSchema.

  Hint Rewrite sconcatenate_noedges_p sconcatenate_p_noedges sconcatenate_addedge.
  Hint Rewrite <- sconcatenate_prepend_equivalent.
  Hint Rewrite sconcatenate_associative.

  Hint Extern 1 (@RelationsEquivalent _ _ _ (SPathsEquivalent _) _ _ _ _) => apply saddedge_equivalent.
  Hint Extern 1 (@RelationsEquivalent _ _ _ (SPathsEquivalent _) _ _ _ _) => apply SPreCompose.

  Hint Rewrite sconcatenate_p_noedges sconcatenate_noedges_p sconcatenate_associative.

  Ltac replace_noedges' :=
    match goal with
      | [ H : ?rel NoEdges ?x |- _ ] => rewrite <- H in *; clear H
      | [ H : ?rel SNoEdges ?x |- _ ] => rewrite <- H in *; clear H
      | [ H : ?rel ?x NoEdges |- _ ] => rewrite H in *; clear H
      | [ H : ?rel ?x SNoEdges |- _ ] => rewrite H in *; clear H
    end.

  Ltac replace_noedges :=
        repeat replace_noedges'; repeat (rewrite sconcatenate_p_noedges in * || rewrite sconcatenate_noedges_p in *).

  Ltac clear_paths :=
    repeat match goal with
             | [ H : spath' _ _ _ |- _ ] => subst H || clear H
           end.

  Ltac replace_paths_equivalent' :=
    try replace_noedges;
      try solve [ assumption || symmetry; assumption ];
        clear_paths;
        repeat match goal with
                 | [ H : context[SPathsEquivalent] |- _ ] => rewrite <- H in *; clear H
               end; clear_paths; repeat rewrite sconcatenate_associative in *; try reflexivity || symmetry;
        repeat match goal with
                 | [ H : context[SPathsEquivalent] |- _ ] => rewrite H in *; clear H
               end; clear_paths; repeat rewrite sconcatenate_associative in *; try reflexivity || symmetry.

  Hint Rewrite scompose_morphism_path_alt.

  Hint Rewrite SLeftIdentity SRightIdentity.
  Hint Rewrite scompose_morphism_path_distr.

  Definition unsaturate_saturate_translation_to_PathOf s d (e : C.(SEdge) s d) : spath (unsaturate (saturate C)) s d :=
    SAddEdge SNoEdges (@classOf (spath' _ s d) _ (Reflexive _ _ _) (Symmetric _ _ _) (Transitive _ _ _) (SAddEdge SNoEdges e)).

  Hint Unfold unsaturate_saturate_translation_to_PathOf.

  Lemma unsaturate_saturate_translation_to_PathOf_InClass s d (p : spath C s d) :
    InClass (scompose_morphism_path (saturate C) (stransferPath _ unsaturate_saturate_translation_to_PathOf p)) p.
    induction p; simpl; repeat esplit; try reflexivity; t_with t'; try apply AddEdge_mor; try reflexivity; assumption.
  Qed.

  Hint Rewrite sconcatenate_p_addedge.
  Hint Resolve unsaturate_saturate_translation_to_PathOf_InClass.

  Ltac unsaturate_saturate_translation_to_PathOf_InClass' :=
    unfold path, spath in *;
    match goal with
      | [ H : InClass ?C _, p : spath' _ _ _ |- _ ] =>
        assert (InClass C p) by (apply unsaturate_saturate_translation_to_PathOf_InClass);
          clear_InClass; unfold equiv in *;
            try match goal with
                  | [ H : InClass C _, H' : context[C] |- _ ] => fail 1
                  | [ H : InClass C _ |- context[C] ] => fail 1
                  | [ H : InClass C _ |- _ ] => clear H
                  | _ => idtac
                end
      | [ p : spath' _ _ _ |- InClass ?C _ ] =>
        assert (InClass C p) by (apply unsaturate_saturate_translation_to_PathOf_InClass);
          clear_InClass; unfold equiv in *
    end.

  Ltac unsaturate_saturate_translation_to_PathOf_InClass := repeat unsaturate_saturate_translation_to_PathOf_InClass'.

  Lemma unsaturate_saturate_translation_to_PathOf_equivalent s d (p : spath C s d) :
    SPathsEquivalent _ _ _ (stransferPath _ unsaturate_saturate_translation_to_PathOf p)
    (SAddEdge SNoEdges (@classOf (spath' _ s d) _ (Reflexive _ _ _) (Symmetric _ _ _) (Transitive _ _ _) p)).
    induction p; unfold RelationsEquivalent, unsaturate_saturate_translation_to_PathOf in *; simpl;
    apply forall__eq; intros; split; intros; simpl in *; destruct_hypotheses; replace_noedges; repeat esplit; try reflexivity;
      eauto; autorewrite with core in *;
        try solve [ eauto || symmetry; eauto || etransitivity; eauto; try (symmetry; eauto) ];
          repeat match goal with
                   | [ H : context[@eq] |- _ ] => clear H
                 end.
    unsaturate_saturate_translation_to_PathOf_InClass.
    replace_paths_equivalent'.
  Qed.

  Definition unsautrate_saturate_translation_to : SmallTranslation C (unsaturate (saturate C)).
    refine {| SVertexOf := (fun x : C => x : (unsaturate (saturate C)));
      SPathOf := unsaturate_saturate_translation_to_PathOf (* (fun s d e => AddEdge NoEdges (@classOf (path' _ s d) _ (Reflexive _ _ _) (Symmetric _ _ _) (Transitive _ _ _) (AddEdge NoEdges e))) *)
    |};
    abstract (
      t_with t'; unfold RelationsEquivalent, unsaturate_saturate_translation_to_PathOf in *; apply forall__eq; t_with t';
        unsaturate_saturate_translation_to_PathOf_InClass;
        solve [ assumption || symmetry; assumption || etransitivity; eauto; symmetry; eauto ]
    ).
  Defined.

  Lemma unsaturate_saturate_cmp_eq_eqv s d (p1 p2 : spath (unsaturate (saturate C)) s d) :
    (scompose_morphism_path (saturate C) p1 = scompose_morphism_path (saturate C) p2) =
    (SPathsEquivalent _ _ _ p1 p2).
    simpl; unfold RelationsEquivalent in *; trivial.
  Qed.

  Definition unsautrate_saturate_roundtrip_category : Category := ComputableSchemaCategory
    (fun b => match b with
                | true => C
                | false => unsaturate (saturate C)
              end).

  Section chooser.
    Variable chooser : forall s d, forall cls : EquivalenceClass ((SPathsEquivalent C) s d),
      { p : _ | InClass cls p }.

    Ltac simpl_chooser :=
      repeat match goal with
               | [ |- context[proj1_sig (chooser ?m)] ] =>
                 let hyp := constr:(proj2_sig (chooser m)) in
                   let T := type of hyp in
                     match goal with
                       | [ H : T |- _ ] => fail 1
                       | _ => let H := fresh in assert (H := hyp); try rewrite <- H in *
                     end
             end; simpl in *; trivial.

    Ltac simpl_chooser_more := simpl_chooser;
      repeat match goal with
               | [ H : context[proj1_sig (chooser ?m)] |- _ ] =>
                 let hyp := constr:(proj2_sig (chooser m)) in
                   let T := type of hyp in
                     match goal with
                       | [ H : T |- _ ] => fail 1
                       | _ => let H := fresh in assert (H := hyp); try rewrite <- H in *
                     end
             end; simpl in *; trivial.

    Definition unsaturate_saturate_translation_from_PathOf s d (e : Edge (unsaturate (saturate C)) s d) : path C s d :=
      proj1_sig (chooser e).

    Hint Unfold unsaturate_saturate_translation_from_PathOf.

    Lemma unsaturate_saturate_translation_from_PathOf_eqv s d (p : spath (unsaturate (saturate C)) s d) :
      SPathsEquivalent _ _ _
      (stransferPath _ (fun s d (e : SEdge (unsaturate (saturate C)) s d) => proj1_sig (chooser e)) p)
      (proj1_sig (chooser (scompose_morphism_path (saturate C) p))).
      induction p; simpl in *; simpl_chooser_more.
      destruct_hypotheses; clear_InClass.
      unfold equiv in *.
      repeat_subst_mor_of_type @spath'.
      match goal with
        | [ H : _ |- _ ] => rewrite H; apply sconcatenate_mor; eauto
      end.
    Qed.

    Hint Rewrite sconcatenate_p_addedge.
    Hint Resolve unsaturate_saturate_translation_from_PathOf_eqv.

    Definition unsautrate_saturate_translation_from : SmallTranslation (unsaturate (saturate C)) C.
      refine {| SVertexOf := (fun x : unsaturate (saturate C) => x : C);
        SPathOf := (fun s d e => proj1_sig (chooser e))
      |};
      abstract (
        repeat simpl in *; intros; unfold RelationsEquivalent in *;
          do 2 (etransitivity; try apply unsaturate_saturate_translation_from_PathOf_eqv; symmetry);
            match goal with
              | [ H : _ |- _ ] => rewrite H; reflexivity
            end
      ).
    Defined.

    Hint Rewrite apply2_to_classOf unsaturate_saturate_translation_to_PathOf_equivalent.

    (* TODO: Simplify this proof. *)
    Lemma unsautrate_saturate_roundtrip' : @CategoryIsomorphism unsautrate_saturate_roundtrip_category _ _
      (@classOf _ _ (@SmallTranslationsEquivalent_refl _ _) (@SmallTranslationsEquivalent_sym _ _) (@SmallTranslationsEquivalent_trans _ _)
        unsautrate_saturate_translation_to : Morphism unsautrate_saturate_roundtrip_category true false).
      eexists (@classOf _ _ (@SmallTranslationsEquivalent_refl _ _) (@SmallTranslationsEquivalent_sym _ _) (@SmallTranslationsEquivalent_trans _ _)
        unsautrate_saturate_translation_from).
      split; stranslation_eq; rewrite apply2_to_classOf;
        apply forall__eq; intros; split; intros;
          clear_InClass; unfold equiv in *;
            repeat_subst_mor_of_type @SmallTranslation;
            repeat esplit; intros; eauto; try reflexivity; simpl in *; autorewrite with core in *;
              unfold RelationsEquivalent in *;
                unfold STransferPath, unsautrate_saturate_translation_to, unsautrate_saturate_translation_from in *;
                  simpl; try rewrite unsaturate_saturate_translation_to_PathOf_equivalent;
                    autorewrite with core in *;
                      simpl_chooser; auto; try solve [ symmetry; auto ];
                        simpl;
                          autorewrite with core;
                            apply forall__eq; intros; split; intros; simpl in *; destruct_hypotheses; auto;
                              repeat (clear_InClass; eexists; eauto; try reflexivity); clear_InClass;
                                unfold equiv in *; auto;
                                  repeat_subst_mor_of_type @spath'; autorewrite with core; reflexivity.
    Qed.
  End chooser.

  Section chooser'.
    Ltac simpl_chooser chooser :=
      repeat match goal with
               | [ |- context[proj1_sig (chooser ?s ?d ?m)] ] =>
                 let hyp := constr:(proj2_sig (chooser s d m)) in
                   let T := type of hyp in
                     match goal with
                       | [ H : T |- _ ] => fail 1
                       | _ => let H := fresh in assert (H := hyp)
                     end
             end; simpl in *; t_rev_with t'.

    Lemma unsautrate_saturate_translation_from_unique chooser chooser'
      : SmallTranslationsEquivalent (unsautrate_saturate_translation_from chooser) (unsautrate_saturate_translation_from chooser').
      unfold unsautrate_saturate_translation_from.
      stranslation_eqv; simpl_chooser chooser; simpl_chooser chooser'; destruct_hypotheses;
      clear_InClass; unfold equiv, RelationsEquivalent in *; t_with t'.
    Qed.

    (* XXX TODO: Automate this better. *)
    Lemma unsautrate_saturate_translation_from_exists' :
      forall s d, forall cls : EquivalenceClass ((SPathsEquivalent C) s d),
        exists choice : { p : _ | InClass cls p }, True.
      intros s d cls.
      destruct (ClassInhabited cls) as [ x H ].
      simpl.
      eexists (exist _ x H).
      trivial.
    Qed.

    Require Import IndefiniteDescription.

    Lemma unsat_sat_chooser_exists : exists _ : (forall s d
      (cls : EquivalenceClass ((SPathsEquivalent C) s d)),
      { p : _ | InClass cls p }), True.
      constructor; trivial; intros s d cls.
      apply constructive_indefinite_description.
      destruct (unsautrate_saturate_translation_from_exists' cls) as [ [ p H ] ].
      eexists; eauto.
    Qed.
  End chooser'.

  Theorem unsautrate_saturate_roundtrip : @CategoryIsomorphism' unsautrate_saturate_roundtrip_category _ _
    (@classOf _ _ (@SmallTranslationsEquivalent_refl _ _) (@SmallTranslationsEquivalent_sym _ _) (@SmallTranslationsEquivalent_trans _ _)
      unsautrate_saturate_translation_to : Morphism unsautrate_saturate_roundtrip_category true false).
    destruct unsat_sat_chooser_exists as [ chooser H ].
    apply CategoryIsomorphism2Isomorphism'. exact (unsautrate_saturate_roundtrip' chooser).
  Qed.
End SchemaCategorySchema_RoundTrip.

Section CatSchIsomorphic.
  Section Cat2Sch.
    Variable O : Type.
    Variable Object2Cat : O -> Category.

    Local Coercion Object2Cat : O >-> Category.

    Set Printing Universes.
(*    Definition Cat2Sch := ComputableSchemaCategory (fun o => unsaturate o).*)

  End Cat2Sch.
End CatSchIsomorphic.