Require Import Logic.SeparationLogic.Tactics.Language.
Require Import Coq.Lists.List.
Require Import Coq.Numbers.BinNums.
Require Import Coq.PArith.BinPosDef.
Require Import Logic.lib.Coqlib.
Require Import Logic.lib.PTree.

Local Open Scope shallow_syntax.
Local Open Scope list_scope.

Inductive expr_deep: Type :=
  | impp_deep : expr_deep -> expr_deep -> expr_deep
  | sepcon_deep : expr_deep -> expr_deep -> expr_deep
  | emp_deep : expr_deep
  | varp_deep : nat -> expr_deep.

Fixpoint beq e1 e2 :=
  match e1, e2 with
  | emp_deep, emp_deep => true
  | varp_deep x, varp_deep y => EqNat.beq_nat x y
  | sepcon_deep p11 p12, sepcon_deep p21 p22 => andb (beq p11 p21) (beq p12 p22)
  | impp_deep p11 p12, impp_deep p21 p22 => andb (beq p11 p21) (beq p12 p22)
  | _, _ => false
  end.

Ltac length_cont ls k :=
  match ls with
  | nil => k O
  | _ :: ?ls' => length_cont ls' ltac:(fun n => k (S n))
  end.
Ltac length ls := length_cont ls ltac:(fun l => l).

Ltac pred n :=
  match n with
  | O => O
  | S ?m => m
  end.

Ltac search_expr' n i l l0 :=
  match l with
  | nil => let len := length l0 in constr:((S len, n :: l0))
  | n :: ?t => constr:((i, l0))
  | _ :: ?t => let pi := pred i in search_expr' n pi t l0
  end.
Ltac search_expr n l := let len := length l in search_expr' n len l l.

Ltac shallowTodeep' se l0 :=
  match se with
  | ?sp * ?sq =>
    match shallowTodeep' sp l0 with
    | (?dp, ?l1) =>
      match shallowTodeep' sq l1 with
      | (?dq, ?l2) => constr:((sepcon_deep dp dq, l2))
      end
    end
  | ?sp --> ?sq =>
    match shallowTodeep' sp l0 with
    | (?dp, ?l1) =>
      match shallowTodeep' sq l1 with
      | (?dq, ?l2) => constr:((impp_deep dp dq, l2))
      end
    end
  | emp => constr:((emp_deep, l0))
  | ?sp => match search_expr sp l0 with
          | (?i, ?l1) => constr:((varp_deep i, l1))
          end
  end.

Ltac shallowTodeep se :=
  match shallowTodeep' se constr:(@nil expr) with
  | (?de, ?tbl) =>
    match de with
    | impp_deep ?dep ?deq => constr:((dep, deq, tbl))
    end
  end.

Inductive tree_pos: Type :=
  | var_pos : expr -> option positive -> tree_pos
  | sepcon_pos : tree_pos -> tree_pos -> tree_pos.

Ltac shallowTotree_odd se :=
  match se with
  |?sp * ?sq =>
    match shallowTotree_odd sp with
    | ?tp =>
      match shallowTotree_odd sq with
      | ?tq => constr:(sepcon_pos tp tq)
      end
    end
  | ?sp => constr:(var_pos sp None)
  end.

Ltac shallowTotree se :=
  match se with
  | ?sep --> ?seq =>
    match shallowTotree_odd sep with
    | ?tep =>
      match shallowTotree_odd seq with
      | ?teq => constr:((tep, teq))
      end
    end
  end.

Fixpoint cancel_mark_context dep q tep key : tree_pos * bool:=
  match dep, tep with
  | sepcon_deep dp dq, sepcon_pos tp tq =>
    match cancel_mark_context dp q tp key with
    | (tp', true) => ((sepcon_pos tp' tq), true)
    | (tp', false) =>
      match cancel_mark_context dq q tq key with
      | (tq', true) => ((sepcon_pos tp tq'), true)
      | (tq', false) => (tep, false)
      end
    end
  | p, (var_pos sp o) =>
    match (beq p q) with
    | true =>
      match o with
      | None => ((var_pos sp (Some key)), true)
      | _ => (tep, false)
      end
    | false => (tep, false)
    end
  | _, _ => (tep, false)
  end.

Fixpoint cancel_mark' dep deq tep teq key : tree_pos * tree_pos * positive :=
  match deq, teq with
  | sepcon_deep dp dq, sepcon_pos tp tq =>
    match (cancel_mark' dep dp tep tp key) with
    | (tep', tp', key') =>
      match (cancel_mark' dep dq tep' tq key') with
      | (tep'', tq', key'') => (tep'', sepcon_pos tp' tq', key'')
      end
    end
  | q, (var_pos sq o) =>
    match (cancel_mark_context dep q tep key) with
    | (tep', true) => (tep', (var_pos sq (Some key)), Pos.succ key)
    | (tep', false) => (tep', var_pos sq None, key)
    end
  | _, _ => (tep, teq, key)
  end.

Definition cancel_mark dep deq tep teq : tree_pos * tree_pos :=
  match (cancel_mark' dep deq tep teq xH) with
  | (tep', teq', key') => (tep', teq')
  end.

Fixpoint unmark_sort' tep : option expr :=
  match tep with
  | sepcon_pos tp tq =>
    match unmark_sort' tp with
    | None => unmark_sort' tq
    | Some sp =>
      match unmark_sort' tq with
      | None => Some sp
      | Some sq => Some (sp * sq)
      end
    end
  | var_pos sq o =>
    match o with
    | None => Some sq
    | _ => None
    end
  end.
Definition unmark_sort tep : expr :=
  match unmark_sort' tep with
  | Some sp => sp
  | None => emp
  end.

Definition cancel_different tep teq : expr :=
  (unmark_sort tep) --> (unmark_sort teq).

(*
Fixpoint flatten tep : list expr :=
  match tep with
  | sepcon_pos tp tq => (flatten tp) ++ (flatten tq)
  | var_pos sp o =>
    match o with
    | None => sp :: nil
    | _ => nil
    end
  end.

Fixpoint unflatten' lep sp : expr :=
  match lep with
  | nil => sp
  | sq :: lep' => unflatten' lep' (sp * sq)
  end.

Definition unflatten lep : expr :=
  match lep with
  | nil => emp
  | sp :: lep' => unflatten' lep' sp
  end.

Definition cancel_different tep teq : expr :=
  (unflatten (flatten tep)) --> (unflatten (flatten teq)).
*)

Fixpoint mark_sort' tep m: PTree.tree expr :=
  match tep with
  | sepcon_pos tp tq =>
    match mark_sort' tp m with
    | m' => mark_sort' tq m'
    end
  | var_pos sq o =>
    match o with
    | None => m
    | Some pos =>
      match PTree.get_rec expr pos m with
      | None => PTree.set_rec expr pos sq m
      | Some sp => PTree.set_rec expr pos (sp * sq) m
      end
    end
  end.
Definition mark_sort tep : PTree.tree expr :=
  mark_sort' tep PTree.empty.

Definition cancel_same tep teq : Prop :=
  mark_sort tep = mark_sort teq.

Fixpoint restore' tep : expr :=
  match tep with
  | sepcon_pos tp tq => (restore' tp) * (restore' tq)
  | var_pos sp o => sp
  end.
Definition restore tep teq : expr :=
  (restore' tep) --> (restore' teq).

Section AxiomClass2.

Lemma sepcon_assoc2 : forall x y z,
  |-- (x * y) * z --> (x * (y * z)).
Proof.
  intros.
  rewrite (sepcon_comm_impp (x * y) z).
  rewrite (sepcon_assoc1 z x y).
  rewrite (sepcon_comm_impp (z * x) y).
  rewrite (sepcon_assoc1 y z x).
  rewrite (sepcon_comm_impp (y * z) x).
  apply provable_impp_refl.
Qed.

Lemma switch : forall x y p q,
  |-- x * y * (p * q) --> x * p * (y * q).
Proof.
  intros.
  rewrite <- (sepcon_assoc1 x p (y * q)).
  rewrite <- (sepcon_comm_impp (y * q) p).
  rewrite <- (sepcon_assoc1 y q p).
  rewrite <- (sepcon_comm_impp p q).
  apply sepcon_assoc2.
Qed.

End AxiomClass2.

Section Proof.

Fixpoint build l : expr :=
  match l with
  | nil => emp
  | p :: l' => p * build l'
  end.

Lemma build_cons : forall l1 l2 e,
  |-- build (l1 ++ e :: l2) --> build (l1 ++ l2) * e.
Proof.
  intros.
  induction l1; simpl.
  - apply sepcon_comm_impp.
  - rewrite IHl1.
    apply sepcon_assoc1.
Qed.

Lemma sepcon_build : forall l1 l2 e,
  |-- build (l1 ++ l2) * e --> build (l1 ++ e :: l2).
Proof.
  intros.
  induction l1; simpl.
  - apply sepcon_comm_impp.
  - rewrite <- IHl1.
    apply sepcon_assoc2.
Qed.

Lemma add1 : forall e' p m,
  |-- build (PTree.elements expr (mark_sort' (var_pos e' (Some p)) m))
  --> build (PTree.elements expr m) * e'.
Proof.
  intros.
  unfold mark_sort'.
  destruct (PTree.get_rec expr p m) eqn:?H.
  - pose proof (PTree.elements_set_some expr p e (e * e') m).
    apply H0 in H; clear H0.
    destruct H as [l1]; destruct H as [l2].
    destruct H as [H1 H2].
    rewrite H1, H2.
    rewrite build_cons. rewrite <- sepcon_build.
    apply sepcon_assoc1.
  - pose proof (PTree.elements_set_none expr p e' m).
    apply H0 in H; clear H0.
    destruct H as [l1]; destruct H as [l2].
    destruct H as [H1 H2].
    rewrite H1, H2.
    rewrite build_cons.
    apply provable_impp_refl.
Qed.

Lemma add2 : forall e' p m,
  |-- build (PTree.elements expr m) * e'
  --> build (PTree.elements expr (mark_sort' (var_pos e' (Some p)) m)).
Proof.
  intros.
  unfold mark_sort'.
  destruct (PTree.get_rec expr p m) eqn:?H.
  - pose proof (PTree.elements_set_some expr p e (e * e') m).
    apply H0 in H; clear H0.
    destruct H as [l1]; destruct H as [l2].
    destruct H as [H1 H2].
    rewrite H1, H2.
    rewrite build_cons. rewrite <- sepcon_build.
    apply sepcon_assoc2.
  - pose proof (PTree.elements_set_none expr p e' m).
    apply H0 in H; clear H0.
    destruct H as [l1]; destruct H as [l2].
    destruct H as [H1 H2].
    rewrite H1, H2.
    rewrite <- sepcon_build.
    apply provable_impp_refl.
Qed.

Lemma L1_before1 : forall sp p,
  |-- sp --> build (PTree.elements expr (mark_sort (var_pos sp (Some p)))).
Proof.
  intros.
  unfold mark_sort, mark_sort'.
  rewrite PTree.get_empty.
  rewrite PTree.elements_set_empty.
  unfold build.
  apply sepcon_emp2.
Qed.

Lemma L1_before2 : forall p1 p2,
  |-- unmark_sort p1 * unmark_sort p2 --> unmark_sort (sepcon_pos p1 p2).
Proof.
  intros.
  unfold unmark_sort.
  unfold unmark_sort'; fold unmark_sort'.
  destruct (unmark_sort' p1), (unmark_sort' p2).
  - apply provable_impp_refl.
  - apply sepcon_emp1.
  - rewrite sepcon_comm_impp; apply sepcon_emp1.
  - apply sepcon_emp1.
Qed.

Lemma L1_before3 : forall p1 p2,
  |-- build (PTree.elements expr (mark_sort p1)) * build (PTree.elements expr (mark_sort p2)) --> build (PTree.elements expr (mark_sort (sepcon_pos p1 p2))).
Proof.
  intros.
  unfold  mark_sort.
  unfold mark_sort'; fold mark_sort'.
  set (m1 := mark_sort' p1 PTree.empty) at 1.
  set (m3 := mark_sort' p1 PTree.empty).
  set (m2 := PTree.empty).
  assert (|-- build (PTree.elements expr m1) * build (PTree.elements expr m2) --> build (PTree.elements expr m3)).
  { unfold m2, PTree.empty, PTree.elements, PTree.xelements. apply sepcon_emp1. }
  clearbody m1 m2 m3.
  revert m1 m2 m3 H.
  induction p2; intros.
  - destruct o.
    + rewrite add1.
      rewrite <- add2.
      rewrite sepcon_assoc1.
      rewrite H.
      apply provable_impp_refl.
    + auto.
  - apply IHp2_1 in H.
    apply IHp2_2 in H.
    auto.
Qed.

Lemma L1 : forall tep,
  |-- restore' tep --> unmark_sort tep * (build (PTree.elements expr (mark_sort tep))).
Proof.
  intros.
  induction tep as [sp op|p1 IH1 p2 IH2]; unfold restore'; fold restore'.
  - unfold unmark_sort, unmark_sort'.
    destruct op.
    + pose proof (L1_before1 sp p) as L1_before1; compute in L1_before1.
      rewrite <- L1_before1; clear L1_before1.
      rewrite <- sepcon_comm_impp.
      apply sepcon_emp2.
    + apply sepcon_emp2.
  - rewrite IH1, IH2.
    rewrite <- L1_before2, <- L1_before3.
    apply switch.
Qed.

Lemma L2_before1 : forall sq p,
  |-- build (PTree.elements expr (mark_sort (var_pos sq (Some p)))) --> sq.
Proof.
  intros.
  unfold mark_sort, mark_sort'.
  rewrite PTree.get_empty.
  rewrite PTree.elements_set_empty.
  unfold build.
  apply sepcon_emp1.
Qed.

Lemma L2_before2 : forall q1 q2,
  |-- unmark_sort (sepcon_pos q1 q2) --> unmark_sort q1 * unmark_sort q2.
Proof.
  intros.
  unfold unmark_sort.
  unfold unmark_sort'; fold unmark_sort'.
  destruct (unmark_sort' q1), (unmark_sort' q2).
  - apply provable_impp_refl.
  - apply sepcon_emp2.
  - rewrite <- sepcon_comm_impp; apply sepcon_emp2.
  - apply sepcon_emp2.
Qed.

Lemma L2_before3 : forall q1 q2,
  |-- build (PTree.elements expr (mark_sort (sepcon_pos q1 q2))) --> build (PTree.elements expr (mark_sort q1)) * build (PTree.elements expr (mark_sort q2)).
Proof.
  intros.
  unfold  mark_sort.
  unfold mark_sort'; fold mark_sort'.
  set (m1 := mark_sort' q1 PTree.empty) at 2.
  set (m3 := mark_sort' q1 PTree.empty).
  set (m2 := PTree.empty).
  assert (|-- build (PTree.elements expr m3) --> build (PTree.elements expr m1) * build (PTree.elements expr m2)).
  { unfold m2, PTree.empty, PTree.elements, PTree.xelements. apply sepcon_emp2. }
  clearbody m1 m2 m3.
  revert m1 m2 m3 H.
  induction q2; intros.
  - destruct o.
    + rewrite add1.
      rewrite <- add2.
      rewrite <- sepcon_assoc2.
      rewrite H.
      apply provable_impp_refl.
    + auto.
  - apply IHq2_1 in H.
    apply IHq2_2 in H.
    auto.
Qed.

Lemma L2 : forall teq,
  |-- unmark_sort teq * build (PTree.elements expr (mark_sort teq)) --> restore' teq.
Proof.
  intros.
  induction teq as [sq oq|q1 IH1 q2 IH2]; unfold restore'; fold restore'.
  - unfold unmark_sort, unmark_sort'.
    destruct oq.
    + pose proof (L2_before1 sq p) as L2_before1; compute in L2_before1.
      rewrite L2_before1; clear L2_before1.
      rewrite sepcon_comm_impp.
      apply sepcon_emp1.
    + apply sepcon_emp1.
  - rewrite <- IH1, <- IH2.
    rewrite L2_before2, L2_before3.
    apply switch.
Qed.

Lemma L3 : forall m1 m2,
  m1 = m2 ->
  |-- build (PTree.elements expr m1) --> build (PTree.elements expr m2).
Proof.
  intros.
  rewrite H.
  apply provable_impp_refl.
Qed.

End Proof.

Lemma cancel_new_sound : forall tep teq,
  cancel_same tep teq ->
  |-- cancel_different tep teq ->
  |-- restore tep teq.
Proof.
  unfold restore, cancel_same, cancel_different.
  intros tep teq CS CD.
  apply L3 in CS.
  rewrite L1, CS, CD.
  apply L2.
Qed.

Ltac cancel_new' se :=
  match shallowTodeep se with
    | (?dep, ?deq, ?tbl) =>
    match shallowTotree se with
    | (?tep, ?teq) =>
    let te' := eval compute in (cancel_mark dep deq tep teq) in
    let tep' := eval compute in (fst te') in
    let teq' := eval compute in (snd te') in
    apply (cancel_new_sound tep' teq');
    [ let same := eval compute in (cancel_same tep' teq') in change same;
      reflexivity
    | let different := eval compute in (cancel_different tep' teq') in change (provable different);
    try apply provable_impp_refl
    ]
    end
  end.

Ltac cancel_new :=
    match goal with
    | [|- |-- ?se] => cancel_new' se
    end.

Section Temp.
Parameter (A B C D E F G H I J K L M N O P Q R S T U V W X Y Z: expr).

Lemma foo: forall P, P /\ P -> P.
Proof. intros. tauto. Qed.

Goal |-- (W --> T) * U --> S * V -> |-- (W --> T) * U * (V --> W) * (P * Q) * T --> T * S * V * Q * P * (V --> W).
  intros.
  cancel_new.
  auto.
  Qed.

Goal
|-- A * B * (C * D) * (E * F * (G * H)) * (I * J * K * L)
--> (I * J * (D * K) * L) * A * B * (C * H) * (E * F * G).
  intros.
  Time
  apply foo; split;
    apply foo; split;
      apply foo; split;
  cancel_new;
  auto.
  Time
  Qed.

Goal
|-- A * B * (C * D) * (E * F * (G * H)) * (I * J * K * L) *
    A * B * (C * D) * (E * F * (G * H)) * (I * J * K * L)
--> (I * J * (D * K) * L) * A * B * (C * H) * (E * F * G) *
    (I * J * (D * K) * L) * A * B * (C * H) * (E * F * G).
  intros.
  Time
  apply foo; split;
    apply foo; split;
      apply foo; split;
  cancel_new;
  auto.
  Time
  Qed.

Goal
|-- A * B * (C * D) * (E * F * (G * H)) * (I * J * K * L) *
    A * B * (C * D) * (E * F * (G * H)) * (I * J * K * L) *
    A * B * (C * D) * (E * F * (G * H)) * (I * J * K * L)
--> (I * J * (D * K) * L) * A * B * (C * H) * (E * F * G) *
    (I * J * (D * K) * L) * A * B * (C * H) * (E * F * G) *
    (I * J * (D * K) * L) * A * B * (C * H) * (E * F * G).
  intros.
  Time
  apply foo; split;
    apply foo; split;
      apply foo; split;
  cancel_new;
  auto.
  Time
  Qed.

Goal
|-- A * B * (C * D) * (E * F * (G * H)) * (I * J * K * L) *
    (M * (N * O) * P) * (Q * R * S) * T * (U * V) * W * X
--> (I * J * (D * K) * L) * A * B * (C * H) * (E * F * G) *
    (M * X * (N * W) * O) * P * Q * (T * S) * (V * R * U).
  intros.
  Time
  apply foo; split;
    apply foo; split;
      apply foo; split;
  cancel_new;
  auto.
  Time
  Qed.

Goal
|-- A * B * (C * D) * (E * F * (G * H)) * (I * J * K * L) *
    (M * (N * O) * P) * (Q * R * S) * T * (U * V) * W * X *
    (M * (N * O) * P) * (Q * R * S) * T * (U * V) * W * X *
    A * B * (C * D) * (E * F * (G * H)) * (I * J * K * L)
--> (I * J * (D * K) * L) * A * B * (C * H) * (E * F * G) *
    (M * X * (N * W) * O) * P * Q * (T * S) * (V * R * U) *
    (I * J * (D * K) * L) * A * B * (C * H) * (E * F * G) *
    (M * X * (N * W) * O) * P * Q * (T * S) * (V * R * U).
  intros.
  Time
  apply foo; split;
    apply foo; split;
      apply foo; split;
  cancel_new;
  auto.
  Time
  Qed.

Goal
|-- A * B * (C * D) * (E * F * (G * H)) * (I * J * K * L) *
    (M * (N * O) * P) * (Q * R * S) * T * (U * V) * W * X *
    A * B * (C * D) * (E * F * (G * H)) * (I * J * K * L) *
    (M * (N * O) * P) * (Q * R * S) * T * (U * V) * W * X *
    A * B * (C * D) * (E * F * (G * H)) * (I * J * K * L) *
    (M * (N * O) * P) * (Q * R * S) * T * (U * V) * W * X
--> (I * J * (D * K) * L) * A * B * (C * H) * (E * F * G) *
    (M * X * (N * W) * O) * P * Q * (T * S) * (V * R * U) *
    (M * X * (N * W) * O) * P * Q * (T * S) * (V * R * U) *
    (I * J * (D * K) * L) * A * B * (C * H) * (E * F * G) *
    (I * J * (D * K) * L) * A * B * (C * H) * (E * F * G) *
    (M * X * (N * W) * O) * P * Q * (T * S) * (V * R * U).
  intros.
  Time
  apply foo; split;
    apply foo; split;
      apply foo; split;
  cancel_new;
  auto.
  Time
  Qed.

Goal
|-- A * B * (C * D) --> M * N * (O * E) ->
|-- A * B * (C * D) * (E * F * (G * H)) * (I * J * K * L)
--> I * J * (G * E) * (F * M * N) * (O * (L * K * E) * H).
  intros.
  Time
  apply foo; split;
    apply foo; split;
      apply foo; split;
  cancel_new;
  auto.
  Time
  Qed.

Goal
|-- A * B * (C * D) * A * B * (C * D)
--> M * N * O * E * (M * N) * (O * E) ->
|-- A * B * (C * D) * (E * F * (G * H)) * (I * J * K * L) *
    A * B * (C * D) * (E * F * (G * H)) * (I * J * K * L)
--> I * J * (G * E) * (F * M * N) * (O * (L * K * E) * H) *
    I * J * (G * E) * (F * M * N) * (O * (L * K * E) * H).
  intros.
  Time
  apply foo; split;
    apply foo; split;
      apply foo; split;
  cancel_new;
  auto.
  Time
  Qed.

Goal
|-- A * B * (C * D) * A * B * (C * D) * A * B * (C * D)
--> M * N * O * (M * N) * (O * E) * E * (M * N) * (O * E) ->
|-- A * B * (C * D) * (E * F * (G * H)) * (I * J * K * L) *
    A * B * (C * D) * (E * F * (G * H)) * (I * J * K * L) *
    A * B * (C * D) * (E * F * (G * H)) * (I * J * K * L)
--> I * J * (G * E) * (F * M * N) * (O * (L * K * E) * H) *
    I * J * (G * E) * (F * M * N) * (O * (L * K * E) * H) *
    I * J * (G * E) * (F * M * N) * (O * (L * K * E) * H).
  intros.
  Time
  apply foo; split;
    apply foo; split;
      apply foo; split;
  cancel_new;
  auto.
  Time
  Qed.

Goal
|-- A * B * (C * D) * (E * F * (G * H))
--> S * T * Q * X * U * (V * W) * R ->
|-- A * B * (C * D) * (E * F * (G * H)) * (I * J * K * L) * (M * (N * O) * P)
--> (P * (I * J * (S * T)) * Q) * X * (U * M * N) * (O * (L * K * V) * W) * R.
  intros.
  Time
  apply foo; split;
    apply foo; split;
      apply foo; split;
  cancel_new;
  auto.
  Time
  Qed.

Goal
|-- A * B * (C * D) * (E * F * (G * H)) * A * B * (C * D) * (E * F * (G * H))
--> S * T * Q * X * U * (V * W) * R * (S * T * Q) * X * U * (V * W) * R ->
|-- A * B * (C * D) * (E * F * (G * H)) * (I * J * K * L) * (M * (N * O) * P) *
    A * B * (C * D) * (E * F * (G * H)) * (I * J * K * L) * (M * (N * O) * P)
--> (P * (I * J * (S * T)) * Q) * X * (U * M * N) * (O * (L * K * V) * W) * R *
    (P * (I * J * (S * T)) * Q) * X * (U * M * N) * (O * (L * K * V) * W) * R.
  intros.
  Time
  apply foo; split;
    apply foo; split;
      apply foo; split;
  cancel_new;
  auto.
  Time
  Qed.

Goal
|-- A * B * (C * D) * (E * F * (G * H)) * A * B * (C * D) * (E * F * (G * H)) * A * B * (C * D) * (E * F * (G * H))
--> S * T * Q * X * U * (V * W) * R * (S * T * Q) * X * U * (V * W) * R * (S * T * Q) * X * U * (V * W) * R ->
|-- A * B * (C * D) * (E * F * (G * H)) * (I * J * K * L) * (M * (N * O) * P) *
    A * B * (C * D) * (E * F * (G * H)) * (I * J * K * L) * (M * (N * O) * P) *
    A * B * (C * D) * (E * F * (G * H)) * (I * J * K * L) * (M * (N * O) * P)
--> (P * (I * J * (S * T)) * Q) * X * (U * M * N) * (O * (L * K * V) * W) * R *
    (P * (I * J * (S * T)) * Q) * X * (U * M * N) * (O * (L * K * V) * W) * R *
    (P * (I * J * (S * T)) * Q) * X * (U * M * N) * (O * (L * K * V) * W) * R.
  intros.
  Time
  apply foo; split;
    apply foo; split;
      apply foo; split;
  cancel_new;
  auto.
  Time
  Qed.

End Temp.


(** * Finite Interaction Tree *)

(* begin hide *)
From ITree Require Import
     ITree
     Basics.Tacs
     Eq.Eqit
     Interp.TranslateFacts
     Leaf.
From ITree.Events Require Import Nondeterminism Exception. (* For counterexamples *)

From Paco Require Import paco.
From Coq Require Import Morphisms Basics Program.Equality.
Import ITree.
Import ITreeNotations.
Import LeafNotations.
(* end hide *)

(** ** Finite computations as Interaction Trees

  We provide two predicates capturing finiteness of an [itree]:
  - [all_finite t] expresses that [t] is finite along all branches
  - [any_finite t] expresses that [t] admits a finite branch

  In each case, we prove:
  - Smart constructors and inversion lemmas
  - Closure under [eutt R] (in the case of [Leaf], we get another value related by R) and Proper instances for [eutt eq]
  - Forward and backward proof rules for [bind]s
  We additionally provide:
  - Particular cases of non-interactive computations and [spin]
  - Counterexamples to properties that could be expected at first glance
*)

(** Definitions *)

(** all_finite t
  The tree admits exclusively finite branches *)
Inductive all_finite {E} {A: Type} : itree E A -> Prop :=
 | all_finiteRet: forall a t,
    observe t = RetF a ->
   all_finite t
 | all_finiteTau: forall t u,
   observe t = TauF u ->
   all_finite u ->
   all_finite t
 | all_finiteVis: forall {X} (e: E X) t k,
   observe t = VisF e k ->
   (forall x, all_finite (k x)) ->
   all_finite t
.
#[global] Hint Constructors all_finite : itree.

(** any_finite t
  The tree admits at least one finite branch *)
Inductive any_finite {E} {A: Type} : itree E A -> Prop :=
 | any_finiteRet: forall a t,
    observe t = RetF a ->
   any_finite t
 | any_finiteTau: forall t u,
   observe t = TauF u ->
   any_finite u ->
   any_finite t
 | any_finiteVis: forall {X} (e: E X) t k x,
   observe t = VisF e k ->
   any_finite (k x) ->
   any_finite t
.
#[global] Hint Constructors any_finite : itree.

(** Smart constructors *)

(* all_finite *)
Lemma all_finite_Ret : forall E R a,
  @all_finite E R (Ret a).
Proof.
  intros; econstructor 1; reflexivity.
Qed.
#[global] Hint Resolve all_finite_Ret : itree.

Lemma all_finite_Tau : forall E R t,
  all_finite t ->
  @all_finite E R (Tau t).
Proof.
  intros; econstructor 2; [reflexivity | eauto].
Qed.
#[global] Hint Resolve all_finite_Tau : itree.

Lemma all_finite_Vis : forall E X R (e : E X) k,
  (forall x, all_finite (k x)) ->
  @all_finite E R (Vis e k).
Proof.
  intros; econstructor 3; [reflexivity | eauto].
Qed.
#[global] Hint Resolve all_finite_Vis : itree.

Lemma all_finite_trigger : forall E R (e: E R),
  all_finite (ITree.trigger e).
Proof.
  intros. apply all_finite_Vis. auto with itree.
Qed.
#[global] Hint Extern 1 (all_finite (trigger _)) => apply all_finite_trigger : itree.

(* any_finite *)
Lemma any_finite_Ret : forall E R a,
  @any_finite E R (Ret a).
Proof.
  intros; econstructor 1; reflexivity.
Qed.
#[global] Hint Resolve any_finite_Ret : itree.

Lemma any_finite_Tau : forall E R t,
  any_finite t ->
  @any_finite E R (Tau t).
Proof.
  intros; econstructor 2; [reflexivity | eauto].
Qed.
#[global] Hint Resolve any_finite_Tau : itree.

Lemma any_finite_Vis : forall E X R (e : E X) k x,
  any_finite (k x) ->
  @any_finite E R (Vis e k).
Proof.
  intros; econstructor 3; [reflexivity | eauto].
Qed.
#[global] Hint Resolve any_finite_Vis : itree.

Lemma any_finite_trigger : forall E R (e: E R) (r: R),
  any_finite (ITree.trigger e).
Proof.
  intros. apply any_finite_Vis with (x := r). auto with itree.
Qed.
#[global] Hint Extern 1 (any_finite (trigger _)) => apply any_finite_trigger : itree.

(** Inversion lemmas *)

(* all_finite *)
Lemma all_finite_Tau_inv : forall E R t,
  @all_finite E R (Tau t) ->
  all_finite t.
Proof.
  intros * FIN; inv FIN; cbn in *; congruence.
Qed.

Lemma all_finite_Vis_inv : forall E X R (e : E X) k,
  @all_finite E R (Vis e k) ->
  forall x, all_finite (k x).
Proof.
  intros * FIN x; inv FIN; cbn in *; try congruence.
  revert H0.
  refine (match H in _ = u return match u with VisF e0 k0 => _ | _ => False end with eq_refl => _ end).
  auto.
Qed.

(* any_finite *)
Lemma any_finite_Tau_inv : forall E R t,
  @any_finite E R (Tau t) ->
  any_finite t.
Proof.
  intros * FIN; inv FIN; cbn in *; congruence.
Qed.

Lemma any_finite_Vis_inv : forall E X R (e : E X) k,
  @any_finite E R (Vis e k) ->
  exists x, any_finite (k x).
Proof.
  intros * FIN; inv FIN; cbn in *; try congruence.
  revert x H0.
  refine (match H in _ = u return match u with VisF e0 k0 => _ | _ => False end with eq_refl => _ end).
  eauto.
Qed.

(** Closure under [eutt]

  General asymetric lemmas for [eutt R], and [Proper]
  instances for [eutt eq]. *)

(* all_finite *)
Lemma all_finite_eutt_l {E A B R}:
  forall (t : itree E A) (u : itree E B),
  eutt R t u ->
  all_finite t ->
  all_finite u.
Proof.
  intros * EQ FIN;
  revert u EQ.
  induction FIN; intros u2 EQ.
  - punfold EQ.
    red in EQ; rewrite H in EQ; clear H.
    remember (RetF a); genobs u2 ou.
    hinduction EQ before R; intros; try discriminate; eauto with itree.
  - punfold EQ; red in EQ; rewrite H in EQ; clear H.
    remember (TauF u); genobs u2 ou2.
    hinduction EQ before R; intros; try discriminate; pclearbot; inv Heqi; eauto with itree.
  - punfold EQ; red in EQ; rewrite H in EQ; clear H.
    remember (VisF e k); genobs u2 ou2.
    hinduction EQ before R; intros; try discriminate; pclearbot.
    + revert H0 H1.
      refine (match Heqi in _ = u return match u with VisF e0 k0 => _ | _ => False end with eq_refl => _ end).
      eauto with itree.
    + inv Heqi; eauto with itree.
Qed.

Lemma all_finite_eutt_r {E A B R}:
  forall (t : itree E A) (u : itree E B),
  eutt R t u ->
  all_finite u ->
  all_finite t.
Proof.
  intros * EQ. apply eqit_flip in EQ. revert EQ. apply all_finite_eutt_l.
Qed.

#[global] Instance all_finite_eutt {E A R}:
  Proper (eutt R ==> iff) (@all_finite E A).
Proof.
  repeat intro; split.
  - eapply all_finite_eutt_l; eauto.
  - eapply all_finite_eutt_r; eauto.
Qed.

(* any_finite *)
Lemma any_finite_eutt_l {E A B R}:
  forall (t : itree E A) (u : itree E B),
  eutt R t u ->
  any_finite t ->
  any_finite u.
Proof.
  intros * EQ FIN;
  revert u EQ.
  induction FIN; intros u2 EQ.
  - punfold EQ.
    red in EQ; rewrite H in EQ; clear H.
    remember (RetF a); genobs u2 ou.
    hinduction EQ before R; intros; try discriminate; eauto with itree.
  - punfold EQ; red in EQ; rewrite H in EQ; clear H.
    remember (TauF u); genobs u2 ou2.
    hinduction EQ before R; intros; try discriminate; pclearbot; inv Heqi; eauto with itree.
  - punfold EQ; red in EQ; rewrite H in EQ; clear H.
    remember (VisF e k); genobs u2 ou2.
    hinduction EQ before R; intros; try discriminate; pclearbot.
    + revert x FIN IHFIN.
      refine (match Heqi in _ = u return match u with VisF e0 k0 => _ | _ => False end with eq_refl => _ end).
      eauto with itree.
    + inv Heqi; eauto with itree.
Qed.

Lemma any_finite_eutt_r {E A B R}:
  forall (t : itree E A) (u : itree E B),
  eutt R t u ->
  any_finite u ->
  any_finite t.
Proof.
  intros * EQ. apply eqit_flip in EQ. revert EQ. apply any_finite_eutt_l.
Qed.

#[global] Instance any_finite_eutt {E A R}:
  Proper (eutt R ==> iff) (@any_finite E A).
Proof.
  split.
  eapply any_finite_eutt_l; eauto.
  eapply any_finite_eutt_r; eauto.
Qed.

(** Compatibility with [bind], forward and backward *)

(* all_finite *)

(* Only the reachable branches, as captured by the
    leaves in the image of the prefix, need to be
   finite in the continuation *)
Lemma all_finite_bind : forall {E R S}
  (t : itree E R) (k : R -> itree E S),
  all_finite t ->
  (forall x, x ∈ t -> all_finite (k x)) ->
  all_finite (t >>= k).
Proof.
  intros * FIN; induction FIN; intros FINs;
    rewrite unfold_bind, H; eauto with itree.
Qed.

Lemma all_finite_bind_weak : forall {E R S}
  (t : itree E R) (k : R -> itree E S),
  all_finite t ->
  (forall x, all_finite (k x)) ->
  all_finite (t >>= k).
Proof.
  intros; apply all_finite_bind; auto.
Qed.

(* We only get finiteness of the reachable branches *)
Lemma all_finite_bind_inv : forall {E R S}
  (t : itree E R) (k : R -> itree E S),
  all_finite (t >>= k) ->
  (all_finite t /\ forall x, x ∈ t -> all_finite (k x)).
Proof.
  intros E R S.
  cut (forall (u : itree E S), all_finite u ->
       forall (t : itree E R) k, u ≈ t >>= k ->
        (all_finite t /\ forall x, x ∈ t -> all_finite (k x))).
  intros LEM * FIN; eapply LEM; eauto; reflexivity.
  induction 1; intros * EQ.
  - rewrite (itree_eta t), H in EQ; clear H t.
    symmetry in EQ; apply eqit_inv_bind_ret in EQ as (? & EQt & EQk).
    rewrite EQt; split; auto with itree.
    intros z IN.
    rewrite EQt in IN; apply Leaf_Ret_inv in IN; subst.
    rewrite EQk; auto with itree.
  - rewrite (itree_eta t), H in EQ; clear H t.
    rewrite tau_eutt in EQ.
    eauto.
  - rewrite (itree_eta t), H in EQ; clear H t.
    symmetry in EQ; apply eutt_inv_bind_vis in EQ.
    destruct EQ as [(kca & EQ & EQk) | (?a & EQ & EQk)].
    + rewrite EQ.
      split.
      apply all_finite_Vis.
      intros ?; eapply H1; symmetry; eauto.
      intros x IN.
      rewrite EQ in IN.
      apply Leaf_Vis_inv in IN as (y & IN).
      edestruct H1 as (_ & H).
      symmetry in EQk; exact (EQk y).
      apply H, IN.
    + rewrite EQ; split; auto with itree.
      intros y IN.
      rewrite EQ in IN; apply Leaf_Ret_inv in IN; subst.
      rewrite EQk. eauto with itree.
Qed.

Lemma all_finite_bind_inv_left : forall {E R S}
  (t : itree E R) (k : R -> itree E S),
  all_finite (t >>= k) ->
  all_finite t.
Proof.
  intros; eapply all_finite_bind_inv; eauto.
Qed.

(* any_finite *)

(* For a [bind] to have a finite branch, we need to
   exhibit a finite branch in [t] that _continues_
   into a finite branch in [k]. We capture this
   continuity using [Leaf].
*)
Lemma any_finite_bind : forall {E R S}
  (t : itree E R) (k : R -> itree E S) x,
  x ∈ t ->
  any_finite (k x) ->
  any_finite (t >>= k).
Proof.
  intros * IN FIN; induction IN.
  - rewrite (itree_eta t), H, bind_ret_l; auto.
  - rewrite unfold_bind, H, tau_eutt; eauto.
  - rewrite unfold_bind, H.
    eapply any_finite_Vis; eauto.
Qed.

(* We get the additional guarantee that the
   finite branch in the continuation comes
   from a point in the image of the prefix.  *)
Lemma any_finite_bind_inv : forall {E R S}
  (t : itree E R) (k : R -> itree E S),
  any_finite (t >>= k) ->
  (any_finite t /\
   exists x, x ∈ t /\ any_finite (k x)).
Proof.
  intros * FIN;
  remember (ITree.bind t k) as u.
  revert t k Hequ.
  induction FIN; intros t' k' ->; rename t' into t.
  - unfold observe in H; cbn in H.
    desobs t EQ; cbn in *; try congruence.
    split; eauto with itree.
  - unfold observe in H; cbn in H.
    desobs t EQ; cbn in *; try congruence.
    split; eauto with itree.
    inversion H; clear H; symmetry in H1.
    edestruct IHFIN as (? & ? & ? & ?).
    apply H1.
    split; eauto with itree.
  - unfold observe in H; cbn in H.
    desobs t EQ; cbn in *; try congruence.
    split; eauto with itree.
    revert x FIN IHFIN.
    refine (match H in _ = u return match u with VisF e0 k0 => _ | _ => False end with eq_refl => _ end).
    intros.
    edestruct IHFIN as (? & ? & ? & ?); [ reflexivity | ].
    split; eauto with itree.
Qed.

Lemma any_finite_bind_inv_weak : forall {E R S}
  (t : itree E R) (k : R -> itree E S),
  any_finite (t >>= k) ->
  (any_finite t /\
   exists x, any_finite (k x)).
Proof.
  intros * FIN; apply any_finite_bind_inv in FIN as (?&?&?&?).
  split; eauto.
Qed.

Lemma any_finite_bind_inv_left : forall {E R S}
  (t : itree E R) (k : R -> itree E S),
  any_finite (t >>= k) ->
  any_finite t.
Proof.
  intros; eapply any_finite_bind_inv; eauto.
Qed.

(** * [any_finite] is non-empty [Leaf] *)
Lemma Leaf_finite : forall E R (t : itree E R) x,
  x ∈ t ->
  any_finite t.
Proof.
  intros * FIN; induction FIN; rewrite itree_eta, H; eauto with itree.
Qed.

Lemma finite_Leaf : forall E R (t : itree E R),
  any_finite t ->
  exists x, x ∈ t.
Proof.
  intros * FIN; induction FIN.
  1: exists a; rewrite itree_eta, H; eauto with itree.
  all: destruct IHFIN; eauto with itree.
Qed.

(** Degenerate case of non-interactive computations
  In the absence of interaction ([E = void1]), [all_finite] and [any_finite] collapse:
  we indeed both know that the computation is deterministic,
  and that it cannot fail, excluding hence any subtletly.
  The image is either empty, or a singleton.
*)

Lemma finite_non_interactive : forall X (t: itree void1 X),
  all_finite t <-> any_finite t.
Proof.
  split; induction 1; cbn in *; first [now destruct e | eauto with itree].
Qed.

Lemma finite_leaf_non_interactive : forall X (t: itree void1 X),
  all_finite t <-> (exists x, x ∈ t).
Proof.
  intros *.
  rewrite finite_non_interactive.
  split; [ eauto using finite_Leaf | intros []; eauto using Leaf_finite ].
Qed.

Lemma Leaf_non_interactive_singleton : forall X (t: itree void1 X) a b,
  a ∈ t -> b ∈ t -> a = b.
Proof.
  intros * IN; revert b; induction IN; intros * IN'.
  - rewrite itree_eta, H in IN'; apply Leaf_Ret_inv in IN'; auto.
  - rewrite itree_eta, H, tau_eutt in IN'; eauto.
  - inv e.
Qed.

(** [translate] does not affect termination *)

Lemma all_finite_translate {E F R}: forall (f: E ~> F) (t: itree E R),
  all_finite t ->
  all_finite (translate f t).
Proof.
  intros *; induction 1; rewrite unfold_translate, H; cbn.
  - apply all_finite_Ret.
  - apply all_finite_Tau. auto.
  - apply all_finite_Vis. auto.
Qed.

Lemma any_finite_translate {E F R}: forall (f: E ~> F) (t: itree E R),
  any_finite t ->
  any_finite (translate f t).
Proof.
  intros *. induction 1; rewrite unfold_translate, H; cbn.
  - apply any_finite_Ret.
  - apply any_finite_Tau. auto.
  - eapply any_finite_Vis. eauto.
Qed.

(** [spin] is not finite, in any sense of the term *)
Lemma spin_not_all_finite: forall E X,
  ~ all_finite (@spin E X).
Proof.
  intros * FIN; remember spin as t; revert Heqt; induction FIN; intros ->;
  unfold observe in H; cbn in H; inv H; auto.
Qed.

Lemma spin_not_any_finite: forall E X,
  ~ any_finite (@spin E X).
Proof.
  intros * FIN; remember spin as t; revert Heqt; induction FIN; intros ->;
  unfold observe in H; cbn in H; inv H; auto.
Qed.

Lemma spin_empty_Leaf: forall E X x,
  ~ x ∈ (@spin E X).
Proof.
  intros * IN; apply Leaf_finite, spin_not_any_finite in IN; auto.
Qed.

Module Counterexamples.

(** * Counterexamples *)

(** Counterexamples to statements that could be expected to be true at firt glance. *)

(** [all_finite] does _not_ entail [any_finite].

  Indeed, [any_finite] guarantees that a finite branch exists,
  where [all_finite] enforces that no infinite branch exists.
  If the computation has no branch, [all_finite] can be satisfied
  while [any_finite] is not.
  The [fail] computation is the simplest counterexample *)

  Notation fail := (@throw unit (exceptE _) _ unit tt).

  Fact fail_all_finite: all_finite fail.
  Proof.
    unfold fail.
    apply all_finite_Vis; intros [].
  Qed.

  Fact fail_not_any_finite: ~ any_finite fail.
  Proof.
    unfold fail; intros FIN.
    apply any_finite_Vis_inv in FIN as ([] & ? & ?).
  Qed.

(** The [bind] proof rule for [any_finite] _must_ quantify
    on the [Leaf]
    It could be tempting to hope for a simpler lemma than
    [any_finite], simply ensure diamond on the prefix and
    at a point in the continuation:
    any_finite t ->
    any_finite (k x) ->
    any_finite (t >>= k)
    It is however primordial to ensure that the finite path exhibited by k
    is reachable for t, as illustrated in the following *)

  Definition t : itree nondetE bool :=
    or (Ret true) spin.

  Definition k : bool -> itree nondetE unit :=
    fun b => if b then spin else Ret tt.

  Lemma spin_not_any_finite: forall E X,
    ~ any_finite (@spin E X).
  Proof.
    intros * FIN; remember spin as t; revert Heqt; induction FIN; intros ->;
    unfold observe in H; cbn in H; inv H; auto.
  Qed.

  Fact DFt : any_finite t.
  Proof.
    apply any_finite_Vis with true; auto with itree.
  Qed.

  Fact DFk : any_finite (k false).
  Proof.
    cbn; auto with itree.
  Qed.

  Fact NotDFtk: ~ any_finite (t >>= k).
  Proof.
  intros abs.
  apply any_finite_bind_inv in abs as (FINt & b & IN & FINk).
  destruct b; cbn in *.
  - eapply spin_not_any_finite; eauto.
  - unfold t in IN.
    clear FINk FINt.
    inv IN; cbn in *; try congruence.
    dependent induction H.
    destruct x; cbn in *.
    apply Leaf_Ret_inv in H0; congruence.
    apply Leaf_finite in H0.
    eapply spin_not_any_finite; eauto.
  Qed.

End Counterexamples.


Require Import String.
Require Export Coq.Lists.List.
Require Export Coq.Arith.Compare_dec.
Require Export Coq.Arith.EqNat.

(* Add a single element to the end of the list *)
Fixpoint snoc {A : Type} (x : A) (xx : list A): list A :=
  match xx with
  | nil => x :: nil
  | y :: xs' => y :: snoc x xs'
  end.

(* Get an indexed element from a list, starting from 0.
   This is like the Coq 'nth' function, but returns an option instead
   of a provided default value. Using an option is useful when we simply
   want to determine whether some element is in the list, but don't
   need the actual value *)
Fixpoint get {A : Type} (i : nat) (e : list A) {struct e}:
option A :=
  match e, i with
  | x :: _, O => Some x
  | _ :: xs, S i' => get i' xs
  | _, _ => None
  end.

(** Remove all instances of a given string [s] from a list of strings [l]. *)
Definition rm (s : string) (l : list string) := remove string_dec s l.

Fixpoint is_in (s : string) (l : list string): bool :=
  match l with
  | nil => false
  | x :: rest => if string_dec s x then true else is_in s rest
  end.

(** Appends [l2] to [l1] removing duplicates from [l2]. *)
Fixpoint append (l1 : list string) (l2 : list string):
list string :=
  match l2 with
  | nil => l1
  | x :: tl2 => append (if is_in x l1 then l1 else snoc x l1) tl2
  end.

Open Scope string_scope.
Example append_ex1 :
  append (cons "a" (cons "b" nil)) (cons "x" (cons "y" nil)) =
  "a" :: "b" :: "x" :: "y" :: nil.
Proof. reflexivity. Qed.

Example append_ex2 :
  append (cons "a" (cons "b" nil)) (cons "x" (cons "b" nil)) =
  "a" :: "b" :: "x" :: nil.
Proof. reflexivity. Qed.

Example append_ex3 :
  append (cons "a" (cons "b" nil)) (cons "a" (cons "y" nil)) =
  "a" :: "b" :: "y" :: nil.
Proof. reflexivity. Qed.
Close Scope string_scope.

Require String. Open Scope string_scope.

Ltac move_to_top x :=
  match reverse goal with
  | H:_ |- _ => try move x after H
  end.

Tactic Notation
  "assert_eq" ident(x) constr(v) :=
  let H := fresh in
  assert (x = v) as H by reflexivity; clear H.

Tactic Notation "Case_aux" ident(x) constr(name) :=
  first [
    set (x := name); move_to_top x
  | assert_eq x name; move_to_top x
  | fail 1 "because we are working on a different case" ].

Tactic Notation "Case" constr(name) := Case_aux Case name.
Tactic Notation "SCase" constr(name) := Case_aux SCase name.
Tactic Notation "SSCase" constr(name) := Case_aux SSCase name.
Tactic Notation "SSSCase" constr(name) := Case_aux SSSCase name.
Tactic Notation "SSSSCase" constr(name) := Case_aux SSSSCase name.
Tactic Notation "SSSSSCase" constr(name) := Case_aux SSSSSCase name.
Tactic Notation "SSSSSSCase" constr(name) := Case_aux SSSSSSCase name.
Tactic Notation "SSSSSSSCase" constr(name) := Case_aux SSSSSSSCase name.

(**
Binary relation utilities, specifically the [multi] closure of a relation.
*)
Definition relation (X : Type) := X -> X -> Prop.

Definition deterministic {X : Type} (R : relation X) :=
  forall x y1 y2 : X, R x y1 -> R x y2 -> y1 = y2.

Inductive multi (X : Type) (R : relation X) : X -> X -> Prop :=
  | multi_refl : forall x : X, multi X R x x
  | multi_step : forall x y z : X, R x y -> multi X R y z -> multi X R x z.
Implicit Arguments  multi [[X]].

Tactic Notation "multi_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "multi_refl" | Case_aux c "multi_step" ].

Theorem multi_R :
 forall (X : Type) (R : relation X) (x y : X), R x y -> multi R x y.
Proof.
  intros X R x y r.
  apply multi_step with y. apply r. apply multi_refl.   Qed.

Theorem multi_trans :
 forall (X : Type) (R : relation X) (x y z : X),
 multi R x y -> multi R y z -> multi R x z.
Proof.
  intuition.
  induction H.
  - assumption.
  - apply multi_step with y. assumption.
    apply IHmulti. assumption.
Qed.


Require Import List Relation_Operators Operators_Properties Lia.
Import ListNotations.

Require Import Undecidability.StringRewriting.Reductions.CM2_HALT_to_SSTS01.SR2ab.
Require Import Undecidability.CounterMachines.CM2.

Require Import Undecidability.StringRewriting.Util.List_facts.
Require Import Undecidability.StringRewriting.Reductions.CM2_HALT_to_SSTS01.SR2ab_facts.
Require Import Undecidability.CounterMachines.Util.Facts Undecidability.CounterMachines.Util.CM2_facts.

Require Import ssreflect ssrbool ssrfun.

Set Default Proof Using "Type".
Set Default Goal Selector "!".

Local Arguments rt_trans {A R x y z}.
Local Arguments in_combine_l {A B l l' x y}.

Module Facts.

Lemma iter_plus {X: Type} {f: X -> X} {x: X} {n m: nat} :
  Nat.iter (n + m) f x = Nat.iter n f (Nat.iter m f x).
Proof. by rewrite /Nat.iter nat_rect_plus. Qed.

Lemma nth_error_Some_in_combine {X: Type} {l: list X} {i x}:
  nth_error l i = Some x ->
  In (i, x) (combine (seq 0 (length l)) l).
Proof.
  move Hk: (0) => k Hi. have ->: (i = i + k) by lia.
  elim: l i k {Hk} Hi; first by case.
  move=> y l IH [|i] k.
  - move=> /= [<-]. by left.
  - move=> /IH {}IH /=. right. by have ->: (S (i + k) = i + S k) by lia.
Qed.

Lemma inv_nth_error_Some_in_combine {X: Type} {l: list X} {i x}:
  In (i, x) (combine (seq 0 (length l)) l) -> nth_error l i = Some x.
Proof.
  move Hk: (0) => k. rewrite [in (_, _)](ltac:(lia) : (i = i + k)).
  elim: l i k {Hk}; first by case.
  move=> y l IH i k /= [].
  - move=> [? ->]. by have ->: i = 0 by lia.
  - move: i => [|i].
    + move=> /in_combine_l /in_seq. by lia.
    + have ->: S i + k = i + S k by lia.
      by move=> /IH.
Qed.
End Facts.

Module Argument.
Import Facts.
Local Arguments List.app : simpl never.
Local Arguments Nat.sub : simpl never.
Local Arguments repeat : simpl never.
Local Arguments app_inj_tail {A x y a b}.

Section Reduction.
(* given two-counter machine *)
Context (cm : Cm2).

Fixpoint cm_steps n x :=
  match n with
  | 0 => x
  | S n => if CM2.step cm x is Some y then cm_steps n y else x
  end.

Local Notation sb := ((0, @None nat)). (* blank *)
Local Notation sl := ((1, @None nat)). (* left marker *)
Local Notation sr := ((2, @None nat)). (* right marker *)
Local Notation sm := ((3, @None nat)). (* middle marker *)

Local Notation sz := ((4, @None nat)). (* 0 *)
Local Notation so := ((5, @Some nat 0)). (* 1 *)
Local Notation st := ((6, @None nat)). (* temporary marker *)

Local Notation sb' p := ((0, @Some nat p)). (* blank *)
Local Notation sl' p := ((1, @Some nat p)). (* left marker *)
Local Notation sr' p := ((2, @Some nat p)). (* right marker *)
Local Notation sm' p := ((3, @Some nat p)). (* middle marker *)

Definition states := map (fun i => if i is dec _ q then q else 0) cm.
Definition sum : list nat -> nat := fold_right Nat.add 0.

Definition state_bound := 1 + length cm + sum states.

Lemma state_boundP {p i} : nth_error cm p = Some i ->
  (if i is dec _ q then q else 0) + 1 + p < state_bound.
Proof.
  rewrite /state_bound /states.
  elim: (cm) p; first by case.
  move=> ? l IH [|p] /= => [[->] | /IH]; last by lia.
  by case: (i); lia.
Qed.

(* encode instruction i at position n *)
Definition enc_Instruction (ni: (nat * Instruction)) : Srs :=
  match ni with
  | (p, inc b) => if b then [((sr' p, sz), (sb, sr' (S p)))] else [((sz, sl' p), (sl' (S p), sb))]
  | (p, dec b q) =>
      if b then [((sm, sr' p), (sm, sr' (S p))); ((sb, sr' p), (sr' q, sz))]
      else [((sl' p, sm), (sl' (S p), sm)); ((sl' p, sb), (sz, sl' q))]
  end.

(* constructed string rewriting system *)
Definition srs : Srs :=
  (* initialization *)
  [((sz, sz), (st, sr)); (* 00 -> tr *)
   ((sz, st), (sl' 0, sm)) (* 0t -> l_0 m *)] ++
  (* simulation *)
  flat_map enc_Instruction (combine (seq 0 (length cm)) cm) ++
  (* state movement to the right *)
  flat_map (fun p => [
    ((sl' p, sb), (sl, sb' p)); ((sl' p, sm), (sl, sm' p));
    ((sb' p, sb), (sb, sb' p)); ((sb' p, sm), (sb, sm' p)); ((sb' p, sr), (sb, sr' p));
    ((sm' p, sb), (sm, sb' p)); ((sm' p, sr), (sm, sr' p))]) (seq 0 state_bound) ++
  (* state movement to the left *)
  flat_map (fun p => [
    ((sb, sr' p), (sb' p, sr)); ((sm, sr' p), (sm' p, sr));
    ((sb, sb' p), (sb' p, sb)); ((sm, sb' p), (sm' p, sb)); ((sl, sb' p), (sl' p, sb));
    ((sb, sm' p), (sb' p, sm)); ((sl, sm' p), (sl' p, sm))]) (seq 0 state_bound) ++
  (* finalization *)
  map (fun p => ((sz, sl' p), (so, so))) (seq (length cm) (state_bound - length cm)) ++
  [((sz, so), (so, so)); ((so, sb), (so, so)); ((so, sm), (so, so));
   ((so, sr), (so, so)); ((so, sz), (so, so))].

(* initialization, simulation, finalization *)
Inductive srs_spec (a b c d: Symbol) : Prop :=
  | srs_i0 : ((sz, sz), (st, sr)) = ((a, b), (c, d)) -> srs_spec a b c d
  | srs_i1 : ((sz, st), (sl' 0, sm)) = ((a, b), (c, d)) -> srs_spec a b c d
  | srs_sim0 {p} : ((sr' p, sz), (sb, sr' (S p))) = ((a, b), (c, d)) -> nth_error cm p = Some (inc true) -> srs_spec a b c d
  | srs_sim1 {p} : ((sz, sl' p), (sl' (S p), sb)) = ((a, b), (c, d)) -> nth_error cm p = Some (inc false) -> srs_spec a b c d
  | srs_sim2 {p q} : ((sm, sr' p), (sm, sr' (S p))) = ((a, b), (c, d)) -> nth_error cm p = Some (dec true q) -> srs_spec a b c d
  | srs_sim3 {p q} : ((sb, sr' p), (sr' q, sz))= ((a, b), (c, d)) -> nth_error cm p = Some (dec true q) -> srs_spec a b c d
  | srs_sim4 {p q} : ((sl' p, sm), (sl' (S p), sm)) = ((a, b), (c, d)) -> nth_error cm p = Some (dec false q) -> srs_spec a b c d
  | srs_sim5 {p q} : ((sl' p, sb), (sz, sl' q)) = ((a, b), (c, d)) -> nth_error cm p = Some (dec false q) -> srs_spec a b c d
  | srs_fin0 {p} : ((sz, sl' p), (so, so)) = ((a, b), (c, d)) -> length cm <= p < state_bound -> srs_spec a b c d
  | srs_fin1 : ((sz, so), (so, so)) = ((a, b), (c, d)) -> srs_spec a b c d
  | srs_fin2 : ((so, sb), (so, so)) = ((a, b), (c, d)) -> srs_spec a b c d
  | srs_fin3 : ((so, sm), (so, so)) = ((a, b), (c, d)) -> srs_spec a b c d
  | srs_fin4 : ((so, sr), (so, so)) = ((a, b), (c, d)) -> srs_spec a b c d
  | srs_fin5 : ((so, sz), (so, so)) = ((a, b), (c, d)) -> srs_spec a b c d.

(* opaque state movement *)
Inductive srs_mlr_spec (a b c d: Symbol) : Prop :=
  | srs_mr0 {p} : ((sl' p, sb), (sl, sb' p)) = ((a, b), (c, d)) -> p < state_bound -> srs_mlr_spec a b c d
  | srs_mr1 {p} : ((sl' p, sm), (sl, sm' p)) = ((a, b), (c, d)) -> p < state_bound -> srs_mlr_spec a b c d
  | srs_mr2 {p} : ((sb' p, sb), (sb, sb' p)) = ((a, b), (c, d)) -> p < state_bound -> srs_mlr_spec a b c d
  | srs_mr3 {p} : ((sb' p, sm), (sb, sm' p)) = ((a, b), (c, d)) -> p < state_bound -> srs_mlr_spec a b c d
  | srs_mr4 {p} : ((sb' p, sr), (sb, sr' p)) = ((a, b), (c, d)) -> p < state_bound -> srs_mlr_spec a b c d
  | srs_mr5 {p} : ((sm' p, sb), (sm, sb' p)) = ((a, b), (c, d)) -> p < state_bound -> srs_mlr_spec a b c d
  | srs_mr6 {p} : ((sm' p, sr), (sm, sr' p)) = ((a, b), (c, d)) -> p < state_bound -> srs_mlr_spec a b c d
  | srs_ml0 {p} : ((sb, sr' p), (sb' p, sr)) = ((a, b), (c, d)) -> p < state_bound -> srs_mlr_spec a b c d
  | srs_ml1 {p} : ((sm, sr' p), (sm' p, sr)) = ((a, b), (c, d)) -> p < state_bound -> srs_mlr_spec a b c d
  | srs_ml2 {p} : ((sb, sb' p), (sb' p, sb)) = ((a, b), (c, d)) -> p < state_bound -> srs_mlr_spec a b c d
  | srs_ml3 {p} : ((sm, sb' p), (sm' p, sb)) = ((a, b), (c, d)) -> p < state_bound -> srs_mlr_spec a b c d
  | srs_ml4 {p} : ((sl, sb' p), (sl' p, sb)) = ((a, b), (c, d)) -> p < state_bound -> srs_mlr_spec a b c d
  | srs_ml5 {p} : ((sb, sm' p), (sb' p, sm)) = ((a, b), (c, d)) -> p < state_bound -> srs_mlr_spec a b c d
  | srs_ml6 {p} : ((sl, sm' p), (sl' p, sm)) = ((a, b), (c, d)) -> p < state_bound -> srs_mlr_spec a b c d.

Lemma srs_specI a b c d : In ((a, b), (c, d)) srs -> srs_spec a b c d \/ srs_mlr_spec a b c d.
Proof.
  rewrite /srs. case /in_app_iff.
  { firstorder (by eauto using srs_spec with nocore). }
  case /in_app_iff.
  { move=> /in_flat_map [[? i]] [/inv_nth_error_Some_in_combine].
    move: i => [] [] > /=; firstorder (by eauto using srs_spec with nocore). }
  case /in_app_iff.
  { move=> /in_flat_map [?] [/in_seq] [_ ?].
    firstorder (by eauto using srs_mlr_spec with nocore). }
  case /in_app_iff.
  { move=> /in_flat_map [?] [/in_seq] [_ ?].
    firstorder (by eauto using srs_mlr_spec with nocore). }
  case /in_app_iff.
  { move=> /in_map_iff [?] [?] /in_seq H. left.
    apply: srs_fin0; first by eassumption.
    move: H. rewrite /state_bound. by lia. }
  by firstorder (by eauto using srs_spec with nocore).
Qed.

Lemma In_srsI {a b c d} : srs_spec a b c d \/ srs_mlr_spec a b c d -> In ((a, b), (c, d)) srs.
Proof.
  case.
  - move=> [] > <- *.
    1-2: apply /In_appl; rewrite /=; by tauto.
    1-6: apply /In_appr /In_appl /in_flat_map; eexists;
      (constructor; [apply: nth_error_Some_in_combine; by eassumption | by move=> /=; tauto ]).
    1: apply /In_appr /In_appr /In_appr /In_appr /In_appl /in_map_iff; eexists;
      (constructor; [by reflexivity | apply /in_seq; by lia ]).
    1-5: do 5 (apply /In_appr); move=> /=; by tauto.
  - move=> [] p <- *.
    1-7: apply /In_appr /In_appr /In_appl /in_flat_map; exists p;
      (constructor; [apply /in_seq; by lia | by move=> /=; tauto ]).
    1-7: apply /In_appr /In_appr /In_appr /In_appl /in_flat_map; exists p;
      (constructor; [apply /in_seq; by lia | by move=> /=; tauto ]).
Qed.

Lemma srs_mlr_specE {a b c d} : srs_mlr_spec a b c d ->
  exists x y p,
  ((a, b), (c, d)) = (((x, Some p), (y, None)), ((x, None), (y, Some p))) \/
  ((a, b), (c, d)) = (((x, None), (y, Some p)), ((x, Some p), (y, None))).
Proof. move=> [] > [] ? ? ? ? _; subst; do 3 eexists; by tauto. Qed.

(* resolve In _ srs goals : by eauto with in_srs_db nocore. *)
Local Create HintDb in_srs_db.

Local Hint Resolve or_introl or_intror conj In_srsI : in_srs_db.
Local Hint Immediate erefl : in_srs_db.
Local Hint Constructors srs_spec srs_mlr_spec : in_srs_db.

Definition stepI_nil := (@step_intro srs []).

Lemma move_sb_right {p n} : p < state_bound ->
  multi_step srs ((sb' p) :: repeat sb n) ((repeat sb n) ++ [sb' p]).
Proof.
  move=> Hp. elim: n; first by apply: rt_refl.
  move=> n IH /=. apply: rt_trans;
    [apply: rt_step | apply: (multi_step_applI (u := [sb])); exact: IH].
  apply: stepI_nil. by eauto with in_srs_db nocore.
Qed.

Lemma move_sb_left {p n} : p < state_bound -> multi_step srs ((repeat sb n) ++ [sb' p]) ((sb' p) :: repeat sb n).
Proof.
  move=> Hp. elim: n; first by apply: rt_refl.
  move=> n IH /=. apply: rt_trans;
    [apply: (multi_step_applI (u := [sb])); exact: IH | apply: rt_step].
  apply: stepI_nil. by eauto with in_srs_db nocore.
Qed.

Section Transport.
(* number of steps until halting *)
Context (n_cm: nat).
Definition c0 := (0, (0, 0)).
Context (H_n_cm: CM2.steps cm n_cm c0 = None).

Lemma cm_steps_S n x : cm_steps (S n) x = cm_steps 1 (cm_steps n x).
Proof.
  elim: n x; first done.
  move=> n IH x.
  have ->: S (S n) = (S n) + 1 by lia.
  rewrite /=.
  have ->: n + 1 = S n by lia.
  case Hxy: (step cm x) => [y|].
  - by rewrite IH.
  - by rewrite Hxy.
Qed.

Lemma cm_steps_plus n m x : cm_steps (n + m) x = cm_steps n (cm_steps m x).
Proof.
  elim: n; first done.
  move=> n IH. by rewrite [S n + m]/= (cm_steps_S (n + m)) (cm_steps_S n) IH.
Qed.

Lemma steps_Some_cm_steps n x y : steps cm n x = Some y -> cm_steps n x = y.
Proof.
  elim: n x. { by move=> ? [<-]. }
  move=> n IH x /=. rewrite obind_oiter.
  case: (step cm x) => [z|]; last by rewrite oiter_None.
  by apply: IH.
Qed.

Lemma steps_None_cm_steps n x : steps cm n x = None ->
  cm_steps 1 (cm_steps n x) = (cm_steps n x).
Proof.
  elim: n x; first done.
  move=> n IH x /=. rewrite obind_oiter.
  case Hxy: (step cm x) => [y|]; last by rewrite Hxy.
  by move=> /IH.
Qed.

(*
Lemma cm_steps_ub n : steps cm n c0 = None -> cm_steps n c0 = cm_steps n_cm c0.
Proof.
  elim: n (n_cm) (H_n_cm); first done.
  move=> n IH [|n_cm']; first done.
  rewrite /=.
*)

Lemma cm_steps_haltingP x : cm_steps 1 x = x <-> length cm <= state x.
Proof using.
  rewrite /=.
  case Hxy: (step cm x) => [y|].
  { split.
    - move=> ?. subst y. by move: Hxy => /step_neq.
    - move=> /nth_error_None Hx. move: Hxy.
      by rewrite /step Hx. }
  split; last done.
  by move: Hxy => /step_None'.
Qed.

Lemma halting_eq n : cm_steps (n + n_cm) c0 = cm_steps n_cm c0.
Proof using H_n_cm.
  elim: n; first done.
  move=> n IH.
  have ->: S n + n_cm = 1 + (n + n_cm) by lia.
  rewrite cm_steps_plus IH.
  by apply: steps_None_cm_steps.
Qed.

Lemma cm_steps_values_ub n :
  value1 (cm_steps n c0) + value2 (cm_steps n c0) <= n.
Proof using.
  elim: n. { rewrite /=. lia. }
  move=> n IH. have ->: S n = 1 + n by lia.
  rewrite cm_steps_plus /=.
  case Hx: (step cm (cm_steps n c0)) => [x|]; last by lia.
  move: Hx => /step_values_bound. lia.
Qed.

Lemma cm_values_ub n :
  value1 (cm_steps n c0) + value2 (cm_steps n c0) <= n_cm.
Proof using H_n_cm.
  have [?|->] : n <= n_cm \/ n = ((n - n_cm) + n_cm) by lia.
  - have := cm_steps_values_ub n. lia.
  - rewrite halting_eq.
    by apply: cm_steps_values_ub.
Qed.

Lemma cm_state_ub n : state (cm_steps n c0) < state_bound.
Proof.
  elim: n. { rewrite /= /state_bound. lia. }
  move=> n IH. have ->: S n = 1 + n by lia.
  rewrite cm_steps_plus /=.
  case Hx: (step cm (cm_steps n c0)) => [x|]; last done.
  move: Hx. rewrite /step.
  move: (cm_steps n c0) => [p [a b]] /=.
  case Hoi: (nth_error cm p) => [i|]; last done.
  move: Hoi => /state_boundP.
  case: i x.
  - move=> ? [? [? ?]] /= ? []. lia.
  - move: a b => [|?] [|?] [] ? [? [? ?]] /= ? []; lia.
Qed.

Definition d := 5 + n_cm + n_cm. (* maximal space requirement *)

(* s is (0^(n-a) l_p _^a m _^b r 0^(n-b)) with a unique state annotation *)
Definition enc_Config : Config -> list Symbol :=
  fun '(p, (a, b)) =>
    (repeat sz (1 + n_cm-a)) ++ [sl' p] ++ (repeat sb a) ++ [sm] ++
    (repeat sb b) ++ [sr] ++ (repeat sz (1 + n_cm-b)).

(* s is (0^(n-a) l _^a m _^b r_p 0^(n-b)) with a unique state annotation *)
Definition enc_Config' : Config -> list Symbol :=
  fun '(p, (a, b)) =>
    (repeat sz (1 + n_cm-a)) ++ [sl] ++ (repeat sb a) ++ [sm] ++
    (repeat sb b) ++ [sr' p] ++ (repeat sz (1 + n_cm-b)).

Lemma multi_step_enc_c0 : multi_step srs (repeat sz d) (enc_Config c0).
Proof using.
  apply: (rt_trans (y := (repeat sz (1 + n_cm)) ++ [sz] ++ [st] ++ [sr] ++ (repeat sz (1 + n_cm)))).
  - have ->: d = 1 + n_cm + 1 + 1 + 1 + 1 + n_cm by (rewrite /d; lia).
    rewrite ?repeat_app -?app_assoc. do ? apply: multi_step_applI.
    apply /rt_step /stepI_nil. by eauto with in_srs_db nocore.
  - apply /multi_step_applI /rt_step /stepI_nil. by eauto with in_srs_db nocore.
Qed.

Lemma move_sb_right' {p n x y} : p < state_bound -> ((x, y) = (1, 3) \/ (x, y) = (3, 2)) ->
  multi_step srs ([(x, Some p)] ++ repeat sb n ++ [(y, None)]) ([(x, None)] ++ repeat sb n ++ [(y, Some p)]).
Proof.
  move=> ? /= Hxy. case: n.
  - apply /rt_step /stepI_nil.
    move: Hxy => [] [-> ->]; by eauto with in_srs_db nocore.
  - move=> n. apply: (rt_trans (y := [(x, None)] ++ [sb' p] ++ (repeat sb n) ++ [(y, None)])).
    + have ->: repeat sb (S n) = [sb] ++ repeat sb n by done.
      rewrite /= -?app_assoc. apply /rt_step /stepI_nil.
      move: Hxy => [] [-> _]; by eauto with in_srs_db nocore.
    + rewrite -?app_assoc. apply: multi_step_applI.
      apply: (rt_trans (y := (repeat sb n) ++ [sb' p] ++ [(y, None)])).
      * rewrite ?app_assoc. apply: multi_step_apprI. by apply: move_sb_right.
      * have ->: S n = n + 1 by lia. rewrite repeat_app -?app_assoc.
        apply /multi_step_applI /rt_step /stepI_nil.
        move: Hxy => [] [_ ->]; by eauto with in_srs_db nocore.
Qed.

Lemma move_sb_left' {p n x y} : p < state_bound -> ((x, y) = (1, 3) \/ (x, y) = (3, 2)) ->
  multi_step srs ([(x, None)] ++ repeat sb n ++ [(y, Some p)]) ([(x, Some p)] ++ repeat sb n ++ [(y, None)]).
Proof.
  move=> ? /= Hxy. case: n.
  - apply /rt_step /stepI_nil.
    move: Hxy => [] [-> ->]; by eauto with in_srs_db nocore.
  - move=> n. apply: (rt_trans (y := [(x, None)] ++ (repeat sb n) ++ [sb' p] ++ [(y, None)])).
    + rewrite (ltac:(lia) : S n = n + 1) repeat_app -?app_assoc. do ? apply: multi_step_applI.
      apply /rt_step /stepI_nil.
      move: Hxy => [] [_ ->]; by eauto with in_srs_db nocore.
    + rewrite ?app_assoc. apply: multi_step_apprI.
      apply: (rt_trans (y := [(x, None)] ++ [sb' p] ++ (repeat sb n))).
      * rewrite -?app_assoc. apply: multi_step_applI. by apply: move_sb_left.
      * apply /rt_step /stepI_nil.
        move: Hxy => [] [-> _]; by eauto with in_srs_db nocore.
Qed.

Lemma move_right n : let c := (cm_steps n c0) in
  multi_step srs (enc_Config c) (enc_Config' c).
Proof.
  move=> c. subst c. have := cm_state_ub n.
  move: (cm_steps n c0) => [p [a b]] /= ?.
  apply: multi_step_applI. rewrite ?app_assoc. apply: multi_step_apprI.
  apply: (rt_trans (y := [sl] ++ (repeat sb a) ++ [sm' p] ++ (repeat sb b) ++ [sr])).
  - rewrite ?app_assoc. do 2 apply: multi_step_apprI.
    apply: move_sb_right'; by tauto.
  - rewrite -?app_assoc. do 2 apply: multi_step_applI.
    apply: move_sb_right'; by tauto.
Qed.

Lemma move_left n : let c := (cm_steps n c0) in
  multi_step srs (enc_Config' c) (enc_Config c).
Proof.
  move=> c. subst c. have := cm_state_ub n.
  move: (cm_steps n c0) => [p [a b]] /= ?.
  apply: multi_step_applI. rewrite ?app_assoc. apply: multi_step_apprI.
  apply: (rt_trans (y := [sl] ++ (repeat sb a) ++ [sm' p] ++ (repeat sb b) ++ [sr])).
  - rewrite -?app_assoc. do 2 apply: multi_step_applI.
    apply: move_sb_left'; by tauto.
  - rewrite ?app_assoc. do 2 apply: multi_step_apprI.
    apply: move_sb_left'; by tauto.
Qed.

Lemma simulate_cm_step {n} : let c := (cm_steps n c0) in
  multi_step srs (enc_Config c) (enc_Config (cm_steps 1 c)).
Proof using H_n_cm.
  move=> c. subst c.
  have := cm_values_ub n.
  have := move_right n. have := move_left (1+n).
  rewrite cm_steps_plus /=.
  case: (cm_steps n c0) => p [a b] /=. rewrite /step.
  move Hoi: (nth_error cm p) => oi.
  case: oi Hoi; last by (move=> *; apply: rt_refl). case; case.
  (* inc b *)
  - move=> ? /= Hr Hl ?.
    apply: rt_trans; first by eassumption.
    apply: rt_trans; last by eassumption.
    have [-> ->]: S b = b + 1 /\ S n_cm - b = 1 + (S n_cm - (b + 1)) by lia.
    rewrite ?repeat_app -?app_assoc. do 5 apply: multi_step_applI.
    apply /rt_step /stepI_nil. by eauto with in_srs_db nocore.
  (* inc a *)
  - move=> ? _ _ ? /=.
    have [-> ->]: S n_cm - a = (n_cm - a) + 1 /\ S a = 1 + a by lia.
    rewrite ?repeat_app -?app_assoc. apply: multi_step_applI.
    apply /rt_step /stepI_nil. by eauto with in_srs_db nocore.
  (* dec b q *)
  - move=> q ? /= Hr Hl Hb.
    apply: rt_trans; first by eassumption.
    apply: rt_trans; last by eassumption.
    case: (b) Hb => [_ | b' Hb'] /=.
    + do 3 apply: multi_step_applI.
      apply /rt_step /stepI_nil. by eauto with in_srs_db nocore.
    + have [-> ->] : S b' = b' + 1 /\ S n_cm - b' = 1 + (S n_cm - (b' + 1)) by lia.
      rewrite ?repeat_app -?app_assoc. do 5 apply: multi_step_applI.
      apply /rt_step /stepI_nil. by eauto with in_srs_db nocore.
  (* dec a q*)
  - move=> q ? _ _ Ha.
    case: (a) Ha => [_ | a' Ha'] /=.
    + apply /multi_step_applI /rt_step /stepI_nil.
      by eauto with in_srs_db nocore.
    + rewrite (ltac:(lia) : (S n_cm - a' = (n_cm - a') + 1)) repeat_app -?app_assoc.
      apply /multi_step_applI /rt_step /stepI_nil.
      by eauto with in_srs_db nocore.
Qed.

Lemma multi_step_repeat_solI n : multi_step srs (repeat sz n ++ [so]) (repeat so (n+1)).
Proof.
  elim: n; first by apply: rt_refl.
  move=> n IH. rewrite repeat_app.
  have ->: S n = n + 1 by lia.
  apply: (rt_trans (y := repeat sz n ++ [so] ++ [so]));
    last by (rewrite ?app_assoc; apply: multi_step_apprI).
  rewrite repeat_app -?app_assoc.
  apply /multi_step_applI /rt_step /stepI_nil.
  by eauto with in_srs_db nocore.
Qed.

Lemma multi_step_repeat_sorI {n x} : x = sb \/ x = sz ->
  multi_step srs ([so] ++ repeat x n) ([so] ++ repeat so n).
Proof.
  move=> Hx. elim: n; first by apply: rt_refl.
  move=> n IH.
  apply: (rt_trans (y := ([so] ++ [so] ++ repeat x n))); last by apply: multi_step_applI.
  apply /rt_step /stepI_nil.
  move: Hx => [] ->; by eauto with in_srs_db nocore.
Qed.

Lemma multi_step_repeat_sorI' {s t n x} : x = sb \/ x = sz ->
  multi_step srs ([so] ++ s) ([so] ++ t) ->
  multi_step srs ([so] ++ repeat x n ++ s) ([so] ++ repeat so n ++ t).
Proof.
  move=> /multi_step_repeat_sorI H1 H2.
  apply: (rt_trans (y := ([so] ++ repeat so n ++ s))).
  - rewrite ?app_assoc. by apply: multi_step_apprI.
  - have ->: [so] = repeat so 1 by done. rewrite ?app_assoc -repeat_app.
    have ->: 1 + n = n + 1 by lia. rewrite repeat_app -?app_assoc.
    by apply: multi_step_applI.
Qed.

Lemma simulate_cm_halting {n} : let c := (cm_steps n c0) in
  cm_steps 1 c = c -> multi_step srs (enc_Config c) (repeat so d).
Proof using H_n_cm.
  move=> c. subst c. move=> /cm_steps_haltingP.
  have := cm_values_ub n. have := cm_state_ub n.
  move: (cm_steps n c0) => [p [a b]] /= *.
  apply: (rt_trans (y := (repeat sz (n_cm - a)) ++ [so] ++ [so] ++ _)).
  - rewrite (ltac:(lia) : S n_cm - a = (n_cm - a) + 1) repeat_app -?app_assoc.
    apply /multi_step_applI /rt_step /stepI_nil.
    by eauto with in_srs_db nocore.
  - apply: (rt_trans (y := (repeat so (n_cm - a + 1) ++ [so] ++
      repeat sb a ++ [sm] ++ repeat sb b ++ [sr] ++ repeat sz (S n_cm - b)))).
    + rewrite ?app_assoc. do 6 apply: multi_step_apprI. by apply: multi_step_repeat_solI.
    + have ->: d = (n_cm - a + 1) + 1 + a + 1 + b + 1 + (S n_cm - b) by (rewrite /d; lia).
      rewrite ?repeat_app -?app_assoc. do 2 apply: multi_step_applI.
      apply: multi_step_repeat_sorI'; first by left.
      apply: (rt_trans (y := ([so] ++ [so] ++ repeat sb b ++ [sr] ++ repeat sz (S n_cm - b)))).
      * apply /rt_step /stepI_nil. by eauto with in_srs_db nocore.
      * apply: multi_step_applI. apply: multi_step_repeat_sorI'; first by left.
        apply: (rt_trans (y := ([so] ++ [so] ++ repeat sz (S n_cm - b)))).
        ** apply /rt_step /stepI_nil. by eauto with in_srs_db nocore.
        ** apply: multi_step_applI. apply: multi_step_repeat_sorI. by right.
Qed.
End Transport.

Lemma transport : CM2_HALT cm -> SR2ab (srs, sz, so).
Proof.
  move=> [n Hn]. move: (Hn) (Hn) => /steps_None_cm_steps.
  move=> /simulate_cm_halting H /H {}H. exists (@d n - 1).
  apply: rt_trans; last by eassumption.
  apply: rt_trans; first by apply: (multi_step_enc_c0).
  elim: (n in cm_steps n); first by apply: rt_refl.
  move=> m IH {H}. apply: rt_trans; [by exact: IH |].
  rewrite cm_steps_S. by apply: simulate_cm_step.
Qed.

Section InverseTransport.
Context (N: nat). (* number of 0s / 1s *)
Context (HN: multi_step srs (repeat sz (1+N)) (repeat so (1+N))). (* 0^N ->> 1^N *)

Local Definition rt_rt1n {A R x y} := @clos_rt_rt1n_iff A R x y.

(* s is (0^n1 l _^a m _^b r 0^n2) with a unique state annotation *)
Definition encodes : Config -> list Symbol -> Prop :=
  fun c s =>
  exists u v t, let '(p, (a, b)) := c in
    s = u ++ t ++ v /\
    map fst t = map fst ([sl] ++ repeat sb a ++ [sm] ++ repeat sb b ++ [sr]) /\
    filter (fun x => if x is None then false else true) (map snd t) = [Some p].

Lemma In_srs_stE {a b c d} : In ((a, b), (c, d)) srs ->
  ((sz, sz), (st, sr)) = ((a, b), (c, d)) \/
  ((sz, st), (sl' 0, sm)) = ((a, b), (c, d)) \/
  if a is (_, None) then (if b is (_, None) then False else True) else True.
Proof. move=> /srs_specI [] [] > [] ? ? ? ? *; subst; by tauto. Qed.

Lemma init_encodes : exists s, encodes c0 s /\ multi_step srs s (repeat so (1+N)).
Proof using HN.
  have [s] : exists s,
    multi_step srs s (repeat so (1+N)) /\
    Forall (fun x => snd x = None) s /\
    forall n, nth n s sz = st -> nth (1+n) s sz = sr.
  { eexists. constructor; [|constructor]; [by eassumption | apply /Forall_repeatI; by tauto |].
    move: (1+N) => m n H. exfalso. elim: n m H; first by case.
    move=> n IH [|m]; [done | by apply: IH]. }
  move Ht: (repeat so (1+N)) => t [/rt_rt1n Hst] [].
  elim: Hst Ht; first by move=> ? <- /Forall_cons_iff [].
  move=> {}s {}t > Hst Ht IH /IH {IH}.
  case: Hst Ht => u v a b c d /In_srs_stE [|[]].
  - move=> [] <- <- <- <- _ IH.
    move=> /Forall_app [Hu] /Forall_cons_iff [_] /Forall_cons_iff [_ Ht] Huv.
    apply: IH.
    + apply /Forall_app. by do ? constructor.
    + move=> n. have := Huv n. elim: (u) n; first by move=> [|[|n]].
      clear. move=> x {}u IH [|n]; last by move/IH.
      move: (u) => [|? ?]; [by move=> H /H | done].
  - move=> [] <- <- <- <- /rt_rt1n Ht _ _ /(_ (1 + length u)).
    do 2 (rewrite app_nth2; first by lia).
    rewrite (ltac:(lia) : 1 + length u - length u = 1).
    rewrite (ltac:(lia) : 1 + (1 + length u) - length u = 2).
    move=> /(_ ltac:(done)) Hv. eexists. constructor; last by eassumption.
    move: (v) Hv => [|? v']; first done.
    move=> /= ->. exists u, v', [sl' 0; sm; sr].
    constructor; [done | by constructor].
  - move=> H _ _ /Forall_app [_] /Forall_cons_iff [+] /Forall_cons_iff [+] _.
    by move: a b H => [? [?|]] [? [?|]].
Qed.

(* possibilities to split two symbols among one app *)
Lemma eq2_app {u v a b} {s t: list Symbol} : u ++ a :: b :: v = s ++ t ->
  (exists v1, v = v1 ++ t /\ s = u ++ a :: b :: v1) \/
  (s = u ++ [a] /\ t = b :: v) \/
  (exists u2, u = s ++ u2 /\ t = u2 ++ a :: b :: v).
Proof.
  elim: u s.
  - move=> [|y1 [|y2 s]].
    + rewrite ?app_nil_l. move=> <-. right. right. by exists [].
    + move=> [] <- <- /=. right. by left.
    + move=> [] <- <- ->. left. by exists s.
  - move=> x1 u IH [|y1 s].
    + rewrite ?app_nil_l. move=> <-. right. right. by exists (x1 :: u).
    + move=> [] <- /IH [|[|]].
      * move=> [?] [-> ->]. left. by eexists.
      * move=> [-> ->]. right. by left.
      * move=> [?] [-> ->]. right. right. by eexists.
Qed.

(* possibilities to split two symbols among one twp apps *)
Lemma eq2_app_app {u a b v u' v'} {s: list Symbol} : length s > 1 ->
  u ++ a :: b :: v = u' ++ s ++ v' ->
  (exists u'2, v = u'2 ++ s ++ v') \/
  (exists s2, u' = u ++ [a] /\ s = b :: s2 /\ v = s2 ++ v') \/
  (exists s1 s2, s = s1 ++ [a] ++ [b] ++ s2 /\ u = u' ++ s1 /\ v = s2 ++ v') \/
  (exists s1, u = u' ++ s1 /\ s = s1 ++ [a] /\ v' = b ::  v) \/
  (exists v'1, u = u' ++ s ++ v'1).
Proof.
  move=> Hs /eq2_app [|[|]].
  - move=> [?] [-> ->]. left. by eexists.
  - move=> [->]. move: s Hs => [|? s] /=; first by lia.
    move=> _ [] <- <-. right. left. by eexists.
  - move=> [?] [->] /esym /eq2_app [|[|]].
    + move=> [?] [-> ->]. right. right. left. by do 2 eexists.
    + move=> [-> ->]. do 3 right. left. by eexists.
    + move=> [?] [-> ->]. do 4 right. by eexists.
Qed.

(* specification of inner Cm2 step *)
Inductive srs_step_spec (u v: list Symbol) (a b: Symbol) (n m: nat) : Prop :=
  | srs_step0 : a.1 = sl.1 -> b.1 = sm.1 -> u = [] -> n = 0 -> srs_step_spec u v a b n m
  | srs_step1 : a.1 = sl.1 -> b.1 = sb.1 -> u = [] -> n = 1 + (n - 1) -> srs_step_spec u v a b n m
  | srs_step2 : a.1 = sm.1 -> b.1 = sr.1 -> v = [] -> m = 0 -> srs_step_spec u v a b n m
  | srs_step3 : a.1 = sb.1 -> b.1 = sr.1 -> v = [] -> m = 1 + (m - 1) -> srs_step_spec u v a b n m.

Lemma srs_step_specI {u v a b n m} :
  map fst (u ++ [a] ++ [b] ++ v) = map fst ([sl] ++ repeat sb n ++ [sm] ++ repeat sb m ++ [sr]) ->
  srs_step_spec u v a b n m \/
  (a.1 = sb.1 /\ b.1 = sb.1) \/ (a.1 = sb.1 /\ b.1 = sm.1) \/ (a.1 = sm.1 /\ b.1 = sb.1).
Proof.
  move: u => [|? u].
  { move: n => [|n].
    - move=> [] *. left. by apply: srs_step0.
    - move=> [] *. left. apply: srs_step1; by [|lia]. }
  move=> [] _. rewrite -/(_ ++ _).
  elim /rev_ind: v.
  { rewrite app_nil_r ?map_app /=.
    rewrite ?app_assoc. move=> /app_inj_tail [].
    have [->|->] : m = 0 \/ m = (m - 1) + 1 by lia.
    - rewrite app_nil_r. move=> /app_inj_tail [] *. left. by apply: srs_step2.
    - rewrite repeat_app map_app ?app_assoc.
      move=> /app_inj_tail [] *. left. apply: srs_step3; by [|lia]. }
  move=> ? v _. rewrite ?map_app ?app_assoc.
  move=> /app_inj_tail [+] _. move=> + /ltac:(right).
  elim: u n.
  { move=> [|[|n]].
    - move: m => [|m [] *]; [done | by tauto ].
    - move=> [] *. by tauto.
    - move=> [] *. by tauto. }
  move=> ? u IH [|n]; last by move=> [_] /IH.
  move=> [_] {IH}. rewrite -?/(_ ++ _). elim: m u; first by case.
  move=> m IH [|? u]; last by move=> [_] /IH.
  move: m {IH} => [|m] []; [done | by tauto].
Qed.

(* each srs step is sound *)
Lemma simulate_srs_step {c s t} : SR2ab.step srs s t -> encodes c s ->
  cm_steps 1 c = c \/ encodes c t \/ encodes (cm_steps 1 c) t.
Proof.
  move: c => [p [a b]] [] u v a' b' c' d' H [u'] [v'] [{}t].
  rewrite -?/([_] ++ [_] ++ v). move=> [+] [H1t H2t] => /eq2_app_app.
  have : length t > 1.
  { move: H1t => /(congr1 (@length _)).
    rewrite ?map_app ?app_length ?map_length /=. move=> ->. by lia. }
  move=> Ht /(_ Ht) {Ht}.
  case; [|case; [|case; [|case]]].
  - move=> [u'2 ->]. right. left.
    exists (u ++ c' :: d' :: u'2), v', t.
    constructor; [by rewrite -?app_assoc | done].
  - move=> [s2] [?] [? ?]. subst. move: H1t H2t => [].
    move: H => /srs_specI [|] [] > [] ? ? ? ?; subst; try done; [|].
    + move=> Hi _ H1s2 [<- H2s2]. right. right.
      rewrite /= /step Hi. eexists u, v', (_ :: _ :: s2).
      constructor; [done | constructor; by rewrite /= ?H1s2  ?H2s2].
    + move=> ? _ _ [<-] _ *. left.
      apply /cm_steps_haltingP => /=. by lia.
  - move=> [s1] [s2] [?] [? ?]. subst.
    move: H H1t H2t => /srs_specI [].
    + move=> H + + /ltac:(right; right). move=> /[dup] [/srs_step_specI] [].
      * move=> H'. move: H' H => [] ? ? ? ? [] > [] ? ? ? ?; subst; try done; [ | | | ].
        ** rewrite app_nil_r /= /step. move=> + [H1] [<-] => -> H2.
           eexists u', v', (_ :: _ :: _). constructor; [done | by rewrite /= H1 H2].
        ** rewrite app_nil_r /= ?map_app /step. move: (a) => [|?]; first done.
           move=> + [] H1 [<-] H2 => ->.
           eexists (u' ++ [sz]), v', (_ :: _).
           rewrite -?app_assoc. constructor; [done | by rewrite /= ?map_app H1 H2].
        ** rewrite ?map_app filter_app /= app_nil_r /step.
           move=> + + /(app_inj_tail (y := [])) [H2] [<-].
           move=> ->. rewrite ?app_assoc app_nil_r.
           move=> /app_inj_tail [/app_inj_tail] [H1] _ _.
           eexists u', v', (_ ++ [_; _]).
           rewrite -?app_assoc. constructor; first done.
           by rewrite ?map_app filter_app /= H1 H2.
        ** rewrite [in repeat sb b](ltac:(lia) : b = (b - 1) + 1) repeat_app.
           rewrite ?map_app ?filter_app ?app_assoc ?app_nil_r /= /step.
           move=> + + /(app_inj_tail (y := [])) [H2] [<-].
           move=> ->. move=> /app_inj_tail [/app_inj_tail] [H1] _ _.
           eexists u', ([sz] ++ v'), (_ ++ [_]).
           rewrite (ltac:(lia) : b = 1 + (b - 1)) -?app_assoc /=.
           constructor; first done.
           by rewrite ?map_app filter_app /= H1 H2 -?app_assoc.
      * move: H => + + _ /ltac:(exfalso).
        move=> [] > [] *; subst; by firstorder done.
    + move=> + + + /ltac:(right; left; exists u', v', (s1 ++ c' :: d' :: s2)).
      move=> /srs_mlr_specE [x] [y] [q] [] [] ? ? ? ? H1t H2t;
        subst; rewrite -?app_assoc.
      * constructor; first done.
        constructor; first by rewrite -H1t ?map_app.
        move: H2t. by rewrite ?map_app ?filter_app /=.
      * constructor; first done.
        constructor; first by rewrite -H1t ?map_app.
        move: H2t. by rewrite ?map_app ?filter_app /=.
  - move=> [s1] [?] [? ?]. subst.
    move: (H1t). rewrite ?map_app ?app_assoc. move=> /app_inj_tail [_].
    move: H H1t H2t => /srs_specI [|] [] > [] ? ? ? ?; subst; try done; [].
    move=> Hi H1s1. rewrite map_app filter_app.
    move=> /(app_inj_tail (y := [])) [H2s2] [<-] _.
    right. right. rewrite /= /step Hi. eexists u', v, (s1 ++ [_; _]).
    rewrite -?app_assoc. constructor; [done | constructor].
    * move: H1s1. rewrite ?map_app ?app_assoc. move=> /app_inj_tail [-> _].
      by rewrite (ltac:(lia) : 1 + b = b + 1) [repeat _ (b + 1)]repeat_app map_app -?app_assoc.
    * by rewrite map_app filter_app /= H2s2.
  - move=> [v'1 ->]. right. left.
    exists u', (v'1 ++ c' :: d' :: v), t.
    constructor; [by rewrite -?app_assoc | done].
Qed.

Lemma halting_cmI : exists n, cm_steps 1 (cm_steps n c0) = cm_steps n c0.
Proof using HN.
  have [s [H1s H2s]] := init_encodes.
  move Ht: (repeat so (1+N)) (c0) H2s H1s => t c Hst.
  have {}Ht : Forall (fun x => fst so = x) (map fst t).
  { subst t. elim: (N); by constructor. }
  move: Hst Ht c. move=> /rt_rt1n. elim.
  - move=> {}s Hs [? [? ?]] /= [?] [?] [{}t] [?] [H]. subst s.
    move: Hs. rewrite ?map_app ?Forall_app H.
    by move=> [_] [/Forall_cons_iff] [].
  - move=> > /simulate_srs_step H _ IH /IH {}IH c /H {H} [|[]].
    + move=> ?. by exists 0.
    + by move=> /IH.
    + move=> /IH [n Hn]. exists (n + 1).
      by rewrite ?cm_steps_plus.
Qed.

End InverseTransport.

Lemma inverse_transport : SR2ab (srs, sz, so) -> CM2_HALT cm.
Proof.
  move=> [n Hn].
  have [m  Hm] := halting_cmI n Hn.
  exists (S m) => /=.
  case Hx: (steps cm m (0, (0, 0))) => [x|]; last done.
  move: (Hm) => /cm_steps_haltingP.
  move: (Hx) => /steps_Some_cm_steps.
  rewrite /c0 /= /step.
  by move=> -> /nth_error_None ->.
Qed.

End Reduction.
End Argument.

Require Import Undecidability.Synthetic.Definitions.

Theorem reduction : CM2_HALT ⪯ SR2ab.
Proof.
  exists (fun cm => (Argument.srs cm, (4, None), (5, Some 0))).
  intro cm. constructor.
  - exact (Argument.transport cm).
  - exact (Argument.inverse_transport cm).
Qed.


Require Import ClassicalRealizability.Kbase.

(**********************************)
(** *  Primitive pairs and sums  **)
(**********************************)

(** **  Hypotheses: new instructions and their evaluation rules  **)

Parameter cpl : Λ -> Λ -> Λ.
Parameter ι₁ ι₂ : Λ -> Λ.
Parameter pair proj1 proj2 inj1 inj2 case : instruction.
Notation "<| t , u |>" := (cpl t u).

Axiom red_pair : forall t u k π e, pair↓e ★ t·u·k·π ≻ k ★ <|t, u|>·π.
Axiom red_proj1 : forall t u k π e, proj1↓e ★ <|t, u|>·k·π ≻ k ★ t·π.
Axiom red_proj2 : forall t u k π e, proj2↓e ★ <|t, u|>·k·π ≻ k ★ u·π.
Axiom red_inj1 : forall t k π e, inj1↓e ★ t·k·π ≻ k ★ ι₁ t·π.
Axiom red_inj2 : forall u k π e, inj2↓e ★ u·k·π ≻ k ★ ι₂ u·π.
Axiom red_case1 : forall t k₁ k₂ π e, case↓e ★ ι₁ t·k₁·k₂·π ≻ k₁ ★ t·π.
Axiom red_case2 : forall u k₁ k₂ π e, case↓e ★ ι₂ u·k₁·k₂·π ≻ k₂ ★ u·π.

Definition prod A B F := fun π => exists t, exists u, exists π', π = <|t, u|>·π' /\ t ⊩ A /\ u ⊩ B /\ π' ∈ ‖F‖.
Notation "A ** B ⇒ F" := (prod A B F) (at level 40).
Definition sum A B F := fun π =>
  exists t, exists π', ((π = ι₁ t·π' /\ t ⊩ A) \/ (π = ι₂ t·π' /\ t ⊩ B)) /\ π' ∈ ‖F‖.
Notation "A ++ B ⇒ F" := (sum A B F) (at level 40).

(** **  Tactics  **)

Global Ltac pair_sum_Keval tac :=
  lazymatch goal with
    | [ |- Cst pair↓ _ ★ ?t·?u·?k·?π ∈ ⫫] => Debug "Keval_pair";
         apply anti_evaluation with (k ★ <|t, u|>·π); [now apply red_pair |]
    | [ |- Cst proj1↓ _ ★ <|?t, ?u|>·?k·?π ∈ ⫫] => Debug "Keval_proj1";
         apply anti_evaluation with (k ★ t·π); [now apply red_proj1 |]
    | [ |- Cst proj2↓ _ ★ <|?t, ?u|>·?k·?π ∈ ⫫] => Debug "Keval_proj2";
         apply anti_evaluation with (k ★ u·π); [now apply red_proj2 |]
    | [ |- Cst inj1↓ _ ★ ?t·?k·?π ∈ ⫫] => Debug "Keval_inj1";
         apply anti_evaluation with (k ★ ι₁ t·π); [now apply red_inj1 |]
    | [ |- Cst inj2↓ _ ★ ?u·?k·?π ∈ ⫫] => Debug "Keval_inj2";
         apply anti_evaluation with (k ★ ι₂ u·π); [now apply red_inj2 |]
    | [ |- Cst case↓ _ ★ ι₁ ?t·?k₁·?k₂·?π ∈ ⫫] => Debug "Keval_case1";
         apply anti_evaluation with (k₁ ★ t·π); [now apply red_case1 |]
    | [ |- Cst case↓ _ ★ ι₂ ?u·?k₁·?k₂·?π ∈ ⫫] => Debug "Keval_case2";
         apply anti_evaluation with (k₂ ★ u·π); [now apply red_case2 |]
    | _ => Debug "Keval_next"; tac
  end.

Ltac Keval ::= basic_Keval ltac:(idtac; pair_sum_Keval fail).

Global Ltac pair_sum_dstack tac Hπ :=
  lazymatch type of Hπ with
    | ?π ∈ ‖?A ** ?B ⇒ ?F‖ =>
      let t := fresh "t" in let Ht := fresh "Ht" in let u := fresh "u" in let Hu := fresh "Hu" in
      let π' := fresh "π" in let t' := fresh "t" in let u' := fresh "u" in let Heq := fresh "Heq" in
      destruct Hπ as [t' [u' [π' [Heq [Ht [Hu Hπ]]]]]]; destruct π as [| t π]; inversion Heq
    | ?π ∈ ‖?A ++ ?B ⇒ ?F‖ =>
      let t := fresh "t" in let t' := fresh "t" in let π' := fresh "π" in
      let Ht := fresh "Ht" in let Heq := fresh "Heq" in
      destruct Hπ as [t [π' [Hcase Hπ]]]; destruct π as [| t' π]; (destruct Hcase as [[Heq Ht] | [Heq Ht]];
      inversion Heq; subst π' t'; clear Heq)
    | _ => tac Hπ
  end.

Ltac dstack ::= basic_dstack ltac:(pair_sum_dstack fail).

(** **  Specifications  **)

Theorem pair_realizer : forall e, pair↓e ⊩ ∀A B, A → B → ∀Z, (A ** B ⇒ Z) → Z.
Proof. Ksolve. Qed.

Theorem proj1_realizer : forall e, proj1↓e ⊩ ∀A B Z, (A ** B ⇒ ((A → Z) → Z)).
Proof. Ksolve. Qed.

Theorem proj2_realizer : forall e, proj2↓e ⊩ ∀A B Z, (A ** B ⇒ ((B → Z) → Z)).
Proof. Ksolve. Qed.

Theorem inj1_realizer : forall e, inj1↓e ⊩ ∀A B, A → ∀Z, (A ++ B ⇒ Z) → Z.
Proof. Ksolve. intuition. Qed.

Theorem inj2_realizer : forall e, inj2↓e ⊩ ∀A B, B → ∀Z, (A ++ B ⇒ Z) → Z.
Proof. Ksolve. intuition. Qed.

Theorem case_realizer : forall e, case↓e ⊩ ∀A B, A ++ B ⇒ ∀Z, (A → Z) → (B → Z) → Z.
Proof. Ksolve. Qed.

(*********************************************************)
(** *  Equivalence between e₁ = e₂ ⇒ A and e₁ = e₂ ↦ A  **)
(*********************************************************)

Lemma eq_equiv1 : forall T (a a' : T) A e, λ"x" λ"e" "e" @ "x"↓e ⊩ (a = a' ↦ A) → prop (a = a') → A.
Proof.
Ksolve. elim (Classical_Prop.classic (a = a')); intro H.
  left. find.
  right. find.
Qed.

Lemma eq_equiv2 : forall T (a a' : T) A e, λ"x" "x" @ Id↓e ⊩ (prop (a = a') → A) → a = a' ↦ A.
Proof. Ksolve. start. destruct Hπ as [[] | []]. now apply Id_realizer. contradiction. Qed.

(****************************************************)
(** *  Equivalence between e₁ ≠ e₂ and ¬(e₁ = e₂)  **)
(****************************************************)

Notation "a ≠ a'" := (if Peano_dec.eq_nat_dec a a' then ⊥ else ⊤) (at level 10).
(*Definition neq_equiv1 := λ"x" "x" @ Id.
Definition neq_equiv2 := λ"x" λ"y" "y" @ "x".*)

Transparent prop.
Lemma neq_equiv1 : forall e, λ"x" "x" @ Id↓e ⊩ ∀a a', ¬(prop (a = a')) → a ≠ a'.
Proof.
Ksolve. destruct (Peano_dec.eq_nat_dec a a').
  unfold prop in *. start. destruct Hπ as [[_ Hπ] | [Hc _]]. unfold one in *. Ksolve. contradiction.
  elim Hπ.
Qed.

Lemma neq_equiv2 : forall e, λ"x" λ"y" "y" @ "x"↓e ⊩ ∀a a', a ≠ a' → ¬(prop (a = a')).
Proof.
Ksolve. unfold prop. destruct (Peano_dec.eq_nat_dec a a').
  left. split. ok. find.
  right. repeat split; ok.
Qed.
Opaque prop.

(***********************************)
(** *  Weak Recurrence Principle  **)
(***********************************)

Notation "x ==  0" := (∀y, x ≠ (S y)) (at level 11).

Lemma S_wf : well_founded (fun y x => S y = x).
Proof.
intros n. induction n; constructor; intros m Hm.
  discriminate Hm.
  now inversion Hm.
Qed.

Lemma Y_wra : forall e, Y↓e ⊩ ∀P, (∀x, (∀y, S y = x ↦ P y) → P x) → ∀x, P x.
Proof. intros ? ? ?. apply (Y_realizer S_wf). exact H. Qed.

Definition WRA := λ"x" λ"y" Y @ (λ"z" callcc @ (λ"k" "x" @ ("k" @ ("y" @ "z")))).

Theorem WRA_realizer : forall e, WRA↓e ⊩ ∀P, (∀x, x == 0 → P x) → (∀y, P y → P (S y)) → ∀x, P x.
Proof.
Ksolve. apply Y_wra. do 2 Ksolve. Ksolve.
  destruct (Peano_dec.eq_nat_dec (S y) x0) as [Heq | Heq]. Ksolve.
  destruct (Peano_dec.eq_nat_dec x0 (S y)) as [Heq2 | Heq2].
    subst. now elim Heq.
    ok.
  destruct (Peano_dec.eq_nat_dec x0 (S y)).
    now subst.
    ok.
Qed.


(************************************************************************)
(*                                                                      *)
(*                Quantitative Hoare Logic for Clight                   *)
(*                                                                      *)
(*  Author: Quentin Carbonneaux (c) 2014              Yale University   *)
(*                                                                      *)
(************************************************************************)

(* Here we prove a stack bound on a simple
   quicksort implementation.
*)

Add LoadPath "..".
Require Import Coqlib.
Require Import Common.

Section QUICKSORT.
Context (F: fid -> Z) (FNN: forall f, 0 <= F f).

(* ---- PROGRAM DEFINITION *)

(*
    /* Quicksort function from CompCert's benchmarks. */

    void quicksort(int lo, int hi, int *base)
    {
      int i,j;
      int pivot,temp;

      if (lo<hi) {
        i=lo; j=hi; pivot=base[hi];
        while (i<j) {
          while (i<hi && base[i]<=pivot) i++;
          while (j>lo && base[j]>=pivot) j--;
          if (i<j) { temp=base[i]; base[i]=base[j]; base[j]=temp; }
        }
        temp=base[i]; base[i]=base[hi]; base[hi]=temp;
        quicksort(lo,i-1,base);
        quicksort(i+1,hi,base);
      }
    }

*)

(* --- Variable Identifiers *)

(* -- global variables *)
Definition qsort_id := 1%positive.

(* -- quicksort locals *)
Definition lo_id    := 1%positive.
Definition hi_id    := 2%positive.
Definition base_id  := 3%positive.
Definition i_id     := 4%positive.
Definition j_id     := 5%positive.
Definition pivot_id := 6%positive.
Definition temp_id  := 7%positive.

(* --- Quicksort Expressions *)

Definition lo_e    := Etempvar lo_id i32.
Definition hi_e    := Etempvar hi_id i32.
Definition base_e  := Etempvar base_id i32.
Definition i_e     := Etempvar i_id i32.
Definition j_e     := Etempvar j_id i32.
Definition pivot_e := Etempvar pivot_id i32.
Definition temp_e  := Etempvar temp_id i32.

Definition one_e := Econst_int Int.one i32.

Parameter base: expr -> expr.

(* --- Quicksort Swap Code Snippet *)

Definition swap i j :=
  (sseq (slset temp_id (base i))
  (sseq (sgset (base i) (base j))
        (sgset (base j) temp_e)
  )).

(* --- Quicksort Internal Loop Definition *)

Definition inner_loop :=
  let o op a b := Ebinop op a b i32 in
  (sloop
    (sif (o Olt i_e j_e)
         (* loop body *)
         (sseq (sloop (sif (o Olt i_e hi_e)
                      (sif (o Ole (base i_e) pivot_e)
                         (slset i_id (o Oadd i_e one_e))
                         sbreak)
                         sbreak))
         (sseq (sloop (sif (o Ogt j_e lo_e)
                      (sif (o Oge pivot_e (base i_e))
                         (slset j_id (o Osub j_e one_e))
                         sbreak)
                         sbreak))
               (sif (o Olt i_e j_e) (swap i_e j_e) sskip)
         ))
         (* exit loop *)
         sbreak)
  ).

(* --- Full Quicksort Function Definition *)

Definition quicksort_body :=
  let o op a b := Ebinop op a b i32 in
  (sif (o Olt lo_e hi_e)
       (* main if statement *)
       (sseq (slset i_id lo_e)
       (sseq (slset j_id hi_e)
       (sseq (slset pivot_id (base hi_e))
       (sseq inner_loop
       (sseq (swap i_e hi_e)
       (sseq (scall None qsort_id (lo_e :: (o Osub i_e one_e) :: base_e :: nil))
       (sseq (scall None qsort_id ((o Oadd i_e one_e) :: hi_e :: base_e :: nil))
             (sret None)
       )))))))
       (* no op *)
       (sret None)
  ).

Definition quicksort :=
  {| fi_name := qsort_id
  ;  fi_locals := (i_id, i32) :: (j_id, i32) :: (pivot_id, i32) :: (temp_id, i32) :: nil
  ;  fi_body := quicksort_body
  ;  fi_args := (lo_id, i32) :: (hi_id, i32) :: (base_id, Tpointer i32 noattr) :: nil
  ;  fi_return := Tvoid
  |}.

(* --- Global Environment Used *)

Definition ge: genv :=
  Genv.add_globals (@Genv.empty_genv _ _) (
    (qsort_id, Gfun quicksort) ::
    nil
  ).

(* ---- STACK BOUND PROOF *)
Require Import Maps.

(* --- Expression Tools *)
Definition local s id n := s!id = Some (Vint n).

Lemma eval_local:
  forall c id n (LOC: local (c_stack c) id n)
         v (EVAL: eval ge c (Etempvar id i32) v),
  v = (Vint n, i32).
Proof.
simpl; intros until v.
destruct v; intros [? ?]; f_equal; auto.
eapply Clight.eval_expr_determ; eauto.
constructor; auto.
Qed.

Lemma eval_lt:
  forall
    (c: conf)
    a_id na (LOCA: local (c_stack c) a_id na)
    b_id nb (LOCB: local (c_stack c) b_id nb)
    b (EVLTB: eval ge c
                (Ebinop Olt (Etempvar a_id i32)
                            (Etempvar b_id i32) i32) b)
      (BTRUE: val_bool b true),

    sint na < sint nb.

Proof.
intros.
destruct b as [b bty].
destruct EVLTB as [EV ?]; simpl in *; subst.
inv EV.
replace v1 with (Vint na) in *.
replace v2 with (Vint nb) in *.
inv H6.
  revert BTRUE. unfold Int.lt, sint.
  destruct (zlt (Int.signed na) (Int.signed nb));
   try discriminate; auto.
eapply Clight.eval_expr_determ; eauto.
constructor; auto.
eapply Clight.eval_expr_determ; eauto.
constructor; auto.
inv H.
Qed.

(* -- lemmas about operation on the bounds *)

(* We define here a predicate indicating if
   (lo, hi) is a valid pair of bounds to give
   to the quicksort function.
*)
Inductive bounds lo hi: Prop :=
  | bounds_rec
      (LOHI: sint lo <= sint hi)
      (LOMIN: Int.min_signed < sint lo)
      (HIMAX: sint hi < Int.max_signed)
  | bounds_base
      (LOHI: sint lo > sint hi).

(*
Lemma eval_i_add_one:
  forall
    (ge: genv) (c: conf)
    ni (LOCI: local (c_stack c) i_id ni)
    hi (LOCHI: local (c_stack c) hi_id hi)
    b (EVLTB: eval ge c (Ebinop Olt i_e hi_e i32) b)
      (BTRUE: val_bool b true)
    ve (EVADD: eval ge c (Ebinop Oadd i_e one_e i32) ve),

  fst ve = Vint (Int.add ni Int.one) /\
  sint ni < sint hi /\
  sint (Int.add ni Int.one) = sint ni + 1.
*)

Lemma eval_i_add_one:
  forall
    (c: conf)
    ni (LOCI: local (c_stack c) i_id ni)
    (NI: sint ni < Int.max_signed)
    ve (EVADD: eval ge c (Ebinop Oadd i_e one_e i32) ve),

  ve = (Vint (Int.add ni Int.one), i32) /\
  sint (Int.add ni Int.one) = sint ni + 1.

Proof.
intros. split.

+ destruct ve as [v ty].
  destruct EVADD as [EV ?]; simpl in *; subst.
  inv EV.
  replace v1 with (Vint ni) in *.
  replace v2 with (Vint Int.one) in *.
  inv H6. reflexivity.
  inv H5. reflexivity.
  inv H.
  eapply Clight.eval_expr_determ; eauto.
  constructor; auto.
  inv H.
+ rewrite Int.add_signed.
  rewrite Int.signed_repr.
  reflexivity.
  generalize (Int.signed_range ni); intro.
  change (Int.signed Int.one) with 1.
  unfold sint in *; omega.
Qed.

Lemma eval_i_add_one_bounds:
  forall
    (c: conf)
    ni (LOCI: local (c_stack c) i_id ni)
    lo hi (LOHI: sint lo < sint hi) (BOUNDS: bounds lo hi)
    (NI: sint lo <= sint ni <= sint hi)
    ve (EVADD: eval ge c (Ebinop Oadd i_e one_e i32) ve),

  ve = (Vint (Int.add ni Int.one), i32) /\
  sint (Int.add ni Int.one) = sint ni + 1 /\
  bounds (Int.add ni Int.one) hi.

Proof.
intros.
exploit eval_i_add_one; eauto.
{ destruct BOUNDS; omega. }
intros [VE IADD]; repeat split; auto.

+ destruct BOUNDS; try omega.
  assert (CASES: sint ni < sint hi \/ sint ni = sint hi)
   by omega.
  destruct CASES as [NILT | NIEQ].
  left; omega.
  right; omega.
Qed.

Lemma eval_i_sub_one_bounds:
  forall
    (c: conf)
    ni (LOCI: local (c_stack c) i_id ni)
    lo hi (LOHI: sint lo < sint hi) (BOUNDS: bounds lo hi)
    (NI: sint lo <= sint ni <= sint hi)
    ve (EVSUB: eval ge c (Ebinop Osub i_e one_e i32) ve),

  ve = (Vint (Int.sub ni Int.one), i32) /\
  sint (Int.sub ni Int.one) = sint ni - 1 /\
  bounds lo (Int.sub ni Int.one).

Proof.
intros.

assert (ISUB: sint (Int.sub ni Int.one) = sint ni - 1).
{ rewrite Int.sub_signed.
  rewrite Int.signed_repr.
  reflexivity.
  generalize (Int.signed_range hi); intro.
  generalize (Int.signed_range ni); intro.
  change (Int.signed Int.one) with 1.
  destruct BOUNDS; unfold sint in *; try omega.
}

repeat split.

+ destruct ve as [v ty].
  destruct EVSUB as [EV ?]; simpl in *; subst.
  inv EV.
  replace v1 with (Vint ni) in *.
  replace v2 with (Vint Int.one) in *.
  inv H6. reflexivity.
  inv H5. reflexivity.
  inv H.
  eapply Clight.eval_expr_determ; eauto.
  constructor; auto.
  inv H.
+ eexact ISUB.
+ destruct BOUNDS; try omega.
  assert (CASES: sint lo < sint ni \/ sint lo = sint ni)
   by omega.
  destruct CASES as [NILT | NIEQ].
  left; omega.
  right; omega.
Qed.

(* --- Ltac Hacks *)

(* -- destruct on steroids *)
Ltac destroids :=
  repeat match goal with
  | [ H: exists _, _ |- _ ] => destruct H
  | [ H: _ /\ _ |- _ ] => destruct H
  | [ H: True |- _ ] => clear H
  | [ H: False |- _ ] => elim H
  end.

(* -- some basic goal killer *)
Ltac t pre :=
  match goal with
  | [ |- pre _ _ _ ] => unfold pre, ifP in *

  (* valid proofs *)
  | [ |- valid _ _ _ _ _ (sif _ _ _) _ ] =>
      apply sound_if; unfold ifP in *; intros []
  | [ |- valid _ _ _ _ _ (sseq _ _) _ ] =>
      eapply sound_seq with (Q := fun _ => pre);
      unfold ifP, pre
  | [ |- valid _ _ _ _ _ (slset _ _) _ ] =>
      eapply weak_pre; [| apply sound_lset ]
  | [ |- valid _ _ _ _ _ (sgset _ _) _ ] =>
      eapply weak_pre; [| apply sound_gset ]
  | [ |- valid _ _ _ _ _ sskip _ ] =>
      eapply weak_pre; [| apply sound_skip ]
  | [ |- valid _ _ _ _ _ sbreak _ ] =>
      eapply weak_pre; [| apply sound_break ]

  (* kill obligations resulting from a slset statement *)
  | [ STK: stack_set_ _ _ _ _ _ |- _ ] => simpl; inv STK
  | [ H: exists (_: int), _ |- exists (_: int), _ ] =>
      let ni := fresh in
      destruct H as [ni ?]; exists ni
  | [ |- local _ _ _ ] =>
      unfold local; rewrite PTree.gso;
      try assumption; compute; congruence

  (* general purpose goal killers (fast) *)
  | [ H: _ /\ _ |- _ ] => destruct H
  | [ |- _ /\ _ ] => split
  | [ |- _ ] => intros; simpl; auto

  end.

(* -- kill arithmetic goals with Nat <-> Z conversions *)
Ltac zomg :=
  match goal with
  | [ |- context[ Z.of_nat (_ + _) ] ] => rewrite Nat2Z.inj_add
  | [ |- context[ Z.of_nat (Z.to_nat _) ] ] => rewrite Z2Nat.id by zomg
  | [ |- 0 <= F _ ] => apply FNN
  | [ |- _ ] => try rewrite Z.mul_sub_distr_r in *; omega
  end.

(* --- Proof Of Quicksort's Inner Loop *)

Lemma inner_loop_valid:
  forall pred n,
  let pre z c phi := exists hi lo ni,
    local (c_stack c) i_id ni /\
    local (c_stack c) hi_id hi /\
    local (c_stack c) lo_id lo /\
    sint lo <= sint ni <= sint hi /\
    pred hi lo z phi in

  valid Z ge F n
        pre inner_loop (fun _ => pre).
Proof.

intros.
change pre with ((fun _ => pre) (@oskip expr)) at 1.
apply sound_loop; intuition.
apply sound_if; intros [].

(* 1. proof of the loop body *)

apply sound_seq with
  (Q := fun _ => pre).
destruct o; auto.

(* 1.2. proof of the first inner loop *)
{ apply weak_pre with (P := pre). unfold ifP; intuition.
  change pre with ((fun _ => pre) (@oskip expr)) at 1.
  apply sound_loop; intuition.

  apply sound_if; intros [].
  apply sound_if; intros [].

  eapply weak_pre; [| apply sound_lset ].
  unfold ifP, pre. intuition.
  destruct H2 as [hi [lo [ni ?]]]; destroids.
  exists hi. exists lo.
  exists (Int.add ni Int.one).
  simpl; inv H3.
  generalize (Int.signed_range hi); intro HIMX.
  assert (NIHI: sint ni < sint hi)
   by (eauto using eval_lt).
  exploit eval_i_add_one; eauto.
  unfold sint in *; omega.
  intros [VE ADDEQ].
  split. subst.
  unfold local; rewrite PTree.gss. reflexivity.
  repeat (t pre).
  omega. omega.

  repeat (t pre).
  repeat (t pre).
}

apply sound_seq with
  (Q := fun _ => pre).
destruct o; auto.

(* 1.3. proof of the second inner loop *)
{ apply weak_pre with (P := pre). auto.
  change pre with ((fun _ => pre) (@oskip expr)) at 1.
  apply sound_loop; auto.
  repeat (t pre).
}

(* 1.4. proof of the swapping if *)
unfold swap; repeat (t pre).

(* 2. proof of the loop exit *)
repeat (t pre).
Qed.

(* --- Proof For The Full Quicksort Function *)

Definition lin z phi := z * F qsort_id <= Z.of_nat phi.

Theorem quicksort_valid: forall n,
  let pre z (_: mem) args phi :=
    exists hi lo base,
      args = (Vint lo, i32) :: (Vint hi, i32) :: base :: nil /\
      bounds lo hi /\
      sint hi - sint lo <= z /\
      lin z phi in
  let post z (_: mem) (_: option val) phi :=
    lin z phi in

  validf _ ge F (S n)
        pre qsort_id post.
Proof.
intro. eapply validf_ind; [| apply validC_empty ].
clear n; intros n VALIDC.
unfold validf; intros. inv H.

apply sound_if; intros [].

(* 1. prove the recursive case (lo<hi) *)

(* first, we clean the precondition *)
apply weak_pre with
  (P := fun z c phi => exists hi lo,
    local (c_stack c) hi_id hi /\
    local (c_stack c) lo_id lo /\
    bounds lo hi /\
    sint lo < sint hi /\
    sint hi - sint lo <= z /\
    lin z phi).
{ unfold ifP; intros.
  destroids; subst.
  inv H0.
  assert (FI: Some quicksort = Some fi) by assumption.
  replace fi with quicksort in * by congruence; clear FI.
  repeat match goal with
  | [ H: castl _ _ _ |- _ ] => inv H
  | [ H: val_cast (Vint _, _) _ = Some _ |- _ ] => inv H
  end.
  injection H9; clear H9; intros STACK.
  unfold stack,temp_env in *. rewrite <- STACK.
  repeat esplit; eauto.
  eapply eval_lt; eauto.
  rewrite <- STACK. reflexivity.
  rewrite <- STACK. reflexivity.
}

pose (i_lo z (c: conf) phi := exists hi lo,
  local (c_stack c) i_id lo /\
  local (c_stack c) hi_id hi /\
  local (c_stack c) lo_id lo /\
  bounds lo hi /\
  sint lo < sint hi /\
  sint hi - sint lo <= z /\
  lin z phi
).

apply sound_seq with
  (Q := fun _ => i_lo).
unfold i_lo. destruct o; intros; destroids; auto.

(* 1.1. prove the assignment to i *)
{ eapply weak_pre; [| apply sound_lset ].
  unfold i_lo; simpl; intros.
  destruct H as [hi [lo ?]]; destroids.
  exists hi. exists lo.
  destruct H1; split.
  unfold local. rewrite PTree.gss.
    f_equal.
    eapply Clight.eval_expr_determ; eauto.
    constructor; auto.
  repeat split; t i_lo.
}

apply sound_seq with
  (Q := fun _ => i_lo).
unfold i_lo. destruct o; intros; destroids; auto.

(* 1.2. prove the assignment to j *)
repeat (t i_lo).

apply sound_seq with
  (Q := fun _ => i_lo).
unfold i_lo. destruct o; intros; destroids; auto.

(* 1.3. prove the assignment to pivot *)
repeat (t i_lo).

unfold i_lo; clear i_lo.
pose (i_mid z (c: conf) phi := exists hi lo ni,
  local (c_stack c) i_id ni /\
  local (c_stack c) hi_id hi /\
  local (c_stack c) lo_id lo /\
  bounds lo hi /\
  sint lo <= sint ni <= sint hi /\
  sint lo < sint hi /\
  sint hi - sint lo <= z /\
  lin z phi
).

apply sound_seq with
  (Q := fun _ => i_mid).
unfold i_mid. destruct o; intros; destroids; auto.

(* 1.4. prove the inner loop *)
{ pose (frame hi lo z phi :=
    sint lo < sint hi /\
    bounds lo hi /\
    sint hi - sint lo <= z /\
    lin z phi
  ).

  eapply weak_pre.
  2: eapply weak_post.
  3: apply (inner_loop_valid frame).

  unfold frame; intros.
  destroids; repeat eexists; eauto; omega.

  unfold frame; intros.
  destroids; repeat eexists; eauto; omega.
}

apply sound_seq with
  (Q := fun _ => i_mid).
unfold i_mid. destruct o; intros; destroids; auto.

(* 1.5. prove the swap correct *)
unfold swap; repeat (t i_mid).

pose (stack_frame z s := exists hi lo ni,
  local s i_id ni /\
  local s hi_id hi /\
  local s lo_id lo /\
  bounds lo hi /\
  sint lo <= sint ni <= sint hi /\
  sint lo < sint hi /\
  sint hi - sint lo <= z + 1
).

apply sound_seq with
  (Q := fun _ => i_mid).
unfold i_mid. destruct o; intros; destroids; auto.

(* 1.6. prove the first recursive call correct *)
{ eapply sound_consequence;
   [| eapply sound_call1; eauto ].
  2: reflexivity.
  instantiate (1 := stack_frame).

  unfold wk, enter, leave, pls, i_mid, stack_frame;
   revert FNN; clear; intros.
  exists (z - 1); split; intros.

  + destruct H as [hi [lo [ni ?]]]; destroids.
    assert (RFRAME: F qsort_id <= Z.of_nat r).
    { unfold lin in *.
      assert (1 * F qsort_id <= z * F qsort_id).
      apply Z.mul_le_mono_nonneg_r; auto; omega.
      omega.
    }

    exists (Z.to_nat (Z.of_nat r - F qsort_id)).
    repeat split; auto; intros.
    repeat match goal with
      [ H: evall _ _ _ _ |- _ ] => inv H end.
    exploit eval_local; eauto.
    exploit eval_i_sub_one_bounds; eauto.
    intros [? [SINT BOUNDS']] ?; subst.
    repeat eexists; auto. omega.
    unfold lin in *.
    repeat zomg.

    repeat eexists; eauto. omega.

    apply Nat2Z.inj. repeat zomg.

  + destruct o; try tauto.
    clear H. destroids.
    inv H. inv H10.
    repeat eexists; eauto. omega.
    unfold lin in *; repeat zomg.
    repeat eexists; eauto. omega.
    unfold lin in *; repeat zomg.
}

apply sound_seq with
  (Q := fun _ => i_mid).
unfold i_mid. destruct o; intros; destroids; auto.

(* 1.7. prove the second recursive call correct *)
{ eapply sound_consequence;
   [| eapply sound_call1; eauto ].
  2: reflexivity.
  instantiate (1 := stack_frame).

  unfold wk, enter, leave, pls, i_mid, stack_frame;
   revert FNN; clear; intros.
  exists (z - 1); split; intros.

  + destruct H as [hi [lo [ni ?]]]; destroids.
    assert (RFRAME: F qsort_id <= Z.of_nat r).
    { unfold lin in *.
      assert (1 * F qsort_id <= z * F qsort_id).
      apply Z.mul_le_mono_nonneg_r; auto; omega.
      omega.
    }

    exists (Z.to_nat (Z.of_nat r - F qsort_id)).
    repeat split; auto; intros.
    repeat match goal with
      [ H: evall _ _ _ _ |- _ ] => inv H end.
    clear H1. exploit eval_local; eauto.
    exploit eval_i_add_one_bounds; eauto.
    intros [? [SINT BOUNDS']] ?; subst.
    repeat eexists; auto. omega.
    unfold lin in *. repeat zomg.

    repeat eexists; eauto. omega.

    apply Nat2Z.inj. repeat zomg.

  + destruct o; try tauto.
    clear H. destroids.
    inv H. inv H10.
    repeat eexists; eauto. omega.
    unfold lin in *; repeat zomg.
    repeat eexists; eauto. omega.
    unfold lin in *; repeat zomg.
}

unfold i_mid; clear i_mid stack_frame.

(* 1.8. prove the last return statement *)
{ eapply weak_pre; [| apply sound_ret ].
  intros; destroids; auto.
}

(* 2. prove the implicit return in the else branch *)
{ eapply weak_pre; [| apply sound_ret ].
  unfold ifP; intros; destroids; auto.
}
Qed.

End QUICKSORT.