Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.Logic.Eqdep.

Require Export CatSem.PCF_order_comp.RPCF_rep_cat.
Require Export CatSem.PCF_order_comp.RPCF_syntax_init.

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

Section unique.

Variable R : REP.

Variable g : PCFE_rep ---> R.

Lemma initR_unique : g == initR R.
Proof.
  simpl.
  assert (H : forall t, tcomp (initR R) t = tcomp g t).
  assert (H':= ttriag g).
  simpl in *.
  auto.
  apply (eq_rep (H:=H)).
  simpl.
  intros V t y.
  destruct y as [t y].
  simpl.

  destruct g.
  simpl in *.

  assert (H' : type_mor R = tcomp) by
     (apply functional_extensionality;
         intros; auto).

  generalize dependent rep_Hom_monad.
  generalize dependent ttriag.
  generalize dependent H.

  rewrite <- H'.

  simpl.
  intros.

  assert (Hl := rlift_transp_id (Q:=R) H).
  simpl in *.
  rewrite Hl.
  rewrite (UIP_refl _ _ (H t)).
  simpl.

  induction y;
  simpl.

  assert (Hb:=bottom_hom (PCFPO_rep_Hom_struct :=
            rep_gen_Hom_monad_struct) t (c:=V) tt).
  simpl in *.

  rewrite (UIP_refl _ _ (ttriag _)) in Hb.
  simpl in *.
  auto.

  destruct c.

    assert (Hb:=nats_hom n (PCFPO_rep_Hom_struct :=
            rep_gen_Hom_monad_struct)  (c:=V) tt).
    simpl in *.

    rewrite (UIP_refl _ _ (ttriag _)) in Hb.
    simpl in * ; auto.

    assert (Hb:=ttt_hom (PCFPO_rep_Hom_struct :=
            rep_gen_Hom_monad_struct)  (c:=V) tt).
    simpl in *.

    rewrite (UIP_refl _ _ (ttriag _)) in Hb.
    simpl in * ; auto.

    assert (Hb:=fff_hom (PCFPO_rep_Hom_struct :=
            rep_gen_Hom_monad_struct)  (c:=V) tt).
    simpl in *.

    rewrite (UIP_refl _ _ (ttriag _)) in Hb.
    simpl in * ; auto.

    assert (Hb:=Succ_hom (PCFPO_rep_Hom_struct :=
            rep_gen_Hom_monad_struct) (c:=V) tt).
    simpl in *.

    rewrite (UIP_refl _ _ (ttriag _)) in Hb.
    simpl in * ; auto.

    assert (Hb:=Pred_hom (PCFPO_rep_Hom_struct :=
            rep_gen_Hom_monad_struct)  (c:=V) tt).
    simpl in *.

    rewrite (UIP_refl _ _ (ttriag _)) in Hb.
    simpl in * ; auto.

    assert (Hb:=Zero_hom (PCFPO_rep_Hom_struct :=
            rep_gen_Hom_monad_struct)  (c:=V) tt).
    simpl in *.

    rewrite (UIP_refl _ _ (ttriag _)) in Hb.
    simpl in * ; auto.

    assert (Hb:=CondN_hom (PCFPO_rep_Hom_struct :=
            rep_gen_Hom_monad_struct)  (c:=V) tt).
    simpl in *.

    rewrite (UIP_refl _ _ (ttriag _)) in Hb.
    simpl in * ; auto.

    assert (Hb:=CondB_hom (PCFPO_rep_Hom_struct :=
            rep_gen_Hom_monad_struct)  (c:=V) tt).
    simpl in *.

    rewrite (UIP_refl _ _ (ttriag _)) in Hb.
    simpl in * ; auto.

  (*1*)
  assert (Hw:=gen_rmonad_hom_rweta
     ((*gen_RMonad_Hom_struct := *)rep_Hom_monad)).
     simpl in Hw.
  assert (Hw' := Hw _ _ (ctype _ v)).
  simpl in Hw'.
  auto.

  rewrite <- IHy1.
  rewrite <- IHy2.
  assert (Happ:=app_hom (PCFPO_rep_Hom_struct :=
            rep_gen_Hom_monad_struct) (r:=s) (s:=t) (y1,y2)).
  simpl in *.

  rewrite (UIP_refl _ _ (ttriag s)) in Happ.
  rewrite (UIP_refl _ _ (ttriag t)) in Happ.
  rewrite (UIP_refl _ _ (ttriag (s ~> t))) in Happ.
  simpl in *.
  simpl in *.
  auto.
  (*2*)
  rewrite <- IHy.
  assert (Habs:=abs_hom (PCFPO_rep_Hom_struct :=
            rep_gen_Hom_monad_struct) (r:=t) (s:=s)  y ).
  simpl in *.

  rewrite (UIP_refl _ _ (ttriag s)) in Habs.
  rewrite (UIP_refl _ _ (ttriag t)) in Habs.
  rewrite (UIP_refl _ _ (ttriag _)) in Habs.
  simpl in *.
  auto.

  rewrite <- IHy.
  assert (Happ:=rec_hom (PCFPO_rep_Hom_struct :=
            rep_gen_Hom_monad_struct) (t:=t) y).
  simpl in *.

  rewrite (UIP_refl _ _ (ttriag t)) in Happ.
  rewrite (UIP_refl _ _ (ttriag (t ~> t))) in Happ.
  simpl in *.
  auto.
Qed.

End unique.

Hint Resolve initR_unique : fin.

Obligation Tactic := fin.

Program Instance PCF_initial : Initial REP := {
  Init := PCFE_rep ;
  InitMor R := initR R ;
  InitMorUnique R := @initR_unique R
}.

Print Assumptions PCF_initial.


(** * Proof Trick: Small Inversions *)

(** ** 1 Introduction *)

Inductive mul3 : nat -> Prop :=
| T0 : mul3 0
| T3 : forall n : nat, mul3 n -> mul3 (3 + n).

Fixpoint mod3 (n : nat) : nat :=
match n with
| S (S (S n')) => mod3 n'
| n' => n'
end.

(** ** 2 Two Facets of Inversion *)

(** ** 3 Inversion by Diagonalization of Absurd Hypotheses *)

(* 11 lines *)
Definition absurd2_prog :
  forall P : Prop, mul3 2 -> P :=
    fun (P : Prop) (H : mul3 2) =>
    let
      diag (x : nat) :=
      match x with
      | 2 => P
      | _ => mul3 2
      end
    in
      match H in (mul3 n) return (diag n) with
      | T0     => H
      | T3 _ _ => H
      end.

Inductive nd (f g : nat -> nat) (c : nat) : nat -> Prop :=
| Nc : nd f g c c
| Nf : forall n : nat, nd f g c n -> nd f g c (f n)
| Ng : forall n : nat, nd f g c n -> nd f g c (g n).

Definition pl3 := plus 3.
Definition pl5 := plus 5.

Lemma absurd_nd4_interac :
  forall C : Prop, nd pl3 pl5 7 4 -> C.
Proof.
  intros C H.
  pose (diag x := match x with | 4 => C | _ => nd pl3 pl5 7 4 end).
  change (diag 4).
  case H; intros.
    apply H.
    case H0; intros; apply H.
    apply H.
  Show Proof. (* 21 lines *)
Restart.
  intros C H.
  pose (diag x := match x with | 4 => C | _ => nd pl3 pl5 7 4 end).
  change (diag 4).
  case H; (intros; exact H) || (intros n N; case N; intros; exact H).
  Show Proof. (* 21 lines *)
Qed.

(* 12 lines, effectively 10 *)
Definition absurd_nd4_prog :
  forall C : Prop, nd pl3 pl5 7 4 -> C :=
    fun (C : Prop) (H : nd pl3 pl5 7 4) =>
    let
      diag x := match x with | 4 => C | _ => nd pl3 pl5 7 4 end
    in
      match H in (nd _ _ _ n) return (diag n) with
      | Nf _ _ _ _ N =>
        match N in (nd _ _ _ n0) return (diag (pl3 n0)) with
        | Nc _ _ _     => H
        | Nf _ _ _ _ _ => H
        | Ng _ _ _ _ _ => H
        end
      | _ => H
      end.

(** ** 4 Eliminating Strong Elimination *)

(** ** 5 Recursively Absurd Hypotheses *)

Require Import Arith.

Lemma invmul10 : mul3 10 -> 0 = 1.
Proof.
  intro H.
  pose (diag x := if Nat.eqb x 10 then 1 else 0).
  change (0 = diag 10).
  do 4 (case H; clear H; reflexivity || intros).
  Show Proof. (* 20 lines *)
Restart.
  intro. do 4 (inversion H; clear - H1; rename H1 into H).
  Show Proof. (* 148 lines *)
Qed.

(** ** 6 Size of Proof Terms *)

Section wut.

Variable p : nat.

Definition tr15 : nat -> Prop :=
  nd (plus 6) (plus 9) 15.

(** Proofscript from the paper doesn't work. *)
Lemma tr15_beq :
  tr15 40 -> tr15 p.
Proof.
  intros t40.
  pose (diag n := if Nat.eqb n 40 then p else n).
  change (tr15 (diag 40)).
  assert (gen : forall n : nat, tr15 n -> tr15 (diag n)).
(*    repeat (exact t40 || intros n t; exact t40 || (case t; clear t n)).*)
    intros n t; case t; clear n t.
      constructor.
      intros n t. case t; clear n t.
Abort.

Lemma tr15_inv :
  tr15 40 -> tr15 p.
Proof.
  unfold tr15. intros t40.
  repeat match goal with
  | H : nd _ _ _ _ |- _ => inversion_clear H
  end.
  Show Proof. (* 8985 lines *)
Qed.

End wut.

(** ** 7 Other experiments *)

Section wut2.

Variable A : nat -> Prop.

Inductive l10 : nat -> Prop :=
| l10ini : l10 10
| l10rec : forall n : nat, A n -> l10 (pred n).

Lemma inv_lA0 :
  l10 0 -> A 0 \/ A 1.
Proof.
  intro l.
  match goal with
  | l : ?P |- ?Q =>
    pose (diag n := match n with 0 => Q | _ => P end)
  end.
  change (diag 0).
  case l; cbn; auto.
  do 2 (destruct n; cbn; auto).
  Show Proof. (* 17 lines *)
Restart.
  intros. inversion H. destruct n; cbn; auto.
  Show Proof. (* 39 lines *)
Qed.

End wut2.

(** ** 8 Application to Operational Semantics *)

(** ** 9 Conclusion and Further Work *)


Require Import RamifyCoq.msl_ext.ramify_tactics.
Require Import RamifyCoq.msl_ext.msl_ext.
Require Import VST.msl.msl_direct.
Require Import RamifyCoq.msl_ext.sepalg.

Local Open Scope pred.

Definition ocon {A: Type}{JA: Join A} (p q:pred A) : pred A :=
  fun h:A => exists h1 h2 h3 h12 h23, join h1 h2 h12 /\ join h2 h3 h23 /\ join h12 h3 h /\ p h12 /\ q h23.

Notation "P ⊗ Q" := (ocon P Q) (at level 40, left associativity) : pred.

Program Definition owand {A: Type}{JA: Join A} (p q:pred A) : pred A :=
  fun h23:A => forall h1 h2 h3 h12 h123, join h1 h2 h12 -> join h2 h3 h23 -> join h12 h3 h123 -> p h12 -> q h123.

Lemma ocon_emp_d {A}{JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{CA: Canc_alg A}: forall P: pred A, P ⊗ emp = P.
Proof.
  intros; apply pred_ext; hnf; intros; simpl in *; intros.
  destruct_ocon H h; try_join h2 h3 h23'; equate_join h23 h23'.
  rewrite (H3 _ _ (join_comm H5)) in H.
  generalize (join_positivity H H1); intro; rewrite H4; trivial.
  exists a, (core a), (core a), a, (core a).
  generalize (core_unit a); intro.
  unfold unit_for in H0.
  repeat split; auto.
  apply core_duplicable.
  apply core_identity.
Qed.

Lemma ocon_TT_d {A}{JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{CA: Canc_alg A}: forall P: pred A, P ⊗ TT = P * TT.
Proof.
  intros; apply pred_ext; hnf; intros; simpl in *; intros.
  + destruct_ocon H h.
    exists h12, h3; auto.
  + destruct H as [? [? [? [? ?]]]].
    exists x, (core x), x0, x, x0.
    repeat split; auto.
    - apply join_comm, core_unit.
    - apply join_core2 in H.
      rewrite H.
      apply core_unit.
Qed.

Lemma andp_ocon_d {A}{JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}: forall P Q, P && Q |-- P ⊗ Q.
Proof.
  intros.
  hnf; intros; simpl in *; intros.
  destruct H.
  remember (core a) as u.
  exists u, a, u, a, a.
  repeat split; try rewrite Hequ; auto;
  try apply core_unit;
  apply join_comm; apply core_unit.
Qed.

Lemma ocon_andp_prop_d {A}{JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}: forall P Q R, P ⊗ (!!Q && R) = !!Q && (P ⊗ R).
Proof.
  intros; apply pred_ext; hnf; intros; simpl in *.
  + destruct H as [h1 [h2 [h3 [h12 [h23 [? [? [? [? [? ?]]]]]]]]]].
    split; auto. exists h1, h2, h3, h12, h23. intuition.
  + destruct H as [? [h1 [h2 [h3 [h12 [h23 [? [? [? [? ?]]]]]]]]]].
    exists h1, h2, h3, h12, h23. unfold andp. intuition.
Qed.

Lemma sepcon_ocon_d {A}{JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}: forall P Q, P * Q |-- P ⊗ Q.
Proof.
  intros; hnf; intros; simpl in *; intros.
  destruct H as [y [z [? [? ?]]]].
  remember (core z) as u.
  exists y, u, z, y, z.
  repeat split; auto.
  generalize (join_core H); intro.
  generalize (join_core (join_comm H)); intro.
  rewrite Hequ.
  replace (core z) with (core y).
  apply join_comm, core_unit.
  rewrite H2, H3; trivial.
  rewrite Hequ. apply core_unit.
Qed.

Lemma ocon_sep_true_d {A}{JA: Join A}{PA: Perm_alg A}: forall P Q, P ⊗ Q |-- P * TT.
Proof.
  intros; hnf; intros; simpl in *; intros.
  destruct_ocon H h.
  exists h12, h3.
  repeat split; auto.
Qed.

Lemma ocon_wand_d {A}{JA: Join A}{PA: Perm_alg A}: forall P Q, P ⊗ Q = EX R : pred A, (R -* P) * (R -* Q) * R.
Proof.
  intros; apply pred_ext; hnf; intros; simpl in *.
  destruct_ocon H h; try_join h2 h3 h23'; equate_join h23 h23'; try_join h1 h3 h13.
  exists (exactly h2), h13, h2; repeat split; simpl; auto; exists h1, h3; repeat split; auto.
  intros h2' h12'; intros; rewrite H8 in *; equate_join h12 h12'; trivial.
  intros h2' h23'; intros; rewrite H8 in *; equate_join h23 h23'; trivial.
  (* another direction *)
  destruct H as [R [w13 [w2 [? [[w1 [w3 [? [HP HQ]]]] HR]]]]].
  try_join w2 w3 w23; try_join w1 w2 w12.
  exists w1, w2, w3, w12, w23; repeat split; auto.
  apply (HP w2 w12). auto. trivial. apply (HQ w2 w23); auto.
Qed.

Lemma ocon_comm_d {A}{JA: Join A}{PA: Perm_alg A}: forall P Q, P ⊗ Q = Q ⊗ P.
Proof.
  intros; apply pred_ext; hnf; intros; simpl in *; intros;
  destruct_ocon H h; exists h3, h2, h1, h23, h12;
  repeat split; auto; try_join h2 h3 h23'; equate_join h23 h23'; auto.
Qed.

Lemma cross_rev_d {A}{JA: Join A}{PA: Perm_alg A}: forall h1 h2 h3 h4
  h12 h34 h13 h24 h1234, join h1 h2 h12 -> join h1 h3 h13 -> join h3 h4
  h34 -> join h2 h4 h24 -> join h12 h34 h1234 -> join h13 h24 h1234.
Proof.
  intros; try_join h2 h34 h234;
  try_join h2 h4 h24'; equate_join h24 h24';
  try_join h1 h3 h13'; equate_join h13 h13'; auto.
Qed.

Lemma ocon_assoc_d {A}{JA: Join A}{PA: Perm_alg A}{CA: Cross_alg A}:
  forall P Q R: pred A, P ⊗ Q ⊗ R = P ⊗ (Q ⊗ R).
Proof.
  intros; apply pred_ext; hnf; intros; simpl in *; intros.
  destruct H as [w124 [w567 [w3 [w124567 [w3567 [? [? [? [[w15 [w47 [w26 [w1457 [w2467 [? [? [? [? ?]]]]]]]]] ?]]]]]]]]].
  destruct (cross_split _ _ _ _ _ H H4) as [[[[w14 w2] w57] w6] [? [? [? ?]]]].
  destruct (cross_split _ _ _ _ _ H2 H10) as [[[[w1 w5] w4] w7] [? [? [? ?]]]].
  try_join w5 w47 w457; try_join w3 w26 w236; try_join w236 w457 w234567.
  exists w1, w457, w236, w1457, w234567; repeat split; auto.
  try_join w2 w4 w24; try_join w6 w7 w67; try_join w3 w5 w35.
  exists w24, w67, w35, w2467, w3567; repeat split; auto.
  apply (cross_rev_d w2 w6 w4 w7 w26 w47); auto.
  apply (cross_rev_d w47 w5 w26 w3 w457 w236); auto.
  (* another direction *)
  destruct H as [w1 [w457 [w236 [w1457 [w234567 [? [? [? [? [w24 [w67 [w35 [w2467 [w3567 [? [? [? [? ?]]]]]]]]]]]]]]]]]].
  destruct (cross_split _ _ _ _ _ H0 H5) as [[[[w47 w5] w26] w3] [? [? [? ?]]]].
  destruct (cross_split _ _ _ _ _ H3 H10) as [[[[w4 w2] w7] w6] [? [? [? ?]]]].
  try_join w26 w1457 w124567; try_join w5 w67 w567; try_join w5 w7 w57; try_join w1 w4 w14;
  try_join w14 w26 w1246; try_join w2 w14 w124.
  exists w124, w567, w3, w124567, w3567; repeat split; auto.
  apply join_comm; apply (cross_rev_d w6 w2 w57 w14 w26 w1457); auto.
  try_join_through w67 w5 w7 w57'; equate_join w57 w57'; auto.
  try_join w1 w5 w15; exists w15, w47, w26, w1457, w2467;
  repeat split; auto.
Qed.

Lemma ocon_derives_d {A} {JA: Join A}{PA: Perm_alg A}: forall p q p' q', (p |-- p') -> (q |-- q') -> (p ⊗ q |-- p' ⊗ q').
Proof.
  repeat (intros; hnf).
  simpl in H1.
  destruct_ocon H1 w.
  exists w1,w2,w3,w12,w23.
  repeat split; auto.
Qed.

Lemma owand_ocon_adjoint_d {A} {JA: Join A}{PA: Perm_alg A}: forall P Q R, ocon P Q |-- R <-> P |-- owand Q R.
Proof.
  intros.
  rewrite ocon_comm_d.
  unfold ocon, owand, derives.
  simpl.
  split; intros.
  + apply H.
    exists h1, h2, h3, h12, a.
    repeat split; auto.
  + destruct H0 as [h1 [h2 [h3 [h12 [h23 [? [? [? [? ?]]]]]]]]].
    specialize (H h23 H4).
    specialize (H h1 h2 h3 h12 a).
    apply H; auto.
Qed.

Lemma ocon_contain_d {A} {JA: Join A} {PA: Perm_alg A} {SA: Sep_alg A}: forall P Q, Q |-- P * TT -> Q |-- ocon P Q.
Proof.
  unfold ocon, owand, derives; simpl; intros.
  destruct (H a H0) as [y [z [? [? ?]]]].
  exists (core y), y, z, y, a.
  repeat split; auto.
  apply core_unit.
Qed.

Lemma precise_ocon_contain_d {A} {JA: Join A} {PA: Perm_alg A} {SA: Sep_alg A} {CA: Canc_alg A} {DA: Disj_alg A} : forall P Q, precise P -> Q |-- P * TT -> Q = ocon P Q.
Proof.
  intros; apply pred_ext; [apply ocon_contain_d; auto |].
  unfold ocon, owand, derives in *; simpl in *.
  intros.
  destruct H1 as [h1 [h2 [h3 [h12 [h23 [? [? [? [? ?]]]]]]]]].
  destruct (H0 _ H5) as [y [z [? [? ?]]]].
  try_join h2 h3 h23'. equate_join h23 h23'. assertSub y a HS1.
  equate_precise_direct y h12.
  try_join z h1 h3'. equate_canc h3 h3'.
  assert (identity h1).
  1: {
    try_join h1 h3 h_temp.
    assertSub h1 h3 H12.
    eapply join_sub_joins_identity; eauto.
  }
  apply join_comm in H4.
  apply H9 in H10; apply H9 in H4.
  subst.
  auto.
Qed.

Definition disjointed {A: Type} {JA: Join A} (P Q: pred A):=
  forall h1 h2 h3 h12 h23,
  join h1 h2 h12 -> join h2 h3 h23 -> P h12 -> Q h23 -> identity h2 /\ joins h1 h3.

Lemma ocon_sepcon_d {A: Type} {JA: Join A} {SA: Sep_alg A} {PA : Perm_alg A}:
  forall P Q, disjointed P Q -> ocon P Q |-- P * Q.
Proof.
  unfold ocon, sepcon, disjointed, derives; simpl.
  intros.
  destruct H0 as [h1 [h2 [h3 [h12 [h23 [? [? [? [? ?]]]]]]]]].
  destruct (H h1 h2 h3 h12 h23 H0 H1 H3 H4) as [? ?].
  apply join_comm in H0.
  apply H5 in H0.
  apply H5 in H1.
  subst.
  exists h12, h23.
  auto.
Qed.

Lemma disj_emp_d {A: Type} {JA: Join A} {SA: Sep_alg A} {PA : Perm_alg A} {CA: Canc_alg A}: forall P, disjointed P emp.
Proof.
  intros.
  unfold disjointed. simpl; intros.
  pose proof split_identity _ _ H0 H2.
  pose proof split_identity _ _ (join_comm H0) H2.
  pose proof identities_unique H3 H4 (ex_intro _ h23 H0).
  subst.
  split; eauto.
Qed.

Lemma disj_comm_d {A: Type} {JA: Join A} {PA: Perm_alg A}: forall P Q, disjointed P Q -> disjointed Q P.
Proof.
  unfold disjointed; intros.
  specialize (H h3 h2 h1 h23 h12).
  do 2 (spec H; [apply join_comm; auto |]).
  do 2 (spec H; [auto |]).
  destruct H; split; auto.
  apply joins_comm; auto.
Qed.

Lemma disj_derives_d {A: Type} {JA: Join A} {PA: Perm_alg A}:
  forall P P' Q Q', P |-- P' -> Q |-- Q' -> disjointed P' Q' -> disjointed P Q.
Proof.
  unfold derives, disjointed.
  intros.
  apply H1 with h12 h23; auto.
Qed.

(**************************************************************************

          |------------------------------------------|
          |                                          |
          |                                          |
          |                                          |
          |                     P                    |
          |                                          |
          |                                          |
|---------|----------|-----------------------|-------|------------|
|         |          |                       |       |            |
|         |    p1    |         p2            |   p3  |            |
|         |          |                       |       |            |
|         |------------------------------------------|            |
|                    |                       |                    |
|                    |                       |                    |
|        r1          |          r2           |         r3         |
|                    |                       |                    |
|                    |                       |                    |
|                    |                       |                    |
|--------------------|-----------------------|--------------------|

**************************************************************************)

Lemma disj_ocon_right_d {A: Type} {JA: Join A} {SA: Sep_alg A} {PA : Perm_alg A} {CA: Canc_alg A} {CrA: Cross_alg A} {TA: Trip_alg A}:
  forall P Q R, disjointed P Q -> disjointed P R -> disjointed P (ocon Q R).
Proof.
  unfold ocon, disjointed, precise; simpl.
  intros P Q R ? ? hP hp1p2p3 hr1r2r3 hPp h123.
  intros.
  destruct H4 as [h1 [h2 [h3 [h12 [h23 [? [? [? [? ?]]]]]]]]].
  destruct (join_assoc H4 H6) as [h23' [? ?]]; equate_join h23 h23'.
  destruct (cross_split _ _ _ _ _ H10 H2) as [[[[hp1 hr1] hp2p3] hr2r3] [? [? [? ?]]]].
  destruct (cross_split _ _ _ _ _ H5 H11) as [[[[hp2 hr2] hp3] hr3] [? [? [? ?]]]].
  try_join hp1 hp2 hp1p2.
  try_join hr1 hr2 hr1r2.
  assert (join hp1p2 hr1r2 h12).
  1: {
    try_join hp1 h2 hp1p2r2.
    destruct (join_assoc (join_comm H14) (join_comm H22)) as [hp1p2' [? ?]].
    equate_join hp1p2 hp1p2'.
    destruct (join_assoc (join_comm H25) (join_comm H23)) as [hr1r2' [? ?]].
    equate_join hr1r2 hr1r2'.
    auto.
  }

  try_join hP hp3 hPp3.
  assert (identity hp1p2 /\ joins hPp3 hr1r2) as [? ?] by (apply H with hPp h12; auto).
  try_join hP hp1 hPp1.
  assert (identity hp2p3 /\ joins hPp1 hr2r3) as [? ?] by (apply H0 with hPp h23; auto).

  assert (identity hp1) by (apply split_identity with hp2 hp1p2; auto).
  assert (identity hp3) by (apply split_identity with hp2 hp2p3; auto).
  split.
  + apply join_identity with hp1 hp2p3; auto.
  + apply H31 in H27.
    apply H32 in H23.
    subst hPp1 hPp3.
    destruct H26 as [hPr1r2 ?].
    destruct H30 as [hPr1r3 ?].
    destruct (join_assoc H20 (join_comm H23)) as [hPr1 [? ?]].
    destruct (triple_join_exists _ _ _ _ _ _ H13 (join_comm H26) H27) as [hPr1r2r3 ?H].
    apply joins_comm; eauto.
Qed.

Lemma covariant_ocon_d {B}{A} {JA: Join A}{PA: Perm_alg A}:
   forall F1 F2 : (B -> pred A) -> (B -> pred A),
    covariant F1 -> covariant F2 ->
    covariant (fun (x : B -> pred A) b => F1 x b ⊗ F2 x b).
Proof.
  intros; hnf.
  intros P Q ? ?.
  eapply ocon_derives_d.
  apply H, H1.
  apply H0, H1.
Qed.

Definition contravariant_d {B A : Type} (F: (B -> pred A) -> (B -> pred A)) : Prop :=
forall (P Q: B -> pred A), (forall x, P x |-- Q x) -> (forall x, F Q x |-- F P x).

Lemma contravariant_ocon_d {B}{A} {JA: Join A}{PA: Perm_alg A}:
   forall F1 F2 : (B -> pred A) -> (B -> pred A),
    contravariant_d F1 -> contravariant_d F2 ->
    contravariant_d (fun (x : B -> pred A) b => F1 x b ⊗ F2 x b).
Proof.
  intros; hnf.
  intros P Q ? ?.
  eapply ocon_derives_d.
  apply H, H1.
  apply H0, H1.
Qed.

Lemma precise_ocon_d {A} {JA : Join A} {PA : Perm_alg A} {SA: Sep_alg A}{CaA : Canc_alg A}{CrA : Cross_alg A}{DA : Disj_alg A} :
  forall P Q, precise P -> precise Q -> precise (P ⊗ Q).
Proof.
  intros; intro; intros.
  destruct_ocon H1 h; destruct_ocon H2 i.
  generalize (join_join_sub H6); intro; generalize (join_sub_trans H13 H3); intro.
  generalize (join_join_sub H10); intro; generalize (join_sub_trans H15 H4); intro.
  generalize (H w h12 i12 H7 H11 H14 H16); intro.
  try_join h2 h3 h23'; equate_join h23 h23'; try_join i2 i3 i23'; equate_join i23 i23'.
  generalize (join_join_sub' H19); intro; generalize (join_sub_trans H18 H3); intro.
  generalize (join_join_sub' H20); intro; generalize (join_sub_trans H22 H4); intro.
  generalize (H0 w h23 i23 H8 H12 H21 H23); intro.
  rewrite H17 in *; rewrite H24 in *. clear h12 h23 H7 H8 H11 H12 H13 H14 H15 H16 H17 H18 H21 H22 H23 H24.
  apply (overlapping_eq h1 h2 h3 i1 i2 i3 i12 i23); trivial.
Qed.

Lemma precise_tri_exp_ocon_d {A} {JA : Join A} {PA : Perm_alg A} {SA: Sep_alg A} {CaA : Canc_alg A}
      {CrA : Cross_alg A} {DA : Disj_alg A} B:
  forall (P : B -> B -> B -> pred A) (Q R: B -> pred A),
    precise (EX x : B, EX y : B, EX z : B, P x y z) -> precise (exp Q) -> precise (exp R) ->
    precise (EX x : B, EX y : B, EX z : B, P x y z ⊗ Q y ⊗ R z).
Proof.
  repeat intro.
  destruct H2 as [x1 [y1 [z1 ?]]]; destruct_ocon H2 h; destruct_ocon H8 j;
  destruct H3 as [x2 [y2 [z2 ?]]]; destruct_ocon H3 i; destruct_ocon H16 k.
  assert (j12 = k12) by (hnf in H; apply H with (w := w);
                         [exists x1, y1, z1 | exists x2, y2, z2 | assertSub j12 w Hsub | assertSub k12 w Hsub]; auto).
  assert (j23 = k23) by (hnf in H0; apply H0 with (w := w);
                         [exists y1 | exists y2 | try_join j2 j3 j23'; equate_join j23 j23'; assertSub j23 w Hsub |
                                 try_join k2 k3 k23'; equate_join k23 k23'; assertSub k23 w Hsub]; auto).
  rewrite H22 in *; rewrite H23 in *; assert (h12 = i12) by (apply (overlapping_eq j1 j2 j3 k1 k2 k3 k12 k23); trivial).
  assert (h23 = i23) by (hnf in H1; apply H1 with (w := w);
                         [exists z1 | exists z2 | try_join h2 h3 h23'; equate_join h23 h23'; assertSub h23 w Hsub |
                                 try_join i2 i3 i23'; equate_join i23 i23'; assertSub i23 w Hsub]; auto).
  rewrite H24 in *; rewrite H25 in *; apply (overlapping_eq h1 h2 h3 i1 i2 i3 i12 i23); trivial.
Qed.

Lemma extract_andp_ocon_ocon_left_d {A} {JA : Join A} {PA : Perm_alg A} {SA: Sep_alg A}:
  forall (w : A) P Q R S, (P && Q ⊗ R ⊗ S) w -> exists w', P w'.
Proof. repeat intro; destruct_ocon H h; destruct_ocon H2 i; destruct H6; exists i12; trivial. Qed.

Lemma ocon_precise_elim_d  {A}{JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{CA: Canc_alg A}{DA : Disj_alg A}:
  forall P : pred A, precise P -> P ⊗ P = P.
Proof.
  intros; apply pred_ext; intro w; intro. destruct_ocon H0 h. try_join h2 h3 h23'; equate_join h23 h23'.
  equate_precise_direct h12 h23. assert (emp h1). assertSub h1 h12 HS. assert (joins h1 h12). exists w; auto.
  apply (join_sub_joins_identity HS H4). equate_canc h1 h3. apply (join_unit1_e _ _ H4) in H6. subst. auto. hnf.
  exists (core w), w, (core w), w, w. split. apply core_unit. split. apply join_comm, core_unit. split.
  apply join_comm, core_unit. split; auto.
Qed.

Lemma corable_ocon_d: forall {A}{JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A} P Q, corable P -> corable Q -> corable (ocon P Q).
Proof.
  intros.
  rewrite corable_spec in H, H0 |- *.
  unfold ocon.
  intros.
  simpl in H2 |- *.
  destruct H2 as [h1 [h2 [h3 [h12 [h23 [? [? [? [? ?]]]]]]]]].
  exists (core y), (core y), y, (core y), y.
  pose proof join_core H2.
  pose proof join_core (join_comm H2).
  pose proof join_core H3.
  pose proof join_core (join_comm H3).
  pose proof join_core H4.
  pose proof join_core (join_comm H4).
  repeat split.
  + rewrite <- core_idem at 1.
    apply core_unit.
  + apply core_unit.
  + apply core_unit.
  + apply H with h12; auto.
    rewrite core_idem.
    congruence.
  + apply H0 with h23; auto.
    congruence.
Qed.

Lemma corable_andp_ocon1_d {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}:
   forall P Q R, corable P ->  ocon (P && Q) R = P && (ocon Q R).
Proof.
  intros.
  apply pred_ext.
  + intros h [h1 [h2 [h3 [h12 [h23 [? [? [? [[? ?] ?]]]]]]]]].
    split.
    - apply join_core in H2.
      rewrite corable_spec in H.
      apply H with h12; [congruence | auto].
    - exists h1, h2, h3, h12, h23.
      tauto.
  + intros h [? [h1 [h2 [h3 [h12 [h23 [? [? [? [? ?]]]]]]]]]].
    exists h1, h2, h3, h12, h23.
    rewrite corable_spec in H.
    repeat split; auto.
    apply join_core in H3.
    apply H with h; [congruence | auto].
Qed.


(* Syncer spec *)

From iris.program_logic Require Export weakestpre.
From iris.heap_lang Require Export lang.
From iris.heap_lang Require Import proofmode notation.
From iris.prelude Require Import options.

Section sync.
  Context `{!heapGS Σ} (N : namespace).

  (* TODO: We could get rid of the x, and hard-code a unit. That would
     be no loss in expressiveness, but probably more annoying to apply.
     How much more annoying? And how much to we gain in terms of things
     becoming easier to prove? *)
  Definition synced R (f f': val) :=
    (□ ∀ P Q (x: val), {{{ R ∗ P }}} f x {{{ v, RET v; R ∗ Q v }}} →
                       {{{ P }}} f' x {{{ v, RET v; Q v }}})%I.

  (* Notice that `s f` is *unconditionally safe* to execute, and only
     when executing the returned f' we have to provide a spec for f.
     This is crucial. *)
  (* TODO: Use our usual style with a generic post-condition. *)
  Definition is_syncer (R: iProp Σ) (s: val) :=
    (□ ∀ (f : val), WP s f {{ f', synced R f f' }})%I.

  Definition mk_syncer_spec (mk_syncer: val) :=
    ∀ (R: iProp Σ),
      {{{ R }}} mk_syncer #() {{{ s, RET s; is_syncer R s }}}.
End sync.


(* PREAMBLE *)

From compcert.cfrontend           Require Csem.
From compcert.common              Require Values.
From compcert.lib                 Require Coqlib.

From trancert.lib                 Require All.
From trancert.simulations.memory.bijection
                                  Require Def ToInjection.

Import lib.All
       bijection.Def bijection.AST
       Coqlib bijection.ToInjection
       common.Values
       Values.Val
       Memory Mem.

(** ** [load] simulation *)

Section Load.

  Theorem load_biject
          M m1 m2 chunk b1 ofs b2 v:
    biject M m1 m2 ->
    load chunk m1 b1 ofs = Some v ->
    m_fwd M b1 = Some b2 ->
    exists v', biject_value (m_fwd M) v v' /\ load chunk m2 b2 ofs = Some v'.
  Proof.
    intros Hbiject Hload Hf.

    assert (exists v2 : val,
               load chunk m2 b2 ofs = Some v2 /\
               Val.inject (m_fwd M) v v2)
      as (v2 & Hload2 & Hinj2).
    {
      replace ofs with (ofs + 0)%Z; last by rewrite Z.add_0_r.
      eapply load_inject; eauto.
      - eapply Hbiject.
      - unfold to_meminj, option_map in *. by rewrite Hf.
    }

    assert (exists v3 : val,
               load chunk m1 b1 ofs = Some v3 /\
               Val.inject (m_bwd M) v2 v3)
      as (v3 & Hload3 & Hinj3).
    {
      replace ofs with (ofs + 0)%Z; last by rewrite Z.add_0_r.
      eapply load_inject; eauto.
      - eapply Hbiject.
      - unfold to_meminj, option_map in *. apply M in Hf. by rewrite Hf.
    }

    assert (v3 = v).
    {
      rewrite Hload in Hload3; by inversion Hload3.
    }

    subst v3.
    exists v2. split; eauto.
    by eapply biject_inject_value; eassumption.
  Qed.

End Load.

(** ** [loadbytes] commutation *)

Theorem loadbytes_biject:
  forall M (m1 m2 : mem) (b1 : Values.block)
    (ofs len : Z) (b2 : Values.block) (bytes1 : list Memdata.memval),
    biject M m1 m2 ->
    loadbytes m1 b1 ofs len = Some bytes1 ->
    m_fwd M b1 = Some b2 ->
    exists bytes2 : list Memdata.memval,
      list_forall2 (biject_memval (m_fwd M)) bytes1 bytes2 /\
      loadbytes m2 b2 ofs len = Some bytes2.
Proof.
  intros M m1 m2 b1 ofs len b2 bytes1 [] Hload Hf.
  unfold to_meminj, option_map in *.
  exploit loadbytes_inject; try eapply mb_inj__fwd; eauto.
  { simpl in *. by rewrite Hf. }
  intros; decomp.

  exploit loadbytes_inject; try eapply mb_inj_g; eauto.
  { simpl in *. apply M in Hf. by rewrite Hf. }
  intros; decomp.

  rewrite ! Z.add_0_r in H1, H.
  exists x. split; auto.
  assert (x0 = bytes1).
  { rewrite H1 in Hload. by inv Hload. }
  subst x0.

  eapply list_forall2_imply.
  - eapply list_forall2_conj.
    + eapply H0.
    + eapply list_forall2_inv with (Q := converse _); last by eapply H2.
      intros a1 a2 H3.
      unfold converse.
      eapply H3.
  - intros v1 v2 _ _ Hminjs.
    decomp.
    unfold converse in *.
    decomp.
    eapply biject_inject_memval; eauto.
Qed.


Require Import msl.msl_direct.
Require Import overlapping.
Require Import ramify_tactics.
Require Import msl.sepalg_list.
Require Import msl_ext.
Require Import Classical.
Require Import Permutation.

Tactic Notation "LEM" constr(v) := (destruct (classic v); auto).

Definition ramify {A: Type}{JA: Join A}{PA: Perm_alg A}
           (R P Q R' : pred A) := R |-- P * (Q -* R').

Lemma ocon_ramification {A: Type}{JA: Join A}{PA: Perm_alg A}{CA: Cross_alg A}{CAA: Canc_alg A}{SA: Sep_alg A}:
  forall P Q R R' F, precise P -> precise Q -> ramify (P ⊗ R) P Q (Q ⊗ R') ->
                     ramify ((P * F) ⊗ R) P Q ((Q * F) ⊗ R').
Proof.
  repeat intro; destruct_ocon H2 h; destruct_sepcon H5 x; destruct_cross h12.
  try_join h1x1 h2 h1x1h2; try_join h1x1h2 h3 h1x1h2h3; try_join h1x1 h2x1 x1'; equate_join x1 x1'.
  try_join h2x2 h3 h2x2h3; try_join_through h1x1h2 h2x2 h3 h2x2h3'; equate_join h2x2h3 h2x2h3'.
  assert (HPR: (P ⊗ R)%pred h1x1h2h3) by (simpl; exists h1x1, h2x1, h2x2h3, x1, h23; split; auto).
  specialize (H1 h1x1h2h3 HPR). destruct H1 as [x1' [h2x2h3' [? [? ?]]]]. equate_precise x1 x1'. equate_canc h2x2h3 h2x2h3'.
  try_join x2 h3 x2h3; exists x1, x2h3; repeat split; auto.
  intros m x2h3m; intros. try_join h2x2 h3 h2x2h3'; equate_join h2x2h3 h2x2h3'.
  try_join h2x2h3 m h2x2h3m; assert (HQR': (Q ⊗ R')%pred h2x2h3m) by (apply (H22 m); auto).
  destruct_ocon HQR' m. equate_precise m m12; equate_canc h2x2h3 m3.
  try_join h2x2 m2 h2x2m2. try_join h1x2 h2x2 x2'; equate_join x2 x2'. try_join x2 m x2m. try_join m1 x2 m1x2.
  try_join h1x2 m1 h1x2m1. exists h1x2m1, h2x2m2, h3, x2m, m23; repeat split; auto.
  try_join h2x2 m2 h2x2m2'; equate_join h2x2m2 h2x2m2'; auto.
  exists m, x2; split; auto.
Qed.

Lemma andp_ramification1 {A: Type}{JA: Join A}{PA: Perm_alg A}{CAA: Canc_alg A}{SA: Sep_alg A}:
  forall P Q R R' F, precise P -> ramify R P Q R' -> ramify ((P * F) && R) P Q ((Q * F) && R').
Proof.
  intros; hnf; intros; destruct H1 as [[y [z [? [? ?]]]] ?].
  specialize (H0 a H4); destruct H0 as [y' [z' [? [? ?]]]]; equate_precise y y'; equate_canc z z'.
  exists y, z; do 2 (split; auto); intros z' m z'm; intros. specialize (H6 z' m z'm H0).
  split; auto. exists z', z; repeat split; auto.
Qed.

Notation "P '-⊛' Q" := (ewand P Q) (at level 60, right associativity) : pred.

Lemma andp_ramification2 {A: Type}{JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}:
  forall P Q R R' F, (P -⊛ R |-- Q -* R') -> ramify ((P * F) && R) P Q ((Q * F) && R').
Proof.
  intros; hnf; intros; destruct H0 as [[y [z [? [? ?]]]] ?].
  assert ((P -⊛ R)%pred z) by (exists y, a; repeat split; auto).
  specialize (H z H4); exists y, z; do 2 (split; auto).
  intros m zm; intros; specialize (H m zm H5 H6).
  split; auto; exists m, z; repeat split; auto.
Qed.

Lemma disjoint_ramificatin {A: Type}{JA: Join A}{PA: Perm_alg A}:
  forall R P P' R' S Q Q' S', ramify R P P' R' -> ramify S Q Q' S' -> ramify (R * S) (P * Q) (P' * Q') (R' * S').
Proof.
  intros; hnf; intro ab; intros; destruct H1 as [a [b [? [? ?]]]].
  specialize (H a H2); specialize (H0 b H3).
  destruct H as [a1 [a2 [? [? ?]]]]; destruct H0 as [b1 [b2 [? [? ?]]]].
  try_join a1 b a1b; try_join a1 b1 a1b1; try_join a2 b2 a2b2.
  exists a1b1, a2b2; repeat split; auto. exists a1, b1; repeat split; auto. hnf.
  intros s1s2 w1w2; intros; destruct_sepcon H15 s.
  try_join a2 s1s2 a2s1s2; try_join a2 s1 a2s1; try_join b2 s2 b2s2.
  assert (R' a2s1) by (apply (H5 s1); auto); assert (S' b2s2) by (apply (H7 s2); auto).
  exists a2s1, b2s2; repeat split; auto.
Qed.

Lemma ocon_piecewise_ramification {A: Type}{JA: Join A}{PA: Perm_alg A}{CA: Cross_alg A}{CAA: Canc_alg A}{SA: Sep_alg A}:
  forall P P' Q1 Q2 Q1' Q2', precise P -> precise P' -> ramify (P ⊗ Q1) P P' (P' ⊗ Q1') -> ramify (P ⊗ Q2) P P' (P' ⊗ Q2')
                             -> ramify (P ⊗ Q1 ⊗ Q2) P P' (P' ⊗ Q1' ⊗ Q2').
Proof.
  intros; hnf; intros.
  destruct H3 as [h124 [h567 [h3 [h124567 [h3567 [? [? [? [[h15 [h47 [h26 [h1457 [h2467 [? [? [? [? ?]]]]]]]]] ?]]]]]]]]].
  destruct (cross_split _ _ _ _ _ H3 H8) as [[[[h14 h2] h57] h6] [? [? [? ?]]]].
  destruct (cross_split _ _ _ _ _ H6 H14) as [[[[h1 h5] h4] h7] [? [? [? ?]]]].
  try_join h26 h3 h236; exists h1457, h236; repeat split; auto.
  assert (HPQ1: (P ⊗ Q1)%pred h124567) by (exists h15, h47, h26, h1457, h2467; repeat split; auto).
  specialize (H1 h124567 HPQ1); destruct H1 as [h1457' [h26' [? [? ?]]]]; equate_precise h1457 h1457'; equate_canc h26 h26'.
  assert (join h14 h57 h1457) by (apply (cross_rev h1 h5 h4 h7 h15 h47); auto).
  try_join h3 h6 h36; try_join h36 h1457 h134567; try_join h14 h36 h1346.
  try_join_through h1346 h14 h57 h1457'; equate_join h1457 h1457'.
  try_join h3 h57 h357; try_join_through h357 h3 h6 h36'; equate_join h36 h36'.
  assert (HPQ2: (P ⊗ Q2)%pred h134567) by (exists h14, h57, h36, h1457, h3567; repeat split; auto).
  specialize (H2 h134567 HPQ2); destruct H2 as [h1457' [h36' [? [? ?]]]]; equate_precise h1457 h1457'; equate_canc h36 h36'.
  intros h1457' a'; intros.
  (* destruct (nec_join2 H20 H2) as [h26' [h3' [? [? ?]]]]; destruct (nec_join2 H15 H37) as [h2' [h6' [? [? ?]]]]. *)
  (* try_join h3' h6' h36'; assert (necR h36 h36') by (apply (join_necR h3 h6 _ h3' h6' _); auto). *)
  try_join h26 h1457' h124567'; try_join h36 h1457' h134567'.
  assert (HPQ1': (P' ⊗ Q1')%pred h124567') by (apply (H23 h1457'); auto).
  assert (HPQ2': (P' ⊗ Q2')%pred h134567') by (apply (H34 h1457'); auto).
  destruct HPQ1' as [h15' [h47' [h26'' [h1457'' [h2467' [? [? [? [? ?]]]]]]]]].
  equate_precise h1457' h1457''; equate_canc h26 h26''.
  destruct HPQ2' as [h14' [h57' [h36'' [h1457'' [h3567' [? [? [? [? ?]]]]]]]]].
  equate_precise h1457' h1457''; equate_canc h36 h36''.
  destruct (cross_split _ _ _ _ _ H39 H41) as [[[[h1' h5'] h4'] h7'] [? [? [? ?]]]].
  try_join h6 h57' h567'; try_join h2 h1457' h12457'; try_join h14' h2 h124'.
  try_join h124' h6 h1246'; try_join_through h1246' h6 h57' h567''; equate_join h567' h567''.
  exists h124', h567', h3, h124567', h3567'; repeat split; auto.
  exists h15', h47', h26, h1457', h2467'; repeat split; auto.
Qed.

Lemma wand_ewand {A: Type}{JA: Join A}{PA: Perm_alg A}{CAA: Canc_alg A}:
  forall R P Q R', precise P -> R |-- P * (Q -* R') -> Q * (P -⊛ R) |-- R'.
Proof.
  intros. intro w. intros. destruct_sepcon H1 h. destruct H3 as [h3 [h4 [? [? ?]]]]. specialize (H0 h4 H5).
  destruct_sepcon H0 h. equate_precise h3 h0. equate_canc h2 h5. apply (H7 h1); auto.
Qed.

Lemma ewand_wand {A: Type}{JA: Join A}{PA: Perm_alg A}{CAA: Canc_alg A}:
  forall R P Q R', R |-- P * TT -> Q * (P -⊛ R) |-- R' -> R |-- P * (Q -* R').
Proof.
  intros. intro w. intros. specialize (H w H1). destruct_sepcon H h. exists h1, h2. do 2 (split; auto). intros w1 w2; intros.
  apply (H0 w2). exists w1, h2. do 2 (split; auto). exists h1, w. split; auto.
Qed.

Definition alignable {A : Type} {JA : Join A} {B : Type} (p : B -> pred A) :=
  forall (x y : B), p x ⊗ p y |-- (p x && !!(x = y)) || ((p x * p y) && !!(x <> y)).

Lemma alignable_emp {A : Type} {JA : Join A} {PA: Perm_alg A} {SA : Sep_alg A} {CA : Canc_alg A}: emp ⊗ emp |-- emp.
Proof.
  intro w; intros. destruct_ocon H w. apply (split_identity _ _ (join_comm H0)) in H3.
  apply (join_unit2_e _ _ H3) in H1. subst; auto.
Qed.

Lemma alignable_joinable {A : Type} {JA : Join A} {PA: Perm_alg A} {CA: Cross_alg A} {B : Type}:
  forall (p : B -> pred A) (w : A), alignable p -> joinable p w.
Proof.
  repeat intro. specialize (H x y). assert ((p x ⊗ p y * TT)%pred w). destruct_sepcon H1 w. destruct_sepcon H2 w.
  rename w3 into w4. rename w0 into w3. destruct_cross w. try_join w1 w2w3 wxy. exists wxy, w2w4. do 2 (split; auto).
  exists w1w4, w1w3, w2w3, w1, w3. split; auto. destruct_sepcon H3 w. specialize (H w1 H4). destruct H as [[? ?] | [? ?]].
  exfalso; auto. exists w1, w2. split; auto.
Qed.

Lemma alignable_iter_sepcon {A : Type} {JA : Join A} {PA : Perm_alg A} {SA: Sep_alg A} {CA : Canc_alg A}
      {C: Cross_alg A} {DA : Disj_alg A} {B : Type}:
  forall (p : B -> pred A) (l : list B) (x : B),
    alignable p -> (forall z, precise (p z)) -> p x ⊗ iter_sepcon l p |--
                                                  (iter_sepcon l p && !!(In x l)) || ((p x * iter_sepcon l p) && !!(~ In x l)).
Proof.
  intros. intro w. intros. destruct_ocon H1 w. try_join w2 w3 w23'; equate_join w23 w23'.
  LEM (In x l); [left | right]; split; auto. apply in_split in H6. destruct H6 as [l1 [l2 ?]]. subst.
  assert (Permutation (l1 ++ x :: l2) (x :: (l2 ++ l1))). rewrite app_comm_cons. apply Permutation_app_comm.
  generalize (iter_sepcon_permutation _ _ p H6); intro. rewrite H8 in *. clear H6 H8. simpl in H5. destruct_sepcon H5 h.
  destruct_cross w23. assertSub w12 w HS1. assertSub h1 w HS2. generalize (H0 x); intro. equate_precise_through (p x) w12 h1.
  clear H13. assert (emp w1). apply join_sub_joins_identity with w23. try_join w1 h2 t1. assertSub w1 w23 HS. auto.
  exists w. auto. elim_emp. simpl. exists w12, h2. split; auto.

  clear H7. revert w w1 w2 w3 w12 w23 H1 H2 H3 H4 H5 H6.
  induction l; intros; simpl in *; try_join w2 w3 w23'; equate_join w23 w23'. rewrite sepcon_emp. apply join_comm in H2.
  apply split_identity in H2; auto. elim_emp. auto. assert (a <> x). intro. apply H6. left; auto. assert (~ In x l). intro.
  apply H6. right; auto. clear H6. destruct_sepcon H5 h. destruct_cross w23. rename w2h1 into i1. rename w3h1 into i2.
  rename w2h2 into i4. rename w3h2 into i3. try_join w1 i4 w1i4. try_join h1 i4 h1i4. try_join w12 i2 w12h1.
  assert ((p x ⊗ p a)%pred w12h1). exists w1i4, i1, i2, w12, h1. split; auto. apply H in H21. destruct H21 as [[? ?] | [? ?]].
  exfalso; auto. assert (emp i1). apply (overlapping_precise_emp w1i4 i1 i2 w12 h1 w12h1 (p x) (p a)); auto. elim_emp.
  clear H23 i1. try_join h2 w1 w1h2. rewrite <- sepcon_assoc. rewrite (sepcon_comm (p x)). rewrite sepcon_assoc.
  exists h1, w1h2. do 2 (split; auto). try_join w12 i3 w1h2'. equate_canc w1h2 w1h2'. apply (IHl _ w1 w2 i3 w12 h2); auto.
Qed.

Lemma disjoint_iter_sepcon_app {A : Type} {JA : Join A} {PA : Perm_alg A} {SA: Sep_alg A} {CA : Canc_alg A} {C: Cross_alg A}
      {DA : Disj_alg A} {B : Type}:
  forall (p : B -> pred A) (l1 l2 : list B), alignable p -> (forall z, precise (p z)) -> (forall x, In x l1 -> ~ In x l2) ->
                                             iter_sepcon l1 p ⊗ iter_sepcon l2 p |-- iter_sepcon l1 p * iter_sepcon l2 p.
Proof.
  intros. induction l1; intro w; intros. simpl in *. rewrite ocon_comm, ocon_emp in H2. rewrite sepcon_comm, sepcon_emp. auto.
  simpl in *. destruct_ocon H2 w. destruct_sepcon H5 h. destruct_cross w12. rename w1h1 into i1. rename w2h1 into i2.
  rename w1h2 into i3. rename w2h2 into i4. try_join w2 w3 w23'; equate_join w23 w23'. try_join i4 w3 i4w3.
  try_join w23 i1 w23h1. try_join i1 i2 h1'. equate_join h1 h1'. assert ((p a ⊗ iter_sepcon l2 p)%pred w23h1).
  exists i1, i2, i4w3, h1, w23. split; auto. apply alignable_iter_sepcon in H18; auto. destruct H18 as [[? ?] | [? ?]].
  simpl in H20. exfalso. specialize (H1 a). apply H1; [left|]; auto. assert (emp i2).
  apply (overlapping_precise_emp i1 i2 i4w3 h1 w23 w23h1 (p a) (iter_sepcon l2 p)); auto. apply precise_iter_sepcon. auto.
  elim_emp. clear H21 i2. try_join h2 w3 h2w3. rewrite sepcon_assoc. exists h1, h2w3. do 2 (split; auto). apply IHl1. intros.
  apply H1. right; auto. exists i3, w2, w3, h2, w23. split; auto.
Qed.


Require Export SpecializedCategory Functor.
Require Import Common.

Set Implicit Arguments.

Set Asymmetric Patterns.

Set Universe Polymorphism.

Section ComputableCategory.
  Variable I : Type.
  Variable Index2Object : I -> Type.
  Variable Index2Cat : forall i : I, @SpecializedCategory (@Index2Object i).

  Local Coercion Index2Cat : I >-> SpecializedCategory.

  Definition ComputableCategory : @SpecializedCategory I.
    refine (@Build_SpecializedCategory _
                                       (fun C D : I => SpecializedFunctor C D)
                                       (fun o : I => IdentityFunctor o)
                                       (fun C D E : I => ComposeFunctors (C := C) (D := D) (E := E))
                                       _
                                       _
                                       _);
    abstract functor_eq.
  Defined.
End ComputableCategory.


Require Import Essentials.Notations.
Require Import Essentials.Types.
Require Import Essentials.Facts_Tactics.
Require Import Category.Main.
Require Import Functor.Main.
Require Import Basic_Cons.Equalizer.
Require Import Coq_Cats.Type_Cat.Type_Cat Coq_Cats.Type_Cat.Equalizer.
Require Import NatTrans.NatTrans NatTrans.Func_Cat.
Require Import PreSheaf.PreSheaf.

Local Obligation Tactic := idtac.

Section Equalizer.
  Context (C : Category) {A B : PreSheaf C} (f g : (A –≻ B)%nattrans).

  (** The pointwise equalizer presheaf. *)
  Program Definition PSh_ptw_eq_Func : PreSheaf C :=
    {|
      FO := fun c => Type_Cat_Has_Equalizers _ _ (Trans f c) (Trans g c);
      FA := fun c c' h x => exist _ (A _a h (proj1_sig x))%morphism _
    |}.

  Next Obligation.
  Proof.
    intros c c' h x.
    basic_simpl.
    cbn_rewrite (equal_f (Trans_com f h) x1).
    cbn_rewrite (equal_f (Trans_com g h) x1).
    rewrite x2.
    trivial.
  Qed.

  Next Obligation.
  Proof.
    basic_simpl; FunExt; basic_simpl.
    apply sig_proof_irrelevance; cbn.
    rewrite (F_id A).
    trivial.
  Qed.

  Next Obligation.
  Proof.
    intros a b c f' g'.
    FunExt; basic_simpl.
    apply sig_proof_irrelevance; cbn.
    cbn_rewrite (F_compose A f' g').
    trivial.
  Qed.

  Local Obligation Tactic := basic_simpl; auto.

  (** The equalizer morph. *)
  Program Definition PSh_ptw_eq_morph_NatTrans : NatTrans PSh_ptw_eq_Func A :=
    {|
      Trans :=
        fun c =>
          equalizer_morph
            (Type_Cat_Has_Equalizers _ _ (Trans f c) (Trans g c))
    |}.

  Local Hint Extern 1 => apply NatTrans_eq_simplify; FunExt; basic_simpl.

  Program Definition PSh_Eq : Equalizer (PShCat C) f g :=
    {|
      equalizer := PSh_ptw_eq_Func;
      equalizer_morph := PSh_ptw_eq_morph_NatTrans;
      equalizer_morph_ex :=
        fun u v H =>
          {|
            Trans := fun c x => exist _ (Trans v c x) _
          |}
    |}.

  Next Obligation.
  Proof.
    apply (f_equal (fun w :(u –≻ B)%nattrans => Trans w c x) H).
  Qed.

  Next Obligation.
  Proof.
    FunExt.
    apply sig_proof_irrelevance; cbn.
    apply (equal_f (Trans_com v h)).
  Qed.

  Next Obligation.
  Proof.
    symmetry.
    apply PSh_Eq_obligation_3.
  Qed.

  Local Obligation Tactic := idtac.

  Next Obligation.
    intros e' eqm H1 u u' H4 H5.
    rewrite <- H5 in H4; clear H5.
    assert (H4' := f_equal Trans H4); clear H4.
    apply NatTrans_eq_simplify.
    extensionality x; extensionality y.
    apply sig_proof_irrelevance.
    apply (f_equal (fun w => w x y) H4').
  Qed.

End Equalizer.

Instance PSh_Has_Equalizers (C : Category) : Has_Equalizers (PShCat C)
  := fun _ _ => PSh_Eq C.

Section CoEqualizer.
  Context (C : Category) {A B : PreSheaf C} (f g : (A –≻ B)%nattrans).

  Lemma another_coequalizer
        (c c' : C)
        (h : (c' –≻ c)%morphism)
    :
      ((equalizer_morph (Type_Cat_Has_CoEqualizers _ _ (Trans f c') (Trans g c'))) ∘ (B _a h) ∘ (Trans f c))%morphism
      =
      ((equalizer_morph (Type_Cat_Has_CoEqualizers _ _ (Trans f c') (Trans g c'))) ∘ (B _a h) ∘ (Trans g c))%morphism
  .
  Proof.
    FunExt; cbn.
    cbn_rewrite <- (equal_f (Trans_com f h)).
    cbn_rewrite <- (equal_f (Trans_com g h)).
    apply (equal_f (equalizer_morph_com (Type_Cat_Has_CoEqualizers _ _ (Trans f c') (Trans g c')))).
  Qed.

  Lemma CoEq_rel_natural
        (a b : C)
        (h : (b –≻ a)%morphism)
        (x y : (B _o)%object a)
        (H : CoEq_rel (Trans f a) (Trans g a) x y)
    :
      CoEq_rel (Trans f b) (Trans g b) (B _a h x)%morphism (B _a h y)%morphism
  .
  Proof.
    cbn in *.
    induction H.
    {
      destruct H as [z [H1 H2]].
      rewrite <- H1, <- H2.
      constructor 1.
      exists ((A _a)%morphism h z); split.
      apply (equal_f (Trans_com f h)).
      apply (equal_f (Trans_com g h)).
    }
    {
      constructor 2.
    }
    {
      constructor 3; auto.
    }
    {
      econstructor 4; eauto.
    }
  Qed.

  Lemma equalizer_morph_com_simplified
        (a : C)
        (x y : (B _o)%object a)
        (H : CoEq_rel (Trans f a) (Trans g a) x y)
    :
      Equalizer.Type_Cat_CoEq_obligation_1 (Trans f a) (Trans g a) y =
      Equalizer.Type_Cat_CoEq_obligation_1 (Trans f a) (Trans g a) x
  .
  Proof.
    induction H; auto.
    destruct H as [z [H1 H2]].
    rewrite <- H1, <- H2.
    symmetry.
    apply (equal_f (@equalizer_morph_com _ _ _ _ _ (Type_Cat_Has_CoEqualizers _ _ (Trans f a) (Trans g a)))).
  Qed.

  (** The pointwise equalizer presheaf. *)
  Program Definition PSh_ptw_coeq_Func : PreSheaf C :=
    {|
      FO := fun c => Type_Cat_Has_CoEqualizers _ _ (Trans f c) (Trans g c);
      FA :=
        fun c c' h x =>
          @equalizer_morph_ex
            _
            _
            _
            _
            _
            (Type_Cat_Has_CoEqualizers _ _ (Trans f c) (Trans g c))
            _
            (
              (equalizer_morph (Type_Cat_Has_CoEqualizers _ _ (Trans f c') (Trans g c')))
                ∘ (B _a h)
            )%morphism (another_coequalizer _ _ _) x
    |}.

  Next Obligation.
  Proof.
    basic_simpl.
    eapply
      (
        @equalizer_morph_unique
          _
          _
          _
          _
          _
          (Type_Cat_Has_CoEqualizers _ _ (Trans f c) (Trans g c))
          _
          (equalizer_morph (Type_Cat_Has_CoEqualizers _ _ (Trans f c) (Trans g c)))
      );
      cbn; trivial.
    + apply (@equalizer_morph_com _ _ _ _ _ (Type_Cat_Has_CoEqualizers _ _ (Trans f c) (Trans g c))).
    + extensionality x.
      destruct (
          (
            CoEq_Choice
              (Trans f c)
              (Trans g c)
              (
                Equalizer.Type_Cat_CoEq_obligation_1
                  (Trans f c)
                  (Trans g c)
                  x
              )
          )
        ) as [y H].
      rewrite (F_id B).
      apply equalizer_morph_com_simplified; assumption.
  Qed.

  Next Obligation.
  Proof.
    intros a b c f' g'.
    cbn in *.
    apply
      (
        @equalizer_morph_unique
          _
          _
          _
          _
          _
          (Type_Cat_Has_CoEqualizers _ _ (Trans f a) (Trans g a))
          _
          (
            (equalizer_morph (Type_Cat_Has_CoEqualizers _ _ (Trans f c) (Trans g c)))
              ∘ (B _a (f' ∘ g'))
          )%morphism
      );
      cbn.
    {
      extensionality x.
      cbn_rewrite (F_compose B f' g').
      cbn_rewrite <- (equal_f (Trans_com f f')).
      cbn_rewrite <- (equal_f (Trans_com f g')).
      cbn_rewrite <- (equal_f (Trans_com g f')).
      cbn_rewrite <- (equal_f (Trans_com g g')).
      apply (equal_f
               (@equalizer_morph_com
                  _
                  _
                  _
                  _
                  _
                  (Type_Cat_Has_CoEqualizers _ _ (Trans f c) (Trans g c))
               )
            ).
    }
    {
      extensionality x.
      destruct (
          (
            CoEq_Choice
              _
              _
              (
                Equalizer.Type_Cat_CoEq_obligation_1
                  _
                  _
                  x
              )
          )
        ) as [y H].
      cbn in *.
      apply equalizer_morph_com_simplified.
      apply CoEq_rel_natural; trivial.
    }
    {
      extensionality x.
      cbn_rewrite (F_compose B f' g').
      destruct (
          (
            CoEq_Choice
              _
              _
              (
                Equalizer.Type_Cat_CoEq_obligation_1
                  _
                  _
                  x
              )
          )
        ) as [y H].
      cbn in *.
      destruct (
          (
            CoEq_Choice
              _
              _
              (
                Equalizer.Type_Cat_CoEq_obligation_1
                  _
                  _
                  ((B _a)%morphism f' y)
              )
          )
        ) as [z H'].
      cbn in *.
      apply equalizer_morph_com_simplified.
      apply CoEq_rel_natural; trivial.
      econstructor 4; [|exact H'].
      apply CoEq_rel_natural; trivial.
    }
  Qed.

  (** The equalizer morph. *)
  Program Definition PSh_ptw_coeq_morph_NatTrans : NatTrans B PSh_ptw_coeq_Func :=
    {|
      Trans :=
        fun c =>
          equalizer_morph
            (Type_Cat_Has_CoEqualizers _ _ (Trans f c) (Trans g c))
    |}.

  Next Obligation.
  Proof.
    intros c c' h.
    extensionality x.
    cbn.
    destruct (
          (
            CoEq_Choice
              _
              _
              (
                Equalizer.Type_Cat_CoEq_obligation_1
                  _
                  _
                  x
              )
          )
        ) as [z H'].
      cbn in *.
      apply equalizer_morph_com_simplified.
      apply CoEq_rel_natural; trivial.
      constructor 3; trivial.
  Qed.

  Next Obligation.
  Proof.
    symmetry.
    apply PSh_ptw_coeq_morph_NatTrans_obligation_1.
  Qed.

(*  Local Hint Extern 1 => apply NatTrans_eq_simplify; FunExt; basic_simpl. *)

  Program Definition PSh_CoEq : CoEqualizer (PShCat C) f g :=
    {|
      equalizer := PSh_ptw_coeq_Func;
      equalizer_morph := PSh_ptw_coeq_morph_NatTrans;
      equalizer_morph_ex :=
        fun u v H =>
          {|
            Trans := fun x w => _
          |}
    |}.

  Next Obligation.
  Proof.
    apply NatTrans_eq_simplify.
    extensionality c; extensionality x.
    cbn.
    apply (equal_f
             (@equalizer_morph_com
                _
                _
                _
                _
                _
                (Type_Cat_Has_CoEqualizers _ _ (Trans f c) (Trans g c))
               )
          ).
  Qed.

  Next Obligation.
  Proof.
    intros.
    destruct (CoEq_Choice _ _ w) as [z H'].
    exact (Trans v x z).
  Defined.

  Next Obligation.
  Proof.
    intros u v H c c' h.
    extensionality w.
    unfold PSh_CoEq_obligation_2.
    cbn in *.
    destruct (CoEq_Choice _ _ w) as [z H'].
    cbn in *.
    cbn_rewrite <- (equal_f (Trans_com v h)).
    destruct (
        CoEq_Choice
          _
          _
          (
            Equalizer.Type_Cat_CoEq_obligation_1
              _
              _
              ((B _a)%morphism h z)
          )
      ) as [y H''].
    cbn in *.
    induction H'' as [l l' H''| | |]; auto.
    destruct H'' as [q [H''1 H''2]].
    rewrite <- H''1, <- H''2.
    symmetry.
    apply (f_equal (fun w : (A –≻ u)%nattrans => Trans w c' q) H).
  Qed.

  Next Obligation.
  Proof.
    symmetry.
    apply PSh_CoEq_obligation_3.
  Qed.

  Next Obligation.
  Proof.
    intros e' eqm eqmc.
    apply NatTrans_eq_simplify.
    unfold PSh_CoEq_obligation_2.
    extensionality c; extensionality x.
    cbn in *.
    destruct (
        CoEq_Choice
          _
          _
          (
            Equalizer.Type_Cat_CoEq_obligation_1
              _
              _
              x
          )
      ) as [y H''].
    cbn in *.
    induction H'' as [l l' H''| | |]; auto.
    destruct H'' as [q [H''1 H''2]].
    rewrite <- H''1, <- H''2.
    symmetry.
    apply (f_equal (fun w : (A –≻ e')%nattrans => Trans w c q) eqmc).
  Qed.

  Next Obligation.
    intros e' eqm eqmc u u' H4 H5.
    apply NatTrans_eq_simplify.
    extensionality c.
    assert (eqmc' := f_equal (fun w : (A –≻ e')%nattrans => Trans w c) eqmc); clear eqmc.
    assert (H4' := f_equal (fun w : (B –≻ e')%nattrans=> Trans w c) H4); clear H4.
    assert (H5' := f_equal (fun w : (B –≻ e')%nattrans => Trans w c) H5); clear H5.
    apply (
        @equalizer_morph_unique
          _
          _
          _
          _
          _
          (Type_Cat_Has_CoEqualizers _ _ (Trans f c) (Trans g c))
          _
          (Trans eqm c)
      ); assumption.
  Qed.

End CoEqualizer.

Instance PSh_Has_CoEqualizers (C : Category) : Has_CoEqualizers (PShCat C)
  := fun _ _ => PSh_CoEq C.


Require Export Iron.Language.SystemF2Effect.Type.
Require Export Iron.Language.SystemF2Effect.Value.Exp.
Require Export Iron.Language.SystemF2Effect.Value.Relation.FreeXX.
Require Export Iron.Language.SystemF2Effect.Value.Relation.SuppX.
Require Export Iron.Language.SystemF2Effect.Value.Relation.TyJudge.
Require Export Iron.Language.SystemF2Effect.Value.Relation.TyJudge.TypeKind.

(********************************************************************)
Fixpoint FreshV (p : nat) (vv : val) : Prop :=
 match vv with
 | VVar     _       => True
 | VLoc     _       => True
 | VLam     t x     => FreshT p t  /\ FreshX p x
 | VLAM     k x     => FreshX p x
 | VConst   _       => True
 end
 with    FreshX (p : nat) (xx : exp) : Prop :=
 match xx with
 | XVal     v       => FreshV p v
 | XLet     t x1 x2 => FreshT p t  /\ FreshX p x1 /\ FreshX p x2
 | XApp     v1 v2   => FreshV p v1 /\ FreshV p v2
 | XAPP     v1 t2   => FreshV p v1 /\ FreshT p t2
 | XOp1     op v    => FreshV p v
 | XPrivate x       => FreshX p x
 | XExtend  t x     => FreshT p t  /\ FreshX p x
 | XAlloc   t v     => FreshT p t  /\ FreshV p v
 | XRead    t v     => FreshT p t  /\ FreshV p v
 | XWrite   t v1 v2 => FreshT p t  /\ FreshV p v1 /\ FreshV p v2
 end.

Definition FreshFreeV p2 te v
 := forall n t, (FreeXV n v /\ get n te = Some t) -> FreshT p2 t.
Hint Unfold FreshFreeV.

Definition FreshFreeX p2 te x
 := forall n t, (FreeXX n x /\ get n te = Some t) -> FreshT p2 t.
Hint Unfold FreshFreeX.

Definition FreshSuppV p2 se v
 := forall l t, get l se = Some t -> SuppV l v -> FreshT p2 t.
Hint Unfold FreshSuppV.

Definition FreshSuppX p2 se x
 := forall l t, get l se = Some t -> SuppX l x -> FreshT p2 t.
Hint Unfold FreshSuppX.

(********************************************************************)
Lemma freshX_typeX
 :  forall ke te se sp x t e  p
 ,  not (In (SRegion p) sp)
 -> TypeX ke te se sp x t e
 -> FreshX p x.
Proof.
 intros. gen ke te se sp t e.
 induction x using exp_mutind with
  (PV := fun v => forall ke te se sp t
      ,  not (In (SRegion p) sp)
      -> TypeV ke te se sp v t
      -> FreshV p v);
  intros; inverts_type;
  try (solve [simpl; rip; eauto]).
Qed.
Hint Resolve freshX_typeX.

Lemma freshT_typeX_type
 :  forall ke te se sp x t e p
 ,  not (In (SRegion p) sp)
 -> TypeX ke te se sp x t e
 -> FreshT p t.
Proof.
 intros. gen ke te se sp t e.
 induction x using exp_mutind with
  (PV := fun v => forall ke te se sp t
      ,  not (In (SRegion p) sp)
      -> TypeV ke te se sp v t
      -> FreshT p t);
  intros; rip; eauto 3.
Qed.
Hint Resolve freshT_typeX_type.

Lemma freshT_typeX_effect
 :  forall ke te se sp x t e p
 ,  not (In (SRegion p) sp)
 -> TypeX ke te se sp x t e
 -> FreshT p e.
Proof.
 intros. gen ke te se sp t e.
 induction x using exp_mutind with
  (PV := fun v => forall ke te se sp t
      ,  not (In (SRegion p) sp)
      -> TypeV ke te se sp v t
      -> FreshT p t);
  intros; rip; eauto 3.
Qed.
Hint Resolve freshT_typeX_effect.

(********************************************************************)
Lemma freshFreeX_nil
 : forall p2 x
 , FreshFreeX p2 nil x.
Proof.
 unfold FreshFreeX.
 intros. snorm.
Qed.
Hint Resolve freshFreeX_nil.

Lemma freshFreeV_nil
 : forall p2 x
 , FreshFreeV p2 nil x.
Proof.
 unfold FreshFreeV.
 intros. snorm.
Qed.
Hint Resolve freshFreeV_nil.

Lemma freshFreeX_XLam
 :  forall p te t  x
 ,  FreshT p t
 -> FreshFreeV p te (VLam t x)
 -> FreshFreeX p (te :> t) x.
Proof.
 intros.
 unfold FreshFreeX in *.
 unfold FreshFreeV in *.
 rip.
 destruct n.
 - snorm.
 - snorm. eauto.
Qed.
Hint Resolve freshFreeX_XLam.

Lemma freshFreeX_XLAM
 :  forall p te k x
 ,  FreshFreeV p te (VLAM k x)
 -> FreshFreeX p (liftTE 0 te) x.
Proof.
 intros.
 unfold FreshFreeX in *.
 unfold FreshFreeV in *.
 rip.
 snorm.
 unfold liftTE in *.
 eapply get_map_exists in H2.
 destruct H2 as [t']. rip.
 rewrite <- freshT_liftTT. eauto.
Qed.
Hint Resolve freshFreeX_XLAM.

Lemma freshFreeX_XLet
 :  forall p t te x1 x2
 ,  FreshT p t
 -> FreshFreeX p te (XLet t x1 x2)
 -> FreshFreeX p (te :> t) x2.
Proof.
 intros.
 unfold FreshFreeX in *.
 rip.
 snorm.
 eapply H0; eauto.
Qed.
Hint Resolve freshFreeX_XLet.

Lemma freshFreeX_XPrivate
 :  forall p te x
 ,  FreshFreeX p te (XPrivate x)
 -> FreshFreeX p (liftTE 0 te) x.
Proof.
 intros.
 unfold FreshFreeX in *.
 rip.
 snorm.
 unfold liftTE in *.
 eapply get_map_exists in H2.
 destruct H2 as [t']. rip.
 rewrite <- freshT_liftTT. eauto.
Qed.

Lemma freshFreeX_XExtend
 :  forall p te t x
 ,  FreshT p t
 -> FreshFreeX p te (XExtend t x)
 -> FreshFreeX p (liftTE 0 te) x.
Proof.
 intros.
 unfold FreshFreeX in *.
 rip.
 snorm.
 unfold liftTE in *.
 eapply get_map_exists in H3.
 destruct H3 as [t']. rip.
 rewrite <- freshT_liftTT. eauto.
Qed.

(********************************************************************)
Lemma freshSuppX_liftTE
 :  forall p se x
 ,  FreshSuppX p se x
 -> FreshSuppX p (liftTE 0 se) x.
Proof.
 intros.
 unfold FreshSuppX in *; intros.
 unfold liftTE in H0.
 eapply get_map_exists in H0.
 destruct H0. rip.
 rewrite <- freshT_liftTT.
 eauto.
Qed.
Hint Resolve freshSuppX_liftTE.

Lemma freshSuppX_XLet_split
 :  forall p te t x1 x2
 ,  FreshSuppX p te (XLet t x1 x2)
 -> FreshSuppX p te x1
 /\ FreshSuppX p te x2.
Proof.
 intros.
 split; unfold FreshSuppX in *; firstorder.
Qed.

Lemma freshSuppX_XLet_join
 :  forall p te t x1 x2
 ,  FreshSuppX p te x1
 -> FreshSuppX p te x2
 -> FreshSuppX p te (XLet t x1 x2).
Proof.
 intros.
 unfold FreshSuppX in *; firstorder.
Qed.

Lemma freshSuppX_XApp_split
 :  forall p te v1 v2
 ,  FreshSuppX p te (XApp v1 v2)
 -> FreshSuppV p te v1
 /\ FreshSuppV p te v2.
Proof.
 intros.
 split; unfold FreshSuppX in *; unfold FreshSuppV in *; firstorder.
Qed.

Lemma freshSuppX_XApp_join
 :  forall p te v1 v2
 ,  FreshSuppV p te v1
 -> FreshSuppV p te v2
 -> FreshSuppX p te (XApp v1 v2).
Proof.
 intros.
 unfold FreshSuppX in *; firstorder.
Qed.

Lemma freshSuppX_XWrite_split
 :  forall p te v1 v2 t
 ,  FreshSuppX p te (XWrite t v1 v2)
 -> FreshSuppV p te v1
 /\ FreshSuppV p te v2.
Proof.
 intros.
 split; unfold FreshSuppX in *; unfold FreshSuppV in *; firstorder.
Qed.

Lemma freshSuppX_XWrite_join
 :  forall p te v1 v2 t
 ,  FreshSuppV p te v1
 -> FreshSuppV p te v2
 -> FreshSuppX p te (XWrite t v1 v2).
Proof.
 intros.
 unfold FreshSuppX in *; firstorder.
Qed.

(* NOTE: the firstorder tactic runs away when given an term with
   multiple sub terms, so we need to do some split/join manually. *)
Lemma freshSuppX_mergeTE
 :  forall p1 p2 p3 te x
 ,  FreshSuppX p1 te x
 -> FreshSuppX p2 te x
 -> FreshSuppX p2 (mergeTE p3 p1 te) x.
Proof.
 intros. gen te.
 induction x using exp_mutind with
  (PV := fun v => forall te
      ,  FreshSuppV p1 te v
      -> FreshSuppV p2 te v
      -> FreshSuppV p2 (mergeTE p3 p1 te) v);
  intros; snorm.

  - firstorder.

  - unfold FreshSuppV in *.
    rip.
    simpl in H2. subst.
    spec H l. spec H0 l. snorm.
    unfold mergeTE in H1.
    eapply get_map_exists in H1.
    destruct H1 as [t'].
    spec H t'. spec H0 t'.
    have (l = l). firstorder.
    subst.
    rewrite mergeT_freshT_id; auto.

  - firstorder.
  - firstorder.
  - firstorder.
  - firstorder.

  - apply freshSuppX_XLet_split in H.
    apply freshSuppX_XLet_split in H0.
    apply freshSuppX_XLet_join; firstorder.

  - apply freshSuppX_XApp_split in H.
    apply freshSuppX_XApp_split in H0.
    apply freshSuppX_XApp_join; firstorder.

  - firstorder.
  - firstorder.
  - firstorder.
  - firstorder.
  - firstorder.
  - firstorder.

  - apply freshSuppX_XWrite_split in H.
    apply freshSuppX_XWrite_split in H0.
    apply freshSuppX_XWrite_join; firstorder.
Qed.

Lemma freshSuppX_typeX
 :  forall ke te se sp x t e p
 ,  not (In (SRegion p) sp)
 -> TypeX ke te se sp x t e
 -> FreshSuppX p se x.
Proof.
 intros. gen ke te se sp t e.
 induction x using exp_mutind with
  (PV := fun v => forall ke te se sp t
      ,  not (In (SRegion p) sp)
      -> TypeV ke te se sp v t
      -> FreshSuppV p se v);
  intros; inverts_type;
  unfold FreshSuppX in *;
  unfold FreshSuppV in *;
  snorm;
  try (solve [ nope]);
  try (solve [ eapply IHx; eauto 2]).

 - subst. rewrite H2 in H0. inverts H0.
   inverts_kind; snorm; eauto.

 - eapply get_map with (f := liftTT 1 0) in H0.
   erewrite freshT_liftTT.
   eapply IHx; eauto.

 - inverts H1.
   eapply IHx1; eauto.
   eapply IHx2; eauto.

 - inverts H1.
   eapply IHx; eauto.
   eapply IHx0; eauto.

 - eapply get_map with (f := liftTT 1 0) in H0.
   erewrite freshT_liftTT.
   eapply IHx; eauto.

 - eapply get_map with (f := liftTT 1 0) in H0.
   erewrite freshT_liftTT.
   eapply IHx; eauto.

 - inverts H1.
   eapply IHx; eauto.
   eapply IHx0; eauto.
Qed.


Require Import Bedrock.Platform.Facade.examples.TuplesF.
Require Import CertifiedExtraction.Utils.
Require Import Bedrock.Memory.

Require Import CertifiedExtraction.Extraction.QueryStructures.Basics.
Require Import CertifiedExtraction.Extraction.QueryStructures.AllOfLength.
Require Import CertifiedExtraction.Extraction.QueryStructures.TupleToListW.
Require Import CertifiedExtraction.Extraction.QueryStructures.Zip2.

Require Import
        Coq.Lists.List
        Coq.Program.Program.

(** Connections of [IndexedEnsemble]s, [Tuple]s, and [GenericTuple W]. *)

Definition IndexedEnsemble_TupleToListW {N} (ensemble: FiatWBag N) : BedrockWBag :=
  fun indexedListW => exists tup, ensemble tup /\ RelatedIndexedTupleAndListW indexedListW tup.

Lemma IndexedEnsemble_TupleToListW_refl :
  forall {N} (tup: FiatWElement N) (ens: FiatWBag N),
    ens tup -> IndexedEnsemble_TupleToListW ens (TupleToListW_indexed tup).
Proof.
  cleanup; red; eauto using RelatedIndexedTupleAndListW_refl.
Qed.

Lemma IndexedEnsemble_TupleToListW_inj_helper:
  forall (N : nat) (e : FiatWBag N) (x : FiatWElement N),
    (IndexedEnsemble_TupleToListW e (IndexedElement_TupleToListW (N := N) x)) <-> e x.
Proof.
  unfold IndexedEnsemble_TupleToListW, RelatedIndexedTupleAndListW;
  repeat match goal with
         | _ => cleanup
         | _ => eassumption
         | _ => progress subst
         | [ x: FiatWElement _ |- _ ] => destruct x
         | [ H: TupleToListW _ = TupleToListW _ |- _ ] => apply TupleToListW_inj in H
         | _ => eexists
         | _ => simpl in *
         end.
Qed.

Lemma lift_eq {A} (f g: A -> Prop) :
  f = g -> (forall x, f x <-> g x).
Proof.
  intros; subst; reflexivity.
Qed.

Lemma IndexedEnsemble_TupleToListW_inj :
  forall {N} (e1 e2: FiatWBag N),
    IndexedEnsemble_TupleToListW e1 = IndexedEnsemble_TupleToListW e2 ->
    e1 = e2.
Proof.
  intros * H; pose proof (lift_eq H); clear H.
  apply Ensembles.Extensionality_Ensembles; unfold Ensembles.Same_set, Ensembles.Included, Ensembles.In.
  repeat cleanup; repeat match goal with
                         | [ H: forall _, _ |- _ ?x ] => specialize (H (IndexedElement_TupleToListW x)); cbv beta in H
                         | [ H: _ |- _ ] => setoid_rewrite IndexedEnsemble_TupleToListW_inj_helper in H
                         end; tauto.
Qed.

Hint Resolve IndexedEnsemble_TupleToListW_inj : inj_db.

Lemma IndexedEnsemble_TupleToListW_length:
  forall (N : nat) (table: FiatWBag N),
    BinNat.N.lt (BinNat.N.of_nat N) (Word.Npow2 32) ->
    AllOfLength_set N (IndexedEnsemble_TupleToListW table).
Proof.
repeat match goal with
       | _ => cleanup
       | _ => progress destruct_conjs
       | _ => progress unfold AllOfLength_set, IndexedEnsemble_TupleToListW,
             RelatedIndexedTupleAndListW, Ensembles.In, GenericTuple in *
       | [ H: _ = _ |- _ ] => rewrite H
       end; auto using TupleToListW_length.
Qed.

Lemma EnsembleIndexedListEquivalence_keepEq_AllOfLength:
  forall {N : nat} {table k default key seq},
    BinNat.N.lt (BinNat.N.of_nat N) (Word.Npow2 32) ->
    TuplesF.EnsembleIndexedListEquivalence
      (TuplesF.keepEq eq default (@IndexedEnsemble_TupleToListW N table) k key) seq ->
    AllOfLength_list N seq.
Proof.
  cleanup; eapply EnsembleIndexedListEquivalence_AllOfLength;
  eauto using keepEq_length, IndexedEnsemble_TupleToListW_length.
Qed.

Hint Unfold IndexedEnsembles.EnsembleIndexedListEquivalence
     IndexedEnsembles.UnIndexedEnsembleListEquivalence
     TuplesF.EnsembleIndexedListEquivalence
     TuplesF.UnIndexedEnsembleListEquivalence
     IndexedEnsembles.UnConstrFreshIdx TuplesF.UnConstrFreshIdx : FiatBedrockEquivalences.

Hint Unfold Ensembles.Same_set Ensembles.Included Ensembles.In : Ensembles.

Lemma EnsembleIndexedListEquivalence_TupleToListW_FreshIdx:
  forall (n : nat) (lst : list (FiatWTuple n)) (ens : FiatWBag n),
    TuplesF.EnsembleIndexedListEquivalence
      (IndexedEnsemble_TupleToListW ens) (map TupleToListW lst) ->
    exists bound : nat, IndexedEnsembles.UnConstrFreshIdx ens bound.
Proof.
  repeat match goal with
         | _ => cleanup
         | _ => progress destruct_conjs
         | [ H: context[IndexedEnsemble_TupleToListW ?ens _], H': ?ens ?element |- _ ] =>
           learn (H (TupleToListW_indexed element))
         | _ => progress autounfold with FiatBedrockEquivalences Ensembles in *
         | [  |- exists x, _ ] => eexists
         end; eauto using IndexedEnsemble_TupleToListW_refl.
Qed.

Lemma map_id' :
  forall `{f: A -> A} lst,
    (forall x, List.In x lst -> f x = x) ->
    map f lst = lst.
Proof.
  induction lst; simpl; intros.
  - eauto.
  - f_equal; eauto.
Qed.

Lemma EnsembleIndexedListEquivalence_TupleToListW_UnIndexedEquiv_Characterisation:
  forall (n : nat) (lst : list (FiatWTuple n)) (x : list BedrockWElement),
    map TuplesF.indexedElement x = map TupleToListW lst ->
    map2
      (fun (x0 : BedrockWElement) (y : FiatWTuple n) =>
         TupleToListW_indexed
           {| IndexedEnsembles.elementIndex := TuplesF.elementIndex x0; IndexedEnsembles.indexedElement := y |})
      x lst = x.
Proof.
  unfold TupleToListW_indexed; cleanup; simpl;
  rewrite map2_two_maps, <- H, two_maps_map2;
  apply map_id'; destruct 0; reflexivity.
Qed.

Lemma BedrockWElement_roundtrip:
  forall (b: BedrockWElement),
    {| TuplesF.elementIndex := TuplesF.elementIndex b; TuplesF.indexedElement := TuplesF.indexedElement b |}
    = b.
Proof.
  destruct 0; reflexivity.
Qed.

Lemma IndexedEnsemble_TupleToListW_Characterization :
  forall {N} ens (x: BedrockWElement) (t: FiatWTuple N),
    TuplesF.indexedElement x = TupleToListW t ->
    IndexedEnsemble_TupleToListW (N := N) ens x ->
    ens {| IndexedEnsembles.elementIndex := TuplesF.elementIndex x; IndexedEnsembles.indexedElement := t |}.
Proof.
  cleanup.
  repeat match goal with
         | _ => progress destruct_conjs
         | [ H: TupleToListW _ = TupleToListW _ |- _ ] => apply TupleToListW_inj in H
         | [ H: FiatWElement _ |- _ ] => destruct H
         | [ H: BedrockWElement |- _ ] => destruct H
         | _ => progress unfold IndexedEnsemble_TupleToListW, RelatedIndexedTupleAndListW in H0
         | _ => progress (simpl in *; subst)
         | _ => trivial
         end.
Qed.

Ltac map2_t :=
  match goal with
  | [  |- context[map _ (map2 _ _ _)] ] => unfold map2; rewrite map_map; simpl
  | [  |- context[map ?f (zip2 ?x ?y)] ] => change (map f (zip2 x y)) with (map2 (fun x y => f (x, y)) x y); simpl
  | [ H: In _ (map2 _ _ _) |- _ ] => (unfold map2 in H; rewrite in_map_iff in H)
  | [ H: In (_, _) (zip2 _ _) |- _ ] => learn (in_zip2 _ _ _ _ H)
  | [ H: map _ ?aa = map _ ?bb, H': In (_, _) (zip2 ?aa ?bb) |- _ ] => learn (in_zip2_map_map_eq H H')
  end.

Hint Rewrite
     @map2_fst'
     @map2_snd
     @EnsembleIndexedListEquivalence_TupleToListW_UnIndexedEquiv_Characterisation
  : EnsembleIndexedListEquivalence_TupleToListW_UnIndexedEquiv.

Require Import Coq.Strings.String.

Lemma EnsembleIndexedListEquivalence_TupleToListW_UnIndexedEquiv:
  forall (n : nat) (lst : list (FiatWTuple n)) (ens : FiatWBag n),
    TuplesF.EnsembleIndexedListEquivalence (IndexedEnsemble_TupleToListW ens) (map TupleToListW lst) ->
    IndexedEnsembles.UnIndexedEnsembleListEquivalence ens lst.
Proof.
  repeat match goal with
         | _ => cleanup
         | _ => solve [constructor]
         | _ => progress destruct_conjs
         | _ => progress map2_t

         | [ H: context[IndexedEnsemble_TupleToListW ?ens _] |- context [?ens ?element] ] =>
           specialize (H (TupleToListW_indexed element))
         | [ H: context[IndexedEnsemble_TupleToListW ?ens _], H': ?ens ?element |- _ ] =>
           specialize (H (TupleToListW_indexed element))
         | [ H: ?ens ?element |- _ ] => learn (IndexedEnsemble_TupleToListW_refl element ens H)
         | [ H: map TuplesF.indexedElement ?x = map TupleToListW ?y
             |- map IndexedEnsembles.indexedElement ?var = ?y ] =>
           is_evar var;
             unify var (map2 (fun bedrockElement fiatTuple =>
                                {| IndexedEnsembles.elementIndex := TuplesF.elementIndex bedrockElement;
                                   IndexedEnsembles.indexedElement := fiatTuple |}) x y)
             ; pose "Removing this string will break the match that introduced it (this is Coq bug #3412)"%string
         | [ H: context[In (TupleToListW_indexed ?x) _] |- In ?x _ ] =>
           rewrite <- (Equality.in_map_iff_injective TupleToListW_indexed)
             by (eauto using TupleToListW_indexed_inj)
         | [ H: TuplesF.indexedElement _ = TupleToListW _ |- _ ] => rewrite <- H in *

         | [ H: map _ _ = map _ _ |- _ ] => learn (map_map_sameLength H)
         | _ => progress rewrite BedrockWElement_roundtrip in *
         | _ => progress autounfold with FiatBedrockEquivalences Ensembles in *
         | _ => progress autorewrite with EnsembleIndexedListEquivalence_TupleToListW_UnIndexedEquiv
         | [  |- exists x, _ ] => eexists
         | _ => unfold TupleToListW_indexed in *; simpl in *
         end; apply IndexedEnsemble_TupleToListW_Characterization; try tauto.
Qed.

Lemma ListWToTuple_Truncated_map_keepEq:
  forall (N : nat) (table : FiatWBag N) w,
    BinNat.N.lt (BinNat.N.of_nat N) (Word.Npow2 32) ->
    forall (x8 : W) (x9 : list TuplesF.tupl) default,
      TuplesF.EnsembleIndexedListEquivalence
        (TuplesF.keepEq eq default (IndexedEnsemble_TupleToListW table) w x8) x9 ->
      x9 = map TupleToListW (map (ListWToTuple_Truncated N) x9).
Proof.
  cleanup.
  rewrite map_map.
  rewrite map_id'; [ eauto | intros; symmetry; apply ListWToTuple_Truncated_id ].
  apply (EnsembleIndexedListEquivalence_keepEq_AllOfLength H H0); assumption.
Qed.

Lemma EnsembleIndexedListEquivalence_TupleToListW :
  forall n lst ens,
    TuplesF.EnsembleIndexedListEquivalence
      (IndexedEnsemble_TupleToListW ens) (map (TupleToListW (N := n)) lst) ->
    IndexedEnsembles.EnsembleIndexedListEquivalence ens lst.
Proof.
  cleanup.
  split; eauto using EnsembleIndexedListEquivalence_TupleToListW_FreshIdx, EnsembleIndexedListEquivalence_TupleToListW_UnIndexedEquiv.
Qed.

Lemma TuplesF_EnsembleIndexedListEquivalence_EquivEnsembles :
  forall A ens1 ens2,
    Ensembles.Same_set _ ens1 ens2 ->
    forall seq, @TuplesF.EnsembleIndexedListEquivalence A ens1 seq <->
                @TuplesF.EnsembleIndexedListEquivalence A ens2 seq.
Proof.
  intros.
  apply Ensembles.Extensionality_Ensembles in H; rewrite H; reflexivity.
Qed.

Definition FiatWBagEmpty N : FiatWBag N := fun _ => False.

Lemma Empty_lift:
  forall N : nat,
    Empty = IndexedEnsemble_TupleToListW (FiatWBagEmpty N).
Proof.
  intros; apply Ensembles.Extensionality_Ensembles.
  unfold Ensembles.Same_set, Ensembles.Included, Ensembles.In, FiatWBagEmpty, Empty, IndexedEnsemble_TupleToListW; split; intros.
  - exfalso; assumption.
  - repeat cleanup.
Qed.