(* Laying out labels, and generally coming up with final "machine code" programs *)

Require Import NArith.

Require Import Nomega Word IL LabelMap PropX XCAP Memory.

Set Implicit Arguments.

Definition labelsOf' (M : LabelMap.t (assert * block)) (acc : (W * ((label -> option W) * (W -> option block))))
  : (label -> option W) * (W -> option block) :=
  snd (LabelMap.fold (fun k (v : assert * block) p => let (_, bl) := v in let '(w, (labels, prog)) := p in
    (natToWord _ 1 ^+ w,
      ((fun k' => if LabelKey.eq_dec k' k then Some w else labels k'),
        (fun w' => if weq w' w then Some bl else prog w'))))
  M acc).

Definition labelsOf (M : LabelMap.t (assert * block)) : (label -> option W) * (W -> option block) :=
  labelsOf' M (wzero _, (fun _ => None, fun _ => None)).

Lemma lt_trans : forall n m o, (n < o)%N -> m = n -> (m < o)%N.
  congruence.
Qed.

Lemma labelsOf'_inj : forall M l1 l2 w w' labels prog,
  let labels' := fst (labelsOf' M (w', (labels, prog))) in
    labels' l1 = Some w
    -> labels' l2 = Some w
    -> (forall l1' l2' w'', labels l1' = Some w'' -> labels l2' = Some w'' -> l1' = l2')
    -> (forall l w'', labels l = Some w'' -> (wordToNat w'' < wordToNat w')%nat)
    -> (wordToN w' + N_of_nat (LabelMap.cardinal M) < Npow2 32)%N
    -> l1 = l2.
  unfold labelsOf'; simpl; intros.
  rewrite LabelMap.fold_1 in *.
  rewrite LabelMap.cardinal_1 in *.
  generalize dependent prog.
  generalize dependent labels.
  generalize dependent w'.
  induction (LabelMap.elements M); simpl; intuition.
  eauto.
  simpl in *.
  eapply IHl; clear IHl; try (apply H || apply H0); simpl; intuition.
  generalize H3; clear.
  unfold wplus, wordBin.
  match goal with
    | [ |- context[wordToN ?N] ] =>
      match N with
        | _~1 => change (wordToN N) with 1%N
      end
  end.
  intro; eapply lt_trans; eauto.
  replace (Npos (P_of_succ_nat (length l))) with (1 + N_of_nat (length l))%N in *.
  replace (wordToN (NToWord 32 (1 + wordToN w'))) with (1 + wordToN w')%N.
  ring.
  rewrite NToWord_nat.
  assert (1 + wordToN w' < 4294967296)%N.

  Lemma lt_rearrange : forall n p m k,
    (n + (p + m) < k)%N
    -> (p + n < k)%N.
    intros; nomega.
  Qed.

  eapply lt_rearrange; eauto.

  rewrite nat_of_Nplus.
  change (nat_of_N 1) with 1.
  repeat rewrite wordToN_nat.
  rewrite nat_of_N_of_nat.
  destruct (wordToNat_natToWord 32 (1 + wordToNat w')); intuition.
  rewrite H1.
  rewrite N_of_minus.
  rewrite N_of_plus.
  rewrite N_of_mult.
  change (N_of_nat 1) with 1%N.
  destruct x.
  change (N_of_nat 0) with 0%N.
  rewrite Nmult_0_l.
  clear.
  nomega.
  elimtype False.
  clear H1.

  Lemma contra : forall x b n,
    (n < b)%nat
    -> (S x * b <= n)%nat
    -> False.
    simpl; intros.
    assert (b <= n)%nat.
    generalize dependent (x * b)%nat.
    intros; omega.
    omega.
  Qed.

  eapply contra; [ | eassumption ].
  generalize H; clear; intro.
  rewrite <- Npow2_nat.
  change 1 with (nat_of_N 1) at 1.
  rewrite <- (nat_of_N_of_nat (wordToNat w')).
  rewrite <- nat_of_Nplus.
  apply Nlt_out.
  rewrite wordToN_nat in H.
  apply H.
  clear.
  apply nat_of_N_eq.
  change (nat_of_N (Npos (P_of_succ_nat (length l)))) with (nat_of_P (P_of_succ_nat (length l))).
  rewrite Pnat.nat_of_P_o_P_of_succ_nat_eq_succ.
  rewrite nat_of_Nplus.
  simpl.
  autorewrite with N; reflexivity.

  repeat match goal with
           | [ _ : context[if ?E then _ else _] |- _ ] => destruct E
           | [ H : LabelKey.eq _ _ |- _ ] => hnf in H; subst
         end; auto.
  elimtype False.
  injection H5; clear H5; intro; subst.
  apply H2 in H4; omega.
  elimtype False.
  injection H4; clear H4; intro; subst.
  apply H2 in H5; omega.
  eauto.

  repeat match goal with
           | [ _ : context[if ?E then _ else _] |- _ ] => destruct E
           | [ H : LabelKey.eq _ _ |- _ ] => hnf in H; subst
         end; auto.
  injection H4; clear H4; intro; subst.
  generalize H3; clear; intros.
  apply Nlt_out in H3.
  autorewrite with N in *.
  change (nat_of_N (Npos (P_of_succ_nat (length l)))) with (nat_of_P (P_of_succ_nat (length l))) in H3.
  rewrite Pnat.nat_of_P_o_P_of_succ_nat_eq_succ in H3.
  rewrite wordToN_nat in H3.
  autorewrite with N in *.
  unfold wplus, wordBin.
  match goal with
    | [ |- context[wordToN ?N] ] =>
      match N with
        | _~1 => change (wordToN N) with 1%N
      end
  end.
  rewrite NToWord_nat.
  rewrite nat_of_Nplus.
  change (nat_of_N 1) with 1.
  rewrite wordToN_nat.
  autorewrite with N.
  destruct (wordToNat_natToWord 32 (1 + wordToNat w'')); intuition.
  rewrite H0; clear H0.
  destruct x.
  omega.
  elimtype False.
  change 4294967296%N with (Npow2 32) in *.
  rewrite Npow2_nat in *.
  eapply contra; [ | eassumption ].
  generalize H3; clear; intro.
  generalize dependent (pow2 32).
  intros; omega.

  apply H2 in H4.
  generalize H3 H4; clear; intros.
  change 4294967296%N with (Npow2 32) in *.
  unfold wplus, wordBin.
  rewrite NToWord_nat.
  match goal with
    | [ |- context[wordToN ?N] ] =>
      match N with
        | _~1 => change (wordToN N) with 1%N
      end
  end.
  rewrite nat_of_Nplus.
  change (nat_of_N 1) with 1.
  rewrite wordToN_nat.
  autorewrite with N.
  destruct (wordToNat_natToWord 32 (1 + wordToNat w')); intuition.
  rewrite H0; clear H0.
  destruct x.
  omega.
  elimtype False.
  eapply contra; [ | eassumption ].
  generalize H3; clear; intro.
  apply Nlt_out in H3.
  autorewrite with N in *.
  change (nat_of_N (Npos (P_of_succ_nat (length l)))) with (nat_of_P (P_of_succ_nat (length l))) in H3.
  rewrite Pnat.nat_of_P_o_P_of_succ_nat_eq_succ in H3.
  rewrite wordToN_nat in H3.
  autorewrite with N in *.
  rewrite Npow2_nat in *.
  generalize dependent (pow2 32).
  intros; omega.
Qed.

Theorem labelsOf_inj : forall M l1 l2 w, fst (labelsOf M) l1 = Some w
  -> fst (labelsOf M) l2 = Some w
  -> (N_of_nat (LabelMap.cardinal M) < Npow2 32)%N
  -> l1 = l2.
  intros; eapply labelsOf'_inj; eauto; simpl; intuition; discriminate.
Qed.

Lemma labelsOf'_agree : forall M l pre bl w' labels prog, LabelMap.MapsTo l (pre, bl) M
  -> (forall l w'', labels l = Some w'' -> (wordToNat w'' < wordToNat w')%nat)
  -> (wordToN w' + N_of_nat (LabelMap.cardinal M) < Npow2 32)%N
  -> exists w, fst (labelsOf' M (w', (labels, prog))) l = Some w
    /\ snd (labelsOf' M (w', (labels, prog))) w = Some bl.
  unfold labelsOf'; simpl; intros.
  rewrite LabelMap.fold_1 in *.
  rewrite LabelMap.cardinal_1 in *.
  apply LabelMap.elements_1 in H.
  generalize dependent prog.
  generalize dependent labels.
  generalize dependent w'.
  generalize (LabelMap.elements_3w M).
  induction 1; simpl; intuition.
  inversion H.

  inversion H; clear H; intros; subst.
  hnf in H5; simpl in H5; intuition; subst.
  destruct x; simpl in *; subst.

  exists w'; intuition.

  Lemma labels_keep : forall k v w ls w' labels prog,
    labels k = Some w
    -> ~SetoidList.InA (@LabelMap.eq_key _) (k, v) ls
    -> fst (snd (List.fold_left
      (fun
        (a : word 32 *
          ((LabelKey.t -> option (word 32)) *
            (word 32 -> option block)))
        (p : LabelMap.key * (assert * block)) =>
        let (_, bl0) := snd p in
          let '(w, (labels0, prog0)) := a in
            (WO~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~1
              ^+ w,
              (fun k' : LabelKey.t =>
                if LabelFacts.eq_dec k' (fst p) then Some w else labels0 k',
                  fun w'0 : word 32 =>
                    if weq w'0 w then Some bl0 else prog0 w'0))) ls
      (w', (labels, prog))))
     k = Some w.
    induction ls as [ | [ ? [ ] ] ]; simpl; intuition.
    apply IHls; auto.
    destruct (LabelFacts.eq_dec k k0).
    elimtype False; apply H0.
    hnf in e; subst.
    constructor; hnf; auto.
    auto.
  Qed.

  eapply labels_keep; eauto.
  destruct (LabelFacts.eq_dec k k); auto.
  elimtype False; apply n; reflexivity.

  Lemma prog_keep : forall w bl ls w' labels prog,
    prog w = Some bl
    -> w < w'
    -> (wordToN w' + N_of_nat (length ls) < Npow2 32)%N
    -> snd (snd (List.fold_left
      (fun
        (a : word 32 *
          ((LabelKey.t -> option (word 32)) *
            (word 32 -> option block)))
        (p : LabelMap.key * (assert * block)) =>
        let (_, bl0) := snd p in
          let '(w, (labels0, prog0)) := a in
            (WO~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~1
              ^+ w,
              (fun k' : LabelKey.t =>
                if LabelFacts.eq_dec k' (fst p) then Some w else labels0 k',
                  fun w'0 : word 32 =>
                    if weq w'0 w then Some bl0 else prog0 w'0))) ls
      (w', (labels, prog))))
     w = Some bl.
    induction ls as [ | [ ? [ ] ] ]; simpl; intuition.
    apply IHls; auto.
    destruct (weq w w').
    subst.
    elimtype False.
    unfold wlt in H0.
    apply Nlt_not_eq in H0; tauto.
    auto.

    generalize H0 H1; clear; intros.
    change 4294967296%N with (Npow2 32) in *.
    destruct (wordToNat_natToWord 32 (1 + wordToNat w')); intuition.
    rewrite <- Npow2_nat in *.
    generalize dependent (Npow2 32); intros.
    apply Nlt_out in H1.
    autorewrite with N in *.
    change (nat_of_N (Npos (P_of_succ_nat (length ls)))) with (nat_of_P (P_of_succ_nat (length ls))) in H1.
    rewrite Pnat.nat_of_P_o_P_of_succ_nat_eq_succ in H1.
    rewrite wordToN_nat in H1.
    autorewrite with N in *.
    unfold wlt in *.
    unfold wplus, wordBin.
    rewrite NToWord_nat.
    repeat rewrite wordToN_nat in *.
    autorewrite with N in *.
    match goal with
      | [ |- context[wordToNat ?N] ] =>
        match N with
          | _~1 => change (wordToNat N) with 1
        end
    end.
    rewrite H2; clear H2.
    destruct x.
    generalize H0; clear.
    intros; nomega.
    elimtype False.
    clear H0.

    Lemma slow : forall x ln w' n,
      (w' + S ln < n)%nat
      -> (S x * n <= 1 + w')%nat
      -> False.
      simpl; intros.
      generalize dependent (x * n); intros; omega.
    Qed.

    eapply slow; eassumption.

    generalize H1; clear; intros.
    change 4294967296%N with (Npow2 32) in *.
    destruct (wordToNat_natToWord 32 (1 + wordToNat w')); intuition.
    rewrite <- Npow2_nat in *.
    generalize dependent (Npow2 32); intros.
    unfold wplus, wordBin.
    rewrite NToWord_nat.
    match goal with
      | [ |- context[wordToN ?N] ] =>
        match N with
          | _~1 => change (wordToN N) with 1%N
        end
    end.
    rewrite nat_of_Nplus.
    change (nat_of_N 1) with 1.
    rewrite wordToN_nat.
    autorewrite with N.
    repeat rewrite wordToN_nat in *.
    autorewrite with N in *.
    rewrite H0; clear H0.
    rewrite N_of_minus.
    rewrite N_of_plus.
    rewrite N_of_mult.
    change (N_of_nat 1) with 1%N.
    apply Nlt_out in H1.
    autorewrite with N in *.
    change (nat_of_N (Npos (P_of_succ_nat (length ls)))) with (nat_of_P (P_of_succ_nat (length ls))) in H1.
    rewrite Pnat.nat_of_P_o_P_of_succ_nat_eq_succ in H1.
    destruct x.
    change (N_of_nat 0) with 0%N.
    apply Nlt_in.
    autorewrite with N.
    change (nat_of_N 1) with 1.
    change (nat_of_N (0 * N_of_nat (pow2 32))) with 0.
    omega.
    elimtype False.
    eapply contra; [ | eassumption ].
    omega.
  Qed.

  apply prog_keep.
  destruct (weq w' w'); tauto.

  generalize H2; clear; intros.
  change 4294967296%N with (Npow2 32) in *.
  apply Nlt_out in H2.
  autorewrite with N in H2.
  change (nat_of_N (Npos (P_of_succ_nat (length l0)))) with (nat_of_P (P_of_succ_nat (length l0))) in H2.
  rewrite Pnat.nat_of_P_o_P_of_succ_nat_eq_succ in H2.
  unfold wlt, wplus, wordBin.
  match goal with
    | [ |- context[wordToN ?N] ] =>
      match N with
        | _~1 => change (wordToN N) with 1%N
      end
  end.
  rewrite NToWord_nat in *.
  rewrite wordToN_nat in *.
  autorewrite with N in *.
  rewrite wordToN_nat in *.
  change (nat_of_N 1) with 1.
  destruct (wordToNat_natToWord 32 (1 + wordToNat w')); intuition.
  rewrite H0.
  rewrite <- Npow2_nat in *.
  generalize dependent (Npow2 32); intros.
  apply Nlt_in.
  autorewrite with N.
  destruct x.
  omega.
  elimtype False.
  eapply slow; eauto.

  generalize H2; clear.
  change 4294967296%N with (Npow2 32).
  destruct (wordToNat_natToWord 32 (1 + wordToNat w')); intuition.
  rewrite <- Npow2_nat in *.
  generalize dependent (Npow2 32); intros.
  eapply lt_trans; eauto.
  apply nat_of_N_eq.
  autorewrite with N.
  change (nat_of_N (Npos (P_of_succ_nat (length l0)))) with (nat_of_P (P_of_succ_nat (length l0))).
  rewrite Pnat.nat_of_P_o_P_of_succ_nat_eq_succ.
  rewrite wordToN_nat.
  autorewrite with N.
  unfold wplus, wordBin.
  rewrite NToWord_nat.
  autorewrite with N.
  match goal with
    | [ |- context[wordToN ?N] ] =>
      match N with
        | _~1 => change (wordToN N) with 1%N
      end
  end.
  change (nat_of_N 1) with 1.
  rewrite wordToN_nat; autorewrite with N.
  rewrite H0; clear H0.
  apply Nlt_out in H2.
  autorewrite with N in *.
  change (nat_of_N (Npos (P_of_succ_nat (length l0)))) with (nat_of_P (P_of_succ_nat (length l0))) in H2.
  rewrite Pnat.nat_of_P_o_P_of_succ_nat_eq_succ in H2.
  destruct x.
  omega.
  elimtype False.
  eapply slow; eauto.
  rewrite wordToN_nat; autorewrite with N; eauto.

  destruct x as [ ? [ ] ]; simpl in *.
  apply IHNoDupA; auto.
  generalize H2; clear.
  change 4294967296%N with (Npow2 32) in *.
  unfold wplus, wordBin.
  rewrite NToWord_nat.
  match goal with
    | [ |- context[wordToN ?N] ] =>
      match N with
        | _~1 => change (wordToN N) with 1%N
      end
  end.
  rewrite nat_of_Nplus.
  change (nat_of_N 1) with 1.
  repeat rewrite wordToN_nat.
  autorewrite with N.
  destruct (wordToNat_natToWord 32 (1 + wordToNat w')); intuition.
  rewrite H0; clear H0.
  repeat rewrite <- Npow2_nat in *.
  generalize dependent (Npow2 32); intros.
  rewrite N_of_minus.
  rewrite N_of_plus.
  rewrite N_of_mult.
  change (N_of_nat 1) with 1%N.
  apply Nlt_out in H2.
  autorewrite with N in H2.
  change (nat_of_N (Npos (P_of_succ_nat (length l0)))) with (nat_of_P (P_of_succ_nat (length l0))) in H2.
  rewrite Pnat.nat_of_P_o_P_of_succ_nat_eq_succ in H2.
  autorewrite with N.
  destruct x.
  apply Nlt_in.
  autorewrite with N.
  change (nat_of_N 1) with 1.
  change (nat_of_N (N_of_nat 0 * n))%N with 0.
  omega.
  elimtype False.
  eapply contra; [ | eassumption ].
  omega.

  intros.
  repeat match goal with
           | [ _ : context[if ?E then _ else _] |- _ ] => destruct E
           | [ H : LabelKey.eq _ _ |- _ ] => hnf in H; subst
         end; auto.
  injection H; clear H; intro; subst.
  generalize H2; clear; intros.
  apply Nlt_out in H2.
  autorewrite with N in *.
  change (nat_of_N (Npos (P_of_succ_nat (length l0)))) with (nat_of_P (P_of_succ_nat (length l0))) in H2.
  rewrite Pnat.nat_of_P_o_P_of_succ_nat_eq_succ in H2.
  rewrite wordToN_nat in H2.
  autorewrite with N in *.
  unfold wplus, wordBin.
  match goal with
    | [ |- context[wordToN ?N] ] =>
      match N with
        | _~1 => change (wordToN N) with 1%N
      end
  end.
  rewrite NToWord_nat.
  rewrite nat_of_Nplus.
  change (nat_of_N 1) with 1.
  rewrite wordToN_nat.
  autorewrite with N.
  destruct (wordToNat_natToWord 32 (1 + wordToNat w'')); intuition.
  rewrite H0; clear H0.
  destruct x.
  omega.
  elimtype False.
  change 4294967296%N with (Npow2 32) in *.
  rewrite Npow2_nat in *.
  eapply contra; [ | eassumption ].
  omega.

  apply H3 in H.
  generalize H H2; clear; intros.
  change 4294967296%N with (Npow2 32) in *.
  unfold wplus, wordBin.
  rewrite NToWord_nat.
  match goal with
    | [ |- context[wordToN ?N] ] =>
      match N with
        | _~1 => change (wordToN N) with 1%N
      end
  end.
  rewrite nat_of_Nplus.
  change (nat_of_N 1) with 1.
  rewrite wordToN_nat.
  autorewrite with N.
  destruct (wordToNat_natToWord 32 (1 + wordToNat w')); intuition.
  rewrite H1; clear H1.
  destruct x.
  omega.
  elimtype False.
  eapply contra; [ | eassumption ].
  generalize H2; clear; intro.
  apply Nlt_out in H2.
  autorewrite with N in *.
  change (nat_of_N (Npos (P_of_succ_nat (length l0)))) with (nat_of_P (P_of_succ_nat (length l0))) in H2.
  rewrite Pnat.nat_of_P_o_P_of_succ_nat_eq_succ in H2.
  rewrite wordToN_nat in H2.
  autorewrite with N in *.
  rewrite Npow2_nat in *.
  generalize dependent (pow2 32).
  intros; omega.
Qed.

Theorem labelsOf_agree : forall M l pre bl, LabelMap.MapsTo l (pre, bl) M
  -> (N_of_nat (LabelMap.cardinal M) < Npow2 32)%N
  -> exists w, fst (labelsOf M) l = Some w
    /\ snd (labelsOf M) w = Some bl.
  intros; eapply labelsOf'_agree; intuition eauto; discriminate.
Qed.

(** * Some default word-size memory accessors *)

Theorem wlt_not_refl : forall n (w : word n), w < w -> False.
  unfold wlt; intros; nomega.
Qed.

Hint Immediate wlt_not_refl.

Lemma use_separated : forall (k : W) q,
  (forall n m, (n < 4)%nat -> (m < 4)%nat -> k ^+ $ q ^+ $ n = k ^+ $ m -> False)
  -> (q < 4)%nat
  -> False.
  intros.
  apply H with 0 q; auto.
  word_eq.
Qed.

Lemma use_separated' : forall (k : W) q,
  (forall n m, (n < 4)%nat -> (m < 4)%nat -> k ^+ $ n = k ^+ $ q ^+ $ m -> False)
  -> (q < 4)%nat
  -> False.
  intros.
  apply H with q 0; auto.
  word_eq.
Qed.

Local Hint Extern 1 False => eapply use_separated; [ eassumption | omega ].
Local Hint Extern 1 False => eapply use_separated'; [ eassumption | omega ].
Local Hint Extern 1 False => match goal with
                               | [ H : forall n m : nat, _ |- _ ] => eapply H; [ | | eassumption ]; omega
                             end.

(** * Finally, we can create settings for testing. *)

Section LittleEndianSettings.
  Variable memHigh : W.
  Variable m : module.

(** NOTE: this is little endian *)
  Definition explode_le (v : W) : B * B * B * B :=
    let dw1 := split1 16 16 v in
    let dw2 := split2 16 16 v in
    let b1 := split1 8 8 dw1 in
    let b2 := split2 8 8 dw1 in
    let b3 := split1 8 8 dw2 in
    let b4 := split2 8 8 dw2 in
    (b1,b2,b3,b4).

  Definition implode_le (bs : B * B * B * B) : W :=
    let '(b1,b2,b3,b4) := bs in
    combine (combine b1 b2) (combine b3 b4).

  Theorem implode_explode_le : forall w,
    implode_le (explode_le w) = w.
  Proof.
    unfold implode_le, explode_le.
    intros. repeat rewrite combine_split. reflexivity.
  Qed.

  Theorem explode_implode_le : forall b,
    explode_le (implode_le b) = b.
  Proof.
    unfold implode_le, explode_le.
    intros. destruct b. destruct p. destruct p.
    repeat (rewrite split1_combine || rewrite split2_combine).
    reflexivity.
  Qed.

  Definition leSettings := {|
    implode := implode_le ;
    explode := explode_le ;
    implode_explode := implode_explode_le ;
    explode_implode := explode_implode_le ;
    Labels := fst (labelsOf (Blocks m))
  |}.

  Hypothesis closed : LabelMap.cardinal (Imports m) = 0.
  Hypothesis notTooBig : (N_of_nat (LabelMap.cardinal (Blocks m)) < Npow2 32)%N.
  Hypothesis ok : moduleOk m.

  Theorem safety : forall mn g pre, LabelMap.find (mn, Global g) (Exports m) = Some pre
    -> forall w, Labels leSettings (mn, Global g) = Some w
      -> forall st, interp (specs m leSettings) (pre (leSettings, st))
        -> safe leSettings (snd (labelsOf (Blocks m))) (w, st).
    intros; eapply safety; intuition eauto.
    apply labelsOf_inj with (Blocks m) w0; auto.
    simpl; eapply labelsOf_agree; eauto.
    apply LabelMap.find_2; eauto.
  Qed.
End LittleEndianSettings.


Require Import Fiat.Parsers.ContextFreeGrammar.Fix.Properties.
Require Import Fiat.Common.BoolFacts.
Require Import Fiat.Common.
Require Import Fiat.Common.Wf.

Set Implicit Arguments.

Local Open Scope bool_scope.

Global Instance prod_fixedpoint_lattice {prestate0 prestate1}
       {fpldata0 : grammar_fixedpoint_lattice_data prestate0}
       {fpldata1 : grammar_fixedpoint_lattice_data prestate1}
  : grammar_fixedpoint_lattice_data (@state _ fpldata0 * @state _ fpldata1).
Proof.
  refine {| prestate_lt x y := ((state_le (fst x) (fst y) && state_le (snd x) (snd y))
                                  && negb (state_beq (fst x) (fst y) && state_beq (snd x) (snd y)));
            prestate_beq := Equality.prod_beq state_beq state_beq;
            preleast_upper_bound x y
            := constant (least_upper_bound (fst x) (fst y), least_upper_bound (snd x) (snd y)) |};
  try abstract (
        repeat match goal with
               | _ => progress unfold Equality.prod_beq
               | [ |- RelationClasses.Equivalence _ ]
                 => split; repeat intro
               | [ |- well_founded _ ] => fail 1
               | [ |- is_true (?R ?x ?x) ] => reflexivity
               | [ |- is_true true ] => reflexivity
               | [ |- ?R ?x ?x ] => reflexivity
               | _ => congruence
               | [ |- Proper _ _ ] => unfold Proper, respectful
               | [ |- Transitive _ ] => intros ???; cbv beta
               | _ => progress intros
               | [ H : and _ _ |- _ ] => destruct H
               | [ H : prod _ _ |- _ ] => destruct H
               | _ => progress simpl in *
               | [ H : is_true (state_beq ?x ?y) |- _ ]
                 => rewrite H in *; clear x H
               | [ H : is_true (state_beq ?x ?y) |- _ ]
                 => clear x H
               | [ |- context[(?x <= least_upper_bound ?x ?y)%fixedpoint] ]
                 => replace (x <= least_upper_bound x y)%fixedpoint
                    with true by (symmetry; apply least_upper_bound_correct_l)
               | [ |- context[(?y <= least_upper_bound ?x ?y)%fixedpoint] ]
                 => replace (y <= least_upper_bound x y)%fixedpoint
                    with true by (symmetry; apply least_upper_bound_correct_r)
               | [ H : is_true true |- _ ] => clear H
               | [ H : is_true ?x |- context[?x] ]
                 => progress replace x with true by (symmetry; exact H)
               | [ H : is_true ?x, H' : context[?x] |- _ ]
                 => progress replace x with true in H' by (symmetry; exact H)
               | [ H : context[@state_beq ?A ?B ?x ?x] |- _ ]
                 => replace (@state_beq A B x x) with true in H by (symmetry; change (is_true (@state_beq A B x x)); reflexivity)
               | [ H : is_true (?R ?x ?y), H' : is_true (?R ?y ?z) |- _ ]
                 => unique pose proof (transitivity (R := R) H H' : is_true (R x z))
               | [ H : is_true (@state_le ?A ?B ?x ?y), H' : is_true (state_le ?y ?x) |- _ ]
                 => unique pose proof (@antisymmetry _ (@state_beq A B) _ (@state_le A B) _ x y H H' : is_true (state_beq x y))
               | [ |- context[is_true (negb ?x)] ]
                 => destruct x eqn:?; simpl; fold_is_true
               | _ => progress bool_congr_setoid
               | [ |- and _ _ ] => split
               end
      ).
  { unfold flip.
    eapply well_founded_subrelation; [ | eapply well_founded_prod_relationA with (eqA := state_beq) ];
      [ .. | eapply state_gt_wf | eapply state_gt_wf ].
    { intros x y H.
      unfold prod_relationA, flip, state_le, state in *.
      revert H.
      generalize (@state_lt _ fpldata0).
      generalize (@state_lt _ fpldata1).
      generalize (@state_beq _ fpldata0).
      generalize (@state_beq _ fpldata1).
      unfold state.
      clear.
      abstract (
          repeat match goal with
                 | _ => setoid_rewrite Bool.negb_andb
                 | _ => tauto
                 | _ => congruence
                 | _ => progress destruct_head and
                 | [ H : is_true ?x, H' : context[?x] |- _ ]
                   => progress replace x with true in H' by (symmetry; exact H)
                 | _ => progress simpl in *
                 | _ => progress bool_congr_setoid
                 | _ => progress intros
                 | _ => progress destruct_head or
                 end
        ). }
    { apply prod_relationA_Proper_from_Equivalence; try exact _; [].
      unfold flip; intros ??? x y H H'; subst.
      rewrite H; assumption. } }
Defined.

Global Instance prod_fixedpoint_lattice' {prestate0 prestate1}
       {fpldata0 : grammar_fixedpoint_lattice_data prestate0}
       {fpldata1 : grammar_fixedpoint_lattice_data prestate1}
  : grammar_fixedpoint_lattice_data (lattice_for prestate0 * lattice_for prestate1)
  := prod_fixedpoint_lattice.


From iris.program_logic Require Export language ectx_language ectxi_language.
From iris_io.prelude Require Export base.
From iris.algebra Require Export ofe.
From stdpp Require Import gmap.
From Coq.Logic Require Export FunctionalExtensionality PropExtensionality.

Module Plang.
  Definition loc := positive.

  Instance loc_dec_eq (l l' : loc) : Decision (l = l') := _.

  Inductive binop := Add | Sub | Eq | Le | Lt.

  Instance binop_dec_eq (op op' : binop) : Decision (op = op').
  Proof. solve_decision. Defined.

  Definition ioTag := positive.

  Inductive expr :=
  | Var (x : var)
  | Rec (e : {bind 2 of expr})
  | Lam (e : {bind expr})
  | LetIn (e : expr) (e : {bind expr})
  | Seq (e1 e2 : expr)
  | App (e1 e2 : expr)
  (* Base Types *)
  | Unit
  | Nat (n : nat)
  | Bool (b : bool)
  | BinOp (op : binop) (e1 e2 : expr)
  (* If then else *)
  | If (e0 e1 e2 : expr)
  (* Products *)
  | Pair (e1 e2 : expr)
  | Fst (e : expr)
  | Snd (e : expr)
  (* Sums *)
  | InjL (e : expr)
  | InjR (e : expr)
  | Case (e0 : expr) (e1 : {bind expr}) (e2 : {bind expr})
  (* Recursive Types *)
  | Fold (e : expr)
  | Unfold (e : expr)
  (* Polymorphic Types *)
  | TLam (e : expr)
  | TApp (e : expr)
  (* Concurrency *)
  | Fork (e : expr)
  (* Reference Types *)
  | Loc (l : loc)
  | IOtag (t : ioTag)
  | Alloc (e : expr)
  | Load (e : expr)
  | Store (e1 : expr) (e2 : expr)
  (* Compare and swap used for fine-grained concurrency *)
  | CAS (e0 : expr) (e1 : expr) (e2 : expr)
  (* Instrumenting Prophecies *)
  | Pr (l : loc)
  | Create_Pr
  | Assign_Pr (e1 e2 : expr)
  (* Random bit *)
  | Rand
  (* I/O *)
  | IO (e1 e2 : expr).

  Instance Ids_expr : Ids expr. derive. Defined.
  Instance Rename_expr : Rename expr. derive. Defined.
  Instance Subst_expr : Subst expr. derive. Defined.
  Instance SubstLemmas_expr : SubstLemmas expr. derive. Qed.

  (* Notation for bool and nat *)
  Notation "#♭ b" := (Bool b) (at level 20).
  Notation "#n n" := (Nat n) (at level 20).

  Global Instance expr_dec_eq : EqDecision expr.
  Proof. solve_decision. Defined.

  Inductive val :=
  | RecV (e : {bind 1 of expr})
  | LamV (e : {bind 1 of expr})
  | TLamV (e : {bind 1 of expr})
  | UnitV
  | NatV (n : nat)
  | BoolV (b : bool)
  | PairV (v1 v2 : val)
  | InjLV (v : val)
  | InjRV (v : val)
  | FoldV (v : val)
  | LocV (l : loc)
  | IOtagV (t : ioTag)
  | PrV (l : loc).

  (* Notation for bool and nat *)
  Notation "'#♭v' b" := (BoolV b) (at level 20).
  Notation "'#nv' n" := (NatV n) (at level 20).

  Fixpoint binop_eval (op : binop) : nat → nat → val :=
    match op with
    | Add => λ a b, #nv(a + b)
    | Sub => λ a b, #nv(a - b)
    | Eq => λ a b, if (eq_nat_dec a b) then #♭v true else #♭v false
    | Le => λ a b, if (le_dec a b) then #♭v true else #♭v false
    | Lt => λ a b, if (lt_dec a b) then #♭v true else #♭v false
    end.

  Global Instance val_dec_eq : EqDecision val.
  Proof. solve_decision. Defined.

  Instance val_inh : Inhabited val := populate UnitV.

  Fixpoint of_val (v : val) : expr :=
    match v with
    | RecV e => Rec e
    | LamV e => Lam e
    | TLamV e => TLam e
    | UnitV => Unit
    | NatV v => Nat v
    | BoolV v => Bool v
    | PairV v1 v2 => Pair (of_val v1) (of_val v2)
    | InjLV v => InjL (of_val v)
    | InjRV v => InjR (of_val v)
    | FoldV v => Fold (of_val v)
    | LocV l => Loc l
    | IOtagV t => IOtag t
    | PrV l => Pr l
    end.

  Fixpoint to_val (e : expr) : option val :=
    match e with
    | Rec e => Some (RecV e)
    | Lam e => Some (LamV e)
    | TLam e => Some (TLamV e)
    | Unit => Some UnitV
    | Nat n => Some (NatV n)
    | Bool b => Some (BoolV b)
    | Pair e1 e2 => v1 ← to_val e1; v2 ← to_val e2; Some (PairV v1 v2)
    | InjL e => InjLV <$> to_val e
    | InjR e => InjRV <$> to_val e
    | Fold e => v ← to_val e; Some (FoldV v)
    | Loc l => Some (LocV l)
    | Pr l => Some (PrV l)
    | IOtag t => Some (IOtagV t)
    | _ => None
    end.

  (** Evaluation contexts *)
  Inductive ectx_item :=
  | AppLCtx (e2 : expr)
  | AppRCtx (v1 : val)
  | LetInCtx (e2 : expr)
  | SeqCtx (e2 : expr)
  | TAppCtx
  | PairLCtx (e2 : expr)
  | PairRCtx (v1 : val)
  | BinOpLCtx (op : binop) (e2 : expr)
  | BinOpRCtx (op : binop) (v1 : val)
  | FstCtx
  | SndCtx
  | InjLCtx
  | InjRCtx
  | CaseCtx (e1 : {bind expr}) (e2 : {bind expr})
  | IfCtx (e1 : {bind expr}) (e2 : {bind expr})
  | FoldCtx
  | UnfoldCtx
  | AllocCtx
  | LoadCtx
  | StoreLCtx (e2 : expr)
  | StoreRCtx (v1 : val)
  | CasLCtx (e1 : expr)  (e2 : expr)
  | CasMCtx (v0 : val) (e2 : expr)
  | CasRCtx (v0 : val) (v1 : val)
  | Assign_PrLCtx (e2 : expr)
  | Assign_PrRCtx (v1 : val)
  | IOLCtx (e2 : expr)
  | IORCtx (v1 : val).

  Definition fill_item (Ki : ectx_item) (e : expr) : expr :=
    match Ki with
    | AppLCtx e2 => App e e2
    | AppRCtx v1 => App (of_val v1) e
    | LetInCtx e2 => LetIn e e2
    | SeqCtx e2 => Seq e e2
    | TAppCtx => TApp e
    | PairLCtx e2 => Pair e e2
    | PairRCtx v1 => Pair (of_val v1) e
    | BinOpLCtx op e2 => BinOp op e e2
    | BinOpRCtx op v1 => BinOp op (of_val v1) e
    | FstCtx => Fst e
    | SndCtx => Snd e
    | InjLCtx => InjL e
    | InjRCtx => InjR e
    | CaseCtx e1 e2 => Case e e1 e2
    | IfCtx e1 e2 => If e e1 e2
    | FoldCtx => Fold e
    | UnfoldCtx => Unfold e
    | AllocCtx => Alloc e
    | LoadCtx => Load e
    | StoreLCtx e2 => Store e e2
    | StoreRCtx v1 => Store (of_val v1) e
    | CasLCtx e1 e2 => CAS e e1 e2
    | CasMCtx v0 e2 => CAS (of_val v0) e e2
    | CasRCtx v0 v1 => CAS (of_val v0) (of_val v1) e
    | Assign_PrLCtx e2 => Assign_Pr e e2
    | Assign_PrRCtx v1 => Assign_Pr (of_val v1) e
    | IOLCtx e2 => IO e e2
    | IORCtx v1 => IO (of_val v1) e
    end.

  Definition ioSpec := (list (ioTag * val * val)) → Prop.

  Global Instance ioSpec_equiv : Equiv ioSpec :=
    λ M M', ∀ T, M T ↔ M' T.

  Global Instance ioSpec_LeibnizEquiv : LeibnizEquiv ioSpec.
  Proof.
    intros M M' HMM. extensionality z.
    by apply propositional_extensionality.
  Qed.

  Global Instance Equivalence_ioSpec_equiv : Equivalence ioSpec_equiv.
  Proof.
    split.
    - intros x; cbv in *; auto.
    - intros x y Hxy T; specialize (Hxy T); intuition.
    - intros x y z Hxy Hyz T; specialize (Hxy T); specialize (Hyz T); intuition.
  Qed.

  Global Instance ioSpec_inh : Inhabited ioSpec.
  Proof.
    exact {|inhabitant := λ _, False |}.
  Qed.

  Record state : Type :=
    { Heap : gmap loc val;
      Proph : gmap loc (Stream val);
      ioState : ioSpec
    }.

  Global Instance state_inh : Inhabited state.
  Proof.
    exact {|inhabitant := {| Heap := ∅; Proph := ∅; ioState := λ _, False |} |}.
  Qed.

  Definition update_heap σ h :=
    {| Heap := h; Proph := Proph σ; ioState := ioState σ |}.

  Definition update_proph σ ι :=
    {| Heap := Heap σ; Proph := ι; ioState := ioState σ |}.

  Definition update_ioState σ T :=
    {| Heap := Heap σ; Proph := Proph σ; ioState := T |}.

  Inductive head_step : expr → state → expr → state → list expr → Prop :=
  (* β *)
  | BetaS e1 e2 v2 σ :
      to_val e2 = Some v2 →
      head_step (App (Rec e1) e2) σ e1.[(Rec e1), e2/] σ []
  | ZetaS e1 e2 v1 σ :
      to_val e1 = Some v1 →
      head_step (LetIn e1 e2) σ e2.[e1/] σ []
  | LamBetaS e1 e2 v2 σ :
      to_val e2 = Some v2 →
      head_step (App (Lam e1) e2) σ e1.[e2/] σ []
  | SeqS e1 e2 v1 σ :
      to_val e1 = Some v1 →
      head_step (Seq e1 e2) σ e2 σ []
  (* Products *)
  | FstS e1 v1 e2 v2 σ :
      to_val e1 = Some v1 → to_val e2 = Some v2 →
      head_step (Fst (Pair e1 e2)) σ e1 σ []
  | SndS e1 v1 e2 v2 σ :
      to_val e1 = Some v1 → to_val e2 = Some v2 →
      head_step (Snd (Pair e1 e2)) σ e2 σ []
  (* Sums *)
  | CaseLS e0 v0 e1 e2 σ :
      to_val e0 = Some v0 →
      head_step (Case (InjL e0) e1 e2) σ e1.[e0/] σ []
  | CaseRS e0 v0 e1 e2 σ :
      to_val e0 = Some v0 →
      head_step (Case (InjR e0) e1 e2) σ e2.[e0/] σ []
    (* nat bin op *)
  | BinOpS op a b σ :
      head_step (BinOp op (#n a) (#n b)) σ (of_val (binop_eval op a b)) σ []
  (* If then else *)
  | IfFalse e1 e2 σ :
      head_step (If (#♭ false) e1 e2) σ e2 σ []
  | IfTrue e1 e2 σ :
      head_step (If (#♭ true) e1 e2) σ e1 σ []
  (* Recursive Types *)
  | Unfold_Fold e v σ :
      to_val e = Some v →
      head_step (Unfold (Fold e)) σ e σ []
  (* Polymorphic Types *)
  | TBeta e σ :
      head_step (TApp (TLam e)) σ e σ []
  (* Concurrency *)
  | ForkS e σ:
      head_step (Fork e) σ Unit σ [e]
  (* Reference Types *)
  | AllocS e v σ l :
     to_val e = Some v → (Heap σ) !! l = None →
     head_step (Alloc e) σ (Loc l) (update_heap σ (<[l:=v]>(Heap σ))) []
  | LoadS l v σ :
     (Heap σ) !! l = Some v →
     head_step (Load (Loc l)) σ (of_val v) σ []
  | StoreS l e v σ :
     to_val e = Some v → is_Some ((Heap σ) !! l) →
     head_step (Store (Loc l) e) σ Unit (update_heap σ (<[l:=v]>(Heap σ))) []
  (* Compare and swap *)
  | CasFailS l e1 v1 e2 v2 vl σ :
     to_val e1 = Some v1 → to_val e2 = Some v2 →
     (Heap σ) !! l = Some vl → vl ≠ v1 →
     head_step (CAS (Loc l) e1 e2) σ (#♭ false) σ []
  | CasSucS l e1 v1 e2 v2 σ :
     to_val e1 = Some v1 → to_val e2 = Some v2 →
     (Heap σ) !! l = Some v1 →
     head_step (CAS (Loc l) e1 e2) σ (#♭ true) (update_heap σ (<[l:=v2]>(Heap σ))) []
  (* Prophecy operational semantics *)
  | Create_PrS v σ :
      head_step Create_Pr σ (Pr (fresh (dom (gset loc) (Proph σ))))
                (update_proph σ (<[fresh (dom (gset loc) (Proph σ)):= v]>(Proph σ))) []
  | AssignSucS l e p σ :
     (Proph σ) !! l = Some p → to_val e = Some (Shead p) →
     head_step (Assign_Pr (Pr l) e) σ Unit (update_proph σ (<[l:= Stail p]>(Proph σ))) []
  | AssignS_unalloced e v e' v' σ :
     (∀ l, v = PrV l →(Proph σ) !! l = None) →
     to_val e = Some v → to_val e' = Some v' →
     head_step (Assign_Pr e e') σ Unit σ []
  | AssignFailS l e w p σ :
      (Proph σ) !! l = Some p → to_val e = Some w → w ≠ Shead p →
      head_step (Assign_Pr (Pr l) e) σ (Assign_Pr (Pr l) e) σ []
  | RandS b σ : head_step Rand σ (Bool b) σ []
  | IOS t e v v' σ : to_val e = Some v → (ioState σ) [(t, v, v')] →
                    head_step (IO (IOtag t) e) σ (of_val v')
                              (update_ioState σ (λ τ, (ioState σ) ((t, v, v') :: τ))) [].

  (** Basic properties about the language *)
  Lemma to_of_val v : to_val (of_val v) = Some v.
  Proof. by induction v; simplify_option_eq. Qed.

  Lemma of_to_val e v : to_val e = Some v → of_val v = e.
  Proof.
    revert v; induction e; intros; simplify_option_eq; auto with f_equal.
  Qed.

  Instance of_val_inj : Inj (=) (=) of_val.
  Proof. by intros ?? Hv; apply (inj Some); rewrite -!to_of_val Hv. Qed.

  Lemma fill_item_val Ki e :
    is_Some (to_val (fill_item Ki e)) → is_Some (to_val e).
  Proof. intros [v ?]. destruct Ki; simplify_option_eq; eauto. Qed.

  Instance fill_item_inj Ki : Inj (=) (=) (fill_item Ki).
  Proof. destruct Ki; intros ???; simplify_eq; auto with f_equal. Qed.

  Lemma val_stuck e1 σ1 e2 σ2 ef :
    head_step e1 σ1 e2 σ2 ef → to_val e1 = None.
  Proof. destruct 1; naive_solver. Qed.

  Lemma head_ctx_step_val Ki e σ1 e2 σ2 ef :
    head_step (fill_item Ki e) σ1 e2 σ2 ef → is_Some (to_val e).
  Proof. destruct Ki; inversion_clear 1; simplify_option_eq; eauto. Qed.

  Lemma fill_item_no_val_inj Ki1 Ki2 e1 e2 :
    to_val e1 = None → to_val e2 = None →
    fill_item Ki1 e1 = fill_item Ki2 e2 → Ki1 = Ki2.
  Proof.
    destruct Ki1, Ki2; intros; try discriminate; simplify_eq;
    repeat match goal with
           | H : to_val (of_val _) = None |- _ => by rewrite to_of_val in H
           end; auto.
  Qed.

  Lemma alloc_fresh e v σ :
    let l := fresh (dom (gset loc) (Heap σ)) in
    to_val e = Some v → head_step (Alloc e) σ (Loc l) (update_heap σ (<[l:=v]>(Heap σ))) [].
  Proof. by intros; apply AllocS, (not_elem_of_dom (D:=gset loc)), is_fresh. Qed.

  Lemma create_pr v σ :
    head_step Create_Pr σ (Pr (fresh (dom (gset loc) (Proph σ))))
              (update_proph σ (<[fresh (dom (gset loc) (Proph σ)):= v ]>(Proph σ))) [].
  Proof. intros; eapply Create_PrS. Qed.

  Lemma val_head_stuck e1 σ1 e2 σ2 efs : head_step e1 σ1 e2 σ2 efs → to_val e1 = None.
  Proof. destruct 1; naive_solver. Qed.

  Lemma lang_mixin : EctxiLanguageMixin of_val to_val fill_item head_step.
  Proof.
    split; apply _ || eauto using to_of_val, of_to_val, val_head_stuck,
           fill_item_val, fill_item_no_val_inj, head_ctx_step_val.
  Qed.

  Canonical Structure stateC := leibnizC state.
  Canonical Structure valC := leibnizC val.
  Canonical Structure exprC := leibnizC expr.
End Plang.

Canonical Structure P_ectxi_lang :=
  EctxiLanguage Plang.lang_mixin.
Canonical Structure P_ectx_lang :=
  EctxLanguageOfEctxi P_ectxi_lang.
Canonical Structure P_lang :=
  LanguageOfEctx P_ectx_lang.

Export Plang.

Hint Extern 20 (PureExec _ _ _) => progress simpl : typeclass_instances.

Hint Extern 5 (IntoVal _ _) => eapply to_of_val : typeclass_instances.
Hint Extern 10 (IntoVal _ _) =>
  rewrite /IntoVal /= ?to_of_val /=; eauto : typeclass_instances.

Hint Extern 5 (AsVal _) => eexists; eapply to_of_val : typeclass_instances.
Hint Extern 10 (AsVal _) =>
  eexists; rewrite /IntoVal /= ?to_of_val /=; eauto : typeclass_instances.

Definition is_atomic (e : expr) : Prop :=
  match e with
  | Alloc e => is_Some (to_val e)
  | Load e =>  is_Some (to_val e)
  | Store e1 e2 => is_Some (to_val e1) ∧ is_Some (to_val e2)
  | CAS e1 e2 e3 => is_Some (to_val e1) ∧ is_Some (to_val e2)
                   ∧ is_Some (to_val e3)
  | IO e1 e2 => is_Some (to_val e1) ∧ is_Some (to_val e2)
  | _ => False
  end.
Local Hint Resolve language.val_irreducible.
Local Hint Resolve to_of_val.
Local Hint Unfold language.irreducible.
Global Instance is_atomic_correct s e : is_atomic e → Atomic s e.
Proof.
  intros Ha; apply strongly_atomic_atomic,  ectx_language_atomic.
  - destruct 1; simpl in *; try tauto; eauto.
  - intros K e' -> Hval%eq_None_not_Some.
    induction K using rev_ind; first done.
    simpl in Ha; rewrite fill_app in Ha; simpl in Ha.
    destruct Hval. apply (fill_val K e'); simpl in *.
    destruct x; naive_solver.
Qed.

Ltac solve_atomic :=
  apply is_atomic_correct; simpl; repeat split;
    rewrite ?to_of_val; eapply mk_is_Some; fast_done.

Hint Extern 0 (Atomic _ _) => solve_atomic.
Hint Extern 0 (Atomic _ _) => solve_atomic : typeclass_instances.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)
(**********************************************************************)

(**********************************************************************)
(*                    SF_Tactics.v                                    *)
(*                                                                    *)
(*                     Barry Jay                                      *)
(*                                                                    *)
(**********************************************************************)

Require Import Omega.
Require Import IntensionalLib.SF_calculus.Test.
Require Import IntensionalLib.SF_calculus.General.
Require Import IntensionalLib.Tree_calculus.SF_Terms.

Definition termred := SF -> SF -> Prop.

Definition preserve (R : termred) (P : SF -> Prop) :=
  forall x : SF, P x -> forall y : SF, R x y -> P y.

Inductive multi_step : termred -> termred :=
  | zero_red : forall red M, multi_step red M M
  | succ_red : forall (red: SF-> SF -> Prop) M N P,
                   red M N -> multi_step red N P -> multi_step red M P
.

Hint Constructors multi_step.

Definition reflective red := forall (M: SF), red M M.

Lemma refl_multi_step : forall (red: termred), reflective (multi_step red).
Proof. red; split_all. Qed.

Ltac reflect := match goal with
| |- reflective (multi_step _) => eapply2 refl_multi_step
| |- multi_step _ _ _ => try (eapply2 refl_multi_step)
| _ => split_all
end.

Ltac one_step :=
match goal with
| |- multi_step _ _ ?N => apply succ_red with N; auto; try red; try reflect
end.

Definition transitive red := forall (M N P: SF), red M N -> red N P -> red M P.

Lemma transitive_red : forall red, transitive (multi_step red).
Proof. red; induction 1; split_all.
apply succ_red with N; auto.
Qed.

Definition preserves_app (red : termred) :=
forall M M' N N', red M M' -> red N N' -> red (App M N) (App M' N').

Lemma preserves_app_multi_step : forall (red: termred), reflective red -> preserves_app red -> preserves_app (multi_step red).
Proof.
red. induction 3; split_all. generalize H0; induction 1.
reflect.
apply succ_red with (App M N); auto.
assert( transitive (multi_step red)) by eapply2 transitive_red.
apply X0 with (App N0 N); auto.
one_step.
Qed.

Hint Resolve preserves_app_multi_step.

Ltac inv1 prop :=
match goal with
| H: prop _ |- _ => inversion H; clear H; inv1 prop
| H: prop (App  _ _) |- _ => inversion H; clear H; inv1 prop
| H: prop Op _ |- _ => inversion H; clear H; inv1 prop
| _ => split_all
 end.

Definition implies_red (red1 red2: termred) := forall M N, red1 M N -> red2 M N.

Lemma implies_red_multi_step: forall red1 red2, implies_red red1  (multi_step red2) ->
                                                implies_red (multi_step red1) (multi_step red2).
Proof. red.
intros red1 red2 IR M N R; induction R; split_all.
apply transitive_red with N; auto.
Qed.

Ltac inv red :=
match goal with
| H: multi_step red (App _ _) _ |- _ => inversion H; clear H; inv red
| H: multi_step red (Op _) _ |- _ => inversion H; clear H; inv red
| H: red (App _ _) _ |- _ => inversion H; clear H; inv red
| H: red (Op _) _ |- _ => inversion H; clear H; inv red
| H: multi_step red _ (App _ _) |- _ => inversion H; clear H; inv red
| H: multi_step red _ (Op _) |- _ => inversion H; clear H; inv red
| H: red _ (App _ _) |- _ => inversion H; clear H; inv red
| H: red _ (Op _) |- _ => inversion H; clear H; inv red
| _ => subst; split_all
 end.

Definition diamond (red1 red2 : termred) :=
forall M N, red1 M N -> forall P, red2 M P -> exists Q, red2 N Q /\ red1 P Q.

Lemma diamond_flip: forall red1 red2, diamond red1 red2 -> diamond red2 red1.
Proof.
unfold diamond; split_all. elim (H M P H1 N H0); split_all. inversion H2.
 exist x.
Qed.

Lemma diamond_strip :
forall red1 red2, diamond red1 red2 -> diamond red1 (multi_step red2).
Proof. intros.
eapply2 diamond_flip.
red; induction 1; split_all.
exist P.
elim (H M P0 H2 N); split_all. inversion H3.
elim(IHmulti_step H x); split_all. inversion H6.
exist x0. split. auto.
apply succ_red with x; auto.
Qed.

Definition diamond_star (red1 red2: termred) := forall  M N, red1 M N -> forall P, red2 M P ->
  exists Q, red1 P Q /\ multi_step red2 N Q.

Lemma diamond_star_strip: forall red1 red2, diamond_star red1 red2 -> diamond (multi_step red2) red1 .
Proof.
red. induction 2; split_all.
exist P.
elim(H M P0 H2 N H0); split_all. inversion H3.
elim(IHmulti_step H x); split_all. inversion H6.
exist x0. split. auto.
apply transitive_red with x; auto.
Qed.

Lemma diamond_tiling :
forall red1 red2, diamond red1 red2 -> diamond (multi_step red1) (multi_step red2).
Proof.
red.  induction 2; split_all.
exist P.
elim(diamond_strip red red2 H M N H0 P0); split_all.
inversion H3.
elim(IHmulti_step H x H4); split_all. inversion H6.
exist x0. split. auto.
apply succ_red with x; auto.
Qed.

Hint Resolve diamond_tiling.

Fixpoint rank (M: SF) :=
match M with
| Op _ => 1
| App M1 M2 => S((rank M1) + (rank M2))
end.

Lemma rank_positive: forall M, rank M > 0.
Proof.
induction M; split_all; try omega.
Qed.

Ltac rank_tac := match goal with
| |- forall M, ?P  =>
  cut (forall p M, p >= rank M -> P )
; [ intros H M;  eapply2 H | ]
end .


Require Import Coq.Classes.Morphisms Coq.Setoids.Setoid.
Require Import Coq.Structures.Equalities.
Require Import Crypto.Util.Option.
Require Import Crypto.Util.Tactics.DestructHead.
Require Import Crypto.Util.Structures.Equalities.

Local Set Implicit Arguments.

Module OptionTyp (E : Typ) <: Typ.
  Definition t := option E.t.
End OptionTyp.

Module OptionHasEq (E : Eq).
  Definition eq : relation (option E.t) := option_eq E.eq.
End OptionHasEq.

Module OptionIsEq (E : EqualityType).
  Local Notation eq := (option_eq E.eq).
  Global Instance eq_equiv : Equivalence eq | 5.
  Proof.
    constructor; exact _.
  Defined.
End OptionIsEq.

Module OptionIsEqOrig (E : EqualityTypeOrig).
  Local Notation eq := (option_eq E.eq).
  Definition eq_refl : Reflexive eq.
  Proof. repeat intro; destruct_head' option; (reflexivity + apply E.eq_refl). Defined.
  Definition eq_sym : Symmetric eq.
  Proof. repeat intro; destruct_head' option; cbv [eq] in *; (assumption + apply E.eq_sym + idtac + exfalso + inversion_option); assumption. Defined.
  Definition eq_trans : Transitive eq.
  Proof. repeat intro; destruct_head' option; cbv [eq] in *; try ((assumption + eapply E.eq_trans + idtac + exfalso + inversion_option); eassumption). Defined.
End OptionIsEqOrig.

Module OptionHasEqDec (E : Eq) (EDec : HasEqDec E).
  Local Notation eq := (option_eq E.eq).
  Definition eq_dec x y : {eq x y} + {~eq x y}.
  Proof.
    destruct x as [x|], y as [y|]; [ destruct (EDec.eq_dec x y); [ left | right ] | right | right | left ];
      cbv [option_eq]; try assumption; try reflexivity; try solve [ intros [] ]; congruence.
  Defined.
End OptionHasEqDec.

Module OptionHasEqb (E : Typ) (Eb : HasEqb E).
  Definition eqb := option_beq Eb.eqb.
End OptionHasEqb.

Module OptionEqbNotation (E : Typ) (Es : HasEqb E).
  Module Import _OptionEqbNotation.
    Module T := OptionTyp E.
    Module E := OptionHasEqb E Es.
  End _OptionEqbNotation.
  Include EqbNotation T _OptionEqbNotation.E.
End OptionEqbNotation.

Module OptionEqbSpec (E : Typ) (Ee : HasEq E) (Eb : HasEqb E) (Es : EqbSpec E Ee Eb).
  Local Notation eq := (option_eq Ee.eq).
  Local Notation eqb := (option_beq Eb.eqb).
  Lemma eqb_eq x y : eqb x y = true <-> eq x y.
  Proof.
    destruct x as [x|], y as [y|]; cbv [option_eq option_beq];
      try apply Es.eqb_eq;
      intuition congruence.
  Qed.
End OptionEqbSpec.

Module OptionHasEqBool (E : Eq) (Es : HasEqBool E) := OptionHasEqb E Es <+ OptionEqbSpec E E Es Es.

Module OptionUsualHasEqDec (E : UsualEq) (EDec : HasEqDec E).
  Definition eq_dec (x y : option E.t) : {eq x y} + {~eq x y}.
  Proof.
    destruct x as [x|], y as [y|];
      [ destruct (EDec.eq_dec x y); [ left | right ]
      | right
      | right
      | left ];
      repeat first [ assumption
                   | reflexivity
                   | apply f_equal
                   | intro
                   | progress inversion_option
                   | solve [ auto with nocore ] ].
  Defined.
End OptionUsualHasEqDec.

Module OptionUsualEqbSpec (E : UsualBoolEq).
  Lemma eqb_eq x y : @option_beq _ E.eqb x y = true <-> eq x y.
  Proof.
    destruct x as [x|], y as [y|]; cbn;
      rewrite ?E.eqb_eq;
      intuition congruence.
  Qed.
End OptionUsualEqbSpec.

Module OptionHasUsualEq (E : UsualEq).
  Module Import _OptionHasUsualEq.
    Module E' := OptionTyp E.
  End _OptionHasUsualEq.
  Include HasUsualEq E'.
End OptionHasUsualEq.

Module OptionUsualEq (E : UsualEq) <: UsualEq := OptionTyp E <+ HasUsualEq.

Module OptionUsualIsEq (E : UsualEq).
  Module Import _OptionUsualIsEq.
    Module E' := OptionUsualEq E.
  End _OptionUsualIsEq.
  Include UsualIsEq E'.
End OptionUsualIsEq.

Module OptionUsualIsEqOrig (E : UsualEq).
  Module Import _OptionUsualIsEqOrig.
    Module E' := OptionUsualEq E.
  End _OptionUsualIsEqOrig.
  Include UsualIsEqOrig E'.
End OptionUsualIsEqOrig.

Module OptionMiniDecidableType (E : MiniDecidableType) <: MiniDecidableType.
  Include OptionTyp E.
  Module Import _OptionMiniDecidableType.
    Module E' := Make_UDT E.
  End _OptionMiniDecidableType.
  Include OptionUsualHasEqDec E' E'.
End OptionMiniDecidableType.

Local Coercion is_true : bool >-> Sortclass.
Module OptionIsEqb (E : EqbType).
  Global Instance eqb_equiv : Equivalence (option_beq E.eqb) | 5.
  Proof.
    destruct E.eqb_equiv.
    split; repeat intros [|]; cbv in *; try congruence; eauto.
  Qed.
End OptionIsEqb.

Module OptionUsualHasEqBool (E : UsualBoolEq) := OptionHasEqb E E <+ OptionUsualEqbSpec E.

Module OptionEq (E : Eq) <: Eq := OptionTyp E <+ OptionHasEq E.
Module OptionEqualityType (E : EqualityType) <: EqualityType := OptionEq E <+ OptionIsEq E.
Module OptionEqualityTypeOrig (E : EqualityTypeOrig) <: EqualityTypeOrig := OptionEq E <+ OptionIsEqOrig E.
Module OptionEqualityTypeBoth (E : EqualityTypeBoth) <: EqualityTypeBoth := OptionEq E <+ OptionIsEq E <+ OptionIsEqOrig E.
Module OptionDecidableType (E : DecidableType) <: EqualityType := OptionEqualityType E <+ OptionHasEqDec E E.
Module OptionDecidableTypeOrig (E : DecidableTypeOrig) <: EqualityTypeOrig := OptionEqualityTypeOrig E <+ OptionHasEqDec E E.
Module OptionDecidableTypeBoth (E : DecidableTypeBoth) <: EqualityTypeBoth := OptionEqualityTypeBoth E <+ OptionHasEqDec E E.
Module OptionBooleanEqualityType (E : BooleanEqualityType) <: BooleanEqualityType := OptionEqualityType E <+ OptionHasEqb E E <+ OptionEqbSpec E E E E.
Module OptionBooleanDecidableType (E : BooleanDecidableType) <: BooleanDecidableType := OptionBooleanEqualityType E <+ OptionHasEqDec E E.
Module OptionDecidableTypeFull (E : DecidableTypeFull) <: DecidableTypeFull := OptionEq E <+ OptionIsEq E <+ OptionIsEqOrig E <+ OptionHasEqDec E E <+ OptionHasEqBool E E.

Module OptionEq' (E : Eq) := OptionEq E <+ EqNotation.
Module OptionEqualityType' (E : EqualityType) := OptionEqualityType E <+ EqNotation.
Module OptionEqualityTypeOrig' (E : EqualityTypeOrig) := OptionEqualityTypeOrig E <+ EqNotation.
Module OptionEqualityTypeBoth' (E : EqualityTypeBoth) := OptionEqualityTypeBoth E <+ EqNotation.
Module OptionDecidableType' (E : DecidableType) := OptionDecidableType E <+ EqNotation.
Module OptionDecidableTypeOrig' (E : DecidableTypeOrig) := OptionDecidableTypeOrig E <+ EqNotation.
Module OptionDecidableTypeBoth' (E : DecidableTypeBoth) := OptionDecidableTypeBoth E <+ EqNotation.
Module OptionBooleanEqualityType' (E : BooleanEqualityType) := OptionBooleanEqualityType E <+ EqNotation <+ EqbNotation.
Module OptionBooleanDecidableType' (E : BooleanDecidableType) := OptionBooleanDecidableType E <+ EqNotation <+ EqbNotation.
Module OptionDecidableTypeFull' (E : DecidableTypeFull) := OptionDecidableTypeFull E <+ EqNotation.

Module OptionUsualEqualityType (E : UsualEqualityType) <: UsualEqualityType := OptionUsualEq E <+ UsualIsEq.
Module OptionUsualEqualityTypeOrig (E : UsualEqualityTypeOrig) <: UsualEqualityTypeOrig := OptionUsualEq E <+ UsualIsEqOrig.
Module OptionUsualEqualityTypeBoth (E : UsualEqualityTypeBoth) <: UsualEqualityTypeBoth := OptionUsualEq E <+ UsualIsEq <+ UsualIsEqOrig.

Module OptionUsualDecidableType (E : UsualDecidableType) <: UsualDecidableType
:= OptionUsualEq E <+ UsualIsEq <+ OptionUsualHasEqDec E E.
Module OptionUsualDecidableTypeOrig (E : UsualDecidableTypeOrig) <: UsualDecidableTypeOrig
:= OptionUsualEq E <+ UsualIsEqOrig <+ OptionUsualHasEqDec E E.
Module OptionUsualDecidableTypeBoth (E : UsualDecidableTypeBoth) <: UsualDecidableTypeBoth
 := OptionUsualDecidableType E <+ UsualIsEqOrig.
Module OptionUsualBoolEq (E : UsualBoolEq) <: UsualBoolEq
:= OptionUsualEq E <+ OptionUsualHasEqBool E.
Module OptionUsualDecidableTypeFull (E : UsualDecidableTypeFull) <: UsualDecidableTypeFull
 := OptionUsualEq E <+ UsualIsEq <+ UsualIsEqOrig <+ OptionUsualHasEqDec E E <+ OptionUsualHasEqBool E.

Module OptionEqbType (E : EqbType) <: EqbType := OptionTyp E <+ OptionHasEqb E E <+ OptionIsEqb E.


(* This file is developed by Qinxiang Cao, Aquinas Hobor and Shengyi Wang in 2015. *)

Require Import VST.veric.base.
Require Import VST.veric.val_lemmas.
Require Import VST.veric.Memory.

Lemma range_overlap_spec: forall l1 n1 l2 n2,
  n1 > 0 ->
  n2 > 0 ->
  (range_overlap l1 n1 l2 n2 <-> adr_range l1 n1 l2 \/ adr_range l2 n2 l1).
Proof.
  intros.
  unfold range_overlap, adr_range.
  destruct l1, l2.
  split; intros.
  + destruct H1 as [[? ?] [[? ?] [? ?]]].
    subst.
    destruct (zle z z0); [left | right].
    - split; auto.
      omega.
    - split; auto.
      omega.
  + destruct H1 as [[? ?] | [? ?]].
    - exists (b0, z0). repeat split; auto; omega.
    - exists (b, z). repeat split; auto; omega.
Qed.

Lemma range_overlap_comm: forall l1 n1 l2 n2, range_overlap l1 n1 l2 n2 -> range_overlap l2 n2 l1 n1.
Proof.
  unfold range_overlap.
  intros.
  destruct H as [l ?].
  exists l.
  tauto.
Qed.

Lemma range_overlap_non_zero: forall l1 n1 l2 n2, range_overlap l1 n1 l2 n2 -> n1 > 0 /\ n2 > 0.
Proof.
  unfold range_overlap.
  intros.
  destruct H as [l [? ?]].
  apply adr_range_non_zero in H.
  apply adr_range_non_zero in H0.
  auto.
Qed.

Definition pointer_range_overlap p n p' n' :=
  exists l l', val2adr p l /\ val2adr p' l' /\ range_overlap l n l' n'.

Lemma pointer_range_overlap_dec: forall p1 n1 p2 n2, {pointer_range_overlap p1 n1 p2 n2} + {~ pointer_range_overlap p1 n1 p2 n2}.
Proof.
  unfold pointer_range_overlap.
  intros.
  destruct p1;
  try solve
   [right;
    intros [[? ?] [[? ?] [HH [_ _]]]];
    inversion HH].
  destruct p2;
  try solve
   [right;
    intros [[? ?] [[? ?] [_ [HH _]]]];
    inversion HH].
  destruct (zlt 0 n1); [| right; intros [[? ?] [[? ?] [_ [_ HH]]]]; apply range_overlap_non_zero in HH; omega].
  destruct (zlt 0 n2); [| right; intros [[? ?] [[? ?] [_ [_ HH]]]]; apply range_overlap_non_zero in HH; omega].
  destruct (eq_block b b0).
  (*destruct (Clight_lemmas.block_eq_dec b b0).*)
  + subst b0.
    unfold val2adr.
    forget (Ptrofs.unsigned i) as i1;
    forget (Ptrofs.unsigned i0) as i2;
    clear i i0.
    destruct (range_dec i1 i2 (i1 + n1)); [| destruct (range_dec i2 i1 (i2 + n2))].
    - left.
      exists (b, i1), (b, i2); repeat split; auto.
      apply range_overlap_spec; try omega.
      left; simpl; auto.
    - left.
      exists (b, i1), (b, i2); repeat split; auto.
      apply range_overlap_spec; try omega.
      right; simpl; auto.
    - right.
      intros [[? ?] [[? ?] [? [? HH]]]].
      inversion H; inversion H0; subst.
      apply range_overlap_spec in HH; [| omega | omega].
      simpl in HH; omega.
  + right.
    intros [[? ?] [[? ?] [? [? HH]]]].
    simpl in H, H0.
    inversion H; inversion H0; subst.
    apply range_overlap_spec in HH; [| omega | omega].
    simpl in HH.
    pose proof @eq_sym _ b0 b.
    tauto.
Qed.

Lemma pointer_range_overlap_refl: forall p n1 n2,
  isptr p ->
  n1 > 0 ->
  n2 > 0 ->
  pointer_range_overlap p n1 p n2.
Proof.
  intros.
  destruct p; try inversion H.
  exists (b, Ptrofs.unsigned i), (b, Ptrofs.unsigned i).
  repeat split; auto.
  apply range_overlap_spec; auto.
  left.
  simpl.
  split; auto; omega.
Qed.

Lemma pointer_range_overlap_comm: forall p1 n1 p2 n2,
  pointer_range_overlap p1 n1 p2 n2 <->
  pointer_range_overlap p2 n2 p1 n1.
Proof.
  cut (forall p1 n1 p2 n2,
         pointer_range_overlap p1 n1 p2 n2 ->
         pointer_range_overlap p2 n2 p1 n1). {
    intros.
    pose proof H p1 n1 p2 n2.
    pose proof H p2 n2 p1 n1.
    tauto.
  }
  unfold pointer_range_overlap.
  intros.
  destruct H as [l [l' [? [? ?]]]].
  exists l', l.
  repeat split; auto.
  apply range_overlap_comm.
  auto.
Qed.

Lemma pointer_range_overlap_non_zero: forall p1 n1 p2 n2,
  pointer_range_overlap p1 n1 p2 n2 -> n1 > 0 /\ n2 > 0.
Proof.
  intros.
  destruct H as [? [? [? [? ?]]]].
  eapply range_overlap_non_zero; eauto.
Qed.

Lemma pointer_range_overlap_isptr: forall p1 n1 p2 n2,
  pointer_range_overlap p1 n1 p2 n2 -> isptr p1 /\ isptr p2.
Proof.
  intros.
  destruct H as [? [? [? [? ?]]]].
  destruct p1, p2; try solve [inversion H | inversion H0].
  simpl; auto.
Qed.


(**
This file is part of the Flocq formalization of floating-point
arithmetic in Coq: http://flocq.gforge.inria.fr/

Copyright (C) 2010-2011 Sylvie Boldo
#<br />#
Copyright (C) 2010-2011 Guillaume Melquiond

This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 3 of the License, or (at your option) any later version.

This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
COPYING file for more details.
*)

(** * Error of the multiplication is in the FLX/FLT format *)
Require Import Fcore.
Require Import Fcalc_ops.

Section Fprop_mult_error.

Variable beta : radix.
Notation bpow e := (bpow beta e).

Variable prec : Z.
Context { prec_gt_0_ : Prec_gt_0 prec }.

Notation format := (generic_format beta (FLX_exp prec)).
Notation cexp := (canonic_exp beta (FLX_exp prec)).

Variable rnd : R -> Z.
Context { valid_rnd : Valid_rnd rnd }.

(** Auxiliary result that provides the exponent *)
Lemma mult_error_FLX_aux:
  forall x y,
  format x -> format y ->
  (round beta (FLX_exp prec) rnd (x * y) - (x * y) <> 0)%R ->
  exists f:float beta,
      (F2R f = round beta (FLX_exp prec) rnd (x * y) - (x * y))%R
      /\  (canonic_exp beta (FLX_exp prec) (F2R f) <= Fexp f)%Z
      /\ (Fexp f = cexp x + cexp y)%Z.
Proof with auto with typeclass_instances.
intros x y Hx Hy Hz.
set (f := (round beta (FLX_exp prec) rnd (x * y))).
destruct (Req_dec (x * y) 0) as [Hxy0|Hxy0].
contradict Hz.
rewrite Hxy0.
rewrite round_0...
ring.
destruct (ln_beta beta (x * y)) as (exy, Hexy).
specialize (Hexy Hxy0).
destruct (ln_beta beta (f - x * y)) as (er, Her).
specialize (Her Hz).
destruct (ln_beta beta x) as (ex, Hex).
assert (Hx0: (x <> 0)%R).
contradict Hxy0.
now rewrite Hxy0, Rmult_0_l.
specialize (Hex Hx0).
destruct (ln_beta beta y) as (ey, Hey).
assert (Hy0: (y <> 0)%R).
contradict Hxy0.
now rewrite Hxy0, Rmult_0_r.
specialize (Hey Hy0).
(* *)
assert (Hc1: (cexp (x * y)%R - prec <= cexp x + cexp y)%Z).
unfold canonic_exp, FLX_exp.
rewrite ln_beta_unique with (1 := Hex).
rewrite ln_beta_unique with (1 := Hey).
rewrite ln_beta_unique with (1 := Hexy).
cut (exy - 1 < ex + ey)%Z. omega.
apply (lt_bpow beta).
apply Rle_lt_trans with (1 := proj1 Hexy).
rewrite Rabs_mult.
rewrite bpow_plus.
apply Rmult_le_0_lt_compat.
apply Rabs_pos.
apply Rabs_pos.
apply Hex.
apply Hey.
(* *)
assert (Hc2: (cexp x + cexp y <= cexp (x * y)%R)%Z).
unfold canonic_exp, FLX_exp.
rewrite ln_beta_unique with (1 := Hex).
rewrite ln_beta_unique with (1 := Hey).
rewrite ln_beta_unique with (1 := Hexy).
cut ((ex - 1) + (ey - 1) < exy)%Z.
generalize (prec_gt_0 prec).
clear ; omega.
apply (lt_bpow beta).
apply Rle_lt_trans with (2 := proj2 Hexy).
rewrite Rabs_mult.
rewrite bpow_plus.
apply Rmult_le_compat.
apply bpow_ge_0.
apply bpow_ge_0.
apply Hex.
apply Hey.
(* *)
assert (Hr: ((F2R (Float beta (- (Ztrunc (scaled_mantissa beta (FLX_exp prec) x) *
  Ztrunc (scaled_mantissa beta (FLX_exp prec) y)) + rnd (scaled_mantissa beta (FLX_exp prec) (x * y)) *
  beta ^ (cexp (x * y)%R - (cexp x + cexp y))) (cexp x + cexp y))) = f - x * y)%R).
rewrite Hx at 6.
rewrite Hy at 6.
rewrite <- F2R_mult.
simpl.
unfold f, round, Rminus.
rewrite <- F2R_opp, Rplus_comm, <- F2R_plus.
unfold Fplus. simpl.
now rewrite Zle_imp_le_bool with (1 := Hc2).
(* *)
exists (Float beta (- (Ztrunc (scaled_mantissa beta (FLX_exp prec) x) *
  Ztrunc (scaled_mantissa beta (FLX_exp prec) y)) + rnd (scaled_mantissa beta (FLX_exp prec) (x * y)) *
  beta ^ (cexp (x * y)%R - (cexp x + cexp y))) (cexp x + cexp y)).
split;[assumption|split].
rewrite Hr.
simpl.
clear Hr.
apply Zle_trans with (cexp (x * y)%R - prec)%Z.
unfold canonic_exp, FLX_exp.
apply Zplus_le_compat_r.
rewrite ln_beta_unique with (1 := Hexy).
apply ln_beta_le_bpow with (1 := Hz).
replace (bpow (exy - prec)) with (ulp beta (FLX_exp prec) (x * y)).
apply ulp_error...
unfold ulp, canonic_exp.
now rewrite ln_beta_unique with (1 := Hexy).
apply Hc1.
reflexivity.
Qed.

(** Error of the multiplication in FLX *)
Theorem mult_error_FLX :
  forall x y,
  format x -> format y ->
  format (round beta (FLX_exp prec) rnd (x * y) - (x * y))%R.
Proof.
intros x y Hx Hy.
destruct (Req_dec (round beta (FLX_exp prec) rnd (x * y) - x * y) 0) as [Hr0|Hr0].
rewrite Hr0.
apply generic_format_0.
destruct (mult_error_FLX_aux x y Hx Hy Hr0) as ((m,e),(H1,(H2,H3))).
rewrite <- H1.
now apply generic_format_F2R.
Qed.

End Fprop_mult_error.

Section Fprop_mult_error_FLT.

Variable beta : radix.
Notation bpow e := (bpow beta e).

Variable emin prec : Z.
Context { prec_gt_0_ : Prec_gt_0 prec }.
Variable Hpemin: (emin <= prec)%Z.

Notation format := (generic_format beta (FLT_exp emin prec)).
Notation cexp := (canonic_exp beta (FLT_exp emin prec)).

Variable rnd : R -> Z.
Context { valid_rnd : Valid_rnd rnd }.

(** Error of the multiplication in FLT with underflow requirements *)
Theorem mult_error_FLT :
  forall x y,
  format x -> format y ->
  (x*y = 0)%R \/ (bpow (emin + 2*prec - 1) <= Rabs (x * y))%R ->
  format (round beta (FLT_exp emin prec) rnd (x * y) - (x * y))%R.
Proof with auto with typeclass_instances.
clear Hpemin.
intros x y Hx Hy Hxy.
set (f := (round beta (FLT_exp emin prec) rnd (x * y))).
destruct (Req_dec (f - x * y) 0) as [Hr0|Hr0].
rewrite Hr0.
apply generic_format_0.
destruct Hxy as [Hxy|Hxy].
unfold f.
rewrite Hxy.
rewrite round_0...
ring_simplify (0 - 0)%R.
apply generic_format_0.
destruct (mult_error_FLX_aux beta prec rnd x y) as ((m,e),(H1,(H2,H3))).
now apply generic_format_FLX_FLT with emin.
now apply generic_format_FLX_FLT with emin.
rewrite <- (round_FLT_FLX beta emin).
assumption.
apply Rle_trans with (2:=Hxy).
apply bpow_le.
generalize (prec_gt_0 prec).
clear ; omega.
rewrite <- (round_FLT_FLX beta emin) in H1.
2:apply Rle_trans with (2:=Hxy).
2:apply bpow_le ; generalize (prec_gt_0 prec) ; clear ; omega.
unfold f; rewrite <- H1.
apply generic_format_F2R.
intros _.
simpl in H2, H3.
unfold canonic_exp, FLT_exp.
case (Zmax_spec (ln_beta beta (F2R (Float beta m e)) - prec) emin);
  intros (M1,M2); rewrite M2.
apply Zle_trans with (2:=H2).
unfold canonic_exp, FLX_exp.
apply Zle_refl.
rewrite H3.
unfold canonic_exp, FLX_exp.
assert (Hxy0:(x*y <> 0)%R).
contradict Hr0.
unfold f.
rewrite Hr0.
rewrite round_0...
ring.
assert (Hx0: (x <> 0)%R).
contradict Hxy0.
now rewrite Hxy0, Rmult_0_l.
assert (Hy0: (y <> 0)%R).
contradict Hxy0.
now rewrite Hxy0, Rmult_0_r.
destruct (ln_beta beta x) as (ex,Ex) ; simpl.
specialize (Ex Hx0).
destruct (ln_beta beta y) as (ey,Ey) ; simpl.
specialize (Ey Hy0).
assert (emin + 2 * prec -1 < ex + ey)%Z.
2: omega.
apply (lt_bpow beta).
apply Rle_lt_trans with (1:=Hxy).
rewrite Rabs_mult, bpow_plus.
apply Rmult_le_0_lt_compat; try apply Rabs_pos.
apply Ex.
apply Ey.
Qed.

End Fprop_mult_error_FLT.


(**
    Definitions of Algorithmic Lightweight Linear F
    Authors: Aileen Zhang, Jianzhou Zhao, and Steve Zdancewic.
*)

Require Export LinearF_Definitions.
Require Export LinearF_Infrastructure.

(* ********************************************************************** *)
(** * ## Algo Environments *)

(** In our presentation of System F with subtyping, we use a single
    environment for both typing and subtyping assumptions.  We
    formalize environments by representing them as association lists
    (lists of pairs of keys and values) whose keys are atoms.

    The [Metatheory] and [Environment] libraries provide functions,
    predicates, tactics, notations and lemmas that simplify working
    with environments.  The [Environment] library treats environments
    as lists of type [list (atom * A)].

    Since environments map [atom]s, the type [A] should encode whether
    a particular binding is a typing or subtyping assumption.  Thus,
    we instantiate [A] with the type [binding], defined below. *)

Inductive gbinding : Set :=
  | gbind_kn :  kn -> gbinding
  | gbind_typ : typ -> gbinding.

Notation genv := (list (atom * gbinding)).
Notation gempty := (@nil (atom * gbinding)).

Inductive dbinding : Set :=
  | dbind_typ : typ -> dbinding.

Notation denv := (list (atom * dbinding)).
Notation dempty := (@nil (atom * dbinding)).

(* ********************************************************************** *)
(** * ## Well-formedness *)

(** A type [T] is well-formed with respect to an environment [E],
    denoted [(wf_typ E T)], when [T] is locally-closed and its free
    variables are bound in [E].  We need this relation in order to
    restrict the subtyping and typing relations, defined below, to
    contain only well-formed types.  (This relation is missing in the
    original statement of the POPLmark Challenge.)

    Note: It is tempting to define the premise of [wf_typ_var] as [(X
    `in` dom E)], since that makes the rule easier to apply (no need
    to guess an instantiation for [U]).  Unfortunately, this is
    incorrect.  We need to check that [X] is bound as a type-variable,
    not an expression-variable; [(dom E)] does not distinguish between
    the two kinds of bindings. *)
Inductive kn_order : kn -> kn -> Prop :=
  | kn_order_base :
     kn_order kn_nonlin kn_lin
  | kn_order_refl : forall K,
     kn_order K K
 .

Inductive wf_atyp : genv -> typ -> kn -> Prop :=
  | wf_atyp_var : forall K G (X : atom),
      ok G ->
      binds X (gbind_kn K) G ->
      wf_atyp G (typ_fvar X) K
  | wf_atyp_arrow : forall G K1 K2 K T1 T2,
      wf_atyp G T1 K1 ->
      wf_atyp G T2 K2 ->
      wf_atyp G (typ_arrow K T1 T2) K
  | wf_atyp_all : forall L G K1 K2 T2,
      (forall X : atom, X `notin` L ->
        wf_atyp ([(X, gbind_kn K1)] ++ G) (open_tt T2 X) K2) ->
      wf_atyp G (typ_all K1 T2) K2
  .

(** An environment E is well-formed, denoted [(wf_env E)], if each
    atom is bound at most at once and if each binding is to a
    well-formed type.  This is a stronger relation than the [ok]
    relation defined in the [Environment] library.  We need this
    relation in order to restrict the subtyping and typing relations,
    defined below, to contain only well-formed environments.  (This
    relation is missing in the original statement of the POPLmark
    Challenge.)  *)

Inductive wf_genv : genv -> Prop :=
  | wf_genv_empty :
      wf_genv gempty
  | wf_genv_kn : forall (G : genv) (X : atom) (K : kn),
      wf_genv G ->
      X `notin` dom G ->
      wf_genv ([(X, gbind_kn K)] ++ G)
  | wf_genv_typ : forall (G : genv) (x : atom) (T : typ) ,
      wf_genv G ->
      wf_atyp G T kn_nonlin ->
      x `notin` dom G ->
      wf_genv ([(x, gbind_typ T)] ++ G)
.

Inductive wf_denv : genv -> denv -> Prop :=
  | wf_denv_empty : forall G,
     wf_genv G ->
     wf_denv G dempty
  | wf_denv_typ : forall G D T x,
    wf_denv G D ->
    wf_atyp G T kn_lin ->
    x `notin` dom G ->
    x `notin` dom D ->
    wf_denv G ([(x, dbind_typ T)] ++ D)
.

Fixpoint dminus_var (x : atom) (l : list (atom*dbinding)){struct l} : list (atom*dbinding) :=
  match l with
  | nil => nil
  | (y, b)::tl => if (eq_atom_dec x y) then dminus_var x tl else (y, b)::(dminus_var x tl)
  end.

Notation "D [-] x" := (dminus_var x D) (at level 70, no associativity).

Fixpoint dminus (D : denv) (D' : denv) {struct D'} : denv :=
  match D' with
  | nil => D
  | (y, b)::tl => dminus (D [-] y) tl
  end.

Notation "D -- D'" := (dminus D D') (at level 70, no associativity).

(* ********************************************************************** *)
(** * ## Algo Typing *)

Inductive atyping : genv -> denv -> exp -> typ -> denv -> Prop :=
  | atyping_uvar : forall G D x T,
      binds x (gbind_typ T) G ->
      wf_denv G D ->
      atyping G D x T D
  | atyping_lvar : forall G D x T,
      binds x (dbind_typ T) D ->
      wf_denv G D ->
      atyping G D x T (D [-] x)
   | atyping_uabs : forall L K G D V e1 T1 D',
      wf_atyp G V kn_nonlin ->
      (forall x : atom, x `notin` L ->
        atyping ([(x, gbind_typ V)] ++ G) D  (open_ee e1 x) T1 D') ->
      (K = kn_nonlin -> D = D') ->
      atyping G D (exp_abs K V e1) (typ_arrow K V T1) D'
   | atyping_labs : forall L K G D V e1 T1 D',
      wf_atyp G V kn_lin ->
      (forall x : atom, x `notin` L ->
        atyping G ([(x, dbind_typ V)] ++ D)  (open_ee e1 x) T1 D') ->
      (K = kn_nonlin -> D = D') ->
      atyping G D (exp_abs K V e1) (typ_arrow K V T1) D'
  | atyping_app : forall G T1 K D1 D2 D3 e1 e2 T2,
      atyping G D1 e1 (typ_arrow K T1 T2) D2->
      atyping G D2 e2 T1 D3 ->
      atyping G D1 (exp_app e1 e2) T2 D3
  | atyping_tabs : forall L G K e1 T1 D D' K',
      value e1 ->
      (forall X : atom, X `notin` L ->
	wf_atyp ([(X,gbind_kn K)] ++ G) (open_tt T1 X) K') ->
      (forall X : atom, X `notin` L ->
        atyping ([(X,gbind_kn K)] ++ G) D (open_te e1 X) (open_tt T1 X) D')->
      atyping G D (exp_tabs K e1) (typ_all K T1) D'
  | atyping_tapp : forall K K'  G e1 T T2 D D',
      atyping G D e1 (typ_all K T2) D' ->
      wf_atyp G T K' ->
      kn_order K' K ->
      atyping G D (exp_tapp e1 T) (open_tt T2 T) D'
.

(* ********************************************************************** *)
(** * ## Automation *)

(** We declare most constructors as [Hint]s to be used by the [auto]
    and [eauto] tactics.  We exclude constructors from the subtyping
    and typing relations that use cofinite quantification.  It is
    unlikely that [eauto] will find an instantiation for the finite
    set [L], and in those cases, [eauto] can take some time to fail.
    (A priori, this is not obvious.  In practice, one adds as hints
    all constructors and then later removes some constructors when
    they cause proof search to take too long.) *)

Hint Constructors wf_atyp wf_genv wf_denv ok.
Hint Resolve atyping_uvar atyping_lvar atyping_app atyping_tapp.

(* ********************************************************************** *)
(** * ## Cases Tactic *)

Tactic Notation "typ_cases" tactic(first) tactic(c) :=
  first;
  [ c "typ_bvar" |  c "typ_fvar" |
    c "typ_arrow" | c "typ_all" ].

Tactic Notation "exp_cases" tactic(first) tactic(c) :=
  first;
  [ c "exp_bvar" |  c "exp_fvar" |
    c "exp_abs" | c "exp_app" |
    c "exp_tabs" | c "exp_tapp" ].

Tactic Notation "type_cases" tactic(first) tactic(c) :=
  first;
  [ c "type_var" | c "type_arrow" | c "type_all" ].

Tactic Notation "expr_cases" tactic(first) tactic(c) :=
  first;
  [ c "expr_var" |
    c "expr_abs" | c "expr_app" |
    c "expr_tabs" | c "expr_tapp" ].

Tactic Notation "wf_atyp_cases" tactic(first) tactic(c) :=
  first;
  [ c "wf_atyp_var" | c "wf_atyp_arrow" | c "wf_typS_all" ].

Tactic Notation "wf_genv_cases" tactic(first) tactic(c) :=
  first;
  [ c "wf_genv_empty" | c "wf_genv_kn" | c "wf_genv_typ" ].

Tactic Notation "wf_denv_cases" tactic(first) tactic(c) :=
  first;
  [ c "wf_denv_empty" | c "wf_denv_typ" ].

Tactic Notation "value_cases" tactic(first) tactic(c) :=
  first;
  [ c "value_abs" | c "value_tabs" ].

Tactic Notation "red_cases" tactic(first) tactic(c) :=
  first;
  [ c "red_app_1" |  c "red_app_2" |
    c "red_tapp" | c "red_abs" | c "red_tabs" ].

Tactic Notation "atyping_cases" tactic(first) tactic(c) :=
  first;
  [ c "atyping_uvar" | c "atyping_lvar" |
    c "atyping_uabs" | c "atyping_labs" | c "atyping_app" |
    c "atyping_tabs" | c "atyping_tapp" ].


Require Export SystemFR.StarInversions.
Require Export SystemFR.WFLemmas.

Fixpoint nat_recognizer (v: tree): tree :=
  match v with
  | zero => tmatch (lvar 0 term_var) ttrue tfalse
  | succ v' => tmatch (lvar 0 term_var) tfalse (nat_recognizer v')
  | _ => tfalse
  end.

Lemma is_erased_term_nat_recognizer:
  forall v, is_erased_term (nat_recognizer v).
Proof.
  induction v;
    repeat step.
Qed.

Lemma wf_nat_recognizer:
  forall v, wf (nat_recognizer v) 1.
Proof.
  induction v;
    repeat step; eauto with wf; eauto using wf_loop.
Qed.

Lemma fv_nat_recognizer:
  forall v tag, pfv (nat_recognizer v) tag = nil.
Proof.
  induction v;
    repeat step || list_utils.
Qed.

Lemma eval_nat_recognizer:
  forall v,
    is_nat_value v ->
    open 0 (nat_recognizer v) v ~>* ttrue.
Proof.
  induction 1;
    repeat step; eauto using star_one with smallstep.

  eapply Relation_Operators.rt1n_trans; eauto with smallstep values.
  rewrite (open_none _ 1); eauto using wf_nat_recognizer.
Qed.

Lemma eval_nat_recognizer2:
  forall v1 v2,
    is_nat_value v2 ->
      open 0 (nat_recognizer v1) v2 ~>* ttrue \/
      open 0 (nat_recognizer v1) v2 ~>* tfalse.
Proof.
  induction v1; inversion 1;
    repeat
      step ||
      rewrite open_none by eauto using wf_nat_recognizer;
    eauto using star_one, scbv_step_same with smallstep values.
    try solve [
      instantiate_any; steps;
        eauto using star_one, scbv_step_same with smallstep values star
    ].
Qed.

Lemma true_nat_recognizer:
  forall v,
    is_nat_value v ->
    forall v',
      cbv_value v' ->
      open 0 (nat_recognizer v) v' ~>* ttrue ->
      v = v'
.
Proof.
  induction 1;
    repeat step || t_invert_star;
    eauto using star_one with smallstep.

  rewrite (open_none _ 1) in H6 by eauto using wf_nat_recognizer.
  eauto using f_equal.
Qed.


Require Import
  HoTT.Utf8
  HoTT.Classes.implementations.list
  HoTT.Basics.Overture
  HoTT.Spaces.Nat.

Local Open Scope nat_scope.
Local Open Scope type_scope.

Declare Scope ne_list_scope.

Delimit Scope ne_list_scope with ne_list.

Open Scope ne_list_scope.

(** Nonempty list implementation [ne_list.ne_list]. *)

Module ne_list.

Section with_type.
  Context {T: Type}.

(** A nonempty list. Below there is an implicit coercion
    [ne_list >-> list]. *)

  Inductive ne_list : Type
    := one: T → ne_list | cons: T → ne_list → ne_list.

  Fixpoint app (a b: ne_list): ne_list :=
    match a with
    | one x => cons x b
    | cons x y => cons x (app y b)
    end.

  Fixpoint foldr {R} (u: T → R) (f: T → R → R) (a: ne_list): R :=
    match a with
    | one x => u x
    | cons x y => f x (foldr u f y)
    end.

  Fixpoint foldr1 (f: T → T → T) (a: ne_list): T :=
    match a with
    | one x => x
    | cons x y => f x (foldr1 f y)
    end.

  Definition head (l: ne_list): T
    := match l with one x => x | cons x _ => x end.

  Fixpoint to_list (l: ne_list): list T :=
    match l with
    | one x => x :: nil
    | cons x xs => x :: to_list xs
    end.

  Fixpoint from_list (x: T) (xs: list T): ne_list :=
    match xs with
    | nil => one x
    | Datatypes.cons h t => cons x (from_list h t)
    end.

  Definition tail (l: ne_list): list T
    := match l with one _ => nil | cons _ x => to_list x end.

  Lemma decomp_eq (l: ne_list): l = from_list (head l) (tail l).
  Proof with auto.
    induction l...
    destruct l...
    cbn in *.
    rewrite IHl...
  Qed.

  Definition last: ne_list → T := foldr1 (fun x y => y).

  Fixpoint replicate_Sn (x: T) (n: nat): ne_list :=
    match n with
    | 0 => one x
    | S n' => cons x (replicate_Sn x n')
    end.

  Fixpoint take (n: nat) (l: ne_list): ne_list :=
    match l, n with
    | cons x xs, S n' => take n' xs
    | _, _ => one (head l)
    end.

  Fixpoint front (l: ne_list) : list T :=
    match l with
    | one _ => nil
    | cons x xs => x :: front xs
    end.

  Lemma two_level_rect (P: ne_list → Type)
    (Pone: ∀ x, P (one x))
    (Ptwo: ∀ x y, P (cons x (one y)))
    (Pmore: ∀ x y z, P z → (∀ y', P (cons y' z)) → P (cons x (cons y z)))
    : ∀ l, P l.
  Proof with auto.
   cut (∀ l, P l * ∀ x, P (cons x l)).
   - intros. apply X.
   - destruct l...
     revert t.
     induction l...
     intros.
     split.
     + apply IHl.
     + intro. apply Pmore; intros; apply IHl.
  Qed.

  Lemma tl_length (l: ne_list)
    : S (length (tl (to_list l))) = length (to_list l).
  Proof. destruct l; reflexivity. Qed.
End with_type.

Arguments ne_list : clear implicits.

Fixpoint tails {T} (l: ne_list T): ne_list (ne_list T) :=
  match l with
  | one x => one (one x)
  | cons x y => cons l (tails y)
  end.

Lemma tails_are_shorter {T} (y x: ne_list T):
  InList x (to_list (tails y)) →
  leq (length (to_list x)) (length (to_list y)).
Proof with auto.
 induction y; cbn.
 - intros [[] | C].
   + constructor.
   + elim C.
 - intros [[] | C]...
Qed.

Fixpoint map {A B} (f: A → B) (l: ne_list A): ne_list B :=
  match l with
  | one x => one (f x)
  | cons h t => cons (f h) (map f t)
  end.

Lemma list_map {A B} (f: A → B) (l: ne_list A)
  : to_list (map f l) = list.map f (to_list l).
Proof.
  induction l.
  - reflexivity.
  - cbn. rewrite <- IHl. reflexivity.
Qed.

Fixpoint inits {A} (l: ne_list A): ne_list (ne_list A) :=
  match l with
  | one x => one (one x)
  | cons h t => cons (one h) (map (cons h) (inits t))
  end.

Fixpoint zip {A B: Type} (l: ne_list A) (m: ne_list B)
  : ne_list (A * B) :=
  match l with
  | one a => one (a, head m)
  | cons a l =>
      match m with
      | one b => one (a, b)
      | cons b m => cons (a, b) (zip l m)
      end
  end.

  Module notations.

    Global Notation ne_list := ne_list.

    Global Notation "[: x :]" := (one x) : ne_list_scope.

    Global Notation "[: x ; .. ; y ; z :]"
        := (cons x .. (cons y (one z)) ..) : ne_list_scope.

    Global Infix ":::" := cons : ne_list_scope.

  End notations.

End ne_list.

Global Coercion ne_list.to_list : ne_list.ne_list >-> list.


(* Use of this source code is governed by the license described	*
 * in the LICENSE file at the root of the source tree.		*)

(* Definitions and theory related to "procedures" -- functions that return computations and special forms of the same.
*)

Set Implicit Arguments.
Unset Strict Implicit.

Require Import FCF.
Require Import CompFold.
(* Require Import ProgramLogic_old. *)

Local Open Scope type_scope.

Record ProcedureWithOracle
  (D_P R_P D_O R_O : Set) := {
    q : nat;
    S_P : Set;
    P1 : D_P -> Comp (D_O * S_P);
    P2 : S_P -> R_O -> Comp (D_O * S_P);
    P3 : S_P -> R_O -> Comp R_P;

    P1_wf : forall x, well_formed_comp (P1 x);
    P2_wf : forall x y, well_formed_comp (P2 x y);
    P3_wf : forall x y, well_formed_comp (P3 x y);

    S_P_EqDec : EqDec S_P;
    D_O_EqDec : EqDec D_O;
    R_O_EqDec : EqDec R_O;
    R_P_EqDec : EqDec R_P

      }.

Section CompLoop.

  Variable A : Set.
  Hypothesis eqd : EqDec A.

  Variable c : A -> Comp A.
  Hypothesis c_wf : forall a, well_formed_comp (c a).

  Definition compLoop n (a : A) : Comp A :=
    compFold _ (fun a n => c a) a (allNatsLt n).

  Theorem compLoop_wf : forall n a,
    well_formed_comp (compLoop n a).

    intuition.
    eapply compFold_wf; intuition.
  Qed.

End CompLoop.

Theorem compLoop_O :
  forall (A : Set)(eqda : EqDec A)(c : A -> Comp A) a,
    (compLoop _ c O a) = ret a.

  intuition.

Qed.

Theorem compLoop_S :
  forall (A : Set)(eqda : EqDec A)(c : A -> Comp A) n a x,
    evalDist (compLoop _ c (S n) a) x ==
    evalDist (a0 <-$ c a; compLoop eqda c n a0) x.

  induction n; intuition.
  unfold compLoop, allNatsLt.
  rewrite app_nil_l.
  unfold compFold.
  intuition.

  unfold compLoop, allNatsLt.
  fold allNatsLt.

  eapply eqRat_trans.
  rewrite compFold_app.
  eapply evalDist_seq_eq.
  intros.
  eapply IHn.
  intros.
  eapply eqRat_refl.
  dist_inline_first.
  comp_skip.
  unfold compLoop.
  eapply eqRat_trans.
  symmetry.
  eapply compFold_app.

  eapply comp_spec_eq_impl_eq.
  eapply (@compFold_eq _ _ (fun x y => True)).
  eapply list_pred_I.
  repeat rewrite app_length.
  simpl; intuition.

  intuition.
Qed.

Theorem compLoop_spec :
  forall (A B : Set){e1 : EqDec A}{e2 : EqDec B}(P : A -> B -> Prop)(c1 : A -> Comp A)(c2 : B -> Comp B) n a b,
    (forall x y, P x y -> comp_spec P (c1 x) (c2 y)) ->
    P a b ->
    comp_spec P (compLoop e1 c1 n a) (compLoop e2 c2 n b).

  induction n; intuition.
  unfold compLoop.
  simpl.
  eapply comp_spec_ret; intuition.

  unfold compLoop in *.
  simpl.
  (*
  eapply comp_spec_eq_trans.
  eapply eq_impl_comp_spec_eq.
  intros.
  eapply compFold_app.
  eapply comp_spec_eq_trans_r.
  Focus 2.
  eapply comp_spec_eq_symm.
  eapply eq_impl_comp_spec_eq.
  intros.
  eapply compFold_app.
  eapply comp_spec_seq; intuition.
  simpl.
  eapply comp_spec_seq; intuition.
  eapply comp_spec_ret; intuition.
   *)
Admitted.

Theorem compLoop_eq :
  forall (A : Set){e1 e2 : EqDec A}(c1 c2 : A -> Comp A) n a x,
    (forall x y, evalDist (c1 x) y == evalDist (c2 x) y) ->
    evalDist (compLoop e1 c1 n a) x == evalDist (compLoop e2 c2 n a) x.

  intuition.
  eapply (@comp_spec_eq_impl_eq _ e1 e2).
  eapply compLoop_spec; intuition.
  subst.
  eapply eq_impl_comp_spec_eq.
  eapply H.

Qed.

Section RunP2.

  Variable S_P D_O R_O : Set.
  Variable P2 : S_P -> R_O -> Comp (D_O * S_P).
  Variable S_O : Set.
  Variable P_O : S_O -> D_O -> Comp (R_O * S_O).

  Hypothesis S_O_EqDec : EqDec S_O.
  Hypothesis S_P_EqDec : EqDec S_P.
  Hypothesis D_O_EqDec : EqDec D_O.

  Definition runP2_once (p : S_O * S_P * D_O) :=
    [s_O, s_P, d] <-3 p;
    [r, s_O] <-$2 P_O s_O d;
    [d, s_P] <-$2 P2 s_P r;
    ret (s_O, s_P, d).

  Definition runP2 q s_O s_P d := compLoop _ runP2_once q (s_O, s_P, d).

End RunP2.

Section RunWithOracle.

  Variable D_P R_P D_O R_O : Set.
  Variable (P : ProcedureWithOracle D_P R_P D_O R_O).
  Variable (d_P : D_P).

  Variable S_O : Set.
  Hypothesis S_O_EqDec : EqDec S_O.
  Variable P_O : S_O -> D_O -> Comp (R_O * S_O).
(*
  Hint Resolve (P.(S_P_EqDec)) : typeclass_instances.
  Hint Resolve (P.(D_O_EqDec)) : typeclass_instances.
  Hint Resolve (P.(R_P_EqDec)) : typeclass_instances.
*)

  Definition runPWO s_O :=
    [d, s_P] <-$2 P.(P1) d_P;
    [s_O, s_P, d] <-$3 runP2 (@P2 _ _ _ _ P) P_O _ _ _ P.(q) s_O s_P d;
    [r, s_O] <-$2 P_O s_O d;
    r_P <-$ P3 s_P r;
    ret (s_O, r_P).

End RunWithOracle.

Arguments runPWO {D_P R_P D_O R_O} P d_P {S_O S_O_EqDec} P_O s_O.

(*
Definition runPWO(R_P D_O R_O : Set)(q : nat)(P: ProcedureWithOracle R_P D_O R_O q)
  (S_O : Set)(eqd_S_O : EqDec S_O)(oracle : S_O -> D_O -> Comp (R_O * S_O)) :=
  runProcedureWithOracle P _ oracle.
*)

Coercion runPWO : ProcedureWithOracle >-> Funclass.

Definition oracleWrap
  (D_O R_O S_O D_O' R_O' S_W : Set)
  (eqd_R_O' : EqDec R_O')
  (eqd_S_O : EqDec S_O)
  (oracle : S_O -> D_O -> Comp (R_O * S_O))
  (WD : D_O' -> Comp (D_O * S_W))
  (WR : S_W -> R_O -> Comp R_O') : S_O -> D_O' -> Comp (R_O' * S_O) :=
  fun s_O d_O' =>
    [d_O, s_W] <-$2 WD d_O';
    [r_O, s_O] <-$2 oracle s_O d_O;
    r_O' <-$ WR s_W r_O;
    ret (r_O', s_O).

Section PWO_Wrap.

  Variable D_P R_P D_O R_O : Set.
  Variable (P : ProcedureWithOracle D_P R_P D_O R_O).

  Hint Resolve (P.(S_P_EqDec)) : typeclass_instances.
  Hint Resolve (P.(R_O_EqDec)) : typeclass_instances.

  Variable D_O' R_O' S_W : Set.
  Variable WD : D_O -> Comp (D_O' * S_W).
  Variable WR : S_W -> R_O' -> Comp R_O.

  Hypothesis WD_wf : forall x, well_formed_comp (WD x).
  Hypothesis WR_wf : forall x y, well_formed_comp (WR x y).

  Hypothesis D_O'_EqDec : EqDec D_O'.
  Hypothesis R_O'_EqDec : EqDec R_O'.
  Hypothesis S_W_EqDec : EqDec S_W.

  Definition PWO_Wrap_P1 d_P :=
    [d_O, s_P] <-$2 P.(P1) d_P;
    [d_O', s_W] <-$2 WD d_O;
    ret (d_O', (s_P, s_W)).

  Theorem PWO_Wrap_P1_wf :
    forall x, well_formed_comp (PWO_Wrap_P1 x).

    intuition.
    unfold PWO_Wrap_P1.
    wftac.
    eapply P1_wf.

  Qed.

  Definition PWO_Wrap_P2 s_Ps r_O' :=
    [s_P, s_W] <-2 s_Ps;
    r_O <-$ WR s_W r_O';
    [d_O, s_P] <-$2 P2 s_P r_O;
    [d_O', s_W] <-$2 WD d_O;
    ret (d_O', (s_P, s_W)).

  Theorem PWO_Wrap_P2_wf :
    forall x y, well_formed_comp (PWO_Wrap_P2 x y).

    intuition.
    unfold PWO_Wrap_P2.
    wftac.
    eapply P2_wf.
  Qed.

  Definition PWO_Wrap_P3 (s_Ps : P.(S_P) * S_W) r_O' :=
    [s_P, s_W] <-2 s_Ps;
    r_O <-$ WR s_W r_O';
    P3 s_P r_O.

  Theorem PWO_Wrap_P3_wf :
    forall x y, well_formed_comp (PWO_Wrap_P3 x y).

    intuition.
    unfold PWO_Wrap_P3.
    wftac.
    intuition.
    eapply P3_wf.
  Qed.

  Definition PWO_Wrap : ProcedureWithOracle D_P R_P D_O' R_O'.

    econstructor.
    eapply P.(q).

    eapply PWO_Wrap_P1_wf.
    eapply PWO_Wrap_P2_wf.
    eapply PWO_Wrap_P3_wf.

    intuition.
    intuition.
    intuition.
    eapply P.(R_P_EqDec).
  Defined.

  Variable S_O : Set.
  Variable S_O_EqDec : EqDec S_O.
  Variable O : S_O -> D_O' -> Comp (R_O' * S_O).

  (*
  Theorem PWO_Wrap_equiv :
    forall d_P s_O x e1 e2 e3 e4,
    evalDist (P _ e1 (oracleWrap e2 e3 O WD WR) d_P s_O) x ==
    evalDist (PWO_Wrap _ e4 O d_P s_O) x.
  Admitted.
  *)

End PWO_Wrap.

Section PWO_Seq.

  Variable D1 R1 DO RO : Set.
  Variable (PWO_P1 : ProcedureWithOracle D1 R1 DO RO).
  Variable R2 : Set.
  Variable (PWO_P2 : ProcedureWithOracle R1 R2 DO RO).

  Hint Resolve (PWO_P1.(S_P_EqDec)) : typeclass_instances.
  Hint Resolve (PWO_P2.(S_P_EqDec)) : typeclass_instances.
  Hint Resolve (PWO_P1.(D_O_EqDec)) : typeclass_instances.
  Hint Resolve (PWO_P2.(R_P_EqDec)) : typeclass_instances.

  Definition S_P' := (nat * (PWO_P1.(S_P) + PWO_P2.(S_P))).

  Definition PWO_Seq_P1 (d : D1) : Comp (DO * S_P') :=
    [d, s] <-$2 PWO_P1.(P1) d;
    ret (d, (PWO_P1.(q), inl s)).

  Theorem PWO_Seq_P1_wf :
    forall x,
      well_formed_comp (PWO_Seq_P1 x).

    intuition.
    unfold PWO_Seq_P1.
    wftac.
    eapply P1_wf.

  Qed.

  Definition PWO_Seq_P2 (s : S_P') (r : RO)  : Comp (DO * S_P') :=
    match (snd s) with
      | inl s' =>
        match (fst s) with
          | O =>
            r <-$ P3 s' r;
            [d', s'] <-$2 PWO_P2.(P1) r;
            ret (d', (O, inr s'))
          | S q' =>
            [d', s'] <-$2 P2 s' r;
            ret (d', (q', inl s'))
        end
      | inr s' =>
        [d', s'] <-$2 P2 s' r;
        ret (d', (O, inr s'))
    end.

  Theorem PWO_Seq_P2_wf :
    forall x y,
      well_formed_comp (PWO_Seq_P2 x y).

    intuition.
    unfold PWO_Seq_P2.
    destruct (snd x); destruct (fst x); wftac.
    eapply P3_wf.
    eapply P1_wf.
    eapply P2_wf.
    eapply P2_wf.
    eapply P2_wf.

  Qed.

  Variable R2_def : R2.

  Definition PWO_Seq_P3 (s : S_P') r : Comp R2 :=
    match (snd s) return (Comp R2) with
      | inl s' => ret R2_def
      | inr s' => P3 s' r
    end.

  Theorem PWO_Seq_P3_wf :
    forall x y,
      well_formed_comp (PWO_Seq_P3 x y).

    intuition.
    unfold PWO_Seq_P3.
    destruct (snd x); wftac.
    eapply P3_wf.

  Qed.

  Definition PWO_Seq : ProcedureWithOracle D1 R2 DO RO.

  econstructor.
  eapply (S (PWO_P1.(q) + PWO_P2.(q)))%nat.
  eapply PWO_Seq_P1_wf.
  eapply PWO_Seq_P2_wf.
  eapply PWO_Seq_P3_wf.
  unfold S_P'.
  intuition.
  intuition.
  eapply PWO_P1.(R_O_EqDec).
  intuition.

  Defined.

  (*
  Theorem PWO_Seq_runP2 :
    forall n (S_O : Set) (s_O : S_O)(S_O_EqDec : EqDec S_O)(RO_EqDec : EqDec RO)
      m s_P d_O o x,
      evalDist
      (
        [s_O, s_P, d_O] <-$3 runP2 (@P2 _ _ _ _ PWO_P1) o _ _ _ n s_O s_P d_O;
        [r_O, s_O] <-$2 o s_O d_O;
        r_P1 <-$ P3 s_P r_O;
        [d_O, s_P] <-$2 PWO_P2.(P1) r_P1;
        [s_O, s_P, d_O] <-$3 runP2 (@P2 _ _ _ _ PWO_P2) o _ _ _ m s_O s_P d_O;
      ret (s_O, (0%nat, inr s_P), d_O)) x ==
      evalDist (runP2 (PWO_Seq_P2) o _ _ _ (S (n + m)) s_O (n, inl s_P) d_O) x.

    induction n; intros.

    rewrite plus_0_l.
    unfold runP2.
    rewrite compLoop_O.
    dist_ret_l.
    unfold setLet.
    rewrite compLoop_S.
    unfold runP2_once.
    inline_first.
    eapply evalDist_seq_eq.
    intuition.
    intros.
    destruct x0.

    unfold PWO_Seq_P2.
    unfold snd, fst.
    inline_first.
    eapply evalDist_seq_eq.
    intuition.
    intros.
    inline_first.
    eapply evalDist_seq_eq.
    intuition.
    intros.
    destruct x1.
    dist_ret_r.
    unfold setLet.
    dist_ret_r.

    symmetry.
    rewrite <- evalDist_right_ident.
    symmetry.

    eapply comp_spec_eq_impl_eq.
    eapply comp_spec_seq; intuition.
    admit.
    admit.
    eapply (@compLoop_spec _ _ _ _
      (fun (x : S_O * S_P PWO_P2 * DO) (y :  S_O * S_P' * DO) => snd x = snd y /\ fst (fst x) = fst (fst y) /\ (0, inr (snd (fst x))) = snd (fst y)))%nat; intros.
    intuition.

    destruct x.
    destruct y.
    destruct p.
    destruct p0.
    simpl in H2.
    simpl in H5.
    simpl in H3.
    subst.
    comp_skip.
    admit.

    eapply comp_spec_symm.
    eapply comp_spec_eq_trans.

    specialize (@comp_spec_assoc _ _ _ _ (P2 (p:=PWO_P2) s2 a3) (fun z => [d', s']<-2 z; ret (d', (0, inr s'))) (fun z => [d0, s_P0]<-2 z; ret (b0, s_P0, d0))); intuition.

    (*
    Ltac prog_inline_r :=
  match goal with
    | [ |- comp_spec _ _ _ ] =>
          eapply comp_spec_eq_trans_r; [idtac | eapply comp_spec_symm;
  eapply comp_spec_consequence; [
  eapply comp_spec_assoc |
  intuition] ]
  end.
  *)

       Ltac prog_inline_r :=
  match goal with
    | [ |- comp_spec _ _ _ ] =>
          eapply comp_spec_eq_trans_r; [idtac | eapply comp_spec_symm;
  eapply comp_spec_consequence; [
  eapply comp_spec_assoc |
  intuition] ]
  end.

       Show.
       eapply comp_spec_eq_trans_r.
       Focus 2.
       eapply comp_spec_symm.
       eapply comp_spec_consequence.

       assert (EqDec DO).
       admit.
       specialize (@comp_spec_assoc _ _ _ _ (P2 (p:=PWO_P2) s2 a3) (fun z => [d', s']<-2 z; ret (d', (0, inr s')))); intros.
       eapply H4.

       eapply comp_spec_assoc.

    Show.
    prog_inline_r.

    inline_first.
    eapply comp_spec_seq.
    admit.
    admit.
    eapply comp_spec_eq_refl.
    intuition.
    subst.

    comp_skip.

    unfold comp_spec_post; intros.
    destruct H2.
    destruct H5.
    destruct y.
    destruct x1.
    simpl in H2.
    simpl in H5.
    destruct p0.
    destruct p.
    simpl in H5.
    subst.
    comp_simp.
    inline_first.
    eapply evalDist_seq.
    intuition.
    intuition.
    intros.
    subst.
    comp_simp.
    simpl in H6.
    inversion H6; clear H6; subst.
    inline_first.
    eapply evalDist_seq.
    intuition.
    intuition.
    intros.
    subst.
    comp_simp.
    eapply H4.
    simpl.
    intuition.

    eapply getSupport_In_Seq; eauto.
    comp_simp.
    eapply getSupport_In_Seq; eauto.
    comp_simp.
    simpl. intuition.

    eapply getSupport_In_Seq; eauto.
    comp_simp.
    eapply getSupport_In_Seq; eauto.
    eapply getSupport_In_Seq; eauto.
    comp_simp.
    simpl. intuition.
    comp_simp.
    simpl. intuition.

    simpl.
    intuition.
    intuition.

    comp_simp.
    destruct r2.
    destruct p.
    intuition;
    simpl in H5;
    simpl in H2;
    simpl in H7;
    subst;
    eapply eqRat_refl.

    unfold runP2 in *.
    rewrite compLoop_S.
    eapply eqRat_trans.
    eapply evalDist_seq_eq.
    intros.
    eapply compLoop_S.
    intros.
    eapply eqRat_refl.

    inline_first.
    eapply evalDist_seq_eq.
    intuition.
    intros.
    comp_simp.
    inline_first.
    eapply evalDist_seq_eq.
    intuition.
    intros.
    comp_simp.

    rewrite Nat.add_succ_l.
    eapply IHn.

  Qed.

  (* running the two PWOs in sequence is equivalent to running PWO_Seq *)
  Theorem PWO_Seq_equiv :
    forall (S_O : Set) o x d_P (s_O : S_O) e1 e2 e3,
      evalDist ([s_O, r_P1] <-$2 PWO_P1 _ e1 o d_P s_O;
        PWO_P2 _ e2 o r_P1 s_O) x ==
      evalDist (PWO_Seq _ e3 o d_P s_O) x.

    intuition.
    unfold PWO_Seq, PWO_Seq_P1, runPWO.
    inline_first.
    comp_skip.
    comp_ret_r.
    unfold setLet.

    eapply eqRat_trans.
    Focus 2.
    eapply evalDist_seq_eq.
    intros.
    eapply PWO_Seq_runP2.

    intros.
    eapply eqRat_refl.

    inline_first.
    eapply evalDist_seq_eq.
    intuition.
    unfold runP2.
    eapply compLoop_eq.
    intros.
    unfold runP2_once.
    comp_simp.
    comp_skip.
    comp_skip.
    eapply evalDist_ret_eq.
    trivial.

    intros.
    destruct x.
    destruct p.
    inline_first.
    eapply evalDist_seq_eq.
    intuition.
    intros.

    destruct x.
    inline_first.
    eapply evalDist_seq_eq.
    intuition.
    intros.

    comp_ret_l.
    unfold setLet.
    inline_first.
    eapply evalDist_seq_eq.
    intuition.
    intros.

    destruct x0.
    inline_first.
    unfold runP2.
    eapply (@compLoop_spec _ _ eq).
    intros.
    subst.
    unfold comp_spec_post.
    intros.
    eapply evalDist_seq.
    intros.
    unfold runP2_once.
    comp_simp.
    comp_skip.
    comp_skip.
    eapply evalDist_ret_eq.
    intuition.
    intuition.

    intros.
    subst.
    eapply H6; trivial.
    intuition.
    intuition.

    intros.
    subst.

    destruct r2.
    destruct p.
    comp_ret_r.
    unfold setLet.
    eapply evalDist_seq_eq.
    intuition.
    intros.

    destruct x0.
    unfold P3, PWO_Seq_P3.
    unfold snd.
    eapply evalDist_seq_eq.
    intuition.
    unfold P3.
    intuition.

    intros.
    eapply evalDist_ret_eq.
    intuition.

  Qed.

  *)

End PWO_Seq.

Definition DataTypeFamily := nat -> Set.
Definition ProcedureFamily(A B : nat -> Type) := forall n, A n -> B n.
Definition EfficiencyPredicate := forall (A B : nat -> Type), ProcedureFamily A B -> Prop.

Require Import Asymptotic.

Record Adversary_2_concrete
  (D1 : Type)(R1 : Set)(D2 : Type)(R2 : Set) :={
    A2_SA : Set;
    A2_SA_EqDec : EqDec A2_SA;
    A2_A1 : D1 -> Comp (R1 * A2_SA);
    A2_A2 : (A2_SA * D2) -> Comp R2;
    Adversary_2_concrete_A1_wf : forall x, well_formed_comp (A2_A1 x);
    Adversary_2_concrete_A2_wf : forall x, well_formed_comp (A2_A2 x)
  }.

Definition Adversary_2_concrete_prod D1 R1 D2 R2 (A : Adversary_2_concrete D1 R1 D2 R2)
  := (A.(A2_A1), (fun s x => (@A2_A2 _ _ _ _ A (s, x)))).

Coercion Adversary_2_concrete_prod :
  Adversary_2_concrete >-> prod.

Notation "x <-${ A } c1 ; c2" :=
  (Bind (let A := (fst A) in c1) (fun z => [x, state] <-2 z; let A := (snd A) state in c2))
(right associativity, at level 81, c1 at next level) : comp_scope.

Notation "[ x1 , x2 ] <-$2{ A } c1 ; c2" :=
  (Bind (let A := (fst A) in c1) (fun z => [x1, x2, state] <-3 z; let A := (snd A) state in c2))
(right associativity, at level 81, c1 at next level) : comp_scope.

Record Adversary_2_O_O_concrete
  (DA1 RA1 DA2 RA2 DO RO : Set) :=
  {
    A2OO_SA : Set;
    A2OO_SA_EqDec : EqDec A2OO_SA;
    RA1_EqDec : EqDec RA1;
    A2OO_A1 : ProcedureWithOracle DA1 (RA1 * A2OO_SA) DO RO;
    A2OO_A2 : ProcedureWithOracle (A2OO_SA * DA2) RA2 DO RO
  }.

Definition Adversary_2_O_O_concrete_prod {D1 R1 D2 R2 DO RO} (A : Adversary_2_O_O_concrete D1 R1 D2 R2 DO RO)
  := (fun {SO : Set}{eqdSO : EqDec SO} (O : SO -> DO -> Comp (RO * SO)) d1 so =>
    [s_O, p] <-$2 runPWO A.(A2OO_A1) d1 O so;
    [d_A, s_A] <-2 p;
    Ret (EqDec_dec (pair_EqDec (pair_EqDec eqdSO (RA1_EqDec A)) (A2OO_SA_EqDec _)) ) (s_O, d_A, s_A)
,
    (fun {SO : Set}{eqdSO : EqDec SO}(s : A2OO_SA A) (x : D2) (O : SO -> DO -> Comp (RO * SO)) => runPWO (A2OO_A2 A) (s, x) O)).

    Coercion Adversary_2_O_O_concrete_prod :
      Adversary_2_O_O_concrete >-> prod.

    Notation "[ x1 , x2 ] <-$2{{ A }} c1 ; c2" :=
  (Bind (let A := (fst A) _ _ in c1) (fun z => [x1, x2, state] <-3 z; let A := (snd A) _ _ state in c2))
(right associativity, at level 81, c1 at next level) : comp_scope.

Record Adversary_2
  (efficient : EfficiencyPredicate)
  (D1 : nat -> Type)(R1 : DataTypeFamily)(D2 : nat -> Type)(R2 : DataTypeFamily) :={

    Adversary_2_to_concrete :
    forall n, Adversary_2_concrete (D1 n) (R1 n) (D2 n) (R2 n);

    A2_A1_efficient :
      efficient _ _ (fun n => (Adversary_2_to_concrete n).(A2_A1));

    (* Why doesn't this one work?
    A2_A2_efficient :
      efficient _ (fun n => (Adversary_2_to_concrete n).(A2_A2))
      *)

    A2_A2_efficient:
    efficient _ _ (fun n => @A2_A2 _ _ _ _ (Adversary_2_to_concrete n))

  }.

Coercion Adversary_2_to_concrete : Adversary_2 >-> Funclass.

Definition efficientPWO
  (efficient : EfficiencyPredicate)
  (DP RP DO RO : DataTypeFamily)
  (P : forall n, ProcedureWithOracle (DP n) (RP n) (DO n) (RO n)) : Prop :=

  efficient _ _ (fun n => (P n).(P1)) /\
    efficient _ _ (fun n => fun p => @P2 _ _ _ _ (P n) (fst p) (snd p)) /\
    efficient _ _ (fun n => fun p => @P3 _ _ _ _ (P n) (fst p) (snd p)) /\
    polynomial (fun n => (P n).(q)).

(*
Definition efficientPWO_fun
  (efficient : EfficiencyPredicate)
  (DP RP DO RO SP : DataTypeFamily)
  (P : forall n, (SP n) -> ProcedureWithOracle (DP n) (RP n) (DO n) (RO n)) : Prop :=

    efficient _ _ (fun n sp => @P1 _ _ _ _ (P n sp)) /\
    efficient _ _ (fun n sp => @P2 _ _ _ _ (P n sp)) /\
    efficient _ _ (fun n sp => @P3 _ _ _ _ (P n sp)) /\
    (forall x, polynomial (fun n => (P n (x n)).(q))).
*)

Record EfficientProcedureWithOracle
  (efficient : EfficiencyPredicate)
  (DP RP DO RO : DataTypeFamily) :={

    EPWO_to_concrete : forall n, ProcedureWithOracle (DP n) (RP n) (DO n) (RO n);
    EPWO_efficient : efficientPWO efficient EPWO_to_concrete

  }.

Coercion EPWO_to_concrete : EfficientProcedureWithOracle >-> Funclass.

Record Adversary_2_O_O
  (efficient : EfficiencyPredicate)
  (D1 R1 D2 R2 DO RO : DataTypeFamily) :={

    Adversary_2_O_O_to_concrete :
    forall n, Adversary_2_O_O_concrete (D1 n) (R1 n) (D2 n) (R2 n) (DO n) (RO n);

    A2OO_A1_efficient : efficientPWO efficient (fun n => @A2OO_A1 _ _ _ _ _ _ (Adversary_2_O_O_to_concrete n));
    A2OO_A2_efficient : efficientPWO efficient (fun n => @A2OO_A2 _ _ _ _ _ _ (Adversary_2_O_O_to_concrete n))

  }.

Coercion Adversary_2_O_O_to_concrete : Adversary_2_O_O >-> Funclass.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall O A B Oprime Aprime Bprime Cprime : Universe, ((wd_ O A /\ (wd_ Oprime Aprime /\ (wd_ A B /\ (wd_ Aprime Cprime /\ (wd_ A Aprime /\ (wd_ O Aprime /\ (wd_ A Cprime /\ (wd_ B Aprime /\ (wd_ B Cprime /\ (wd_ O Oprime /\ (wd_ A Oprime /\ (wd_ Bprime B /\ (col_ O A B /\ (col_ O B B /\ (col_ Oprime Aprime Bprime /\ (col_ Oprime Bprime Cprime /\ (col_ Oprime Aprime Cprime /\ (col_ B Cprime Aprime /\ col_ B Cprime Bprime)))))))))))))))))) -> col_ B Oprime Aprime)).
Proof.
  time tac.
Qed.

End FOFProblem.