(* Author: Harley Eades
 *
 * Coq Version: 8.3pl3
 *
 * This file contains results related to substitution (subst_t). *)
Require Import Arith.
Require Import List.
Require Import F.
Require Import names.

Lemma trm_app_eq : forall t1 t2 t'1 t'2,
  t1 = t'1 ->
  t2 = t'2 -> trm_app t1 t2 = trm_app t'1 t'2.
Proof.
  intros; subst; eauto.
Qed.

Lemma subst_free_t : forall (x:nat) (u t:trm),
  ~ (free_in_t x t) -> subst_t u x t = t.
Proof.
  induction t; intros; simpl in *; eauto.
  clarify_compares_natc; subst; simpl in *; eauto.
  unfold free_in_t in H. contradict H; simpl; eauto.

  rewrite -> IHt; auto.
  rewrite -> IHt; auto.

  unfold free_in_t in H.
  rewrite -> IHt1; unfold free_in_t; eauto.
  rewrite -> IHt2; unfold free_in_t; eauto.

  rewrite -> IHt; auto.
Qed.

Lemma subst_open_t : forall t u w x,
  lc u ->
  subst_t u x (open_t 0 w t) = open_t 0 (subst_t u x w) (subst_t u x t).
Proof.
  intros. generalize 0. induction t; intros; simpl; f_equal; auto;
  clarify_compares_natc; subst; simpl; eauto with naming_open.
Qed.
Hint Resolve subst_open_t : naming_open.

Lemma subst_id : forall t' t x,
  ~ In x (FV_t t') -> subst_t t x t' = t'.
Proof.
  induction t'; intros; simpl; eauto.
  clarify_compares_natc; auto.
  subst. contradict H. simpl. eauto.
  rewrite -> IHt'; auto.

  rewrite -> IHt'; auto.

  rewrite -> IHt'1; eauto.
  rewrite -> IHt'2; eauto.

  rewrite -> IHt'; auto.
Qed.

Lemma subst_open_var_t : forall (y x:nat) (u t:trm),
  lc u ->
  (trm_fvar x) <> (trm_fvar y) ->
  subst_t u x (open_t 0 (trm_fvar y) t) = open_t 0 (trm_fvar y) (subst_t u x t).
Proof.
  intros. rewrite -> subst_open_t; auto.
  rewrite -> subst_id; auto.
  simpl. unfold not; intros. destruct H1; auto.
Qed.

Lemma subst_id' : forall t x, subst_t (trm_fvar x) x t = t.
Proof.
  induction t; intros; simpl; eauto.

  clarify_compares_natc; subst; auto.

  rewrite -> IHt. auto.
  rewrite -> IHt; auto.
  rewrite -> IHt1. rewrite -> IHt2. auto.
  rewrite -> IHt; auto.
Qed.

Lemma close_open_alpha_neq : forall t,
  lc t ->
  forall n x y,
    y <> x ->
    open_t n (trm_fvar y) (close_t n x t) = subst_t (trm_fvar y) x t.
Proof.
  intros t H. induction H; intros; simpl;
  try apply_ccn; auto.

  apply trm_lam_eq_lc with (L:=L++x::y::nil); intros.
  rewrite open_comm at 1; destruct_nin; simpl in *; auto.
  rewrite <- close_id with (t:=trm_fvar y0) (n:=S n) (x:=x) at 1; [ | simpl; omega].
  rewrite <- close_open_comm; [| auto | simpl; omega].
  rewrite -> H1; auto.
  rewrite -> subst_open_t; auto.
  rewrite -> subst_id at 1; auto; simpl; omega.

  apply f_equal; auto.

  rewrite -> IHlc1; auto.
  rewrite -> IHlc2; auto.

  rewrite -> IHlc; auto.
Qed.

Lemma close_open_alpha : forall t,
  lc t ->
  forall n y x, open_t n (trm_fvar y) (close_t n x t) = subst_t (trm_fvar y) x t.
Proof.
  intros. case_split_names y x.
  rewrite -> subst_id'. apply close_open_id; auto.

  apply close_open_alpha_neq; auto with arith.
  apply close_open_alpha_neq; auto with arith.
Qed.

Lemma close_alpha_conv : forall t y z,
  ~ In y (FV_t t) -> close_t 0 z t = close_t 0 y (subst_t (trm_fvar y) z t).
Proof.
  intros t y z. generalize t 0 y z. clear t y z.
  induction t; intros; simpl;
    try apply_ccn; auto; try smash_contra.

  rewrite -> IHt with (y:=y); auto.

  rewrite -> IHt with (y:=y); auto.

  rewrite -> IHt1 with (y:=y); eauto.
  rewrite -> IHt2 with (y:=y); eauto.

  rewrite -> IHt with (y:=y); auto.
Qed.

Lemma app_eq_subst : forall t1 t2 x,
  ~ In x (FV_t t1++FV_t t2) ->
  trm_app t1 t2 = subst_t t1 x (trm_app (trm_fvar x) t2).
Proof.
  intros. simpl.
  rewrite -> nat_compare_eq_eq.
  rewrite -> subst_free_t; auto.
Qed.

Lemma subst_open_eq : forall t t' L,
  let y := pick_fresh (L++FV_t t) in
    open_t 0 t' t = subst_t t' y (open_t 0 (trm_fvar y) t).
Proof.
  intros t t' L y. unfold y. clear y. generalize t t' L 0.
  clear t t' L.
  induction t; intros; simpl; eauto; try apply_ccn; eauto.

  contradict Heqc; eauto.

  rewrite -> IHt with (L:=L); auto.

  rewrite -> IHt with (L:=L); auto.

  rewrite -> IHt1 with (L:=L++FV_t t2).
  rewrite -> IHt2 with (L:=L++FV_t t1).

  apply trm_app_eq.

  rewrite -> pick_fresh_eq'. repeat rewrite <- app_assoc. auto.
  repeat rewrite <- app_assoc. auto.

  rewrite -> IHt with (L:=L); auto.
Qed.

Lemma subst_open_t_gen : forall t u w x n,
  lc u ->
  subst_t u x (open_t n w t) = open_t n (subst_t u x w) (subst_t u x t).
Proof.
  induction t; intros; simpl; f_equal; auto;
    clarify_compares_natc; subst; simpl; eauto with naming_open.
Qed.

Lemma subst_open_eq_gen : forall t t' y n,
  ~ In y (FV_t t) ->
  open_t n t' t = subst_t t' y (open_t n (trm_fvar y) t).
Proof.
  induction t; intros; simpl; eauto; try apply_ccn.

  rewrite -> IHt with (y:=y); auto; simpl in H; auto.

  apply f_equal; auto.

  simpl FV_t in *. destruct_nin.
  rewrite -> IHt1 with (y:=y); auto.
  rewrite -> IHt2 with (y:=y); auto.

  rewrite -> IHt with (y:=y); auto.
Qed.

Lemma open_alpha_subst : forall t' t x y n,
  ~ In x (FV_t t') ->
  ~ In y (FV_t t') ->
  open_t n (trm_fvar x) t' = t ->
  open_t n (trm_fvar y) t' = (subst_t (trm_fvar y) x t).
Proof.
  induction t'; intros; simpl; try apply_ccn; try (simpl; apply_ccn).

  simpl in H1; subst; simpl; apply_ccn.

  simpl in H1; subst.  simpl.
  rewrite <- subst_open_eq_gen with (y:=x); auto.

  simpl in *; subst; simpl; apply f_equal; auto.

  apply open_app in H1. subst. simpl in *. destruct_nin.
  rewrite <- IHt'1 with (t:=open_t n (trm_fvar x) t'1) (x:=x) (n:=n); auto.
  rewrite <- IHt'2 with (t:=open_t n (trm_fvar x) t'2) (x:=x) (n:=n); auto.

  simpl in *. invert_typing H1; simpl.
  Lemma trm_tapp_eq : forall t t' T T',
    t = t' ->
    T = T' ->
    trm_tapp t T = trm_tapp t' T'.
  Proof.
    intros; subst; auto.
  Qed.
  apply trm_tapp_eq; auto.

  simpl in H1; subst; auto.
Qed.

Lemma open_alpha_eq_subst : forall t t' z y,
  ~ In z (FV_t t) ->
  ~ In y (FV_t t) ->
  open_t 0 (trm_fvar z) t = t' ->
  open_t 0 (trm_fvar y) t = subst_t (trm_fvar y) z t'.
Proof.
  induction t; intros.
  case_split_names n 0; simpl in *; apply_ccn; simpl; auto.
  simpl in *; subst; simpl; apply_ccn.

  simpl in *. subst. simpl.

  rewrite -> subst_open_t_gen; auto.
  simpl. rewrite -> nat_compare_eq_eq. rewrite -> subst_id; intuition eauto.

  simpl in *; subst; simpl; apply f_equal; auto.

  simpl in *; apply open_app in H1; subst; simpl.
  rewrite -> IHt1 with (t':=open_t 0 (trm_fvar z) t1) (z:=z); auto.
  rewrite -> IHt2 with (t':=open_t 0 (trm_fvar z) t2) (z:=z); auto.

  simpl in *; subst; simpl.
  apply trm_tapp_eq; auto.

  simpl in *; subst; intuition.
Qed.

Lemma subst_close_comm : forall t x y z n,
  x <> z ->
  x <> y ->
  close_t n x (subst_t (trm_fvar y) z t) = subst_t (trm_fvar y) z (close_t n x t).
Proof.
  induction t; intros; simpl; auto.

  apply_ccn.

  rewrite -> IHt; auto.

  rewrite -> IHt; auto.

  rewrite -> IHt1; auto. rewrite IHt2; auto.

  rewrite -> IHt; auto.
Qed.

Lemma el_nin_fv_subst : forall t x y z,
  x <> y ->
  x <> z ->
  ~ In x (FV_t (subst_t (trm_fvar y) z t)) ->
  ~ In x (FV_t t).
Proof.
  induction t; intros. simpl in *. auto.

  simpl in H1. remember (nat_compare z n). destruct c; auto. apply eq_sym in Heqc.
  apply nat_compare_eq in Heqc. subst. intuition. simpl in H2. destruct H2; eauto.

  simpl. apply IHt with (y:=y) (z:=z); auto.
  simpl in *. apply IHt with (y:=y) (z:=z); auto.

  simpl. apply el_nin_conj_2. split.
  apply IHt1 with (y:=y) (z:=z); auto.
  simpl in H1. destruct_nin*.
  apply IHt2 with (y:=y) (z:=z); auto.
  simpl in H1. destruct_nin*.

  simpl in *. apply IHt with (y:=y) (z:=z); auto.

  simpl in H1. auto.
Qed.

Lemma subst_lc : forall t',
  lc t' ->
  forall x t,
    lc t ->
    lc (subst_t t x t').
Proof.
  induction 1; intros; simpl; eauto.

  apply_ccn.

  apply lc_lam with (L:=x::L++FV_t t0); intros; auto.
  rewrite <- subst_id with (t':=trm_fvar x0) (t:=t0) (x:=x).
  rewrite <- subst_open_t; auto. eauto.
  destruct_nin. simpl in *. unfold not; intros. destruct H6; auto; subst.
Qed.

Lemma open_eq_subst : forall t t1 t2 x y n,
  ~ In y (x::FV_t t) ->
  ~ In x (FV_t t) ->
  t1 = open_t n (trm_fvar x) t ->
  t2 = open_t n (trm_fvar y) t ->
  t2 = subst_t (trm_fvar y) x t1.
Proof.
  induction t; intros.
  simpl in H1; simpl in H2.
  case_split_names n n0; simpl. rewrite -> nat_compare_eq_eq; auto.
  subst; simpl; auto. subst; simpl; auto.
  subst; simpl. simpl FV_t in *.
  apply_ccn.

  subst; simpl;
    rewrite -> IHt with
      (t1:=open_t (S n) (trm_fvar x) t)
      (t2:=open_t (S n) (trm_fvar y) t)
      (x:=x)
      (y:=y)
      (n:=S n); auto.

  subst; simpl;
    rewrite -> IHt with
      (t1:=open_t n (trm_fvar x) t)
      (t2:=open_t n (trm_fvar y) t)
      (x:=x)
      (y:=y)
      (n:=n); auto.

  subst; simpl; simpl FV_t in *; destruct_nin.
  rewrite -> IHt1 with
    (t2:=open_t n (trm_fvar x) t1)
    (t3:=open_t n (trm_fvar y) t1)
    (x:=x)
    (y:=y)
    (n:=n); auto.
  rewrite -> IHt2 with
    (t1:=open_t n (trm_fvar x) t2)
    (t3:=open_t n (trm_fvar y) t2)
    (x:=x)
    (y:=y)
    (n:=n); auto.
  rewrite list_cons_eq_app; apply el_nin_conj_2; split; auto.
  rewrite list_cons_eq_app; apply el_nin_conj_2; split; auto.

  simpl in *; subst.
  simpl.
  rewrite -> IHt with
    (t1:=open_t n (trm_fvar x) t)
    (t2:=open_t n (trm_fvar y) t)
    (x:=x)
    (y:=y)
    (n:=n); auto.

  subst; simpl; auto.
Qed.

Lemma subst_close_comm_gen : forall t t' x z n,
  x <> z ->
  ~ In x (FV_t t') ->
  close_t n x (subst_t t' z t) = subst_t t' z (close_t n x t).
Proof.
  induction t; intros; eauto; simpl;
    try (apply_ccn; [ apply close_id; auto | apply close_id; auto]).

  rewrite -> IHt; auto.
  rewrite -> IHt; auto.
  rewrite -> IHt1; auto. rewrite IHt2; auto.
  rewrite -> IHt; auto.
Qed.

Lemma close_eq_close_alpha : forall t y x n,
  ~ In y (x ::FV_t t) ->
  close_t n x t = close_t n y (subst_t (trm_fvar y) x t).
Proof.
  induction t; intros; auto; simpl; simpl FV_t in H.
  apply_ccn.

  rewrite -> IHt with (y:=y); auto.
  rewrite -> IHt with (y:=y); auto.

  simpl FV_t in *; rewrite list_cons_eq_app in H; destruct_nin.
  rewrite -> IHt1 with (y:=y); auto.
  rewrite -> IHt2 with (y:=y); auto.
  rewrite list_cons_eq_app. apply el_nin_conj_2. split; auto.
  rewrite list_cons_eq_app. apply el_nin_conj_2. split; auto.

  rewrite -> IHt with (y:=y); auto.
Qed.

Ltac not_in_var_var :=
  match goal with
    | [|- ~ In ?x (FV_t (trm_fvar ?y)) ] =>
      match goal with
        | [H : ~ In y (x :: _) |- _] =>
          let new_var := fresh "H" in
            unfold not; intro new_var; simpl in *;
              destruct new_var; simpl; auto
      end
  end.
Hint Extern 5 (~ In _ _) => not_in_var_var.

Lemma close_open_subst_gen : forall t ,
  lc t ->
  forall t' n x, lc t' -> open_t n t' (close_t  n x t) = subst_t t' x t.
Proof.
  induction 1; intros; simpl; auto; try apply_ccn.

  apply trm_lam_eq_lc with (L:=x::L++FV_t t'); intros.
  destruct_nin.
  rewrite -> open_comm'; auto.

  rewrite <- close_id with (t:=trm_fvar y) (x:=x) (n:=S n) at 1; auto.
  rewrite <- close_open_comm; auto with arith; auto.
  rewrite <- subst_id with (t':=trm_fvar y) (t:=t') (x:=x) at 2; auto.

  rewrite <- subst_open_t; auto.

  apply f_equal; auto.

  apply trm_app_eq; eauto.
  apply trm_tapp_eq; auto.
Qed.

Lemma lc_open_inst : forall x t t' L n,
  lc t' ->
  ~ In x (L++FV_t t) ->
  lc (open_t n (trm_fvar x) t) ->
  lc (open_t n t' t).
Proof.
  intros. remember (open_t n (trm_fvar x) t) as t''.
  generalize x t t' L n H H0 Heqt''. clear - H1.
  induction H1; intros; destruct_nin.

  (* Case: trm_fvar. *)
  apply eq_sym in Heqt''.
  case_split_names x n.
  apply open_eq_fvar in Heqt''.
  destruct Heqt''; subst.
  simpl; apply_ccn.
  simpl; auto.
  apply open_neq_fvar in Heqt''; auto; subst.
  simpl; auto.
  apply open_neq_fvar in Heqt''; auto; subst.
  simpl; auto.

  (* Case: trm_lam. *)
  apply eq_sym in Heqt''.
  apply open_eq_lam_fv in Heqt''; auto.
  destruct Heqt''. destruct_conj. subst.
  simpl. apply lc_lam with (L:=x::L++L0++FV_t t'); intros; auto.
  destruct_nin.

  rewrite -> open_comm'; auto.
  rewrite <- close_id with (t := trm_fvar x0) (x:=x) (n:=S n); auto.
  rewrite <- close_open_comm; auto with arith.

  rewrite -> close_open_subst_gen; auto.
  apply subst_lc; auto.

  apply eq_sym in Heqt''.
  Lemma open_eq_Lam : forall n x t' t,
    open_t n (trm_fvar x) t' = trm_Lam t ->
    exists a, t' = trm_Lam a.
  Proof.
    induction t'; intros; simpl in *; try smash_contra.
    contradict H; apply_ccn; unfold not; intros; smash_contra.
    exists t'; auto.
  Qed.
  copy_hyp Heqt'' Ha.
  apply open_eq_Lam in Heqt''.
  destruct Heqt''.
  subst. simpl in *.
  apply lc_Lam. invert_typing Ha.
  apply IHlc with (x1:=x) (L:=L); auto.

  (* Case: trm_app. *)
  apply eq_sym in Heqt''.
  copy_hyp Heqt'' Hc.
  apply open_eq_app in Heqt''.
  destruct Heqt''. destruct H2. subst.
  simpl. apply lc_app.
  simpl in *; destruct_nin.
  apply IHlc1 with (x:=x) (L:=L); auto.
  invert_typing Hc; auto.
  simpl in *; destruct_nin.
  apply IHlc2 with (x:=x) (L:=L); auto.
  invert_typing Hc; auto.

  Lemma open_eq_tapp
     : forall (t t' : trm) (T:typ) (n x : nat),
       open_t n (trm_fvar x) t = trm_tapp t' T ->
       exists (t'' : trm), t = trm_tapp t'' T.
  Proof.
    induction t; intros; simpl in *; try smash_contra.
    contradict H; apply_ccn; unfold not; intros; smash_contra.
    exists t; auto.
    invert_typing H; auto.
  Qed.
  apply eq_sym in Heqt''.
  copy_hyp Heqt'' Ha.
  apply open_eq_tapp in Ha.
  destruct Ha. subst.
  simpl in *. invert_typing Heqt''.
  apply lc_tapp; auto.
  apply IHlc with (x1:=x) (L:=L); auto.

  (* Case: trm_c. *)
  apply eq_sym in Heqt''.
  apply open_eq_trmc in Heqt''; subst; simpl; auto.
Qed.

Lemma lc_renaming : forall t'',
  lc t'' ->
  forall t x n,
    ~ In x (FV_t t) ->
    t'' = open_t n (trm_fvar x) t ->
    (forall y, ~ In y (x::FV_t t) -> lc (open_t n (trm_fvar y) t)).
Proof.
  induction 1; intros q x m Ha Hb y H3; simpl open_t in *; apply eq_sym in Hb.

  case_split_names n x.
  apply open_eq_fvar in Hb.
  destruct Hb; subst; simpl; auto.
  rewrite -> nat_compare_eq_eq; auto.
  apply open_neq_fvar in Hb; try omega; subst; simpl; auto.
  apply open_neq_fvar in Hb; try omega; subst; simpl; auto.

  apply open_eq_lam_fv in Hb; auto. destruct Hb; destruct H2; subst; simpl in *.
  apply lc_lam with (L:=x::y::L); intros; auto.
  rewrite -> open_comm; auto with arith.
  rewrite <- close_id with (x:=x) (n:=S m) (t:=trm_fvar x0); auto.
  rewrite <- close_open_comm; auto with arith.
  rewrite -> close_open_alpha.
  destruct_nin. rewrite list_cons_eq_app in H4; destruct_nin.
  apply_hyp (H0 x0 H5) Hc. apply subst_lc with (t:=trm_fvar y) (x:=x) in Hc; auto.
  destruct_nin. rewrite list_cons_eq_app in H4; destruct_nin.
  apply H0; auto.
  unfold not; intros. subst. smash_contra.

  copy_hyp Hb Hb'.
  apply open_eq_Lam in Hb. destruct Hb; subst.
  simpl; simpl in IHlc; simpl in Ha; simpl FV_t in *.
  apply lc_Lam. apply IHlc with (x:=x).

  rewrite -> cons_to_app in H3. destruct_nin; auto.
  simpl in Hb'. invert_typing Hb'; auto.
  rewrite -> cons_to_app in H3. destruct_nin; auto.
  unfold not; intros; destruct H2; subst; simpl in *;
    smash_contra.

  copy_hyp Hb Hb'.
  apply open_eq_app in Hb. destruct Hb. destruct H1; subst.
  apply open_app in Hb'. invert_typing Hb'. clear Hb'.
  simpl FV_t in *; destruct_nin.
  simpl. apply lc_app.

  apply IHlc1 with (x1:=x); auto.
  rewrite -> list_cons_eq_app. apply el_nin_conj_2. split; auto.

  apply IHlc2 with (x0:=x); auto.
  rewrite -> list_cons_eq_app. apply el_nin_conj_2. split; auto.

  copy_hyp Hb Hb'.
  apply open_eq_tapp in Hb.
  destruct Hb.
  subst. simpl FV_t in *. simpl.
  apply lc_tapp; auto.
  apply IHlc with (x:=x); auto.
  simpl in Hb'. invert_typing Hb'; auto.

  apply open_eq_trmc in Hb; subst; intuition.
Qed.


From stdpp Require Export countable vector.
From stdpp Require Import options.

Class Finite A `{EqDecision A} := {
  enum : list A;
  (* [NoDup] makes it easy to define the cardinality of the type. *)
  NoDup_enum : NoDup enum;
  elem_of_enum x : x ∈ enum
}.
Global Hint Mode Finite ! - : typeclass_instances.
Arguments enum : clear implicits.
Arguments enum _ {_ _} : assert.
Arguments NoDup_enum : clear implicits.
Arguments NoDup_enum _ {_ _} : assert.
Definition card A `{Finite A} := length (enum A).

Program Definition finite_countable `{Finite A} : Countable A := {|
  encode := λ x,
    Pos.of_nat $ S $ default 0 $ fst <$> list_find (x =.) (enum A);
  decode := λ p, enum A !! pred (Pos.to_nat p)
|}.
Arguments Pos.of_nat : simpl never.
Next Obligation.
  intros ?? [xs Hxs HA] x; unfold encode, decode; simpl.
  destruct (list_find_elem_of (x =.) xs x) as [[i y] Hi]; auto.
  rewrite Nat2Pos.id by done; simpl; rewrite Hi; simpl.
  destruct (list_find_Some (x =.) xs i y); naive_solver.
Qed.
Global Hint Immediate finite_countable : typeclass_instances.

Definition find `{Finite A} P `{∀ x, Decision (P x)} : option A :=
  list_find P (enum A) ≫= decode_nat ∘ fst.

Lemma encode_lt_card `{finA: Finite A} (x : A) : encode_nat x < card A.
Proof.
  destruct finA as [xs Hxs HA]; unfold encode_nat, encode, card; simpl.
  rewrite Nat2Pos.id by done; simpl.
  destruct (list_find _ xs) as [[i y]|] eqn:HE; simpl.
  - apply list_find_Some in HE as (?&?&?); eauto using lookup_lt_Some.
  - destruct xs; simpl; [|lia].
    exfalso; eapply not_elem_of_nil, (HA x).
Qed.
Lemma encode_decode A `{finA: Finite A} i :
  i < card A → ∃ x : A, decode_nat i = Some x ∧ encode_nat x = i.
Proof.
  destruct finA as [xs Hxs HA].
  unfold encode_nat, decode_nat, encode, decode, card; simpl.
  intros Hi. apply lookup_lt_is_Some in Hi. destruct Hi as [x Hx].
  exists x. rewrite !Nat2Pos.id by done; simpl.
  destruct (list_find_elem_of (x =.) xs x) as [[j y] Hj]; auto.
  split; [done|]; rewrite Hj; simpl.
  apply list_find_Some in Hj as (?&->&?). eauto using NoDup_lookup.
Qed.
Lemma find_Some `{finA: Finite A} P `{∀ x, Decision (P x)} (x : A) :
  find P = Some x → P x.
Proof.
  destruct finA as [xs Hxs HA]; unfold find, decode_nat, decode; simpl.
  intros Hx. destruct (list_find _ _) as [[i y]|] eqn:Hi; simplify_eq/=.
  rewrite !Nat2Pos.id in Hx by done.
  destruct (list_find_Some P xs i y); naive_solver.
Qed.
Lemma find_is_Some `{finA: Finite A} P `{∀ x, Decision (P x)} (x : A) :
  P x → ∃ y, find P = Some y ∧ P y.
Proof.
  destruct finA as [xs Hxs HA]; unfold find, decode; simpl.
  intros Hx. destruct (list_find_elem_of P xs x) as [[i y] Hi]; auto.
  rewrite Hi; unfold decode_nat, decode. simpl.
  rewrite !Nat2Pos.id by done. simpl.
  apply list_find_Some in Hi; naive_solver.
Qed.

Definition encode_fin `{Finite A} (x : A) : fin (card A) :=
  Fin.of_nat_lt (encode_lt_card x).
Program Definition decode_fin `{Finite A} (i : fin (card A)) : A :=
  match Some_dec (decode_nat i) return _ with
  | inleft (x ↾ _) => x | inright _ => _
  end.
Next Obligation.
  intros A ?? i ?; exfalso.
  destruct (encode_decode A i); naive_solver auto using fin_to_nat_lt.
Qed.
Lemma decode_encode_fin `{Finite A} (x : A) : decode_fin (encode_fin x) = x.
Proof.
  unfold decode_fin, encode_fin. destruct (Some_dec _) as [[x' Hx]|Hx].
  { by rewrite fin_to_nat_to_fin, decode_encode_nat in Hx; simplify_eq. }
  exfalso; by rewrite ->fin_to_nat_to_fin, decode_encode_nat in Hx.
Qed.

Lemma fin_choice {n} {B : fin n → Type} (P : ∀ i, B i → Prop) :
  (∀ i, ∃ y, P i y) → ∃ f, ∀ i, P i (f i).
Proof.
  induction n as [|n IH]; intros Hex.
  { exists (fin_0_inv _); intros i; inv_fin i. }
  destruct (IH _ _ (λ i, Hex (FS i))) as [f Hf], (Hex 0%fin) as [y Hy].
  exists (fin_S_inv _ y f); intros i; by inv_fin i.
Qed.
Lemma finite_choice `{Finite A} {B : A → Type} (P : ∀ x, B x → Prop) :
  (∀ x, ∃ y, P x y) → ∃ f, ∀ x, P x (f x).
Proof.
  intros Hex. destruct (fin_choice _ (λ i, Hex (decode_fin i))) as [f ?].
  exists (λ x, eq_rect _ _ (f(encode_fin x)) _ (decode_encode_fin x)); intros x.
  destruct (decode_encode_fin x); simpl; auto.
Qed.

Lemma card_0_inv P `{finA: Finite A} : card A = 0 → A → P.
Proof.
  intros ? x. destruct finA as [[|??] ??]; simplify_eq.
  by destruct (not_elem_of_nil x).
Qed.
Lemma finite_inhabited A `{finA: Finite A} : 0 < card A → Inhabited A.
Proof.
  unfold card; intros. destruct finA as [[|x ?] ??]; simpl in *; [exfalso;lia|].
  constructor; exact x.
Qed.
Lemma finite_inj_submseteq `{finA: Finite A} `{finB: Finite B} (f: A → B)
  `{!Inj (=) (=) f} : f <$> enum A ⊆+ enum B.
Proof.
  intros. destruct finA, finB. apply NoDup_submseteq; auto using NoDup_fmap_2.
Qed.
Lemma finite_inj_Permutation `{Finite A} `{Finite B} (f : A → B)
  `{!Inj (=) (=) f} : card A = card B → f <$> enum A ≡ₚ enum B.
Proof.
  intros. apply submseteq_Permutation_length_eq.
  - by rewrite fmap_length.
  - by apply finite_inj_submseteq.
Qed.
Lemma finite_inj_surj `{Finite A} `{Finite B} (f : A → B)
  `{!Inj (=) (=) f} : card A = card B → Surj (=) f.
Proof.
  intros HAB y. destruct (elem_of_list_fmap_2 f (enum A) y) as (x&?&?); eauto.
  rewrite finite_inj_Permutation; auto using elem_of_enum.
Qed.

Lemma finite_surj A `{Finite A} B `{Finite B} :
  0 < card A ≤ card B → ∃ g : B → A, Surj (=) g.
Proof.
  intros [??]. destruct (finite_inhabited A) as [x']; auto with lia.
  exists (λ y : B, default x' (decode_nat (encode_nat y))).
  intros x. destruct (encode_decode B (encode_nat x)) as (y&Hy1&Hy2).
  { pose proof (encode_lt_card x); lia. }
  exists y. by rewrite Hy2, decode_encode_nat.
Qed.
Lemma finite_inj A `{Finite A} B `{Finite B} :
  card A ≤ card B ↔ ∃ f : A → B, Inj (=) (=) f.
Proof.
  split.
  - intros. destruct (decide (card A = 0)) as [HA|?].
    { exists (card_0_inv B HA). intros y. apply (card_0_inv _ HA y). }
    destruct (finite_surj A B) as (g&?); auto with lia.
    destruct (surj_cancel g) as (f&?). exists f. apply cancel_inj.
  - intros [f ?]. unfold card. rewrite <-(fmap_length f).
    by apply submseteq_length, (finite_inj_submseteq f).
Qed.
Lemma finite_bijective A `{Finite A} B `{Finite B} :
  card A = card B ↔ ∃ f : A → B, Inj (=) (=) f ∧ Surj (=) f.
Proof.
  split.
  - intros; destruct (proj1 (finite_inj A B)) as [f ?]; auto with lia.
    exists f; split; [done|]. by apply finite_inj_surj.
  - intros (f&?&?). apply (anti_symm (≤)); apply finite_inj.
    + by exists f.
    + destruct (surj_cancel f) as (g&?). exists g. apply cancel_inj.
Qed.
Lemma inj_card `{Finite A} `{Finite B} (f : A → B)
  `{!Inj (=) (=) f} : card A ≤ card B.
Proof. apply finite_inj. eauto. Qed.
Lemma surj_card `{Finite A} `{Finite B} (f : A → B)
  `{!Surj (=) f} : card B ≤ card A.
Proof.
  destruct (surj_cancel f) as (g&?).
  apply inj_card with g, cancel_inj.
Qed.
Lemma bijective_card `{Finite A} `{Finite B} (f : A → B)
  `{!Inj (=) (=) f} `{!Surj (=) f} : card A = card B.
Proof. apply finite_bijective. eauto. Qed.

(** Decidability of quantification over finite types *)
Section forall_exists.
  Context `{Finite A} (P : A → Prop).

  Lemma Forall_finite : Forall P (enum A) ↔ (∀ x, P x).
  Proof. rewrite Forall_forall. intuition auto using elem_of_enum. Qed.
  Lemma Exists_finite : Exists P (enum A) ↔ (∃ x, P x).
  Proof. rewrite Exists_exists. naive_solver eauto using elem_of_enum. Qed.

  Context `{∀ x, Decision (P x)}.

  Global Instance forall_dec: Decision (∀ x, P x).
  Proof using Type*.
   refine (cast_if (decide (Forall P (enum A))));
    abstract by rewrite <-Forall_finite.
  Defined.
  Global Instance exists_dec: Decision (∃ x, P x).
  Proof using Type*.
   refine (cast_if (decide (Exists P (enum A))));
    abstract by rewrite <-Exists_finite.
  Defined.
End forall_exists.

(** Instances *)
Section enc_finite.
  Context `{EqDecision A}.
  Context (to_nat : A → nat) (of_nat : nat → A) (c : nat).
  Context (of_to_nat : ∀ x, of_nat (to_nat x) = x).
  Context (to_nat_c : ∀ x, to_nat x < c).
  Context (to_of_nat : ∀ i, i < c → to_nat (of_nat i) = i).

  Program Instance enc_finite : Finite A := {| enum := of_nat <$> seq 0 c |}.
  Next Obligation.
    apply NoDup_alt. intros i j x. rewrite !list_lookup_fmap. intros Hi Hj.
    destruct (seq _ _ !! i) as [i'|] eqn:Hi',
      (seq _ _ !! j) as [j'|] eqn:Hj'; simplify_eq/=.
    apply lookup_seq in Hi' as  [-> ?]. apply lookup_seq in Hj' as [-> ?].
    rewrite <-(to_of_nat i), <-(to_of_nat j) by done. by f_equal.
  Qed.
  Next Obligation.
    intros x. rewrite elem_of_list_fmap. exists (to_nat x).
    split; auto. by apply elem_of_list_lookup_2 with (to_nat x), lookup_seq.
  Qed.
  Lemma enc_finite_card : card A = c.
  Proof. unfold card. simpl. by rewrite fmap_length, seq_length. Qed.
End enc_finite.

Section bijective_finite.
  Context `{Finite A, EqDecision B} (f : A → B) (g : B → A).
  Context `{!Inj (=) (=) f, !Cancel (=) f g}.

  Program Instance bijective_finite: Finite B := {| enum := f <$> enum A |}.
  Next Obligation. apply (NoDup_fmap_2 _), NoDup_enum. Qed.
  Next Obligation.
    intros y. rewrite elem_of_list_fmap. eauto using elem_of_enum.
  Qed.
End bijective_finite.

Program Instance option_finite `{Finite A} : Finite (option A) :=
  {| enum := None :: (Some <$> enum A) |}.
Next Obligation.
  constructor.
  - rewrite elem_of_list_fmap. by intros (?&?&?).
  - apply (NoDup_fmap_2 _); auto using NoDup_enum.
Qed.
Next Obligation.
  intros ??? [x|]; [right|left]; auto.
  apply elem_of_list_fmap. eauto using elem_of_enum.
Qed.
Lemma option_cardinality `{Finite A} : card (option A) = S (card A).
Proof. unfold card. simpl. by rewrite fmap_length. Qed.

Program Instance Empty_set_finite : Finite Empty_set := {| enum := [] |}.
Next Obligation. by apply NoDup_nil. Qed.
Next Obligation. intros []. Qed.
Lemma Empty_set_card : card Empty_set = 0.
Proof. done. Qed.

Program Instance unit_finite : Finite () := {| enum := [tt] |}.
Next Obligation. apply NoDup_singleton. Qed.
Next Obligation. intros []. by apply elem_of_list_singleton. Qed.
Lemma unit_card : card unit = 1.
Proof. done. Qed.

Program Instance bool_finite : Finite bool := {| enum := [true; false] |}.
Next Obligation.
  constructor; [ by rewrite elem_of_list_singleton | apply NoDup_singleton ].
Qed.
Next Obligation. intros [|]; [ left | right; left ]. Qed.
Lemma bool_card : card bool = 2.
Proof. done. Qed.

Program Instance sum_finite `{Finite A, Finite B} : Finite (A + B)%type :=
  {| enum := (inl <$> enum A) ++ (inr <$> enum B) |}.
Next Obligation.
  intros. apply NoDup_app; split_and?.
  - apply (NoDup_fmap_2 _). by apply NoDup_enum.
  - intro. rewrite !elem_of_list_fmap. intros (?&?&?) (?&?&?); congruence.
  - apply (NoDup_fmap_2 _). by apply NoDup_enum.
Qed.
Next Obligation.
  intros ?????? [x|y]; rewrite elem_of_app, !elem_of_list_fmap;
    [left|right]; (eexists; split; [done|apply elem_of_enum]).
Qed.
Lemma sum_card `{Finite A, Finite B} : card (A + B) = card A + card B.
Proof. unfold card. simpl. by rewrite app_length, !fmap_length. Qed.

Program Instance prod_finite `{Finite A, Finite B} : Finite (A * B)%type :=
  {| enum := foldr (λ x, (pair x <$> enum B ++.)) [] (enum A) |}.
Next Obligation.
  intros A ?????. induction (NoDup_enum A) as [|x xs Hx Hxs IH]; simpl.
  { constructor. }
  apply NoDup_app; split_and?.
  - by apply (NoDup_fmap_2 _), NoDup_enum.
  - intros [? y]. rewrite elem_of_list_fmap. intros (?&?&?); simplify_eq.
    clear IH. induction Hxs as [|x' xs ?? IH]; simpl.
    { rewrite elem_of_nil. tauto. }
    rewrite elem_of_app, elem_of_list_fmap.
    intros [(?&?&?)|?]; simplify_eq.
    + destruct Hx. by left.
    + destruct IH; [ | by auto ]. by intro; destruct Hx; right.
  - done.
Qed.
Next Obligation.
  intros ?????? [x y]. induction (elem_of_enum x); simpl.
  - rewrite elem_of_app, !elem_of_list_fmap. eauto using elem_of_enum.
  - rewrite elem_of_app; eauto.
Qed.
Lemma prod_card `{Finite A} `{Finite B} : card (A * B) = card A * card B.
Proof.
  unfold card; simpl. induction (enum A); simpl; auto.
  rewrite app_length, fmap_length. auto.
Qed.

Definition list_enum {A} (l : list A) : ∀ n, list { l : list A | length l = n } :=
  fix go n :=
  match n with
  | 0 => [[]↾eq_refl]
  | S n => foldr (λ x, (sig_map (x ::.) (λ _ H, f_equal S H) <$> (go n) ++.)) [] l
  end.

Program Instance list_finite `{Finite A} n : Finite { l : list A | length l = n } :=
  {| enum := list_enum (enum A) n |}.
Next Obligation.
  intros A ?? n. induction n as [|n IH]; simpl; [apply NoDup_singleton |].
  revert IH. generalize (list_enum (enum A) n). intros l Hl.
  induction (NoDup_enum A) as [|x xs Hx Hxs IH]; simpl; auto; [constructor |].
  apply NoDup_app; split_and?.
  - by apply (NoDup_fmap_2 _).
  - intros [k1 Hk1]. clear Hxs IH. rewrite elem_of_list_fmap.
    intros ([k2 Hk2]&?&?) Hxk2; simplify_eq/=. destruct Hx. revert Hxk2.
    induction xs as [|x' xs IH]; simpl in *; [by rewrite elem_of_nil |].
    rewrite elem_of_app, elem_of_list_fmap, elem_of_cons.
    intros [([??]&?&?)|?]; simplify_eq/=; auto.
  - apply IH.
Qed.
Next Obligation.
  intros A ?? n [l Hl]. revert l Hl.
  induction n as [|n IH]; intros [|x l] Hl; simpl; simplify_eq.
  { apply elem_of_list_singleton. by apply (sig_eq_pi _). }
  revert IH. generalize (list_enum (enum A) n). intros k Hk.
  induction (elem_of_enum x) as [x xs|x xs]; simpl in *.
  - rewrite elem_of_app, elem_of_list_fmap. left. injection Hl. intros Hl'.
    eexists (l↾Hl'). split; [|done]. by apply (sig_eq_pi _).
  - rewrite elem_of_app. eauto.
Qed.

Lemma list_card `{Finite A} n : card { l : list A | length l = n } = card A ^ n.
Proof.
  unfold card; simpl. induction n as [|n IH]; simpl; auto.
  rewrite <-IH. clear IH. generalize (list_enum (enum A) n).
  induction (enum A) as [|x xs IH]; intros l; simpl; auto.
  by rewrite app_length, fmap_length, IH.
Qed.

Fixpoint fin_enum (n : nat) : list (fin n) :=
  match n with 0 => [] | S n => 0%fin :: (FS <$> fin_enum n) end.
Program Instance fin_finite n : Finite (fin n) := {| enum := fin_enum n |}.
Next Obligation.
  intros n. induction n; simpl; constructor.
  - rewrite elem_of_list_fmap. by intros (?&?&?).
  - by apply (NoDup_fmap _).
Qed.
Next Obligation.
  intros n i. induction i as [|n i IH]; simpl;
    rewrite elem_of_cons, ?elem_of_list_fmap; eauto.
Qed.
Lemma fin_card n : card (fin n) = n.
Proof. unfold card; simpl. induction n; simpl; rewrite ?fmap_length; auto. Qed.

Section sig_finite.
  Context {A} (P : A → Prop) `{∀ x, Decision (P x)}.

  Fixpoint list_filter_sig (l : list A) : list (sig P) :=
    match l with
    | [] => []
    | x :: l => match decide (P x) with
              | left H => x ↾ H :: list_filter_sig l
              | _ => list_filter_sig l
              end
    end.
  Lemma list_filter_sig_filter (l : list A) :
    proj1_sig <$> list_filter_sig l = filter P l.
  Proof.
    induction l as [| a l IH]; [done |].
    simpl; rewrite filter_cons.
    destruct (decide _); csimpl; by rewrite IH.
  Qed.

  Context `{Finite A} `{∀ x, ProofIrrel (P x)}.

  Global Program Instance sig_finite : Finite (sig P) :=
    {| enum := list_filter_sig (enum A) |}.
  Next Obligation.
    eapply NoDup_fmap_1. rewrite list_filter_sig_filter.
    apply NoDup_filter, NoDup_enum.
  Qed.
  Next Obligation.
    intros p. apply (elem_of_list_fmap_2_inj proj1_sig).
    rewrite list_filter_sig_filter, elem_of_list_filter.
    split; [by destruct p | apply elem_of_enum].
  Qed.
  Lemma sig_card : card (sig P) = length (filter P (enum A)).
  Proof. by rewrite <-list_filter_sig_filter, fmap_length. Qed.
End sig_finite.


(** * TImp: Case Study: a Typed Imperative Language *)

Set Warnings "-notation-overridden,-parsing".
Set Warnings "-extraction-opaque-accessed,-extraction".
Require Import Bool Arith EqNat List. Import ListNotations.

From QuickChick Require Import QuickChick Tactics.
Import QcNotation QcDefaultNotation. Open Scope qc_scope.

Set Bullet Behavior "Strict Subproofs".

From QC Require Import QC.

(** Having covered the basics of QuickChick in the previous
    chapter, we are ready to dive into a more realistic case study: a
    typed variant of Imp, the simple imperative language introduced in
    _Logical Foundations_.

    The version of Imp presented there enforces a syntactic separation
    between boolean and arithmetic expressions: [bexp] just ranges
    over boolean expressions, while [aexp] ranges over arithmetic
    ones.  Moreover, variables are only allowed in [aexp] and hence
    only take numeric values.  By contrast, in _Typed Imp_ (TImp) we
    collapse the expression syntax and allow variables to range over
    both numbers and booleans. With the unified syntax, we introduce
    the notion of _well-typed_ Imp expressions and programs (where
    every variable only ranges over values of a single type throughout
    the whole program).  We then give an operational semantics to TImp
    in the form of a (partial) evaluation function -- partial since,
    in the unified syntax, we can write nonsensical expressions such
    as [0 + True].

    A common mantra in functional programming is "well-typed programs
    cannot go wrong," and TImp is no exception. The _soundness_
    property for TImp will state that evaluating well-typed
    expressions and programs always succeeds.

    From the point of view of testing, soundness is interesting
    because it is a _conditional_ property. As we saw in the previous
    chapter, testing such properties effectively requires custom
    generators.  In this chapter, we show how to scale the techniques
    for writing generators explained in [QC] to more realistic
    generators for well-typed expressions and programs. In addition,
    we dicuss the need for custom shrinkers preserving invariants, a
    problem dual to that of custom generators. *)

(** Acknowledgement: We are grateful to Nicolas Koh for important
    contributions to an early version of this chapter. *)

(* ################################################################# *)
(** * Identifiers, Types and Contexts *)

(* ================================================================= *)
(** ** Identifiers *)

(** For the type of identifiers of TImp we will use a wrapper around
    plain natural numbers. *)

Inductive id :=
|  Id : nat -> id.

(** We will need one identifier-specific operation, [fresh]: given any
    finite set of identifiers, we can produce one that is distinct
    from all other identifiers in the set.

    To compute a fresh [id] given a list of [id]s we can just produce
    the number that is 1 larger than the maximum element: *)

Fixpoint max_elt (al:list id) : nat :=
  match al with
  | nil => 0
  | (Id n')::al' => max n' (max_elt al')
  end.

Definition fresh (al:list id) : id :=
  Id (S (max_elt al)).

(** We will also need a way of testing for equality, which we can
    derive with the standard [dec_eq] tactic. *)
Instance eq_id_dec (x1 x2 : id) : Dec (x1 = x2).
Proof. dec_eq. Defined.

(** One advantage of using natural numbers as identifiers is that
    we can take advantage of the [Show] instance of [nat] to print
    them. *)

(* BCP: Print them as "A", "B", etc.  Or maybe "X1", "X2", etc. *)
Instance show_id : Show id :=
  { show x := let '(Id n) := x in show n }.

(** To generate identifiers for TImp, we will not just generate
    arbitrary natural numbers. More often than not, we will need to
    generate a set of identifiers, or pick an identifier from such a
    set. If we represent a set as a list, we can do the former with a
    recursive function that generates [n] fresh [nat]s starting from
    the empty list. For the latter, we have QuickChick's [elems_]
    combinator. *)

Fixpoint get_fresh_ids n l :=
  match n with
  | 0 => l
  | S n' => get_fresh_ids n' ((fresh l) :: l)
  end.

(** **** Exercise: 2 stars (genId)  *)
(** Write a [Gen] instance for [id] using the [elems_]
    combinator and [get_fresh_ids].  *)

(* FILL IN HERE *)
(** [] *)

(** There remains the question of how to [shrink] [id]s.
    We will answer that question when [id]s are used later
    in the chapter. For now, let's leave the [Shrink] instance
    as a no-op.
 *)
Instance shrinkId : Shrink id :=
  { shrink x := [] }.

(* ================================================================= *)
(** ** Types *)

(** Here is the type of TImp types: *)

Inductive ty := TBool | TNat.

(** That is, TImp has two kinds of values: booleans and natural
    numbers. *)

(** To use [ty] in testing, we will need [Arbitrary], [Show], and
    [Dec] instances. *)

(** In QC.v, we saw how to write such generators by hand.
    We also saw, however, that this process can largely be automated
    for simple inductive types (like [ty], [nat], [list], [tree], etc.).
    QuickChick provides a top-level vernacular command to derive such
    instances. *)

Derive (Arbitrary, Show) for ty.
(* ==>
    GenSizedty is defined
    Shrinkty is defined
    Showty is defined
*)

Check GenSizedty.
(* ==> GenSizedty : GenSized ty *)
Check Shrinkty.
(* ==> Shrinkty  : Shrink ty   *)
Check Showty.
(* ==> Showty : Show ty     *)

(** Decidable equality instances are not yet derived fully
    automatically by QuickChick.  However, the boilerplate we have to
    write is largely straightforward. As we saw in the previous
    chapters, [Dec] is a typeclass wrapper around ssreflect's
    [decidable] and we can use the [dec_eq] tactic to automate
    the process. *)

Instance eq_dec_ty (x y : ty) : Dec (x = y).
Proof. dec_eq. Defined.

(* ================================================================= *)
(** ** List-Based Maps *)

(** To encode typing environments (and, later on, states), we will
    need maps from identifiers to values. However, the function-based
    representation in the _Software Foundations_ version of Imp is not
    well suited for testing: we need to be able to access the domain
    of the map, fold over it, and test for equality; these are all
    awkward to define for Coq functions. Therefore, we introduce a
    simple list-based map representation that uses [id]s as the keys.

    The operations we need are:
       - [empty] : To create the empty map.
       - [get] : To look up the binding of an element, if any.
       - [set] : To update the binding of an element.
       - [dom] : To get the list of keys in the map. *)

(** The implementation of a map is a simple association list.  If a
    list contains multiple tuples with the same key, then the binding
    of the key in the map is the one that appears first in the list;
    that is, later bindings can be shadowed. *)

Definition Map A := list (id * A).

(** The [empty] map is the empty list. *)

Definition map_empty {A} : Map A := [].

(** To [get] the binding of an identifier [x], we just need to walk
    through the list and find the first [cons] cell where the key
    is equal to [x], if any. *)

Fixpoint map_get {A} (m : Map A) x : option A :=
  match m with
  | [] => None
  | (k, v) :: m' => if x = k ? then Some v else map_get m' x
  end.

(** To [set] the binding of an identifier, we just need to [cons]
    it at the front of the list. *)

Definition map_set {A} (m:Map A) (x:id) (v:A) : Map A := (x, v) :: m.

(** Finally, the domain of a map is just the set of its keys. *)
Fixpoint map_dom {A} (m:Map A) : list id :=
  match m with
  | [] => []
  | (k', v) :: m' => k' :: map_dom m'
  end.

(** We next introduce a simple inductive relation, [bound_to m x a], that
    holds precisely when the binding of some identifier [x] is equal to [a] in
    [m] *)

Inductive bound_to {A} : Map A -> id -> A -> Prop :=
  | Bind : forall x m a, map_get m x = Some a -> bound_to m x a.

(* ================================================================= *)
(** ** Deciding [bound_to] (optional) *)

(** We can now decide whether [bound_to m x a] holds for a given
    arrangement of [m], [x] and [a].  On a first reading, you may
    prefer to skip the next few paragraphs (until the start of the
    [Context] subsection), which deal with partially automating the
    proofs for such instances. *)

Instance dec_bound_to {A : Type} Gamma x (T : A)
         `{D : forall (x y : A), Dec (x = y)}
          : Dec (bound_to Gamma x T).
Proof.
  constructor. unfold ssrbool.decidable.
  destruct (map_get Gamma x) eqn:Get.

(** After unfolding [decidable] and destructing [map_get Gamma x], we are
    left with two subgoals. In the first, we know that [map_get Gamma x =
    Some a] and effectively want to decide whether [map_get Gamma x = Some
    T] or not. Which means we need to decide whether [a = T]. Thankfully,
    we can decide that using our hypothesis [D]. *)

  - destruct (D a T) as [[Eq | NEq]]; subst.

(** At this point, the first goal can be immediately decided positevely
    using constructor. *)

    + left. constructor. auto.

(** In the second subgoal, we can show that [bound_to] doesn't hold. *)

    + right; intro Contra; inversion Contra; subst; clear Contra.
      congruence.

(** Both of these tactic patterns are very common in non-trival [Dec]
    instances. It is worth we automating them a bit using LTac. *)

Abort.

(** A lot of the time, we can immediately decide a property positivly
    using constructor applications. That is captured in [solve_left]. *)

Ltac solve_left  := try solve [left; econstructor; eauto].

(** Much of the time, we can also immediately decide that a property
    _doesn't_ hold by assuming it, doing inversion, and using
    [congruence]. *)

Ltac solve_right :=
  let Contra := fresh "Contra" in
  try solve [right; intro Contra; inversion Contra; subst;
             clear Contra; eauto; congruence].

(** We group both in a single tactic, which does nothing at all if
    it fails to solve a goal, thanks to [try solve]. *)

Ltac solve_sum := solve_left; solve_right.

(** We can now prove the [Dec] instance quite concisely. *)

Instance dec_bound_to {A : Type} Gamma x (T : A)
         `{D : forall (x y : A), Dec (x = y)}
  : Dec (bound_to Gamma x T).
Proof.
  constructor. unfold ssrbool.decidable.
  destruct (map_get Gamma x) eqn:Get; solve_sum.
  destruct (D a T) as [[Eq | NEq]]; subst; solve_sum.
Defined.

(* ================================================================= *)
(** ** Contexts *)

(** Typing contexts in TImp are just maps from identifiers to types. *)

Definition context := Map ty.

(** Given a context [Gamma] and a type [T], we can try to generate a
    random [identifier] whose binding in [Gamma] is [T].

    We use [List.filter] to extract all of the elements in [Gamma]
    whose type is equal to [T] and then, for each [(a,T')] that
    remains, return the name [a]. We use the [oneOf_] combinator to
    pick an generator from this list at random.

    Since the filtered list might be empty we return an [option],
    we use [ret None] as the default element for [oneOf_].
 *)

Definition gen_typed_id_from_context (Gamma : context) (T : ty)
            : G (option id) :=
  oneOf_ (ret None)
         (List.map (fun '(x,T') => ret (Some x))
                   (List.filter (fun '(x,T') => T = T'?) Gamma)).

(** We also need to generate typing contexts. *)

(** Given some natural number [n] to serve as the size of the context,
    we first create its domain, [n] fresh identifiers.  We then create [n]
    arbitrary types with [vectorOf], using the [Gen] instance for [ty]
    we derived earlier.  Finally, we zip ([List.combine]) the domain
    with the ranges which creates the (list-based) map.
*)

Definition gen_context (n : nat) : G context :=
  let domain := get_fresh_ids n [] in
  range <- vectorOf n arbitrary ;;
  ret (List.combine domain range).

(* ################################################################# *)
(** * Expressions *)

(** We are now ready to introduce the syntax of expressions in TImp.
    The original Imp had two distinct types of expressions,
    arithmetic and boolean expressions; variables were only
    allowed to range over natural numbers. In TImp, we extend
    variables to range over boolean values as well, and we collapse
    expressions into a single type [exp]. *)

Inductive exp : Type :=
  | EVar : id -> exp
  | ENum : nat -> exp
  | EPlus : exp -> exp -> exp
  | EMinus : exp -> exp -> exp
  | EMult : exp -> exp -> exp
  | ETrue : exp
  | EFalse : exp
  | EEq : exp -> exp -> exp
  | ELe : exp -> exp -> exp
  | ENot : exp -> exp
  | EAnd : exp -> exp -> exp.

(** To print expressions we derive a [Show] Instance. *)

Derive Show for exp.

(* ================================================================= *)
(** ** Typed Expressions *)

(** The following inductive relation characterizes well-typed
    expressions of a particular type. It is straightforward, using
    [bound_to] to access the typing context in the variable case *)

Reserved Notation "Gamma '||-' e '\IN' T" (at level 40).

Inductive has_type : context -> exp -> ty -> Prop :=
| Ty_Var : forall x T Gamma,
    bound_to Gamma x T -> Gamma ||- EVar x \IN T
| Ty_Num : forall Gamma n,
    Gamma ||- ENum n \IN TNat
| Ty_Plus : forall Gamma e1 e2,
    Gamma ||- e1 \IN TNat -> Gamma ||- e2 \IN TNat ->
    Gamma ||- EPlus e1 e2 \IN TNat
| Ty_Minus : forall Gamma e1 e2,
    Gamma ||- e1 \IN TNat -> Gamma ||- e2 \IN TNat ->
    Gamma ||- EMinus e1 e2 \IN TNat
| Ty_Mult : forall Gamma e1 e2,
    Gamma ||- e1 \IN TNat -> Gamma ||- e2 \IN TNat ->
    Gamma ||- EMult e1 e2 \IN TNat
| Ty_True : forall Gamma, Gamma ||- ETrue \IN TBool
| Ty_False : forall Gamma, Gamma ||- EFalse \IN TBool
| Ty_Eq : forall Gamma e1 e2,
    Gamma ||- e1 \IN TNat -> Gamma ||- e2 \IN TNat ->
    Gamma ||- EEq e1 e2 \IN TBool
| Ty_Le : forall Gamma e1 e2,
    Gamma ||- e1 \IN TNat -> Gamma ||- e2 \IN TNat ->
    Gamma ||- ELe e1 e2 \IN TBool
| Ty_Not : forall Gamma e,
    Gamma ||- e \IN TBool ->  Gamma ||- ENot e \IN TBool
| Ty_And : forall Gamma e1 e2,
    Gamma ||- e1 \IN TBool -> Gamma ||- e2 \IN TBool ->
    Gamma ||- EAnd e1 e2 \IN TBool

where "Gamma '||-' e '\IN' T" := (has_type Gamma e T).

(** While the typing relation is almost entirely standard, there is a
    choice to make about the [Ty_Eq] rule. The [Ty_Eq] constructor
    above requires that the arguments to an equality check are both
    arithmetic expressions (just like it was in Imp), which simplifies
    some of the discussion in the remainder of the chapter. We could
    have allowed for equality checks between booleans as well - that will
    become an exercise at the end of this chapter. *)

(** Once again, we need a decidable instance for the typing relation of
    TImp. You can skip to the next exercise if you are not interested in
    specific proof details. *)

(** We will need a bit more automation for this proof. We will
    have a lot of hypotheses of the form:

   IH : forall (T : ty) (Gamma : context),
          ssrbool.decidable (Gamma ||- e1 \IN T)

    Using a brute-force approach, we instantiate such [IH]
    with both [TNat] and [TBool], destruct them and then
    call [solve_sum].

    The [pose proof] tactic introduces a new hypothesis
    in our context, while [clear IH] removes it so that
    we don't try the same instantiations again and
    again.
*)

Ltac solve_inductives Gamma :=
  repeat (match goal with
      [ IH : forall _ _, _ |- _ ] =>
      let H1 := fresh "H1" in
      pose proof (IH TNat Gamma) as H1;
      let H2 := fresh "H2" in
      pose proof (IH TBool Gamma) as H2;
      clear IH;
      destruct H1; destruct H2; solve_sum
    end).

(** Typing in TImp is decidable: given an expression [e], a context [Gamma]
    and a type [T], we can decide whether [has_type Gamma e T] holds. *)

Instance dec_has_type (e : exp) (Gamma : context) (T : ty)
  : Dec (Gamma ||- e \IN T).
Proof with solve_sum.
  constructor.
  generalize dependent Gamma.
  generalize dependent T.
  induction e; intros T Gamma; unfold ssrbool.decidable;
    try solve [destruct T; solve_sum];
    try solve [destruct T; solve_inductives Gamma].
  (* bound_to case: *)
  destruct (dec_bound_to Gamma i T); destruct dec; solve_sum.
Defined.

(** **** Exercise: 3 stars (arbitraryExp)  *)
(** Derive [Arbitrary] for expressions.  To see how good it is at
    generating _well-typed_ expressions, write a conditional property
    [cond_prop] that is (trivially) always true, with the precondition
    that some expression is well-typed. Try to check that property like
    this:

    QuickChickWith (updMaxSize stdArgs 3) cond_prop.

    This idiom sets the maximum-size parameter for all generators to
    [3], rather the default, which is something larger like 10.  When
    generating examples, QuickChick will start with size 0, gradually
    increase the size until the maximum size is reached, and then
    start over.  What happens when you vary the size bound? *)

(* FILL IN HERE *)
(** [] *)

(* ================================================================= *)
(** ** Generating Typed Expressions *)

(** Instead of generating expressions and filtering them using
    [has_type], we can be smarter and generate _well-typed_
    expressions for a given context directly.

    It is common for conditional generators to return [option]s,
    allowing the possibility of failure if a wrong choice is made
    internally. For example, if we wanted to generate an expression of
    type [TNat] and chose to try to do so by generating a variable,
    then we might not be able to finish (if the context is empty or
    only binds booleans). *)

(** To chain together two generators with types of the form
    [G (option ...)], we need to execute the first generator, match
    on its result, and, when it is a [Some], apply the second generator. *)

Definition bindGenOpt {A B : Type}
             (gma : G (option A)) (k : A -> G (option B))
           : G (option B) :=
  ma <- gma ;;
  match ma with
  | Some a => k a
  | None => ret None
  end.

(** This pattern is common enough that QuickChick introduces explicit monadic
    notations. *)

Print GOpt.
(**
    GOpt = fun A : Type => G (option A)
         : Type -> Type
*)

(* Check Monad_GOpt. *)
(**
    Monad_GOpt
         : Monad GOpt
*)

(** This brings us to our first interesting generator -- one for typed
    expressions.  We assume that [Gamma] and [T] are inputs to the
    generation process.  We also use a [size] parameter to control the
    depth of generated expressions (i.e., we'll define a sized
    generator). *)

(** Let's start with a much smaller relation: [has_type_1] (which
    consists of just the first constructor of [has_type]), to
    demonstrate how to build up complex generators for typed
    expressions from smaller parts. *)

Inductive has_type_1 : context -> exp -> ty -> Prop :=
  | Ty_Var1 : forall x T Gamma,
      bound_to Gamma x T -> has_type_1 Gamma (EVar x) T.

(** To generate [e] such that [has_type_1 Gamma e T] holds, we need to
    pick one of its constructors (there is only one choice, here) and
    then try to satisfy its preconditions by generating more things.
    To satisfy [Ty_Var1] (given [Gamma] and [T]), we need to generate
    [x] such that [bound_to Gamma x T]. But we already have such a
    generator!  We just need to wrap it in an [EVar].  *)

Definition gen_typed_evar (Gamma : context) (T : ty) : GOpt exp :=
  x <- gen_typed_id_from_context Gamma T;;
  ret (EVar x).

(** (Note that this is the [ret] of the [GOpt] monad.) *)

(** Now let's consider a typing relation [has_type_2], extending
    [has_type_1] with all of the constructors of [has_type] that do
    not recursively require [has_type] as a side-condition. These will
    be the _base cases_ for our final generator. *)

Inductive has_type_2 : context -> exp -> ty -> Prop :=
| Ty_Var2 : forall x T Gamma,
    bound_to Gamma x T -> has_type_2 Gamma (EVar x) T
| Ty_Num2 : forall Gamma n,
    has_type_2 Gamma  (ENum n) TNat
| Ty_True2 : forall Gamma, has_type_2 Gamma ETrue TBool
| Ty_False2 : forall Gamma, has_type_2 Gamma EFalse TBool.

(** We can already generate values satisfying [Ty_Var2] using
    [gen_typed_evar].  For the rest of the rules, we will need to
    pattern match on the input [T], since [Ty_Num] can only be used if
    [T = TNat], while [Ty_True] and [Ty_False] can only be used if [T
    = TBool].  *)

Definition base' Gamma T : list (GOpt exp) :=
      gen_typed_evar Gamma T ::
      match T with
      | TNat  => [ n <- arbitrary;; ret (Some (ENum n))]
      | TBool => [ ret ETrue ; ret EFalse ]
      end.

(** We now need to go from a list of (optional) generators to a
    single generator. We could do that using the [oneOf] combinator (which
    chooses uniformly), or the [freq] combinator (by adding weights).

    Instead, we introduce a new one, called [backtrack]:

       backtrack : list (nat * GOpt ?A) -> GOpt ?A
*)

(** Just like [freq], [backtrack] selects one of the generators
    according to the input weights. Unlike [freq], if the chosen
    generator fails (i.e. produces [None]), [backtrack] will discard
    it, choose another, and keep going until one succeeds or all
    possibilities are exhausted. Our base-case generator could then be
    like this: *)

Definition base Gamma T :=
      (2, gen_typed_evar Gamma T) ::
      match T with
      | TNat  => [ (2, n <- arbitrary;; ret (Some (ENum n)))]
      | TBool => [ (1, ret ETrue)
                 ; (1, ret EFalse) ]
      end.

Definition gen_has_type_2 Gamma T := backtrack (base Gamma T).

(** To see how we handle recursive rules, let's consider a third
    sub-relation, [has_type_3], with just variables and addition: *)

Inductive has_type_3 : context -> exp -> ty -> Prop :=
 | Ty_Var3 : forall x T Gamma,
     bound_to Gamma x T -> has_type_3 Gamma (EVar x) T
 | Ty_Plus3 : forall Gamma e1 e2,
    has_type_3 Gamma e1 TNat -> has_type_3 Gamma e2 TNat ->
    has_type_3 Gamma (EPlus e1 e2) TNat.

(** Typing derivations involving [EPlus] nodes are binary trees, so we
    need to add a [size] parameter to enforce termination. The base
    case ([Ty_Var3]) is handled using [gen_typed_evar] just like
    before.  The non-base case can choose between trying to generate
    [Ty_Var3] and trying to generate [Ty_Plus3]. For the latter, the
    input type [T] must be [TNat], otherwise it is not
    applicable. Once again, this leads to a match on [T]: *)

Fixpoint gen_has_type_3 size Gamma T : GOpt exp :=
  match size with
  | O => gen_typed_evar Gamma T
  | S size' =>
    backtrack
      ([ (1, gen_typed_evar Gamma T) ]
      ++ match T with
         | TNat =>
           [ (size, e1 <- gen_has_type_3 size' Gamma TNat;;
                    e2 <- gen_has_type_3 size' Gamma TNat;;
                    ret (EPlus e1 e2)) ]
         | _ => []
         end)
  end.

(** Putting all this together, we get the full generator for
    well-typed expressions. *)

Fixpoint gen_exp_typed_sized
            (size : nat) (Gamma : context) (T : ty)
       : GOpt exp :=
  let base := base Gamma T in
  let recs size' :=
    match T with
    | TNat =>
      [ (size, e1 <- gen_exp_typed_sized size' Gamma TNat ;;
            e2 <- gen_exp_typed_sized size' Gamma TNat ;;
            ret (EPlus e1 e2))
      ; (size, e1 <- gen_exp_typed_sized size' Gamma TNat ;;
            e2 <- gen_exp_typed_sized size' Gamma TNat ;;
            ret (EMinus e1 e2))
      ; (size, e1 <- gen_exp_typed_sized size' Gamma TNat ;;
            e2 <- gen_exp_typed_sized size' Gamma TNat ;;
            ret (EMult e1 e2)) ]
    | TBool =>
    [ (size, e1 <- gen_exp_typed_sized size' Gamma TNat ;;
             e2 <- gen_exp_typed_sized size' Gamma TNat ;;
             ret (EEq e1 e2))
       ; (size, e1 <- gen_exp_typed_sized size' Gamma TNat ;;
             e2 <- gen_exp_typed_sized size' Gamma TNat ;;
             ret (ELe e1 e2))
       ; (size, e1 <- gen_exp_typed_sized size' Gamma TBool ;;
             ret (ENot e1))
       ; (size, e1 <- gen_exp_typed_sized size' Gamma TBool ;;
             e2 <- gen_exp_typed_sized size' Gamma TBool ;;
             ret (EAnd e1 e2)) ]
    end in
  match size with
  | O =>
    backtrack base
  | S size' =>
    backtrack (base ++ recs size')
  end.

(** When writing such complex generators, it's good to have some tests
    to verify that we are generating what we expect. For example, here
    we would expect [gen_exp_typed_sized] to always return expressions
    that are well typed.

    We can use [forAll] to encode such a property. *)

Definition gen_typed_has_type :=
  let num_vars := 4 in
  let top_level_size := 3 in
  forAll (gen_context num_vars) (fun Gamma =>
  forAll arbitrary (fun T =>
  forAll (gen_exp_typed_sized top_level_size Gamma T) (fun me =>
  match me with
  | Some e => (has_type Gamma e T)?
  | None => false
  end))).

(* QuickChick gen_typed_has_type. *)

(* ################################################################# *)
(** * Values and States *)

(* ================================================================= *)
(** ** Values *)

(** In the original Imp language from _Logical Foundations_, variables
    ranged over natural numbers, so states were just maps from
    identifiers to [nat].  Since we now want to extend this to also
    include booleans, we need a type of [value]s that includes
    both. *)

Inductive value := VNat : nat -> value | VBool : bool -> value.

Derive Show for value.

(** We can also quickly define a typing relation for values, a Dec instance
    for it, and a generator for values of a given type. *)

Inductive has_type_value : value -> ty -> Prop :=
  | TyVNat  : forall n, has_type_value (VNat  n) TNat
  | TyVBool : forall b, has_type_value (VBool b) TBool.

Instance dec_has_type_value v T : Dec (has_type_value v T).
Proof. constructor; unfold ssrbool.decidable.
destruct v; destruct T; solve_sum.
Defined.

Definition gen_typed_value (T : ty) : G value :=
  match T with
  | TNat  => n <- arbitrary;; ret (VNat n)
  | TBool => b <- arbitrary;; ret (VBool b)
  end.

(* ================================================================= *)
(** ** States *)

(** _States_ in TImp are just maps from identifiers to values *)

Definition state := Map value.

(** We introduce an inductive relation that specifies when a state is
    well typed in a context (that is, when all of its variables are
    mapped to values of appropriate types).

    We encode this in an element-by-element style inductive relation:
    empty states are only well typed with respect to an empty context,
    while non-empty states need to map their head identifier to a value of
    the appropriate type (and their tail must similarly be well
    typed). *)

Inductive well_typed_state : context -> state -> Prop :=
| TS_Empty : well_typed_state map_empty map_empty
| TS_Elem  : forall x v T st Gamma,
    has_type_value v T -> well_typed_state Gamma st ->
    well_typed_state ((x,T)::Gamma) ((x,v)::st).

Instance dec_well_typed_state Gamma st : Dec (well_typed_state Gamma st).
Proof.
constructor; unfold ssrbool.decidable.
generalize dependent Gamma.
induction st; intros; destruct Gamma; solve_sum.
destruct a as [a v]; destruct p as [a' T].
destruct (@dec (a = a') _ ); solve_sum.
subst; specialize (IHst Gamma); destruct IHst; solve_sum.
destruct (dec_has_type_value v T); destruct dec; solve_sum.
Defined.

Definition gen_well_typed_state (Gamma : context) : G state :=
  sequenceGen (List.map (fun '(x, T) =>
                           v <- gen_typed_value T;;
                           ret (x, v)) Gamma).

(* ################################################################# *)
(** * Evaluation *)

(** The evaluation function takes a state and an expression and
    returns an optional value, which can be [None] if the expression
    encounters a dynamic type error like trying to perform addition on
    a boolean. *)

Fixpoint eval (st : state) (e : exp) : option value :=
  match e with
  | EVar x => map_get st x
  | ENum n => Some (VNat n)
  | EPlus e1 e2 =>
    match eval st e1, eval st e2 with
    | Some (VNat n1), Some (VNat n2) => Some (VNat (n1 + n2))
    | _, _ => None
    end
  | EMinus e1 e2 =>
    match eval st e1, eval st e2 with
    | Some (VNat n1), Some (VNat n2) => Some (VNat (n1 - n2))
    | _, _ => None
    end
  | EMult e1 e2 =>
    match eval st e1, eval st e2 with
    | Some (VNat n1), Some (VNat n2) => Some (VNat (n1 * n2))
    | _, _ => None
    end
  | ETrue       => Some (VBool true  )
  | EFalse      => Some (VBool false )
  | EEq e1 e2 =>
    match eval st e1, eval st e2 with
    | Some (VNat n1), Some (VNat n2) => Some (VBool (n1 =? n2))
    | _, _ => None
    end
  | ELe e1 e2 =>
    match eval st e1, eval st e2 with
    | Some (VNat n1), Some (VNat n2) => Some (VBool (n1 <? n2))
    | _, _ => None
    end
  | ENot e =>
    match eval st e with
    | Some (VBool b) => Some (VBool (negb b))
    | _ => None
    end
  | EAnd e1 e2  =>
    match eval st e1, eval st e2 with
(* Let's include a silly bug here! *)
    | Some (VBool b), Some (VNat n2) => Some (VBool (negb b))
(*  | Some (VBool b1), Some (VBool b2) => Some (VBool (andb b1 b2)) *)
    | _, _ => None
    end
  end.

(** We will see in a later chapter ([QuickChickTool]) how we can
    use QuickChick to introduce such _mutations_ and have them
    automatically checked. *)

(** _Type soundness_ states that, if we have an expression [e] of a
    given type [T] as well as a well-typed state [st], then evaluating
    [e] in [st] will never fail.*)

Definition isNone {A : Type} (m : option A) :=
  match m with
  | None => true
  | Some _ => false
  end.

Conjecture expression_soundness : forall Gamma st e T,
    well_typed_state Gamma st ->  Gamma ||- e \IN T ->
    isNone (eval st e) = false.

(** To test this property, we construct an appropriate checker: *)

Definition expression_soundness_exec :=
  let num_vars := 4 in
  let top_level_size := 3 in
  forAll (gen_context num_vars)  (fun Gamma =>
  forAll (gen_well_typed_state Gamma) (fun st =>
  forAll arbitrary (fun T =>
  forAll (gen_exp_typed_sized 3 Gamma T) (fun me =>
  match me with
  | Some e => negb (isNone (eval st e))
  | _ => true
  end)))).

(* QuickChick expression_soundness_exec. *)
(**

     ===>
       QuickChecking expression_soundness_exec
       [(1,TNat), (2,TNat), (3,TBool), (4,TNat)]
       [(1,VNat 0), (2,VNat 0), (3,VBool true), (4,VNat 0)]
       TBool
       Some EAnd (EAnd (EEq (EVar 4) (EVar 1)) (EEq (ENum 0) (EVar 4))) EFalse
       *** Failed after 8 tests and 0 shrinks. (0 discards)
*)
(** Where is the bug??  Looks like we need some shrinking! *)

(* ================================================================= *)
(** ** Shrinking for Expressions *)

(** Let's see what happens if we use the default shrinker for
    expressions carelessly. *)

Derive Shrink for exp.

Definition expression_soundness_exec_firstshrink :=
  let num_vars := 4 in
  let top_level_size := 3 in
  forAll (gen_context num_vars)  (fun Gamma =>
  forAll (gen_well_typed_state Gamma) (fun st =>
  forAll arbitrary (fun T =>
  forAllShrink (gen_exp_typed_sized 3 Gamma T) shrink (fun me =>
  match me with
  | Some e => negb (isNone (eval st e))
  | _ => true
  end)))).

(* QuickChick expression_soundness_exec_firstshrink. *)
(**
<<
     ===>
       QuickChecking expression_soundness_exec_firsttry
       [(1,TBool), (2,TNat), (3,TBool), (4,TBool)]
       [(1,VBool false), (2,VNat 0), (3,VBool true), (4,VBool false)]
       TBool
       Some EAnd (ENum 0) ETrue
       *** Failed after 28 tests and 7 shrinks. (0 discards)
*)

(** The expression shrank to something ill-typed! Since it causes the
    checker to fail, QuickChick views this as a succesfull shrink, even
    though this could not actually be produced by our generator and
    doesn't satisfy our preconditions!  One solution would be to check
    the preconditions in the Checker, filtering out shrinks.  But that
    would be inefficient. *)

(** We not only need to shrink expressions, we need to shrink them so
    that their type is preserved! To accomplish this, we need to
    intuitively follow the opposite of the procedure we did for
    generators: look at a typing derivation and see what parts of it
    we can shrink to while maintaining their types so that the type of
    the entire thing is preserved.

    As in the case of [gen_exp_typed], we are going to build up the
    full shrinker in steps. Let's begin with shrinking constants.

    - If [e = ENum x] for some [x], all we can do is try to shrink
      [x].
    - If [e = ETrue] or [e = EFalse], we could shrink it to the other.
      But remember, we don't want to do both, as this would lead to an
      infinite loop in shrinking!  We choose to shrink [EFalse] to
      [ETrue]. *)

Definition shrink_base (e : exp) : list exp :=
  match e with
  | ENum n => map ENum (shrink n)
  | ETrue => []
  | EFalse => [ETrue]
  | _ => []
  end.

(** The next case, [EVar], must take the type [T] to be preserved into
    account. To shrink an [EVar] we could try shrinking the inner
    identifier, but shrinking an identifier by shrinking its natural
    number representation makes little sense. Better, we can try to
    shrink the [EVar] to a constant of the appropriate type. *)

Definition shrink_evar (T : ty) (e : exp) : list exp :=
  match e with
  | EVar x =>
    match T with
    | TNat => [ENum 0]
    | TBool => [ETrue ; EFalse]
    end
  | _ => []
  end.

(** Finally, we need to be able to shrink the recursive cases. Consider
    [EPlus e1 e2]:
      - We could try (recursively) shrinking [e1] or [e2] preserving their
        [TNat] type.
      - We could try to shrink directly to [e1] or [e2] since their type
        is the same as [EPlus e1 e2]. *)

(** On the other hand, consider [EEq e1 e2]:
      - Again, we could recursively shrink [e1] or [e2].
      - But we can't shrink _to_ [e1] or [e2] since they are of a
        different type.
      - For faster shrinking, we can also try to shrink such expressions
        to boolean constants directly. *)

Fixpoint shrink_rec (T : ty) (e : exp) : list exp :=
  match e with
  | EPlus e1 e2 =>
    e1 :: e2
       :: (List.map (fun e1' => EPlus e1' e2) (shrink_rec T e1))
       ++ (List.map (fun e2' => EPlus e1 e2') (shrink_rec T e2))
  | EEq e1 e2 =>
    ETrue :: EFalse
       :: (List.map (fun e1' => EEq e1' e2) (shrink_rec TNat e1))
       ++ (List.map (fun e2' => EEq e1 e2') (shrink_rec TNat e2))
  | _ => []
  end.

(** Putting it all together yields the following smart shrinker: *)

Fixpoint shrink_exp_typed (T : ty) (e : exp) : list exp :=
  match e with
  | EVar _ =>
    match T with
    | TNat => [ENum 0]
    | TBool => [ETrue ; EFalse]
    end
  | ENum _ => []
  | ETrue => []
  | EFalse => [ETrue]
  | EPlus e1 e2 =>
    e1 :: e2
       :: (List.map (fun e1' => EPlus e1' e2) (shrink_exp_typed T e1))
       ++ (List.map (fun e2' => EPlus e1 e2') (shrink_exp_typed T e2))
  | EMinus e1 e2 =>
    e1 :: e2 :: (EPlus e1 e2)
       :: (List.map (fun e1' => EMinus e1' e2) (shrink_exp_typed T e1))
       ++ (List.map (fun e2' => EMinus e1 e2') (shrink_exp_typed T e2))
  | EMult e1 e2 =>
    e1 :: e2 :: (EPlus e1 e2)
       :: (List.map (fun e1' => EMult e1' e2) (shrink_exp_typed T e1))
       ++ (List.map (fun e2' => EMult e1 e2') (shrink_exp_typed T e2))
  | EEq e1 e2 =>
    ETrue :: EFalse
       :: (List.map (fun e1' => EEq e1' e2) (shrink_exp_typed TNat e1))
       ++ (List.map (fun e2' => EEq e1 e2') (shrink_exp_typed TNat e2))
  | ELe e1 e2 =>
    ETrue :: EFalse :: (EEq e1 e2)
       :: (List.map (fun e1' => ELe e1' e2) (shrink_exp_typed TNat e1))
       ++ (List.map (fun e2' => ELe e1 e2') (shrink_exp_typed TNat e2))
  | ENot e =>
    ETrue :: EFalse :: e :: (List.map ENot (shrink_exp_typed T e))
  | EAnd e1 e2 =>
    ETrue :: EFalse :: e1 :: e2
       :: (List.map (fun e1' => EAnd e1' e2) (shrink_exp_typed TBool e1))
       ++ (List.map (fun e2' => EAnd e1 e2') (shrink_exp_typed TBool e2))
  end.

(** As we saw for generators, we can also perform sanity checks on our
    shrinkers.  Here, when the shrinker is applied to an expression of
    a given type, all of its results should have the same type. *)

Definition shrink_typed_has_type :=
  let num_vars := 4 in
  let top_level_size := 3 in
  forAll (gen_context num_vars) (fun Gamma =>
  forAll arbitrary (fun T =>
  forAll (gen_exp_typed_sized top_level_size Gamma T) (fun me =>
  match me with
  | Some e =>
    List.forallb (fun e' => (has_type Gamma e' T)?) (shrink_exp_typed T e)
  | _ => false
  end))).

(* QuickChick shrink_typed_has_type. *)

(* ================================================================= *)
(** ** Back to Soundness *)
(** To lift the shrinker to optional expressions, QuickChick provides
    the following function. *)

Definition lift_shrink {A}
              (shr : A -> list A) (m : option A)
           : list (option A) :=
  match m with
  | Some x => List.map Some (shr x)
  | _ => []
  end.

(** Armed with shrinking, we can pinpoint the bug in the [EAnd] branch
    of the evaluator. *)

Definition expression_soundness_exec' :=
  let num_vars := 4 in
  let top_level_size := 3 in
  forAll (gen_context num_vars)  (fun Gamma =>
  forAll (gen_well_typed_state Gamma) (fun st =>
  forAll arbitrary (fun T =>
  forAllShrink (gen_exp_typed_sized 3 Gamma T)
               (lift_shrink (shrink_exp_typed T))
               (fun me =>
  match me with
  | Some e => negb (isNone (eval st e))
  | _ => true
  end)))).

(* QuickChick expression_soundness_exec'. *)
(**

     ===>
        QuickChecking expression_soundness_exec'
        [(1,TNat), (2,TNat), (3,TNat), (4,TBool)]
        [(1,VNat 0), (2,VNat 0), (3,VNat 0), (4,VBool false)]
        TBool
        Some EAnd ETrue ETrue
        *** Failed after 8 tests and 1 shrinks. (0 discards)
*)

(* ################################################################# *)
(** * Well-Typed Programs *)

(** Now we're ready to introduce TImp commands; they are just like the
    ones in Imp. *)

Inductive com : Type :=
  | CSkip  : com
  | CAss   : id  -> exp -> com
  | CSeq   : com -> com -> com
  | CIf    : exp -> com -> com -> com
  | CWhile : exp -> com -> com.

Notation "'SKIP'" :=
  CSkip.
Notation "x '::=' a" :=
  (CAss x a) (at level 60).
Notation "c1 ;;; c2" :=
  (CSeq c1 c2) (at level 80, right associativity).
Notation "'WHILE' b 'DO' c 'END'" :=
  (CWhile b c) (at level 80, right associativity).
Notation "'IFB' c1 'THEN' c2 'ELSE' c3 'FI'" :=
  (CIf c1 c2 c3) (at level 80, right associativity).

Derive Show for com.

(** (Of course, the derived [Show] instance is not going to use these
    notations!) *)

(** We can now define what it means for a command to be well typed
    for a given context. The interesting cases are [TAss] and [TIf]/[TWhile].
    The first one, ensures that the type of the variable we are
    assigning to is the same as that of the expression. The latter,
    requires that the conditional is indeed a boolean expression.
 *)

Inductive well_typed_com : context -> com -> Prop :=
  | TSkip : forall Gamma, well_typed_com Gamma CSkip
  | TAss  : forall Gamma x e T,
      bound_to Gamma x T ->
      Gamma ||- e \IN T ->
      well_typed_com Gamma (CAss x e)
  | TSeq  : forall Gamma c1 c2,
      well_typed_com Gamma c1 -> well_typed_com Gamma c2 ->
      well_typed_com Gamma (CSeq c1 c2)
  | TIf : forall Gamma b c1 c2,
      Gamma ||- b \IN TBool ->
      well_typed_com Gamma c1 -> well_typed_com Gamma c2 ->
      well_typed_com Gamma (CIf b c1 c2)
  | TWhile : forall Gamma b c,
      Gamma ||- b \IN TBool -> well_typed_com Gamma c ->
      well_typed_com Gamma (CWhile b c).

(* ================================================================= *)
(** ** Decidable instance for well-typed. *)

(** A couple of lemmas and a custom tactic will help the decidability
    proof... *)

Lemma bind_deterministic Gamma x (T1 T2 : ty) :
  bound_to Gamma x T1 -> bound_to Gamma x T2 ->
  T1 = T2.
Proof.
  destruct T1; destruct T2; intros H1 H2; eauto;
    inversion H1; inversion H2; congruence.
Qed.

Lemma has_type_deterministic Gamma e (T1 T2 : ty) :
  has_type e Gamma T1 -> has_type e Gamma T2 ->
  T1 = T2.
Proof.
  destruct T1; destruct T2; intros H1 H2; eauto;
    inversion H1; inversion H2; subst; eauto; try congruence;
  inversion H7; subst;
    eapply bind_deterministic; eauto.
Qed.

Ltac solve_det :=
  match goal with
  | [ H1 : bound_to _ _ ?T1 ,
      H2 : bound_to _ _ ?T2 |- _ ] =>
    assert (T1 = T2) by (eapply bind_deterministic; eauto)
  | [ H1 : has_type _ _ ?T1 ,
      H2 : has_type _ _ ?T2 |- _ ] =>
    assert (T1 = T2) by (eapply bind_deterministic; eauto)
  end.

(** Now, here is a brute-force decision procedure for the typing
    relation (which amounts to a simple typechecker). *)

Instance dec_well_typed_com (Gamma : context) (c : com)
  : Dec (well_typed_com Gamma c).
Proof with eauto.
  constructor. unfold ssrbool.decidable.
  induction c; solve_sum.
  - destruct (dec_bound_to Gamma i TNat); destruct dec;
    destruct (dec_has_type e Gamma TNat); destruct dec;
    destruct (dec_bound_to Gamma i TBool); destruct dec;
    destruct (dec_has_type e Gamma TBool); destruct dec; solve_sum;
    try solve_det; try congruence;
    right; intro Contra; inversion Contra; subst; clear Contra;
    try solve_det; try congruence;
    destruct T; eauto.
  - destruct IHc1; destruct IHc2; subst; eauto; solve_sum.
  - destruct IHc1; destruct IHc2; subst; eauto; solve_sum.
    destruct (dec_has_type e Gamma TBool); destruct dec; solve_sum.
  - destruct IHc;
    destruct (dec_has_type e Gamma TBool); destruct dec; solve_sum.
Qed.

(** **** Exercise: 4 stars (arbitrary_well_typed_com)  *)
(** Write a generator and a shrinker for well_typed programs given
    some context [Gamma].  Write some appropriate sanity checks and
    make sure they give expected results. *)

(* FILL IN HERE *)
(** [] *)

(** To complete the tour of testing for TImp, here is a (buggy??)
    evaluation function for commands given a state. To ensure
    termination, we've included a "fuel" parameter: if it gets to zero
    we return [OutOfGas], signifying that we're not sure if evaluation
    would have succeeded, failed, or diverged if we'd gone on
    evaluating. *)

Inductive result :=
| Success : state -> result
| Fail : result
| OutOfGas : result.

Fixpoint ceval (fuel : nat) (st : state) (c : com) : result :=
  match fuel with
  | O => OutOfGas
  | S fuel' =>
    match c with
    | SKIP =>
        Success st
    | x ::= e =>
        match eval st e with
        | Some v => Success (map_set st x v)
        | _ => Fail
        end
    | c1 ;;; c2 =>
        match ceval fuel' st c1 with
        | Success st' =>  ceval fuel' st' c2
        | _ => Fail
        end
    | IFB b THEN c1 ELSE c2 FI =>
      match eval st b with
      | Some (VBool b) =>
        ceval fuel' st (if b then c1 else c2)
      | _ => Fail
      end
    | WHILE b DO c END =>
      match eval st b with
      | Some (VBool b') =>
        if b'
          then ceval fuel' st (c ;;; WHILE b DO c END)
          else Success st
      | _ => Fail
      end
    end
  end.

Definition isFail r :=
  match r with
  | Fail => true
  | _ => false
  end.

(** _Type soundness_: well-typed commands never fail. *)

Conjecture well_typed_state_never_stuck :
  forall Gamma st, well_typed_state Gamma st ->
  forall c, well_typed_com Gamma c ->
  forall fuel, isFail (ceval fuel st c) = false.

(** **** Exercise: 4 stars (well_typed_state_never_stuck)  *)
(** Write a checker for the above property, find any bugs, and fix them. *)

(* FILL IN HERE *)

(** **** Exercise: 4 stars (ty_eq_polymorphic)  *)
(** In the [has_type] relation we allowed equality checks between
    only arithmetic expressions. Introduce an additional typing
    rule that allows for equality checks between booleans.

    | Ty_Eq : forall Gamma e1 e2,
        Gamma ||- e1 \IN TBool -> Gamma ||- e2 \IN TBool ->
        Gamma ||- EEq e1 e2 \IN TBool

   Make sure you also update the evaluation relation to
   compare boolean values. Update the generators and shrinkers
   accordingly to find counterexamples to the buggy properties
   above.

   HINT: When updating the shrinker, you will need to
   come up with the type of the equated expressions. The
   [Dec] instance of [has_type] will come in handy.
*)

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

(** QuickChick is under very active development.  Our vision is that
    it should automate most of the tedious parts of testing, while
    retaining full customizability.

    We close this case study with a brief demo of some things it can
    do now. *)

(** Recall the [has_type_value] property and its corresponding generator:

  Inductive has_type_value : value -> ty -> Prop :=
    | TyVNat  : forall n, has_type_value (VNat  n) TNat
    | TyVBool : forall b, has_type_value (VBool b) TBool.

  Definition gen_typed_value (T : ty) : G value :=
    match T with
    | TNat  => n <- arbitrary;; ret (VNat n)
    | TBool => b <- arbitrary;; ret (VBool b)
    end.

    QuickChick includes a derivation mechanism that can _automatically_
    produce such generators -- i.e., generators for data structures
    satisfying inductively defined properties! *)

Derive ArbitrarySizedSuchThat for (fun v => has_type_value v T).
(** ===>
  GenSizedSuchThathas_type_value is defined. *)

(** Let's take a closer look at what is being generated (after
    doing some renaming and reformatting). *)

Print GenSizedSuchThathas_type_value.
(**
     ===>
       GenSizedSuchThathas_type_value = fun T : ty =>
       {| arbitrarySizeST :=
          let fix aux_arb (size0 : nat) (T : ty) {struct size0}
                : G (option value) :=
            match size0 with
            | 0 => backtrack [(1, match T with
                                  | TBool => ret None
                                  | TNat => n <- arbitrary;;
                                            ret (Some (VNat n))
                                  end)
                             ;(1, match T with
                                  | TBool => b <- arbitrary;;
                                             ret (Some (VBool b)))
                                  | TNat => ret None
                                  end)]
            | S _ => backtrack [(1, match T with
                                    | TBool => ret None
                                    | TNat => n <- arbitrary;;
                                              ret (Some (VNat n))
                                    end)
                               ;(1, match T with
                                    | TBool => b <- arbitrary;;
                                               ret (Some (VBool b)))
                                    | TNat => ret None
                                    end)]
            end in
            fun size0 : nat => aux_arb size0 T |}

       : forall T : ty,
           GenSizedSuchThat value
               (fun v => has_type_value v T)
*)

(** This is a rather more verbose version of the [gen_typed_value]
    generator, but the end result is actually exactly the same
    distribution! *)

(* ================================================================= *)
(** ** (More) Typeclasses for Generation *)

(** QuickChick provides typeclasses for automating the generation
    for data satisfying predicates. *)

Module GenSTPlayground.

(** A variant that takes a size,... *)

Class GenSizedSuchThat (A : Type) (P : A -> Prop) :=
  { arbitrarySizeST : nat -> G (option A) }.

(** ...an unsized variant,... *)

Class GenSuchThat (A : Type) (P : A -> Prop) :=
  { arbitraryST : G (option A) }.

(** ...convenient notation,... *)

Notation "'genST' x" := (@arbitraryST _ x _) (at level 70).

(** ...and a coercion between the two: *)

Instance GenSuchThatOfBounded (A : Type) (P : A -> Prop)
         (H : GenSizedSuchThat A P)
  : GenSuchThat A P :=
  { arbitraryST := sized arbitrarySizeST }.

End GenSTPlayground.

(* ================================================================= *)
(** ** Using "SuchThat" Typeclasses *)

(** QuickChick can now (ab)use the typeclass resolution mechanism to
    perform a bit of black magic: *)

Conjecture conditional_prop_example :
  forall (x y : nat), x = y -> x = y.

(* QuickChick conditional_prop_example. *)
(**
  ==>
    QuickChecking conditional_prop_example
    +++ Passed 10000 tests (0 discards)
*)

(** Notice the "0 discards": that means that quickchick is using
    generators that produce [x] and [y] such that [x = y]! *)

(* ################################################################# *)
(** * Acknowledgements *)

(** The first version of this material was developed in collaboration
    with Nicolas Koh. *)

(* Tue Oct 9 11:47:31 EDT 2018 *)


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e291m19_6limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition freeze :
  { freeze : feBW_tight -> feBW_limbwidths
  | forall a, phiBW_limbwidths (freeze a) = phiBW_tight a }.
Proof.
  Set Ltac Profiling.
  Time synthesize_freeze ().
  Show Ltac Profile.
Time Defined.

Print Assumptions freeze.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e291m19_5limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition freeze :
  { freeze : feBW_tight -> feBW_limbwidths
  | forall a, phiBW_limbwidths (freeze a) = phiBW_tight a }.
Proof.
  Set Ltac Profiling.
  Time synthesize_freeze ().
  Show Ltac Profile.
Time Defined.

Print Assumptions freeze.


Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.Logic.Classical_Prop.
Require Import Coq.Logic.Classical_Pred_Type.
Require Import Logic.lib.Bijection.
Require Import Logic.lib.Countable.
Require Import Logic.GeneralLogic.Base.
Require Import Logic.GeneralLogic.KripkeModel.
Require Import Logic.GeneralLogic.ProofTheory.BasicSequentCalculus.
Require Import Logic.GeneralLogic.Semantics.Kripke.
Require Import Logic.GeneralLogic.Complete.ContextProperty.
Require Import Logic.GeneralLogic.Complete.ContextProperty_Kripke.
Require Import Logic.MinimumLogic.Syntax.
Require Import Logic.MinimumLogic.ProofTheory.Minimum.
Require Import Logic.MinimumLogic.Semantics.Trivial.
Require Import Logic.MinimumLogic.Complete.ContextProperty_Kripke.
Require Import Logic.PropositionalLogic.Syntax.
Require Import Logic.PropositionalLogic.ProofTheory.Intuitionistic.
Require Import Logic.PropositionalLogic.ProofTheory.DeMorgan.
Require Import Logic.PropositionalLogic.ProofTheory.GodelDummett.
Require Import Logic.PropositionalLogic.ProofTheory.Classical.
Require Import Logic.PropositionalLogic.Semantics.Trivial.
Require Import Logic.PropositionalLogic.Complete.ContextProperty_Kripke.
Require Import Logic.PropositionalLogic.Complete.ContextProperty_Trivial.
Require Import Logic.PropositionalLogic.Complete.ContextProperty_Kripke.
Require Import Logic.PropositionalLogic.Complete.ContextProperty_Trivial.

Local Open Scope logic_base.
Local Open Scope syntax.
Local Open Scope kripke_model.
Import PropositionalLanguageNotation.
Import KripkeModelFamilyNotation.
Import KripkeModelNotation_Intuitionistic.

Section TruthLemma.

Context {L: Language}
        {minL: MinimumLanguage L}
        {andpL: AndLanguage L}
        {orpL: OrLanguage L}
        {falsepL: FalseLanguage L}
        {negpL: NegLanguage L}
        {iffpL: IffLanguage L}
        {truepL: TrueLanguage L}
        {Gamma: Derivable L}
        {bSC: BasicSequentCalculus L Gamma}
        {minSC: MinimumSequentCalculus L Gamma}
        {andpSC: AndSequentCalculus L Gamma}
        {orpSC: OrSequentCalculus L Gamma}
        {falsepSC: FalseSequentCalculus L Gamma}
        {inegpSC: IntuitionisticNegSequentCalculus L Gamma}
        {iffpSC: IffSequentCalculus L Gamma}
        {truepSC: TrueSequentCalculus L Gamma}
        {cpSC: ClassicalSequentCalculus L Gamma}
        {MD: Model}
        {kMD: KripkeModel MD}
        {M: Kmodel}
        {SM: Semantics L MD}
        {tminSM: TrivialMinimumSemantics L MD SM}
        {andpSM: AndSemantics L MD SM}
        {orpSM: OrSemantics L MD SM}
        {falsepSM: FalseSemantics L MD SM}
        {truepSM: TrueSemantics L MD SM}
        {iffpSM: IffSemantics L MD SM}
        {negpSM: NegSemantics L MD SM}.

Context (cP: context -> Prop)
        (rel: bijection (Kworlds M) (sig cP)).

Context (AL_MC: at_least (maximal consistent) cP).

Lemma truth_lemma_falsep:
  forall m Phi, rel m Phi -> (KRIPKE: M, m |= falsep <-> proj1_sig Phi falsep).
Proof.
  intros.
  rewrite sat_falsep.
  pose proof proj2_sig Phi.
  pose proof proj1 (AL_MC _ H0).
  rewrite consistent_spec in H1.
  split; [intros [] |].
  intro; apply H1.
  apply derivable_assum; auto.
Qed.

Lemma truth_lemma_andp
      (x y: expr)
      (IHx: forall m Phi, rel m Phi -> (KRIPKE: M, m |= x <-> proj1_sig Phi x))
      (IHy: forall m Phi, rel m Phi -> (KRIPKE: M, m |= y <-> proj1_sig Phi y)):
  forall m Phi, rel m Phi -> (KRIPKE: M, m |= x && y <-> proj1_sig Phi (x && y)).
Proof.
  intros.
  rewrite sat_andp.
  rewrite MCS_andp_iff by (apply AL_MC, (proj2_sig Phi)).
  apply Morphisms_Prop.and_iff_morphism; auto.
Qed.

Lemma truth_lemma_orp
      (x y: expr)
      (IHx: forall m Phi, rel m Phi -> (KRIPKE: M, m |= x <-> proj1_sig Phi x))
      (IHy: forall m Phi, rel m Phi -> (KRIPKE: M, m |= y <-> proj1_sig Phi y)):
  forall m Phi, rel m Phi -> (KRIPKE: M, m |= x || y <-> proj1_sig Phi (x || y)).
Proof.
  intros.
  rewrite sat_orp.
  rewrite MCS_orp_iff by (apply AL_MC, (proj2_sig Phi)).
  apply Morphisms_Prop.or_iff_morphism; auto.
Qed.

Lemma truth_lemma_impp
      (x y: expr)
      (IHx: forall m Phi, rel m Phi -> (KRIPKE: M, m |= x <-> proj1_sig Phi x))
      (IHy: forall m Phi, rel m Phi -> (KRIPKE: M, m |= y <-> proj1_sig Phi y)):
  forall m Phi, rel m Phi -> (KRIPKE: M, m |= x --> y <-> proj1_sig Phi (x --> y)).
Proof.
  intros.
  rewrite sat_impp.
  rewrite MCS_impp_iff by (apply AL_MC, (proj2_sig Phi)).
  apply Morphisms_Prop.iff_iff_iff_impl_morphism; auto.
Qed.

Lemma truth_lemma_negp
      (x: expr)
      (IHx: forall m Phi, rel m Phi -> (KRIPKE: M, m |= x <-> proj1_sig Phi x)):
  forall m Phi, rel m Phi -> (KRIPKE: M, m |= ~~ x <-> proj1_sig Phi (~~ x)).
Proof.
  intros.
  rewrite sat_negp.
  rewrite IHx by eassumption.
  pose proof MCS_negp_iff.
  rewrite MCS_negp_iff by (apply AL_MC, (proj2_sig Phi)).
  tauto.
Qed.

End TruthLemma.