Require Import Coq.Program.Program.
Require Import Coq.Program.Tactics.
Require Import Coq.Classes.Morphisms.
Require Import Coq.Reals.Reals.
Require Import Coquelicot.Rbar.
Require Import Coquelicot.Lim_seq.
Require Import Autosubst.Autosubst.
Require Import Coq.Logic.Decidable.

Require Import Biorthogonality.Basics.
Require Import Biorthogonality.Measures.
Require Import Biorthogonality.Syntax.
Require Import Biorthogonality.OpSem.
Require Import Biorthogonality.MeasSem.

Set Bullet Behavior "Strict Subproofs".

Local Open Scope nat.

Local Obligation Tactic := idtac.
Program Fixpoint find_smallest_helper
        {P : nat -> Prop}
        (P_dec : forall n, decidable (P n))
        (cur : nat)
        (n : nat)
        (Hcur : (forall i, i < cur -> ~ P i) -> (forall i, i < n -> ~ P i))
        (Hn : P n) :
  exists n, P n /\ forall i, i < n -> ~ P i :=
  match cur with
  | 0 =>
    match P_dec 0 with
    | or_introl yes => ex_intro _ 0 _
    | or_intror no => ex_intro _ n _
    end
  | S cur' =>
    match P_dec cur' with
    | or_introl yes => find_smallest_helper P_dec cur' cur' id yes
    | or_intror no => find_smallest_helper P_dec cur' n _ Hn
    end
  end.
Obligation 1. program_simpl. Qed.
Obligation 2. program_simpl. Qed.
Obligation 3.
intros.
subst.
apply Hcur; auto.
intros.
inversion H1; subst; auto.
Qed.

Definition find_smallest
           {P : nat -> Prop}
           (P_dec : forall n, decidable (P n))
           (n : nat)
           (Hn : P n) :
  exists n, P n /\ forall i, i < n -> ~ P i :=
  find_smallest_helper P_dec n n id Hn.

Definition ex_least (P : nat -> Prop) :=
  exists j, P j /\ (forall j', P j' -> j <= j').

Notation "'exists_least' j , P" := (ex_least (fun j => P)) (at level 200).

Lemma smallest_alt : forall {P : nat -> Prop},
    (exists n, P n /\ forall i, i < n -> ~ P i) ->
    exists_least n, P n.
Proof.
  intros.
  destruct H as [n Hn].
  exists n.
  intuition auto.
  destruct (lt_dec j' n); auto.
  exfalso.
  apply H0 in H1; auto.
Qed.

Definition find_smallest_alt
           {P : nat -> Prop}
           (P_dec : forall n, decidable (P n))
           (H : exists n, P n) :
  exists_least n, P n :=
  let (n,Hn) := H in smallest_alt (find_smallest P_dec n Hn).
Opaque find_smallest_alt.

(* Definition 4.3 *)
Inductive K_gt : Kont -> Entropy -> Kont -> Entropy -> Prop :=
| K_nil : forall K σ, K_gt K σ K σ
| K_cons : forall K1 σ1 K2 σ2 e σ,
    K_gt K2 σ2 K1 σ1 ->
    K_gt (e-:K2) (σ#σ2) K1 σ1.

Local Hint Constructors K_gt.

Definition ConfigClosed c :=
  match c with
  | mkConfiguration (Configuration_more _ e K _) _ => ECLOSED e /\ KCLOSED K
  | mkConfiguration (Configuration_done _) _ => True
  end.

Lemma step_closed : forall c,
    ConfigClosed c ->
    match step c with
    | None => True
    | Some c' => ConfigClosed c'
    end.
Proof.
  intros.
  unfold ConfigClosed in H.
  destruct c.
  destruct c; try solve [cbn; auto].
  solve_step e K H.
  - cbn.
    destruct K; cbn; intuition auto.
    + inversion H1; subst.
      apply -> sub_preserves_scope_exp; eauto.
    + inversion H1; subst.
      auto.
  - destruct K; cbn; intuition auto.
    + inversion H1; subst.
      apply -> sub_preserves_scope_exp; eauto.
    + inversion H1; subst.
      auto.
  - cbn.
    destruct e1; cbn; intuition auto.
    inversion H1; subst.
    + apply -> sub_preserves_scope_exp; eauto.
    + apply -> sub_preserves_scope_exp; eauto.
Qed.

Lemma run_closed : forall n c,
    ConfigClosed c ->
    match run n c with
    | None => True
    | Some c' => ConfigClosed c'
    end.
Proof.
  induction n; intros; auto.
  destruct c.
  destruct c; auto.
  destruct e;
    try solve_inversion;
    auto;
    try solve
        [cbn;
         destruct K;
         try destruct e1;
         try (destruct e; auto;
              destruct Rlt_dec; auto);
         try
         auto;
         apply IHn;
         cbn;
         auto;
         inversion H;
         inversion H1; subst;
         try (inversion H0; subst);
         intuition auto;
         try solve_inversion;
         apply -> sub_preserves_scope_exp;
         eauto].
  - unfold δ1;
      destruct e;
      destruct e0;
      cbn;
      try destruct Req_EM_T;
      cbn;
      auto;
      apply IHn;
      inversion H; subst;
      repeat (constructor; auto).
  - unfold δ2;
      destruct e1, e2, e3;
      cbn;
      try destruct Req_EM_T;
      try destruct Rle_dec;
      try destruct Rlt_dec;
      auto;
      apply IHn;
      inversion H; subst;
      repeat (constructor; auto).
  - inversion H; subst.
    inversion H0; subst;
      destruct e1;
      cbn;
      try destruct Rlt_dec;
      auto;
      apply IHn;
      repeat (constructor; eauto).
Qed.

Fixpoint Kont_end (K : Kont) (σ : Entropy) : Entropy :=
  match K with
  | Knil => σ
  | Kcons e K' => Kont_end K' (Entropy_π2 σ)
  end.

Lemma run_Kont_determined : forall {n σ1 e1 K1 σ1' w1
                                      σ2 e2 K2 σ2' w2},
    run n ⟨ σ1 | e1 | K1 | σ1' | w1 ⟩ = Some ⟨ σ2 | e2 | K2 | σ2' | w2 ⟩ ->
    Kont_end K1 σ1' = Kont_end K2 σ2'.
Proof.
  induction n; intros.
  - cbn in H.
    inversion H; subst; intuition.
  - solve_run e1 K1 n H.
    apply IHn in H.
    cbn in H.
    rewrite interpolate_project_2 in H.
    auto.
Qed.

Lemma run_Knil_determined : forall {n σ1 e1 σ1' w1
                                      σ2 e2 σ2' w2},
    run n ⟨ σ1 | e1 | Knil | σ1' | w1 ⟩ = Some ⟨ σ2 | e2 | Knil | σ2' | w2 ⟩ ->
    σ1' = σ2'.
Proof.
  intros.
  apply run_Kont_determined in H.
  inversion H; subst; auto.
Qed.

Definition ConfigKont_picked (c : Configuration) j :=
  match c, run j c with
  | mkConfiguration (Configuration_more _ _ K0 σK0) _,
    Some (mkConfiguration (Configuration_more _ ej Kj σKj) _) =>
    VCLOSED ej /\ Kj = K0 /\ σKj = σK0
  | _, _ => False
  end.

Lemma ConfigKont_picked_dec (c : Configuration) : forall j,
    decidable (ConfigKont_picked c j).
Proof.
  intros.
  unfold decidable.
  unfold ConfigKont_picked.
  destruct c.
  destruct c; auto.
  remember (run j ⟨ σ | e | K | σK | w ⟩) as c.
  destruct c; auto.
  destruct c; auto.
  destruct c; auto.
  destruct (ValScoped_dec e0 0); [|right; intuition auto].
  destruct (Kont_eq_dec K0 K); [|right; intuition auto].
  destruct (Entropy_eq_dec σK0 σK); [|right; intuition auto].
  subst.
  left; intuition.
Qed.

Lemma run_fixpoint : forall n c v w,
    run n c = Some ⟨ v@w ⟩ ->
    run (S n) c = Some ⟨ v@w ⟩.
Proof.
  intros.
  replace (S n) with (n + 1) by auto.
  eapply run_transitive.
  apply H.
  cbn.
  auto.
Qed.

(* Lemma 4.4 {lemma-continuations-are-continuous} *)
Lemma continuations_are_continuous : forall i c,
    ConfigClosed c ->
    match c, run i c with
    | mkConfiguration (Configuration_more σ0 e0 K0 σK0) w0,
      Some (mkConfiguration (Configuration_more σi ei Ki σKi) wi) =>
      (exists_least j, j <= i /\ ConfigKont_picked c j) \/
      K_gt Ki σKi K0 σK0
    | _,_ => True
    end.
Proof.
  (** By induction on i. *)
  induction i;
    intros c0 Hclosed;
    destruct c0 as [[|σ0 e0 K0 σK0] w0];
    try solve [cbn; auto].
  remember (run (S i) ⟨ σ0 | e0 | K0 | σK0 | w0 ⟩) as cSi eqn:HcSi;
    destruct cSi as [[[|σSi eSi KSi σKSi] wSi]|];
    auto.
  (** Assume the proposition holds at i (IHi) and check at i+1. *)
  (* take apart (ci i) *)
  remember (run i ⟨ σ0 | e0 | K0 | σK0 | w0 ⟩) as ci eqn:Hci.
  destruct ci as [[[|σi ei Ki σKi] wi]|].
  { (* can't be final, there is a following step *)
    exfalso.
    symmetry in Hci.
    apply run_fixpoint in Hci.
    rewrite Hci in HcSi.
    inversion HcSi.
  }
  {
    specialize (IHi ⟨ σ0 | e0 | K0 | σK0 | w0 ⟩).
    specialize (IHi Hclosed).
    cbn in IHi.
    rewrite <- Hci in IHi.
    destruct IHi.
    { (** If property (a) holds for some j <= i, then (a) holds at i+1. *)
      left.
      destruct H as [j Hj].
      exists j.
      intuition auto.
      (* This is more complicated than the paper makes it seem. *)
      inversion H3; auto.
    }
    (* Assume property (b) holds at i. *)
    apply (run_closed i) in Hclosed.
    rewrite <- Hci in Hclosed.
    inversion Hclosed.
    inversion H0;
      subst;
      try solve                 (* not a value *)
          [right;
           replace (S i) with (i + 1) in HcSi by auto;
           erewrite run_transitive in HcSi; revgoals; eauto;
           cbn in HcSi;
           try (inversion H2; subst; auto);
           try (destruct Rlt_dec; auto);
           inversion HcSi; subst;
           inversion H; subst; auto].
    - right.                    (* Op1: not a value *)
      replace (S i) with (i + 1) in HcSi by auto.
      erewrite run_transitive in HcSi; eauto.
      destruct o, v; auto; cbn in HcSi;
        try destruct Req_EM_T; cbn in HcSi; auto;
          inversion HcSi; subst; auto.
    - right.                    (* Op2: not a value *)
      replace (S i) with (i + 1) in HcSi by auto.
      erewrite run_transitive in HcSi; eauto.
      destruct o, v1, v2; auto; cbn in HcSi;
        try destruct Req_EM_T;
        try destruct Rle_dec;
        try destruct Rlt_dec;
        cbn in HcSi; auto;
          inversion HcSi; subst; auto.
    -
      (* is a value *)
      inversion H; subst; auto.
      + (* rule 1 *)
        left.
        assert (exists j : nat, (j <= S i /\ ConfigKont_picked ⟨ σ0 | e0 | K0 | σK0 | w0 ⟩ j)).
        { exists i.
          intuition auto.
          unfold ConfigKont_picked.
          rewrite <- Hci.
          intuition idtac.
        }
        apply find_smallest_alt; auto.
        intros.
        unfold decidable.
        destruct (ConfigKont_picked_dec ⟨ σ0 | e0 | K0 | σK0 | w0 ⟩ n);
          destruct (le_dec n (S i));
          intuition auto.
      + (* rule 2 *)
        right.
        replace (S i) with (i + 1) in HcSi by auto.
        symmetry in HcSi.
        eapply run_intermediate_exists in HcSi.
        destruct HcSi.
        destruct H4.
        rewrite H4 in Hci.
        inversion Hci; subst.
        clear Hci.
        destruct ei;
          try solve_inversion.
        * cbn in H5.
          inversion H5; subst.
          clear H5.
          rewrite interpolate_project_2.
          auto.
        * cbn in H5.
          inversion H5; subst.
          clear H5.
          rewrite interpolate_project_2.
          auto.
  }
  { exfalso.
    replace (S i) with (i + 1) in HcSi by auto.
    symmetry in HcSi.
    eapply run_intermediate_exists in HcSi.
    destruct HcSi.
    destruct H.
    rewrite H in Hci.
    solve_inversion.
  }
Qed.

(* Theorem 4.5 {thm-interpolation} *)
Theorem interpolation : forall σ1 e1 K1 σ1' w1
                               σ3 e3 σ3' w3 n,
    ECLOSED e1 ->
    KCLOSED K1 ->
    VCLOSED e3 ->
    run n ⟨σ1|e1|K1|σ1'|w1⟩ = Some ⟨σ3|e3|Knil|σ3'|w3⟩ ->
    exists_least j, exists σ2 v w2,
      VCLOSED v /\
      run j ⟨σ1|e1|K1|σ1'|w1⟩ = Some ⟨σ2|v|K1|σ1'|w2⟩ /\
      run (n-j) ⟨σ2|v|K1|σ1'|w2⟩ = Some ⟨σ3|e3|Knil|σ3'|w3⟩.
Proof.
  intros.
  apply find_smallest_alt; revgoals.
  { destruct K1.
    - exists n.
      replace (n - n) with 0 by auto.
      destruct (run_Knil_determined H2); subst.
      repeat eexists; eauto.
    - assert
        (forall z j : nat,
            match run z ⟨ σ1 | e1 | e -: K1 | σ1' | w1 ⟩ with
            | Some cz => run j cz = run (j + z) ⟨ σ1 | e1 | e -: K1 | σ1' | w1 ⟩
            | None => None = run (j + z) ⟨ σ1 | e1 | e -: K1 | σ1' | w1 ⟩
            end).
      { intros.
        remember (run z ⟨ σ1 | e1 | e -: K1 | σ1' | w1 ⟩) as runz.
        destruct runz.
        - replace (j + z) with (z + j) by ring.
          erewrite run_transitive; eauto.
        - induction j; auto.
          simpl (S j + z).
          symmetry.
          apply run_index_monotonic_None.
          auto.
      }
      assert (ConfigClosed ⟨ σ1 | e1 | e -: K1 | σ1' | w1 ⟩)
        by (constructor; auto).
      pose proof (continuations_are_continuous n ⟨ σ1 | e1 | e -: K1 | σ1' | w1 ⟩ H4)
        as Hcont.
      cbn in Hcont.
      remember (run n ⟨ σ1 | e1 | e -: K1 | σ1' | w1 ⟩) as run_n.
      destruct run_n; try solve_inversion.
      destruct c.
      destruct c; try solve_inversion.
      inversion H2; subst; clear H2.
      inversion Hcont; subst; try solve_inversion.
      destruct H2.
      remember (run x ⟨ σ1 | e1 | e -: K1 | σ1' | w1 ⟩) as run_x.
      destruct run_x; intuition auto; try solve_inversion.
      destruct c; intuition auto.
      destruct c; intuition auto.
      subst.
      exists x.
      exists σ.
      exists e0.
      exists w.
      split; [|split]; auto.
      eapply run_intermediate; eauto.
  }
  intros.
  remember (run n0 ⟨ σ1 | e1 | K1 | σ1' | w1 ⟩) as c.
  destruct c; revgoals.
  { right.
    intro.
    destruct H3 as [? [? [? [? [? ?]]]]].
    inversion H4.
  }
  destruct c.
  destruct c.
  { right.
    intro.
    destruct H3 as [? [? [? [? [? ?]]]]].
    inversion H4.
  }
  destruct (ValScoped_dec e 0); revgoals.
  { right.
    intro.
    destruct H4 as [? [? [? [? [? ?]]]]].
    inversion H5; subst.
    auto.
  }
  assert (decidable (run (n - n0) ⟨ σ | e | K1 | σ1' | w ⟩ =
                     Some ⟨ σ3 | e3 | Knil | σ3' | w3 ⟩)).
  { remember (run (n - n0) ⟨ σ | e | K1 | σ1' | w ⟩) as c.
    destruct c; [|right; intro; solve_inversion].
    destruct c.
    destruct c; [right; intro; solve_inversion|].
    destruct (Entropy_eq_dec σ0 σ3);
      [|right; intro Hfalse; inversion Hfalse];
      subst;
      auto.
    destruct (Expr_eq_dec e0 e3);
      [|right; intro Hfalse; inversion Hfalse];
      subst;
      auto.
    destruct (Kont_eq_dec K0 Knil);
      [|right; intro Hfalse; inversion Hfalse];
      subst;
      auto.
    destruct (Entropy_eq_dec σK0 σ3');
      [|right; intro Hfalse; inversion Hfalse];
      subst;
      auto.
    destruct (Req_dec w0 w3);
      [|right; intro Hfalse; inversion Hfalse];
      subst;
      auto.
    left.
    auto.
  }
  inversion H4; revgoals.
  { right.
    intro.
    destruct H6 as [? [? [? [? [? ?]]]]].
    inversion H7; subst.
    auto.
  }
  destruct (Kont_eq_dec K K1); revgoals.
  { right.
    intro.
    destruct H7 as [? [? [? [? [? ?]]]]].
    inversion H8.
    auto.
  }
  subst.
  destruct (Entropy_eq_dec σK σ1'); revgoals.
  { right.
    intro.
    destruct H7 as [? [? [? [? [? ?]]]]].
    inversion H8.
    auto.
  }
  subst.
  left.
  exists σ.
  exists e.
  exists w.
  intuition auto.
Qed.

Inductive B (K1 K2 : Kont) (τ1 τ2 : Entropy) :
  Kont -> Entropy -> Kont -> Entropy -> Prop :=
| B_nil : B K1 K2 τ1 τ2 K1 τ1 K2 τ2
| B_cons : forall K K' τ τ' e σ,
    B K1 K2 τ1 τ2 K τ K' τ' ->
    B K1 K2 τ1 τ2 (e-:K) (σ#τ) (e-:K') (σ#τ').

Inductive RR (K1 K2 : Kont) (τ1 τ2 : Entropy) (r: R) :
  option Configuration -> option Configuration -> Prop :=
| RR_intro : forall σ e w K K' τ τ',
    B K1 K2 τ1 τ2 K τ K' τ' ->
    RR K1 K2 τ1 τ2 r (Some ⟨σ|e|K|τ|w⟩) (Some ⟨σ|e|K'|τ'|w * r⟩).

Fixpoint Kont_length (K : Kont) : nat :=
  match K with
  | Knil => 0
  | Kcons e K' => S (Kont_length K')
  end.

Lemma Kont_occurs : forall (x : Expr) (xs : Kont),
    x-:xs <> xs.
Proof.
  intros.
  intro.
  induction xs.
  - inversion H.
  - contradict IHxs.
    inversion H; subst.
    rewrite H2.
    rewrite H2.
    auto.
Qed.

Lemma B_length : forall K1 τ1 K2 τ2
                        K τ K' τ',
    B K1 K2 τ1 τ2 K τ K' τ' ->
    Kont_length K1 <= Kont_length K.
Proof.
  intros.
  dependent induction H; subst.
  - auto.
  - cbn.
    rewrite IHB; eauto.
Qed.

Lemma B_no_smaller : forall eK1 K1 τ1
                            K2 τ2 τ
                            K' τ',
    ~ (B (eK1 -: K1) K2 τ1 τ2 K1 τ K' τ').
Proof.
  intros.
  intro.
  apply B_length in H.
  cbn in H.
  auto.
Qed.

Theorem genericity : forall n σ σ' e v w' K1 K2 τ1 τ2 w1 w2,
    (w1 <> 0)%R ->
    ECLOSED e ->
    KCLOSED K1 ->
    KCLOSED K2 ->
    VCLOSED v ->
    run n ⟨σ|e|K1|τ1|w1⟩ = Some ⟨σ'|v|K1|τ1|w'*w1⟩ ->
    (forall i σ' v w',
        VCLOSED v ->
        run i ⟨σ|e|K1|τ1|w1⟩ = Some ⟨σ'|v|K1|τ1|w'*w1⟩ ->
        n <= i) ->
    run n ⟨σ|e|K2|τ2|w2⟩ = Some ⟨σ'|v|K2|τ2|w'*w2⟩.
Proof.
  intros.
  enough (forall i (Hi : i <= n),
             RR K1 K2 τ1 τ2 (w2/w1)
                (run i ⟨ σ | e | K1 | τ1 | w1 ⟩)
                (run i ⟨ σ | e | K2 | τ2 | w2 ⟩)).
  { specialize (H6 n (le_refl _)).
    rewrite H4 in H6.
    inversion H6; subst.
    inversion H8; subst.
    - field_simplify (w' * w1 * (w2 / w1))%R; auto.
      replace (w' * w2 / 1)%R with (w' * w2)%R by (field; auto).
      auto.
    - apply B_no_smaller in H7.
      auto.
  }
  intro i.
  (* revert w1 w2 τ1 τ2 K1 K2 w' e v σ σ' n H5 H4 H3 H2 H1 H0 H. *)
  induction i;
    intros.
  - cbn.
    replace w2 with (w1 * (w2/w1))%R at 2 by (field; auto).
    constructor.
    constructor.
  - specialize (IHi ltac:(auto)).
    replace n with (S i + (n - S i)) in H4 by auto.
    destruct (run_intermediate_exists H4) as [c2 [HSi_c2 _]].

    replace (S i) with (i + 1) in HSi_c2 by auto.
    destruct (run_intermediate_exists HSi_c2) as [c2' [Hi_c2 HSi_c2']].

    replace (i + 1) with (S i) in HSi_c2 by auto.
    rewrite <- HSi_c2' in HSi_c2.
    rewrite HSi_c2.
    inversion IHi.
    inversion H8; subst.
    + symmetry in H6.
      symmetry in H7.
      rewrite H6 in Hi_c2.
      pose proof H7.
      inversion Hi_c2; subst.
      eapply run_transitive with (n2:=1) in H7;
        try solve [reflexivity].
      replace (i + 1) with (S i) in H7 by auto.
      rewrite H7.
      destruct e0; auto;
        try solve_inversion;
        try solve [cbn; repeat constructor].
      * exfalso.
        replace w with ((w/w1) * w1)%R in H6 by (field; auto).
        specialize (H5 _ _ _ _ ltac:(auto) H6).
        auto.
      * exfalso.
        pose proof H6 as Henv.
        eapply run_preserves_environment in Henv; eauto.
        replace w with ((w/w1) * w1)%R in H6 by (field; auto).
        eapply H5 in H6; intuition auto.
      * destruct e0_1; auto; try solve_inversion.
        cbn.
        constructor.
        constructor.
      * destruct e0, e1; auto;
          cbn;
          cbn in HSi_c2';
          try destruct Req_EM_T;
          subst;
          try solve_inversion;
          auto;
          constructor;
          constructor.
      * destruct e0, e0_1, e0_2; auto;
          cbn;
          cbn in HSi_c2';
          try destruct Req_EM_T;
          try destruct Rle_dec;
          try destruct Rlt_dec;
          subst;
          try solve_inversion;
          auto;
          constructor;
          constructor.
      * destruct e0_1; auto;
          cbn;
          cbn in HSi_c2';
          try destruct Rlt_dec;
          subst;
          try solve_inversion;
          auto;
          constructor;
          constructor.
      * cbn.
        cbn in HSi_c2'.
        destruct e0; try solve_inversion.
        destruct Rlt_dec; try solve_inversion.
        replace (w * (w2 / w1) * r)%R with (w * r * (w2 / w1))%R by ring.
        constructor.
        constructor.
    + symmetry in H6.
      symmetry in H7.
      rewrite H6 in IHi.
      rewrite H7 in IHi.
      pose proof Hi_c2.
      rewrite H6 in Hi_c2.
      inversion Hi_c2; subst.
      clear Hi_c2.
      eapply run_transitive with (n2:=1) in H7;
        try solve [reflexivity].
      replace (i + 1) with (S i) in H7 by auto.
      rewrite H7.
      destruct e0;
        try solve_inversion;
        try solve [cbn; econstructor; eauto].
      * cbn.
        repeat rewrite interpolate_project_2.
        repeat rewrite interpolate_project_1.
        constructor.
        inversion H9; subst; auto.
      * cbn.
        repeat rewrite interpolate_project_2.
        repeat rewrite interpolate_project_1.
        constructor.
        inversion H9; subst; auto.
      * cbn.
        destruct e0_1; try solve_inversion.
        constructor.
        constructor.
        auto.
      * cbn.
        constructor.
        constructor.
        constructor.
        auto.
      * destruct e0, e2;
          cbn;
          cbn in HSi_c2';
          try destruct Req_EM_T;
          subst;
          try solve_inversion;
          auto;
          constructor;
          constructor;
          auto.
      * destruct e0, e0_1, e0_2;
          try solve [cbn in HSi_c2'; inversion HSi_c2'];
          cbn;
          cbn in HSi_c2';
          try destruct Req_EM_T;
          try destruct Rle_dec;
          try destruct Rlt_dec;
          subst;
          try solve_inversion;
          auto;
          constructor;
          constructor;
          auto.
      * destruct e0_1;
          cbn;
          cbn in HSi_c2';
          try destruct Rlt_dec;
          subst;
          try solve_inversion;
          auto;
          constructor;
          constructor;
          auto.
      * cbn in *.
        destruct e0; try solve_inversion.
        destruct Rlt_dec; try solve_inversion.
        replace (w * (w2 / w1) * r)%R with (w * r * (w2 / w1))%R by ring.
        constructor.
        constructor.
        auto.
Qed.


From Ornamental Require Import Ornaments.

Set DEVOID search prove equivalence.
Set DEVOID lift type.

Module SCS.
  Definition fst {A B} := @fst A B.
  Definition snd {A B} := @snd A B.
End SCS.

Module SN.

  Definition h : Type := (bool * nat).

  Definition c : Type := (nat * (nat * (bool * ((bool * nat) * nat)))).

  Definition f (h : h) (c : c) : bool :=
    andb (fst h) (fst (snd (snd c))).

End SN.

Preprocess Module SN as SN_PP { opaque andb }.

Module H.

  Record H :=
    {
      b : bool;
      n : nat;
    }.

  Scheme Induction for H Sort Prop.
  Scheme Induction for H Sort Type.
  Scheme Induction for H Sort Set.

  (* We'd like to wrap the ugly access into this: *)
  Definition get_h_b (h : SN.h) : bool := fst h.

End H.

Preprocess Module H as H_PP.

Lift SN_PP.h H_PP.H in H_PP.get_h_b as getHB.
Lift SN_PP.h H_PP.H in SN_PP.f as f_PP { opaque andb }.

Definition get_h_b_expected (h : SN_PP.h) :=
  Prod.fst _ _ h.

Arguments SN_PP.Coq_Init_Datatypes_fst [A B].
Arguments SN_PP.Coq_Init_Datatypes_snd [A B].

Notation "'fst_PP' x" := (SN_PP.Coq_Init_Datatypes_fst x) (at level 50, only printing).
Notation "'snd_PP' x" := (SN_PP.Coq_Init_Datatypes_snd x) (at level 50, only printing).

Print f_PP.

Definition f_PP_expected (h : H_PP.H) (c : nat * (nat * (bool * (H_PP.H * nat)))) : bool :=
 H_PP.b h
 &&
 SN_PP.Coq_Init_Datatypes_fst bool (H_PP.H * nat)
   (SN_PP.Coq_Init_Datatypes_snd nat (bool * (H_PP.H * nat))
                                 (SN_PP.Coq_Init_Datatypes_snd nat (nat * (bool * (H_PP.H * nat))) c)).

Lemma test_f_PP:
  f_PP = f_PP_expected.
Proof.
  unfold f_PP, f_PP_expected.
  match goal with
  | |- ?x = ?x => reflexivity
  | _ => idtac
  end.
Qed.

Print f_PP.

(*
Output:

f_PP =
fun (h : H_PP.H) (c : nat * (nat * (bool * (H_PP.H * nat)))) =>
(H_PP.H_rect (fun _ : H_PP.H => bool) (fun (b : bool) (_ : nat) => b) h &&
 prod_rect (fun _ : bool * (H_PP.H * nat) => bool) (fun (a : bool) (_ : H_PP.H * nat) => a)
   (prod_rect (fun _ : nat * (bool * (H_PP.H * nat)) => (bool * (H_PP.H * nat))%type)
      (fun (_ : nat) (b : bool * (H_PP.H * nat)) => b)
      (prod_rect (fun _ : nat * (nat * (bool * (H_PP.H * nat))) => (nat * (bool * (H_PP.H * nat)))%type)
         (fun (_ : nat) (b : nat * (bool * (H_PP.H * nat))) => b) c)))%bool
     : H_PP.H -> nat * (nat * (bool * (H_PP.H * nat))) -> bool

Ideally, I'd love to have:

 *)

Definition f_PP_ideal
  : H_PP.H -> nat * (nat * (bool * (H_PP.H * nat))) -> bool
  := fun h c => (getHB h && (fst (snd (snd c))))%bool.

(*
Two differences:

- [H_PP.H_rect (fun _ : H_PP.H => bool) (fun (b : bool) (_ : nat) => b) h] is replaced with
   the lifted accessor [getHB].

- The other calls to [fst] and [snd] are somehow magically preserved, while
  the calls that participate in the lifting have been properly replaced.  This
  is hard, not sure how you can make it so smart...

 *)

Module C.

  Record C :=
    {
      n1 : nat;
      n2 : nat;
      b  : bool;
      h  : H_PP.H;
      n3 : nat;
    }.

  (* We'd like to wrap the ugly access into this: *)
  Definition get_c_b (c : SN.c) : bool := fst (snd (snd c)).

  Scheme Induction for C Sort Prop.
  Scheme Induction for C Sort Type.
  Scheme Induction for C Sort Set.

End C.

Preprocess Module C as C_PP.

Lift SN_PP.h H_PP.H in SN_PP.c as c_PP.

Lift SN_PP.h H_PP.H in C_PP.get_c_b as getCB0.
Lift c_PP C_PP.C in getCB0 as getCB.

Lift SN_PP.h H_PP.H in SN_PP.f as f0 { opaque andb }.

(* oh this is nice! f0 is defined to be f_PP! *)

Lift c_PP C_PP.C in f0 as f { opaque andb }.

Print f.

(*
  Output:

f =
fun (h : H_PP.H) (c : C_PP.C) =>
(H_PP.H_rect (fun _ : H_PP.H => bool) (fun (b : bool) (_ : nat) => b) h &&
 prod_rect (fun _ : bool * (H_PP.H * nat) => bool) (fun (a : bool) (_ : H_PP.H * nat) => a)
   (prod_rect (fun _ : nat * (bool * (H_PP.H * nat)) => (bool * (H_PP.H * nat))%type)
      (fun (_ : nat) (b : bool * (H_PP.H * nat)) => b)
      (C_PP.C_rect (fun _ : C_PP.C => (nat * (bool * (H_PP.H * nat)))%type)
         (fun (_ n2 : nat) (b : bool) (h0 : H_PP.H) (n3 : nat) => (n2, (b, (h0, n3)))) c)))%bool
     : H_PP.H -> C_PP.C -> bool

This has the type that I want, but the body of the function is a little too
verbose, due to calls to [fst] and [snd] not being opaque, and having been
replaced with the more verbose [prod_rect].

Ideally I'd love:

 *)

Definition f' (h : H_PP.H) (c : C_PP.C)
  : bool
  := (getHB h && getCB c)%bool.


Require Export CatSem.CAT.cat_INDEXED_TYPE.
Require Export CatSem.CAT.ind_potype.
Require Export CatSem.CAT.cat_TYPE_option.

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

Definition unit_passing (c : unit -> Type) t u
(y : (opt t c u)):
(option (c tt)).
intros.
destruct y.
destruct t0.
apply (Some c0).
apply (None).
Defined.

Definition unit_passing2 c t u (y : opt t c u) :
       (option (c tt)).
intros.
destruct u.
destruct y.
apply (Some c0).
apply None.
Defined.

Section bla.

Notation "'TT'":= (ITYPE unit).

Obligation Tactic := mauto.

(** a functor (unit -> Type) -> Type *)

Program Instance sunit_s : Functor_struct (C:=TT) (D:=TYPE)
    (Fobj:= fun V => V tt) (fun a b f => f tt).

Definition sunit : Functor TT TYPE := IT_proj tt.

(** a functor Type -> (unit -> Type) *)

Program Instance wunit_s : Functor_struct (C:=TYPE) (D:=TT)
     (Fobj := fun V => fun _ => V)(fun a b f => fun _ => f).

Definition wunit := Build_Functor wunit_s.

(** a functor (unit -> PO) -> PO  = (IPO unit) -> PO*)

Definition sunit_po : Functor (IPO unit) Ord := IP_proj tt.

(** a functor PO -> (IPO unit) *)

Program Instance wunit_ob_s (V : Ord):
    ipo_obj_struct (T:=unit)(fun _ => V) := {
  IRel t := Rel ;
  IPOprf t := POprf
}.

Definition wunit_ob V := Build_ipo_obj (wunit_ob_s V).

Obligation Tactic := cat; try unf_Proper; cat;
  repeat apply PO_mor_monotone; cat.

Program Instance wunit_mor_s (V W : Ord)(f : V ---> W) :
  ipo_mor_struct (a:=wunit_ob V) (b:=wunit_ob W)
  (fun t => f).

Definition wunit_mor V W (f:V--->W) :=
   Build_ipo_mor (wunit_mor_s _ _ f).

Obligation Tactic := mauto.

Program Instance wunit_po_s : Functor_struct (C:=Ord)(D:=IPO unit)
    (Fobj:=wunit_ob)
    (fun a b f => wunit_mor f).

Definition wunit_po : Functor Ord (IPO unit) := Build_Functor wunit_po_s.

End bla.


Require Export Predefs.
Require Export TLC.LibTactics.
Require Export TLC.LibLN.
Require Export GMu.Prelude.
Require Export Definitions.

Require Export Lists.List.
Export ListNotations.
Require Export ExampleTactics.

Notation "'{' A '==' T '}'" := (dec_typ A T T).
Coercion typ_rcd : dec >-> Target.typ.
Notation "'{(' a , .. , c ')}'" := (defs_cons (.. (defs_cons defs_nil a) ..) c).
Coercion trm_val  : val >-> trm.

Coercion defp : path >-> def_rhs.
Coercion defv : val >-> def_rhs.

Lemma intersection_order : forall G A1 B1 A2 B2,
    G ⊢ A1 <: A2 ->
    G ⊢ B1 <: B2 ->
    G ⊢ A1 ∧ B1 <: A2 ∧ B2.
Proof.
  intros.
  apply subtyp_and2.
  - apply subtyp_trans with A1; auto.
  - apply subtyp_trans with B1; auto.
Qed.

Notation "G ⊢ A =:= B" := (G ⊢ A <: B /\ G ⊢ B <: A) (at level 40, A at level 59).

Lemma eq_transitive : forall G A B C,
    G ⊢ A =:= B ->
    G ⊢ B =:= C ->
    G ⊢ A =:= C.
Proof.
  intros G X Y Z [] [].
  constructor;
    eapply subtyp_trans; eauto.
Qed.

Lemma eq_symmetry : forall G A B,
    G ⊢ A =:= B ->
    G ⊢ B =:= A.
Proof.
  intros G X Y [].
  constructor; auto.
Qed.

Lemma eq_reflexive : forall G A,
    G ⊢ A =:= A.
Proof.
  constructor;
    apply subtyp_refl.
Qed.

Lemma swap_typ : forall G X Y L T,
    G ⊢ trm_path (pvar Y) : {{pvar X}} ->
    G ⊢ trm_path (pvar X) : T ->
    G ⊢ pvar X ↓ L =:= pvar Y ↓ L.
Proof.
  intros.
  constructor.
  - eapply subtyp_sngl_qp with (p := pvar Y) (q := pvar X); eauto.
    assert (HR: pvar X = (pvar X) •• []) by crush.
    rewrite HR at 2.
    assert (HR2: pvar Y = (pvar Y) •• []) by crush.
    rewrite HR2 at 2.
    apply rpath.
  - eapply subtyp_sngl_pq with (p := pvar Y) (q := pvar X); eauto.
    assert (HR: pvar X = (pvar X) •• []) by crush.
    rewrite HR at 2.
    assert (HR2: pvar Y = (pvar Y) •• []) by crush.
    rewrite HR2 at 2.
    apply rpath.
Qed.

Lemma eq_sel : forall G p A T,
    G ⊢ trm_path p : typ_rcd { A == T } ->
    G ⊢ T =:= (p ↓ A).
Proof.
  intros.
  constructor.
  - eapply subtyp_sel2; eauto.
  - eapply subtyp_sel1; eauto.
Qed.

Lemma sub_and_assoc : forall G A B C,
    G ⊢ A ∧ (B ∧ C) <: (A ∧ B) ∧ C.
Proof.
  intros.
  apply subtyp_and2.
  + apply subtyp_and2.
    * apply subtyp_and11.
    * eapply subtyp_trans.
      -- apply subtyp_and12.
      -- apply subtyp_and11.
  + eapply subtyp_trans;
      apply subtyp_and12.
Qed.

Lemma sub_and_assoc2 : forall G A B C,
    G ⊢ (A ∧ B) ∧ C <: A ∧ (B ∧ C).
Proof.
  intros.
  apply subtyp_and2.
  + eapply subtyp_trans;
      apply subtyp_and11.
  + apply subtyp_and2.
    * eapply subtyp_trans.
      -- apply subtyp_and11.
      -- apply subtyp_and12.
    * apply subtyp_and12.
Qed.

Lemma eq_and_assoc : forall G A B C,
    G ⊢ A ∧ (B ∧ C) =:= (A ∧ B) ∧ C.
Proof.
  intros.
  constructor.
  - apply sub_and_assoc.
  - apply sub_and_assoc2.
Qed.

Lemma sub_and_comm : forall G A B,
    G ⊢ A ∧ B <: B ∧ A.
Proof.
  intros.
  apply subtyp_and2.
  - apply subtyp_and12.
  - apply subtyp_and11.
Qed.

Lemma eq_and_comm : forall G A B,
    G ⊢ A ∧ B =:= B ∧ A.
Proof.
  constructor; apply sub_and_comm.
Qed.

Lemma sub_and_merge : forall G A B C D,
    G ⊢ A <: B ->
    G ⊢ C <: D ->
    G ⊢ A ∧ C <: B ∧ D.
Proof.
  intros.
  apply subtyp_and2.
  - eapply subtyp_trans.
    + apply subtyp_and11.
    + auto.
  - eapply subtyp_trans.
    + apply subtyp_and12.
    + auto.
Qed.

Lemma eq_and_merge : forall G A B C D,
    G ⊢ A =:= B ->
    G ⊢ C =:= D ->
    G ⊢ A ∧ C =:= B ∧ D.
Proof.
  introv [] [].
  constructor; apply~ sub_and_merge.
Qed.

Lemma eq_and_bot : forall G A,
    G ⊢ A ∧ ⊥ =:= ⊥.
  auto.
Qed.

Lemma eq_and_top : forall G A,
    G ⊢ A ∧ ⊤ =:= A.
  auto.
Qed.

Lemma eq_and_self : forall G A,
    G ⊢ A ∧ A =:= A.
  auto.
Qed.

Lemma eq_and_bot_exfalso : forall G A B,
    G ⊢ A ∧ ⊥ =:= B ∧ ⊥.
Proof.
  constructor.
  - eapply subtyp_trans.
    + apply subtyp_and12.
    + apply subtyp_bot.
  - eapply subtyp_trans.
    + apply subtyp_and12.
    + apply subtyp_bot.
Qed.

Lemma sub_exfalso : forall G X Y,
    G ⊢ ⊤ <: ⊥ ->
    G ⊢ X <: Y.
Proof.
  intros.
  apply* subtyp_trans.
Qed.

Lemma eq_exfalso : forall G X Y,
    G ⊢ ⊤ =:= ⊥ ->
    G ⊢ X =:= Y.
Proof.
  introv [].
  constructor;
    apply~ sub_exfalso.
Qed.

Lemma eq_inv : forall G X1 X2 T1 T2 A,
    G ⊢ X1 =:= X2 ->
    X1 ↘ {A >: T1 <: T1} ->
    X2 ↘ {A >: T2 <: T2} ->
    G ⊢ T1 =:= T2.
Proof.
  introv [S1 S2]; intros.
  constructor.
  - lets*: subtyp_rcd_inv1.
  - lets*: subtyp_rcd_inv2.
Qed.

Lemma eq_inv_direct : forall G T1 T2 A,
    G ⊢ typ_rcd { A >: T1 <: T1 } =:= typ_rcd { A >: T2 <: T2 } ->
    G ⊢ T1 =:= T2.
Proof.
  introv EQ; intros.
  lets*: eq_inv EQ.
Qed.


From Equations Require Import EqDec DepElim NoConfusion.

(** Tactic to solve EqDec goals, destructing recursive calls for the recursive
  structure of the type and calling instances of eq_dec on other types. *)
Hint Extern 2 (@EqDecPoint ?A ?x) =>
  lazymatch goal with
  | [ H : forall y, { x = _ } + { _ <> _ } |- _ ] => exact H
  | [ H : forall y, dec_eq x y |- _ ] => exact H
  end : typeclass_instances.

Ltac eqdec_one x y :=
  let good := intros -> in
  let contrad := let Hn := fresh in
   intro Hn; right; red; simplify_dep_elim; apply Hn; reflexivity in
  try match goal with
       | [ H : forall z, dec_eq x z |- _ ] =>
         case (H y); [good|contrad]
        | [ H : forall z, { x = z } + { _ } |- _ ] =>
          case (H y); [good|contrad]
         | _ =>
           tryif unify x y then idtac (* " finished " x y *)
           else (case (eq_dec_point (x:=x) y); [good|contrad])
  end.

Ltac eqdec_loop t u :=
  match t with
  | context C [ ?t ?x ] =>
    match u with
    | context C [ ?u ?y] => eqdec_loop t u; eqdec_one x y
    end
   | _ => eqdec_one t u
  end.

Ltac eqdec_proof := try red; intros;
  match goal with
    |- dec_eq ?x ?y =>
    revert y; induction x; intros until y; depelim y;
    match goal with
      |- dec_eq ?x ?y => eqdec_loop x y
    end
   | |- { ?x = ?y } + { _ } =>
    revert y; induction x; intros until y; depelim y;
    match goal with
      |- { ?x = ?y } + { _ } => eqdec_loop x y
    end
  end; try solve[left; reflexivity | right; red; simplify_dep_elim].

(** Standard instances. *)

Instance unit_eqdec : EqDec unit.
Proof. eqdec_proof. Defined.

Instance bool_eqdec : EqDec bool.
Proof. eqdec_proof. Defined.

Instance nat_eqdec : EqDec nat.
Proof. eqdec_proof. Defined.

Instance prod_eqdec {A B} `(EqDec A) `(EqDec B) : EqDec (prod A B).
Proof. eqdec_proof. Defined.

Instance sum_eqdec {A B} `(EqDec A) `(EqDec B) : EqDec (A + B).
Proof. eqdec_proof. Defined.

Instance list_eqdec {A} `(EqDec A) : EqDec (list A).
Proof. eqdec_proof. Defined.

Instance sigma_eqdec {A B} `(EqDec A) `(forall x, EqDec (B x)) : EqDec {x : A & B x}.
Proof. eqdec_proof. Defined.

Polymorphic Definition eqdec_sig@{i j} {A : Type@{i}} {B : A -> Type@{j}}
            `(EqDec A) `(forall a, EqDec (B a)) :
  EqDec (sigma A B).
Proof.
  intros. intros [x0 x1] [y0 y1].
  case (eq_dec x0 y0). intros ->. case (eq_dec x1 y1). intros ->. left. reflexivity.
  intros. right. red. apply simplification_sigma2_dec@{i j Set}. apply n.
  intros. right. red. apply simplification_sigma1@{i j Set}.
  intros e _; revert e. apply n.
Defined.

Polymorphic Existing Instance eqdec_sig.


From Rela Require Import Vcg.
From Rela Require Import Com.
From Rela Require Import Sigma.
From Rela Require Import Hoare_Triple.
From Rela Require Import Rela.

From Coq Require Import Program.
From Coq Require Import Eqdep_dec.
From Coq Require Import Lists.List.
Import ListNotations.

(** Defintion of the verification condition generator for relational properties,
    using the verification condition generator for Hoare Triples **)

Definition r_suite : Type := list Sigma.sigma -> list history -> Prop.

Program Fixpoint rtc (cl : list com) (ml: list Sigma.sigma) (hl: list history)
            (cls: Phi.phi) (suite : r_suite)
            (hy1:length cl = length ml) (hy2:length cl = length hl): Prop :=
 match cl,ml,hl with
 | [],[],[] => suite [] []
 | c :: qc, m :: qm, h :: qh =>
   tc c m h cls (fun m' h' => rtc qc qm qh cls (fun lm lh => suite (m'::lm) (h' :: lh)) _ _)
 | _,_,_ => !
end.

Next Obligation.
destruct cl.
- simpl in hy1.
  symmetry in hy1.
  apply length_zero_iff_nil in hy1.
  simpl in hy2.
  symmetry in hy2.
  apply length_zero_iff_nil in hy2.
  subst ml hl.
  contradiction H0.
  split.
  reflexivity.
  split.
  reflexivity. reflexivity.
- destruct ml as [|m qm].
  discriminate hy1.
  destruct hl as [|h hm].
  discriminate hy2.
  eapply H.
  split.
  reflexivity.
  split.
  reflexivity. reflexivity.
Qed.

Next Obligation.
split.
intros.
intros contra.
destruct contra as (contra & _).
discriminate contra.
intros contra.
destruct contra as ( _ & contra).
destruct contra as ( _ & contra).
discriminate contra.
Defined.

Next Obligation.
split.
intros.
intros contra.
destruct contra as ( _ & contra).
destruct contra as (contra & _).
discriminate contra.
intros contra.
destruct contra as (contra & _).
discriminate contra.
Defined.

Next Obligation.
split.
intros.
intros contra.
destruct contra as (contra & _).
discriminate contra.
intros contra.
destruct contra as (_ & contra ).
destruct contra as (contra & _).
discriminate contra.
Defined.

Next Obligation.
split.
intros.
intros contra.
destruct contra as (_ & contra ).
destruct contra as (_ & contra ).
discriminate contra.
intros contra.
destruct contra as (contra & _).
discriminate contra.
Defined.

(** Connect between Hoare Triple and Relational Properties **)

Lemma hoare_rela :
forall (P: r_precondition) (Q: r_postcondition)
h q ps pi sl hl (hy1:length q = length sl) (hy2:length q = length hl),
(forall s2 s3 : sigma,
P (s2 :: sl) -> ceval h s2 ps s3 ->
rtc q sl hl pi (fun sl' _ => Q (s3 :: sl') (s2 :: sl)) hy1 hy2) =
hoare_triple (fun s => P (s:: sl) )
     (fun s' s => rtc q sl hl pi (fun sl' _ => Q (s' :: sl') (s :: sl)) hy1 hy2)
              h ps.
Proof.
intros.
unfold hoare_triple.
reflexivity.
Qed.

(** Defintion of the generator of auxiliare goals for relational properties **)

Program Fixpoint rtc' (cl : list com) (ml: list Sigma.sigma)
            (hl: list history) (cls : Phi.phi)
            (hy1:length cl = length ml) (hy2:length cl = length hl): Prop :=
 match cl,ml,hl with
 | [],[],[] => True
 | c :: qc, m :: qm, h :: qh =>
   tc' c m h cls /\ rtc' qc qm qh cls _ _
 | _,_, _ => !
end.

Next Obligation.
destruct cl.
- simpl in hy1.
  symmetry in hy1.
  apply length_zero_iff_nil in hy1.
  simpl in hy2.
  symmetry in hy2.
  apply length_zero_iff_nil in hy2.
  subst ml.
  subst hl.
  contradiction H0.
  split.
  reflexivity.
  split.
  reflexivity. reflexivity.
- destruct ml as [|m qm].
  discriminate hy1.
  destruct hl as [|h qh].
  discriminate hy2.
  eapply H.
  split.
  reflexivity.
  split.
  reflexivity. reflexivity.
Qed.

Next Obligation.
split.
intros.
intros contra.
destruct contra as (contra & _).
discriminate contra.
intros contra.
destruct contra as ( _ & contra).
destruct contra as ( _ & contra).
discriminate contra.
Defined.

Next Obligation.
split.
intros.
intros contra.
destruct contra as ( _ & contra).
destruct contra as (contra & _).
discriminate contra.
intros contra.
destruct contra as (contra & _).
discriminate contra.
Defined.

Next Obligation.
split.
intros.
intros contra.
destruct contra as (contra & _).
discriminate contra.
intros contra.
destruct contra as (_ & contra ).
destruct contra as (contra & _).
discriminate contra.
Defined.

Next Obligation.
split.
intros.
intros contra.
destruct contra as (_ & contra ).
destruct contra as (_ & contra ).
discriminate contra.
intros contra.
destruct contra as (contra & _).
discriminate contra.
Defined.

(** Facts about rtc and rtc' **)

Lemma mk_rtc_def :
forall c q pi s sl h hl
(hy1:length (c::q) = length (s::sl)) (hy2:length (c::q) = length (h::hl)),
exists (hyr1:length q = length sl),
exists (hyr2:length q = length hl),
forall P,
rtc (c :: q) (s::sl) (h::hl) pi P hy1 hy2  =
tc c s h pi (fun m' h' => rtc q sl hl pi (fun ml hl => P (m'::ml) (h'::hl)) hyr1 hyr2).
Proof.
intros.
eexists.
eexists.
program_simpl.
Qed.

Lemma mk_rtc'_def :
forall c q pi s sl h hl
(hy1:length (c::q) = length (s::sl))
(hy2:length (c::q) = length (h::hl)),
exists (hyr1:length q = length sl),
exists (hyr2:length q = length hl),
rtc' (c :: q) (s::sl) (h::hl)pi hy1 hy2  =
(tc' c s h pi /\ rtc' q sl hl pi hyr1 hyr2).
Proof.
intros.
eexists.
eexists.
program_simpl.
Qed.

(** Translation of a list of procedure call to Prop **)

Definition proc_call f s s' ps := ceval (CCall f) s ps s'.

Program Fixpoint proc_to_pred p s s' ps (hy1:length p = length s)
                                        (hy2:length p = length s'): Prop:=
match p, s, s' with
| [] , [], [] => True
| h :: q, s:: qs, s' :: qs' => proc_call h s s' ps /\ proc_to_pred q qs qs' ps _ _
| _, _, _ => !
end.

Next Obligation.
destruct p.
- simpl in hy1.
  symmetry in hy1.
  apply length_zero_iff_nil in hy1.
  simpl in hy2.
  symmetry in hy2.
  apply length_zero_iff_nil in hy2.
  subst s.
  subst s'.
  contradiction H0.
  split.
  reflexivity.
  split.
  reflexivity. reflexivity.
- destruct s as [|s qs].
  discriminate hy1.
  destruct s' as [|s' qs'].
  discriminate hy2.
  eapply H.
  split.
  reflexivity.
  split.
  reflexivity. reflexivity.
Qed.

Next Obligation.
split.
intros.
intros contra.
destruct contra as (contra & _).
discriminate contra.
intros contra.
destruct contra as ( _ & contra).
destruct contra as ( _ & contra).
discriminate contra.
Defined.

Next Obligation.
split.
intros.
intros contra.
destruct contra as ( _ & contra).
destruct contra as (contra & _).
discriminate contra.
intros contra.
destruct contra as (contra & _).
discriminate contra.
Defined.

Next Obligation.
split.
intros.
intros contra.
destruct contra as (contra & _).
discriminate contra.
intros contra.
destruct contra as (_ & contra ).
destruct contra as (contra & _).
discriminate contra.
Defined.

Next Obligation.
split.
intros.
intros contra.
destruct contra as (_ & contra ).
destruct contra as (_ & contra ).
discriminate contra.
intros contra.
destruct contra as (contra & _).
discriminate contra.
Defined.

(** Facts about proc_to_pred **)

Lemma mk_proc_to_pred_def :
forall c q s sl s' sl' ps
(hy1:length (c::q) = length (s::sl)) (hy2:length (c::q) = length (s'::sl')),
exists (hyr1:length q = length sl),
exists (hyr2:length q = length sl'),
proc_to_pred (c :: q) (s::sl) (s'::sl') ps hy1 hy2  =
(proc_call c s s' ps /\ proc_to_pred q sl sl' ps hyr1 hyr2).
Proof.
intros.
eexists.
eexists.
program_simpl.
Qed.

Lemma rceval_proc_to_prod p s s' ps (hy1:length p = length s) (hy2:length p = length s') :
proc_to_pred p s s' ps hy1 hy2 -> rceval (fold_call p) s ps s' .
Proof.
generalize dependent hy2.
generalize dependent hy1.
generalize dependent s'.
generalize dependent s.
induction p; intros.
  + destruct s;[| inversion hy1].
    destruct s';[| inversion hy2].
    simpl. apply E_Empty.
  + destruct s;[inversion hy1| ].
    destruct s';[inversion hy2| ].
    specialize (mk_proc_to_pred_def a p s s0 s1 s' ps hy1 hy2) as (hyr1 & hyr2 & HYP).
    rewrite HYP in H.
    simpl.
    apply E_Seq.
    -  apply H.
    - inversion hy1.
      inversion hy2.
     apply IHp with (hy1:= hyr1)(hy2:= hyr2). apply H.
Qed.

(** Translation of a relational contract into Prop **)

Definition tr (rcl:R_Phi.r_phi) ps :=
   forall p s s' (hy1:length p = length s) (hy2:length p = length s'),
          0 < length p ->
          proc_to_pred p s s' ps hy1 hy2 ->
          (get_r_pre (rcl p)) s -> (get_r_post (rcl p)) s' s.

(** Facts about tr **)

Lemma tr_relational_prop (rcl:R_Phi.r_phi) (ps: Psi.psi):
(forall p, 0 < length p ->
     relational_prop (get_r_pre (rcl p)) (get_r_post (rcl p)) (fold_call p) ps)
          -> tr rcl ps.
Proof.
intros H p s s' hy1 hy2 hy Hcall Hrp.
  apply H.
  + apply hy.
  + rewrite fold_call_length.
    symmetry. assumption.
  + rewrite fold_call_length.
    symmetry. assumption.
  + assumption.
  + eapply rceval_proc_to_prod in Hcall.
    apply Hcall.
Qed.

(** Adding proc_call to post condition of procedure contract **)

Definition phi_call (cl : Phi.phi) ps :=
    fun x => (get_pre (cl x), (fun m' m => (get_post (cl x)) m' m /\ proc_call x m m' ps)).

(* Facts about phi_call *)

Lemma phi_call_hoare (ps: Psi.psi) (cl : Phi.phi) :
  (forall p, hoare_triple (get_pre (cl p)) (get_post (cl p)) (CCall p) ps) ->
  (forall p, hoare_triple (get_pre (phi_call cl ps p)) (get_post (phi_call cl ps p)) (CCall p) ps).
Proof.
intros.
intros s s' Hpre Heval.
split.
* generalize p, s, s', Hpre, Heval.
  apply H.
* apply Heval.
Qed.

(** Extract standard procedure contract from relational procedure contract **)

Definition extract rcl := fun y:Proc.Proc.t =>
  (fun m => get_r_pre (rcl [y]) [m], fun m' m =>  get_r_post (rcl [y]) [m'] [m]).

(* Facts about Extract *)

Lemma hd_length_1 s: length s = 1 -> [hd default_sigma s] = s.
Proof.
intros.
destruct s.
* inversion H.
* inversion H.
  rewrite length_zero_iff_nil in H1.
  subst.
  simpl.
  reflexivity.
Qed.

Lemma rela_hoare_extract rcl ps:
  (forall p : list Proc.Proc.t,
    0 < length p -> relational_prop (get_r_pre (rcl p)) (get_r_post (rcl p)) (fold_call p) ps) ->
   (forall p, hoare_triple (get_pre ((extract rcl) p)) (get_post ((extract rcl) p)) (CCall p) ps).
Proof.
intros.
assert (H1 : 0 < 1); auto.
specialize (H [p] H1). simpl in H.
apply Single_Rela_Prop.one_rela_is_hoare.
simpl.
intros s s' hy1 hy2 Hpre Heval.
inversion hy1.
inversion hy2.
rewrite hd_length_1 by apply H3.
rewrite hd_length_1 by apply H2.
apply H. all: try assumption.
rewrite hd_length_1 in Hpre by apply H2.
assumption.
Qed.

(** Definition of a relational verification condition generator for procedures **)

Definition rtc_p (ps: Psi.psi) (rcl : R_Phi.r_phi) : Prop :=
    forall f m ps',
    let c := (map ps f) in
    let h := (map (fun _ => empty_history) f) in
    forall (hy1:length c = length m) (hy2:length c = length h),
    (get_r_pre (rcl f)) m -> tr rcl ps' ->
              rtc' c m h (phi_call (extract rcl) ps') hy1 hy2 /\
              rtc c m h (phi_call (extract rcl) ps')
                                       (fun m' _ => (get_r_post (rcl f)) m' m) hy1 hy2.

(* Facts about relational verification condition generator for procedures *)

Lemma simpl_rtc' :
  forall (a:Proc.Proc.t) f (s:sigma) m ps ps' phi
   (hy1:length (map ps (a::f)) = length (s::m))
   (hy2:length (map ps (a::f)) =
        length (map (fun _ : Proc.Proc.t => empty_history) (a :: f))),
  exists H1, exists H2,
       rtc' (map ps (a :: f))
            (s :: m)
            (map (fun _ : Proc.Proc.t => empty_history) (a :: f))
            (phi_call (extract phi) ps') hy1 hy2 =
       rtc' (ps a :: map ps f)
            (s :: m)
            (empty_history :: map (fun _ : Proc.Proc.t => empty_history) f)
            (phi_call (extract phi) ps') H1 H2.
Proof.
 eexists. eexists. program_simpl.
Qed.

Lemma simpl_rtc :
  forall (a:Proc.Proc.t) f (s:sigma) m ps
   (hy1:length (map Psi.empty_psi (a::f)) = length (s::m))
   (hy2:length (map Psi.empty_psi (a::f)) =
        length (map (fun _ : Proc.Proc.t => empty_history) (a :: f))),
  exists H1, exists H2,
  forall suite,
       rtc (map Psi.empty_psi (a :: f))
            (s :: m)
            (map (fun _ : Proc.Proc.t => empty_history) (a :: f))
            (phi_call (extract R_Phi.empty_r_phi) ps)
            suite hy1 hy2 =
       rtc (CSkip :: map Psi.empty_psi f)
            (s :: m)
            (empty_history :: map (fun _ : Proc.Proc.t => empty_history) f)
            (phi_call (extract R_Phi.empty_r_phi) ps)
            suite H1 H2.
Proof.
  eexists. eexists. intros. program_simpl.
Qed.

Lemma rtc_p_empty_psi : rtc_p Psi.empty_psi R_Phi.empty_r_phi.
Proof.
unfold rtc_p.
intros.
split.
* generalize dependent m.
  induction f;intros.
  + inversion hy1.
    symmetry in H2.
    apply length_zero_iff_nil in H2.
    subst.
    simpl.
    auto.
  + destruct m;[ discriminate hy1 | ].
    destruct (simpl_rtc' a f s m
                         Psi.empty_psi ps' R_Phi.empty_r_phi hy1 hy2)
       as (hyr1 & hyr2 & HYP).
    rewrite HYP.
    clear HYP.
    destruct (mk_rtc'_def _ _ (phi_call (extract R_Phi.empty_r_phi) ps')
                          _ _  _ _ hyr1 hyr2)
          as (hyr3 & hyr4 & HYP).
    rewrite HYP.
    clear HYP.
    split.
    - simpl.
      auto.
    - apply IHf.
      simpl.
      unfold empty_r_precondition.
      auto.
* generalize dependent m.
  induction f; intros.
  + inversion hy1.
    symmetry in H2.
    apply length_zero_iff_nil in H2.
    subst.
    simpl.
    unfold empty_r_postcondition.
    auto.
  + destruct m; [discriminate hy1 | ].
    destruct (simpl_rtc a f s m ps' hy1 hy2) as (hyr1 & hyr2 & HYP).
    rewrite HYP.
    clear HYP.
    destruct (mk_rtc_def _ _ (phi_call (extract R_Phi.empty_r_phi) ps')
                          _ _ _ _ hyr1 hyr2)
             as (hyr3 & hyr4 & HYP).
    rewrite HYP.
    clear HYP.
    simpl.
    intros.
    apply IHf.
    simpl.
    unfold empty_r_precondition.
    auto.
Qed.


Set Warnings "-notation-overridden".

Require Import Coq.Program.Basics.

From Equations Require Import Equations.
Unset Equations With Funext.

Require Import Category.Lib.
Require Import Category.Theory.
Require Import Category.Instance.Coq.

Require Import Embed.Theory.Btree.
Require Import Embed.Theory.Btree.Functor.

Generalizable All Variables.
Set Universe Polymorphism.
Set Nested Proofs Allowed.

Definition ret_btree {A} : A -> @btree A := bnil.

Equations join_btree {A} (xss : @btree (@btree A)) : @btree A :=
join_btree (bnil xs) := xs ;
join_btree (bcons xs ys) := bcons (join_btree xs) (join_btree ys).

Program Instance btree_monad : @Monad Coq btree_Functor := {
  ret := fun _ => ret_btree;
  join := fun _ => join_btree
}.

Next Obligation.
revert x0.
fix join_fmap_join_btree 1.
destruct x0.
{
  rewrite fmap_btree_equation_1.
  repeat (rewrite join_btree_equation_1).
  reflexivity.
}
{
  rewrite fmap_btree_equation_2.
  repeat (rewrite join_btree_equation_2).
  refine (bcons_eq _ _).
  {
    exact (join_fmap_join_btree _).
  }
  {
    exact (join_fmap_join_btree _).
  }
}
Qed.

Next Obligation.
revert x0.
fix join_fmap_ret_btree 1.
destruct x0.
{
  rewrite fmap_btree_equation_1.
  rewrite join_btree_equation_1.
  auto.
}
{
  rewrite fmap_btree_equation_2.
  rewrite join_btree_equation_2.
  refine (bcons_eq _ _).
  {
    exact (join_fmap_ret_btree _).
  }
  {
    exact (join_fmap_ret_btree _).
  }
}
Qed.

Next Obligation.
revert x0.
fix join_fmap_fmap_btree 1.
destruct x0.
{
  rewrite fmap_btree_equation_1.
  do 2 (rewrite join_btree_equation_1).
  reflexivity.
}
{
  rewrite fmap_btree_equation_2.
  repeat (rewrite join_btree_equation_2).
  refine (bcons_eq _ _).
  {
    exact (join_fmap_fmap_btree _).
  }
  {
    exact (join_fmap_fmap_btree _).
  }
}
Qed.