Require Export Coercion_Defs.
Require Import Classical.

(* ******************************************************************************** *)
(* Lemmas about opening *)
(* ******************************************************************************** *)

Lemma open_idempotent : forall x e n,
  (open_exp n (exp_fvar x) (open_exp n (exp_fvar x) e)) = (open_exp n (exp_fvar x) e).
Proof.
intros.
generalize dependent n. generalize dependent x.
induction e.
Case "base". intros. simpl. eauto.
Case "bvar". intros. simpl.
  destruct (n0===n). simpl. eauto.
  simpl. destruct (n0===n); try contradiction || subst; eauto.
Case "fvar". intros. simpl. eauto.
Case "cast". intros. simpl. rewrite (IHe x n). eauto.
Case "abs". intros. simpl. rewrite (IHe x (S n)). eauto.
Case "app". intros. simpl. rewrite (IHe1 x n). rewrite (IHe2 x n). eauto.
Case "pair". intros. simpl. rewrite (IHe1 x n). rewrite (IHe2 x n). eauto.
Case "proj". intros. simpl. rewrite (IHe x n). eauto.
Qed.

Inductive lc : nat -> exp -> Prop :=
| lc_bvar : forall n m, m < n -> lc n (exp_bvar m)
| lc_var : forall a n, lc n (exp_fvar a)
| lc_base : forall a n, lc n (exp_base a)
| lc_cast : forall e n t, lc n e -> lc n (exp_cast e t)
| lc_app : forall e1 e2 n, lc n e1 -> lc n e2 -> lc n (exp_app e1 e2)
| lc_pair :  forall e1 e2 n, lc n e1 -> lc n e2 -> lc n (exp_pair e1 e2)
| lc_proj : forall e n a, lc n e -> lc n (exp_proj a e)
| lc_abs : forall e n t, lc (S n) e -> lc n (exp_lam t e).

Lemma open_inverse_lc : forall e x n,
  (lc n e) ->
  exists e', e = (open_exp n (exp_fvar x) e') /\
    (forall f, freevars e' f -> x `notin` f).
Proof.
intros. rename H into lcn.
generalize dependent n.
induction e.
Case "base".
exists (exp_base a).
split.
  simpl; eauto.
  intros. inversion H. eauto.
Case "bvar".
intros.
inversion lcn. subst.
exists (exp_bvar n). simpl.
   split.
   destruct (n0 === n).
      SCase "n0 = n".
       simpl. eauto.  subst.  assert False. omega. destruct H.
      SCase "n0 <> n". eauto.
   intros. inversion H. eauto.
Case "fvar".
intros.
destruct (classic (a=x)).
  SCase "a=x".
   subst.
   exists (exp_bvar n).
   split.  simpl.  destruct (n===n). eauto. destruct n0.  eauto.
   intros. inversion H. subst. fsetdec.
  SCase "a<>x".
    exists (exp_fvar a).
    simpl. intuition. inversion H0. subst.
    fsetdec.
Case "cast".
intros.
inversion lcn. subst.
destruct (IHe _ H1) as [e' [e'_eq fvs]].
subst. exists (exp_cast e' t). simpl.
split. eauto.
intros. eapply fvs. inversion H. eauto.
Case "lam".
intros.
inversion lcn. subst.
destruct (IHe _ H1) as [e_body [e_body_eq fvs]].
(* destruct (increase_bvar_index e_body' x 0) as [e_body [e_body_eq fvs]]. *)
exists (exp_lam t e_body).
split.
simpl. simpl in e_body_eq. subst. simpl. f_equal.
intros. inversion H. subst. eapply fvs; eauto.
Case "app".
intros.
inversion lcn. subst.
destruct (IHe1 _ H2) as [e1' [e1'_eq fvs1]].
destruct (IHe2 _ H3) as [e2' [e2'_eq fvs2]].
subst. exists (exp_app e1' e2'). simpl.
split. eauto.
intros. inversion H. subst.
assert (x `notin` fvs0). eapply fvs1; eauto.
assert (x `notin` fvs3). eapply fvs2; eauto.
fsetdec.
Case "pair".
intros.
inversion lcn. subst.
destruct (IHe1 _ H2) as [e1' [e1'_eq fvs1]].
destruct (IHe2 _ H3) as [e2' [e2'_eq fvs2]].
subst. exists (exp_pair e1' e2'). simpl.
split. eauto.
intros. inversion H. subst.
assert (x `notin` fvs0). eapply fvs1; eauto.
assert (x `notin` fvs3). eapply fvs2; eauto.
fsetdec.
Case "proj".
intros.
inversion lcn. subst.
destruct (IHe _ H1) as [e1' [e1'_eq fvs1]].
subst. exists (exp_proj i e1'). simpl.
split. eauto.
intros. inversion H. subst. eapply fvs1; eauto.
Qed.

Hint Constructors lc.

Lemma open_lc : forall n e x,
  lc n (open_exp n (exp_fvar x) e) ->
  lc (S n) e.
intros. generalize dependent n.
induction e;  try solve [intros; inversion H; subst; simpl; firstorder || eauto].
Case "bvar". intros.
simpl in H. destruct (n0===n). subst. eauto.
  inversion H. subst.
  constructor. omega.
Qed.

Lemma coercion_lc : forall sigma pi a t d t' m,
  (coercion sigma pi a t d t' m) -> forall n, lc n m.
Proof.
intros. generalize dependent n.
induction H.
 try repeat  (constructor; omega || firstorder).
 unfold compose. try repeat  (constructor; omega || firstorder).
 intros.  unfold compose.  unfold funcompose. try repeat  (constructor; omega || firstorder).
 intros.  unfold compose.  unfold paircompose. try repeat  (constructor; omega || firstorder).
Qed.

Lemma coerce_disjunct : forall m e,
  (coerce m e) = e \/ (coerce m e) = (exp_app m e).
Proof.
intros m e.
case_eq m; unfold coerce; simpl; intuition.
case_eq e0; simpl; intuition.
case_eq n; simpl; intuition.
Qed.

Lemma coerce_non_identity : forall m e,
  (forall t, m <> (id t)) -> (coerce m e) = (exp_app m e).
Proof.
intros m e m_neq_id.
case_eq m; unfold coerce; simpl; intuition.
case_eq e0; simpl; intuition.
case_eq n; simpl; intuition.
subst. unfold id in m_neq_id. destruct (m_neq_id t (refl_equal _)).
Qed.

Lemma lc_coerce: forall m e n,
  (lc n m) -> (lc n e) -> (lc n (coerce m e)).
Proof.
intros.
destruct (coerce_disjunct m e); rewrite H1; eauto || constructor.
Qed.

Lemma typing_lc: forall sigma gamma e e' t d d',
  nd_typing sigma gamma d d' e e' t ->
  (lc 0 e').
Proof.
intros. rename H into T.
induction T; try solve [intros; try unfold coerciongen in *; try constructor; eauto using coercion_lc, lc_coerce || discriminate].
Case "lam".
constructor. simpl. pick fresh x. assert (x `notin` L). fsetdec.
pose proof (H0 _  H1).
eauto using open_lc.
Qed.

Lemma open_inverse_nd : forall sigma gamma e x tx e' t d d',
  ok sigma -> ok ([(x,tx)]++gamma) ->
  nd_typing sigma ([(x,tx)]++gamma) d d' e e' t ->
  (exists e0, (e' = (open_exp 0 (exp_fvar x) e0)) /\ (forall f, freevars e0 f -> x `notin` f)).
Proof.
intros. eauto using typing_lc, open_inverse_lc.
Qed.

Lemma open_exp_injection : forall e1 e2 y n fv1 fv2,
  (freevars e1 fv1) ->
  (freevars e2 fv2) ->
  (y `notin` fv1) ->
  (y `notin` fv2) ->
  (open_exp n (exp_fvar y) e1) = (open_exp n (exp_fvar y) e2) ->
  e1 = e2.
Proof.
intros e1 e2 y n fv1 fv2 freevars1 freevars2 y_notin_1 y_notin_2 eq.
generalize dependent n.
generalize dependent e2.
generalize dependent fv1.
generalize dependent fv2.
induction e1.
Case "base".
intros.
simpl in eq.
induction e2; simpl in eq; subst; try eauto || discriminate || (destruct (n===n0); subst; discriminate).
Case "bvar".
intros. simpl in eq.
induction e2.
 SCase "e2 base".
 destruct (n0===n); subst; discriminate.
 SCase "e2 bvar".
 simpl in eq.
  destruct (n0===n1) as [n0_eq_n1 | n0_neq_n1].
     SSCase "n0_eq_n1".
       subst.
       destruct (n1===n) as [n1_eq_n | n1_neq_n].
         subst. eauto.
         discriminate.
     SSCase "n0_neq_n1".
        destruct (n0===n); subst; eauto || discriminate.
 SCase "e2 fvar".
   simpl in eq.
   destruct (n0===n).
      subst. assert (y=a). injection eq; intuition.
   subst. inversion freevars2. subst. fsetdec. eauto.
 destruct (n0===n); subst; discriminate.
 destruct (n0===n); subst; discriminate.
 destruct (n0===n); subst; discriminate.
 destruct (n0===n); subst; discriminate.
 destruct (n0===n); subst; discriminate.
Case "fvar".
 intros.
 simpl in eq.
 induction e2; simpl in eq; try eauto || destruct (n===n0); subst; try discriminate || eauto.
 assert (y=a). injection eq; intuition.
  subst. inversion freevars1. subst. fsetdec. eauto.
Case "Cast".
 intros.
 simpl in eq.
 induction e2; simpl in eq; try eauto || destruct (n===n0); subst; try discriminate || eauto.
 inversion freevars1. subst.
 injection eq;  intros. subst.
 inversion freevars2. subst.
 assert (e1 = e2). eapply (IHe1 fv2); eauto. subst; auto.
Case "Abs".
 intros.
 simpl in eq.
 induction e2; simpl in eq; try eauto || destruct (n===n0); subst; try discriminate || eauto.
 inversion freevars1. subst.
 firstorder.
 injection eq. intros. subst.
 inversion freevars2. subst.
 assert (e1 = e2). eapply (IHe1 fv2); eauto. subst; eauto.
Case "App".
 intros.
 simpl in eq.
 induction e2; simpl in eq; try eauto || destruct (n===n0); subst; try discriminate || eauto.
 inversion freevars1. subst.
 injection eq. intros. subst.
 inversion freevars2. subst.
 assert (e1_1 = e2_1). eapply (IHe1_1 fvs0); try fsetdec || eauto.
 assert (e1_2 = e2_2). eapply (IHe1_2 fvs3); try fsetdec || eauto.
 subst. eauto.
Case "Pair".
 intros.
 simpl in eq.
 induction e2; simpl in eq; try eauto || destruct (n===n0); subst; try discriminate || eauto.
 inversion freevars1. subst.
 injection eq. intros. subst.
 inversion freevars2. subst.
 assert (e1_1 = e2_1). eapply (IHe1_1 fvs0); try fsetdec || eauto.
 assert (e1_2 = e2_2). eapply (IHe1_2 fvs3); try fsetdec || eauto.
 subst. eauto.
Case "Proj".
 intros.
 simpl in eq.
 induction e2; simpl in eq; try eauto || destruct (n===n0); subst; try discriminate || eauto.
 inversion freevars1. subst.
 injection eq. intros. subst.
 inversion freevars2. subst.
 assert (e1 = e2). eapply (IHe1 fv2); try fsetdec || eauto.
 subst. eauto.
Qed.

Lemma freevars_totality : forall e, exists fvs, freevars e fvs.
Proof.
intros.
induction e.
Case "base".
exists AtomSet.F.empty. constructor.
Case "bvar".
exists AtomSet.F.empty. constructor.
Case "fvar".
exists (singleton a). constructor.
Case "cast".
destruct IHe as [fvse].
exists fvse; constructor; eauto.
Case "lam".
destruct IHe as [fvse].
exists fvse; constructor; eauto.
Case "app".
destruct IHe1 as [fvse1].
destruct IHe2 as [fvse2].
exists (fvse1 `union` fvse2); constructor; eauto.
Case "pair".
destruct IHe1 as [fvse1].
destruct IHe2 as [fvse2].
exists (fvse1 `union` fvse2); constructor; eauto.
Case "proj".
destruct IHe as [fvse].
exists fvse; constructor; eauto.
Qed.

Lemma binds_id : forall x (t1:typ) t2 G,
  ok G ->
  binds x t1 G ->
  binds x t2 G ->
  (t1 = t2).
Proof.
intros.
induction G.
Case "G is nil".
inversion H0.
Case "G is cons".
rewrite_env ([a] ++ G) in H0.
destruct (binds_concat_inv _ _ _ _ _ H0) as [[xNotinA xinG] | xinA].
SCase "xinG".
rewrite_env ([a] ++ G) in H1.
destruct (binds_concat_inv _ _ _ _ _ H1) as [[xNotinA' xinG'] | xinA'].
SSCase "xinG'".
eapply IHG; try inversion H; eauto.
SSCase "xinA'".
pose proof (binds_In _ _ _ _ xinA'). contradiction.
SCase "xinA".
rewrite_env ([a] ++ G) in H1.
destruct (binds_concat_inv _ _ _ _ _ H1) as [[xNotinA' xinG'] | xinA'].
SSCase "xinG'".
pose proof (binds_In _ _ _ _ xinA). contradiction.
SSCase "xinA".
induction a.
destruct (binds_singleton_inv _ _ _ _ _ xinA) as [ A B].
destruct (binds_singleton_inv _ _ _ _ _ xinA') as [ C D].
subst. auto.
Qed.

Lemma opening_preserves_identity : forall x i e1 e2 fvs1 fvs2,
  (freevars e1 fvs1) ->
  (freevars e2 fvs2) ->
  (x `notin` fvs1) -> (x `notin` fvs2) ->
  ((open_exp i (exp_fvar x) e1) = (open_exp i (exp_fvar x) e2)) -> e1 = e2.
Proof.
Lemma freevar_neq : forall x e fvs,
  (freevars e fvs) ->
  (x `notin` fvs) ->
  (exp_fvar x) <> e.
Proof.
intros.
induction e;
  try discriminate ||
    inversion H. subst fvs. assert (x <> a); [fsetdec | injection; auto].
Qed.
intros.
generalize dependent e2.
generalize dependent i.
generalize dependent fvs1.
generalize dependent fvs2.
induction e1.
Case "exp_base".
  intros.
  assert ((exp_fvar x) <> e2) as Neq2. eauto using freevar_neq.
  induction e2; simpl open_exp in H3; (auto || discriminate ||  (destruct (i===n); [subst; discriminate | auto])).
Case "exp_bvar".
  intros.
  induction e2.
  SCase "exp_base".
  simpl open_exp in H3.
  destruct (i===n). subst. discriminate. auto.
  SCase "exp_bvar".
  simpl open_exp in H3.
  destruct (i===n). destruct (i===n0). subst. subst. auto.
  discriminate.
  destruct (i===n0);
  auto. discriminate.
  SCase "exp_fvar".
  simpl open_exp in H3.
  destruct (i===n).
  assert ((exp_fvar x) <> (exp_fvar a)) as Neq2. eauto using freevar_neq.
  destruct Neq2. auto. auto.
  SCase "exp_cast".
  simpl open_exp in H3.
  destruct (i===n); discriminate H3.
  SCase "exp_lam".
  simpl open_exp in H3.
  destruct (i===n); discriminate H3.
  SCase "exp_app".
  simpl open_exp in H3.
  destruct (i===n); discriminate H3.
  SCase "exp_pair".
  simpl open_exp in H3.
  destruct (i===n); discriminate H3.
  SCase "exp_proj".
  simpl open_exp in H3.
  destruct (i===n); discriminate H3.
Case "exp_fvar".
  intros.
  assert ((exp_fvar x) <> (exp_fvar a)) as Neq1. eauto using freevar_neq.
  induction e2; simpl open_exp in H3; (auto || discriminate ||  (destruct (i===n); [subst; destruct Neq1; auto | auto])).
Case "exp_cast".
  induction e2.
  SCase "exp_base".
   intros.
   simpl open_exp in H3; (auto || discriminate ||  (destruct (i===n); [subst; discriminate | auto])).
  SCase "exp_bvar".
  intros.
  simpl open_exp in H3.
  destruct (i===n); discriminate H3.
  SCase "exp_fvar".
  intros.
  assert ((exp_fvar x) <> (exp_fvar a)) as Neq1. eauto using freevar_neq.
   simpl open_exp in H3; (auto || discriminate ||  (destruct (i===n); [subst; destruct Neq1; auto | auto])).
  SCase "exp_cast".
  intros.
  simpl open_exp in H3.
  injection H3. intros bodyEq tEq.
  inversion H. inversion H0.
  assert (e1=e2) as fromIH.
  eapply (IHe1 fvs2); eauto || fsetdec.
  subst. auto.
  SCase "exp_lam".
   intros.
   simpl open_exp in H3; (auto || discriminate ||  (destruct (i===n); [subst; discriminate | auto])).
  SCase "exp_app".
   intros.
   simpl open_exp in H3; (auto || discriminate ||  (destruct (i===n); [subst; discriminate | auto])).
  SCase "exp_pair".
   intros.
   simpl open_exp in H3; (auto || discriminate ||  (destruct (i===n); [subst; discriminate | auto])).
  SCase "exp_proj".
   intros.
   simpl open_exp in H3; (auto || discriminate ||  (destruct (i===n); [subst; discriminate | auto])).
Case "exp_lam".
  induction e2.
  SCase "exp_base".
   intros.
   simpl open_exp in H3; (auto || discriminate ||  (destruct (i===n); [subst; discriminate | auto])).
  SCase "exp_bvar".
  intros.
  simpl open_exp in H3.
  destruct (i===n); discriminate H3.
  SCase "exp_fvar".
  intros.
  assert ((exp_fvar x) <> (exp_fvar a)) as Neq1. eauto using freevar_neq.
   simpl open_exp in H3; (auto || discriminate ||  (destruct (i===n); [subst; destruct Neq1; auto | auto])).
  SCase "exp_case".
   intros.
   simpl open_exp in H3; (auto || discriminate ||  (destruct (i===n); [subst; discriminate | auto])).
  SCase "exp_lam".
  intros.
  simpl open_exp in H3.
  injection H3. intros bodyEq tEq.
  inversion H. inversion H0.
  assert (e1=e2) as fromIH.
  eapply (IHe1 fvs2); eauto || fsetdec.
  subst. auto.
  SCase "exp_app".
   intros.
   simpl open_exp in H3; (auto || discriminate ||  (destruct (i===n); [subst; discriminate | auto])).
  SCase "exp_pair".
   intros.
   simpl open_exp in H3; (auto || discriminate ||  (destruct (i===n); [subst; discriminate | auto])).
  SCase "exp_proj".
   intros.
   simpl open_exp in H3; (auto || discriminate ||  (destruct (i===n); [subst; discriminate | auto])).
Case "exp_app".
  induction e2.
   SCase "exp_base".
   intros.
   simpl open_exp in H3; (auto || discriminate ||  (destruct (i===n); [subst; discriminate | auto])).
   SCase "exp_bvar".
   intros.
   simpl open_exp in H3.
   destruct (i===n); discriminate H3.
   SCase "exp_fvar".
   intros.
   simpl open_exp in H3; (auto || discriminate ||  (destruct (i===n); [subst; discriminate | auto])).
   SCase "exp_case".
   intros.
   simpl open_exp in H3; (auto || discriminate ||  (destruct (i===n); [subst; discriminate | auto])).
   SCase "exp_lam".
   intros.
   simpl open_exp in H3; (auto || discriminate ||  (destruct (i===n); [subst; discriminate | auto])).
   SCase "exp_app".
   intros.
   simpl open_exp in H3. injection H3. intros Eq2 Eq1.
   assert (e1_1 = e2_1) as fromIH1.
   inversion H. inversion H0. eapply (IHe1_1 fvs4);  eauto || fsetdec.
   assert (e1_2 = e2_2) as fromIH2.
   inversion H. inversion H0. eapply (IHe1_2 fvs5);  eauto || fsetdec.
   subst. auto.
   SCase "exp_pair".
   intros.
   simpl open_exp in H3; (auto || discriminate ||  (destruct (i===n); [subst; discriminate | auto])).
   SCase "exp_proj".
   intros.
   simpl open_exp in H3; (auto || discriminate ||  (destruct (i===n); [subst; discriminate | auto])).
Case "exp_pair".
  induction e2.
   SCase "exp_base".
   intros.
   simpl open_exp in H3; (auto || discriminate ||  (destruct (i===n); [subst; discriminate | auto])).
   SCase "exp_bvar".
   intros.
   simpl open_exp in H3.
   destruct (i===n); discriminate H3.
   SCase "exp_fvar".
   intros.
   simpl open_exp in H3; (auto || discriminate ||  (destruct (i===n); [subst; discriminate | auto])).
   SCase "exp_case".
   intros.
   simpl open_exp in H3; (auto || discriminate ||  (destruct (i===n); [subst; discriminate | auto])).
   SCase "exp_lam".
   intros.
   simpl open_exp in H3; (auto || discriminate ||  (destruct (i===n); [subst; discriminate | auto])).
   SCase "exp_app".
   intros.
   simpl open_exp in H3; (auto || discriminate ||  (destruct (i===n); [subst; discriminate | auto])).
   SCase "exp_pair".
   intros.
   simpl open_exp in H3. injection H3. intros Eq2 Eq1.
   assert (e1_1 = e2_1) as fromIH1.
   inversion H. inversion H0. eapply (IHe1_1 fvs4);  eauto || fsetdec.
   assert (e1_2 = e2_2) as fromIH2.
   inversion H. inversion H0. eapply (IHe1_2 fvs5);  eauto || fsetdec.
   subst. auto.
   SCase "exp_proj".
   intros.
   simpl open_exp in H3; (auto || discriminate ||  (destruct (i===n); [subst; discriminate | auto])).
Case "exp_proj".
  induction e2.
   SCase "exp_base".
   intros.
   simpl open_exp in H3; (auto || discriminate ||  (destruct (i===n); [subst; discriminate | auto])).
   SCase "exp_bvar".
   intros.
   simpl open_exp in H3.
   destruct (i0===n); discriminate H3.
   SCase "exp_fvar".
   intros.
   simpl open_exp in H3; (auto || discriminate ||  (destruct (i===n); [subst; discriminate | auto])).
   SCase "exp_case".
   intros.
   simpl open_exp in H3; (auto || discriminate ||  (destruct (i===n); [subst; discriminate | auto])).
   SCase "exp_lam".
   intros.
   simpl open_exp in H3; (auto || discriminate ||  (destruct (i===n); [subst; discriminate | auto])).
   SCase "exp_app".
   intros.
   simpl open_exp in H3; (auto || discriminate ||  (destruct (i===n); [subst; discriminate | auto])).
   SCase "exp_pair".
   intros.
   simpl open_exp in H3; (auto || discriminate ||  (destruct (i===n); [subst; discriminate | auto])).
   SCase "exp_proj".
   intros.
   simpl open_exp in H3. injection H3. intros Eq2 Eq1.
   assert (e1 = e2) as fromIH1.
   inversion H. inversion H0. eapply (IHe1 fvs2);  eauto || fsetdec.
   subst. auto.
Qed.

(* ******************************************************************************** *)
(* Common structural properties about coercion generation *)
(* ******************************************************************************** *)

Lemma coercion_pi_strengthening: forall sigma pi pi' t t' C a r,
  coercion sigma pi a t r t' C ->
  (forall b, In b pi' -> In b pi) ->
    coercion sigma pi' a t r t' C.
Proof.
intros until 1. rename H into D1. intro subset.
generalize dependent pi'.
induction D1.
Case "coercion_Id".
intros; eapply coercion_Id; eauto.
Case "coercion_PrimTrans".
intros.
eapply coercion_PrimTrans.
eauto. unfold not; intro contra.
pose proof (subset _ contra). contradiction.
eapply IHD1.
intros b inCons.
destruct (in_inv inCons) as [head | tail].
subst. eauto using in_eq.
eapply in_cons. eauto using subset.
Case "coercion_FunTrans".
intros.
eapply coercion_FunTrans.
unfold not; intro contra.
(* weird ... Coq doesn't like this *)
(* pose proof (subset (typ_fun t1' t2') contra).  *)
assert (In (typ_fun t1' t2') pi).
eauto. contradiction.
auto. auto.
eapply IHD1_3.
intros b inCons.
destruct (in_inv inCons) as [head | tail].
subst. eauto using in_eq.
eapply in_cons. eauto using subset.
Case "coercion_PairTrans".
intros.
eapply coercion_PairTrans.
unfold not; intro contra.
(* weird ... Coq doesn't like this *)
(* pose proof (subset (typ_fun t1' t2') contra).  *)
assert (In (typ_pair t1' t2') pi).
eauto. contradiction.
auto. auto.
eapply IHD1_3.
intros b inCons.
destruct (in_inv inCons) as [head | tail].
subst. eauto using in_eq.
eapply in_cons. eauto using subset.
Qed.

Hint Constructors coercion.
Hint Resolve Permutation_in Permutation_sym Permutation_refl Permutation_trans.

Lemma perm_cons : forall A (t:A) pi pi',
  Permutation pi pi' ->
  Permutation (t::pi) (t::pi').
Proof.
intros.
  change (Permutation ([t]++pi) ([t]++pi')). eauto using Permutation_app_head.
Qed.

Lemma coercion_pi_perm: forall sigma pi pi' a t r t' m,
  (coercion sigma pi a t r t' m) ->
  (Permutation pi pi') ->
  (coercion sigma pi' a t r t' m).
Proof with eauto*.
intros. rename H into C. rename H0 into P.
generalize dependent pi'.
induction C.
Case "id".
intros. eauto.
Case "prim trans".
intros.
eapply coercion_PrimTrans.
  eauto.
  try unfold not; eauto.
  assert (Permutation (t2::pi) (t2::pi')). eauto using perm_cons.
  firstorder.
Case "fun trans".
  intros.
eapply coercion_FunTrans. unfold not; eauto. eauto. eauto.
  assert (Permutation ((typ_fun t1' t2')::pi) ((typ_fun t1' t2')::pi')). eauto using perm_cons.
  firstorder.
Case "pair trans".
  intros.
eapply coercion_PairTrans. unfold not; eauto. eauto. eauto.
  assert (Permutation ((typ_pair t1' t2')::pi) ((typ_pair t1' t2')::pi')). eauto using perm_cons.
  firstorder.
Qed.

(* ******************************************************************************** *)
(* Lemmas about lists *)
(* ******************************************************************************** *)
Lemma in_inv_nodup : forall (A:Type) (a:A) (b:A) (l:list A),
  (In b (a::l)) ->
  (NoDup (a::l)) ->
  ((a=b /\ ~In b l) \/ (a<>b /\ In b l)).
Proof.
intros A a b l Inb_al Nodup.
inversion Nodup. subst x. subst l0.
destruct (in_inv Inb_al) as [aEqb | inTl].
  Case "a=b".
  left. subst b.
  eauto.
  Case "In tl".
  right.
  split.
  unfold not. intro. subst b. contradiction.
  auto.
Qed.

Lemma in_singleton_eq :
forall (A:Type) (a:A) (l:list A) (b:A),
  (In b l) ->
  (NoDup l) ->
  (forall c, In c l -> In c [a]) ->
  l = [a].
Proof.
intros A a l.
induction l.
Case "l nil".
intros.
  contradiction.
Case "l cons".
intros.
assert (a=a0).
 pose proof (H1 a0 (in_eq _ _)).
 inversion H2. auto. destruct H3.
 subst a0.
cut (l=nil). intros. subst l. eauto.
SCase "cut l=nil".
destruct (in_inv_nodup _ _ _ l H H0) as [ [aEqb xx] | [aNeqb  bInl]].
  SSCase "a = b".
   subst b.
   induction l. auto.
   clear IHl0.
   inversion H0. subst x. subst l0.
   assert (forall c:A, In c (a0::l) -> In c [a]).
     intros.
      eapply H1. eapply in_cons. eauto.
   pose proof (IHl a0 (in_eq _ _) H5 H2).
   injection H3. intros. subst a0.
   unfold not in H4. destruct (H4 (in_eq _ _)).
  SSCase "a <> b AND b in L".
  pose proof (H1 b (in_cons _ _ _ bInl)).
  destruct H2. contradiction. destruct H2.
Qed.

Lemma in_singleton_pair : forall (A:Type) (B:Type) (a:A) (b:B) c d,
  In (a,b) [(c,d)] -> a = c /\ b = d.
Proof.
intros.
destruct (in_inv H).
      SSSSCase "in head".
         injection H0. intros. subst a b. auto.
      SSSSCase "silly in nil". contradiction.
Qed.

Lemma in_sing_eq_l : forall (x:exp) (y:typ) a b,
  In (x,y) [(a,b)] ->
  x = a.
Proof.
intros.
destruct (in_inv H).
  injection H0. intros. subst. intuition.
contradiction.
Qed.

Lemma in_sing_eq_r : forall (x:exp) (y:typ) a b,
  In (x,y) [(a,b)] ->
  y = b.
Proof.
intros.
destruct (in_inv H).
  injection H0. intros. subst. intuition.
contradiction.
Qed.

Lemma insingleton : forall (A:Type) (a:A) theta,
  In a theta -> (forall b:A, In b [a] -> In b theta).
  intros. assert (a = b).
  destruct (in_inv H0). subst a. auto. contradiction. subst. auto.
  Qed.

Lemma in_ext : forall (A:Type) (x:A) l l',
  In x l -> In x (l ++ l').
Proof.
intros.
eauto using in_or_app.
Qed.

Lemma in_not_in : forall (A:Type) (x:A) (y:A) l,
  In x l -> ~ In y l -> x <> y.
Proof.
intros. unfold not. intros. subst. contradiction.
Qed.

Lemma not_in_singleton : forall (A:Type) (x:A) y,
  x <> y -> ~In x [y].
intros.
unfold not. intros.
destruct (in_inv H0). subst. destruct H. reflexivity. contradiction.
Qed.


(* -*- coding: utf-8 -*- *)
(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)

(** Binary Integers : results about order predicates *)
(** Initial author : Pierre Crégut (CNET, Lannion, France) *)

(** THIS FILE IS DEPRECATED.
    It is now almost entirely made of compatibility formulations
    for results already present in BinInt.Z. *)

Require Import BinPos BinInt Decidable Zcompare.
Require Import Arith_base. (* Useless now, for compatibility only *)

Local Open Scope Z_scope.

(*********************************************************)
(** Properties of the order relations on binary integers *)

(** * Trichotomy *)

Theorem Ztrichotomy_inf n m : {n < m} + {n = m} + {n > m}.
Proof.
  unfold ">", "<". generalize (Z.compare_eq n m).
  destruct (n ?= m); [ left; right | left; left | right]; auto.
Defined.

Theorem Ztrichotomy n m : n < m \/ n = m \/ n > m.
Proof.
  Z.swap_greater. apply Z.lt_trichotomy.
Qed.

(**********************************************************************)
(** * Decidability of equality and order on Z *)

Notation dec_eq := Z.eq_decidable (only parsing).
Notation dec_Zle := Z.le_decidable (only parsing).
Notation dec_Zlt := Z.lt_decidable (only parsing).

Theorem dec_Zne n m : decidable (Zne n m).
Proof.
  destruct (Z.eq_decidable n m); [right|left]; subst; auto.
Qed.

Theorem dec_Zgt n m : decidable (n > m).
Proof.
  destruct (Z.lt_decidable m n); [left|right]; Z.swap_greater; auto.
Qed.

Theorem dec_Zge n m : decidable (n >= m).
Proof.
  destruct (Z.le_decidable m n); [left|right]; Z.swap_greater; auto.
Qed.

Theorem not_Zeq n m : n <> m -> n < m \/ m < n.
Proof.
  apply Z.lt_gt_cases.
Qed.

(** * Relating strict and large orders *)

Notation Zgt_lt := Z.gt_lt (compat "8.6").
Notation Zlt_gt := Z.lt_gt (compat "8.6").
Notation Zge_le := Z.ge_le (compat "8.6").
Notation Zle_ge := Z.le_ge (compat "8.6").
Notation Zgt_iff_lt := Z.gt_lt_iff (only parsing).
Notation Zge_iff_le := Z.ge_le_iff (only parsing).

Lemma Zle_not_lt n m : n <= m -> ~ m < n.
Proof.
 apply Z.le_ngt.
Qed.

Lemma Zlt_not_le n m : n < m -> ~ m <= n.
Proof.
 apply Z.lt_nge.
Qed.

Lemma Zle_not_gt n m : n <= m -> ~ n > m.
Proof.
  trivial.
Qed.

Lemma Zgt_not_le n m : n > m -> ~ n <= m.
Proof.
  Z.swap_greater. apply Z.lt_nge.
Qed.

Lemma Znot_ge_lt n m : ~ n >= m -> n < m.
Proof.
  Z.swap_greater. apply Z.nle_gt.
Qed.

Lemma Znot_lt_ge n m : ~ n < m -> n >= m.
Proof.
  trivial.
Qed.

Lemma Znot_gt_le n m: ~ n > m -> n <= m.
Proof.
  trivial.
Qed.

Lemma Znot_le_gt n m : ~ n <= m -> n > m.
Proof.
  Z.swap_greater. apply Z.nle_gt.
Qed.

Lemma not_Zne n m : ~ Zne n m -> n = m.
Proof.
  intros H.
  destruct (Z.eq_decidable n m); [assumption|now elim H].
Qed.

(** * Equivalence and order properties *)

(** Reflexivity *)

Notation Zle_refl := Z.le_refl (compat "8.6").
Notation Zeq_le := Z.eq_le_incl (only parsing).

Hint Resolve Z.le_refl: zarith.

(** Antisymmetry *)

Notation Zle_antisym := Z.le_antisymm (only parsing).

(** Asymmetry *)

Notation Zlt_asym := Z.lt_asymm (only parsing).

Lemma Zgt_asym n m : n > m -> ~ m > n.
Proof.
  Z.swap_greater. apply Z.lt_asymm.
Qed.

(** Irreflexivity *)

Notation Zlt_irrefl := Z.lt_irrefl (compat "8.6").
Notation Zlt_not_eq := Z.lt_neq (only parsing).

Lemma Zgt_irrefl n : ~ n > n.
Proof.
  Z.swap_greater. apply Z.lt_irrefl.
Qed.

(** Large = strict or equal *)

Notation Zlt_le_weak := Z.lt_le_incl (only parsing).
Notation Zle_lt_or_eq_iff := Z.lt_eq_cases (only parsing).

Lemma Zle_lt_or_eq n m : n <= m -> n < m \/ n = m.
Proof.
  apply Z.lt_eq_cases.
Qed.

(** Dichotomy *)

Notation Zle_or_lt := Z.le_gt_cases (only parsing).

(** Transitivity of strict orders *)

Notation Zlt_trans := Z.lt_trans (compat "8.6").

Lemma Zgt_trans n m p : n > m -> m > p -> n > p.
Proof.
  Z.swap_greater. intros; now transitivity m.
Qed.

(** Mixed transitivity *)

Notation Zlt_le_trans := Z.lt_le_trans (compat "8.6").
Notation Zle_lt_trans := Z.le_lt_trans (compat "8.6").

Lemma Zle_gt_trans n m p : m <= n -> m > p -> n > p.
Proof.
  Z.swap_greater. Z.order.
Qed.

Lemma Zgt_le_trans n m p : n > m -> p <= m -> n > p.
Proof.
  Z.swap_greater. Z.order.
Qed.

(** Transitivity of large orders *)

Notation Zle_trans := Z.le_trans (compat "8.6").

Lemma Zge_trans n m p : n >= m -> m >= p -> n >= p.
Proof.
  Z.swap_greater. Z.order.
Qed.

Hint Resolve Z.le_trans: zarith.

(** * Compatibility of order and operations on Z *)

(** ** Successor *)

(** Compatibility of successor wrt to order *)

Lemma Zsucc_le_compat n m : m <= n -> Z.succ m <= Z.succ n.
Proof.
  apply Z.succ_le_mono.
Qed.

Lemma Zsucc_lt_compat n m : n < m -> Z.succ n < Z.succ m.
Proof.
  apply Z.succ_lt_mono.
Qed.

Lemma Zsucc_gt_compat n m : m > n -> Z.succ m > Z.succ n.
Proof.
  Z.swap_greater. apply Z.succ_lt_mono.
Qed.

Hint Resolve Zsucc_le_compat: zarith.

(** Simplification of successor wrt to order *)

Lemma Zsucc_gt_reg n m : Z.succ m > Z.succ n -> m > n.
Proof.
  Z.swap_greater. apply Z.succ_lt_mono.
Qed.

Lemma Zsucc_le_reg n m : Z.succ m <= Z.succ n -> m <= n.
Proof.
  apply Z.succ_le_mono.
Qed.

Lemma Zsucc_lt_reg n m : Z.succ n < Z.succ m -> n < m.
Proof.
  apply Z.succ_lt_mono.
Qed.

(** Special base instances of order *)

Notation Zlt_succ := Z.lt_succ_diag_r (only parsing).
Notation Zlt_pred := Z.lt_pred_l (only parsing).

Lemma Zgt_succ n : Z.succ n > n.
Proof.
  Z.swap_greater. apply Z.lt_succ_diag_r.
Qed.

Lemma Znot_le_succ n : ~ Z.succ n <= n.
Proof.
  apply Z.lt_nge, Z.lt_succ_diag_r.
Qed.

(** Relating strict and large order using successor or predecessor *)

Notation Zlt_succ_r := Z.lt_succ_r (compat "8.6").
Notation Zle_succ_l := Z.le_succ_l (compat "8.6").

Lemma Zgt_le_succ n m : m > n -> Z.succ n <= m.
Proof.
  Z.swap_greater. apply Z.le_succ_l.
Qed.

Lemma Zle_gt_succ n m : n <= m -> Z.succ m > n.
Proof.
  Z.swap_greater. apply Z.lt_succ_r.
Qed.

Lemma Zle_lt_succ n m : n <= m -> n < Z.succ m.
Proof.
  apply Z.lt_succ_r.
Qed.

Lemma Zlt_le_succ n m : n < m -> Z.succ n <= m.
Proof.
  apply Z.le_succ_l.
Qed.

Lemma Zgt_succ_le n m : Z.succ m > n -> n <= m.
Proof.
  Z.swap_greater. apply Z.lt_succ_r.
Qed.

Lemma Zlt_succ_le n m : n < Z.succ m -> n <= m.
Proof.
  apply Z.lt_succ_r.
Qed.

Lemma Zle_succ_gt n m : Z.succ n <= m -> m > n.
Proof.
  Z.swap_greater. apply Z.le_succ_l.
Qed.

(** Weakening order *)

Notation Zle_succ := Z.le_succ_diag_r (only parsing).
Notation Zle_pred := Z.le_pred_l (only parsing).
Notation Zlt_lt_succ := Z.lt_lt_succ_r (only parsing).
Notation Zle_le_succ := Z.le_le_succ_r (only parsing).

Lemma Zle_succ_le n m : Z.succ n <= m -> n <= m.
Proof.
  intros. now apply Z.lt_le_incl, Z.le_succ_l.
Qed.

Hint Resolve Z.le_succ_diag_r: zarith.
Hint Resolve Z.le_le_succ_r: zarith.

(** Relating order wrt successor and order wrt predecessor *)

Lemma Zgt_succ_pred n m : m > Z.succ n -> Z.pred m > n.
Proof.
  Z.swap_greater. apply Z.lt_succ_lt_pred.
Qed.

Lemma Zlt_succ_pred n m : Z.succ n < m -> n < Z.pred m.
Proof.
  apply Z.lt_succ_lt_pred.
Qed.

(** Relating strict order and large order on positive *)

Lemma Zlt_0_le_0_pred n : 0 < n -> 0 <= Z.pred n.
Proof.
  apply Z.lt_le_pred.
Qed.

Lemma Zgt_0_le_0_pred n : n > 0 -> 0 <= Z.pred n.
Proof.
  Z.swap_greater. apply Z.lt_le_pred.
Qed.

(** Special cases of ordered integers *)

Notation Zlt_0_1 := Z.lt_0_1 (compat "8.6").
Notation Zle_0_1 := Z.le_0_1 (compat "8.6").

Lemma Zle_neg_pos : forall p q:positive, Zneg p <= Zpos q.
Proof.
  exact Pos2Z.neg_le_pos.
Qed.

Lemma Zgt_pos_0 : forall p:positive, Zpos p > 0.
Proof.
  easy.
Qed.

(* weaker but useful (in [Z.pow] for instance) *)
Lemma Zle_0_pos : forall p:positive, 0 <= Zpos p.
Proof.
  exact Pos2Z.pos_is_nonneg.
Qed.

Lemma Zlt_neg_0 : forall p:positive, Zneg p < 0.
Proof.
  exact Pos2Z.neg_is_neg.
Qed.

Lemma Zle_0_nat : forall n:nat, 0 <= Z.of_nat n.
Proof.
  induction n; simpl; intros. apply Z.le_refl. easy.
Qed.

Hint Immediate Z.eq_le_incl: zarith.

(** Derived lemma *)

Lemma Zgt_succ_gt_or_eq n m : Z.succ n > m -> n > m \/ m = n.
Proof.
  Z.swap_greater. intros. now apply Z.lt_eq_cases, Z.lt_succ_r.
Qed.

(** ** Addition *)
(** Compatibility of addition wrt to order *)

Notation Zplus_lt_le_compat := Z.add_lt_le_mono (only parsing).
Notation Zplus_le_lt_compat := Z.add_le_lt_mono (only parsing).
Notation Zplus_le_compat := Z.add_le_mono (only parsing).
Notation Zplus_lt_compat := Z.add_lt_mono (only parsing).

Lemma Zplus_gt_compat_l n m p : n > m -> p + n > p + m.
Proof.
  Z.swap_greater. apply Z.add_lt_mono_l.
Qed.

Lemma Zplus_gt_compat_r n m p : n > m -> n + p > m + p.
Proof.
  Z.swap_greater. apply Z.add_lt_mono_r.
Qed.

Lemma Zplus_le_compat_l n m p : n <= m -> p + n <= p + m.
Proof.
  apply Z.add_le_mono_l.
Qed.

Lemma Zplus_le_compat_r n m p : n <= m -> n + p <= m + p.
Proof.
  apply Z.add_le_mono_r.
Qed.

Lemma Zplus_lt_compat_l n m p : n < m -> p + n < p + m.
Proof.
  apply Z.add_lt_mono_l.
Qed.

Lemma Zplus_lt_compat_r n m p : n < m -> n + p < m + p.
Proof.
  apply Z.add_lt_mono_r.
Qed.

(** Compatibility of addition wrt to being positive *)

Notation Zplus_le_0_compat := Z.add_nonneg_nonneg (only parsing).

(** Simplification of addition wrt to order *)

Lemma Zplus_le_reg_l n m p : p + n <= p + m -> n <= m.
Proof.
 apply Z.add_le_mono_l.
Qed.

Lemma Zplus_le_reg_r n m p : n + p <= m + p -> n <= m.
Proof.
 apply Z.add_le_mono_r.
Qed.

Lemma Zplus_lt_reg_l n m p : p + n < p + m -> n < m.
Proof.
 apply Z.add_lt_mono_l.
Qed.

Lemma Zplus_lt_reg_r n m p : n + p < m + p -> n < m.
Proof.
 apply Z.add_lt_mono_r.
Qed.

Lemma Zplus_gt_reg_l n m p : p + n > p + m -> n > m.
Proof.
 Z.swap_greater. apply Z.add_lt_mono_l.
Qed.

Lemma Zplus_gt_reg_r n m p : n + p > m + p -> n > m.
Proof.
 Z.swap_greater. apply Z.add_lt_mono_r.
Qed.

(** ** Multiplication *)
(** Compatibility of multiplication by a positive wrt to order *)

Lemma Zmult_le_compat_r n m p : n <= m -> 0 <= p -> n * p <= m * p.
Proof.
 intros. now apply Z.mul_le_mono_nonneg_r.
Qed.

Lemma Zmult_le_compat_l n m p : n <= m -> 0 <= p -> p * n <= p * m.
Proof.
 intros. now apply Z.mul_le_mono_nonneg_l.
Qed.

Lemma Zmult_lt_compat_r n m p : 0 < p -> n < m -> n * p < m * p.
Proof.
 apply Z.mul_lt_mono_pos_r.
Qed.

Lemma Zmult_gt_compat_r n m p : p > 0 -> n > m -> n * p > m * p.
Proof.
 Z.swap_greater. apply Z.mul_lt_mono_pos_r.
Qed.

Lemma Zmult_gt_0_lt_compat_r n m p : p > 0 -> n < m -> n * p < m * p.
Proof.
 Z.swap_greater. apply Z.mul_lt_mono_pos_r.
Qed.

Lemma Zmult_gt_0_le_compat_r n m p : p > 0 -> n <= m -> n * p <= m * p.
Proof.
 Z.swap_greater. apply Z.mul_le_mono_pos_r.
Qed.

Lemma Zmult_lt_0_le_compat_r n m p : 0 < p -> n <= m -> n * p <= m * p.
Proof.
 apply Z.mul_le_mono_pos_r.
Qed.

Lemma Zmult_gt_0_lt_compat_l n m p : p > 0 -> n < m -> p * n < p * m.
Proof.
 Z.swap_greater. apply Z.mul_lt_mono_pos_l.
Qed.

Lemma Zmult_lt_compat_l n m p : 0 < p -> n < m -> p * n < p * m.
Proof.
 apply Z.mul_lt_mono_pos_l.
Qed.

Lemma Zmult_gt_compat_l n m p : p > 0 -> n > m -> p * n > p * m.
Proof.
 Z.swap_greater. apply Z.mul_lt_mono_pos_l.
Qed.

Lemma Zmult_ge_compat_r n m p : n >= m -> p >= 0 -> n * p >= m * p.
Proof.
 Z.swap_greater. intros. now apply Z.mul_le_mono_nonneg_r.
Qed.

Lemma Zmult_ge_compat_l n m p : n >= m -> p >= 0 -> p * n >= p * m.
Proof.
 Z.swap_greater. intros. now apply Z.mul_le_mono_nonneg_l.
Qed.

Lemma Zmult_ge_compat n m p q :
  n >= p -> m >= q -> p >= 0 -> q >= 0 -> n * m >= p * q.
Proof.
 Z.swap_greater. intros. now apply Z.mul_le_mono_nonneg.
Qed.

Lemma Zmult_le_compat n m p q :
  n <= p -> m <= q -> 0 <= n -> 0 <= m -> n * m <= p * q.
Proof.
 intros. now apply Z.mul_le_mono_nonneg.
Qed.

(** Simplification of multiplication by a positive wrt to being positive *)

Lemma Zmult_gt_0_lt_reg_r n m p : p > 0 -> n * p < m * p -> n < m.
Proof.
 Z.swap_greater. apply Z.mul_lt_mono_pos_r.
Qed.

Lemma Zmult_lt_reg_r n m p : 0 < p -> n * p < m * p -> n < m.
Proof.
 apply Z.mul_lt_mono_pos_r.
Qed.

Lemma Zmult_le_reg_r n m p : p > 0 -> n * p <= m * p -> n <= m.
Proof.
 Z.swap_greater. apply Z.mul_le_mono_pos_r.
Qed.

Lemma Zmult_lt_0_le_reg_r n m p : 0 < p -> n * p <= m * p -> n <= m.
Proof.
 apply Z.mul_le_mono_pos_r.
Qed.

Lemma Zmult_ge_reg_r n m p : p > 0 -> n * p >= m * p -> n >= m.
Proof.
 Z.swap_greater. apply Z.mul_le_mono_pos_r.
Qed.

Lemma Zmult_gt_reg_r n m p : p > 0 -> n * p > m * p -> n > m.
Proof.
 Z.swap_greater. apply Z.mul_lt_mono_pos_r.
Qed.

Lemma Zmult_lt_compat n m p q :
  0 <= n < p -> 0 <= m < q -> n * m < p * q.
Proof.
 intros (Hn,Hnp) (Hm,Hmq). now apply Z.mul_lt_mono_nonneg.
Qed.

Lemma Zmult_lt_compat2 n m p q :
  0 < n <= p -> 0 < m < q -> n * m < p * q.
Proof.
  intros (Hn, Hnp) (Hm,Hmq).
  apply Z.le_lt_trans with (p * m).
   apply Z.mul_le_mono_pos_r; trivial.
   apply Z.mul_lt_mono_pos_l; Z.order.
Qed.

(** Compatibility of multiplication by a positive wrt to being positive *)

Notation Zmult_le_0_compat := Z.mul_nonneg_nonneg (only parsing).
Notation Zmult_lt_0_compat := Z.mul_pos_pos (only parsing).
Notation Zmult_lt_O_compat := Z.mul_pos_pos (only parsing).

Lemma Zmult_gt_0_compat n m : n > 0 -> m > 0 -> n * m > 0.
Proof.
 Z.swap_greater. apply Z.mul_pos_pos.
Qed.

(* To remove someday ... *)

Lemma Zmult_gt_0_le_0_compat n m : n > 0 -> 0 <= m -> 0 <= m * n.
Proof.
 Z.swap_greater. intros. apply Z.mul_nonneg_nonneg. trivial.
  now apply Z.lt_le_incl.
Qed.

(** Simplification of multiplication by a positive wrt to being positive *)

Lemma Zmult_le_0_reg_r n m : n > 0 -> 0 <= m * n -> 0 <= m.
Proof.
 Z.swap_greater. apply Z.mul_nonneg_cancel_r.
Qed.

Lemma Zmult_lt_0_reg_r n m : 0 < n -> 0 < m * n -> 0 < m.
Proof.
 apply Z.mul_pos_cancel_r.
Qed.

Lemma Zmult_gt_0_lt_0_reg_r n m : n > 0 -> 0 < m * n -> 0 < m.
Proof.
 Z.swap_greater. apply Z.mul_pos_cancel_r.
Qed.

Lemma Zmult_gt_0_reg_l n m : n > 0 -> n * m > 0 -> m > 0.
Proof.
 Z.swap_greater. apply Z.mul_pos_cancel_l.
Qed.

(** ** Square *)
(** Simplification of square wrt order *)

Lemma Zlt_square_simpl n m : 0 <= n -> m * m < n * n -> m < n.
Proof.
 apply Z.square_lt_simpl_nonneg.
Qed.

Lemma Zgt_square_simpl n m : n >= 0 -> n * n > m * m -> n > m.
Proof.
 Z.swap_greater. apply Z.square_lt_simpl_nonneg.
Qed.

(** * Equivalence between inequalities *)

Notation Zle_plus_swap := Z.le_add_le_sub_r (only parsing).
Notation Zlt_plus_swap := Z.lt_add_lt_sub_r (only parsing).
Notation Zlt_minus_simpl_swap := Z.lt_sub_pos (only parsing).

Lemma Zeq_plus_swap n m p : n + p = m <-> n = m - p.
Proof.
 apply Z.add_move_r.
Qed.

Lemma Zlt_0_minus_lt n m : 0 < n - m -> m < n.
Proof.
 apply Z.lt_0_sub.
Qed.

Lemma Zle_0_minus_le n m : 0 <= n - m -> m <= n.
Proof.
 apply Z.le_0_sub.
Qed.

Lemma Zle_minus_le_0 n m : m <= n -> 0 <= n - m.
Proof.
 apply Z.le_0_sub.
Qed.

(** For compatibility *)
Notation Zlt_O_minus_lt := Zlt_0_minus_lt (only parsing).


(** Additional results about [CPermutation] *)

From Coq Require Export CPermutation.
From OLlibs Require Import List_more funtheory.

Set Implicit Arguments.

Lemma CPermutation_app_app_inv A (l1 l2 l3 l4 : list A) :
  CPermutation (l1 ++ l2) (l3 ++ l4) ->
     (exists l3' l3'' l4' l4'',
        CPermutation l1 (l3' ++ l4')  /\ CPermutation l2 (l3'' ++ l4'')
     /\
        CPermutation l3 (l3' ++ l3'') /\ CPermutation l4 (l4' ++ l4''))
  \/ (exists l l',
        CPermutation l1 (l4 ++ l) /\ CPermutation l3 (l2 ++ l')
          /\ CPermutation l l')
  \/ (exists l l',
        CPermutation l2 (l4 ++ l) /\ CPermutation l3 (l1 ++ l')
          /\ CPermutation l l')
  \/ (exists l l',
        CPermutation l1 (l3 ++ l) /\ CPermutation l4 (l2 ++ l')
          /\ CPermutation l l')
  \/ (exists l l',
        CPermutation l2 (l3 ++ l) /\ CPermutation l4 (l1 ++ l')
          /\ CPermutation l l').
Proof.
intros HC; inversion HC as [lx ly Hx Hy].
dichot_app_exec Hx; dichot_app_exec Hy; subst.
- right; left.
  exists (l ++ l0), (l0 ++ l).
  repeat split; rewrite <- ? app_assoc; apply CPermutation_app_rot.
- dichot_app_exec Hy0; subst.
  + now left; exists l, l0, lx, l5; repeat split.
  + right; right; right; left; exists (l1 ++ lx), (lx ++ l1).
    repeat split; rewrite <- ? app_assoc; apply CPermutation_app_rot.
- dichot_app_exec Hy1; subst.
  + right; right; left; exists (ly ++ l2), (l2 ++ ly).
    repeat split; rewrite <- ? app_assoc; apply CPermutation_app_rot.
  + now left; exists l, ly, l3, l0; repeat split.
- right; right; right; right; exists (l5 ++ l0), (l0 ++ l5).
  repeat split; rewrite <- ? app_assoc; apply CPermutation_app_rot.
Qed.

Lemma CPermutation_vs_elt_subst A (a : A) l l1 l2 :
  CPermutation l (l1 ++ a :: l2) -> exists l3 l4,
    (forall l0, CPermutation (l1 ++ l0 ++ l2) (l3 ++ l0 ++ l4)) /\ l = l3 ++ a :: l4.
Proof.
intros HP.
destruct (CPermutation_vs_elt_inv _ _ _ HP) as [l' [l'' [Heq ->]]].
exists l', l''; split; [ | reflexivity ].
intros l0.
etransitivity; [ apply CPermutation_app_comm | ].
list_simpl; rewrite Heq, app_assoc.
constructor.
Qed.

Lemma CPermutation_map_inv_inj A B (f : A -> B) : injective f ->
  forall l1 l2, CPermutation (map f l1) (map f l2) -> CPermutation l1 l2.
Proof.
intros Hi l1 l2 HP; inversion HP as [l3 l4 Heq1 Heq2].
symmetry in Heq1; symmetry in Heq2.
decomp_map Heq1; decomp_map Heq2; subst.
apply map_injective in Heq5; auto.
apply map_injective in Heq6; auto.
subst; constructor.
Qed.

Lemma CPermutation_map_inv_inj_local A B (f : A -> B) l1 l2 :
  (forall x y, In x l1 -> In y l2 -> f x = f y -> x = y) ->
    CPermutation (map f l1) (map f l2) -> CPermutation l1 l2.
Proof.
intros Hi HP; inversion HP as [l3 l4 Heq1 Heq2].
symmetry in Heq1; symmetry in Heq2.
decomp_map Heq1; decomp_map Heq2; subst.
symmetry in Heq5; symmetry in Heq6.
apply map_injective_in in Heq5.
2:{ intros x y Hin1 Hin2 Heq; apply Hi; auto; apply in_or_app; auto. }
apply map_injective_in in Heq6.
2:{ intros x y Hin1 Hin2 Heq; apply Hi; auto; apply in_or_app; auto. }
subst; constructor.
Qed.


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

(************************************************************************)
(*                                                                      *)
(*                           Nat.v                                      *)
(*                                                                      *)
(*    Laurent.Thery @sophia.inria.fr        March 2002                  *)
(************************************************************************)
(** Some extra properties of natural numbers *)
Require Import Arith.
Require Import ZArith.
Require Import ZArithRing.
Require Import sTactic.
Require Import Max.

Theorem le_ind2 :
 forall P : nat -> nat -> Prop,
 (forall m : nat, 0 <= m -> P 0 m) ->
 (forall m n : nat, n <= m -> P n m -> P (S n) (S m)) ->
 forall m n : nat, n <= m -> P n m.
intros P H H0 m n; generalize m; elim n; clear n m; auto with arith.
intros n H1 m; case m; auto with arith.
intros H2; Contradict H2; auto with arith.
Qed.

Theorem minus_O : forall n m : nat, n <= m -> n - m = 0.
intros n m H; elim H using le_ind2; auto.
Qed.

Theorem minus_O_le : forall n m : nat, n - m = 0 -> n <= m.
intros n; elim n; simpl in |- *; auto with arith.
intros n1 Rec m; case m; simpl in |- *; try (intros H; rewrite H);
 auto with arith.
Qed.

(** Check if [i] is strictly less than [o] *)
Fixpoint ltdec (i o : nat) {struct o} : bool :=
  match i, o with
  | O, O => false
  | O, S o1 => true
  | S i1, S o1 => ltdec i1 o1
  | S i1, O => false
  end.

Theorem ltdec_correct :
 forall i o : nat, match ltdec i o with
                   | true => i < o
                   | false => o <= i
                   end.
intros i; elim i; simpl in |- *; auto.
intros o; case o; simpl in |- *; auto with arith.
intros i1 H o; case o; simpl in |- *; auto with arith.
intros o1; generalize (H o1); case (ltdec i1 o1); auto with arith.
Qed.

Theorem pred_le : forall a b, a <= b -> pred a <= pred b.
intros a b; case a; case b; simpl in |- *; auto with arith.
Qed.
Hint Resolve pred_le: arith.

Fixpoint minus2 (m1 m2 : nat) {struct m2} : nat * nat :=
  match m1, m2 with
  | S m3, S m4 => minus2 m3 m4
  | _, _ => (m1, m2)
  end.

Theorem minus2_correct :
 forall m1 m2 : nat,
 match minus2 m1 m2 with
 | (m3, m4) => m3 = m1 - m2 /\ m4 = m2 - m1
 end.
intros m1 m2; generalize m1; elim m2; clear m1 m2; simpl in |- *;
 auto with arith.
intros m1; case m1; simpl in |- *; auto.
intros m2 Rec m1; case m1; simpl in |- *; auto.
Qed.

(** Definition of the gcd of two numbers *)
Fixpoint gcd1 (m1 m2 n : nat) {struct n} : nat :=
  match minus2 m1 m2 with
  | (O, O) => m1
  | (O, m3) => match n with
               | O => m3
               | S n1 => gcd1 m1 m3 n1
               end
  | (m3, _) => match n with
               | O => m3
               | S n1 => gcd1 m3 m2 n1
               end
  end.

Definition gcd m1 m2 := gcd1 m1 m2 (m1 + m2).

Theorem gcd1_bezout0 : forall n m : nat, gcd1 m 0 n = m.
intros n; elim n; simpl in |- *.
intros m; case m; simpl in |- *; auto.
intros n1 Rec m; case m; simpl in |- *; auto.
Qed.

Theorem gcd1_bezout1 : forall n m : nat, gcd1 0 m n = m.
intros n; elim n; simpl in |- *.
intros m; case m; simpl in |- *; auto.
intros n1 Rec m; case m; simpl in |- *; auto.
Qed.

Theorem gcd1_bezout :
 forall n m1 m2 : nat,
 m1 <= n ->
 m2 <= n ->
 exists x1 : Z,
   (exists x2 : Z,
      (Z_of_nat m1 * x1 + Z_of_nat m2 * x2)%Z = Z_of_nat (gcd1 m1 m2 n)).
intros n; elim n; simpl in |- *.
intros m1 m2 H1 H2; inversion H1; inversion H2; simpl in |- *; exists 0%Z;
 exists 0%Z; auto.
intros n0 H m1 m2 H0 H1; generalize (minus2_correct m1 m2);
 case (minus2 m1 m2).
intros n1 n2; case n1; case n2; auto.
intros H2; exists 1%Z; exists 0%Z; ring.
intros m3 (H2, H3).
cut (m1 < m2); [ intros H4 | idtac ].
generalize H0 H3 H4; case m1; clear H2 H0 H3 H4 m1.
intros H0 H3 H4; exists 0%Z; exists 1%Z; rewrite gcd1_bezout1.
replace (S m3) with m2; [ ring | rewrite H3; case m2; simpl in |- *; auto ].
intros n3 H0 H3 H4.
case (H (S n3) (S m3)); auto.
apply gt_S_le; red in |- *.
apply lt_le_trans with m2; auto with arith.
rewrite H3; auto.
generalize H1 H4; case m2; simpl in |- *; auto with arith.
intros n4 H2 H5; apply le_trans with n4; auto with arith.
generalize n3; elim n4; auto with arith; intros n5 Rec n6; case n6;
  simpl in |- *; auto.
intros x (y, H2).
exists (x - y)%Z; exists y; rewrite <- H2; rewrite H3.
rewrite Znat.inj_minus1; try ring.
apply lt_le_weak; auto.
apply lt_O_minus_lt; rewrite <- H3; auto with arith.
intros m3 (H2, H3).
cut (m2 < m1); [ intros H4 | idtac ].
generalize H1 H2 H4; case m2; clear H1 H2 H3 H4 m2.
intros H1 H3 H4; exists 1%Z; exists 0%Z; rewrite gcd1_bezout0.
replace (S m3) with m1; [ ring | rewrite H3; case m1; simpl in |- *; auto ].
intros n3 H1 H3 H4.
case (H (S m3) (S n3)); auto.
apply gt_S_le; red in |- *.
apply lt_le_trans with m1; auto with arith.
rewrite H3; generalize H4; case m1; simpl in |- *; auto with arith.
intros H2; Contradict H2; auto with arith.
intros n4 H2; apply le_lt_trans with n4; auto with arith.
generalize n3; elim n4; auto with arith; intros n5 Rec n6; case n6;
  simpl in |- *; auto.
apply gt_S_le; red in |- *.
apply lt_le_trans with m1; auto with arith.
intros x (y, H2).
exists x; exists (y - x)%Z; rewrite <- H2; rewrite H3.
rewrite Znat.inj_minus1; try ring.
apply lt_le_weak; auto.
apply lt_O_minus_lt; rewrite <- H2; auto with arith.
intros n3 n4 (H2, H3).
case (le_or_lt m1 m2); intros H4.
Contradict H2; rewrite minus_O; auto.
Contradict H3; rewrite minus_O; auto with arith.
Qed.

Theorem gcd1_O : forall n m, gcd1 0 m n = m /\ gcd1 m 0 n = m.
intros n; elim n.
intros m; case m; simpl in |- *; auto.
intros n1 Rec m; case m; simpl in |- *; auto.
Qed.

Theorem gcd_O1 : forall m, gcd 0 m = m.
intros m; case (gcd1_O m m); simpl in |- *; auto.
Qed.

Theorem gcd_O2 : forall m, gcd m 0 = m.
intros m; case (gcd1_O (m + 0) m); simpl in |- *; auto.
Qed.

(** Bezout equality *)
Theorem gcd_bezout :
 forall m1 m2 : nat,
 exists x1 : Z,
   (exists x2 : Z,
      (Z_of_nat m1 * x1 + Z_of_nat m2 * x2)%Z = Z_of_nat (gcd m1 m2)).
intros m1 m2; unfold gcd in |- *; apply gcd1_bezout; auto with arith.
Qed.

(** Division of two numbers *)
Fixpoint div1 (m1 m2 n : nat) {struct n} : nat :=
  match minus2 m1 m2 with
  | (O, O) => 1
  | (O, _) => 0
  | (m3, _) => match n with
               | O => 0
               | S n1 => S (div1 m3 m2 n1)
               end
  end.

Definition div m1 m2 := div1 m1 m2 m1.

Theorem div1_correct :
 forall n m1 m2 : nat,
 m1 <= n -> 0 < m2 -> m2 * div1 m1 m2 n <= m1 /\ m1 < m2 * S (div1 m1 m2 n).
intros n; elim n; simpl in |- *; auto.
intros m1 m2 H H0; inversion H; auto.
generalize H0; case m2; simpl in |- *; auto with arith.
intros; rewrite mult_comm; simpl in |- *; auto with arith.
intros n0 H m1 m2 H0 H1; generalize (minus2_correct m1 m2);
 case (minus2 m1 m2).
intros n1 n2; case n1; case n2; simpl in |- *.
intros (H2, H3); replace m1 with m2; auto with arith.
rewrite mult_1_r; split; auto with arith.
rewrite mult_comm; simpl in |- *; apply le_lt_trans with (m2 + 0);
 auto with arith.
apply le_antisym; apply minus_O_le; auto.
intros n3 (H2, H3); rewrite <- mult_n_O; rewrite mult_1_r; simpl in |- *;
 split; auto with arith.
apply lt_O_minus_lt; rewrite <- H3; auto with arith.
intros n3 (H2, H3); case (H (S n3) m2); auto with arith.
apply gt_S_le; red in |- *.
apply lt_le_trans with m1; auto with arith.
rewrite H2; apply lt_minus; auto.
apply minus_O_le; auto.
intros H4 H5; split; auto.
rewrite <- mult_n_Sm.
apply le_trans with (S n3 + m2); auto with arith.
rewrite H2.
rewrite plus_comm; rewrite <- le_plus_minus; auto with arith.
apply minus_O_le; auto with arith.
rewrite <- mult_n_Sm.
apply le_lt_trans with (S n3 + m2); auto with arith.
rewrite H2.
rewrite plus_comm; rewrite <- le_plus_minus; auto with arith.
apply minus_O_le; auto with arith.
intros n3 n4 (H2, H3).
case (le_or_lt m1 m2); intros H4.
Contradict H2; rewrite minus_O; auto.
Contradict H3; rewrite minus_O; auto with arith.
Qed.

Theorem div_correct :
 forall m1 m2 : nat,
 0 < m2 -> m2 * div m1 m2 <= m1 /\ m1 < m2 * S (div m1 m2).
intros m1 m2 H; unfold div in |- *; apply div1_correct; auto.
Qed.

Definition divides m1 m2 := exists m3 : _, m2 = m1 * m3.

Theorem divides_refl : forall m, divides m m.
intros; exists 1; simpl in |- *; auto; ring.
Qed.

Theorem divides_trans :
 forall m1 m2 m3, divides m1 m2 -> divides m2 m3 -> divides m1 m3.
intros m1 m2 m3 (m1', H1) (m2', H2); exists (m1' * m2'); rewrite H2;
 rewrite H1; ring.
Qed.

Theorem divides_add :
 forall m1 m2 m3, divides m1 m2 -> divides m1 m3 -> divides m1 (m2 + m3).
intros m1 m2 m3 (m1', H1) (m2', H2); exists (m1' + m2'); rewrite H2;
 rewrite H1; ring.
Qed.

Theorem divides_minus :
 forall m1 m2 m3, divides m1 m2 -> divides m1 m3 -> divides m1 (m2 - m3).
intros m1 m2 m3 (m1', H1) (m2', H2); exists (m1' - m2'); rewrite H2;
 rewrite H1. auto with arith.
Qed.
Hint Resolve divides_refl divides_add divides_minus.

Theorem divides_gcd_aux :
 forall n m1 m2,
 0 < m1 ->
 m1 <= n ->
 0 < m2 -> m2 <= n -> divides (gcd1 m1 m2 n) m2 /\ divides (gcd1 m1 m2 n) m1.
intros n; elim n; simpl in |- *.
intros m1 m2 H H0; Contradict H0; auto with arith.
intros n' Rec; intros m1 m2 H1 H2 H3 H4; generalize (minus2_correct m1 m2);
 case (minus2 m1 m2).
intros n0; case n0; clear n0.
intros n1; case n1; clear n1.
intros (H5, H6); replace m1 with m2; auto.
apply le_antisym; apply minus_O_le; auto.
intros n1 (H5, H6); case (Rec m1 (S n1)); auto with arith.
apply lt_n_Sm_le; apply lt_le_trans with m2; auto.
apply lt_O_minus_lt; rewrite <- H6; auto with arith.
apply lt_n_Sm_le; apply lt_le_trans with m2; auto.
rewrite H6.
apply lt_minus; auto.
apply minus_O_le; auto.
intros H7 H8; split; auto.
replace m2 with (m1 + S n1); auto with arith.
rewrite H6.
apply sym_equal; apply le_plus_minus.
apply minus_O_le; auto.
intros n1 n2; case n2; clear n2.
intros (H5, H6); case (Rec (S n1) m2); auto with arith.
apply lt_n_Sm_le; apply lt_le_trans with m1; auto.
rewrite H5.
apply lt_minus; auto.
apply minus_O_le; auto.
apply lt_n_Sm_le; apply lt_le_trans with m1; auto.
apply lt_O_minus_lt; rewrite <- H5; auto with arith.
intros H7 H8; split; auto.
replace m1 with (m2 + S n1); auto with arith.
rewrite H5.
apply sym_equal; apply le_plus_minus.
apply minus_O_le; auto.
intros n2 (H5, H6).
case (le_or_lt m1 m2); intros H7.
Contradict H5; rewrite minus_O; auto.
Contradict H6; rewrite minus_O; auto with arith.
Qed.

Theorem divides_gcd1 : forall m1 m2, divides (gcd m1 m2) m1.
intros m1 m2; case m1.
rewrite gcd_O1; exists 0; simpl in |- *; auto.
intros m1'; case m2; simpl in |- *.
rewrite gcd_O2; exists 1; ring.
intros m2'; case (divides_gcd_aux (S m1' + S m2') (S m1') (S m2'));
 auto with arith.
Qed.

Theorem divides_gcd2 : forall m1 m2, divides (gcd m1 m2) m2.
intros m1 m2; case m1.
rewrite gcd_O1; exists 1; ring.
intros m1'; case m2; simpl in |- *.
rewrite gcd_O2; exists 0; ring.
intros m2'; case (divides_gcd_aux (S m1' + S m2') (S m1') (S m2'));
 auto with arith.
Qed.

Theorem divides_gcd1_aux :
 forall n m1 m2 m3,
 0 < m1 ->
 m1 <= n ->
 0 < m2 ->
 m2 <= n -> divides m3 m1 -> divides m3 m2 -> divides m3 (gcd1 m1 m2 n).
intros n; elim n; simpl in |- *.
intros m1 m2 m3 H H0; Contradict H0; auto with arith.
intros n' Rec m1 m2 m3 H1 H2 H3 H4 H5 H6.
generalize (minus2_correct m1 m2); case (minus2 m1 m2).
intros n0; case n0; clear n0; auto.
intros n1; case n1; clear n1; auto.
intros n1 (H7, H8); apply Rec; auto with arith.
apply lt_n_Sm_le; apply lt_le_trans with m2; auto.
apply lt_O_minus_lt; rewrite <- H8; auto with arith.
apply lt_n_Sm_le; apply lt_le_trans with m2; auto.
rewrite H8.
apply lt_minus; auto.
apply minus_O_le; auto.
rewrite H8; auto.
intros n1 n2; case n2; clear n2; auto.
intros (H7, H8); apply Rec; auto with arith.
apply lt_n_Sm_le; apply lt_le_trans with m1; auto.
rewrite H7.
apply lt_minus; auto.
apply minus_O_le; auto.
apply lt_n_Sm_le; apply lt_le_trans with m1; auto.
apply lt_O_minus_lt; rewrite <- H7; auto with arith.
rewrite H7; auto.
intros n2 (H7, H8).
case (le_or_lt m1 m2); intros H9.
Contradict H7; rewrite minus_O; auto.
Contradict H8; rewrite minus_O; auto with arith.
Qed.

Theorem divides_gcd3 :
 forall m1 m2 m3, divides m3 m1 -> divides m3 m2 -> divides m3 (gcd m1 m2).
intros m1 m2 m3; case m1.
rewrite gcd_O1; auto.
intros m1'; case m2; simpl in |- *.
rewrite gcd_O2; auto.
intros m2' H; apply (divides_gcd1_aux (S m1' + S m2') (S m1') (S m2'));
 auto with arith.
Qed.

Theorem mult_inv : forall m1 m2 m3, S m1 * m2 = S m1 * m3 -> m2 = m3.
intros m1 m2 m3 H; apply le_antisym; apply mult_S_le_reg_l with (n := m1);
 rewrite H; auto with arith.
Qed.

Theorem divides_id : forall m1 m2, divides m1 m2 -> divides m2 m1 -> m2 = m1.
intros m1 m2 (m3, H) (m4, H0).
generalize H H0; clear H H0; case m1; clear m1.
case m2; simpl in |- *; auto; intros; discriminate.
intros m1 H H0.
cut (m3 * m4 = 1); [ intros H1 | idtac ].
cut (m3 = 1); [ intros H2 | idtac ].
rewrite H; rewrite H2; ring.
generalize H1; case m3; case m4; simpl in |- *; auto.
intros n1; rewrite mult_comm; simpl in |- *; intros H2; discriminate.
intros n n0; case n0; simpl in |- *; auto.
intros n1; rewrite <- plus_n_Sm; simpl in |- *; intros; discriminate.
apply mult_inv with (m1 := m1).
pattern (S m1) at 2 in |- *; rewrite H0; rewrite H; ring.
Qed.

Theorem gcd_sym : forall m1 m2, gcd m1 m2 = gcd m2 m1.
intros m1 m2; apply divides_id; auto.
apply divides_gcd3; auto.
apply divides_gcd2; auto.
apply divides_gcd1; auto.
apply divides_gcd3; auto.
apply divides_gcd2; auto.
apply divides_gcd1; auto.
Qed.

(** Definition of the lcm of two numbers *)
Definition lcm m1 m2 := div (m1 * m2) (gcd m1 m2).

Theorem divides_div :
 forall m1 m2, 0 < m1 -> divides m1 m2 -> m2 = m1 * div m2 m1.
intros m1 m2 H0 (m3, H).
case (div_correct m2 m1); auto.
intros H1 H2; auto.
apply le_antisym; auto.
case (le_or_lt m3 (div m2 m1)); intros H3.
pattern m2 at 1 in |- *; rewrite H; auto with arith.
Contradict H2; auto with arith.
apply le_not_lt.
pattern m2 at 2 in |- *; rewrite H; auto with arith.
Qed.

Theorem gcd_lt_zero : forall m1 m2, 0 < m1 -> 0 < m2 -> 0 < gcd m1 m2.
intros m1 m2 H H0.
generalize (divides_gcd1 m1 m2).
case (gcd m1 m2); simpl in |- *; auto with arith.
intros (m3, H1).
Contradict H; rewrite H1; simpl in |- *; auto with arith.
Qed.

Theorem mult_inv1 :
 forall m1 m2 m3 : nat, 0 < m1 -> m1 * m2 = m1 * m3 -> m2 = m3.
intros m1 m2 m3; case m1.
intros H; Contradict H; auto with arith.
intros n H H0; apply mult_inv with (m1 := n); auto.
Qed.

Theorem divides_lcm1 :
 forall m1 m2, 0 < m1 -> 0 < m2 -> divides m1 (lcm m1 m2).
intros m1 m2 H H0.
generalize (divides_gcd1 m1 m2); intros (m3, H1).
generalize (divides_gcd2 m1 m2); intros (m4, H2).
exists m4.
apply mult_inv1 with (m1 := gcd m1 m2).
apply gcd_lt_zero; auto.
unfold lcm in |- *; simpl in |- *.
rewrite <- divides_div.
pattern m2 at 1 in |- *; rewrite H2; ring.
apply gcd_lt_zero; auto.
apply divides_trans with (m2 := m1); auto.
apply divides_gcd1.
exists m2; ring.
Qed.

Theorem lcm_sym : forall a b, lcm a b = lcm b a.
intros a b; unfold lcm in |- *.
rewrite (mult_comm a); rewrite gcd_sym; auto.
Qed.

Theorem divides_lcm2 :
 forall m1 m2, 0 < m1 -> 0 < m2 -> divides m2 (lcm m1 m2).
intros m1 m2 H H0; rewrite lcm_sym; apply divides_lcm1; auto.
Qed.

Theorem divides_lcm3 :
 forall m1 m2 m3,
 0 < m1 -> 0 < m2 -> divides m1 m3 -> divides m2 m3 -> divides (lcm m1 m2) m3.
intros m1 m2 m3; case m3.
intros H H0 H1 H2; exists 0; ring.
clear m3; intros m3 H1 H2 H3 H4.
generalize (divides_gcd1 m1 m2); intros (m6, H5).
generalize (divides_gcd2 m1 m2); intros (m7, H6).
apply divides_trans with (gcd (lcm m1 m2) (S m3)); auto.
2: apply divides_gcd2.
generalize (divides_gcd1 (lcm m1 m2) (S m3)); intros (m8, H7).
pattern (lcm m1 m2) at 1 in |- *; rewrite H7.
replace m8 with 1; [ exists 1; ring | idtac ].
cut (divides (gcd m1 m2 * m8) (gcd m1 m2)); [ intros (m9, H8) | idtac ].
cut (1 = m8 * m9).
case m9.
rewrite mult_comm; simpl in |- *; intros; discriminate.
intros n1; case m8; simpl in |- *; auto.
intros n2; case n2; simpl in |- *; auto.
intros n3; rewrite <- plus_n_Sm; simpl in |- *; intros; discriminate.
apply mult_inv1 with (m1 := gcd m1 m2).
apply gcd_lt_zero; auto.
pattern (gcd m1 m2) at 1 in |- *; rewrite H8; ring.
apply divides_gcd3.
cut (divides m2 (gcd (lcm m1 m2) (S m3))); [ intros (m9, H8) | idtac ].
exists m9.
apply mult_inv1 with (m1 := m2); auto.
apply trans_equal with (gcd m1 m2 * (m2 * m9 * m8)); [ idtac | ring ].
rewrite <- H8; rewrite <- H7.
rewrite (mult_comm m2); unfold lcm in |- *; apply divides_div; auto.
apply gcd_lt_zero; auto.
apply divides_trans with m1; auto.
apply divides_gcd1.
exists m2; ring.
apply divides_gcd3; auto.
apply divides_lcm2; auto.
cut (divides m1 (gcd (lcm m1 m2) (S m3))); [ intros (m9, H8) | idtac ].
exists m9.
apply mult_inv1 with (m1 := m1); auto.
apply trans_equal with (gcd m1 m2 * (m1 * m9 * m8)); [ idtac | ring ].
rewrite <- H8; rewrite <- H7.
unfold lcm in |- *; apply divides_div; auto.
apply gcd_lt_zero; auto.
apply divides_trans with m1; auto.
apply divides_gcd1.
exists m2; ring.
apply divides_gcd3; auto.
apply divides_lcm1; auto.
Qed.

Theorem lcm_lt_O : forall a b, 0 < a -> 0 < b -> 0 < lcm a b.
intros a b H H1; case (le_or_lt (lcm a b) 0); auto; intros H2.
cut (lcm a b = 0); [ intros H3 | inversion H2; auto ].
absurd (0 < a * b); auto with arith.
rewrite (divides_div (gcd a b) (a * b)); auto.
change (~ 0 < gcd a b * lcm a b) in |- *.
rewrite H3; rewrite mult_comm; simpl in |- *; auto with arith.
apply gcd_lt_zero; auto.
apply divides_trans with a; auto.
apply divides_gcd1; auto.
exists b; ring; auto.
generalize H H1; case a; simpl in |- *.
intros H6; Contradict H6; auto with arith.
intros n; case n; simpl in |- *; auto with arith.
Qed.

Theorem mult_lt_ZERO : forall a b, 0 < a -> 0 < b -> 0 < a * b.
intros a; case a.
intros b H; Contradict H; auto with arith.
intros a1 b H; case b; simpl in |- *; auto with arith.
intros H1; Contradict H1; auto with arith.
Qed.

Theorem div_lt_ZERO :
 forall a b, 0 < a -> 0 < b -> a = div a b * b -> 0 < div a b.
intros a b H H0; case (div a b); simpl in |- *; auto with arith.
intros H1; Contradict H; rewrite H1; auto with arith.
Qed.

Theorem max_Or : forall a b, max a b = a \/ max a b = b.
intros a; elim a; simpl in |- *; auto.
intros n H b; case b; simpl in |- *; auto.
intros n0; case (H n0); intros H1; rewrite H1; auto.
Qed.


Require Import XR_Rabs.
Require Import XR_Rcase_abs.
Require Import XR_Rle_antisym.
Require Import XR_Rle_trans.
Require Import XR_Ropp_0.
Require Import XR_Ropp_le_contravar.

Local Open Scope R_scope.

Lemma Rabs_pos_eq : forall x:R, R0 <= x -> Rabs x = x.
Proof.
  intros x h.
  unfold Rabs.
  destruct (Rcase_abs x) as [ hl | hr ].
  {
    apply Rle_antisym.
    {
      apply Rle_trans with R0.
      {
        rewrite <- Ropp_0.
        apply Ropp_le_contravar.
        exact h.
      }
      { exact h. }
    }
    {
      apply Rle_trans with R0.
      {
        left.
        exact hl.
      }
      {
        rewrite <- Ropp_0.
        apply Ropp_le_contravar.
        left.
        exact hl.
      }
    }
  }
  { reflexivity. }
Qed.


(** * Tutorial for QuickChick *)

(** QuickChick is a clone of Haskell's QuickCheck, slightly on
    steroids.  This tutorial explores basic aspects of random
    property-based testing and details the majority of features of
    QuickChick. *)

(* begin hide *)
From QuickChick Require Import QuickChick.
Import QcDefaultNotation. Open Scope qc_scope.
Set Warnings "-extraction-opaque-accessed,-extraction".

Require Import List ZArith.
Import ListNotations.

Require Import mathcomp.ssreflect.ssreflect.
From mathcomp Require Import seq ssreflect ssrbool ssrnat eqtype.

(* end hide *)

(** ** Introduction *)

(** It is not uncommon during a verification effort to spend many
    hours attempting to prove a slightly false theorem, only to result
    in frustration when the mistake is realized and one needs to start
    over. Other theorem provers have testing tools to quickly raise
    one's confidence before embarking on the body of the proof;
    Isabelle has its own QuickCheck clone, as well as Nitpick,
    Sledgehammer and a variety of other tools; ACL2 has gone a step
    further using random testing to facilitate its
    automation. QuickChick is meant to fill this void for Coq.

    Consider the following short function [remove] that takes a
    natural number [x] and a list of nats [l] and proceeds to remove
    [x] from the list. While one might be tempted to pose the question
    "Is there a bug in this definition?", such a question has little
    meaning without an explicit specification. Here, [removeP]
    requires that after removing [x] from [l], the resulting list does
    not contain any occurences of [x]. *)

Fixpoint remove (x : nat) (l : list nat) : list nat :=
  match l with
    | []   => []
    | h::t => if beq_nat h x then t else h :: remove x t
  end.

Definition removeP (x : nat) (l : list nat) :=
  (~~ (existsb (fun y => beq_nat y x) (remove x l))).

(** For this simple example, it is not hard to "spot" the bug by
    inspection. We will use QuickChick to find out what is wrong.

    QuickChick provides a toplevel command [QuickChick] that receives
    as input an executable property and attempts to falsify it. *)

QuickChick removeP.

(** Internally, the code is extracted to OCaml, compiled and ran to
obtain the output:
<<
    0

    [ 0, 0 ]

    Failed! After 17 tests and 12 shrinks
>>
    The output signifies that if we use an input where [x] is [0] and
    [l] is the two element list containing two zeros, then our
    property fails. Indeed, we can now identify that the [then] branch
    of [remove] fails to make a recursive call, which means that only
    one occurence of each element will be deleted. The last line of
    the output states that it took 17 tests to identify some fault
    inducing input and 12 shrinks to reduce it to a minimal
    counterexample.

    Before we begin to explain exactly how QuickChick magically comes
    up with this result, it is important to point out the first (and
    arguably most important) limitation of this tool: it requires an
    *executable* specification. QuickChick needs to be able to "run" a
    property and decide whether it is true or not; a definition like
    [remove_spec] can't be QuickChecked! *)

Definition remove_spec :=
  forall x l, ~ In x (remove x l).

(** QuickChick requires either a functional spec (like [removeP]) or a
    decidability procedure for an inductive spec. *)

(** ** Property Based Random Testing Ingredients

    There are four basic ingredients in property based random testing:

    - An executable property, as discussed above
    - A printer, to report counterexamples found
    - A generator, to produce random inputs
    - A shrinker, to reduce counterexamples.

    We will now review the latter three in order. *)

(** *** Printing

    For printing, QuickChick uses a [Show] typeclass, like Haskell. *)

Print Show.
(**  ==> Record Show (A : Type) : Type
            := Build_Show { show : A -> String.string }   *)

(** The [Show] typeclass contains a single function [show] from some
    type [A] to Coq's [string]. QuickChick provides default instances
    for [string]s (the identity function), [nat], [bool], [Z],
    etc. (via extraction to appropriate OCaml functions for
    efficiency), as well as some common compound datatypes: lists,
    pairs and options.

    Writing your own show instance is easy! Let's define a simple
    [Color] datatype. *)

Inductive Color := Red | Green | Blue | Yellow.

(** After ensuring we have opened the [string] scope, we can declare
    an instance of [Show Color] by encoding [show] as a simple pattern
    matching on colors. *)

Require Import String. Open Scope string.
Instance show_color : Show Color :=
  {| show c :=
       match c with
         | Red    => "Red"
         | Green  => "Green"
         | Blue   => "Blue"
         | Yellow => "Yellow"
       end
  |}.

Eval compute in (show Green).
(** ==> "Green" : string *)

(** While writing show instances is relatively straightforward, it can
    get tedious.  The QuickChick provides a lot of automation, which
    will be discussed at the end of this Tutorial. *)

(** *** Generators *)

(** **** The [G] Monad *)

(** The heart of property based random testing is the random
    generation of inputs.  In QuickChick, a generator for elements of
    some type [A] is a monadic object with type [G A]. The monad [G]
    serves as an abstraction over random seed plumbing. Consider
    writing a program that given a random seed generates many
    integers: one needs to use the given seed to produce an integer
    while at the same time obtain a new, altered seed to use for
    future draws. This [State]-monad like behavior is hidden behind
    [G].

    Standard monadic functions have the [Gen] suffix. *)

Check bindGen.
(** ==> bindGen : G ?A -> (?A -> G ?B) -> G ?B *)

Check returnGen.
(** ==> returnGen : ?A -> G ?A *)

(** For those familiar with Haskell's monadic interface, QuickChick
    also provides variants of [liftM] (as [liftGen]) with arities 1 to
    5, [sequence] (as [sequenceGen]) and [foldM] (as [foldGen]). *)

(** **** Primitive generators *)

(** Primitive generators for booleans, natural numbers and integers
    are provided via extraction to OCaml. They can be accessed via the
    [choose] combinator.
 *)

Check choose.
(** ==> choose : Z * Z -> G Z *)

(** While here [choose] is monomorphised to [Z], it actually takes an
    interval of any type [A] that satisfies a [ChoosableFromInterval]
    typeclass (with default standard numeric instances) and produces
    an object of type [A] within that interval.

    We can see that in action using [Sample]. This is another toplevel
    command by QuickChick that runs a generator a number of times and
    prints whatever was generated in the form of a list. *)

Sample (choose(0, 10)).
(** ==> [ 1, 2, 1, 9, 8, 1, 3, 6, 2, 1, 8, 0, 1, 1, 3, 5, 4, 10, 4, 6 ] *)

(** **** Lists *)

(** Due to being the most commonly used compound datatype, lists have
    special combinators in Haskell's QuickCheck. The same is true in
    QuickChick; there are two combinators, [listOf] and [vectorOf]. *)

Check listOf.
(** ==> listOf : G ?A -> G (list ?A) *)

(** [listOf] takes as input a generator for elements of type [A] and returns a
    generator for lists of the same type. *)

Sample (listOf (choose (0,4))).
(** ==> [ [ 0, 3, 2, 0 ],
         [ 1, 3, 4, 1, 0, 3, 0, 2, 2, 3, 2, 2, 2, 0, 4, 2, 3, 0, 1 ],
         [ 3, 4, 3, 1, 2, 4, 4, 1, 0, 3, 4, 3, 2, 2, 4, 4, 1 ],
         [ 0 ],
         [ 4, 2, 3 ],
         [ 3, 3, 4, 0, 1, 4, 3, 2, 4, 1 ],
         [ 0, 4 ],
         [  ],
         [ 1, 0, 1, 3, 1 ],
         [ 0, 0 ],
         [ 1, 4 ],
         [ 4, 3, 2, 0, 2, 2, 4, 0 ],
         [ 1, 1, 0, 0, 1, 4 ],
         [ 2, 0, 2, 1, 3, 3 ],
         [ 4, 3, 3, 0, 1 ],
         [ 3, 3, 3 ],
         [ 3, 2, 4 ],
         [ 1, 2 ],
         [  ],
         [  ]
       ]
*)

(** The second combinator, [vectorOf], receives an additional numeric
    argument [n], the length of the list to be generated. *)

Check vectorOf.
(** ==> vectorOf : nat -> G ?A -> G (list ?A) *)

(** This raises a question: how does [listOf] decide how big of a list
    to generate? The answer is hidden inside the [G] monad.

    In addition to handling random seed plumbing, the [G] monad also
    provides a [Reader]-like environment with size information: a
    natural number [n] that nominally serves as the upper bound on the
    depth of the generated objects.  QuickChick progressively tries
    larger and larger values for [n], in order to explore larger and
    deeper part of the search space. Note that each generator can
    choose to interpret this input size however it wants and there is
    no guarantee that all generators comply to this standard - it is
    more of a "good practice" when writing one to respect this
    bound. *)

(** **** Custom Datatypes *)

(** Naturally, a lot of the time one needs to write generators involving
    user-defined datatypes. Let's revisit our color datatype; to generate a
    color, we only need to pick one of its four constructors, [Red], [Green],
    [Blue] and [Yellow]. This is done using [elements]. *)

Check elements.
(** ==> elements : ?A -> list ?A -> G ?A *)

(** This is the first place where the totality checker of Coq raises a
    design question. While Haskell's QuickCheck can simply fail
    raising an [error] whenever the input list is empty, Coq does not
    allow that behavior. Instead of increasing the burden to the user
    by requiring a proof that the list is not empty or by making the
    return type an option, QuickChick requires an additional element
    of type [A] as input to serve as a "default" object.  If the list
    is not empty, [elements] returns a generator that picks an element
    of that list; otherwise the generator always returns the default
    object.

    Moreover, QuickChick provides convenient notation to hide this
    default if it is apparent from the structure. *)

(*
Notation            Scope
" 'elems' [ x ] " := elements x (cons x nil)
                      : qc_scope
                      (default interpretation)
" 'elems' [ x ; y ] " := elements x (cons x (cons y nil))
                      : qc_scope
                      (default interpretation)
" 'elems' [ x ; y ; .. ; z ] " := elements x
                                    (cons x (cons y .. (cons z nil) ..))
                      : qc_scope
                      (default interpretation)
" 'elems' ( x ;; l ) " := elements x (cons x l)
                      : qc_scope
                      (default interpretation)
*)

(** Armed with [elems], we can write the following simple [Color]
    generator. *)

Definition genColor : G Color :=
  elems [ Red ; Green ; Blue ; Yellow ].

Sample genColor.
(** ==> [ Blue, Red, Yellow, Red, Blue, Yellow, Yellow, Blue, Green, Red, Green,
         Blue, Blue, Red, Yellow, Blue, Red, Blue, Blue, Red ] *)

(** For more complicated ADTs, QuickChick provides more
    combinators. We will showcase them using everyone's favorite
    datatype: Trees!

    Our trees are standard binary trees; either [Leaf]s or [Node]s
    containing some payload of type [A] and two subtrees. *)

Inductive Tree A :=
| Leaf : Tree A
| Node : A -> Tree A -> Tree A -> Tree A.

Arguments Leaf {A}.
Arguments Node {A} _ _ _.

(** Before getting to generators for trees, we give a simple [Show]
    instance.  The rather inconvenient need for a local [let fix]
    declaration stems from the fact that Coq's typeclasses (unlike
    Haskell's) are not automatically recursive. *)

Instance showTree {A} `{_ : Show A} : Show (Tree A) :=
  {| show :=
       let fix aux t :=
         match t with
           | Leaf => "Leaf"
           | Node x l r => "Node (" ++ show x ++ ") (" ++ aux l ++ ") (" ++ aux r ++ ")"
         end
       in aux
  |}.

(** The first combinator that actually combines different generators
    is [oneof]. *)

Check oneof.
(** ==> oneof : G ?A -> list (G ?A) -> G ?A *)

(** [oneof] takes a default generator and a list of generators, and
    picks one of the generators from the list uniformly at random, as
    long as the list is not empty.  Just like before, QuickChick
    introduces the notation [oneOf] to hide this default element.

    At this point, Coq's termination checker saves us from shooting
    ourselves in the foot. The "obvious" first generator that one
    might write is the following [genTree]: either generate a [Leaf]
    or a [Node] whose subtrees are generated recursively and whose
    payload is produced by a generator for elements of type [A].*)

(*
Fixpoint genTree {A} (g : G A) : G (Tree A) :=
  oneOf [ returnGen Leaf ;
          liftGen3 Node  g (genTree g) (genTree g) ].*)

(** Of course, this fixpoint will not pass Coq's termination
    check. Attempting to justify this fixpoint to oneself, one might
    say that at some point the random generation will pick a [Leaf] so
    it will eventually terminate. Sadly, in this case the expected
    size of the generated Tree is infinite...

    The solution is the standard "fuel" solution Coq users are so
    familiar with: we add an additional natural number [sz] as a
    parameter; when that parameter is [O] we only generate
    non-recursive branches, while we decrease this size in each
    recursive call. Thus, [sz] serves as a bound on the depth of the
    tree.

 *)

Fixpoint genTreeSized {A} (sz : nat) (g : G A) : G (Tree A) :=
  match sz with
    | O => returnGen Leaf
    | S sz' => oneOf [ returnGen Leaf ;
                       liftGen3  Node g (genTreeSized sz' g) (genTreeSized sz' g)
                     ]
  end.

Sample (genTreeSized 3 (choose(0,3))).
(** ==> [ Leaf,
         Leaf,
         Node (3) (Node (0) (Leaf) (Leaf)) (Node (2) (Leaf) (Node (3) (Leaf) (Leaf))),
         Leaf,
         Leaf,
         Leaf,
         Node (1) (Leaf) (Node (1) (Leaf) (Node (0) (Leaf) (Leaf))),
         Leaf,
         Node (3) (Leaf) (Leaf),
         Node (1) (Leaf) (Leaf),
         Leaf,
         Leaf,
         Node (0) (Leaf) (Node (0) (Leaf) (Node (2) (Leaf) (Leaf))),
         Node (0) (Node (2) (Node (3) (Leaf) (Leaf)) (Leaf)) (Leaf),
         Node (0) (Leaf) (Leaf),
         Leaf,
         Leaf,
         Leaf,
         Leaf,
         Leaf ]
*)

(** While this generator succesfully generated trees, just by
    observing [Sample] above there is a problem: [genTreeSized]
    produces way too many [Leaf]s! That is to be expected, 50% of the
    time we generate a [Leaf]. The solution is to skew the
    distribution towards [Node]s, using the most expressive QuickChick
    combinator, [frequency] and its associated default-lifting
    notation [freq].
 *)
Check frequency.
(** ==> frequency : G ?A -> seq (nat * G ?A) -> G ?A *)

(** [freq] takes a list of generators, each one tagged with a natural
    number that serves as the weight of that generator. In the
    following example, a [Leaf] will be generated 1 / (sz + 1) of the
    time, while a [Node] the remaining sz / (sz + 1) of the time.*)

Fixpoint genTreeSized' {A} (sz : nat) (g : G A) : G (Tree A) :=
  match sz with
    | O => returnGen Leaf
    | S sz' => freq [ (1,  returnGen Leaf) ;
                      (sz, liftGen3  Node g (genTreeSized' sz' g) (genTreeSized' sz' g))
                    ]
  end.

Sample (genTreeSized' 3 (choose(0,3))).
(** ==> [ Node (3) (Node (1) (Node (3) (Leaf) (Leaf)) (Leaf)) (Node (0) (Leaf) (Node (3) (Leaf) (Leaf))),
         Leaf,
         Node (2) (Node (1) (Leaf) (Leaf)) (Leaf),
         Node (0) (Leaf) (Node (0) (Node (2) (Leaf) (Leaf)) (Node (0) (Leaf) (Leaf))),
         Node (1) (Node (2) (Leaf) (Node (0) (Leaf) (Leaf))) (Leaf),
         Node (0) (Node (0) (Leaf) (Node (3) (Leaf) (Leaf))) (Node (2) (Leaf) (Leaf)),
         Node (1) (Node (3) (Node (2) (Leaf) (Leaf)) (Node (3) (Leaf) (Leaf))) (Node (1) (Leaf) (Node (2) (Leaf) (Leaf))),
         Node (0) (Node (0) (Node (0) (Leaf) (Leaf)) (Node (1) (Leaf) (Leaf))) (Node (2) (Node (3) (Leaf) (Leaf)) (Node (0) (Leaf) (Leaf))),
         Node (2) (Node (2) (Leaf) (Leaf)) (Node (1) (Node (2) (Leaf) (Leaf)) (Node (2) (Leaf) (Leaf))),
         Node (2) (Node (3) (Node (2) (Leaf) (Leaf)) (Leaf)) (Node (0) (Node (2) (Leaf) (Leaf)) (Leaf)),
         Leaf,
         Node (2) (Node (3) (Node (3) (Leaf) (Leaf)) (Leaf)) (Leaf),
         Leaf,
         Node (1) (Leaf) (Leaf),
         Leaf,
         Node (1) (Node (2) (Leaf) (Node (3) (Leaf) (Leaf))) (Node (0) (Leaf) (Node (1) (Leaf) (Leaf))),
         Leaf,
         Node (3) (Node (0) (Node (0) (Leaf) (Leaf)) (Leaf)) (Node (0) (Leaf) (Node (2) (Leaf) (Leaf))),
         Node (2) (Node (2) (Node (0) (Leaf) (Leaf)) (Leaf)) (Node (1) (Leaf) (Node (2) (Leaf) (Leaf))),
         Leaf ]
 *)

(** To showcase this generator, we will use the notion of mirroring a
    tree: swapping its left and right subtrees recursively. *)

Fixpoint mirror {A : Type} (t : Tree A) : Tree A :=
  match t with
    | Leaf => Leaf
    | Node x l r => Node x (mirror r) (mirror l)
  end.

(** We also need a simple structural equality on trees *)
Fixpoint eq_tree (t1 t2 : Tree nat) : bool :=
  match t1, t2 with
    | Leaf, Leaf => true
    | Node x1 l1 r1, Node x2 l2 r2 =>
      beq_nat x1 x2 && eq_tree l1 l2 && eq_tree r1 r2
    | _, _ => false
  end.

(** One expects that [mirror] should be unipotent; mirroring a tree
    twice yields the original tree.  *)

Definition mirrorP (t : Tree nat) := eq_tree (mirror (mirror t)) t.

(** To test this assumption, we can use the [forAll] property
    combinator that receives a generator [g] for elements of type [A]
    and an executable property with argument [A] and tests the
    property on random inputs of [g]. *)

QuickChick (forAll (genTreeSized' 5 (choose (0,5))) mirrorP).

(** QuickChick quickly responds that this property passed 10000 tests,
    so we gain some confidence in its truth. But what would happend if
    we had the *wrong* property? *)

Definition faultyMirrorP (t : Tree nat) := eq_tree (mirror t) t.

QuickChick (forAll (genTreeSized' 5 (choose (0,5))) faultyMirrorP).
(** ==> Node (3) (Node (0) (Leaf) (Node (0) (Node (1) (Leaf) (Leaf)) (Leaf)))
(Node (5) (Node (0) (Node (1) (Leaf) (Node (4) (Leaf) (Leaf))) (Node (4) (Leaf)
(Node (0) (Leaf) (Leaf)))) (Node (5) (Node (4) (Node (0) (Leaf) (Leaf)) (Leaf))
(Node (3) (Leaf) (Leaf))))

*** Failed! After 1 tests and 0 shrinks
*)

(** The bug is found immediately and reported. However, is this counterexample
    really helpful? What is the important part of it? The reported bug is too
    big and noisy to identify the root cause of the problem. That is where
    shrinking comes in. *)

(** **** Shrinking *)

(** Shrinking, also known as delta debugging, is a greedy process by
    which we can find a smaller counterexample given a relatively
    large one. Given a shrinking function [s] of type [A -> list A]
    and a counterexample [x] of type [A] that is known to falsify some
    property [p], QuickChick (lazily) tries [p] on all members of [s
    x] until it finds another counterexample; then it repeats this
    process.

    This greedy algorithm can only work if all elements of [s x] are
    strictly "smaller" that [x] for all [x]. Most of the time, a
    shrinking function for some type only returns elements that are
    "one step" smaller. For example, consider the default shrinking
    function for lists provided by QuickChick. *)

Print shrinkList.
(** ==> shrinkList =
     fix shrinkList (A : Type) (shr : A -> seq A) (l : seq A) {struct l} :
       seq (seq A) :=
       match l with
       | [::] => [::]
       | x :: xs =>
           ((xs :: List.map (fun xs' : seq A => x :: xs') (shrinkList A shr xs))%SEQ ++
            List.map (fun x' : A => (x' :: xs)%SEQ) (shr x))%list
       end
          : forall A : Type, (A -> seq A) -> seq A -> seq (seq A)
*)

(** An empty list can not be shrunk - there is no smaller list.  A
    cons cell can be shrunk in three ways: by returning the tail of
    the list, by shrinking the tail of the list and consing the head,
    or by shrinking the head and consing its tail. By induction, this
    process can generate all smaller lists.

    Writing a shrinking instance for trees is equally straightforward:
    we don't shrink [Leaf]s while for [Node]s we can return the left
    or right subtrees, shrink the payload or one of the subtrees.*)

Open Scope list.
Fixpoint shrinkTree {A} (s : A -> list A) (t : Tree A) : seq (Tree A) :=
  match t with
    | Leaf => []
    | Node x l r => [l] ++ [r] ++
                    map (fun x' => Node x' l r) (s x) ++
                    map (fun l' => Node x l' r) (shrinkTree s l) ++
                    map (fun r' => Node x l r') (shrinkTree s r)
  end.

(** Armed with [shrinkTree], we use the [forAllShrink] property
    combinator that takes an additional argument, a shrinker *)

QuickChick (forAllShrink (genTreeSized' 5 (choose (0,5))) (shrinkTree shrink) faultyMirrorP).

(** ==> Node (0) (Leaf) (Node (0) (Leaf) (Leaf))

*** Failed! After 1 tests and 8 shrinks *)

(** We now got a much simpler counterexample (in fact, this is one of
    the two minimal ones) and can tell that the real problem occurs
    when the subtrees of a [Node] are different. *)

(** **** Putting it all Together *)

(** QuickChick, just like QuickCheck, provides an [Arbitrary]
    typeclass parameterized over some type [A] with two objects:
    [arbitrary] and [shrink].

    The [arbitrary] object is a generator for elements of type [A]. If
    we were to encode an [Arbitrary] instance for trees we would like
    to use [genTreeSized']; however that generator takes an additional
    size argument.  The [G] monad will provide that argument through
    the combinator [sized].*)

Check sized.
(** ==> sized : (nat -> G ?A) -> G ?A *)

(** [sized] receives a function that given a number produces a
    generator, just like [genTreeSized'], and returns a generator that
    uses the size information inside the [G] monad.

    The [shrink] function is simply a shrinker like [shrinkTree]. *)

Instance genTree {A} `{Gen A} : GenSized (Tree A) :=
  {| arbitrarySized n := genTreeSized n arbitrary |}.

Instance shrTree {A} `{Shrink A} : Shrink (Tree A) :=
  {| shrink x := shrinkTree shrink x |}.

(** With this [Arbitrary] instance we can once again use the toplevel
    [QuickChick] command with just the property.  *)

QuickChick faultyMirrorP.

(** [QuickChick] internally calls the function [quickCheck] with type
    [forall prop. Checkable prop => prop -> Result]. But what _is_
    [Checkable]? It is easy to see how a boolean is [Checkable]; we
    can always tell if it is true or not and then return a [Result],
    [Success]/[Failure] as appropriate.

    To see how executable properties are [Checkable], consider a
    single argument function [p : A -> Bool] that returns a
    boolean. If we know that [A] has [Show] and [Arbitrary] instances,
    we can just call [forAllShrink] with [arbitrary] and
    [shrink]. Going a step further, the result type doesn't really
    need to be [Bool], it can be a [Checkable]! Thus, we can provide a
    [Checkable] instance for arbitrary functions.*)

Print testFun.

(** **** Collecting Statistics *)

(** Earlier in this tutorial we claimed that [genTreeSized] produced
    "too many" [Leaf]s. But how can we justify that? Just looking at
    the result of [Sample] gives us an idea that something is going
    wrong but just observing a handful of samples cannot realistically
    provide statistical guarantees. That is where [collect], another
    property combinator, comes in. In Haskell notation, [collect]
    would have the type [collect : Show A, Checkable prop => A -> prop
    -> prop]; it takes some value of type [A] that can be shown and a
    property, and returns the property itself. Whenever the resulting
    property is exercised, the [A] object is captured and statistics
    are collected.

    For example, consider a [size] function on [Tree]s.
 *)

Fixpoint size {A} (t : Tree A) : nat :=
  match t with
    | Leaf => O
    | Node _ l r => 1 + size l + size r
  end.

(** If we were to write a dummy property to check our generators and
    measure the size of generated trees, we could use [treeProp]
    below. *)

Definition treeProp (g : nat -> G nat -> G (Tree nat)) n :=
  forAll (g n (choose (0,n))) (fun t =>
  collect (size t) true).

QuickChick (treeProp genTreeSized  5).

(** ==>
4947 : 0
1258 : 1
673 : 2
464 : 6
427 : 5
393 : 3
361 : 7
302 : 4
296 : 8
220 : 9
181 : 10
127 : 11
104 : 12
83 : 13
64 : 14
32 : 15
25 : 16
16 : 17
13 : 18
6 : 19
5 : 20
2 : 21
1 : 23
+++ OK, passed 10000 tests

We see that 62.5% of the tests are either [Leaf]s or empty [Nodes], while too
few tests have larger sizes. Compare that with [genTreeSized'] below.  *)

QuickChick (treeProp genTreeSized' 5).
(** ==>
1624 : 0
571 : 10
564 : 12
562 : 11
559 : 9
545 : 8
539 : 14
534 : 13
487 : 7
487 : 15
437 : 16
413 : 6
390 : 17
337 : 5
334 : 1
332 : 18
286 : 19
185 : 4
179 : 20
179 : 2
138 : 21
132 : 3
87 : 22
62 : 23
19 : 24
10 : 25
6 : 26
2 : 27
+++ OK, passed 10000 tests

A lot fewer terms have small sizes, allowing us to explore larger terms*)

(** ** Avoiding Work  :) *)

(** While a lot of time putting a bit of time and effort in a
    generator and a shrinker, the examples shown here are fairly
    straightforward. After writing a couple of [Show] and [Arbitrary]
    instances, it can get tedious and boring. That is precisely why
    [QuickChick] provides some automation in deriving such instances
    for _plain_ datatypes automatically. *)

Derive Arbitrary for Tree.
(* GenSizedTree is defined *)
(* ShrinkTree is defined *)
Print GenSizedTree.
Print ShrinkTree.

Derive Show for Tree.
(* ShowTree is defined *)
Print ShowTree.