Require Import List.

Require Import Logic.Class.Eq.

Require Import Logic.Rel.Properties.

Require Import Logic.Func.Replace.
Require Import Logic.Func.Composition.

Require Import Logic.List.In.
Require Import Logic.List.Equiv.
Require Import Logic.List.Remove.
Require Import Logic.List.Replace.
Require Import Logic.List.Include.
Require Import Logic.List.Coincide.
Require Import Logic.List.Intersect.
Require Import Logic.List.Difference.
Require Import Logic.List.InjectiveOn.

Require Import Logic.Lam.Subst.
Require Import Logic.Lam.Syntax.
Require Import Logic.Lam.Functor.
Require Import Logic.Lam.Variable.
Require Import Logic.Lam.Congruence.

(* Returns the list of free variables (with possible duplication) in a term     *)
(* When facing a lambda abstraction, we need to be able to remove a variable    *)
(* from the list of free variables of the subterm, hence decidable equality.    *)
Fixpoint Fr (v:Type) (e:Eq v) (t:T v) : list v :=
    match t with
    | Var x         => (cons x nil)
    | App t1 t2     => Fr v e t1 ++ Fr v e t2
    | Lam x t1      => remove x (Fr v e t1)
    end.

Arguments Fr {v} {e} _.

(* The free variables of the term (fmap f t) are a subset of the images by f    *)
(* of the free variables of the term t.                                         *)
Lemma free_fmap : forall (v w:Type) (e:Eq v) (e':Eq w) (f:v -> w) (t:T v),
    Fr (fmap f t) <= map f (Fr t).
Proof.
    intros v w e e' f.
    induction t as [x|t1 IH1 t2 IH2|x t1 IH1]; simpl.
    - apply incl_refl.
    - rewrite map_app. apply incl_app.
        + apply incl_appl, IH1.
        + apply incl_appr, IH2.
    - apply incl_tran with (remove (f x) (map f (Fr t1))).
        + apply remove_mon, IH1.
        + apply incl_tran with (map f (remove x (Fr t1))).
            { apply remove_map_incl. }
            { apply incl_refl. }
Qed.

(* A free variable is a variable                                                *)
Lemma free_var : forall (v:Type) (e:Eq v) (t:T v), Fr t <= var t.
Proof.
    intros v e.
    induction t as [x|t1 IH1 t2 IH2|x t1 IH1]; simpl.
    - apply incl_refl.
    - apply incl_app2; assumption.
    - apply incl_tran with (Fr t1).
        + apply remove_incl.
        + apply incl_tl. assumption.
Qed.

Lemma free_inj : forall (v w:Type) (e:Eq v) (e':Eq w) (f:v -> w) (t:T v),
    injective_on (var t) f -> Fr (fmap f t) = map f (Fr t).
Proof.
    intros v w e e' f.
    induction t as [x|t1 IH1 t2 IH2|x t1 IH1]; simpl; intros H.
    - reflexivity.
    - rewrite map_app, IH1, IH2.
        + reflexivity.
        + apply injective_on_appr with (var t1). assumption.
        + apply injective_on_appl with (var t2). assumption.
    - rewrite IH1. apply remove_inj2.
      apply injective_on_incl with (cons x (var t1)).
        + apply incl_cons.
            { left. reflexivity. }
            { apply incl_tl, free_var. }
        + assumption.
        + apply injective_on_cons with x. assumption.
Qed.

Lemma free_replace1 : forall (v:Type) (e:Eq v) (t:T v) (x y:v),
    ~ y :: var t    ->
    ~ x :: Fr t   ->
    Fr (fmap (y // x) t) = Fr t.
Proof.
    intros v e t x y Hy Hx.
    rewrite (free_inj v v e e).
    - rewrite <- map_id. apply coincide_map. unfold coincide.
      intros u H. rewrite replace_not_x.
        + reflexivity.
        + intros E. subst. apply Hx, H.
    - apply replace_inj. assumption.
Qed.

Lemma free_replace2 : forall (v:Type) (e:Eq v) (t:T v) (x y:v),
    ~ y :: var t  ->
      x :: Fr t ->
     forall (z:v),
        z :: Fr (fmap (y // x) t) <->
        z = y \/ (z :: Fr t) /\ z <> x.
Proof.
    intros v e t x y Hy Hx z. rewrite (free_inj v v e e). split.
    - intros H. destruct (eqDec z y) as [Hzy|Hzy].
        + left. assumption.
        + right. apply in_map_iff in H. destruct H as [u [H1 H2]]. split.
            { destruct (eqDec u x) as [Hux|Hux].
                { rewrite Hux, replace_x in H1. exfalso.
                  apply Hzy. symmetry. assumption. }
                { rewrite replace_not_x in H1.
                    { rewrite <- H1. assumption. }
                    { assumption. }}}
                { intros Hzx. rewrite Hzx in H1.
                  destruct (eqDec u x) as [Hux|Hux].
                    { rewrite Hux, replace_x, <- Hzx in H1.
                      apply Hzy. symmetry. assumption. }
                    { rewrite replace_not_x in H1.
                        { apply Hux. assumption. }
                        { assumption. }}}
    - intros [H|[H1 H2]]; apply in_map_iff.
        + exists x. split.
            { rewrite replace_x. symmetry. assumption. }
            { assumption. }
        + exists z. split.
            { rewrite replace_not_x.
                { reflexivity. }
                { assumption. }}
            { assumption. }
    - apply replace_inj. assumption.
Qed.

Lemma free_congruence : forall (v:Type) (e:Eq v),
    congruence (fun (s t:T v) => Fr s = Fr t).
Proof.
    intros v e. split.
    - split.
        + intros t. reflexivity.
        + split.
            { intros s t H. symmetry. assumption. }
            { intros r s t Hrs Hst.
              apply eq_trans with (Fr s); assumption. }
    - split.
        + intros s1 s2 t1 t2 H1 H2. simpl. rewrite H1, H2. reflexivity.
        + intros x s1 t1 H1. simpl. rewrite H1. reflexivity.
Qed.

Lemma free_subst_gen : forall (v:Type) (e:Eq v) (f:v -> T v) (t:T v) (xs:list v),
    Fr (subst_ f xs t) <= (Fr t /\ xs) ++ concat (map (Fr ; f) (Fr t \\ xs)).
Proof.
    intros v e f. induction t as [x|t1 IH1 t2 IH2|x t1 IH1]; intros xs; simpl.
    - destruct (in_dec eqDec x xs) as [H|H]; simpl.
        + apply incl_refl.
        + unfold comp. rewrite app_nil_r. apply incl_refl.
    - apply incl_app.
        + apply incl_tran with
            ((Fr t1 /\ xs) ++ concat (map (Fr; f) (Fr t1 \\ xs))).
            { apply IH1. }
            { apply incl_app2.
                { rewrite inter_distrib_app_r. apply incl_appl. apply incl_refl. }
                { rewrite diff_distrib_app_r. apply incl_concat. apply incl_map.
                  apply incl_appl. apply incl_refl. }}
        + apply incl_tran with
            ((Fr t2 /\ xs) ++ concat (map (Fr; f) (Fr t2 \\ xs))).
            { apply IH2. }
            { apply incl_app2.
                { rewrite inter_distrib_app_r. apply incl_appr. apply incl_refl. }
                { rewrite diff_distrib_app_r. apply incl_concat. apply incl_map.
                  apply incl_appr. apply incl_refl. }}
    - apply incl_tran with
        (remove x (  (Fr t1 /\ (cons x xs))
                  ++ concat (map (Fr; f) (Fr t1 \\ (cons x xs))))).
        + apply remove_mon. apply IH1.
        + rewrite remove_diff. rewrite diff_distrib_app_r. apply incl_app2.
            { rewrite remove_diff.
              apply incl_tran with (Fr t1 \\ (x :: nil) /\ (cons x xs)).
                { apply diff_inter_comm. }
                { rewrite inter_cons_not_in_r.
                    { apply incl_refl. }
                    { intros H. rewrite diff_charac in H. destruct H as [_ H].
                      apply H. left. reflexivity. }}}
            { rewrite <- remove_diff.
              apply incl_tran with (concat (map (Fr; f) (Fr t1 \\ (x :: xs)))).
                { apply remove_incl. }
                { apply incl_concat. apply incl_map. rewrite remove_diff.
                  assert (cons x xs = cons x nil ++ xs) as H1.
                    { reflexivity. }
                  rewrite H1. rewrite diff_distrib_app_l'. apply incl_refl. }}
Qed.

Lemma free_subst : forall (v:Type) (e:Eq v) (f:v -> T v) (t:T v),
    Fr (subst f t) <= concat (map (Fr ; f) (Fr t)).
Proof.
    intros v e f t. unfold subst. rewrite <- (diff_nil v e (Fr t)).
    assert (concat (map (Fr; f) (Fr t \\ nil))
      = nil ++ concat (map (Fr; f) (Fr t \\ nil))) as H.
        { reflexivity. }
    rewrite H. rewrite <- (inter_nil v e (Fr t)) at 2.
    apply free_subst_gen.
Qed.

Lemma free_subst_intersect_gen :
    forall (v:Type) (e:Eq v) (f:v -> T v) (t:T v) (xs ys:list v),
       (Fr t /\ xs) == (Fr t /\ ys) ->  subst_ f xs t = subst_ f ys t.
Proof.
    intros v e f. induction t as [x|t1 IH1 t2 IH2|x t1 IH1];
    intros xs ys H.
    - simpl. simpl in H.
      destruct (in_dec eqDec x xs) as [H2|H2];
      destruct (in_dec eqDec x ys) as [H3|H3].
        + reflexivity.
        + apply equivNil in H. inversion H.
        + apply equivSym in H. apply equivNil in H.
          inversion H.
        + reflexivity.
    - assert ((Fr t1 /\ xs) == (Fr t1 /\ ys)) as H1.
        { apply inter_sub_equiv with (Fr (App t1 t2)).
            { simpl. apply incl_appl. apply incl_refl. }
            { assumption. } }
      assert ((Fr t2 /\ xs) == (Fr t2 /\ ys)) as H2.
        { apply inter_sub_equiv with (Fr (App t1 t2)).
            { simpl. apply incl_appr. apply incl_refl. }
            { assumption. } }
      simpl. rewrite (IH1 xs ys). rewrite (IH2 xs ys).
        + reflexivity.
        + assumption.
        + assumption.
    - simpl. rewrite (IH1 (cons x xs) (cons x ys)).
        + reflexivity.
        + simpl in H. rewrite remove_diff in H.
          split; intros z H1; apply inter_charac in H1;
          destruct H as [H3 H4];
          destruct H1 as [H1 [H2|H2]]; apply inter_charac; split.
            { subst. assumption. }
            { subst. left. reflexivity. }
            { assumption. }
            { destruct (eqDec x z) as [H5|H5].
                { subst. left. reflexivity. }
                { right.
                  assert (z :: (Fr t1 \\ (cons x nil) /\ xs)) as H6.
                    { apply inter_charac. split.
                        { apply diff_charac. split.
                            { assumption. }
                            { intros [H6|H6].
                                { subst. apply H5. reflexivity. }
                                { inversion H6. }}}
                        { assumption. }}
                   apply H3 in H6. apply inter_charac in H6.
                   destruct H6 as [H6 H7]. assumption. }}
            { assumption. }
            { subst. left. reflexivity. }
            { assumption. }
            { destruct (eqDec x z) as [H5|H5].
                { subst. left. reflexivity. }
                { right.
                  assert (z :: (Fr t1 \\ (cons x nil) /\ ys)) as H6.
                    { apply inter_charac. split.
                        { apply diff_charac. split.
                            { assumption. }
                            { intros [H6|H6].
                                { subst. apply H5. reflexivity. }
                                { inversion H6. }}}
                        { assumption. }}
                   apply H4 in H6. apply inter_charac in H6.
                   destruct H6 as [H6 H7]. assumption. }}
Qed.

Lemma free_subst_intersect :
    forall (v:Type) (e:Eq v) (f:v -> T v) (t:T v) (xs:list v),
       (Fr t /\ xs) == nil ->  subst_ f xs t = subst f t.
Proof.
    intros v e f t xs H. unfold subst. apply free_subst_intersect_gen.
    rewrite inter_nil. assumption.
Qed.

Lemma free_coincide_subst_gen :
    forall (v:Type) (e:Eq v) (f g:v -> T v) (t:T v) (xs:list v),
        coincide (Fr t \\ xs) f g <-> subst_ f xs t = subst_ g xs t.
Proof.
    intros v e f g. induction t as [x|t1 IH1 t2 IH2|x t1 IH1]; intros xs; simpl.
    - destruct (in_dec eqDec x xs) as [H|H]; split.
        + intros _. reflexivity.
        + intros _. intros z H'. inversion H'.
        + intros H'. apply (H' x). left. reflexivity.
        + intros H'. intros z [H1|H1].
            { subst. assumption. }
            { inversion H1. }
    - destruct (IH1 xs) as [H1 H2]. destruct (IH2 xs) as [H3 H4]. split; intros H.
        + rewrite H1, H3.
            { reflexivity. }
            { apply coincide_incl with ((Fr t1 ++ Fr t2) \\ xs).
              rewrite diff_distrib_app_r. apply incl_appr.
                { apply incl_refl. }
                { assumption. }}
            { apply coincide_incl with ((Fr t1 ++ Fr t2) \\ xs).
              rewrite diff_distrib_app_r. apply incl_appl.
                { apply incl_refl. }
                { assumption. }}
        + inversion H. rewrite diff_distrib_app_r. apply coincide_app.
            { apply IH1. assumption. }
            { apply IH2. assumption. }
    - split; intros H.
        + rewrite remove_diff in H. rewrite <- diff_distrib_app_l' in H.
          simpl in H. destruct (IH1 (cons x xs)) as [H1 H2]. clear IH1.
          rewrite H1.
            { reflexivity. }
            { assumption. }
        + inversion H as [H1]. rewrite remove_diff.
          rewrite <- diff_distrib_app_l'. simpl. apply IH1. assumption.
Qed.

Lemma free_coincide_subst :
    forall (v:Type) (e:Eq v) (f g:v -> T v) (t:T v),
        coincide (Fr t) f g <-> subst f t = subst g t.
Proof.
    intros v e f g t. unfold subst. rewrite <- (diff_nil v e (Fr t)).
    apply free_coincide_subst_gen.
Qed.


(** * Discrete Gaussian. *)

From Coq Require Import Basics QArith Lia Lqa String Qabs.
Open Scope string_scope.

From ITree Require Import
  ITree ITreeFacts.
Import ITreeNotations.
Local Open Scope itree_scope.

From zar Require Import compile cpGCL itree prelude Q tactics tree.

Local Open Scope cpGCL_scope.

Definition succ (v : val) : val :=
  match v with
  | vnat n => vnat (S n)
  | vint n => vint (n + 1)
  | _ => v
  end.

Definition is_even (v : val) : bool :=
  match v with
  | vnat n => Nat.even n
  | vint n => Z.even n
  | _ => false
  end.

(** Sampling from Bernoulli(exp(-γ)), where ∀ s, 0 <= γ s <= 1. *)
(* Assumes 0 <= gamma <= 1. *)
(* Clobbers: k, a *)
(* Slightly modified from version in paper to make it obvious that the
   divisor is always nonzero. *)
Definition bernoulli_exponential_0_1 (out : string) (gamma : St -> Q) : cpGCL :=
  "k" <-- O;
  "a" <-- true;
  while (fun s : St => as_bool (s "a")) do
      CChoice (fun s => gamma s / N2Q (S (as_nat (s "k"))))
              (fun b => if b then "k" <-- fun s => succ (s "k") else "a" <-- false)
  end;
  if (fun s => is_even (s "k")) then out <-- true else out <-- false end.

Lemma wf_bernoulli_exponential_0_1 (out : string) (gamma : St -> Q) :
  (forall s, 0 <= gamma s <= 1) ->
  wf_cpGCL (bernoulli_exponential_0_1 out gamma).
Proof.
  intros Hg; repeat constructor.
  - apply Qle_shift_div_l; try lra.
    unfold N2Q, Qlt; simpl; lia.
    rewrite Qmult_0_l; apply Hg.
  - apply Qle_shift_div_r.
    + unfold N2Q, Qlt; simpl; lia.
    + rewrite Qmult_1_l; eapply Qle_trans; eauto.
      * apply Hg.
      * apply Qle_num_1; lia.
  - intros []; constructor.
Qed.

(** Sampling from Bernoulli(exp(-γ)), where ∀ s, 0 <= γ s. *)
(* Assumes 0 <= gamma. *)
(* Clobbers: k, a, i, b *)
Definition bernoulli_exponential (out : string) (gamma : St -> Q) : cpGCL :=
  CIte (fun s => Qle_bool (gamma s) 1)
    (bernoulli_exponential_0_1 out
       (fun s => if Qle_bool (gamma s) 1 then gamma s else 1))
    ("i" <-- S O;
    "b" <-- true;
    while (fun s => as_bool (s "b") && Qle_bool (N2Q (as_nat (s "i"))) (gamma s)) do
      bernoulli_exponential_0_1 "b" (const 1);
      "i" <-- fun s => succ (s "i")
    end;
    if (fun s => as_bool (s "b")) then
      bernoulli_exponential_0_1 out
        (fun s => gamma s - (Qround.Qfloor (gamma s) # 1))
    else
      out <-- O
     end).

Lemma Qle_minus a b :
  b <= a ->
  0 <= a - b.
Proof. lra. Qed.

Lemma Qle_minus' a b c :
  a <= b + c ->
  a - b <= c.
Proof. lra. Qed.

Lemma lem2 a :
  0 <= a - (Qround.Qfloor a # 1) <= 1.
Proof.
  split.
  - apply Qle_minus, Qround.Qfloor_le.
  - apply Qle_minus'.
    apply Qlt_le_weak.
    replace ((Qround.Qfloor a # 1) + 1) with (Qround.Qfloor a + 1 # 1).
    2: { generalize inject_Z_plus; unfold inject_Z.
         intro H; rewrite H; reflexivity. }
    apply Qround.Qlt_floor.
Qed.

Lemma wf_bernoulli_exponential (out : string) (gamma : St -> Q) :
  (forall s, 0 <= gamma s) ->
  wf_cpGCL (bernoulli_exponential out gamma).
Proof.
  intro Hg.
  constructor.
  { apply wf_bernoulli_exponential_0_1; auto.
    intro s; destruct (Qle_bool (gamma s) 1) eqn:H; try lra.
    apply Qle_bool_iff in H; auto. }
  constructor.
  { constructor. }
  constructor.
  { constructor. }
  constructor.
  { constructor; constructor.
    - apply wf_bernoulli_exponential_0_1; unfold const; intro; lra.
    - constructor. }
  constructor.
  { apply wf_bernoulli_exponential_0_1.
    intro s; apply lem2. }
  constructor.
Qed.

(** Sampling from Laplace_Z(t/s), where 0 < s and 0 < t. *)
(* Clobbers: k, a, i, b, lp, d, v, il, x, y, c *)
Definition laplace (out : string) (s t : nat) : cpGCL :=
  "lp" <-- true;
  while (fun s => as_bool (s "lp")) do
    CUniform (const t)
      (fun u =>
         bernoulli_exponential "d" (fun s => Z.of_nat (min u t) # Pos.of_nat t);
         if (fun s => as_bool (s "d")) then
           "v" <-- (fun s => O);
           bernoulli_exponential "il" (const 1);
           while (fun s => as_bool (s "il")) do
             "v" <-- (fun s => S (as_nat (s "v")));
             bernoulli_exponential "il" (const 1)
           end;
           "x" <-- (fun s => (u + t * as_nat (s "v"))%nat);
           "y" <-- (fun st => (as_nat (st "x") / s)%nat);
           flip "c" (1#2);
           CIte (fun s => as_bool (s "c") && Nat.eqb (as_nat (s "y")) O)
                 skip
                 ("lp" <-- (fun s => vbool false);
                  out <-- (fun s => vint ((1 - 2 * (if as_bool (s "c") then 1 else 0))
                                     * Z.of_nat (as_nat (s "y")))%Z))
         else
           skip
         end)
  end.

Lemma z_le_0_Qle n d :
  (0 <= n)%Z ->
  0 <= n # d.
Proof. intro Hn; compute; destruct n; try congruence; lia. Qed.

Lemma Qle_0_of_nat n p :
  0 <= Z.of_nat n # p.
Proof. apply z_le_0_Qle, Zle_0_nat. Qed.

Lemma Qmake_le_1 n d :
  (n <= Zpos d)%Z ->
  n # d <= 1.
Proof.
  intro Hle.
  apply Qmult_lt_0_le_reg_r with (z := Zpos d # 1).
  { apply inject_Z_pos_positive. }
  rewrite Qmult_1_l.
  unfold Qmult.
  simpl.
  rewrite Pos.mul_comm.
  rewrite Qreduce_r.
  generalize (Zle_Qle n (Z.pos d)).
  intro H.
  rewrite H in Hle.
  apply Hle.
Qed.

Lemma Z_pos_of_nat n :
  (0 < n)%nat ->
  Z.pos (Pos.of_nat n) = Z.of_nat n.
Proof. destruct n; lia. Qed.

Lemma wf_laplace (out : string) (s t : nat) :
  (0 < s)%nat ->
  (0 < t)%nat ->
  wf_cpGCL (laplace out s t).
Proof.
  intros Hs Ht.
  wf. wf. wf.
  intro n; wf.
  { eapply wf_bernoulli_exponential; intro st.
    apply Qle_0_of_nat. }
  wf. wf. wf.
  { apply wf_bernoulli_exponential; intro st; unfold const; lra. }
  wf.
  { wf. wf.
    apply wf_bernoulli_exponential; intro st; unfold const; lra. }
  wf. wf. wf. wf.
  intro st; unfold const; lra.
Qed.

Lemma lem1 b :
  0 <= (let a := b in if Qle_bool 0 a then a else 0).
Proof.
  simpl. destruct (Qle_bool 0 b) eqn:Hb; simpl; try lra.
  apply Qle_bool_imp_le in Hb; auto.
Qed.

(** Sampling from Gaussian_Z(0, σ²), where 0 < σ. *)
(* Assumes 0 < sigma. *)
(* Clobbers: k, a, i, b, lp, d, v, il, x, y, c, ol, z *)
Definition gaussian (out : string) (sigma : Q) : cpGCL :=
  let t := S (Z.to_nat (Qround.Qfloor sigma)) in
  "ol" <-- false;
  while (fun s => negb (as_bool (s "ol"))) do
    laplace "z" 1 t;
    bernoulli_exponential "ol"
      (fun s => let q := Qpower (Qabs (as_int (s "z") # 1) - Qpower sigma 2 / N2Q t) 2 /
                        (2 * Qpower sigma 2) in
             if Qle_bool 0 q then q else 0)
  end;
  out <-- (fun s => s "z").

Lemma wf_gaussian (out : string) (sigma : Q) :
  0 < sigma ->
  wf_cpGCL (gaussian out sigma).
Proof.
  intro Hs.
  wf. wf. wf. wf.
  { apply wf_laplace; lia. }
  apply wf_bernoulli_exponential.
  intro s; apply lem1.
Qed.

Definition gauss (out : string) (mu : Z) (sigma : Q) : cpGCL :=
  gaussian "x123" sigma;
  out <-- (fun s => vint (as_int (s "x123") + mu)%Z).

Lemma wf_gauss (out : string) (mu : Z) (sigma : Q) :
  0 < sigma ->
  wf_cpGCL (gauss out mu sigma).
Proof. intro Hs; wf; apply wf_gaussian; auto. Qed.

From Coq Require Import ExtrOcamlBasic ExtrOcamlString.

(* Definition sampler (mu : Z) (sigma : Q) : itree boolE Z := *)
(*   ITree.map (fun s => as_int (s "")) (cpGCL_to_itree (gauss "" mu sigma) empty). *)
(* Extraction "extract/gaussian/sampler.ml" sampler. *)


Require Import Coq.Bool.Bool.
Require Import Coq.Arith.Arith.
Require Import Coq.Lists.List.
Require Import listable.
Require Import test_strategy.
Import ListNotations.

(* Let's try an example or two. *)
Definition example_1 := forall P : Prop, P -> P.

Inductive ex1_test : Type :=. (* no tests are available *)

Definition ex1_pt : ex1_test -> Prop.
  intro t. inversion t.
Defined.

Definition ts_ex1 : (@test_strategy ex1_test ex1_pt false example_1).
  unfold example_1. apply ts_prove.
  auto.
Defined.

(*
Compute proven ts_ex1.
(* forall x : Prop, x -> x *)

Compute assumed ts_ex1.
(* True *)

Compute to_test ts_ex1.
(* nil *)
*)

Theorem ts_ex1_correct : example_1.
  apply (test_strategy_correct ts_ex1).
  constructor.
Qed.

Definition example_2 := forall P Q : Prop, P -> Q /\ P.

(* We pretend we can test arbitrary propositions. *)
Inductive ex2_test : Type := ex2_test_any : Prop -> ex2_test.

Definition ex2_pt (t : ex2_test) : Prop :=
match t with
| ex2_test_any P => P
end.

Definition ts_ex2 : @test_strategy ex2_test ex2_pt true example_2.
  apply (@ts_mp _ _ false true (forall Q : Prop, Q)).
  - apply ts_prove. intros Hany. intros P Q HP. split.
    + apply Hany.
    + apply HP.
Abort.
(* There are more than a finite number of propositions to test, so we don't have
   a way to test them all, even if an individual test could test any particular proposition. *)
(*
  - apply (@ts_test ex2_test ex2_pt (ex2_test_any Q)).
Defined.

(*
Compute proven ts_ex2.
(* forall x : Prop, Prop -> x -> True /\ x *)

Compute assumed ts_ex2.
(* forall x x0 : Prop, x -> x0 /\ True *)
*)

(* Unfortunately, our assumption will be hard to prove. *)
Theorem ts_ex2_assumed_false : ~(assumed ts_ex2).
  simpl. intros Hassumed. assert (False /\ True) as H.
  - apply (Hassumed True). constructor.
  - destruct H as [ HFalse _ ]. apply HFalse.
Qed.

(* We could just use exfalso, but let's try applying the correctness theorem anyway. *)
Theorem ts_ex2_correct : assumed ts_ex2 -> example_2.
  intros Hassumed.
  apply (test_strategy_correct ts_ex2).
  apply Hassumed.
Qed.
*)

(* Try to test P x -> R (g (f x)) by testing P x -> Q (f x) and Q y -> R (g y) *)
Section ex3.
  Variable A : Type.
  Variable B : Type.
  Variable C : Type.
  Variable f : A -> B.
  Variable g : B -> C.
  Variable P : A -> Prop.
  Variable Q : B -> Prop.
  Variable R : C -> Prop.

  Definition example_3 := forall a, P a -> R (g (f a)).

  Inductive ex3_test : Type :=
  | ex3_t1 : ex3_test
  | ex3_t2 : ex3_test.

  Definition ex3_pt (t : ex3_test) : Prop :=
  match t with
  | ex3_t1 => forall a:A, P a -> Q (f a)
  | ex3_t2 => forall b:B, Q b -> R (g b)
  end.

  Definition ts_ex3 : @test_strategy ex3_test ex3_pt true example_3.
    apply (@ts_mp _ _ false true ((forall a:A, P a -> Q (f a)) /\ (forall b:B, Q b -> R (g b)))).
    - apply ts_prove. intros Hand. destruct Hand as [ Hf Hg ]. unfold example_3.
      auto.
    - apply (@ts_and _ _ true true).
      + apply (@ts_test ex3_test ex3_pt ex3_t1).
      + apply (@ts_test ex3_test ex3_pt ex3_t2).
  Defined.

(*
Compute proven ts_ex3.
(* ((forall x : A, P x -> Q (f x)) /\ (forall x : B, Q x -> R (g x)) ->
        forall x0 : A, P x0 -> R (g (f x0))) /\ True /\ True *)

Compute assumed ts_ex3.
(* True /\
       (forall x : A, P x -> Q (f x)) /\ (forall x : B, Q x -> R (g x)) *)

Compute to_test ts_ex3.
(* ex3_t1 :: ex3_t2 :: nil *)
*)

  (* TODO: add a hint or hints to make these proofs automatic? *)
  Theorem ts_ex3_correct : assumed ts_ex3 -> example_3.
    intros HAts_ex3. apply (test_strategy_correct ts_ex3).
    apply HAts_ex3.
  Qed.
End ex3.


Require Import Coq.NArith.NArith.
Require Import Coq.FSets.FMaps.
Require Import Coq.micromega.Lia.

(* Override ++> notation with the crelation-based version. *)
#[local] Set Warnings "-notation-overridden".
Require Import Category.Lib.
Require Import Category.Lib.FMapExt.

Generalizable All Variables.

(* For the time being, this module is fixed to maps from [N * N → N]. *)

Module PO := PairOrderedType N_as_OT N_as_OT.
Module M  := FMapList.Make(PO).
Module Import FMapExt := FMapExt PO M.

(**************************************************************************
 * Data type for representing partial results, taken from Chlipala's CPDT
 *)

Inductive partial (P : Prop) : Set :=
| Proved : P → partial
| Uncertain : partial.

Notation "[ P ]" := (partial P) : type_scope.

Declare Scope partial_scope.

Notation "'Yes'" := (Proved _ _) : partial_scope.
Notation "'No'" := (Uncertain _) : partial_scope.

#[local] Open Scope partial_scope.
Delimit Scope partial_scope with partial.

Notation "'Reduce' v" := (if v then Yes else No) (at level 100) : partial_scope.
Notation "x || y" := (if x then Yes else Reduce y) : partial_scope.
Notation "x && y" := (if x then Reduce y else No) : partial_scope.

(**************************************************************************
 * A term language for theorems involving FMaps
 *)

Record environment := {
  vars : positive → N
}.

Inductive term :=
  | Var   : positive → term
  | Value : N → term.

Definition term_beq (x y : term) : bool :=
  match x, y with
  | Var x,   Var y   => (x =? y)%positive
  | Value x, Value y => (x =? y)%N
  | _, _ => false
  end.

Lemma term_beq_sound x y : term_beq x y = true → x = y.
Proof.
  induction x, y; simpl; intros; intuition.
  - apply Pos.eqb_eq in H; subst; reflexivity.
  - apply N.eqb_eq in H; subst; reflexivity.
Defined.

Program Definition term_eq_dec (x y : term) : {x = y} + {x ≠ y} :=
  match x, y with
  | Var x,   Var y   => if Pos.eq_dec x y then left _ else right _
  | Value x, Value y => if N.eq_dec   x y then left _ else right _
  | _, _ => right _
  end.
Next Obligation.
  intuition; subst.
  destruct y.
  - specialize (H0 p p); intuition.
  - specialize (H n n); intuition.
Defined.
Next Obligation.
  split; unfold not; intros ? ? H1;
  destruct H1; discriminate.
Defined.
Next Obligation.
  split; unfold not; intros ? ? H1;
  destruct H1; discriminate.
Defined.

Definition subst_all {A} (f : A → term → term → A) :
  A → list (term * term) → A :=
  fold_right (fun '(v, v') rest => f rest v v').

Definition subst_term (x v v' : term) : term :=
  if term_beq x v then v' else x.

Definition term_denote env (x : term) : N :=
  match x with
  | Var n => vars env n
  | Value n => n
  end.

Inductive map_expr : Set :=
  | Empty : map_expr
  | Add   : term → term → term → map_expr → map_expr.

Fixpoint subst_map_expr (t : map_expr) (v v' : term) : map_expr :=
  match t with
  | Empty => Empty
  | Add x y f m =>
    Add (subst_term x v v')
        (subst_term y v v')
        (subst_term f v v')
        (subst_map_expr m v v')
  end.

Fixpoint map_expr_denote env (m : map_expr) : M.t N :=
  match m with
  | Empty => M.empty N
  | Add x y f m' => M.add (term_denote env x, term_denote env y)
                          (term_denote env  f) (map_expr_denote env m')
  end.

Inductive formula :=
  | Top    : formula
  | Bottom : formula
  | Maps   : term → term → term → map_expr → formula
  | Impl   : formula → formula → formula.

Fixpoint subst_formula (t : formula) (v v' : term) : formula :=
  match t with
  | Top => Top
  | Bottom => Bottom
  | Maps x y f m =>
    Maps (subst_term x v v')
         (subst_term y v v')
         (subst_term f v v')
         (subst_map_expr m v v')
  | Impl p q => Impl (subst_formula p v v') (subst_formula q v v')
  end.

Fixpoint formula_denote env (t : formula) : Prop :=
  match t with
  | Top => True
  | Bottom => False
  | Maps x y f m =>
    M.MapsTo (term_denote env x, term_denote env y)
             (term_denote env f) (map_expr_denote env m)
  | Impl p q => formula_denote env p → formula_denote env q
  end.

(**************************************************************************
 * Compute structural size of formulas, for well-founded recursion
 *)

Fixpoint map_expr_size (t : map_expr) : nat :=
  match t with
  | Empty       => 1%nat
  | Add _ _ _ m => 1%nat + map_expr_size m
  end.

Lemma map_expr_size_subst_map_expr v v' m :
  map_expr_size (subst_map_expr m v v') = map_expr_size m.
Proof. induction m; simpl; auto. Qed.

Lemma map_expr_size_subst_all_map_expr defs m :
  map_expr_size (subst_all subst_map_expr m defs) = map_expr_size m.
Proof.
  induction defs; simpl; auto.
  destruct a.
  now rewrite map_expr_size_subst_map_expr.
Qed.

Fixpoint formula_size (t : formula) : nat :=
  match t with
  | Top          => 1%nat
  | Bottom       => 1%nat
  | Maps _ _ _ m => 1%nat + map_expr_size m
  | Impl p q     => 1%nat + formula_size p + formula_size q
  end.

Lemma formula_size_subst_formula v v' m :
  formula_size (subst_formula m v v') = formula_size m.
Proof.
  induction m; simpl; auto.
  now rewrite map_expr_size_subst_map_expr.
Qed.

Lemma formula_size_subst_all_formula defs m :
  formula_size (subst_all subst_formula m defs) = formula_size m.
Proof.
  induction defs; simpl; auto.
  destruct a.
  now rewrite formula_size_subst_formula.
Qed.

(**************************************************************************
 * Substitution of variables throughout a formula
 *)

Definition substitution (x y : term) : option (term * term) :=
  match x, y with
  | Var n, Var m => if Pos.eq_dec n m then None else Some (x, y)
  | Var _, _     => Some (x, y)
  | _ ,    Var _ => Some (y, x)
  | _,     _     => None
  end.

Fixpoint substitutions (xs : list (term * term)) : list (term * term) :=
  match xs with
  | nil => nil
  | cons (x, y) xs =>
    match substitution x y with
    | Some p => cons p (substitutions xs)
    | None => substitutions xs
    end
  end.

Lemma term_denote_subst_term env v v' t :
  term_denote env v = term_denote env v'
    → term_denote env (subst_term t v v') = term_denote env t.
Proof.
  unfold subst_term; intros.
  destruct term_beq eqn:?; auto.
  apply term_beq_sound in Heqb.
  congruence.
Qed.

Lemma term_denote_substitution {env t0 t1 t2 t3} :
  substitution t0 t1 = Some (t2, t3)
    → term_denote env t0 = term_denote env t1
    → term_denote env t2 = term_denote env t3.
Proof.
  intros.
  destruct t0, t1; simpl in H;
  try (destruct (Pos.eq_dec _ _); [discriminate|]);
  now inversion_clear H.
Qed.

Lemma term_substitution_eq env t xs :
  Forall (fun '(v, v') => term_denote env v = term_denote env v') xs
    → term_denote env (subst_all subst_term t (substitutions xs)) =
      term_denote env t.
Proof.
  induction xs as [|[] ?]; simpl; intros; auto.
  inversion H.
  destruct (substitution t0 t1) eqn:?; intuition.
  destruct p; simpl.
  rewrite term_denote_subst_term; auto.
  now apply (term_denote_substitution Heqo).
Qed.

Lemma map_expr_denote_subst_map_expr env v v' m :
  term_denote env v = term_denote env v'
    → map_expr_denote env (subst_map_expr m v v') = map_expr_denote env m.
Proof.
  induction m; simpl; auto; intros.
  rewrite IHm; auto.
  now rewrite !term_denote_subst_term.
Qed.

Lemma map_expr_substitution_eq env t xs :
  Forall (fun p => term_denote env (fst p) = term_denote env (snd p)) xs
    → map_expr_denote env (subst_all subst_map_expr t (substitutions xs)) =
       map_expr_denote env t.
Proof.
  induction xs as [|[] ?]; simpl; intros; auto.
  inversion H.
  destruct (substitution t0 t1) eqn:?; intuition.
  destruct p; simpl.
  rewrite map_expr_denote_subst_map_expr; auto.
  now apply (term_denote_substitution Heqo).
Qed.

Lemma formula_denote_subst_formula env v v' t :
  term_denote env v = term_denote env v'
    → formula_denote env (subst_formula t v v') = formula_denote env t.
Proof.
  induction t; simpl; auto; intros.
  - rewrite map_expr_denote_subst_map_expr,
            !term_denote_subst_term; auto.
  - rewrite IHt1, IHt2; auto.
Qed.

Lemma formula_substitution_eq env t xs :
  Forall (fun p => term_denote env (fst p) = term_denote env (snd p)) xs
    → formula_denote env (subst_all subst_formula t (substitutions xs)) =
       formula_denote env t.
Proof.
  induction xs as [|[] ?]; simpl; intros; auto.
  inversion H.
  destruct (substitution t0 t1) eqn:?; intuition.
  destruct p; simpl.
  rewrite formula_denote_subst_formula; auto.
  now apply (term_denote_substitution Heqo).
Qed.

(**************************************************************************
 * Code for removing conflicted map entries
 *)

Definition conflicted (x y : term) : bool :=
  match x, y with
  | Value n, Value n' => negb (N.eqb n n')
  | _, _ => false
  end.

Fixpoint remove_conflicts (x y f : term) (m : map_expr) : map_expr :=
  match m with
  | Empty => Empty
  | Add x' y' f' m' =>
    if (conflicted x x' || conflicted y y' || conflicted f f')%bool
    then remove_conflicts x y f m'
    else Add x' y' f' (remove_conflicts x y f m')
  end.

Lemma terms_not_conflicted env x y :
  term_denote env x = term_denote env y
    → conflicted y x = false.
Proof.
  destruct x, y; simpl; auto.
  intros; subst.
  rewrite N.eqb_refl; reflexivity.
Qed.

(**************************************************************************
 * Computational decision procedure for map membership
 *)

Import ListNotations.

Program Definition formula_forward (t : formula) env (hyp : formula)
        (cont : ∀ env' defs,
            [formula_denote env' (subst_all subst_formula t defs)]) :
  [formula_denote env hyp → formula_denote env t] :=
  match hyp with
  | Top => Reduce (cont env [])
  | Bottom => Yes
  | Maps x y f m =>
    let fix go n : [formula_denote env (Maps x y f n)
                    → formula_denote env t] :=
        match n with
        | Empty => Yes
        | Add x' y' f' m' =>
          cont env (substitutions [(x, x'); (y, y'); (f, f')]) && go m'
        end in Reduce (go (remove_conflicts x y f m))
  | Impl _ _ => Reduce (cont env [])
  end.
Next Obligation.
  contradiction.
Defined.
Next Obligation.
  simplify_maps.
  match goal with [ H : _ /\ _ |- _ ] => destruct H end.
  simpl in *.
  pose proof (formula_substitution_eq env t [(x, x'); (y, y'); (f, f')]).
  let Hr := match goal with [ H : _ → _ = _ |- _ ] => H end in
  simpl in Hr; rewrite <- Hr; auto.
Defined.
Next Obligation.
  match goal with [ H : M.MapsTo _ _ _ → _ |- _ ] => apply H; clear H end.
  induction m; simpl in *; auto.
  destruct (conflicted x t0) eqn:?;
  destruct (conflicted y t1) eqn:?;
  destruct (conflicted f t2) eqn:?;
  simpl; simplify_maps;
  try destruct H1;
  simpl in *;
  try pose proof (terms_not_conflicted _ _ _ H);
  try pose proof (terms_not_conflicted _ _ _ H0);
  try pose proof (terms_not_conflicted _ _ _ H2);
  try congruence;
  rewrite ?H, ?H0, ?H2;
  simplify_maps.
Defined.

Fixpoint map_contains env (x y : N) (m : map_expr) : option term :=
  match m with
  | Empty => None
  | Add x' y' f' m' =>
    if (N.eqb x (term_denote env x') &&
        N.eqb y (term_denote env y'))%bool
    then Some f'
    else map_contains env x y m'
  end.

Lemma map_contains_MapsTo env x y f m :
  Some f = map_contains env x y m
    → M.MapsTo (x, y) (term_denote env f) (map_expr_denote env m).
Proof.
  induction m; simpl; intros.
  - discriminate.
  - simplify_maps.
    destruct ((x =? term_denote env t)%N &&
              (y =? term_denote env t0)%N)%bool eqn:?.
    + inversion_clear H.
      clear IHm.
      apply andb_true_iff in Heqb.
      destruct Heqb.
      apply N.eqb_eq in H.
      apply N.eqb_eq in H0.
      intuition.
    + right.
      apply andb_false_iff in Heqb.
      destruct Heqb;
      apply N.eqb_neq in H0;
      intuition.
Qed.

Program Fixpoint formula_backward (t : formula) env {measure (formula_size t)} :
  [formula_denote env t] :=
  match t with
  | Top => Yes
  | Bottom => No
  | Maps x y f m =>
    match map_contains env (term_denote env x) (term_denote env y) m with
    | Some f' => Reduce (term_eq_dec f' f)
    | None => No
    end
  | Impl p q =>
    formula_forward q env p
      (fun env' defs' => formula_backward (subst_all subst_formula q defs') env')
  end.
Next Obligation.
  apply map_contains_MapsTo; auto.
Defined.
Next Obligation.
  rewrite formula_size_subst_all_formula; simpl; lia.
Defined.

Definition formula_tauto : ∀ env t, [formula_denote env t].
Proof.
  intros; refine (Reduce (formula_backward t env)); auto.
Defined.

Lemma formula_sound env t :
  (if formula_tauto env t then True else False) → formula_denote env t.
Proof.
  unfold formula_tauto; destruct t, (formula_backward _ env); tauto.
Qed.

(**************************************************************************
 * Environment management tactics
 *)

Ltac inList x xs :=
  match xs with
  | tt => false
  | (x, _) => true
  | (_, ?xs') => inList x xs'
  end.

Ltac addToList x xs :=
  let b := inList x xs in
  match b with
  | true => xs
  | false => constr:((x, xs))
  end.

Ltac lookup x xs :=
  match xs with
  | (x, _) => constr:(1%positive)
  | (_, ?xs') =>
    let n := lookup x xs' in
    constr:(Pos.succ n)
  end.

Ltac functionalize xs :=
  let rec loop n xs' :=
    lazymatch xs' with
    | tt => constr:(fun _ : positive => 0%N)
    | (?x, tt) => constr:(fun _ : positive => x)
    | (?x, ?xs'') =>
      let f := loop (Pos.succ n) xs'' in
      constr:(fun m : positive => if (m =? n)%positive then x else f m)
    end in
  loop (1%positive) xs.

Ltac allVar xs e :=
  match e with
  | N0 => xs
  | Npos _ => xs
  | _ => addToList e xs
  end.

Ltac allVars xs e :=
  match e with
  | M.MapsTo (?X, ?Y) ?F _ =>
    let xs := allVar xs X in
    let xs := allVar xs Y in
    allVar xs F
  | M.In (?X, ?Y) _ =>
    let xs := allVar xs X in
    allVar xs Y
  | ?P → ?Q =>
    let xs := allVars xs P in
    allVars xs Q
  | _ => xs
  end.

(**************************************************************************
 * Reflection tactics
 *)

Ltac reifyValue env t :=
  match t with
  | N0 => constr:(Value N0)
  | Npos ?X =>
    constr:(Value (Npos X))
  | ?X =>
    let v := lookup X env in
    constr:(Var v)
  end.

Ltac reifyMapTerm env t :=
  match t with
  | M.empty _ => constr:(Empty)
  | M.add (?X, ?Y) ?F ?M =>
    let x := reifyValue env X in
    let y := reifyValue env Y in
    let f := reifyValue env F in
    let m := reifyMapTerm env M in
    constr:(Add x y f m)
  end.

Ltac reifyTerm env t :=
  match t with
  | True => constr:(Top)
  | False => constr:(Bottom)
  | M.MapsTo (?X, ?Y) ?F ?M =>
    let x := reifyValue env X in
    let y := reifyValue env Y in
    let f := reifyValue env F in
    let m := reifyMapTerm env M in
    constr:(Maps x y f m)
  | ?P → ?Q =>
    let p := reifyTerm env P in
    let q := reifyTerm env Q in
    constr:(Impl p q)
  end.

Ltac gather_vars :=
  match goal with
  | [ |- ?X ] =>
    let xs  := allVars tt X in
    pose xs
  end.

Ltac reify' :=
  match goal with
  | [ |- ?X ] =>
    let xs  := allVars tt X in
    let env := functionalize xs in
    let r1  := reifyTerm xs X in
    pose xs;
    pose env;
    pose r1
  end.

Ltac reify :=
  match goal with
  | [ |- ?X ] =>
    let xs  := allVars tt X in
    let env := functionalize xs in
    let r1  := reifyTerm xs X in
    change (formula_denote {| vars := env |} r1)
  end.

(**************************************************************************
 * User interface tactics
 *)

Ltac solve_map := reify; apply formula_sound; vm_compute; auto.

#[export]
Program Instance sigT_proper {A : Type} :
  Proper (pointwise_relation A Basics.arrow ==> Basics.arrow) (@sigT A).
Next Obligation.
  proper.
  destruct X0.
  apply X in x1.
  exists x0.
  assumption.
Defined.

Lemma find_mapsto_iff_ex {elt k m} :
  (∃ v : elt, M.MapsTo (elt:=elt) k v m) ->
  (∃ v : elt, M.find (elt:=elt) k m = Some v).
Proof.
  apply sigT_proper.
  intros ??.
  apply F.find_mapsto_iff.
  assumption.
Defined.

Ltac prepare_maps :=
  repeat lazymatch goal with
  | [ |- ∃ v, M.find _ _ = Some v ] =>
    apply find_mapsto_iff_ex, in_mapsto_iffT
  | [ |- M.find _ _ = Some _ ] =>
    apply F.find_mapsto_iff
  | [ H : M.find _ (M.empty _) = Some _ |- _ ] => inversion H
  | [ H : M.find _ _ = Some ?F |- _ ] =>
    apply F.find_mapsto_iff in H; revert H
  | [ H : M.MapsTo _ _ (M.empty _) |- _ ] =>
    contradiction (proj1 (F.empty_mapsto_iff _ _) H)
  end.

Ltac map_decide := prepare_maps; solve_map.


(** * Records: Adding Records to STLC *)

(* $Date: 2013-07-17 16:19:11 -0400 (Wed, 17 Jul 2013) $ *)

Require Export Stlc.

(* ###################################################################### *)
(** * Adding Records *)

(** We saw in chapter [MoreStlc] how records can be treated as syntactic
    sugar for nested uses of products.  This is fine for simple
    examples, but the encoding is informal (in reality, if we really
    treated records this way, it would be carried out in the parser,
    which we are eliding here), and anyway it is not very efficient.
    So it is also interesting to see how records can be treated as
    first-class citizens of the language.

    Recall the informal definitions we gave before: *)

(**
    Syntax:
<<
       t ::=                          Terms:
           | ...
           | {i1=t1, ..., in=tn}         record
           | t.i                         projection

       v ::=                          Values:
           | ...
           | {i1=v1, ..., in=vn}         record value

       T ::=                          Types:
           | ...
           | {i1:T1, ..., in:Tn}         record type
>>
   Reduction:
                                 ti ==> ti'                            (ST_Rcd)
    --------------------------------------------------------------------
    {i1=v1, ..., im=vm, in=tn, ...} ==> {i1=v1, ..., im=vm, in=tn', ...}

                                 t1 ==> t1'
                               --------------                        (ST_Proj1)
                               t1.i ==> t1'.i

                          -------------------------                (ST_ProjRcd)
                          {..., i=vi, ...}.i ==> vi
   Typing:
               Gamma |- t1 : T1     ...     Gamma |- tn : Tn
             --------------------------------------------------         (T_Rcd)
             Gamma |- {i1=t1, ..., in=tn} : {i1:T1, ..., in:Tn}

                       Gamma |- t : {..., i:Ti, ...}
                       -----------------------------                   (T_Proj)
                             Gamma |- t.i : Ti
*)

(* ###################################################################### *)
(** * Formalizing Records *)

Module STLCExtendedRecords.

(* ###################################################################### *)
(** *** Syntax and Operational Semantics *)

(** The most obvious way to formalize the syntax of record types would
    be this: *)

Module FirstTry.

Definition alist (X : Type) := list (id * X).

Inductive ty : Type :=
  | TBase     : id -> ty
  | TArrow    : ty -> ty -> ty
  | TRcd      : (alist ty) -> ty.

(** Unfortunately, we encounter here a limitation in Coq: this type
    does not automatically give us the induction principle we expect
    -- the induction hypothesis in the [TRcd] case doesn't give us
    any information about the [ty] elements of the list, making it
    useless for the proofs we want to do.  *)

(* Check ty_ind.
   ====>
    ty_ind :
      forall P : ty -> Prop,
        (forall i : id, P (TBase i)) ->
        (forall t : ty, P t -> forall t0 : ty, P t0 -> P (TArrow t t0)) ->
        (forall a : alist ty, P (TRcd a)) ->    (* ??? *)
        forall t : ty, P t
*)

End FirstTry.

(** It is possible to get a better induction principle out of Coq, but
    the details of how this is done are not very pretty, and it is not
    as intuitive to use as the ones Coq generates automatically for
    simple [Inductive] definitions.

    Fortunately, there is a different way of formalizing records that
    is, in some ways, even simpler and more natural: instead of using
    the existing [list] type, we can essentially include its
    constructors ("nil" and "cons") in the syntax of types. *)

Inductive ty : Type :=
  | TBase : id -> ty
  | TArrow : ty -> ty -> ty
  | TRNil : ty
  | TRCons : id -> ty -> ty -> ty.

Tactic Notation "T_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "TBase" | Case_aux c "TArrow"
  | Case_aux c "TRNil" | Case_aux c "TRCons" ].

(** Similarly, at the level of terms, we have constructors [trnil]
    -- the empty record -- and [trcons], which adds a single field to
    the front of a list of fields. *)

Inductive tm : Type :=
  | tvar : id -> tm
  | tapp : tm -> tm -> tm
  | tabs : id -> ty -> tm -> tm
  (* records *)
  | tproj : tm -> id -> tm
  | trnil :  tm
  | trcons : id -> tm -> tm -> tm.

Tactic Notation "t_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "tvar" | Case_aux c "tapp" | Case_aux c "tabs"
  | Case_aux c "tproj" | Case_aux c "trnil" | Case_aux c "trcons" ].

(** Some variables, for examples... *)

Notation a := (Id 0).
Notation f := (Id 1).
Notation g := (Id 2).
Notation l := (Id 3).
Notation A := (TBase (Id 4)).
Notation B := (TBase (Id 5)).
Notation k := (Id 6).
Notation i1 := (Id 7).
Notation i2 := (Id 8).

(** [{ i1:A }] *)

(* Check (TRCons i1 A TRNil). *)

(** [{ i1:A->B, i2:A }] *)

(* Check (TRCons i1 (TArrow A B)
           (TRCons i2 A TRNil)). *)

(* ###################################################################### *)
(** *** Well-Formedness *)

(** Generalizing our abstract syntax for records (from lists to the
    nil/cons presentation) introduces the possibility of writing
    strange types like this *)

Definition weird_type := TRCons X A B.

(** where the "tail" of a record type is not actually a record type! *)

(** We'll structure our typing judgement so that no ill-formed types
    like [weird_type] are assigned to terms.  To support this, we
    define [record_ty] and [record_tm], which identify record types
    and terms, and [well_formed_ty] which rules out the ill-formed
    types. *)

(** First, a type is a record type if it is built with just [TRNil]
    and [TRCons] at the outermost level. *)

Inductive record_ty : ty -> Prop :=
  | RTnil :
        record_ty TRNil
  | RTcons : forall i T1 T2,
        record_ty (TRCons i T1 T2).

(** Similarly, a term is a record term if it is built with [trnil]
    and [trcons] *)

Inductive record_tm : tm -> Prop :=
  | rtnil :
        record_tm trnil
  | rtcons : forall i t1 t2,
        record_tm (trcons i t1 t2).

(** Note that [record_ty] and [record_tm] are not recursive -- they
    just check the outermost constructor.  The [well_formed_ty]
    property, on the other hand, verifies that the whole type is well
    formed in the sense that the tail of every record (the second
    argument to [TRCons]) is a record.

    Of course, we should also be concerned about ill-formed terms, not
    just types; but typechecking can rules those out without the help
    of an extra [well_formed_tm] definition because it already
    examines the structure of terms.  *)
(** LATER : should they fill in part of this as an exercise?  We
    didn't give rules for it above *)

Inductive well_formed_ty : ty -> Prop :=
  | wfTBase : forall i,
        well_formed_ty (TBase i)
  | wfTArrow : forall T1 T2,
        well_formed_ty T1 ->
        well_formed_ty T2 ->
        well_formed_ty (TArrow T1 T2)
  | wfTRNil :
        well_formed_ty TRNil
  | wfTRCons : forall i T1 T2,
        well_formed_ty T1 ->
        well_formed_ty T2 ->
        record_ty T2 ->
        well_formed_ty (TRCons i T1 T2).

Hint Constructors record_ty record_tm well_formed_ty.

(* ###################################################################### *)
(** *** Substitution *)

Fixpoint subst (x:id) (s:tm) (t:tm) : tm :=
  match t with
  | tvar y => if eq_id_dec x y then s else t
  | tabs y T t1 =>  tabs y T (if eq_id_dec x y then t1 else (subst x s t1))
  | tapp t1 t2 => tapp (subst x s t1) (subst x s t2)
  | tproj t1 i => tproj (subst x s t1) i
  | trnil => trnil
  | trcons i t1 tr1 => trcons i (subst x s t1) (subst x s tr1)
  end.

Notation "'[' x ':=' s ']' t" := (subst x s t) (at level 20).

(* ###################################################################### *)
(** *** Reduction *)

(** Next we define the values of our language.  A record is a value if
    all of its fields are. *)

Inductive value : tm -> Prop :=
  | v_abs : forall x T11 t12,
      value (tabs x T11 t12)
  | v_rnil : value trnil
  | v_rcons : forall i v1 vr,
      value v1 ->
      value vr ->
      value (trcons i v1 vr).

Hint Constructors value.

(** Utility functions for extracting one field from record type or
    term: *)

Fixpoint Tlookup (i:id) (Tr:ty) : option ty :=
  match Tr with
  | TRCons i' T Tr' => if eq_id_dec i i' then Some T else Tlookup i Tr'
  | _ => None
  end.

Fixpoint tlookup (i:id) (tr:tm) : option tm :=
  match tr with
  | trcons i' t tr' => if eq_id_dec i i' then Some t else tlookup i tr'
  | _ => None
  end.

(** The [step] function uses the term-level lookup function (for the
    projection rule), while the type-level lookup is needed for
    [has_type]. *)

Reserved Notation "t1 '==>' t2" (at level 40).

Inductive step : tm -> tm -> Prop :=
  | ST_AppAbs : forall x T11 t12 v2,
         value v2 ->
         (tapp (tabs x T11 t12) v2) ==> ([x:=v2]t12)
  | ST_App1 : forall t1 t1' t2,
         t1 ==> t1' ->
         (tapp t1 t2) ==> (tapp t1' t2)
  | ST_App2 : forall v1 t2 t2',
         value v1 ->
         t2 ==> t2' ->
         (tapp v1 t2) ==> (tapp v1 t2')
  | ST_Proj1 : forall t1 t1' i,
        t1 ==> t1' ->
        (tproj t1 i) ==> (tproj t1' i)
  | ST_ProjRcd : forall tr i vi,
        value tr ->
        tlookup i tr = Some vi ->
        (tproj tr i) ==> vi
  | ST_Rcd_Head : forall i t1 t1' tr2,
        t1 ==> t1' ->
        (trcons i t1 tr2) ==> (trcons i t1' tr2)
  | ST_Rcd_Tail : forall i v1 tr2 tr2',
        value v1 ->
        tr2 ==> tr2' ->
        (trcons i v1 tr2) ==> (trcons i v1 tr2')

where "t1 '==>' t2" := (step t1 t2).

Tactic Notation "step_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "ST_AppAbs" | Case_aux c "ST_App1" | Case_aux c "ST_App2"
  | Case_aux c "ST_Proj1" | Case_aux c "ST_ProjRcd"
  | Case_aux c "ST_Rcd_Head" | Case_aux c "ST_Rcd_Tail" ].

Notation multistep := (multi step).
Notation "t1 '==>*' t2" := (multistep t1 t2) (at level 40).

Hint Constructors step.

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

Definition context := partial_map ty.

(** Next we define the typing rules.  These are nearly direct
    transcriptions of the inference rules shown above.  The only major
    difference is the use of [well_formed_ty].  In the informal
    presentation we used a grammar that only allowed well formed
    record types, so we didn't have to add a separate check.

    We'd like to set things up so that that whenever [has_type Gamma t
    T] holds, we also have [well_formed_ty T].  That is, [has_type]
    never assigns ill-formed types to terms.  In fact, we prove this
    theorem below.

    However, we don't want to clutter the definition of [has_type]
    with unnecessary uses of [well_formed_ty].  Instead, we place
    [well_formed_ty] checks only where needed - where an inductive
    call to [has_type] won't already be checking the well-formedness
    of a type.

    For example, we check [well_formed_ty T] in the [T_Var] case,
    because there is no inductive [has_type] call that would
    enforce this.  Similarly, in the [T_Abs] case, we require a
    proof of [well_formed_ty T11] because the inductive call to
    [has_type] only guarantees that [T12] is well-formed.

    In the rules you must write, the only necessary [well_formed_ty]
    check comes in the [tnil] case.  *)

Reserved Notation "Gamma '|-' t '\in' T" (at level 40).

Inductive has_type : context -> tm -> ty -> Prop :=
  | T_Var : forall Gamma x T,
      Gamma x = Some T ->
      well_formed_ty T ->
      Gamma |- (tvar x) \in T
  | T_Abs : forall Gamma x T11 T12 t12,
      well_formed_ty T11 ->
      (extend Gamma x T11) |- t12 \in T12 ->
      Gamma |- (tabs x T11 t12) \in (TArrow T11 T12)
  | T_App : forall T1 T2 Gamma t1 t2,
      Gamma |- t1 \in (TArrow T1 T2) ->
      Gamma |- t2 \in T1 ->
      Gamma |- (tapp t1 t2) \in T2
  (* records: *)
  | T_Proj : forall Gamma i t Ti Tr,
      Gamma |- t \in Tr ->
      Tlookup i Tr = Some Ti ->
      Gamma |- (tproj t i) \in Ti
  | T_RNil : forall Gamma,
      Gamma |- trnil \in TRNil
  | T_RCons : forall Gamma i t T tr Tr,
      Gamma |- t \in T ->
      Gamma |- tr \in Tr ->
      record_ty Tr ->
      record_tm tr ->
      Gamma |- (trcons i t tr) \in (TRCons i T Tr)

where "Gamma '|-' t '\in' T" := (has_type Gamma t T).

Hint Constructors has_type.

Tactic Notation "has_type_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "T_Var" | Case_aux c "T_Abs" | Case_aux c "T_App"
  | Case_aux c "T_Proj" | Case_aux c "T_RNil" | Case_aux c "T_RCons" ].

(* ###################################################################### *)
(** ** Examples *)

(** **** Exercise: 2 stars (examples) *)
(** Finish the proofs. *)

(** Feel free to use Coq's automation features in this proof.
    However, if you are not confident about how the type system works,
    you may want to carry out the proof first using the basic
    features ([apply] instead of [eapply], in particular) and then
    perhaps compress it using automation. *)

Lemma typing_example_2 :
  empty |-
    (tapp (tabs a (TRCons i1 (TArrow A A)
                      (TRCons i2 (TArrow B B)
                       TRNil))
              (tproj (tvar a) i2))
            (trcons i1 (tabs a A (tvar a))
            (trcons i2 (tabs a B (tvar a))
             trnil))) \in
    (TArrow B B).
Proof.
  (* FILL IN HERE *) Admitted.

(** Before starting to prove this fact (or the one above!), make sure
    you understand what it is saying. *)

Example typing_nonexample :
  ~ exists T,
      (extend empty a (TRCons i2 (TArrow A A)
                                TRNil)) |-
               (trcons i1 (tabs a B (tvar a)) (tvar a)) \in
               T.
Proof.
  (* FILL IN HERE *) Admitted.

Example typing_nonexample_2 : forall y,
  ~ exists T,
    (extend empty y A) |-
           (tapp (tabs a (TRCons i1 A TRNil)
                     (tproj (tvar a) i1))
                   (trcons i1 (tvar y) (trcons i2 (tvar y) trnil))) \in
           T.
Proof.
  (* FILL IN HERE *) Admitted.

(* ###################################################################### *)
(** ** Properties of Typing *)

(** The proofs of progress and preservation for this system are
    essentially the same as for the pure simply typed lambda-calculus,
    but we need to add some technical lemmas involving records. *)

(* ###################################################################### *)
(** *** Well-Formedness *)

Lemma wf_rcd_lookup : forall i T Ti,
  well_formed_ty T ->
  Tlookup i T = Some Ti ->
  well_formed_ty Ti.
Proof with eauto.
  intros i T.
  T_cases (induction T) Case; intros; try solve by inversion.
  Case "TRCons".
    inversion H. subst. unfold Tlookup in H0.
    destruct (eq_id_dec i i0)...
    inversion H0. subst...  Qed.

Lemma step_preserves_record_tm : forall tr tr',
  record_tm tr ->
  tr ==> tr' ->
  record_tm tr'.
Proof.
  intros tr tr' Hrt Hstp.
  inversion Hrt; subst; inversion Hstp; subst; auto.
Qed.

Lemma has_type__wf : forall Gamma t T,
  Gamma |- t \in T -> well_formed_ty T.
Proof with eauto.
  intros Gamma t T Htyp.
  has_type_cases (induction Htyp) Case...
  Case "T_App".
    inversion IHHtyp1...
  Case "T_Proj".
    eapply wf_rcd_lookup...
Qed.

(* ###################################################################### *)
(** *** Field Lookup *)

(** Lemma: If [empty |- v : T] and [Tlookup i T] returns [Some Ti],
     then [tlookup i v] returns [Some ti] for some term [ti] such
     that [empty |- ti \in Ti].

    Proof: By induction on the typing derivation [Htyp].  Since
      [Tlookup i T = Some Ti], [T] must be a record type, this and
      the fact that [v] is a value eliminate most cases by inspection,
      leaving only the [T_RCons] case.

      If the last step in the typing derivation is by [T_RCons], then
      [t = trcons i0 t tr] and [T = TRCons i0 T Tr] for some [i0],
      [t], [tr], [T] and [Tr].

      This leaves two possiblities to consider - either [i0 = i] or
      not.

      - If [i = i0], then since [Tlookup i (TRCons i0 T Tr) = Some
        Ti] we have [T = Ti].  It follows that [t] itself satisfies
        the theorem.

      - On the other hand, suppose [i <> i0].  Then
        Tlookup i T = Tlookup i Tr
        and
        tlookup i t = tlookup i tr,
        so the result follows from the induction hypothesis. [] *)

Lemma lookup_field_in_value : forall v T i Ti,
  value v ->
  empty |- v \in T ->
  Tlookup i T = Some Ti ->
  exists ti, tlookup i v = Some ti /\ empty |- ti \in Ti.
Proof with eauto.
  intros v T i Ti Hval Htyp Hget.
  remember (@empty ty) as Gamma.
  has_type_cases (induction Htyp) Case; subst; try solve by inversion...
  Case "T_RCons".
    simpl in Hget. simpl. destruct (eq_id_dec i i0).
    SCase "i is first".
      simpl. inversion Hget. subst.
      exists t...
    SCase "get tail".
      destruct IHHtyp2 as [vi [Hgeti Htypi]]...
      inversion Hval... Qed.

(* ###################################################################### *)
(** *** Progress *)

Theorem progress : forall t T,
     empty |- t \in T ->
     value t \/ exists t', t ==> t'.
Proof with eauto.
  (* Theorem: Suppose empty |- t : T.  Then either
       1. t is a value, or
       2. t ==> t' for some t'.
     Proof: By induction on the given typing derivation. *)
  intros t T Ht.
  remember (@empty ty) as Gamma.
  generalize dependent HeqGamma.
  has_type_cases (induction Ht) Case; intros HeqGamma; subst.
  Case "T_Var".
    (* The final rule in the given typing derivation cannot be [T_Var],
       since it can never be the case that [empty |- x : T] (since the
       context is empty). *)
    inversion H.
  Case "T_Abs".
    (* If the [T_Abs] rule was the last used, then [t = tabs x T11 t12],
       which is a value. *)
    left...
  Case "T_App".
    (* If the last rule applied was T_App, then [t = t1 t2], and we know
       from the form of the rule that
         [empty |- t1 : T1 -> T2]
         [empty |- t2 : T1]
       By the induction hypothesis, each of t1 and t2 either is a value
       or can take a step. *)
    right.
    destruct IHHt1; subst...
    SCase "t1 is a value".
      destruct IHHt2; subst...
      SSCase "t2 is a value".
      (* If both [t1] and [t2] are values, then we know that
         [t1 = tabs x T11 t12], since abstractions are the only values
         that can have an arrow type.  But
         [(tabs x T11 t12) t2 ==> [x:=t2]t12] by [ST_AppAbs]. *)
        inversion H; subst; try (solve by inversion).
        exists ([x:=t2]t12)...
      SSCase "t2 steps".
        (* If [t1] is a value and [t2 ==> t2'], then [t1 t2 ==> t1 t2']
           by [ST_App2]. *)
        destruct H0 as [t2' Hstp]. exists (tapp t1 t2')...
    SCase "t1 steps".
      (* Finally, If [t1 ==> t1'], then [t1 t2 ==> t1' t2] by [ST_App1]. *)
      destruct H as [t1' Hstp]. exists (tapp t1' t2)...
  Case "T_Proj".
    (* If the last rule in the given derivation is [T_Proj], then
       [t = tproj t i] and
           [empty |- t : (TRcd Tr)]
       By the IH, [t] either is a value or takes a step. *)
    right. destruct IHHt...
    SCase "rcd is value".
      (* If [t] is a value, then we may use lemma
         [lookup_field_in_value] to show [tlookup i t = Some ti] for
         some [ti] which gives us [tproj i t ==> ti] by [ST_ProjRcd]
         *)
      destruct (lookup_field_in_value _ _ _ _ H0 Ht H) as [ti [Hlkup _]].
      exists ti...
    SCase "rcd_steps".
      (* On the other hand, if [t ==> t'], then [tproj t i ==> tproj t' i]
         by [ST_Proj1]. *)
      destruct H0 as [t' Hstp]. exists (tproj t' i)...
  Case "T_RNil".
    (* If the last rule in the given derivation is [T_RNil], then
       [t = trnil], which is a value. *)
    left...
  Case "T_RCons".
    (* If the last rule is [T_RCons], then [t = trcons i t tr] and
         [empty |- t : T]
         [empty |- tr : Tr]
       By the IH, each of [t] and [tr] either is a value or can take
       a step. *)
    destruct IHHt1...
    SCase "head is a value".
      destruct IHHt2; try reflexivity.
      SSCase "tail is a value".
      (* If [t] and [tr] are both values, then [trcons i t tr]
         is a value as well. *)
        left...
      SSCase "tail steps".
        (* If [t] is a value and [tr ==> tr'], then
           [trcons i t tr ==> trcons i t tr'] by
           [ST_Rcd_Tail]. *)
        right. destruct H2 as [tr' Hstp].
        exists (trcons i t tr')...
    SCase "head steps".
      (* If [t ==> t'], then
         [trcons i t tr ==> trcons i t' tr]
         by [ST_Rcd_Head]. *)
      right. destruct H1 as [t' Hstp].
      exists (trcons i t' tr)...  Qed.

(* ###################################################################### *)
(** *** Context Invariance *)

Inductive appears_free_in : id -> tm -> Prop :=
  | afi_var : forall x,
      appears_free_in x (tvar x)
  | afi_app1 : forall x t1 t2,
      appears_free_in x t1 -> appears_free_in x (tapp t1 t2)
  | afi_app2 : forall x t1 t2,
      appears_free_in x t2 -> appears_free_in x (tapp t1 t2)
  | afi_abs : forall x y T11 t12,
        y <> x  ->
        appears_free_in x t12 ->
        appears_free_in x (tabs y T11 t12)
  | afi_proj : forall x t i,
     appears_free_in x t ->
     appears_free_in x (tproj t i)
  | afi_rhead : forall x i ti tr,
      appears_free_in x ti ->
      appears_free_in x (trcons i ti tr)
  | afi_rtail : forall x i ti tr,
      appears_free_in x tr ->
      appears_free_in x (trcons i ti tr).

Hint Constructors appears_free_in.

Lemma context_invariance : forall Gamma Gamma' t S,
     Gamma |- t \in S  ->
     (forall x, appears_free_in x t -> Gamma x = Gamma' x)  ->
     Gamma' |- t \in S.
Proof with eauto.
  intros. generalize dependent Gamma'.
  has_type_cases (induction H) Case;
    intros Gamma' Heqv...
  Case "T_Var".
    apply T_Var... rewrite <- Heqv...
  Case "T_Abs".
    apply T_Abs... apply IHhas_type. intros y Hafi.
    unfold extend. destruct (eq_id_dec x y)...
  Case "T_App".
    apply T_App with T1...
  Case "T_RCons".
    apply T_RCons...  Qed.

Lemma free_in_context : forall x t T Gamma,
   appears_free_in x t ->
   Gamma |- t \in T ->
   exists T', Gamma x = Some T'.
Proof with eauto.
  intros x t T Gamma Hafi Htyp.
  has_type_cases (induction Htyp) Case; inversion Hafi; subst...
  Case "T_Abs".
    destruct IHHtyp as [T' Hctx]... exists T'.
    unfold extend in Hctx.
    rewrite neq_id in Hctx...
Qed.

(* ###################################################################### *)
(** *** Preservation *)

Lemma substitution_preserves_typing : forall Gamma x U v t S,
     (extend Gamma x U) |- t \in S  ->
     empty |- v \in U   ->
     Gamma |- ([x:=v]t) \in S.
Proof with eauto.
  (* Theorem: If Gamma,x:U |- t : S and empty |- v : U, then
     Gamma |- ([x:=v]t) S. *)
  intros Gamma x U v t S Htypt Htypv.
  generalize dependent Gamma. generalize dependent S.
  (* Proof: By induction on the term t.  Most cases follow directly
     from the IH, with the exception of tvar, tabs, trcons.
     The former aren't automatic because we must reason about how the
     variables interact. In the case of trcons, we must do a little
     extra work to show that substituting into a term doesn't change
     whether it is a record term. *)
  t_cases (induction t) Case;
    intros S Gamma Htypt; simpl; inversion Htypt; subst...
  Case "tvar".
    simpl. rename i into y.
    (* If t = y, we know that
         [empty |- v : U] and
         [Gamma,x:U |- y : S]
       and, by inversion, [extend Gamma x U y = Some S].  We want to
       show that [Gamma |- [x:=v]y : S].

       There are two cases to consider: either [x=y] or [x<>y]. *)
    destruct (eq_id_dec x y).
    SCase "x=y".
    (* If [x = y], then we know that [U = S], and that [[x:=v]y = v].
       So what we really must show is that if [empty |- v : U] then
       [Gamma |- v : U].  We have already proven a more general version
       of this theorem, called context invariance. *)
      subst.
      unfold extend in H0. rewrite eq_id in H0.
      inversion H0; subst. clear H0.
      eapply context_invariance...
      intros x Hcontra.
      destruct (free_in_context _ _ S empty Hcontra) as [T' HT']...
      inversion HT'.
    SCase "x<>y".
    (* If [x <> y], then [Gamma y = Some S] and the substitution has no
       effect.  We can show that [Gamma |- y : S] by [T_Var]. *)
      apply T_Var... unfold extend in H0. rewrite neq_id in H0...
  Case "tabs".
    rename i into y. rename t into T11.
    (* If [t = tabs y T11 t0], then we know that
         [Gamma,x:U |- tabs y T11 t0 : T11->T12]
         [Gamma,x:U,y:T11 |- t0 : T12]
         [empty |- v : U]
       As our IH, we know that forall S Gamma,
         [Gamma,x:U |- t0 : S -> Gamma |- [x:=v]t0 S].

       We can calculate that
         [x:=v]t = tabs y T11 (if beq_id x y then t0 else [x:=v]t0)
       And we must show that [Gamma |- [x:=v]t : T11->T12].  We know
       we will do so using [T_Abs], so it remains to be shown that:
         [Gamma,y:T11 |- if beq_id x y then t0 else [x:=v]t0 : T12]
       We consider two cases: [x = y] and [x <> y].
    *)
    apply T_Abs...
    destruct (eq_id_dec x y).
    SCase "x=y".
    (* If [x = y], then the substitution has no effect.  Context
       invariance shows that [Gamma,y:U,y:T11] and [Gamma,y:T11] are
       equivalent.  Since the former context shows that [t0 : T12], so
       does the latter. *)
      eapply context_invariance...
      subst.
      intros x Hafi. unfold extend.
      destruct (eq_id_dec y x)...
    SCase "x<>y".
    (* If [x <> y], then the IH and context invariance allow us to show that
         [Gamma,x:U,y:T11 |- t0 : T12]       =>
         [Gamma,y:T11,x:U |- t0 : T12]       =>
         [Gamma,y:T11 |- [x:=v]t0 : T12] *)
      apply IHt. eapply context_invariance...
      intros z Hafi. unfold extend.
      destruct (eq_id_dec y z)...
      subst. rewrite neq_id...
  Case "trcons".
    apply T_RCons... inversion H7; subst; simpl...
Qed.

Theorem preservation : forall t t' T,
     empty |- t \in T  ->
     t ==> t'  ->
     empty |- t' \in T.
Proof with eauto.
  intros t t' T HT.
  (* Theorem: If [empty |- t : T] and [t ==> t'], then [empty |- t' : T]. *)
  remember (@empty ty) as Gamma. generalize dependent HeqGamma.
  generalize dependent t'.
  (* Proof: By induction on the given typing derivation.  Many cases are
     contradictory ([T_Var], [T_Abs]) or follow directly from the IH
     ([T_RCons]).  We show just the interesting ones. *)
  has_type_cases (induction HT) Case;
    intros t' HeqGamma HE; subst; inversion HE; subst...
  Case "T_App".
    (* If the last rule used was [T_App], then [t = t1 t2], and three rules
       could have been used to show [t ==> t']: [ST_App1], [ST_App2], and
       [ST_AppAbs]. In the first two cases, the result follows directly from
       the IH. *)
    inversion HE; subst...
    SCase "ST_AppAbs".
      (* For the third case, suppose
           [t1 = tabs x T11 t12]
         and
           [t2 = v2].  We must show that [empty |- [x:=v2]t12 : T2].
         We know by assumption that
             [empty |- tabs x T11 t12 : T1->T2]
         and by inversion
             [x:T1 |- t12 : T2]
         We have already proven that substitution_preserves_typing and
             [empty |- v2 : T1]
         by assumption, so we are done. *)
      apply substitution_preserves_typing with T1...
      inversion HT1...
  Case "T_Proj".
  (* If the last rule was [T_Proj], then [t = tproj t1 i].  Two rules
     could have caused [t ==> t']: [T_Proj1] and [T_ProjRcd].  The typing
     of [t'] follows from the IH in the former case, so we only
     consider [T_ProjRcd].

     Here we have that [t] is a record value.  Since rule T_Proj was
     used, we know [empty |- t \in Tr] and [Tlookup i Tr = Some
     Ti] for some [i] and [Tr].  We may therefore apply lemma
     [lookup_field_in_value] to find the record element this
     projection steps to. *)
    destruct (lookup_field_in_value _ _ _ _ H2 HT H)
      as [vi [Hget Htyp]].
    rewrite H4 in Hget. inversion Hget. subst...
  Case "T_RCons".
  (* If the last rule was [T_RCons], then [t = trcons i t tr] for
     some [i], [t] and [tr] such that [record_tm tr].  If the step is
     by [ST_Rcd_Head], the result is immediate by the IH.  If the step
     is by [ST_Rcd_Tail], [tr ==> tr2'] for some [tr2'] and we must also
     use lemma [step_preserves_record_tm] to show [record_tm tr2']. *)
    apply T_RCons... eapply step_preserves_record_tm...
Qed.
(** [] *)

End STLCExtendedRecords.


Set Implicit Arguments.
Set Maximal Implicit Insertion.
Set Contextual Implicit.

Require Import GHC.Base.
Require Import Fix.Functor.

From Coq Require Import
     Relation_Definitions
     RelationClasses
     FunctionalExtensionality
     ssrfun
.

(** Based on Section 2.2 of [Meta-theory à la Carte]. *)

(** * Core definitions *)

Section Fix.

(** * Definitions. *)

(* begin fix *)
Definition Alg (F : Set -> Set) (A : Set) : Set := F A -> A.
Definition Fix (F : Set -> Set) : Set := forall {A : Set}, Alg F A -> A.
Definition foldFix {F : Set -> Set } {A : Set}
           (alg : Alg F A) (f : Fix F) : A := f _ alg.
(* end fix *)

(** * In and out *)

(* begin in_out_F *)
Definition inF {F : Set -> Set} `{FunctorE F} (fexp : F (Fix F)) : Fix F :=
  fun _ alg => alg (fmapE (foldFix alg) fexp).

Definition outF {F : Set -> Set} `{FunctorE F} (exp : Fix F) : F (Fix F) :=
  foldFix (fmapE inF) exp.
(* end in_out_F *)

End Fix.

Section Fix1.

(** * Definitions. *)

(* Least fixpoint for program adverbs and effects. *)
(* begin fix1 *)
Definition Alg1 (F : (Set -> Set) -> Set -> Set) (E : Set -> Set) : Type :=
  forall {A : Set}, F E A -> E A.
Definition Fix1 (F : (Set -> Set) -> Set -> Set) (A : Set) :=
  forall (E : Set -> Set), Alg1 F E -> E A.
(* end fix1 *)

Variable F : (Set -> Set) -> Set -> Set.

Definition Alg1M (E : Set -> Set) : Set :=
  forall {E' : Set -> Set} {X : Set}, (E' X -> E X) -> F E' X -> E X.

Definition Fix1M (A : Set) := forall {E : Set -> Set}, Alg1M E -> E A.

Definition foldFix1 {E A} (alg : Alg1 F E) (f : Fix1 F A) : E A := f _ alg.

Definition foldFix1M {E A} (alg : Alg1M E) (f : Fix1M A) : E A := f _ alg.

Context `{Functor1 F}.

(** * In and out *)

Definition inF1 {A : Set} (fexp : F (Fix1 F) A) : Fix1 F A :=
  fun _ alg => alg _ (fmap1 (fun _ => foldFix1 alg) fexp).

Definition outF1 {A : Set} (exp : Fix1 F A) : F (Fix1 F) A :=
  foldFix1 (fun _ => fmap1 (fun _ => inF1)) exp.

End Fix1.

Section FixRel.

(** * Definitions. *)

(* Least fixpoint for equivalence relations of program adverbs and effects. *)
(* begin fixRel *)
Definition AlgRel {F : Set -> Set}
           (R : (forall (A : Set), relation (F A)) -> forall (A : Set), relation (F A))
           (K : forall (A : Set), relation (F A)) : forall (A : Set), relation (F A) :=
  fun A (a b : F A) => R K _ a b -> K _ a b.
Definition FixRel {F : Set -> Set}
           (R : (forall (A : Set), relation (F A)) -> forall (A : Set), relation (F A))
  : forall (A : Set), relation (F A) :=
  fun A (a b : F A) => forall (K : forall (A : Set), relation (F A)),
      (forall (A : Set) (a b : F A), AlgRel R K _ a b) -> K _ a b.
(* end fixRel *)

Variable F : Set -> Set.

Variable R : (forall (A : Set), relation (F A)) -> forall (A : Set), relation (F A).

Variable K : (forall (A : Set), relation (F A)).

Definition foldFixRel {A : Set}
           (alg : forall (A : Set) (a b : F A), AlgRel R (@K) _ a b) :
  forall (a b : F A), FixRel (@R) A a b -> K a b.
  intros a b f. apply f. apply alg.
Defined.

End FixRel.

Section FixRelInOut.

Variable F : Set -> Set.

Variable R : (forall (A : Set), relation (F A)) -> forall (A : Set), relation (F A).

Context `{FunctorRel F (@R)}.

(** This one feels odd. *)
Theorem inFRel {A : Set} (a b : F A) (frel : R (FixRel (@R)) a b) : FixRel R _ a b.
  intros K alg. apply alg.
  eapply fmapRel; [| exact frel].
  intros ? x y f.
  exact (foldFixRel alg f).
Defined.

Theorem outFRel {A : Set} (a b : F A) (frel : FixRel R _ a b) : R (FixRel R) a b.
  refine (foldFixRel _ frel).
  intros ? x y r.
  eapply fmapRel; [|exact r].
  intros. eapply inFRel. assumption.
Defined.
End FixRelInOut.

(** * Equivalence *)

Section Equivalence.

  Variable F : (Set -> Set) -> Set -> Set.
  Variable A : Set.

  Set Implicit Arguments.

  Definition Fix_eq (a b : Fix1 F A) : Prop := forall (E : Set -> Set), a E =1 b E.

  Instance Reflexive_Fix_eq : Reflexive Fix_eq.
  constructor.
  Defined.

  Instance Symmetric_Fix_eq : Symmetric Fix_eq.
  intros x y. cbv. intros. symmetry. auto.
  Defined.

  Instance Transitive_Fix_eq : Transitive Fix_eq.
  intros x y z. cbv. intros. etransitivity; [apply H | auto].
  Defined.

  Instance Equivalence_Fix_eq : Equivalence Fix_eq.
  constructor; typeclasses eauto.
  Defined.
End Equivalence.

Notation "f =f g" := (Fix_eq f g) (at level 70, g at next level).


Require Import Platform.AutoSep Coq.omega.Omega.

Lemma S_le_lt : forall a b c, (a + S b <= c -> a < c)%nat.
  intros; omega.
Qed.
Lemma lt_goodSize'' : forall a b, (a < b)%nat -> goodSize b -> natToW a < natToW b.
  intros; apply lt_goodSize; auto; eapply goodSize_weaken; eauto.
Qed.
Lemma max_le_1 : forall b d1 d2 n, (b + S (max d1 d2) <= n -> b + d1 <= n)%nat.
  intros.
  eapply (Le.le_trans _ _ _ _ H).
  Grab Existential Variables.
  eapply Plus.plus_le_compat_l.
  eapply le_S.
  eapply Max.le_max_l.
Qed.
Lemma max_le_2 : forall b d1 d2 n, (b + S (max d1 d2) <= n -> S b + d2 <= n)%nat.
  intros.
  simpl.
  eapply (Le.le_trans _ _ _ _ H).
  Grab Existential Variables.
  eapply Lt.lt_le_S.
  eapply Plus.plus_lt_compat_l.
  eapply Lt.le_lt_n_Sm.
  eapply Max.le_max_r.
Qed.
Lemma selN_updN : forall ls n v, (n < length ls)%nat -> selN (updN ls n v) n = v.
  induction ls; induction n; simpl; intuition.
Qed.
Lemma sel_upd : forall n ls v, (n < length ls)%nat -> goodSize (length ls) -> Array.sel (Array.upd ls (natToW n) v) (natToW n) = v.
  intros; rewrite sel_selN; try (eapply goodSize_weaken; eauto).
  rewrite upd_updN; try (eapply goodSize_weaken; eauto).
  apply selN_updN; auto.
Qed.
Lemma sel_firstn' : forall ls1 ls2 n, (n < length ls1 -> length ls1 = length ls2 -> firstn (S n) ls1 = firstn (S n) ls2 -> selN ls1 n = selN ls2 n)%nat.
  induction ls1; induction ls2; induction n; simpl; intuition.
  apply IHls1; simpl in *; intuition.
Qed.
Lemma sel_firstn : forall ls1 ls2 n, (n < length ls1 -> length ls1 = length ls2 -> firstn (S n) ls1 = firstn (S n) ls2 -> goodSize (length ls1) -> Array.sel ls1 (natToW n) = Array.sel ls2 (natToW n))%nat.
  intros; repeat rewrite sel_selN; try (eapply goodSize_weaken; eauto).
  eapply sel_firstn'; eauto.
Qed.
Lemma sel_upd_firstn : forall n ls1 ls2 v, (n < length ls1)%nat -> length ls1 = length ls2 -> goodSize (length ls1) -> firstn (S n) ls1 = firstn (S n) (Array.upd ls2 (natToW n) v) -> Array.sel ls1 (natToW n) = v.
  intros.
  erewrite sel_firstn.
  Focus 4.
  eauto.
  apply sel_upd.
  congruence.
  congruence.
  omega.
  rewrite upd_length.
  omega.
  auto.
Qed.
Lemma firstn_S : forall A n (ls1 ls2 : list A), (n < length ls1)%nat -> length ls1 = length ls2 -> firstn (S n) ls1 = firstn (S n) ls2 -> firstn n ls1 = firstn n ls2.
  intros.
  rewrite <- removelast_firstn; try congruence.
  rewrite H1.
  apply removelast_firstn; congruence.
Qed.
Lemma upd_firstn : forall ls n v, firstn n (updN ls n v) = firstn n ls.
  induction ls; induction n; simpl; intuition.
Qed.
Hint Immediate upd_firstn.
Lemma firstn_S_upd : forall n ls1 ls2 v, (n < length ls2)%nat -> length ls1 = length ls2 -> goodSize (length ls1) -> firstn (S n) ls1 = firstn (S n) (Array.upd ls2 (natToW n) v) -> firstn n ls1 = firstn n ls2.
  clear.
  intros.
  apply firstn_S in H2; try rewrite upd_length; try congruence.
  rewrite H2.
  rewrite upd_updN; try (eapply goodSize_weaken; eauto).
  auto.
Qed.

Lemma evalInstrs_cons_fwd : forall i is stn st st_new,
  evalInstrs stn st (i :: is) = Some st_new -> exists st',
    evalInstr stn st i = Some st' /\ evalInstrs stn st' is = Some st_new.
  Transparent evalInstrs.
  simpl; intros.
  destruct (evalInstr stn st i); try discriminate.
  eauto.
  Opaque evalInstrs.
Qed.

Require Import Platform.Wrap.
Import DefineStructured.

Lemma evalInstrs_cons_fwd_None : forall (stn : settings) i (is1 : list instr) (st : state),
  evalInstrs stn st (i :: is1) = None ->
  evalInstr stn st i = None \/
  (exists st' : state,
    evalInstr stn st i = Some st' /\ evalInstrs stn st' is1 = None).
  intros; rewrite evalInstr_evalInstrs in *.
  apply evalInstrs_app_fwd_None. auto.
Qed.

Section Lemmas.

  Lemma sum_S: forall a b, a + S b = S a + b.
    intros; omega.
  Qed.

  Hint Rewrite sum_S : arith.
  Hint Resolve S_le_lt.
  Hint Resolve sel_upd_firstn.
  Hint Resolve firstn_S_upd.
  Hint Resolve Max.le_max_l Max.le_max_r.

  Lemma le_plus_lt : forall a b c, (a + c <= b -> 0 < c -> a < b)%nat.
    intros; omega.
  Qed.

  Lemma lt_max_l : forall l n m, (l < n -> l < max n m)%nat.
    intros; assert (n <= max n m)%nat by eauto; omega.
  Qed.

  Lemma lt_max_r : forall l n m, (l < m -> l < max n m)%nat.
    intros; assert (m <= max n m)%nat by eauto; omega.
  Qed.

  Hint Resolve le_plus_lt lt_max_l lt_max_r.

  Lemma plus_le : forall a b c d, (a + b <= c -> d <= b -> a + d <= c)%nat.
    intros; omega.
  Qed.

  Hint Resolve plus_le.

  Lemma plus_lt : forall a b c d, (a + b <= c -> d < b -> a + d < c)%nat.
    intros; omega.
  Qed.

  Hint Resolve lt_le_S plus_lt.

  Lemma lt_gt_flip : forall a b, (a < b -> b > a)%nat.
    intros; omega.
  Qed.

  Lemma le_ge_flip : forall a b, (a <= b -> b >= a)%nat.
    intros; omega.
  Qed.

  Lemma plus_max_l: forall a b c, (a + max b (S c) >= a + b)%nat.
    intros; apply le_ge_flip; eauto.
  Qed.

  Lemma S_plus_max_r: forall a b c, (a + max b (S c) >= S a + c)%nat.
    intros; apply le_ge_flip; simpl; eauto.
  Qed.

  Lemma S_max_simpl: forall n a b, (n + max a (S b) > n)%nat.
      induction n; induction a; induction b; simpl; intuition.
  Qed.

  Lemma plus_max_tran_r: forall a b c n, (n < c -> b + max a (S c) > n + S b)%nat.
    intros; replace (n + S b) with (b + S n) by omega; apply lt_gt_flip; simpl; eauto.
  Qed.

End Lemmas.


Require Import XR_Rmax.
Require Import XR_Rle_dec.
Require Import XR_Rle_antisym.
Require Import XR_Rnot_le_lt.
Require Import XR_Rle_trans.

Local Open Scope R_scope.

Lemma Rmax_assoc : forall a b c, Rmax a (Rmax b c) = Rmax (Rmax a b) c.
Proof.
  intros x y z.
  unfold Rmax.
  destruct (Rle_dec y z)  as [ hyz | hyz ] ;
  destruct (Rle_dec x y) as [ hxy | hxy ].
  {
    destruct (Rle_dec x z) as [ hxz | hxz ] ;
    destruct (Rle_dec y z) as [ hyz' | hyz' ].
    { reflexivity. }
    {
      apply Rle_antisym.
      {
        left.
        apply Rnot_le_lt.
        exact hyz'.
      }
      { exact hyz. }
    }
    {
      apply Rle_antisym.
      {
        apply Rle_trans with y.
        { exact hxy. }
        { exact hyz. }
      }
      {
        left.
        apply Rnot_le_lt.
        exact hxz.
      }
    }
    {
      apply Rle_antisym.
      { exact hxy. }
      {
        apply Rle_trans with z.
        { exact hyz. }
        {
          left.
          apply Rnot_le_lt.
          exact hxz.
        }
      }
    }
  }
  { reflexivity. }
  {
    destruct (Rle_dec y z) as [ hyz' | hyz' ].
    {
      apply Rle_antisym.
      { exact hyz'. }
      {
        left.
        apply Rnot_le_lt.
        exact hyz.
      }
    }
    { reflexivity. }
  }
  {
  destruct (Rle_dec x z) as [ hxz | hxz ].
  {
    apply Rle_antisym.
    { exact hxz. }
    {
      apply Rle_trans with y.
      {
        left.
        apply Rnot_le_lt.
        exact hyz.
      }
      {
        left.
        apply Rnot_le_lt.
        exact hxy.
      }
    }
  }
  { reflexivity. }
  }
Qed.


(** * Binom: Binomial Queues *)

(** Implementation and correctness proof of fast mergeable priority queues
   using binomial queues.

  Operation [empty] is constant time,  [insert], [delete_max], and [merge]
  are logN time.  (Well, except that comparisons on [nat] take linear time.
  Read the [Extract] chapter to see what can be done about that.) *)

(* ################################################################# *)
(** * Required Reading
  Binomial Queues {https://www.cs.princeton.edu/~appel/Binom.pdf}
  by Andrew W. Appel, 2016.

  Binomial Queues {https://www.cs.princeton.edu/~appel/BQ.pdf}
  Section 9.7 of _Algorithms 3rd Edition in Java, Parts 1-4:
    Fundamentals, Data Structures, Sorting, and Searching_,
  by Robert Sedgewick.  Addison-Wesley, 2002.
*)

(* ################################################################# *)
(** * The Program *)

From Coq Require Import Strings.String. (* for manual grading *)
From VFA Require Import Perm.
From VFA Require Import Priqueue.

Module BinomQueue <: PRIQUEUE.

Definition key := nat.

Inductive tree : Type :=
|  Node: key -> tree -> tree -> tree
|  Leaf : tree.

(** A priority queue (using the binomial queues data structure) is a
   list of trees.  The [i]'th element of the list is either [Leaf] or
   it is a power-of-2-heap with exactly [2^i] nodes.

  This program will make sense to you if you've read the Sedgewick
  reading; otherwise it is rather mysterious.
*)

Definition priqueue := list tree.

Definition empty : priqueue := nil.

Definition smash (t u:  tree) : tree :=
  match t , u with
  |  Node x t1 Leaf, Node y u1 Leaf =>
                   if  x >? y then Node x (Node y u1 t1) Leaf
                                else Node y (Node x t1 u1) Leaf
  | _ , _ => Leaf  (* arbitrary bogus tree *)
  end.

Fixpoint carry (q: list tree) (t: tree) : list tree :=
  match q, t with
  | nil, Leaf        => nil
  | nil, _            => t :: nil
  | Leaf :: q', _  => t :: q'
  | u :: q', Leaf  => u :: q'
  | u :: q', _       => Leaf :: carry q' (smash t u)
 end.

Definition insert (x: key) (q: priqueue) : priqueue :=
     carry q (Node x Leaf Leaf).

Eval compute in fold_left (fun x q =>insert q x) [3;1;4;1;5;9;2;3;5] empty.
(**
    = [Node 5 Leaf Leaf;
       Leaf;
       Leaf;
       Node 9
          (Node 4 (Node 3 (Node 1 Leaf Leaf) (Node 1 Leaf Leaf))
             (Node 3 (Node 2 Leaf Leaf) (Node 5 Leaf Leaf)))
          Leaf]
     : priqueue
*)

Fixpoint join (p q: priqueue) (c: tree) : priqueue :=
  match p, q, c with
    [], _ , _            => carry q c
  | _, [], _             => carry p c
  | Leaf::p', Leaf::q', _              => c :: join p' q' Leaf
  | Leaf::p', q1::q', Leaf            => q1 :: join p' q' Leaf
  | Leaf::p', q1::q', Node _ _ _  => Leaf :: join p' q' (smash c q1)
  | p1::p', Leaf::q', Leaf            => p1 :: join p' q' Leaf
  | p1::p', Leaf::q',Node _ _ _   => Leaf :: join p' q' (smash c p1)
  | p1::p', q1::q', _                   => c :: join p' q' (smash p1 q1)
 end.

Fixpoint unzip (t: tree) (cont: priqueue -> priqueue) : priqueue :=
  match t with
  |  Node x t1 t2   => unzip t2 (fun q => Node x t1 Leaf  :: cont q)
  | Leaf => cont nil
  end.

Definition heap_delete_max (t: tree) : priqueue :=
  match t with
    Node x t1 Leaf  => unzip t1 (fun u => u)
  | _ => nil   (* bogus value for ill-formed or empty trees *)
  end.

Fixpoint find_max' (current: key) (q: priqueue) : key :=
  match q with
  |  []         => current
  | Leaf::q' => find_max' current q'
  | Node x _ _ :: q' => find_max' (if x >? current then x else current) q'
  end.

Fixpoint find_max (q: priqueue) : option key :=
  match q with
  | [] => None
  | Leaf::q' => find_max q'
  | Node x _ _ :: q' => Some (find_max' x q')
 end.

Fixpoint delete_max_aux (m: key) (p: priqueue) : priqueue * priqueue :=
  match p with
  | Leaf :: p'   => let (j,k) := delete_max_aux m p'  in (Leaf::j, k)
  | Node x t1 Leaf :: p' =>
       if m >? x
       then (let (j,k) := delete_max_aux m p'
             in (Node x t1 Leaf::j,k))
       else (Leaf::p', heap_delete_max (Node x t1 Leaf))
  | _ => (nil, nil) (* Bogus value *)
  end.

Definition delete_max (q: priqueue) : option (key * priqueue) :=
  match find_max q with
  | None => None
  | Some  m => let (p',q') := delete_max_aux m q
                            in Some (m, join p' q' Leaf)
  end.

Definition merge (p q: priqueue) := join p q Leaf.

(* ################################################################# *)
(** * Characterization Predicates *)

(** [t] is a complete binary tree of depth [n], with every key <= [m] *)

Fixpoint pow2heap' (n: nat) (m: key) (t: tree) :=
 match n, m, t with
    0, m, Leaf       => True
  | 0, m, Node _ _ _  => False
  | S _, m,Leaf    => False
  | S n', m, Node k l r  =>
       m >= k /\ pow2heap' n' k l /\ pow2heap' n' m r
 end.

(** [t] is a power-of-2 heap of depth [n] *)

Definition pow2heap (n: nat) (t: tree) :=
  match t with
    Node m t1 Leaf => pow2heap' n m t1
  | _ => False
  end.

(** [l] is the [i]th tail of a binomial heap *)

Fixpoint priq'  (i: nat) (l: list tree) : Prop :=
   match l with
  | t :: l' => (t=Leaf \/ pow2heap i t) /\ priq' (S i) l'
  | nil => True
 end.

(** [q] is a binomial heap *)

Definition priq (q: priqueue) : Prop := priq' 0 q.

(* ################################################################# *)
(** * Proof of Algorithm Correctness *)

(* ================================================================= *)
(** ** Various Functions Preserve the Representation Invariant *)

(** ...that is, the [priq] property, or the closely related property [pow2heap].
*)

(** **** Exercise: 1 star, standard (empty_priq)  *)
Theorem empty_priq: priq empty.
(* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 2 stars, standard (smash_valid) *)
Theorem smash_valid:
       forall n t u, pow2heap n t -> pow2heap n u -> pow2heap (S n) (smash t u).
(* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 3 stars, standard (carry_valid) *)
Theorem carry_valid:
           forall n q,  priq' n q ->
           forall t, (t=Leaf \/ pow2heap n t) -> priq' n (carry q t).
(* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 2 stars, standard, optional (insert_valid) *)
Theorem insert_priq: forall x q, priq q -> priq (insert x q).
(* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 3 stars, standard, optional (join_valid) *)
(* This proof is rather long, but each step is reasonably straightforward.
    There's just one [induction] to do, right at the beginning. *)
Theorem join_valid: forall p q c n, priq' n p -> priq' n q -> (c=Leaf \/ pow2heap n c) -> priq' n (join p q c).
(* FILL IN HERE *) Admitted.
(** [] *)

Theorem merge_priq:  forall p q, priq p -> priq q -> priq (merge p q).
Proof.
 intros. unfold merge. apply join_valid; auto.
Qed.

(** **** Exercise: 5 stars, standard, optional (delete_max_Some_priq) *)
Theorem delete_max_Some_priq:
      forall p q k, priq p -> delete_max p = Some(k,q) -> priq q.
(* FILL IN HERE *) Admitted.
(** [] *)

(* ================================================================= *)
(** ** The Abstraction Relation *)

(** [tree_elems t l]    means that the keys in t are the same as the
   elements of l (with repetition) *)

Inductive tree_elems: tree -> list key -> Prop :=
| tree_elems_leaf: tree_elems Leaf nil
| tree_elems_node:  forall bl br v tl tr b,
           tree_elems tl bl ->
           tree_elems tr br ->
           Permutation b (v::bl++br) ->
           tree_elems (Node v tl tr) b.

(** **** Exercise: 3 stars, standard (priqueue_elems)

    Make an inductive definition, similar to [tree_elems], to relate
  a priority queue  "l"  to a list of all its elements.

  As you can see in the definition of [tree_elems],  a [tree] relates to
  _any_ permutation of its keys, not just a single permutation.
  You should make your [priqueue_elems] relation behave similarly,
  using (basically) the same technique as in [tree_elems].
*)

Inductive priqueue_elems: list tree -> list key -> Prop :=
             (* FILL IN HERE *)
.
(* Do not modify the following line: *)
Definition manual_grade_for_priqueue_elems : option (nat*string) := None.
(** [] *)

Definition Abs (p: priqueue) (al: list key) := priqueue_elems p al.

(* ================================================================= *)
(** ** Sanity Checks on the Abstraction Relation *)

(** **** Exercise: 2 stars, standard (tree_elems_ext)

    Extensionality theorem for the tree_elems relation *)

Theorem tree_elems_ext: forall t e1 e2,
  Permutation e1 e2 -> tree_elems t e1 -> tree_elems t e2.
(* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 2 stars, standard (tree_perm) *)
Theorem tree_perm: forall t e1 e2,
  tree_elems t e1 -> tree_elems t e2 -> Permutation e1 e2.
(* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 2 stars, standard (priqueue_elems_ext)

    To prove [priqueue_elems_ext], you should almost be able to cut-and-paste the
   proof of [tree_elems_ext], with just a few edits.  *)

Theorem priqueue_elems_ext: forall q e1 e2,
  Permutation e1 e2 -> priqueue_elems q e1 -> priqueue_elems q e2.
(* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 2 stars, standard (abs_perm) *)
Theorem abs_perm: forall p al bl,
   priq p -> Abs p al -> Abs p bl -> Permutation al bl.
Proof.
(* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 2 stars, standard (can_relate) *)
Lemma tree_can_relate: forall t, exists al, tree_elems t al.
Proof.
(* FILL IN HERE *) Admitted.

Theorem can_relate:  forall p, priq p -> exists al, Abs p al.
Proof.
(* FILL IN HERE *) Admitted.
(** [] *)

(* ================================================================= *)
(** ** Various Functions Preserve the Abstraction Relation *)
(** **** Exercise: 1 star, standard (empty_relate) *)
Theorem empty_relate:  Abs empty nil.
Proof.
(* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 3 stars, standard (smash_elems)

     Warning:  This proof is rather long. *)

Theorem smash_elems: forall n t u bt bu,
                     pow2heap n t -> pow2heap n u ->
                     tree_elems t bt -> tree_elems u bu ->
                     tree_elems (smash t u) (bt ++ bu).
(* FILL IN HERE *) Admitted.
(** [] *)

(* ================================================================= *)
(** ** Optional Exercises *)

(**  Some of these proofs are quite long, but they're not especially tricky. *)

(** **** Exercise: 4 stars, standard, optional (carry_elems) *)
Theorem carry_elems:
      forall n q,  priq' n q ->
      forall t, (t=Leaf \/ pow2heap n t) ->
      forall eq et, priqueue_elems q eq ->
                          tree_elems t et ->
                          priqueue_elems (carry q t) (eq++et).
(* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 2 stars, standard, optional (insert_elems) *)
Theorem insert_relate:
        forall p al k, priq p -> Abs p al -> Abs (insert k p) (k::al).
(* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 4 stars, standard, optional (join_elems) *)
Theorem join_elems:
                forall p q c n,
                      priq' n p ->
                      priq' n q ->
                      (c=Leaf \/ pow2heap n c) ->
                  forall pe qe ce,
                             priqueue_elems p pe ->
                             priqueue_elems q qe ->
                             tree_elems c ce ->
                              priqueue_elems (join p q c) (ce++pe++qe).
(* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 2 stars, standard, optional (merge_relate) *)
Theorem merge_relate:
    forall p q pl ql al,
       priq p -> priq q ->
       Abs p pl -> Abs q ql -> Abs (merge p q) al ->
       Permutation al (pl++ql).
Proof.
(* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 5 stars, standard, optional (delete_max_None_relate) *)
Theorem delete_max_None_relate:
        forall p, priq p -> (Abs p nil <-> delete_max p = None).
(* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 5 stars, standard, optional (delete_max_Some_relate) *)
Theorem delete_max_Some_relate:
  forall (p q: priqueue) k (pl ql: list key), priq p ->
   Abs p pl ->
   delete_max p = Some (k,q) ->
   Abs q ql ->
   Permutation pl (k::ql) /\ Forall (ge k) ql.
(* FILL IN HERE *) Admitted.
(** [] *)

(** With the following line, we're done!  We have demonstrated that
  Binomial Queues are a correct implementation of mergeable
  priority queues.  That is, we have exhibited a [Module BinomQueue]
  that satisfies the [Module Type PRIQUEUE]. *)

End BinomQueue.

(* ################################################################# *)
(** * Measurement. *)

(** **** Exercise: 5 stars, standard, optional (binom_measurement)

    Adapt the program (but not necessarily the proof) to use Ocaml integers
  as keys, in the style shown in [Extract].   Write an ML program to
  exercise it with random inputs.  Compare the runtime to the implementation
  from [Priqueue], also adapted for Ocaml integers.
*)
(** [] *)

(* 2021-08-11 15:15 *)