Require Import VST.msl.msl_standard.
Require Import VST.msl.corable.
Require Import RamifyCoq.msl_ext.ramify_tactics.
Require Import RamifyCoq.msl_ext.msl_ext.
Require Import RamifyCoq.msl_ext.sepalg.

Local Open Scope pred.

Lemma join_age {A}{JA: Join A}{PA: Perm_alg A}{AG: ageable A}{XA: Age_alg A}:
  forall h1 h2 h12 h1' h2' h12', join h1 h2 h12 -> join h1' h2' h12' -> age h1 h1' -> age h2 h2' -> age h12 h12'.
Proof.
  intros; destruct (age1_join _ H H1) as [w2 [w12 [? [? ?]]]];
  equate_age h2' w2; equate_join h12' w12; auto.
Qed.

Program Definition ocon {A: Type}{JA: Join A}{PA : Perm_alg A}{AG : ageable A} {AA : Age_alg 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.
Next Obligation.
  destruct H0 as [h1 [h2 [h3 [h12 [h23 [? [? [? [? ?]]]]]]]]].
  try_join h2 h3 h23'; equate_join h23 h23'.
  destruct (age1_join2 _ H2 H) as [w12 [w3 [? [? ?]]]].
  destruct (age1_join2 _ H0 H7) as [w1 [w2 [? [? ?]]]].
  try_join w2 w3 w23.
  exists w1, w2, w3, w12, w23.
  repeat split; auto.
  apply pred_hereditary with h12; auto.
  apply pred_hereditary with h23; auto.
  apply (join_age h2 h3 _ w2 w3 _); auto.
Qed.

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

Program Definition owand {A: Type}{JA: Join A}{PA : Perm_alg A}{AG : ageable A} {AA : Age_alg A} (p q:pred A) : pred A :=
  fun h23':A => forall h23 h1 h2 h3 h12 h123, necR h23' h23 -> join h1 h2 h12 -> join h2 h3 h23 -> join h12 h3 h123 -> p h12 -> q h123.
Next Obligation.
  rename a' into h23'.
  eapply (H0 h23 h1 h2 h3 h12 h123); eauto.
  apply necR_power_age.
  apply necR_power_age in H1.
  destruct H1 as [n ?H].
  exists (S n).
  exists h23'; auto.
Qed.

Lemma ocon_emp {A}{JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{CA: Canc_alg A}{AG : ageable A} {AA : Age_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 {A}{JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{CA: Canc_alg A}{AG : ageable A} {AA : Age_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 {A}{JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{AG : ageable A} {AA : Age_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 {A}{JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{AG : ageable A} {AA : Age_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. intuition.
Qed.

Lemma sepcon_ocon {A}{JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{AG : ageable A} {AA : Age_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 join_necR {A}{JA: Join A}{PA: Perm_alg A}{AG: ageable A}{XA: Age_alg A}:
  forall h1 h2 h12 h1' h2' h12', join h1 h2 h12 -> join h1' h2' h12' -> necR h1 h1' -> necR h2 h2' -> necR h12 h12'.
Proof.
  intros; destruct (nec_join H H1) as [w2 [w12 [? [? ?]]]];
  destruct (join_level _ _ _ H3); rewrite <- H7 in H6;
  destruct (join_level _ _ _ H0); rewrite <- H9 in H8;
  rewrite H8 in H6; generalize (necR_linear' H2 H4 H6); intro;
  rewrite <- H10 in H3; equate_join h12' w12; auto.
Qed.

Lemma ocon_wand {A}{JA: Join A}{PA: Perm_alg A}{AG : ageable A} {AA : Age_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 H as [h1 [h2 [h3 [h12 [h23 [? [? [? [? ?]]]]]]]]].
  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 h1' h2' h12'; intros; apply (pred_nec_hereditary P h12); auto; apply (join_necR h1 h2 _ h1' h2' _); auto.
  intros h3' h2' h23'; intros; apply (pred_nec_hereditary Q h23); auto; apply (join_necR h2 h3 _ h2' h3' _); auto.
  (* 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 w1 w2); auto. apply (HQ w3 w2); auto.
Qed.

Lemma ocon_comm {A}{JA: Join A}{PA: Perm_alg A}{AG : ageable A} {AA : Age_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 {A}{JA: Join A}{PA: Perm_alg A}{AG : ageable A} {AA : Age_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 {A}{JA: Join A}{PA: Perm_alg A}{CA: Cross_alg A}{AG : ageable A} {AA : Age_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 w2 w6 w4 w7 w26 w47); auto. apply (cross_rev 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 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 {A} {JA: Join A}{PA: Perm_alg A}{AG : ageable A} {AA : Age_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 {A} {JA: Join A}{PA: Perm_alg A}{AG : ageable A} {AA : Age_alg A}: forall P Q R, ocon P Q |-- R <-> P |-- owand Q R.
Proof.
  intros.
  rewrite ocon_comm.
  unfold ocon, owand, derives.
  simpl.
  split; intros.
  + apply H.
    exists h1, h2, h3, h12, h23.
    repeat split; auto.
    inversion P.
    apply pred_nec_hereditary with a; auto.
  + destruct H0 as [h1 [h2 [h3 [h12 [h23 [? [? [? [? ?]]]]]]]]].
    specialize (H h23 H4).
    specialize (H h23 h1 h2 h3 h12 a).
    apply H; auto.
Qed.

Lemma ocon_contain {A} {JA: Join A} {PA: Perm_alg A} {SA: Sep_alg A}{AG : ageable A} {AA : Age_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 {A} {JA: Join A} {PA: Perm_alg A} {SA: Sep_alg A} {CA: Canc_alg A} {DA: Disj_alg A} {AG : ageable A} {AA : Age_alg A}: forall P Q, precise P -> Q |-- P * TT -> Q = ocon P Q.
Proof.
  intros; apply pred_ext; [apply ocon_contain; 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 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} {AG : ageable 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 {A: Type} {JA: Join A} {SA: Sep_alg A} {PA : Perm_alg A} {AG : ageable A} {AA : Age_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 {A: Type} {JA: Join A} {SA: Sep_alg A} {PA : Perm_alg A} {CA: Canc_alg A} {AG : ageable A} {AA : Age_alg A}: forall P, disjointed P emp.
Proof.
  intros.
  unfold disjointed, emp; 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 {A: Type} {JA: Join A} {PA: Perm_alg A} {AG : ageable 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 {A: Type} {JA: Join A} {PA: Perm_alg A} {AG : ageable 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 {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} {AG : ageable A} {AA : Age_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.

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

Lemma covariant_ocon {B}{A} {JA: Join A}{PA: Perm_alg A}{AG : ageable A} {AA : Age_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.
  apply H, H1.
  apply H0, H1.
Qed.

Definition contravariant {B A : Type} {AG: ageable A} (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 {B}{A} {JA: Join A}{PA: Perm_alg A}{AG : ageable A} {AA : Age_alg A}:
   forall F1 F2 : (B -> pred A) -> (B -> pred A),
    contravariant F1 -> contravariant F2 ->
    contravariant (fun (x : B -> pred A) b => F1 x b ⊗ F2 x b).
Proof.
  intros; hnf.
  intros P Q ? ?.
  eapply ocon_derives.
  apply H, H1.
  apply H0, H1.
Qed.

Lemma later_ocon {A}{JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{AG: ageable A}{XA: Age_alg A}:
  forall P Q, ((|> (P ⊗ Q)) = |> Q ⊗ |> P).
Proof.
  intros; repeat rewrite later_age; apply pred_ext; hnf; intros; simpl in *.
  case_eq (age1 a); intros.
  destruct (H a0) as [h1' [h2' [h3' [h12' [h23' [? [? [? [? ?]]]]]]]]]; auto.
  destruct (unage_join2 _ H3 H0) as [x12 [x3 [? [? ?]]]].
  destruct (unage_join2 _ H1 H7) as [x1 [x2 [? [? ?]]]].
  try_join x2 x3 x23; exists x3, x2, x1, x23, x12; repeat (split; auto).
  assert (age x23 h23') by (apply (join_age x2 x3 _ h2' h3' _); auto); intro h23; intros; equate_age h23' h23; auto.
  assert (age x12 h12') by (apply (join_age x1 x2 _ h1' h2' _); auto); intro h12; intros; equate_age h12' h12; auto.
  exists (core a), a, (core a), a, a. repeat split.
  apply core_unit. apply join_comm, core_unit. apply join_comm, core_unit.
  intros; unfold age in H1; rewrite H0 in H1; discriminate H1.
  intros; unfold age in H1; rewrite H0 in H1; discriminate H1.
  (* another direction *)
  destruct H as [x1 [x2 [x3 [x12 [x23 [? [? [? [? ?]]]]]]]]]; intros.
  destruct (age1_join2 _ H1 H4) as [h12 [h3 [? [? ?]]]].
  destruct (age1_join2 _ H H6) as [h1 [h2 [? [? ?]]]].
  try_join h2 h3 h23; exists h3, h2, h1, h23, h12; repeat (split; auto).
  apply H3; apply (join_age x2 x3 _ h2 h3 _); auto.
Qed.

Lemma precise_ocon {A} {JA : Join A} {PA : Perm_alg A} {SA: Sep_alg A}{CaA : Canc_alg A}{CrA : Cross_alg A}{DA : Disj_alg A}{AG : ageable A} {AA : Age_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 {A} {JA : Join A} {PA : Perm_alg A} {SA: Sep_alg A} {CaA : Canc_alg A}
      {CrA : Cross_alg A} {DA : Disj_alg A}{AG : ageable A} {AA : Age_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 {A} {JA : Join A} {PA : Perm_alg A} {SA: Sep_alg A}{AG : ageable A} {AA : Age_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  {A}{JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{CA: Canc_alg A}{DA : Disj_alg A}{AG : ageable A} {AA : Age_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 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: forall {A}{JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{AG : ageable A} {AA : Age_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{A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{agA: ageable A}{AgeA: Age_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.


From iris.program_logic Require Export total_weakestpre.
From iris.bi Require Export big_op.
From iris.proofmode Require Import tactics.
Set Default Proof Using "Type".

Section lifting.
Context `{irisG Λ Σ}.
Implicit Types v : val Λ.
Implicit Types e : expr Λ.
Implicit Types σ : state Λ.
Implicit Types P Q : iProp Σ.
Implicit Types Φ : val Λ → iProp Σ.

Lemma twp_lift_step s E Φ e1 :
  to_val e1 = None →
  (∀ σ1, state_interp σ1 ={E,∅}=∗
    ⌜if s is NotStuck then reducible e1 σ1 else True⌝ ∗
    ∀ e2 σ2 efs, ⌜prim_step e1 σ1 e2 σ2 efs⌝ ={∅,E}=∗
      state_interp σ2 ∗ WP e2 @ s; E [{ Φ }] ∗ [∗ list] ef ∈ efs, WP ef @ s; ⊤ [{ _, True }])
  ⊢ WP e1 @ s; E [{ Φ }].
Proof. by rewrite twp_unfold /twp_pre=> ->. Qed.

(** Derived lifting lemmas. *)
Lemma twp_lift_pure_step `{Inhabited (state Λ)} s E Φ e1 :
  (∀ σ1, reducible e1 σ1) →
  (∀ σ1 e2 σ2 efs, prim_step e1 σ1 e2 σ2 efs → σ1 = σ2) →
  (|={E}=> ∀ e2 efs σ, ⌜prim_step e1 σ e2 σ efs⌝ →
    WP e2 @ s; E [{ Φ }] ∗ [∗ list] ef ∈ efs, WP ef @ s; ⊤ [{ _, True }])
  ⊢ WP e1 @ s; E [{ Φ }].
Proof.
  iIntros (Hsafe Hstep) "H". iApply twp_lift_step.
  { eapply reducible_not_val, (Hsafe inhabitant). }
  iIntros (σ1) "Hσ". iMod "H".
  iMod fupd_intro_mask' as "Hclose"; last iModIntro; first set_solver.
  iSplit; [by destruct s|]; iIntros (e2 σ2 efs ?).
  destruct (Hstep σ1 e2 σ2 efs); auto; subst.
  iMod "Hclose" as "_". iFrame "Hσ". iApply "H"; auto.
Qed.

(* Atomic steps don't need any mask-changing business here, one can
   use the generic lemmas here. *)
Lemma twp_lift_atomic_step {s E Φ} e1 :
  to_val e1 = None →
  (∀ σ1, state_interp σ1 ={E}=∗
    ⌜if s is NotStuck then reducible e1 σ1 else True⌝ ∗
    ∀ e2 σ2 efs, ⌜prim_step e1 σ1 e2 σ2 efs⌝ ={E}=∗
      state_interp σ2 ∗
      from_option Φ False (to_val e2) ∗ [∗ list] ef ∈ efs, WP ef @ s; ⊤ [{ _, True }])
  ⊢ WP e1 @ s; E [{ Φ }].
Proof.
  iIntros (?) "H". iApply (twp_lift_step _ E _ e1)=>//; iIntros (σ1) "Hσ1".
  iMod ("H" $! σ1 with "Hσ1") as "[$ H]".
  iMod (fupd_intro_mask' E ∅) as "Hclose"; first set_solver.
  iIntros "!>" (e2 σ2 efs) "%". iMod "Hclose" as "_".
  iMod ("H" $! e2 σ2 efs with "[#]") as "($ & HΦ & $)"; first by eauto.
  destruct (to_val e2) eqn:?; last by iExFalso.
  iApply twp_value; last done. by apply of_to_val.
Qed.

Lemma twp_lift_pure_det_step `{Inhabited (state Λ)} {s E Φ} e1 e2 efs :
  (∀ σ1, reducible e1 σ1) →
  (∀ σ1 e2' σ2 efs', prim_step e1 σ1 e2' σ2 efs' → σ1 = σ2 ∧ e2 = e2' ∧ efs = efs')→
  (|={E}=> WP e2 @ s; E [{ Φ }] ∗ [∗ list] ef ∈ efs, WP ef @ s; ⊤ [{ _, True }])
  ⊢ WP e1 @ s; E [{ Φ }].
Proof.
  iIntros (? Hpuredet) ">H". iApply (twp_lift_pure_step _ E); try done.
  { by intros; eapply Hpuredet. }
  by iIntros "!>" (e' efs' σ (_&->&->)%Hpuredet).
Qed.

Lemma twp_pure_step `{Inhabited (state Λ)} s E e1 e2 φ Φ :
  PureExec φ e1 e2 →
  φ →
  WP e2 @ s; E [{ Φ }] ⊢ WP e1 @ s; E [{ Φ }].
Proof.
  iIntros ([??] Hφ) "HWP".
  iApply (twp_lift_pure_det_step with "[HWP]"); [eauto|naive_solver|auto].
Qed.
End lifting.


Require Import IL SepIL.
Require Import Word Memory.
Import List.
Require Import DepList EqdepClass.
Require Import PropX.
Require Import Expr SepExpr SepCancel.
Require Import Prover ILEnv.
Require Import Tactics Reflection.
Require Import TacPackIL.
Require ExprUnify.

Set Implicit Arguments.
Set Strict Implicit.

Module U := ExprUnify.UNIFIER.
Module CANCEL := SepCancel.Make U SepIL.SH.

Section existsSubst.
  Variable types : list type.
  Variable funcs : functions types.
  Variable meta_base : env types.
  Variable var_env : env types.
  Variable sub : U.Subst types.

  Definition ExistsSubstNone (_ : tvar) (_ : expr types) :=
    False.

  Fixpoint substInEnv (from : nat) (vals : env types) (ret : env types -> Prop) : Prop :=
    match vals with
      | nil => ret nil
      | val :: vals =>
        match U.Subst_lookup from sub with
          | None => substInEnv (S from) vals (fun e => ret (val :: e))
          | Some v =>
            match exprD funcs meta_base var_env v (projT1 val) with
              | None => ExistsSubstNone (projT1 val) v
              | Some v' => projT2 val = v' /\ substInEnv (S from) vals (fun e => ret (existT _ (projT1 val) v' :: e))
            end
        end
    end.

  Fixpoint existsMaybe (vals : list { t : tvar & option (tvarD types t) }) (ret : env types -> Prop) : Prop :=
    match vals with
      | nil => ret nil
      | existT t None :: vals => exists x : tvarD types t, existsMaybe vals (fun e => ret (existT _ t x :: e))
      | existT t (Some v) :: vals => existsMaybe vals (fun e => ret (existT _ t v :: e))
    end.

End existsSubst.

Definition existsSubst types funcs var_env sub (from : nat) (vals : list { t : tvar & option (tvarD types t) }) (ret : env types -> Prop) :=
  existsMaybe vals (fun e => @substInEnv types funcs e var_env sub from e ret).

Fixpoint consistent {ts} (vals : list { x : tvar & option (tvarD ts x) }) (e : list { x : tvar & tvarD ts x }) : Prop :=
  match vals , e with
    | nil , nil => True
    | existT t None :: vals , existT t' _ :: e =>
      t = t' /\ @consistent _ vals e
    | existT t (Some v) :: vals , existT t' v' :: e =>
      match equiv_dec t t' return Prop with
        | left pf =>
          v' = match (pf : t = t') in _ = t return tvarD ts t with
                 | refl_equal => v
               end /\ @consistent _ vals e
        | right _ => False
      end
    | _ , _ => False
  end.

Lemma ex_iff : forall T (P P' : T -> Prop),
  (forall x, P x <-> P' x) ->
  ((exists x, P x) <-> (exists x, P' x)).
Proof. split; intuition; destruct H0 as [ x ? ]; exists x; firstorder. Qed.

Theorem existsMaybe_sem : forall types vals (ret : env types -> Prop),
  existsMaybe vals ret <->
  existsEach (map (@projT1 _ _) vals) (fun e => consistent vals e /\ ret e).
Proof.
  induction vals; simpl; intros.
  { intuition. }
  { destruct a. destruct o.
    { rewrite IHvals. intuition. exists t. apply existsEach_sem. apply existsEach_sem in H.
      destruct H. exists x0. simpl in *. rewrite EquivDec_refl_left. intuition.
      destruct H. apply existsEach_sem. apply existsEach_sem in H. destruct H.
      exists x1. simpl in *. rewrite EquivDec_refl_left in H. intuition; subst; auto. }
    { simpl. eapply ex_iff. intros. rewrite IHvals.
      intuition; apply existsEach_sem in H; apply existsEach_sem; destruct H; exists x1; intuition. } }
Qed.

Lemma substInEnv_sem : forall types funcs meta_env var_env sub vals from ret,
  @substInEnv types funcs meta_env var_env sub from vals ret <->
  (U.Subst_equations_to funcs meta_env var_env sub from vals /\ ret vals).
Proof.
  induction vals; simpl; intros.
  { intuition. }
  { destruct a; simpl in *.
    consider (U.Subst_lookup from sub); simpl; intros.
    consider (exprD funcs meta_env var_env e x); simpl; intros.
    { rewrite IHvals. intuition; subst; auto. }
    { intuition. }
    { rewrite IHvals. intuition. } }
Qed.

Lemma existsSubst_sem : forall ts (funcs : functions ts) vals sub vars_env from ret,
  existsSubst funcs vars_env sub from vals ret <->
  existsEach (map (@projT1 _ _) vals) (fun meta_env =>
    consistent vals meta_env /\ U.Subst_equations_to funcs meta_env vars_env sub from meta_env /\ ret meta_env).
Proof.
  intros. unfold existsSubst.
  rewrite existsMaybe_sem. rewrite existsEach_sem. rewrite existsEach_sem.
  apply ex_iff. intros. rewrite substInEnv_sem. intuition.
Qed.

Lemma AllProvable_impl_AllProvable : forall ts (funcs : functions ts) U G P ps,
  AllProvable funcs U G ps ->
  AllProvable_impl funcs U G P ps ->
  P.
Proof. clear. induction ps; simpl; intros; eauto. intuition. Qed.

Section canceller.
  Variable ts : list type.
  Let types := Env.repr BedrockCoreEnv.core ts.
  Variable funcs : functions types.
  Variable preds : SEP.predicates types BedrockCoreEnv.pc BedrockCoreEnv.st.
  Variable algos : ILAlgoTypes.AllAlgos ts.

  Record CancellerResult : Type :=
  { AllExt : variables
  ; ExExt  : variables
  ; Lhs    : SH.SHeap types BedrockCoreEnv.pc BedrockCoreEnv.st
  ; Rhs    : SH.SHeap types BedrockCoreEnv.pc BedrockCoreEnv.st
  ; Subst  : U.Subst types
  }.

  Definition canceller (uvars : list tvar) (hyps : Expr.exprs types)
    (lhs rhs : SEP.sexpr types BedrockCoreEnv.pc BedrockCoreEnv.st) : option CancellerResult :=
    let prover :=
      match ILAlgoTypes.Prover algos with
        | None => provers.ReflexivityProver.reflexivityProver
        | Some p => p
      end
    in
    let hints :=
      match ILAlgoTypes.Hints algos with
        | None => UNF.default_hintsPayload _ _ _
        | Some h => h
      end
    in
    let (ql, lhs) := SH.hash lhs in
    let facts := Summarize prover (map (liftExpr 0 0 0 (length ql)) hyps ++ SH.pures lhs) in
    let pre :=
      {| UNF.Vars  := rev ql
       ; UNF.UVars := uvars
       ; UNF.Heap  := lhs
      |}
    in
    match UNF.forward hints prover 10 facts pre with
      | ({| UNF.Vars := vars' ; UNF.UVars := uvars' ; UNF.Heap := lhs |}, n_forward) =>
        let (qr, rhs) := SH.hash rhs in
        let rhs :=
          UNF.HEAP_FACTS.sheapSubstU 0 (length qr) (length uvars') rhs
        in
        let post :=
          {| UNF.Vars  := vars'
           ; UNF.UVars := uvars' ++ rev qr
           ; UNF.Heap  := rhs
          |}
        in
        match UNF.backward hints prover 10 facts post with
          | ({| UNF.Vars := vars' ; UNF.UVars := uvars' ; UNF.Heap := rhs |}, n_backward) =>
            let new_vars  := vars' in
            let new_uvars := skipn (length uvars) uvars' in
            let bound := length uvars' in
            match CANCEL.sepCancel preds prover bound facts lhs rhs (U.Subst_empty _) false with
              | Some (l,r,s) =>
                Some {| AllExt := new_vars
                      ; ExExt  := new_uvars
                      ; Lhs    :=
                        (** TODO: this is a hack for the moment to ensure that
                         ** the pure premises are well typed without the new
                         ** unification variables
                         **)
                        {| SH.impures := SH.impures l
                         ; SH.pures   := SH.pures lhs
                         ; SH.other   := SH.other l
                         |}
                      ; Rhs    := r
                      ; Subst  := s
                      |}
              | None =>
                if match ql , qr with
                     | nil , nil =>
                       match SH.pures lhs , SH.pures rhs with
                         | nil, nil =>
                           if EqNat.beq_nat n_forward 10 then EqNat.beq_nat n_backward 10 else false
                         | _ , _ => false
                       end
                     | _ , _ => false
                   end then
                  None
                else
                  Some {| AllExt := new_vars
                        ; ExExt  := new_uvars
                        ; Lhs    := lhs
                        ; Rhs    := rhs
                        ; Subst  := U.Subst_empty _
                        |}
            end
        end
    end.

  Lemma AllProvable_and_sem : forall U G P Ps,
    AllProvable_and funcs U G P Ps <-> (AllProvable funcs U G Ps /\ P).
  Proof. induction Ps; simpl; intros; intuition auto. Qed.
  Lemma app_inj_length : forall T (a b c d : list T),
    a ++ b = c ++ d ->
    length a = length c ->
    a = c /\ b = d.
  Proof.
    induction a; destruct c; simpl; intros; think; try solve [ intuition ].
    inversion H; subst.  eapply IHa in H3. intuition; subst; auto. omega.
  Qed.
  Lemma WellTyped_env_app : forall ts a b c d,
    WellTyped_env a c ->
    WellTyped_env b d ->
    WellTyped_env (types := ts) (a ++ b) (c ++ d).
  Proof. clear.
    intros. unfold WellTyped_env in *. unfold typeof_env in *. subst.
    rewrite map_app. reflexivity.
  Qed.
  Ltac t_list_length := repeat (rewrite typeof_env_length || rewrite rev_length || rewrite map_length || rewrite app_length).
  Hint Extern 1 (_ = _) => t_list_length; auto : list_length.

  Ltac env_resolution :=
    repeat (rewrite typeof_env_app || unfold typeof_env || rewrite map_app || rewrite map_rev || (f_equal; []) || assumption).

  Lemma consistent_app : forall ts a b c,
    consistent (ts := ts) (a ++ b) c ->
    consistent a (firstn (length a) c) /\ consistent b (skipn (length a) c).
  Proof. clear.
    induction a; simpl; intros; auto.
    destruct a. destruct o. destruct c; try contradiction. destruct s. destruct (equiv_dec x x0); try contradiction.
    destruct H. eapply IHa in H0. intuition.
    destruct c; try contradiction. destruct s. destruct H. apply IHa in H0. intuition.
  Qed.
  Lemma consistent_Some : forall ts a c,
    consistent (ts := ts) (map (fun x => existT _ (projT1 x) (Some (projT2 x))) a) c ->
    a = c.
  Proof.
    induction a; destruct c; simpl; intros; try contradiction; auto.
    destruct s. destruct a; simpl in *. destruct (equiv_dec x0 x); try contradiction.
    unfold equiv in e. intuition; subst. f_equal; eauto.
  Qed.
  Lemma skipn_length : forall T a (b : list T),
    length (skipn a b) = length b - a.
  Proof. induction a; destruct b; simpl; intros; auto. Qed.

  Lemma himp_remove_pure_p : forall cs U G p P Q,
    (Provable funcs U G p ->
      SH.SE.himp funcs preds U G cs P Q) ->
    SH.SE.himp funcs preds U G cs (SEP.Star (@SEP.Inj _ _ _ p) P) Q.
  Proof. clear.
    intros. unfold SH.SE.himp. simpl. unfold Provable in *.
    destruct (exprD funcs U G p tvProp); eapply himp_star_pure_c; intuition.
  Qed.
  Lemma himp_remove_pures_p : forall cs U G ps P Q,
    (AllProvable funcs U G ps ->
      SH.SE.himp funcs preds U G cs P Q) ->
    SH.SE.himp funcs preds U G cs (SH.starred (@SEP.Inj _ _ _) ps P) Q.
  Proof. clear.
    induction ps; intros.
    { rewrite SH.starred_nil. apply H. exact I. }
    { rewrite SH.starred_cons. apply himp_remove_pure_p. intros.
      eapply IHps. intro. apply H; simpl; auto. }
  Qed.
  Lemma himp_remove_pure_c : forall cs U G p P Q,
    Provable funcs U G p ->
    SH.SE.himp funcs preds U G cs P Q ->
    SH.SE.himp funcs preds U G cs P (SEP.Star (@SEP.Inj _ _ _ p) Q).
  Proof. clear.
    intros. unfold SH.SE.himp. simpl. unfold Provable in *.
    destruct (exprD funcs U G p tvProp); eapply himp_star_pure_cc; intuition.
  Qed.
  Lemma himp_remove_pures_c : forall cs U G ps P Q,
    AllProvable funcs U G ps ->
    SH.SE.himp funcs preds U G cs P Q ->
    SH.SE.himp funcs preds U G cs P (SH.starred (@SEP.Inj _ _ _) ps Q).
  Proof. clear.
    induction ps; intros.
    { rewrite SH.starred_nil. apply H0. }
    { rewrite SH.starred_cons. simpl in *. apply himp_remove_pure_c; intuition. }
  Qed.

  Lemma ApplyCancelSep_with_eq' :
    forall (algos_correct : ILAlgoTypes.AllAlgos_correct funcs preds algos),
    forall (meta_env : env types) (hyps : Expr.exprs types),
    Expr.AllProvable funcs meta_env nil hyps ->
    forall (l r : SEP.sexpr types BedrockCoreEnv.pc BedrockCoreEnv.st) res cs,
    forall (WTR : SEP.WellTyped_sexpr (typeof_funcs funcs) (SEP.typeof_preds preds) (typeof_env meta_env) nil r = true),
    canceller (typeof_env meta_env) hyps l r = Some res ->
    match res with
      | {| AllExt := new_vars
         ; ExExt  := new_uvars
         ; Lhs    := lhs'
         ; Rhs    := rhs'
         ; Subst  := subst
         |} =>
        Expr.forallEach new_vars (fun nvs : Expr.env types =>
          let var_env := nvs in
          Expr.AllProvable_impl funcs meta_env var_env
          (existsSubst funcs var_env subst 0
            (map (fun x => existT (fun t => option (tvarD types t)) (projT1 x) (Some (projT2 x))) meta_env ++
             map (fun x => existT (fun t => option (tvarD types t)) x None) new_uvars)
            (fun meta_env : Expr.env types =>
                (Expr.AllProvable_and funcs meta_env var_env
                  (himp cs
                    (SEP.sexprD funcs preds meta_env var_env
                      (SH.sheapD (SH.Build_SHeap _ _ (SH.impures lhs') nil (SH.other lhs'))))
                    (SEP.sexprD funcs preds meta_env var_env
                      (SH.sheapD (SH.Build_SHeap _ _ (SH.impures rhs') nil (SH.other rhs')))))
                  (SH.pures rhs')) ))
            (SH.pures lhs'))
    end ->
    himp cs (@SEP.sexprD _ _ _ funcs preds meta_env nil l)
            (@SEP.sexprD _ _ _ funcs preds meta_env nil r).
  Proof.
    Opaque UNF.backward UNF.forward Env.repr.
    intros. unfold canceller in *.
    assert (PC : ProverT_correct
              match ILAlgoTypes.Prover algos with
              | Some p => p
              | None => ReflexivityProver.reflexivityProver
              end funcs).
    { generalize (ILAlgoTypes.Acorrect_Prover algos_correct).
      destruct (ILAlgoTypes.Prover algos); intros; auto.
      apply ReflexivityProver.reflexivityProver_correct. }
    generalize dependent (match ILAlgoTypes.Prover algos with
                            | Some p => p
                            | None => ReflexivityProver.reflexivityProver
                          end).
    match goal with
      | [ |- context [ ?X ] ] =>
        match X with
          | match ILAlgoTypes.Hints _ with _ => _ end =>
            assert (HC : UNF.hintsSoundness funcs preds X); [ | generalize dependent X ]
        end
    end.
    { generalize (ILAlgoTypes.Acorrect_Hints algos_correct).
      destruct (ILAlgoTypes.Hints algos); auto using UNF.hintsSoundness_default. }
    intros h HC p ? PC.
    consider (SH.hash l); intros.
    rewrite SH.hash_denote. rewrite H0; clear H0; simpl.
    consider (SH.hash r); intros.
    rewrite SH.hash_denote with (s := r). rewrite H0; simpl.
    rewrite UNF.himp_existsEach_ST_EXT_existsEach.
    rewrite UNF.ST_EXT.himp_existsEach_p; [ reflexivity | intros ].
    rewrite app_nil_r.
    apply CANCEL.HEAP_FACTS.himp_pull_pures; intro.
    match goal with
      | [ H : context [ Summarize ?P ?ps ] |- _ ] =>
        assert (Valid PC meta_env (rev G) (Summarize P ps)); [ | generalize dependent (Summarize P ps); intros ]
    end.
    { eapply Summarize_correct.
      apply AllProvable_app; auto.
      revert H; clear - H3. induction hyps; simpl; intros; auto.
      intuition. clear - H0 H3. unfold Provable in *.
      generalize (liftExpr_ext funcs meta_env nil nil nil (rev G) nil a tvProp); simpl.
      rewrite app_nil_r. rewrite rev_length. subst. rewrite map_length.
      intro. rewrite H in *. auto. }
    match goal with
      | [ H : match ?X with _ => _ end = _ |- _ ] => consider X
    end; intros.
    apply CANCEL.SEP_FACTS.himp_WellTyped_sexpr; intro.

    (** Forward **)
    destruct (UNF.forwardLength _ _ _ _ _ H2).
    assert (SH.WellTyped_sheap (typeof_funcs funcs) (UNF.SE.typeof_preds preds) (typeof_env meta_env) (rev v) s = true).
    { rewrite SH.WellTyped_sheap_WellTyped_sexpr. rewrite <- H3. rewrite <- map_rev. apply H7. }

    generalize (@UNF.forward_WellTyped _ _ _ _ _ _ _ HC _ _ _ _ _ H2 H9); intro.
    simpl in *.
    assert (WellTyped_env (rev v) (rev G)).
    { unfold WellTyped_env. subst. rewrite <- map_rev. auto. }
    eapply UNF.forwardOk  with (cs := cs) in H2; simpl; eauto using typeof_env_WellTyped_env.
    simpl in H2. etransitivity; [ eapply H2 | clear H11; simpl in * ].
    rewrite UNF.ST_EXT.himp_existsEach_p; [ reflexivity | intros ].
    destruct H8.
    (** NOTE: I can't shift s0 around until I can witness the existential **)

    (** Open up everything **)
    destruct u.
    consider (UNF.backward h p 10 f
           {| UNF.Vars := Vars
            ; UNF.UVars := UVars ++ rev v0
            ; UNF.Heap := UNF.HEAP_FACTS.sheapSubstU 0 (length v0) (length UVars) s0 |}); intros.
    destruct (UNF.backwardLength _ _ _ _ _ H6); simpl in *.
    destruct u.

    assert (AllExt res = Vars0 /\ ExExt res = skipn (length (typeof_env meta_env)) UVars0
            /\ SH.pures (Lhs res) = SH.pures Heap).
    { clear - H13.
      match goal with
        | [ H : match ?X with _ => _ end = _ |- _ ] => destruct X
      end; intros. destruct p0; destruct p0. inversion H13; auto.
      match goal with
        | [ H : match ?X with _ => _ end = _ |- _ ] => destruct X
      end; try congruence. inversion H13; auto. }
    intuition; subst.

    rewrite ListFacts.rw_skipn_app in H11 by (auto with list_length).

    destruct res. simpl in *. subst AllExt0; subst ExExt0.
    eapply forallEach_sem with (env := rev G ++ G0) in H1; [ | solve [ env_resolution ] ].

    eapply (@CANCEL.HEAP_FACTS.himp_pull_pures types _ _ funcs preds cs meta_env (rev G ++ G0) Heap). intro.
    eapply AllProvable_impl_AllProvable in H1; [ clear H3 | rewrite H19; assumption ].

    apply existsSubst_sem in H1. apply existsEach_sem in H1.
    destruct H1. intuition.
    assert (meta_env = firstn (length meta_env) x1 /\
            typeof_env (skipn (length (rev v0)) (skipn (length meta_env) x1)) = x0 /\
            typeof_env (firstn (length (rev v0)) (skipn (length meta_env) x1)) = rev v0).
    { subst. clear - H3 H1.
      generalize (typeof_env_length x1). rewrite H3; intros.
      rewrite <- firstn_skipn with (n := length meta_env) (l := x1) in H3.
      repeat (rewrite map_app in *  || rewrite map_map in * || rewrite map_id in * || rewrite app_ass in *
        || rewrite ListFacts.rw_skipn_app in * by eauto || rewrite typeof_env_app in * ).
      simpl in *. rewrite typeof_env_app in *. eapply app_inj_length in H3.
      Focus 2. revert H. t_list_length. rewrite firstn_length. intro. rewrite min_l; omega.
      destruct H3.
      rewrite <- firstn_skipn with (n := length (rev v0)) (l := skipn (length meta_env) x1) in H2.
      rewrite typeof_env_app in *.
      eapply app_inj_length in H2. destruct H2. intuition.
      { eapply consistent_app in H1. destruct H1; clear - H1.
        revert H1. t_list_length. intros.
        eapply consistent_Some in H1. auto. }
      revert H. t_list_length. intro. rewrite firstn_length; rewrite min_l; auto.
      rewrite skipn_length. omega. }
    intuition. clear H3 H1.

    eapply AllProvable_and_sem in H14. destruct H14.
    rewrite app_ass in *.

    subst UVars0.
    assert (SH.WellTyped_sheap (typeof_funcs funcs) (UNF.SE.typeof_preds preds)
     (typeof_env meta_env ++ rev v0)
     (rev (map (projT1 (P:=tvarD types)) G) ++ x)
     (UNF.HEAP_FACTS.sheapSubstU 0 (length v0) (length (typeof_env meta_env))
        s0) = true).
    { rewrite <- SH.WellTyped_sheap_WellTyped_sexpr in H7.
      generalize (@UNF.HEAP_FACTS.sheapSubstU_WellTyped types BedrockCoreEnv.pc BedrockCoreEnv.st (typeof_funcs funcs) (UNF.SE.typeof_preds preds) (typeof_env meta_env) nil (rev v0) nil s0); simpl.
      rewrite app_nil_r. intro XX.
      rewrite SH.WellTyped_hash in WTR. rewrite H0 in WTR. simpl in WTR. rewrite app_nil_r in WTR.
      apply XX in WTR. clear XX.
      eapply SH.WellTyped_sheap_weaken with (tU' := nil) (tG := nil) (tG' := (rev (map (projT1 (P:=tvarD types)) G) ++ x)) in WTR.
      simpl in WTR. rewrite app_nil_r in WTR.
      rewrite Plus.plus_0_r in *. rewrite rev_length in WTR. apply WTR. }

    generalize (@UNF.backward_WellTyped _ _ _ _ _ _ _ HC _ _ _ _ _ H6 H14); simpl.
    eapply UNF.backwardOk with (cs := cs) in H6; simpl in *.
    2: eassumption.
    2: solve [ rewrite <- H18; eapply WellTyped_env_app; eauto using typeof_env_WellTyped_env ].
    Focus 2.
    rewrite <- map_rev.
    eapply WellTyped_env_app. eapply typeof_env_WellTyped_env.
    instantiate (1 := G0). symmetry. apply H11.
    2: eassumption.
    2: solve [ eapply Valid_weaken; eassumption ].
    intro.

    (** **)
    rewrite UNF.himp_existsEach_ST_EXT_existsEach.
    eapply UNF.ST_EXT.himp_existsEach_c. exists (rev (firstn (length (rev v0)) (skipn (length meta_env) x1))); split.
    { rewrite map_rev. unfold typeof_env in H18. rewrite H18. apply rev_involutive. }
    rewrite rev_involutive.

    (** In order to call the canceller, they must have the same environments. **)
    assert (SH.SE.ST.heq cs
              (SH.SE.sexprD funcs preds meta_env (rev G ++ G0) (SH.sheapD Heap))
              (SH.SE.sexprD funcs preds x1 (rev G ++ G0) (SH.sheapD Heap))).
    { rewrite <- firstn_skipn with (l := x1) (n := length meta_env).
      rewrite <- H15.
      generalize (@CANCEL.SEP_FACTS.sexprD_weaken_wt types _ _ funcs preds cs meta_env (skipn (length meta_env) x1) nil
        (SH.sheapD Heap) (rev G ++ G0)).
      rewrite app_nil_r. intro XX; apply XX; clear XX.
      rewrite <- SH.WellTyped_sheap_WellTyped_sexpr. rewrite <- H10. f_equal.
      rewrite typeof_env_app. f_equal. rewrite <- map_rev. reflexivity.
      rewrite <- H11. reflexivity. }
    etransitivity; [ eapply H17 | clear H17 ].

    assert (SH.SE.ST.heq cs
              (SH.SE.sexprD funcs preds (meta_env ++ firstn (length (rev v0)) (skipn (length meta_env) x1)) (rev G ++ G0) (SH.sheapD (UNF.HEAP_FACTS.sheapSubstU 0 (length v0)
                       (length (typeof_env meta_env)) s0)))
              (UNF.SE.sexprD funcs preds meta_env
                (firstn (length (rev v0)) (skipn (length meta_env) x1) ++ nil)
                (SH.sheapD s0))).
    { generalize (@UNF.HEAP_FACTS.sheapSubstU_sheapD types _ _ funcs preds cs
        meta_env nil (firstn (length (rev v0)) (skipn (length meta_env) x1)) nil s0).
      simpl. repeat rewrite app_nil_r. intros XX; rewrite XX; clear XX.
      generalize (@CANCEL.SEP_FACTS.sexprD_weaken_wt types _ _ funcs preds cs
        (meta_env ++ firstn (length (rev v0)) (skipn (length meta_env) x1))
        nil (rev G ++ G0)
          (SH.sheapD (UNF.HEAP_FACTS.sheapSubstU 0
              (length (firstn (length (rev v0)) (skipn (length meta_env) x1)) +
               0) (length meta_env) s0)) nil).
      simpl. t_list_length.
      intro XX; rewrite XX; clear XX.
      rewrite H15. rewrite app_ass.
      cutrewrite (length (firstn (length meta_env) x1) = length meta_env).
      rewrite app_nil_r.
      cutrewrite (length (firstn (length v0) (skipn (length meta_env) x1)) + 0 = length v0).
      reflexivity.
      rewrite Plus.plus_0_r. rewrite <- rev_length with (l := v0).
      rewrite <- H18 at 2. t_list_length. reflexivity.
      rewrite <- H15. reflexivity.
      rewrite <- SH.WellTyped_sheap_WellTyped_sexpr.
      rewrite SH.WellTyped_hash in WTR.
      rewrite SH.WellTyped_sheap_WellTyped_sexpr in WTR. rewrite H0 in *. simpl in WTR.
      clear - WTR H15 H12 H18 H11.
      rewrite <- SH.WellTyped_sheap_WellTyped_sexpr in WTR.
      generalize (@UNF.HEAP_FACTS.sheapSubstU_WellTyped_eq types BedrockCoreEnv.pc BedrockCoreEnv.st (typeof_funcs funcs) (SEP.typeof_preds preds)
        (typeof_env meta_env) nil (rev v0) nil s0). simpl. t_list_length. rewrite app_nil_r in *.
      intro XX; rewrite XX in WTR; clear XX.
      rewrite <- WTR. rewrite <- H18. t_list_length. rewrite typeof_env_app. repeat rewrite Plus.plus_0_r.
      f_equal. f_equal. rewrite <- rev_length with (l := v0). rewrite <- H18 at 2.
      t_list_length. reflexivity. }
    rewrite <- H17; clear H17.
    revert H6. t_list_length.
    intro H6. etransitivity; [ clear H6 | eapply H6 ].

    (** witness the conclusion **)
    eapply UNF.ST_EXT.himp_existsEach_c.
    exists (skipn (length (rev v0)) (skipn (length meta_env) x1)). split.
    { t_list_length. rewrite firstn_length; rewrite skipn_length. rewrite <- app_ass. rewrite ListFacts.rw_skipn_app.
      rewrite <- H12. t_list_length. reflexivity.
      env_resolution. t_list_length. f_equal. rewrite min_l; auto.
      clear - H18 H15 H12.
      assert (x1 = firstn (length meta_env) x1 ++ (firstn (length (rev v0)) (skipn (length meta_env) x1)) ++
        (skipn (length (rev v0)) (skipn (length meta_env) x1))).
      repeat rewrite firstn_skipn. reflexivity.
      generalize dependent (firstn (length meta_env) x1).
      generalize dependent (skipn (length (rev v0)) (skipn (length meta_env) x1)).
      generalize dependent (firstn (length (rev v0)) (skipn (length meta_env) x1)).
      intros. subst. rewrite <- rev_length. rewrite <- H18. t_list_length. omega. }
    rewrite app_ass. rewrite H15 at 1.
    t_list_length. repeat rewrite firstn_skipn.
    clear H2.

    assert (U.Subst_WellTyped (typeof_funcs funcs) (typeof_env x1)
      (typeof_env (rev G ++ G0)) (U.Subst_empty types)).
    { eapply U.Subst_empty_WellTyped. }
    assert (SH.WellTyped_sheap (typeof_funcs funcs) (CANCEL.SE.typeof_preds preds)
      (typeof_env x1) (typeof_env (rev G ++ G0)) Heap0 = true).
    { rewrite <- H16. f_equal.
      rewrite H15. rewrite <- H18. rewrite <- H12. t_list_length.
      repeat rewrite <- typeof_env_app. repeat rewrite firstn_skipn. reflexivity.
      rewrite typeof_env_app. f_equal. rewrite typeof_env_rev. reflexivity. apply H11. }
    assert (SH.WellTyped_sheap (typeof_funcs funcs) (CANCEL.SE.typeof_preds preds)
     (typeof_env x1) (typeof_env (rev G ++ G0)) Heap = true).
    { eapply SH.WellTyped_sheap_weaken with (tG' := nil) (tU' := typeof_env (skipn (length meta_env) x1)) in H10.
      rewrite H15 in H10 at 1. rewrite <- typeof_env_app in H10. rewrite firstn_skipn in H10.
      rewrite app_nil_r in H10. rewrite <- H10. f_equal.
      rewrite typeof_env_app. rewrite typeof_env_rev. f_equal. apply H11. }
    consider (CANCEL.sepCancel preds p (length (typeof_env meta_env ++ rev v0 ++ x0)) f Heap Heap0 (U.Subst_empty _) false);
    intros; try congruence.
    { destruct p0. destruct p0. inversion H20; clear H20. subst s3. subst s1.
      subst Lhs0. clear H19. simpl in *.
      eapply CANCEL.sepCancel_correct with (cs := cs) (funcs := funcs) (U := x1) (G := rev G ++ G0) in H13; try eassumption.
      { instantiate (1 := PC). eapply Valid_weaken with (ue := skipn (length meta_env) x1) (ge := G0) in H5.
        rewrite <- firstn_skipn with (n := length meta_env) (l := x1). rewrite <- H15. assumption. }
      { (* eapply CANCEL.sepCancel_PuresPrem in H13; try eassumption. *)
        match type of H3 with
          | himp ?CS (SEP.sexprD ?F ?P ?U ?G ?L) (SEP.sexprD ?F ?P ?U ?G ?R) =>
            change (SEP.himp F P U G CS L R) in H3
        end.
        do 2 rewrite SH.sheapD_def. do 2 rewrite SH.sheapD_def in H3. simpl in *.
        do 2 rewrite CANCEL.SEP_FACTS.heq_star_emp_l in H3.
        rewrite CANCEL.SEP_FACTS.heq_star_comm
          with (P := SH.starred (SEP.Inj (stateType:=BedrockCoreEnv.st)) (SH.pures s2) SEP.Emp).
        rewrite CANCEL.SEP_FACTS.heq_star_comm
          with (P := SH.starred (SEP.Inj (stateType:=BedrockCoreEnv.st)) (SH.pures Rhs0) SEP.Emp).
        do 2 rewrite <- CANCEL.SEP_FACTS.heq_star_assoc.
        apply CANCEL.SEP_FACTS.himp_star_frame. assumption.
        eapply himp_remove_pures_p; intros.
        eapply himp_remove_pures_c; auto. reflexivity. }
      { eapply CANCEL.sepCancel_PureFacts in H13. 4: eapply H6.
        eapply U.Subst_equations_to_Subst_equations; intuition.
        intuition. intuition. } }
    { match goal with
      | [ H : (if ?X then _ else _) = _ |- _ ] =>
        destruct X; try congruence
      end.
      inversion H20; clear H20.
      destruct Lhs0; destruct Rhs0; simpl in *.
      etransitivity. etransitivity; [ | eapply H3 ].
      { repeat rewrite SH.sheapD_def; simpl; repeat apply ST.himp_star_frame; try reflexivity.
        change (SEP.himp funcs preds x1 (rev G ++ G0) cs (SH.starred (SEP.Inj (stateType:=BedrockCoreEnv.st)) pures SEP.Emp) SEP.Emp).
        clear. induction pures. reflexivity.
        rewrite CANCEL.HEAP_FACTS.starred_cons.
         rewrite IHpures.
         eapply himp_remove_pure_p. intro; reflexivity. }
      { repeat rewrite SH.sheapD_def; simpl; repeat apply ST.himp_star_frame; try reflexivity.
        change (SEP.himp funcs preds x1 (rev G ++ G0) cs SEP.Emp (SH.starred (SEP.Inj (stateType:=BedrockCoreEnv.st)) pures0 SEP.Emp)).
        clear - H1. induction pures0. reflexivity.
        rewrite CANCEL.HEAP_FACTS.starred_cons.
        simpl in H1; intuition.
        rewrite <- H1 by assumption.
        eapply himp_remove_pure_c; auto. reflexivity. } }
  Qed.

  Lemma ApplyCancelSep_with_eq :
    forall (algos_correct : ILAlgoTypes.AllAlgos_correct funcs preds algos),
    forall (meta_env : env (Env.repr BedrockCoreEnv.core types)) (hyps : Expr.exprs (_)),

    forall (l r : SEP.sexpr types BedrockCoreEnv.pc BedrockCoreEnv.st) res,
    canceller (typeof_env meta_env) hyps l r = Some res ->
    Expr.AllProvable funcs meta_env nil hyps ->
    forall (WTR : SEP.WellTyped_sexpr (typeof_funcs funcs) (SEP.typeof_preds preds) (typeof_env meta_env) nil r = true) cs,

    match res with
      | {| AllExt := new_vars
         ; ExExt  := new_uvars
         ; Lhs    := lhs'
         ; Rhs    := rhs'
         ; Subst  := subst
         |} =>
        Expr.forallEach new_vars (fun nvs : Expr.env types =>
          let var_env := nvs in
          Expr.AllProvable_impl funcs meta_env var_env
          (existsSubst funcs var_env subst 0
            (map (fun x => existT (fun t => option (tvarD types t)) (projT1 x) (Some (projT2 x))) meta_env ++
             map (fun x => existT (fun t => option (tvarD types t)) x None) new_uvars)
            (fun meta_env : Expr.env types =>
                (Expr.AllProvable_and funcs meta_env var_env
                  (himp cs
                    (SEP.sexprD funcs preds meta_env var_env
                      (SH.sheapD (SH.Build_SHeap _ _ (SH.impures lhs') nil (SH.other lhs'))))
                    (SEP.sexprD funcs preds meta_env var_env
                      (SH.sheapD (SH.Build_SHeap _ _ (SH.impures rhs') nil (SH.other rhs')))))
                  (SH.pures rhs')) ))
            (SH.pures lhs'))
    end ->
    himp cs (@SEP.sexprD _ _ _ funcs preds meta_env nil l)
            (@SEP.sexprD _ _ _ funcs preds meta_env nil r).
  Proof. intros. eapply ApplyCancelSep_with_eq'; eauto. Qed.

  Lemma ApplyCancelSep :
    forall (algos_correct : ILAlgoTypes.AllAlgos_correct funcs preds algos),
    forall (meta_env : env (Env.repr BedrockCoreEnv.core types)) (hyps : Expr.exprs (_)),
    forall (l r : SEP.sexpr types BedrockCoreEnv.pc BedrockCoreEnv.st),
      Expr.AllProvable funcs meta_env nil hyps ->
    forall (WTR : SEP.WellTyped_sexpr (typeof_funcs funcs) (SEP.typeof_preds preds) (typeof_env meta_env) nil r = true) cs,
    match canceller (typeof_env meta_env) hyps l r with
      | Some {| AllExt := new_vars
         ; ExExt  := new_uvars
         ; Lhs    := lhs'
         ; Rhs    := rhs'
         ; Subst  := subst
         |} =>
        Expr.forallEach new_vars (fun nvs : Expr.env types =>
          let var_env := nvs in
          Expr.AllProvable_impl funcs meta_env var_env
          (existsSubst funcs var_env subst 0
            (map (fun x => existT (fun t => option (tvarD types t)) (projT1 x) (Some (projT2 x))) meta_env ++
             map (fun x => existT (fun t => option (tvarD types t)) x None) new_uvars)
            (fun meta_env : Expr.env types =>
                (Expr.AllProvable_and funcs meta_env var_env
                  (himp cs
                    (SEP.sexprD funcs preds meta_env var_env
                      (SH.sheapD (SH.Build_SHeap _ _ (SH.impures lhs') nil (SH.other lhs'))))
                    (SEP.sexprD funcs preds meta_env var_env
                      (SH.sheapD (SH.Build_SHeap _ _ (SH.impures rhs') nil (SH.other rhs')))))
                  (SH.pures rhs')) ))
            (SH.pures lhs'))
      | None =>
        himp cs (@SEP.sexprD _ _ _ funcs preds meta_env nil l)
                (@SEP.sexprD _ _ _ funcs preds meta_env nil r)
    end ->
    himp cs (@SEP.sexprD _ _ _ funcs preds meta_env nil l)
            (@SEP.sexprD _ _ _ funcs preds meta_env nil r).
  Proof.
    intros. consider (canceller (typeof_env meta_env) hyps l r); intros; auto.
    eapply ApplyCancelSep_with_eq; eauto.
  Qed.

End canceller.


From Undecidability Require Import Hoare.HoareLogic.
From Undecidability.TM Require Import TMTac.
From Undecidability.TM Require Export CodeTM LiftTapes ChangeAlphabet.

(* ** Tape/Register Specification *)

(* Register specifications are deep embeded because this makes it
easier to do computation with the specifications. A tapes
specification is a list of assertions about tapes. Each tape may
contain a value (optionally with size), or be right. *)

Section RegSpec.

  Variable sig : Type.

  (* Notation without EqType stuff *)
  Local Notation "sig '^+'" := ((boundary + sig) % type) (at level 0) : type_scope.

  Inductive RegSpec : Type :=
  | Contains {sigX X : Type} {cX : codable sigX X} (r : Retract sigX sig) : X -> RegSpec
  | Contains_size {sigX X : Type} {cX : codable sigX X} (r : Retract sigX sig) : X -> nat -> RegSpec
  | Void : RegSpec
  | Void_size : nat -> RegSpec
  | Custom : (tape sig^+ -> Prop) -> RegSpec. (* Allows the user to specify the tape manually *)

  (* Semantics *)
  Definition tspec_single (spec : RegSpec) (t : tape sig^+) : Prop :=
    match spec with
    | Contains r x => t ≃(r) x
    | Contains_size r x s => t ≃(r; s) x
    | Void => isVoid t
    | Void_size s => isVoid_size t s
    | Custom p => p t
    end.

  Lemma tspec_single_Contains_size_Contains {sigX X : Type} {cX : codable sigX X} (r : Retract sigX sig) (x : X) (s : nat) (t : tape sig^+) :
    tspec_single (Contains_size r x s) t -> tspec_single (Contains r x) t.
  Proof. cbn. auto. Qed.

  Definition SpecV n := Vector.t (RegSpec) n.
  Definition Spec n :Type := list Prop * SpecV n.

  Definition tspec {n : nat} (spec : Spec n) : Assert sig^+ n :=
    match spec with
    | (P,spec) => fun (t : tapes sig^+ n) =>
       List.fold_right and (forall (i : Fin.t n), tspec_single spec[@i] t[@i]) P
    end.

  Arguments tspec : simpl never.

  (* These rules are needed for abstract lemmas, where Ps is a variable *)
  Lemma tspecE {n : nat} Ps Pv t:
  tspec (n:=n) (Ps,Pv) t -> (List.fold_right and True Ps /\ forall (i : Fin.t n), tspec_single Pv[@i] t[@i]).
  Proof.
    cbn. induction Ps;cbn in *. easy. intros []. specialize (IHPs H0) as [H' ?]. split. all:eauto.
  Qed.

  Lemma tspecI {n : nat} P t:
  (List.fold_right and True (fst P))
  -> (forall (i : Fin.t n), tspec_single (snd P)[@i] t[@i])
  -> tspec (n:=n) P t.
  Proof.
    destruct P as (Ps&P). induction Ps;cbn in *. easy. intros H' ?. split. now eapply H';left.
    eapply IHPs. all:easy.
  Qed.

Lemma tspec_iff {n : nat} Ps Pv t:
  tspec (n:=n) (Ps,Pv) t <-> (List.fold_right and True Ps /\ forall (i : Fin.t n), tspec_single Pv[@i] t[@i]).
Proof. split. eapply tspecE;eauto. intros []. eapply tspecI;eauto. Qed.

Lemma tspec_Entails {n : nat} Ps Pv:
Entails (tspec (n:=n) (Ps,Pv)) (fun t => List.fold_right and True Ps /\ forall (i : Fin.t n), tspec_single Pv[@i] t[@i]).
Proof. apply EntailsI. now setoid_rewrite tspec_iff. Qed.

(*
  Lemma tspec_pureE {n : nat} Ps Pv v:
    tspec (n:=n) (Ps,Pv) v -> (forall P, In P Ps -> P).
  Proof. intros ?%tspecE. easy. Qed. *)

  (* Enrich the specification with spaces *)
  Definition withSpace_single (P : RegSpec) (size : nat) :=
    match P with
    | Contains r x => Contains_size r x size
    | Void => Void_size size
    | _ => P
    end.

  Definition withSpace {n : nat} (P : SpecV n) (spaces : Vector.t nat n) : SpecV n :=
    Vector.map2 withSpace_single P spaces.

  (* Drop the spaces *)
  Lemma tspec_single_withSpace_tspec_single (P : RegSpec) (size : nat) t :
    tspec_single (withSpace_single P size) t -> tspec_single P t.
  Proof. intros. destruct P; cbn in *; auto. Qed.

  Lemma tspec_withSpace_tspec {n : nat} Q P (s : Vector.t nat n) t :
    tspec (Q,withSpace P s) t -> tspec (Q,P) t.
  Proof. unfold withSpace. intros [HP H]%tspecE. apply tspecI. easy. intros i; specialize (H i). simpl_vector in *. eapply tspec_single_withSpace_tspec_single; eauto. Qed.

  (* Invent some dummy spaces *)

  Definition dummy_size (t : tape sig^+) (P : RegSpec) : nat :=
    match P with
    | Contains r x => length (left t)
    | Void => length (tape_local_l t)
    | _ => 0
    end.

  Lemma tspec_single_tspec_single_withSpace (P : RegSpec) t :
    tspec_single P t -> tspec_single (withSpace_single P (dummy_size t P)) t.
  Proof. intros H. destruct P; cbn in *; eauto. Qed.

  Definition dummy_sizes (n : nat) (t : tapes sig^+ n) (P : SpecV n) : Vector.t nat n :=
     Vector.map2 dummy_size t P.

  Lemma tspec_tspec_withSpace (n : nat) Q (P : SpecV n) t :
    tspec (Q,P) t -> tspec (Q,withSpace P (dummy_sizes t P)) t.
  Proof.
    unfold withSpace, dummy_sizes in *. intros [HP ?]%tspecE. eapply tspecI. cbn in *; auto.
    intros i; specialize (H i); cbn in *. simpl_vector. now apply tspec_single_tspec_single_withSpace.
  Qed.

  (*
  (* Remove the space annotations *)
  Definition removeSpace_reg (P : RegSpec) :=
    match P with
    | Contains_size r x size => Contains r x
    | Void_size size => Void
    | _ => P
    end.

  Lemma tspec_single_removeSpace_reg (P : RegSpec) t :
    tspec_single P t ->
    tspec_single (removeSpace_reg P) t.
  Proof. intros H. destruct P; cbn in *; auto. Qed.

  Definition removeSpace (n : nat) (P : Spec n) :=
    match P with
    | SpecVector spec => SpecVector (Vector.map removeSpace_reg spec)
    | SpecFalse _ => SpecFalse _
    end.

  Lemma tspec_removeSpace (n : nat) (P : Spec n) t :
    tspec P t ->
    tspec (removeSpace P) t.
  Proof.
    intros H; destruct P; cbn; auto.
    intros i; specialize (H i); cbn in *.
    simpl_vector. eapply tspec_single_removeSpace_reg; eauto.
  Qed.
*)

End RegSpec.

Arguments Custom {sig}.
Arguments Void {sig}.
Arguments Void_size {sig}.
Arguments dummy_sizes : simpl never.
Hint Resolve tspec_single_Contains_size_Contains : core.

Declare Scope spec_scope.
Delimit Scope spec_scope with spec.
Bind Scope spec_scope with Spec.
Notation "'≃≃(' S ')'" := (tspec S%spec) (at level 0, S at level 200, no associativity, format "'≃≃(' S ')'").
Notation "'≃≃(' P ',' S ')'" := (tspec (P%list,S%vector)) (at level 0, P at level 200, S at level 200, no associativity, format "'≃≃(' P ','  S ')'").

Notation "t ≃≃ S" := (tspec S%spec t) (at level 70, no associativity).

Notation "≃( I ) x" := (Contains I x) (at level 70, I at level 200, no associativity, format "'≃(' I ')'  x").
Notation "≃( I ';' s ) x" := (Contains_size I s x) (at level 70, I at level 200, s at level 200, no associativity, format "'≃(' I ';' s ')'  x").

Arguments tspec _%spec _.

Fixpoint implList (Ps : list Prop) (Q : Prop) :=
  match Ps with
    [] => Q
  | P::Ps => P -> implList Ps Q
  end.
Arguments implList !_ _.

Instance fold_right_impl' : Proper (Forall2 Basics.impl --> Basics.impl ==> Basics.impl) (implList).
Proof. intros xs;induction xs;cbn;intros ? H';inv H';cbn. easy. firstorder. Qed.

Instance fold_right_iff : Proper (Forall2 iff ==> iff ==> iff) (implList).
Proof. intros xs;induction xs;cbn;intros ? H';inv H';cbn. easy. firstorder. Qed.

Lemma implList_iff P (Ps : list Prop):
  implList Ps P
  <-> (List.fold_right and True Ps -> P).
Proof.
  induction Ps in P|-*;cbn. firstorder. setoid_rewrite IHPs. tauto.
Qed.

Lemma implListE P (Ps : list Prop): implList Ps P -> (List.fold_right and True Ps -> P).
Proof. now rewrite implList_iff. Qed.

Lemma implListI (P:Prop) (Ps : list Prop): (List.fold_right and True Ps -> P) -> implList Ps P.
Proof. now rewrite implList_iff. Qed.

Instance Forall2_refl X (R: X -> _): Reflexive R -> Reflexive (Forall2 R).
Proof. intros ? xs;induction xs;eauto. Qed.

Lemma tspec_introPure (sig: finType) (n : nat) P (Ps : SpecV sig n) Q:
  implList P (Entails (≃≃([],Ps)) Q)
  -> Entails (tspec (P,Ps)) Q.
Proof.
  setoid_rewrite Entails_iff. rewrite implList_iff. intros H ? []%tspecE. eapply H. eassumption. now apply tspecI.
Qed.

Lemma tspec_revertPure (sig: finType) (n : nat) (P0:Prop) P (Ps : SpecV sig n) Q:
  P0
  -> Entails (tspec (P0::P,Ps)) Q
  -> Entails (tspec (P,Ps)) Q.
Proof.
  setoid_rewrite Entails_iff. unfold tspec;cbn. intuition.
Qed.

Lemma Triple_introPure (F sig: finType) (n : nat) P (Ps : SpecV sig n) Q (pM : pTM sig^+ F n) :
  implList P (Triple (≃≃([],Ps)) pM Q)
  -> Triple (tspec (P,Ps)) pM Q.
Proof.
  intros. rewrite tspec_Entails. apply Triple_and_pre. cbn in H. now rewrite <- implList_iff.
Qed.

Lemma TripleT_introPure (sig F : finType) (n : nat) P (Ps : SpecV sig n) Q k (pM : pTM sig^+ F n) :
  implList P (TripleT (≃≃([],Ps)) k pM Q)
  -> TripleT (tspec (P,Ps)) k pM Q.
Proof.
  intros. rewrite tspec_Entails. apply TripleT_and_pre. cbn in H. now rewrite <- implList_iff.
Qed.

(*
Lemma Triple_SpecFalse {sig : finType} {n : nat} {F : Type} P (pM : pTM sig^+ F n) Q :
  Triple (≃≃([False],P)) pM Q.
Proof. hnf;cbn. tauto. Qed.

Lemma TripleT_SpecFalse {sig : finType} {n : nat} {F : Type} P (k : nat) (pM : pTM sig^+ F n) Q :
  TripleT (≃≃([False],P)) k pM Q.
Proof. eapply ConsequenceT. 1,3,4:now eauto. hnf;cbn;tauto. Qed.

Lemma tspec_not_SpecFalse {sig : Type} {n : nat} (t : tapes (boundary+sig) n) P :
  t ≃≃ ([False],P) -> False.
Proof. cbn. tauto. Qed.

Lemma tspec_not_SpecFalse_withSpace {sig : Type} {n : nat} (t : tapes (boundary+sig) n) P (ss : Vector.t nat n) :
  t ≃≃  ([False], withSpace P ss) -> False.
Proof. cbn. tauto. Qed.

Hint Immediate Triple_SpecFalse TripleT_SpecFalse : core.
*)

(* TODO: [SpecFalse] could be defined in the same manner. We could then remove the unhandy [SpecVector] constructor. *)
Definition SpecVTrue {sig : Type} {n : nat} : SpecV sig n := Vector.const (Custom (fun _ => True)) n.

(*
Lemma tspec_SpecTrue {sig : finType} {n : nat} (t : tapes sig^+ n) :
  t ≃≃ SpecTrue.
Proof. cbn. intros i. unfold tspec_single, SpecTrue. cbn. now rewrite Vector.const_nth. Qed.

Lemma tspec_SpecTrue_withSpace {sig : finType} {n : nat} (t : tapes sig^+ n) (ss : Vector.t nat n) :
  t ≃≃ withSpace SpecTrue ss.
Proof. cbn. intros i. unfold tspec_single, SpecTrue. now rewrite nth_map2', Vector.const_nth. Qed.

Hint Immediate tspec_SpecTrue tspec_SpecTrue_withSpace : core.

Lemma Triple_SpecTrue {sig : finType} {n : nat} {F : Type} (pM : pTM sig^+ F n) P :
  Triple P pM (fun _ => tspec SpecTrue).
Proof. eapply Consequence_post. apply Triple_True. auto. Qed.

Hint Extern 4 =>
     lazymatch goal with
     | [H : _ ≃≃ SpecFalse |- _] => exfalso; now eapply tspec_not_SpecFalse in H
     | [H : _ ≃≃ withSpace SpecFalse _ |- _] => exfalso; now eapply tspec_not_SpecFalse_withSpace in H
     end : core.

Goal forall (t : tapes sigNat^+ 4) P,
    t ≃≃ ([False],P) -> 3 = 4.
Proof. auto. Qed.

*)

Arguments tspec : simpl never.

(* TODO: Move to [TM.Code.CodeTM] *)
Definition appSize {n : nat} : Vector.t (nat->nat) n -> Vector.t nat n -> Vector.t nat n :=
  fun fs s => tabulate (fun i => fs[@i] s[@i]).

Lemma Triple_RemoveSpace_ex (n : nat) (sig : finType) (F : Type) X
(P : SpecV sig n) P' (M : pTM sig^+ F n) Q Q' Ctx (fs : _ -> Vector.t (nat->nat) n) :
  (forall s, Triple (tspec (P',withSpace P s)) M (fun y t => exists x:X, Ctx x (tspec (Q' x y,withSpace (Q x y) (appSize (fs x) s)) t))) -> (* Specifications with size will always have this form *)
  (forall x, Proper (Basics.impl ==> Basics.impl) (Ctx x)) ->
  Triple (tspec (P',P)) M (fun y t => exists x, Ctx x (tspec (Q' x y ,Q x y) t)).
Proof.
  intros HTrip Hctx. setoid_rewrite Triple_iff in HTrip. rewrite Triple_iff.
  eapply Realise_monotone with
  (R' := fun tin '(yout, tout) => forall s, tspec (P',withSpace P s) tin
    -> exists x:X, Ctx x (tspec (Q' x yout,withSpace (Q x yout) (appSize (fs x) s)) tout)).
  - unfold Triple_Rel, Realise in *. intros tin k outc HLoop. intros s HP.
    specialize HTrip with (1 := HLoop) (2 := HP) as [x H'']. eexists. eauto.
  - clear HTrip. intros tin (yout, tout). intros H HP.
    specialize (H (dummy_sizes tin P)). spec_assert H by now apply tspec_tspec_withSpace.
    destruct H as (x&H). exists x. eapply Hctx. 2:eassumption.
    intro H'. now apply tspec_withSpace_tspec in H'.
Qed.

Lemma Triple_RemoveSpace (n : nat) (sig : finType) (F : Type) (P : SpecV sig n) P' (M : pTM sig^+ F n) (Q : F -> SpecV sig n) Q' (fs : Vector.t (nat->nat) n) :
  (forall s, Triple (tspec (P',withSpace P s)) M (fun y => tspec (Q' y,withSpace (Q y) (appSize fs s)))) -> (* Specifications with size will always have this form *)
  Triple (tspec (P',P)) M (fun y => tspec (Q' y ,Q y)).
Proof.
  intro HTrip. setoid_rewrite Triple_iff in HTrip. rewrite Triple_iff.
  eapply Realise_monotone with (R' := fun tin '(yout, tout) => forall s, tspec (P',withSpace P s) tin -> tspec (Q' yout,withSpace (Q yout) (appSize fs s)) tout).
  - unfold Triple_Rel, Realise in *. intros tin k outc HLoop. intros s HP.
    now specialize HTrip with (1 := HLoop) (2 := HP).
  - clear HTrip. intros tin (yout, tout). intros H HP.
    specialize (H (dummy_sizes tin P)). spec_assert H by now apply tspec_tspec_withSpace.
    now apply tspec_withSpace_tspec in H.
Qed.

Lemma TripleT_RemoveSpace (n : nat) (sig : finType) (F : Type) P' (P : SpecV sig n) (k : nat) (M : pTM sig^+ F n) Q' (Q : F -> SpecV sig n) (fs : Vector.t (nat->nat) n) :
  (forall s, TripleT (tspec (P',withSpace P s)) k M (fun y => tspec (Q' y,withSpace (Q y) (appSize fs s)))) ->
  TripleT (tspec (P',P)) k M (fun y => tspec (Q' y,Q y)).
Proof.
  intros HTrip. split.
  - eapply Triple_RemoveSpace. intros s. apply HTrip.
  - setoid_rewrite TripleT_iff in HTrip.
   eapply TerminatesIn_monotone with (T' := fun tin k' => tspec (P',P) tin /\ k <= k').
    + unfold Triple_TRel, TerminatesIn in *. intros tin k' (HP&Hk).
      specialize (HTrip (dummy_sizes tin P)) as (_&HT).
      specialize HT with (tin0 := tin) (k0 := k). spec_assert HT as (conf&HLoop).
      { split. now apply tspec_tspec_withSpace. reflexivity. }
      exists conf. eapply loop_monotone; eauto.
    + unfold Triple_TRel. intros tin k' (HP&Hk). eauto.
Qed.

Instance fold_right_and : Proper (iff ==> Forall2 iff ==> iff) (fold_right and).
Proof. intros ? ? ? xs;induction xs;cbn;intros ? H';inv H';cbn. easy. firstorder. Qed.

Instance fold_right_and' : Proper (Basics.impl ==> Forall2 iff ==> Basics.impl) (fold_right and).
Proof. intros ? ? ? xs;induction xs;cbn;intros ? H';inv H';cbn. easy. firstorder. Qed.

(* For good reasons, [tspec] will be declared to don't simplify with [cbn]. However, [tspec_single] simplifies with [cbn]. *)
Lemma tspec_solve (sig : Type) (n : nat) (t : tapes (boundary+sig) n) (R : SpecV sig n) P:
List.fold_right and (forall i, tspec_single R[@i] t[@i]) P ->
  tspec (P,R) t.
Proof. refine (fun P => P). Qed.

(* [withSpace] does also not simplify; but [withSpace_single] does. *)
Lemma tspec_space_solve (sig : Type) (n : nat) (t : tapes (boundary+sig) n) (R : SpecV sig n) P (ss : Vector.t nat n) :
  List.fold_right and (forall i, tspec_single (withSpace_single R[@i] ss[@i]) t[@i]) P ->
  tspec (P,withSpace R ss) t.
Proof. unfold withSpace. intros. apply tspec_solve. simpl_vector. auto. Qed.

Lemma tspec_ext (sig : finType) (n : nat) (t : tapes (boundary+sig) n) (P P' : list Prop) (R R' : Vector.t (RegSpec sig) n) :
  tspec (P',R') t ->
  implList P' (List.fold_right and True P) ->
  (forall i, tspec_single R'[@i] t[@i] -> tspec_single R[@i] t[@i]) ->
  tspec (P,R) t.
Proof.
  intros [HP H1]%tspecE H1' H2. eapply tspecI.
  eapply implList_iff. 2:eassumption. eapply fold_right_impl'. 2:reflexivity. 2:eassumption. easy.
  intros i; specialize (H1 i); specialize (H2 i); eauto.
Qed.

Lemma tspec_space_ext (sig : finType) (n : nat) (t : tapes (boundary+sig) n) (P P':list Prop) (R R' : SpecV sig n)
      (ss ss' : Vector.t nat n) :
  tspec (P',withSpace R' ss') t ->
  implList P' (List.fold_right and True P) ->
  (forall i, tspec_single (withSpace_single R'[@i] ss'[@i]) t[@i] -> tspec_single (withSpace_single R[@i] ss[@i]) t[@i]) ->
  tspec (P,withSpace R ss) t.
Proof.
  unfold withSpace. intros [HP H1]%tspecE H1' H2. eapply tspecI.
  eapply implList_iff. 2:eassumption. eapply fold_right_impl'. 2:reflexivity. 2:eassumption. easy.
  intros i; specialize (H1 i); specialize (H2 i); eauto.
  cbn. simpl_vector in *; cbn. eauto.
Qed.

(* ** Tape Lifting *)

Section Lifting.

  Variable (sig : Type).

  Variable (m n : nat).

  (* [P] is the premise of the lifted machine [M@I]. *)
  Variable (P : @SpecV sig n).

  Variable (I : Vector.t (Fin.t n) m). (* [m<=n] *)
  Hypothesis (HI : dupfree I).

  (* We want to extract from [P] the premise [P'] for [M] *)
  Definition Downlift : @SpecV sig m :=
    (select I P).

  Lemma tape_fulfill_Downlift_select P' tp :
    tspec (P',P) tp ->
    tspec (P',Downlift) (select I tp).
  Proof.
    unfold Downlift.
    intros [? H]%tspecE.
    eapply tspecI. easy.
    intros i;cbn. rewrite !select_nth. easy.
  Qed.

  (* Same specification as in [P] on indices not in [I], but as in [Q] for indices in [I] (lifted).  *)
  Definition Frame (Q : @SpecV sig m) : @SpecV sig n := fill I P Q.

End Lifting.

Lemma LiftTapes_Spec_ex (sig : finType) X (F : finType) (m n : nat) (I : Vector.t (Fin.t n) m)
P' P Q' Q (pM : pTM sig^+ F m) :
  dupfree I ->
  Triple (tspec (P',Downlift P I)) pM (fun y t => exists x:X, tspec (Q' x y,Q x y) t) ->
  Triple (tspec (P',P)) (LiftTapes pM I) (fun y t=> exists x, tspec (Q' x y,Frame P I (Q x y)) t ).
Proof.
  unfold Frame. rewrite !Triple_iff.
  intros HDup HTrip.
  eapply Realise_monotone.
  { apply LiftTapes_Realise. assumption. apply HTrip. }
  {
    intros tin (yout, tout) (H&HInj). cbn -[Downlift tspec] in *.
    intros HP.
    spec_assert H by now apply tape_fulfill_Downlift_select.
    destruct H as [x H].
    eapply tspecE in H as [H' H]. eapply tspecE in HP as [HP' HP].
    exists x.
    eapply tspecI;cbn.
    { clear - H' HP'. induction P';cbn in *. all:firstorder. }
    clear H' HP'.
    hnf. intros j. decide (Vector.In j I) as [HD|HD].
    - unfold Frame.
      apply vect_nth_In' in HD as (ij&HD).
      erewrite fill_correct_nth; eauto.
      specialize (H ij).
      now rewrite select_nth, HD in H.
    - unfold Frame. rewrite fill_not_index; eauto.
      specialize (HInj j HD). rewrite HInj. now apply HP.
  }
Qed.

Lemma LiftTapes_Spec (sig : finType) (F : finType) (m n : nat) (I : Vector.t (Fin.t n) m) P' (P : SpecV sig n) Q' (Q : F -> SpecV sig m) (pM : pTM sig^+ F m) :
  dupfree I ->
  Triple (tspec (P',Downlift P I)) pM (fun y => tspec (Q' y,Q y)) ->
  Triple (tspec (P',P)) (LiftTapes pM I) (fun y => tspec (Q' y,Frame P I (Q y))).
Proof.
  unfold Frame. rewrite !Triple_iff.
  intros HDup HTrip.
  eapply Realise_monotone.
  { apply LiftTapes_Realise. assumption. apply HTrip. }
  {
    intros tin (yout, tout) (H&HInj). cbn -[Downlift tspec] in *.
    intros HP.
    spec_assert H by now apply tape_fulfill_Downlift_select.
    eapply tspecE in H as [H' H]. eapply tspecE in HP as [HP' HP].
    eapply tspecI;cbn.
    { clear - H' HP'. induction P';cbn in *. all:firstorder. }
    clear H' HP'.
    hnf. intros j. decide (Vector.In j I) as [HD|HD].
    - unfold Frame.
      apply vect_nth_In' in HD as (ij&HD).
      erewrite fill_correct_nth; eauto.
      specialize (H ij).
      now rewrite select_nth, HD in H.
    - unfold Frame. rewrite fill_not_index; eauto.
      specialize (HInj j HD). rewrite HInj. now apply HP.
  }
Qed.

Lemma LiftTapes_Spec_con (sig : finType) (F : finType) (m n : nat) (I : Vector.t (Fin.t n) m) P' (P : SpecV sig n) Q' (Q : F -> SpecV sig m) R' (R : F -> SpecV sig n) (pM : pTM sig^+ F m) :
  dupfree I ->
  Triple (tspec (P',Downlift P I)) pM (fun y => tspec (Q' y,Q y)) ->
  (forall yout, Entails (tspec (Q' yout,Frame P I (Q yout))) (tspec (R' yout,R yout))) ->
  Triple (tspec (P',P)) (LiftTapes pM I) (fun y => tspec (R' y,R y)).
Proof.
   intros ? ? <-%asPointwise. eapply LiftTapes_Spec. all:easy.
Qed.

(*
(* Version with disregarded labels *)
Lemma LiftTapes_Spec' (sig : finType) (F : Type) (m n : nat) (I : Vector.t (Fin.t n) m) (P : Spec sig n) (Q : Spec sig m) (pM : pTM sig^+ F m) :
  dupfree I ->
  Triple (tspec (Downlift I P)) pM (fun y => tspec Q) ->
  Triple (tspec P) (LiftTapes pM  I) (fun _ => tspec (Frame I P Q)).
Proof. apply LiftTapes_Spec. Qed.
*)

Lemma LiftTapes_SpecT (sig F : finType)(m n : nat) (I : Vector.t (Fin.t n) m) P' (P : SpecV sig n) (k : nat) Q' (Q : F -> SpecV sig m) (pM : pTM sig^+ F m) :
  dupfree I ->
  TripleT (tspec (P',Downlift P I)) k pM (fun y => tspec (Q' y,Q y)) ->
  TripleT (tspec (P',P)) k (LiftTapes pM  I) (fun y => tspec (Q' y,Frame P I (Q y))).
Proof.
  intros HDup (HTrip&HTrip').
  split.
  - apply LiftTapes_Spec; eauto.
  - eapply TerminatesIn_monotone.
    + apply LiftTapes_Terminates; eauto.
    + intros tin k' (H&H'). split; auto.
      now apply tape_fulfill_Downlift_select.
Qed.

Lemma LiftTapes_SpecT_con (sig : finType) (F : finType) (m n : nat) (I : Vector.t (Fin.t n) m)
P' (P : SpecV sig n) Q' (Q : F -> SpecV sig m) R' (R : F -> SpecV sig n)
      (k : nat) (pM : pTM sig^+ F m) :
  dupfree I ->
  TripleT (tspec (P',Downlift P I)) k pM (fun y => tspec (Q' y,Q y)) ->
  (forall yout, Entails (tspec (Q' yout,Frame P I (Q yout))) (tspec (R' yout,R yout))) ->
  TripleT (tspec (P',P)) k (LiftTapes pM  I) (fun y => tspec (R' y,R y)).
Proof. eauto using ConsequenceT_post, LiftTapes_SpecT. Qed.

(* Swap [Downlift] and [withSpace] *)
Lemma Downlift_withSpace (m n : nat) (sig : Type) (P : SpecV sig n) (I : Vector.t (Fin.t n) m) (ss : Vector.t nat n) :
  Downlift (withSpace P ss) I = withSpace (Downlift P I) (select I ss).
Proof.
  unfold withSpace, Downlift.
  eapply VectorSpec.eq_nth_iff; intros ? ? ->.
  simpl_vector. rewrite !select_nth. simpl_vector. reflexivity.
Qed.

Lemma tspec_Downlift_withSpace (m n : nat) (sig : Type) P' (P : SpecV sig n) (I : Vector.t (Fin.t n) m) (ss : Vector.t nat n):
  Entails ≃≃( P', Downlift (sig:=sig) (m:=m) (n:=n) (withSpace P ss) I) ≃≃( P',withSpace (Downlift P I) (select I ss)).
Proof. rewrite Entails_iff. intros H. erewrite <- Downlift_withSpace; eauto. Qed.

Lemma Triple_Downlift_withSpace (m n : nat) (sig : finType) P' (P : SpecV sig n) (I : Vector.t (Fin.t n) m) (ss : Vector.t nat n)
      (F : Type) (M : pTM sig^+ F m) (Q : F -> Assert sig^+ m) :
  Triple (tspec (P',withSpace (Downlift P I) (select I ss))) M Q ->
  Triple (tspec (P',Downlift (withSpace P ss) I)) M Q.
Proof. now rewrite <- tspec_Downlift_withSpace. Qed.

Lemma TripleT_Downlift_withSpace (m n : nat) (sig : finType) P' (P : SpecV sig n) (I : Vector.t (Fin.t n) m) (ss : Vector.t nat n)
      (F : Type) (k : nat) (M : pTM sig^+ F m) (Q : F -> Assert sig^+ m) :
  TripleT (tspec (P',withSpace (Downlift P I) (select I ss))) k M Q ->
  TripleT (tspec (P',Downlift (withSpace P ss) I)) k M Q.
Proof. now rewrite <- tspec_Downlift_withSpace. Qed.

(* TODO: Why is this needed? If needed: Move into base *)
Instance dec_ex_fin (n : nat) (P : Fin.t n -> Prop) (decP: forall (i : Fin.t n), dec (P i)) : dec (exists (i : Fin.t n), P i).
Proof.
  induction n.
  - right. intros (i&?). destruct_fin i.
  - decide (P Fin0).
    + left. eauto.
    + specialize (IHn (fun i => P (Fin.FS i))). spec_assert IHn as [IH|IH] by eauto.
      * left. destruct IH as (i&IH). exists (Fin.FS i). eauto.
      * right. intros (j&H). pose proof (fin_destruct_S j) as [(j'&->) | ->]; eauto.
Qed.

(* Move [withFrame] out of [Frame] *)
Lemma Frame_withSpace (m n : nat) (sig : Type) (P : SpecV sig n) (P' : SpecV sig m) (I : Vector.t (Fin.t n) m) (ss : Vector.t nat n) (ss' : Vector.t nat m) :
  dupfree I ->
  Frame (withSpace P ss) I (withSpace P' ss') = withSpace (Frame P I P') (fill I ss ss').
Proof.
  intros Hdup. unfold Frame,withSpace.
  eapply VectorSpec.eq_nth_iff; intros ? i ->.
  simpl_vector.
  decide (exists j, I[@j]=i) as [(j&Hj)|Hj].
  + erewrite !fill_correct_nth by eauto. now simpl_vector.
  + assert (not_index I i).
    { hnf. intros (k&<-) % vect_nth_In'. contradict Hj. eauto. }
    erewrite !fill_not_index by eauto. now simpl_vector.
Qed.

(*)
Lemma tspec_Frame_withSpace
      (m n : nat) (sig : Type) (P : Spec sig n) (P' : Spec sig m) (I : Vector.t (Fin.t n) m) (ss : Vector.t nat n) (ss' : Vector.t nat m)
      (t : tapes (boundary+sig) n) :
  t ≃≃ Frame (withSpace P ss) I (withSpace P' ss') ->
  dupfree I ->
  t ≃≃ withSpace (Frame P I P') (fill I ss ss').
Proof. intros H1 H2. erewrite <- Frame_withSpace; eauto. Qed.
*)

Lemma tspec_Frame_withSpace'
      (m n : nat) (I : Vector.t (Fin.t n) m):
  dupfree I -> forall (sig : Type) Q (P : SpecV sig n) (P' : SpecV sig m) (ss : Vector.t nat n) (ss' : Vector.t nat m),
  Entails ≃≃( Q , Frame (withSpace P ss) I (withSpace P' ss')) ≃≃( Q, withSpace (Frame P I P') (fill I ss ss')).
Proof. intros H1 **. erewrite <- Frame_withSpace; eauto. Qed.

(*
Lemma Triple_Frame_withSpace
      (m n : nat) (sig : finType) (P : Spec sig n) (P' : Spec sig m)(I : Vector.t (Fin.t n) m) (ss : Vector.t nat n) (ss' : Vector.t nat m)
      (F : Type) (M : pTM sig^+ F n) (Q : F -> Assert sig^+ n) :
  dupfree I ->
  Triple (tspec (withSpace (Frame P I P') (fill I ss ss')))    M Q ->
  Triple (tspec (Frame (withSpace P ss) I (withSpace P' ss'))) M Q.
Proof. intros H1 H2. erewrite Frame_withSpace; eauto. Qed.

Lemma TripleT_Frame_withSpace
      (m n : nat) (sig : finType) (P : Spec sig n) (P' : Spec sig m)(I : Vector.t (Fin.t n) m) (ss : Vector.t nat n) (ss' : Vector.t nat m)
      (F : Type) (k : nat) (M : pTM sig^+ F n) (Q : F -> Assert sig^+ n) :
  dupfree I ->
  TripleT (tspec (withSpace (Frame P I P') (fill I ss ss')))    k M Q ->
  TripleT (tspec (Frame (withSpace P ss) I (withSpace P' ss'))) k M Q.
Proof. intros H1 H2. erewrite Frame_withSpace; eauto. Qed.

*)

(* Versions of [LiftTapes] with space *)

Lemma LiftTapes_Spec_space (sig F : finType) (m n : nat) (I : Vector.t (Fin.t n) m) P' (P : SpecV sig n) Q' (Q : F -> SpecV sig m) (pM : pTM sig^+ F m)
     (ss : Vector.t nat n) (ss' : Vector.t nat m) :
  dupfree I ->
  Triple (tspec (P',withSpace (Downlift P I) (select I ss))) pM (fun y => tspec (Q' y,withSpace (Q y) ss')) ->
  Triple (tspec (P',withSpace P ss)) (LiftTapes pM  I) (fun y => tspec (Q' y,withSpace (Frame P I (Q y)) (fill I ss ss'))).
Proof.
  intros H1 H2. rewrite <- Downlift_withSpace in H2. apply LiftTapes_Spec in H2. setoid_rewrite tspec_Frame_withSpace' in H2. all:eauto.
Qed.

Lemma LiftTapes_SpecT_space (sig F : finType) (m n : nat) (I : Vector.t (Fin.t n) m) P' (P : SpecV sig n) (k : nat) Q' (Q : F -> SpecV sig m) (pM : pTM sig^+ F m)
     (ss : Vector.t nat n) (ss' : Vector.t nat m) :
  dupfree I ->
  TripleT (tspec (P',withSpace (Downlift P I) (select I ss))) k pM (fun y => tspec (Q' y,withSpace (Q y) ss')) ->
  TripleT (tspec (P',withSpace P ss)) k (LiftTapes pM  I) (fun y => tspec (Q' y,withSpace (Frame P I (Q y)) (fill I ss ss'))).
Proof.
  intros H1 H2. rewrite <- Downlift_withSpace in H2. apply LiftTapes_SpecT in H2. setoid_rewrite tspec_Frame_withSpace' in H2. all:eauto.
Qed.

Lemma LiftTapes_Spec_space_con (sig : finType) (F : finType) (m n : nat) (I : Vector.t (Fin.t n) m)
      P' (P : SpecV sig n) Q' (Q : F -> SpecV sig m) R' (R : F -> SpecV sig n) (ss : Vector.t nat n) (ss' : Vector.t nat m) (ss'' : Vector.t nat n)
      (pM : pTM sig^+ F m) :
  dupfree I ->
  Triple (tspec (P',withSpace (Downlift P I) (select I ss))) pM (fun y => tspec (Q' y,withSpace (Q y) ss')) ->
  (forall yout, Entails (tspec (Q' yout,withSpace (Frame P I (Q yout)) (fill I ss ss'))) (tspec (R' yout,withSpace (R yout) ss''))) ->
  Triple (tspec (P',withSpace P ss)) (LiftTapes pM  I) (fun y => tspec (R' y,withSpace (R y) ss'')).
Proof.
  intros H1 H2 <-%asPointwise. rewrite <- Downlift_withSpace in H2. apply LiftTapes_Spec in H2.
  setoid_rewrite tspec_Frame_withSpace' in H2. all:easy.
Qed.

Lemma LiftTapes_SpecT_space_con (sig : finType) (F : finType) (m n : nat) (I : Vector.t (Fin.t n) m)
      P' (P : SpecV sig n) Q' (Q : F -> SpecV sig m) R' (R : F -> SpecV sig n) (ss : Vector.t nat n) (ss' : Vector.t nat m) (ss'' : Vector.t nat n)
      (k : nat) (pM : pTM sig^+ F m) :
  dupfree I ->
  TripleT (tspec (P',withSpace (Downlift P I) (select I ss))) k pM (fun y => tspec (Q' y,withSpace (Q y) ss')) ->
  (forall yout, Entails (tspec (Q' yout,withSpace (Frame P I (Q yout)) (fill I ss ss'))) (tspec (R' yout,withSpace (R yout) ss''))) ->
  TripleT (tspec (P',withSpace P ss)) k (LiftTapes pM  I) (fun y => tspec (R' y,withSpace (R y) ss'')).
Proof.
  intros H1 H2 <-%asPointwise. rewrite <- Downlift_withSpace in H2. apply LiftTapes_SpecT in H2.
  setoid_rewrite tspec_Frame_withSpace' in H2. all:easy.
Qed.

(* ** Alphabet Lifting *)

(* Alphabet lifting is easy. We only have to add the retraction to the specification. *)
(* We could also implement this for abstract hoare triples, like in the below rule for [Custom]. *)

Section AlphabetLifting.

  Variable (sig tau : Type).
  Variable (retr : Retract sig tau).

  Definition LiftSpec_single (T : RegSpec sig) : RegSpec tau :=
    match T with
    | Contains r x => Contains (ComposeRetract retr r) x
    | Contains_size r x s => Contains_size (ComposeRetract retr r) x s
    | Void => Void
    | Void_size s => Void_size s
    | Custom p => Custom (fun t => p (surjectTape (Retr_g) (inl UNKNOWN) t))
    end.

  Variable (n : nat).

  Definition LiftSpec (T : SpecV sig n) : SpecV tau n :=
    Vector.map LiftSpec_single T.

  Lemma LiftSpec_surjectTape_tspec_single t T :
    tspec_single (LiftSpec_single T) t ->
    tspec_single T (surjectTape Retr_g (inl UNKNOWN) t).
  Proof. destruct T; cbn in *; intros; simpl_surject; eauto. Qed.

  Lemma LiftSpec_surjectTape_tspec_single' t T :
    tspec_single T (surjectTape Retr_g (inl UNKNOWN) t) ->
    tspec_single (LiftSpec_single T) t.
  Proof. destruct T; cbn in *; intros; simpl_surject; eauto. Qed.

  Lemma LiftSpec_surjectTapes_tspec tin P' P :
    tin ≃≃ (P', LiftSpec P) ->
    surjectTapes Retr_g (inl UNKNOWN) tin ≃≃ (P',P).
  Proof.
    intros (H'&H)%tspecE. eapply tspecI. easy.
    intros i; specialize (H i); cbn. unfold LiftSpec in *.
    simpl_tape in *. now apply LiftSpec_surjectTape_tspec_single.
  Qed.

  Lemma LiftSpec_surjectTapes_tspec' tin P P':
    surjectTapes Retr_g (inl UNKNOWN) tin ≃≃ (P',P) ->
    tin ≃≃ (P',LiftSpec P).
  Proof.
    intros (H'&H)%tspecE. eapply tspecI. easy. unfold LiftSpec in *.
    intros i; specialize (H i); cbn.
    simpl_tape in *. now apply LiftSpec_surjectTape_tspec_single'.
  Qed.

End AlphabetLifting.

Lemma LiftSpec_withSpace_single (sig tau : Type) (I : Retract sig tau) (P : RegSpec sig) (s : nat) :
  LiftSpec_single I (withSpace_single P s) = withSpace_single (LiftSpec_single I P) s.
Proof. destruct P; cbn; eauto. Qed.

Lemma LiftSpec_withSpace (sig tau : Type) (n : nat) (I : Retract sig tau) (P : SpecV sig n) (ss : Vector.t nat n) :
  LiftSpec I (withSpace P ss) = withSpace (LiftSpec I P) ss.
Proof.
  eapply VectorSpec.eq_nth_iff; intros ? ? ->. unfold LiftSpec, withSpace.
  simpl_vector. apply LiftSpec_withSpace_single.
Qed.
(*
Lemma tspec_LiftSpec_withSpace (sig tau : Type) (n : nat) (I : Retract sig tau) P' (P : SpecV sig n) (ss : Vector.t nat n):
  Entails ≃≃( P',LiftSpec I (withSpace P ss)) ≃≃( P', withSpace (LiftSpec I P) ss).
Proof. now rewrite LiftSpec_withSpace. Qed.

Lemma tspec_LiftSpec_withSpace' (sig tau : Type) (n : nat) (I : Retract sig tau) (P : Spec sig n) (ss : Vector.t nat n):
  Entails ≃≃( withSpace (LiftSpec I P) ss) ≃≃( LiftSpec I (withSpace P ss)).
Proof. now rewrite LiftSpec_withSpace. Qed.

Lemma Triple_LiftSpec_withSpace (sig tau : finType) (n : nat) (I : Retract sig tau) (P : Spec sig n) (ss : Vector.t nat n)
      (F : Type) (M : pTM tau^+ F n) (Q : F -> Assert (boundary+tau) n) :
  Triple (tspec (withSpace (LiftSpec I P) ss)) M Q ->
  Triple (tspec (LiftSpec I (withSpace P ss))) M Q.
Proof. now rewrite LiftSpec_withSpace. Qed.

Lemma TripleT_LiftSpec_withSpace (sig tau : finType) (n : nat) (I : Retract sig tau) (P : Spec sig n) (ss : Vector.t nat n)
      (F : Type) (k : nat) (M : pTM tau^+ F n) (Q : F -> Assert (boundary+tau) n) :
  TripleT (tspec (withSpace (LiftSpec I P) ss)) k M Q ->
  TripleT (tspec (LiftSpec I (withSpace P ss))) k M Q.
Proof. now rewrite LiftSpec_withSpace. Qed.
*)

Section AlphabetLifting'.

  Variable (sig tau : finType) (n : nat).
  Variable (retr : Retract sig tau).

  Lemma ChangeAlphabet_Spec_ex (F : finType) X P' (Ctx : X -> Prop -> Prop) (P : SpecV sig n) (pM : pTM sig^+ F n) Q' (Q : X -> F -> SpecV sig n) :
    Triple (tspec (P',P)) pM (fun y t => exists x:X, Ctx x (tspec (Q' x y,Q x y) t)) ->
    (forall x, Proper (Basics.impl ==> Basics.impl) (Ctx x)) ->
    Triple (tspec (P',LiftSpec retr P)) (ChangeAlphabet pM retr)
      (fun yout t => exists x, Ctx x (tspec (Q' x yout,LiftSpec retr (Q x yout)) t)).
  Proof.
    rewrite !Triple_iff. intros HTrip HCtx. eapply Realise_monotone.
    - TM_Correct. eassumption.
    - intros tin (yout, tout) H Henc. cbn in *.
      spec_assert H by now apply LiftSpec_surjectTapes_tspec.
      destruct H as (x&H). exists x. cbv in HCtx. eapply HCtx. 2:apply H.
      now apply LiftSpec_surjectTapes_tspec'.
  Qed.

  Lemma ChangeAlphabet_Spec (F : finType) P' (P : SpecV sig n) (pM : pTM sig^+ F n) Q' (Q : F -> SpecV sig n) :
    Triple (tspec (P',P)) pM (fun yout => tspec (Q' yout,Q yout)) ->
    Triple (tspec (P',LiftSpec retr P)) (ChangeAlphabet pM retr) (fun yout => tspec (Q' yout,LiftSpec retr (Q yout))).
  Proof.
    rewrite !Triple_iff. intros HTrip. eapply Realise_monotone.
    - TM_Correct. eassumption.
    - intros tin (yout, tout) H Henc. cbn in *.
      spec_assert H by now apply LiftSpec_surjectTapes_tspec.
      now apply LiftSpec_surjectTapes_tspec'.
  Qed.

  Lemma ChangeAlphabet_SpecT (F : finType) P' (P : SpecV sig n) (k : nat) (pM : pTM sig^+ F n) Q' (Q : F -> SpecV sig n) :
    TripleT (tspec (P',P)) k pM (fun yout => tspec (Q' yout, Q yout)) ->
    TripleT (tspec (P',LiftSpec retr P)) k (ChangeAlphabet pM retr) (fun yout => tspec (Q' yout,LiftSpec retr (Q yout))).
  Proof.
    intros HTrip. split.
    { apply ChangeAlphabet_Spec. eapply TripleT_Triple; eauto. }
    {
      eapply TerminatesIn_monotone.
      - TM_Correct. apply HTrip.
      - unfold Triple_TRel. intros tin k' (H&Hk). cbn. split; auto.
        now apply LiftSpec_surjectTapes_tspec.
    }
  Qed.

  (* We always have to use at least [Consequence_pre], because the premise will never match. *)

  Lemma ChangeAlphabet_Spec_pre_post (F : finType)
        P0 (P : SpecV sig n) (P' : SpecV tau n)
        (pM : pTM sig^+ F n)
        Q0 (Q : F -> SpecV sig n) (Q' : F -> SpecV tau n) :
    Triple (tspec (P0,P)) pM (fun yout => tspec (Q0 yout, Q yout) ) ->
    (Entails ≃≃( P0,P') ≃≃( P0,LiftSpec retr P)) ->
    (forall yout, Entails ≃≃( Q0 yout, LiftSpec retr (Q yout)) ≃≃( (Q0 yout,Q' yout))) ->
    Triple (tspec (P0, P')) (ChangeAlphabet pM retr) (fun yout => tspec (Q0 yout, Q' yout)).
  Proof.
    intros H1 H2 H3.
    eapply Consequence.
    - apply ChangeAlphabet_Spec. apply H1.
    - apply H2.
    - apply H3.
  Qed.

  Lemma ChangeAlphabet_SpecT_pre_post (F : finType)
        P0 (P : SpecV sig n) (P' : SpecV tau n)
        (k : nat) (pM : pTM sig^+ F n)
        Q0 (Q : F -> SpecV sig n) (Q' : F -> SpecV tau n) :
    TripleT (tspec (P0,P)) k pM (fun yout => tspec (Q0 yout, Q yout) ) ->
    (Entails ≃≃( P0,P') ≃≃( P0,LiftSpec retr P)) ->
    (forall yout, Entails ≃≃( Q0 yout, LiftSpec retr (Q yout)) ≃≃( (Q0 yout,Q' yout))) ->
    TripleT (tspec (P0, P')) k (ChangeAlphabet pM retr) (fun yout => tspec (Q0 yout, Q' yout)).
  Proof.
    intros H1 H2 H3.
    eapply ConsequenceT.
    - apply ChangeAlphabet_SpecT. apply H1.
    - apply H2.
    - apply H3.
    - reflexivity.
  Qed.

  Lemma ChangeAlphabet_Spec_pre (F : finType)
        P0 (P : SpecV sig n) (P' : SpecV tau n)
        (pM : pTM sig^+ F n)
        Q0 (Q : F -> SpecV sig n) :
    Triple (tspec (P0,P)) pM (fun yout => tspec (Q0 yout, Q yout)) ->
    (Entails ≃≃( P0,P') ≃≃( P0, LiftSpec retr P)) ->
    Triple (tspec (P0,P')) (ChangeAlphabet pM retr) (fun yout => tspec (Q0 yout,LiftSpec retr (Q yout))).
  Proof.
    intros H1 H2.
    eapply Consequence.
    - apply ChangeAlphabet_Spec. apply H1.
    - apply H2.
    - eauto.
  Qed.

  Lemma ChangeAlphabet_SpecT_pre (F : finType)
        P0 (P : SpecV sig n) (P' : SpecV tau n)
        (k : nat) (pM : pTM sig^+ F n)
        Q0 (Q : F -> SpecV sig n) :
    TripleT (tspec (P0,P)) k pM (fun yout => tspec (Q0 yout, Q yout)) ->
    (Entails ≃≃( P0, P') ≃≃( P0,LiftSpec retr P)) ->
    TripleT (tspec (P0,P')) k (ChangeAlphabet pM retr) (fun yout => tspec (Q0 yout,LiftSpec retr (Q yout))).
  Proof.
    intros H1 H2.
    eapply ConsequenceT.
    - apply ChangeAlphabet_SpecT. apply H1.
    - apply H2.
    - eauto.
    - reflexivity.
  Qed.

  (* Versions with space *)

  Lemma ChangeAlphabet_Spec_space_pre_post (F : finType)
        P0 (P : SpecV sig n) (P' : SpecV tau n)
        (pM : pTM sig^+ F n)
        Q0 (Q : F -> SpecV sig n) (Q' : F -> SpecV tau n)
        (ss ss' : Vector.t nat n) :
    Triple (tspec (P0,withSpace P ss)) pM (fun yout => tspec (Q0 yout,withSpace (Q yout) ss')) ->
    (Entails ≃≃( P0, withSpace P' ss) ≃≃( P0, withSpace (LiftSpec retr P) ss)) ->
    (forall yout, Entails ≃≃( Q0 yout, withSpace (LiftSpec retr (Q yout)) ss') (tspec (Q0 yout,withSpace (Q' yout) ss'))) ->
    Triple (tspec (P0,withSpace P' ss)) (ChangeAlphabet pM retr) (fun yout => tspec (Q0 yout, withSpace (Q' yout) ss')).
  Proof.
    intros H1 H2 H3.
    eapply Consequence.
    - apply ChangeAlphabet_Spec. apply H1.
    - rewrite LiftSpec_withSpace. apply H2.
    - setoid_rewrite Entails_iff. cbn. intros. rewrite LiftSpec_withSpace in H. now apply H3.
  Qed.

  Lemma ChangeAlphabet_SpecT_space_pre_post (F : finType)
        P0 (P : SpecV sig n) (P' : SpecV tau n)
        (k : nat) (pM : pTM sig^+ F n)
        Q0  (Q : F -> SpecV sig n) (Q' : F -> SpecV tau n)
        (ss ss' : Vector.t nat n) :
        TripleT (tspec (P0,withSpace P ss)) k pM (fun yout => tspec (Q0 yout,withSpace (Q yout) ss')) ->
        (Entails ≃≃( P0, withSpace P' ss) ≃≃( P0, withSpace (LiftSpec retr P) ss)) ->
        (forall yout, Entails ≃≃( Q0 yout, withSpace (LiftSpec retr (Q yout)) ss') (tspec (Q0 yout,withSpace (Q' yout) ss'))) ->
        TripleT (tspec (P0,withSpace P' ss)) k (ChangeAlphabet pM retr) (fun yout => tspec (Q0 yout, withSpace (Q' yout) ss')).
  Proof.
    intros H1 H2 H3.
    eapply ConsequenceT.
    - apply ChangeAlphabet_SpecT. apply H1.
    - rewrite LiftSpec_withSpace. apply H2.
    - setoid_rewrite Entails_iff.  cbn. intros. rewrite LiftSpec_withSpace in H. now apply H3.
    - reflexivity.
  Qed.

  Lemma ChangeAlphabet_Spec_space_pre (F : finType)
        P0 (P : SpecV sig n) (P' : SpecV tau n)
        (pM : pTM sig^+ F n)
        Q0 (Q : F -> SpecV sig n)
        (ss ss' : Vector.t nat n) :
    Triple (tspec (P0,withSpace P ss)) pM (fun yout => tspec (Q0 yout,withSpace (Q yout) ss')) ->
    Entails ≃≃( P0, withSpace P' ss) ≃≃( P0, withSpace (LiftSpec retr P) ss) ->
    Triple (tspec (P0, withSpace P' ss)) (ChangeAlphabet pM retr) (fun yout => tspec (Q0 yout, withSpace (LiftSpec retr (Q yout)) ss')).
  Proof.
    intros H1 H2.
    eapply Consequence.
    - apply ChangeAlphabet_Spec. apply H1.
    - rewrite LiftSpec_withSpace. apply H2.
    - setoid_rewrite Entails_iff. cbn. intros. rewrite LiftSpec_withSpace in H. now apply H.
  Qed.

  Lemma ChangeAlphabet_SpecT_space_pre (F : finType)
        P0 (P : SpecV sig n) (P' : SpecV tau n)
        (k : nat) (pM : pTM sig^+ F n)
        Q0 (Q : F -> SpecV sig n)
        (ss ss' : Vector.t nat n) :
    TripleT (tspec (P0,withSpace P ss)) k pM (fun yout => tspec (Q0 yout, withSpace (Q yout) ss')) ->
    Entails ≃≃( P0, withSpace P' ss) ≃≃( P0, withSpace (LiftSpec retr P) ss) ->
    TripleT (tspec (P0, withSpace P' ss)) k (ChangeAlphabet pM retr) (fun yout => tspec (Q0 yout,withSpace (LiftSpec retr (Q yout)) ss')).
  Proof.
    intros H1 H2.
    eapply ConsequenceT.
    - apply ChangeAlphabet_SpecT. apply H1.
    - rewrite LiftSpec_withSpace. apply H2.
    - setoid_rewrite Entails_iff. cbn. intros. rewrite LiftSpec_withSpace in H. now apply H.
    - reflexivity.
  Qed.

End AlphabetLifting'.

(*
Lemma ChangeAlphabet_Rel (sig tau : finType) (I : Retract sig tau) (n : nat) (F : finType) (M : pTM sig^+ F n) (R : pRel sig^+ F n) (R' : pRel tau^+ F n) :
  M ⊨ R ->
  (forall (tin : tapes tau^+ n) yout tout, R (surjectTapes Retr_g (inl UNKNOWN) tin) (yout, surjectTapes Retr_g (inl UNKNOWN) tout) -> R' tin (yout, tout)) ->
  M ⇑ I ⊨ R'.
Proof.
  intros HRel H.
  eapply Realise_monotone.
  - TM_Correct. apply HRel.
  - intros tin (yout, tout) H'. cbn in *. eauto.
Qed.
*)

(* We always want to keep [withSpace] right after [tspec] in the assertions. *)
Global Arguments withSpace : simpl never.

(*
Definition coerceSpec {sig n} V : Spec sig n := ([],V).
Coercion coerceSpec : SpecV >-> Spec.
*)

(* TODO: remove legacy *)
Notation "'SpecFalse'" := ([False],_): spec_scope.
(*Notation SpecVector P := (coerceSpec P) (only parsing). *)