From FA Require Import String.
From mathcomp Require Import all_ssreflect.

Class KA (A: Type) (plus: A -> A -> A) (times: A -> A -> A) (star: A -> A) (zero: A) (one: A): Type :=
 {
   ax1 : forall a b c, plus a (plus b c) = plus (plus a b) c;
   ax2 : forall a b, plus a b = plus b a;
   ax3 : forall a, plus a a = a;
   ax4 : forall a, plus a zero = a;
   ax5 : forall a, times a zero = zero;
   ax6 : forall a, times zero a = zero;
   ax7 : forall a, times one a = a;
   ax8 : forall a, times a one = a;
   ax9 : forall a b c, times a (times b c) = times (times a b) c;
   ax10: forall a b c, times (plus a b) c = plus (times a c) (times b c);
   ax11: forall a b c, times a (plus b c) = plus (times a b) (times a c);
   leq a b := plus a b = b;
   ax12: forall a, plus one (times a (star a)) = star a;
   ax13: forall a, plus one (times (star a) a) = star a;
   ax14: forall a b c, leq (plus b (times a c)) c -> leq (times (star a) b) c;
   ax15: forall a b c, leq (plus b (times c a)) c -> leq (times b (star a)) c
 }.

(* Definition leq {A: Type} {plus: A -> A -> A} {times: A -> A -> A} {zero: A} {one: A}
               {s: ISR A plus times zero one} (a b: A) := plus a b = b. *)

Lemma leq_refl: forall {A: Type} {plus: A -> A -> A} {times: A -> A -> A} {star: A -> A} {zero: A} {one: A}
                       {s: KA A plus times star zero one} (a: A), leq a a.
Proof. intros.
       unfold leq.
       rewrite ax3.
       reflexivity.
Qed.

Lemma leq_trans: forall {A: Type} {plus: A -> A -> A} {times: A -> A -> A} {star: A -> A} {zero: A} {one: A}
                        {s: KA A plus times star zero one} (a b c: A), leq a b -> leq b c -> leq a c.
Proof. intros A plus times star zero one s a b c Ha Hb.
       unfold leq in *.
       setoid_rewrite <- Hb at 1.
       rewrite <- Ha in Hb.
       rewrite ax1.
       exact Hb.
Qed.

Lemma leq_antisym: forall {A: Type} {plus: A -> A -> A} {times: A -> A -> A} {star: A -> A} {zero: A} {one: A}
                          {s: KA A plus times star zero one} (a b: A), leq a b -> leq b a -> a = b.
Proof. intros A plus times star zero one s a b Ha Hb.
       unfold leq in *.
       rewrite <- Ha.
       setoid_rewrite <- Hb at 1.
       rewrite ax2.
       reflexivity.
Qed.

Lemma leq_antisym_eq: forall {A: Type} {plus: A -> A -> A} {times: A -> A -> A} {star: A -> A} {zero: A} {one: A}
                          {s: KA A plus times star zero one} (a b: A), a = b -> leq a b /\ leq b a.
Proof. intros.
       unfold leq in *.
       subst.
       rewrite ax3.
       easy.
Qed.

Lemma leq_mono_pr: forall {A: Type} {plus: A -> A -> A} {times: A -> A -> A} {star: A -> A} {zero: A} {one: A}
                          {s: KA A plus times star zero one} (a b x: A), leq a b -> leq (plus a x) (plus b x).
Proof. intros.
       unfold leq in *.
       rewrite ax1.
       setoid_rewrite ax2 at 3.
       setoid_rewrite <- ax1 at 2.
       rewrite H.
       setoid_rewrite ax2 at 2.
       rewrite <- ax1.
       rewrite ax3.
       reflexivity.
Qed.

Lemma leq_mono_pl: forall {A: Type} {plus: A -> A -> A} {times: A -> A -> A} {star: A -> A} {zero: A} {one: A}
                          {s: KA A plus times star zero one} (a b x: A), leq a b -> leq (plus x a) (plus x b).
Proof. intros.
       unfold leq in *.
       rewrite ax1.
       setoid_rewrite ax2 at 3.
       setoid_rewrite <- ax1 at 2.
       rewrite ax3.
       setoid_rewrite <- ax2 at 2.
       rewrite <- ax1.
       rewrite H.
       reflexivity.
Qed.

Lemma leq_mono_tl: forall {A: Type} {plus: A -> A -> A} {times: A -> A -> A} {star: A -> A} {zero: A} {one: A}
                          {s: KA A plus times star zero one} (a b x: A), leq a b -> leq (times a x) (times b x).
Proof. intros.
       unfold leq in *.
       rewrite <- ax10.
       rewrite H.
       reflexivity.
Qed.

Lemma leq_mono_tr: forall {A: Type} {plus: A -> A -> A} {times: A -> A -> A} {star: A -> A} {zero: A} {one: A}
                          {s: KA A plus times star zero one} (a b x: A), leq a b -> leq (times x a) (times x b).
Proof. intros.
       unfold leq in *.
       rewrite <- ax11.
       rewrite H.
       reflexivity.
Qed.

Lemma leq_mono_s: forall {A: Type} {plus: A -> A -> A} {times: A -> A -> A} {star: A -> A} {zero: A} {one: A}
                         {s: KA A plus times star zero one} (a b: A), leq a b -> leq (star a) (star b).
Proof. intros A plus times star zero one s a b H.
       assert (Ha: leq (times a (star b)) (times b (star b))).
       { apply (@leq_mono_tl A plus times star zero one s a b (star b) H). }
       assert (Hb: leq (plus one (times a (star b))) (plus one (times b (star b)))).
       { apply (@leq_mono_pl A plus times star zero one s (times a (star b)) (times b (star b)) one Ha). }
       specialize (ax12 b); intros HH.
       rewrite HH in Hb.
       specialize (ax14 a one (star b) Hb); intros HHH.
       rewrite ax8 in HHH.
       exact HHH.
Qed.

Lemma leq_mono_pr2: forall {A: Type} {plus: A -> A -> A} {times: A -> A -> A} {star: A -> A} {zero: A} {one: A}
                           {s: KA A plus times star zero one} (a b x y: A), leq a b -> leq x y -> leq (plus a x) (plus b y).
Proof. intros A plus times star zero one s a b x y Ha Hb.
       unfold leq in *.
       setoid_rewrite ax2 at 3.
       setoid_rewrite <- ax1 at 1.
       setoid_rewrite ax1 at 2.
       rewrite Hb.
       setoid_rewrite ax2 at 2.
       rewrite ax1.
       rewrite Ha.
       reflexivity.
Qed.

Lemma leq_mono_pl2: forall {A: Type} {plus: A -> A -> A} {times: A -> A -> A} {star: A -> A} {zero: A} {one: A}
                           {s: KA A plus times star zero one} (a b x y: A), leq a b -> leq x y -> leq (plus x a) (plus y b).
Proof. intros A plus times star zero one s a b x y Ha Hb.
       unfold leq in *.
       setoid_rewrite ax2 at 3.
       setoid_rewrite <- ax1 at 1.
       setoid_rewrite ax1 at 2.
       rewrite Ha.
       setoid_rewrite ax2 at 2.
       rewrite ax1.
       rewrite Hb.
       reflexivity.
Qed.

Lemma leq_mono_tl2: forall {A: Type} {plus: A -> A -> A} {times: A -> A -> A} {star: A -> A} {zero: A} {one: A}
                           {s: KA A plus times star zero one} (a b x y: A), leq a b -> leq x y -> leq (times a x) (times b y).
Proof. intros A plus times star zero one s a b x y Ha Hb.
       unfold leq in *.
       assert (times (plus a b) y = times b y).
       { rewrite Ha. reflexivity. }
       rewrite ax10 in H.
       setoid_rewrite <- H at 2.
       rewrite <- H at 1.
       assert (times a (plus x y) = times a y).
       { rewrite Hb. reflexivity. }
       rewrite ax11 in H0.
       setoid_rewrite <- H0 at 2.
       setoid_rewrite <- ax1.
       reflexivity.
Qed.

Lemma leq_mono_tr2: forall {A: Type} {plus: A -> A -> A} {times: A -> A -> A} {star: A -> A} {zero: A} {one: A}
                           {s: KA A plus times star zero one} (a b x y: A), leq a b -> leq x y -> leq (times x a) (times y b).
Proof. intros A plus times star zero one s a b x y Ha Hb.
       unfold leq in *.
       assert (times y (plus a b) = times y b).
       { rewrite Ha. reflexivity. }
       rewrite ax11 in H.
       setoid_rewrite <- H at 2.
       rewrite <- H at 1.
       assert (times (plus x y) a = times y a).
       { rewrite Hb. reflexivity. }
       rewrite ax10 in H0.
       setoid_rewrite <- H0 at 2.
       setoid_rewrite <- ax1.
       reflexivity.
Qed.

Lemma bisim: forall {A: Type} {plus: A -> A -> A} {times: A -> A -> A} {star: A -> A} {zero: A} {one: A}
                    {s: KA A plus times star zero one} (a b x: A),
                    times a x = times x b -> times (star a) x = times x (star b).
Proof. intros A plus times star zero one s a b x Ha.
       apply leq_antisym_eq in Ha.
       destruct Ha as (Ha, Hb).
       apply leq_antisym.
       - assert (Hc: leq (times a (times x (star b))) (times x (times b (star b)))).
         { specialize (@leq_mono_tl A plus times star zero one s (times a x) (times x b) (star b) Ha); intro HH.
           specialize (ax9 a x (star b)); intro HHH.
           rewrite HHH.
           specialize (ax9 x b (star b)); intro HHHH.
           rewrite HHHH.
           exact HH.
         }
       - assert (Hd: leq (plus x (times a (times x (star b)))) (plus x (times x (times b (star b))))).
         { specialize (@leq_mono_pl A plus times star zero one s
                                   (times a (times x (star b)))
                                   (times x (times b (star b)))
                                   x Hc); intro HH.
           exact HH.
         }
         specialize (ax8 x); intro HH.
         setoid_rewrite <- HH in Hd at 3.
         rewrite <- ax11 in Hd.
         specialize (ax12 b); intros HHH.
         rewrite HHH in Hd.
         apply ax14 in Hd.
         exact Hd.
       - assert (Hc: leq (times (star a) (times x b)) (times (star a) (times a x))).
         { specialize (@leq_mono_tr A plus times star zero one s (times x b) (times a x) (star a) Hb); intro HH.
           exact HH.
         }
         assert (Hd: leq (plus (times (star a) (times x b)) x) (plus (times (star a) (times a x)) x)).
         { specialize (@leq_mono_pr A plus times star zero one s
                                    (times (star a) (times x b))
                                    (times (star a) (times a x)) x Hc); intros HHH.
           exact HHH.
         }
         specialize (ax7 x); intro HH.
         setoid_rewrite <- HH at 4 in Hd.
         setoid_rewrite ax9 at 2 in Hd.
         rewrite <- ax10 in Hd.
         specialize (ax13 a); intros HHH.
         rewrite ax2 in HHH.
         rewrite HHH in Hd.
         rewrite ax2 in Hd.
         rewrite ax9 in Hd.
         apply ax15 in Hd.
         exact Hd.
Qed.

Lemma sliding: forall {A: Type} {plus: A -> A -> A} {times: A -> A -> A} {star: A -> A} {zero: A} {one: A}
                      {s: KA A plus times star zero one} (a b: A),
                      times a (star (times b a)) = times (star (times a b)) a.
Proof. intros A plus times star zero one s a b.
       specialize (bisim (times a b) (times b a) a); intro H.
       rewrite H.
       reflexivity.
       rewrite ax9.
       reflexivity.
Qed.

Lemma ts_st: forall {A: Type} {plus: A -> A -> A} {times: A -> A -> A} {star: A -> A} {zero: A} {one: A}
                    {s: KA A plus times star zero one} (a: A),
                    (times a (star a)) = times (star a) a.
Proof. intros A plus times star zero one s a.
       specialize (bisim a a a); intro H.
       symmetry.
       apply H.
       reflexivity.
Qed.

Lemma ax14eq: forall {A: Type} {plus: A -> A -> A} {times: A -> A -> A} {star: A -> A} {zero: A} {one: A}
                        {s: KA A plus times star zero one} (a b: A),
                        leq (times a b) b -> leq (times (star a) b) b.
Proof. intros A plus times star zero one s a b Ha.
       specialize (ax14 a b b); intro H.
       apply H.
       unfold leq in Ha.
       unfold leq.
       rewrite ax2 in Ha.
       rewrite Ha.
       rewrite ax3.
       reflexivity.
Qed.

Lemma ax15eq: forall {A: Type} {plus: A -> A -> A} {times: A -> A -> A} {star: A -> A} {zero: A} {one: A}
                        {s: KA A plus times star zero one} (a b: A),
                        leq (times b a) b -> leq (times b (star a)) b.
Proof. intros A plus times star zero one s a b Ha.
       specialize (ax15 a b b); intro H.
       apply H.
       unfold leq in Ha.
       unfold leq.
       rewrite ax2 in Ha.
       rewrite Ha.
       rewrite ax3.
       reflexivity.
Qed.

Lemma plus_one_star: forall {A: Type} {plus: A -> A -> A} {times: A -> A -> A} {star: A -> A} {zero: A} {one: A}
                            {s: KA A plus times star zero one} (a: A),
                            plus one (star a) = star a.
Proof. intros A plus times star zero one s a.
       specialize (ax12 a); intro H.
       rewrite <- H.
       rewrite ax1.
       rewrite ax3.
       reflexivity.
Qed.

Lemma star_double: forall {A: Type} {plus: A -> A -> A} {times: A -> A -> A} {star: A -> A} {zero: A} {one: A}
                          {s: KA A plus times star zero one} (a: A),
                          (times (star a) (star a)) = star a.
Proof. intros A plus times star zero one s a.
       apply leq_antisym.
       - assert (H: leq (times a (star a)) (star a)).
         { unfold leq.
           specialize (ax12 a); intro H.
           setoid_rewrite <- H at 2.
           rewrite ax2.
           rewrite <- ax1.
           rewrite ax3.
           exact H.
         }
         apply ax14eq in H.
         exact H.
       - unfold leq.
         assert (H: star a = times one (star a)).
         { rewrite ax7. reflexivity. }
         setoid_rewrite H at 1.
         rewrite <- ax10.
         rewrite plus_one_star.
         reflexivity.
Qed.

Lemma star_star_star: forall {A: Type} {plus: A -> A -> A} {times: A -> A -> A} {star: A -> A} {zero: A} {one: A}
                             {s: KA A plus times star zero one} (a: A),
                             times (star a) (star (star a)) = star a.
Proof. intros A plus times star zero one s a.
       specialize (star_double a); intro H.
       apply leq_antisym_eq in H.
       destruct H as (Ha, Hb).
       specialize (ax15eq (star a) (star a) Ha); intro H.
       unfold leq in H.
       assert (Hc: times (star a) one = star a).
       { rewrite ax8. reflexivity. }
       setoid_rewrite <- Hc in H at 3.
       rewrite <- ax11 in H.
       rewrite ax2 in H.
       rewrite plus_one_star in H.
       exact H.
Qed.

Lemma star_star: forall {A: Type} {plus: A -> A -> A} {times: A -> A -> A} {star: A -> A} {zero: A} {one: A}
                        {s: KA A plus times star zero one} (a: A),
                        (star (star a)) = star a.
Proof. intros A plus times star zero one s a.
       apply leq_antisym.
       - specialize (star_star_star a); intro Ha.
         apply leq_antisym_eq in Ha.
         destruct Ha as (Ha, Hb).
         specialize (leq_mono_pl (times (star a) (star (star a))) (star a) one Ha); intro H.
         rewrite plus_one_star in H.
         specialize (ax12 (star a)); intro HH.
         rewrite HH in H.
         exact H.
       - specialize (star_star_star a); intro Ha.
         apply leq_antisym_eq in Ha.
         destruct Ha as (Ha, Hb).
         specialize (leq_mono_pl (star a) (times (star a) (star (star a))) one Hb); intro H.
         rewrite plus_one_star in H.
         specialize (ax12 (star a)); intro HH.
         rewrite HH in H.
         exact H.
Qed.

Lemma plus_star_star: forall {A: Type} {plus: A -> A -> A} {times: A -> A -> A} {star: A -> A} {zero: A} {one: A}
                             {s: KA A plus times star zero one} (a: A),
                             (star (plus one a)) = star a.
Proof. intros A plus times star zero one s a.
       apply leq_antisym.
       - assert (leq one (star a)).
         { unfold leq.
           rewrite plus_one_star.
           reflexivity.
         }
         specialize (leq_mono_tr one (star a) a H); intro HH.
         rewrite ax8 in HH.
         specialize (leq_mono_pl a (times a (star a)) one HH); intro HHH.
         specialize (ax12 a); intro HHHH.
         rewrite HHHH in HHH.
         specialize (leq_mono_s (plus one a) (star a) HHH); intro HHHHH.
         rewrite star_star in HHHHH.
         exact HHHHH.
       - assert (leq a (plus one a)).
         { unfold leq.
           rewrite ax2.
           rewrite <- ax1.
           rewrite ax3.
           reflexivity.
         }
         specialize (leq_mono_s a (plus one a) H); intro HH.
         exact HH.
Qed.

Lemma star_times_star: forall {A: Type} {plus: A -> A -> A} {times: A -> A -> A} {star: A -> A} {zero: A} {one: A}
                              {s: KA A plus times star zero one} (a: A),
                              (star (times a (star a))) = star a.
Proof. intros A plus times star zero one s a.
       apply leq_antisym.
       - assert (leq (times a (star a)) (star a)).
         { unfold leq.
           specialize (ax12 a); intro H.
           setoid_rewrite <- H at 2.
           rewrite ax2.
           rewrite <- ax1.
           rewrite ax3.
           exact H.
         }
         specialize (leq_mono_s (times a (star a)) (star a) H); intro HH.
         rewrite star_star in HH.
         exact HH.
       - assert (leq (star a) (plus one (times a (star a)))).
         { unfold leq.
           specialize (ax12 a); intro H.
           rewrite H.
           rewrite ax3.
           reflexivity.
         }
         specialize (leq_mono_s (star a) (plus one (times a (star a))) H); intro HH.
         rewrite star_star in HH.
         rewrite plus_star_star in HH.
         exact HH.
Qed.

Lemma denesting: forall {A: Type} {plus: A -> A -> A} {times: A -> A -> A} {star: A -> A} {zero: A} {one: A}
                        {s: KA A plus times star zero one} (a b: A),
                        star (plus a b) = times (star a) (star (times b (star a))).
Proof. intros A plus times star zero one s a b.
       apply leq_antisym.
       - assert (plus one (times (plus a b) (times (star a) (star (times b (star a))))) =
                 times (star a) (star (times b (star a)))
                ).
         { rewrite ax10.
           setoid_rewrite <- ax2.
           rewrite <- ax1.
           setoid_rewrite ax2 at 2.
           setoid_rewrite ax9 at 2.
           specialize (ax12 (times b (star a))); intro HH.
           rewrite HH.
           rewrite ax9.
           assert ((star (times b (star a))) = times one ((star (times b (star a))))).
           { rewrite ax7. reflexivity. }
           setoid_rewrite H at 2.
           rewrite <- ax10.
           rewrite ax2.
           specialize (ax12 a); intro HHH.
           rewrite HHH.
           reflexivity.
         }
         apply leq_antisym_eq in H.
         destruct H as (Ha, Hb).
         specialize (ax14 (plus a b) one (times (star a) (star (times b (star a))))); intro HH.
         apply HH in Ha.
         rewrite ax8 in Ha.
         exact Ha.
       - assert (Ha: leq a (plus a b)).
         { unfold leq.
           rewrite ax1.
           rewrite ax3.
           reflexivity.
         }
         assert (Hb: leq b (plus a b)).
         { unfold leq.
           rewrite ax2.
           rewrite <- ax1.
           rewrite ax3.
           reflexivity.
         }
         assert (Hc: leq (star a) (star (plus a b))).
         { apply leq_mono_s. exact Ha. }
         assert (Hd: leq (times (star a) b) (times (star (plus a b)) (plus a b)) ).
         { apply leq_mono_tl2.
           exact Hc.
           exact Hb.
         }
         assert (He: leq (times (times (star a) b) (star a)) (times (times (star (plus a b)) (plus a b)) (star (plus a b)))).
         { apply leq_mono_tl2.
           exact Hd.
           exact Hc.
         }
         rewrite <- ax9 in He.
         rewrite <- ax9 in He.
         assert(Hf: leq (times (star a) (star (times b (star a))))
                               (times (star (plus a b)) (star (times (plus a b) (star (plus a b)))))
         ).
         { apply leq_mono_tl2.
           exact Hc.
           apply leq_mono_s.
           apply leq_mono_tl2.
           exact Hb.
           exact Hc.
         }
         rewrite star_times_star in Hf.
         rewrite star_double in Hf.
         exact Hf.
Qed.


(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *)
Require Import ssreflect.
Require Import ssrfun.
Require Import ssrbool.
Require Import eqtype.
Require Import ssrnat.
Require Import seq.
Require Import paths.

(**************************************************************************)
(* This files contains the definitions of:                                *)
(* -division: divn and modn compute the euclidian quotient and remainder  *)
(*            edivn m d performs the euclidian division of m by d         *)
(* -divisibility: dvdn d m <=> d divides m                                *)
(*                divisors m == the ascending divisors list of m if m > 0 *)
(*                gcdn m n == the GCD of m and n                          *)
(*                coprime m n <=> m and n are coprime                     *)
(*                phi n == the Euler totient                              *)
(* The bezout[lr] lemmas give the bezout coefficients.                    *)
(**************************************************************************)

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

(** Euclidian division *)

Definition edivn_rec d := fix loop (m q : nat) {struct m} :=
  if m - d is m'.+1 then loop m' q.+1 else (q, m).

Definition edivn m d := if d is d'.+1 then edivn_rec d' m 0 else (0, m).

CoInductive edivn_spec (m d : nat) : nat * nat -> Type :=
  EdivnSpec q r of m = q * d + r & (d > 0) ==> (r < d) : edivn_spec m d (q, r).

Lemma edivnP : forall m d, edivn_spec m d (edivn m d).
Proof.
move=> m [|d] //=; rewrite -{1}[m]/(0 * d.+1 + m).
elim: m {-2}m 0 (leqnn m) => [|n IHn] [|m] q //=; rewrite ltnS => le_mn.
rewrite subn_if_gt; case: ltnP => [// | le_dm].
rewrite -{1}(subnK le_dm) -addSn addnA -mulSnr; apply: IHn.
apply: leq_trans le_mn; exact: leq_subr.
Qed.

Lemma edivn_eq : forall d q r, r < d -> edivn (q * d + r) d = (q, r).
Proof.
move=> d q r lt_rd; have d_pos: 0 < d by exact: leq_trans lt_rd.
case: edivnP lt_rd => q' r'; rewrite d_pos /=.
wlog: q q' r r' / q <= q' by case (ltnP q q'); last symmetry; eauto.
rewrite leq_eqVlt; case: eqP => [-> _|_] /=; first by move/addn_injl->.
rewrite -(leq_pmul2r d_pos); move/leq_add=> Hqr Eqr _; move/Hqr {Hqr}.
by rewrite addnS ltnNge mulSn -addnA Eqr addnCA addnA leq_addr.
Qed.

Definition divn m d := nosimpl (edivn m d).1.

Notation "m %/ d" := (divn m d) (at level 40, no associativity) : nat_scope.

(* We redefine modn so that it is structurally decreasing. *)

Definition modn_rec d := fix loop (m : nat) :=
  if m - d is m'.+1 then loop m' else m.

Definition modn m d := nosimpl (if d is d'.+1 then modn_rec d' m else m).

Notation "m %% d" := (modn m d) (at level 40, no associativity) : nat_scope.
Notation "m = n %[mod d ]" := (m %% d = n %% d)
  (at level 70, n at next level,
   format "'[hv ' m '/'  =  n '/'  %[mod  d ] ']'") : nat_scope.
Notation "m == n %[mod d ]" := (m %% d == n %% d)
  (at level 70, n at next level,
   format "'[hv ' m '/'  ==  n '/'  %[mod  d ] ']'") : nat_scope.
Notation "m <> n %[mod d ]" := (m %% d <> n %% d)
  (at level 70, n at next level,
   format "'[hv ' m '/'  <>  n '/'  %[mod  d ] ']'") : nat_scope.
Notation "m != n %[mod d ]" := (m %% d != n %% d)
  (at level 70, n at next level,
   format "'[hv ' m '/'  !=  n '/'  %[mod  d ] ']'") : nat_scope.

Lemma modn_def : forall m d, m %% d = (edivn m d).2.
Proof.
rewrite /modn => m [|d] //=; elim: m {-2}m 0 (leqnn m) => [|n IHn] [|m] q //=.
rewrite ltnS !subn_if_gt (fun_if (@snd _ _)) => le_mn; rewrite -{}IHn //.
apply: leq_trans le_mn; exact: leq_subr.
Qed.

Lemma edivn_def : forall m d, edivn m d = (m %/ d, m %% d).
Proof. by move=> m d; rewrite /divn modn_def; case edivn. Qed.

Lemma divn_eq : forall m d, m = m %/ d * d + m %% d.
Proof. by move=> m d; rewrite /divn modn_def; case edivnP. Qed.

Lemma div0n : forall d, 0 %/ d = 0. Proof. by case. Qed.
Lemma divn0 : forall m, m %/ 0 = 0. Proof.  by []. Qed.
Lemma mod0n :  forall d, 0 %% d = 0. Proof. by case. Qed.
Lemma modn0 :  forall m, m %% 0 = m. Proof. by []. Qed.

Lemma divn_small : forall m d, m < d -> m %/ d = 0.
Proof. by move=> m d lt_md; rewrite /divn (edivn_eq 0). Qed.

Lemma divn_addl_mul : forall q m d, 0 < d -> (q * d + m) %/ d = q + m %/ d.
Proof.
move=> q m d d_pos; rewrite {1}(divn_eq m d) addnA -muln_addl.
by rewrite /divn edivn_eq // modn_def; case: edivnP; rewrite d_pos.
Qed.

Lemma mulnK : forall m d, 0 < d -> m * d %/ d = m.
Proof.
by move=> m d d_pos; rewrite -[m * d]addn0 divn_addl_mul // div0n addn0.
Qed.

Lemma mulKn : forall m d, 0 < d -> d * m %/ d = m.
Proof. by move=> *; rewrite mulnC mulnK. Qed.

Lemma modn1 : forall m, m %% 1 = 0.
Proof. by move=> m; rewrite modn_def; case: edivnP => ? []. Qed.

Lemma divn1: forall m, m %/ 1 = m.
Proof. by move=> m; rewrite {2}(@divn_eq m 1) // modn1 addn0 muln1. Qed.

Lemma divnn : forall d, d %/ d = (0 < d).
Proof. by case=> // d; rewrite -{1}[d.+1]muln1 mulKn. Qed.

Lemma divn_pmul2l : forall p m d, p > 0 -> p * m %/ (p * d) = m %/ d.
Proof.
move=> p m d p_pos; case: (posnP d) => [-> | d_pos]; first by rewrite muln0.
rewrite {2}/divn; case: edivnP; rewrite d_pos /= => q r ->{m} lt_rd.
rewrite muln_addr mulnCA divn_addl_mul; last by rewrite ltn_0mul p_pos.
by rewrite addnC divn_small // ltn_pmul2l.
Qed.
Implicit Arguments divn_pmul2l [p m d].

Lemma divn_pmul2r : forall p m d, p > 0 -> m * p %/ (d * p) = m %/ d.
Proof. by move=> p m d p_pos; rewrite -!(mulnC p) divn_pmul2l. Qed.
Implicit Arguments divn_pmul2r [p m d].

Lemma ltn_mod : forall m d, (m %% d < d) = (0 < d).
Proof. by move=> m [|d] //; rewrite modn_def; case: edivnP. Qed.

Lemma ltn_pmod : forall m d, 0 < d -> m %% d < d.
Proof. by move=> m d; rewrite ltn_mod. Qed.

Lemma leq_floor : forall m d, m %/ d * d <= m.
Proof. by move=> m d; rewrite {2}(divn_eq m d) leq_addr. Qed.

Lemma leq_mod : forall m d, m %% d  <= m.
Proof. by move=> m d; rewrite {2}(divn_eq m d) leq_addl. Qed.

Lemma leq_div : forall m d, m %/ d <= m.
Proof. move=> m [|d] //; exact: leq_trans (leq_pmulr _ _) (leq_floor _ _). Qed.

Lemma ltn_ceil : forall m d, 0 < d -> m < (m %/ d).+1 * d.
Proof.
by move=> m d ? /=; rewrite {1}(divn_eq m d) -addnS mulSnr leq_add2l ltn_mod.
Qed.

Lemma ltn_divl : forall m n d, d > 0 -> (m %/ d < n) = (m < n * d).
Proof.
move=> m n d d_pos; apply/idP/idP.
  rewrite -(leq_pmul2r d_pos); exact: leq_trans (ltn_ceil _ _).
rewrite !ltnNge -(@leq_pmul2r d n) //; apply: contra => le_nd_floor.
exact: leq_trans le_nd_floor (leq_floor _ _).
Qed.

Lemma leq_divr : forall m n d, d > 0 -> (m <= n %/ d) = (m * d <= n).
Proof. by move=> m n d d_pos; rewrite leqNgt ltn_divl // -leqNgt. Qed.

Lemma ltn_Pdiv : forall m d, 1 < d -> 0 < m -> m %/ d < m.
Proof. by move=> m d d_gt1 m_pos; rewrite ltn_divl ?ltn_Pmulr // ltnW. Qed.

Lemma ltn_0div : forall d m, 0 < d -> (0 < m %/ d) = (d <= m).
Proof. by move=> d m d_pos; rewrite leq_divr ?mul1n. Qed.

Lemma divn_divl : forall m n p, m %/ n %/ p = m %/ (n * p).
Proof.
move=> m [|n] [|p]; rewrite ?muln0 ?div0n //.
rewrite {1}(divn_eq m (n.+1 * p.+1)) mulnA mulnAC !divn_addl_mul //.
by rewrite addnC divn_small // ltn_divl // mulnC ltn_mod.
Qed.

Lemma divnAC : forall m n p, m %/ n %/ p =  m %/ p %/ n.
Proof. by move=> m n p; rewrite !divn_divl mulnC. Qed.

Lemma modn_small : forall m d, m < d -> m %% d = m.
Proof. by move=> m d lt_md; rewrite {2}(divn_eq m d) divn_small. Qed.

Lemma modn_mod : forall m d, m %% d = m %[mod d].
Proof. by move=> m [|d] //; apply: modn_small; rewrite ltn_mod. Qed.

Lemma modn_addl_mul : forall p m d, p * d + m = m %[mod d].
Proof.
move=> p m d; case: (posnP d) => [-> | d_pos]; first by rewrite muln0.
by rewrite {1}(divn_eq m d) addnA -muln_addl modn_def edivn_eq // ltn_mod.
Qed.

Lemma modn_pmul2l : forall p m d, 0 < p -> p * m %% (p * d) = p * (m %% d).
Proof.
move=> p m d p_pos; apply: (@addn_injl (p * (m %/ d * d))).
by rewrite -muln_addr -divn_eq mulnCA -(divn_pmul2l p_pos) -divn_eq.
Qed.
Implicit Arguments modn_pmul2l [p m d].

Lemma modn_addl : forall m d, d + m = m %[mod d].
Proof. by move=> m d; rewrite -{1}[d]mul1n modn_addl_mul. Qed.

Lemma modn_addr : forall m d, m + d = m %[mod d].
Proof. by move=> *; rewrite addnC modn_addl. Qed.

Lemma modnn : forall d, d %% d = 0.
Proof. by move=> d; rewrite -{1}[d]addn0 modn_addl mod0n. Qed.

Lemma modn_mull : forall p d, p * d %% d = 0.
Proof. by move=> p d; rewrite -[p * d]addn0 modn_addl_mul mod0n. Qed.

Lemma modn_mulr : forall p d, d * p %% d = 0.
Proof. by move=> p d; rewrite mulnC modn_mull. Qed.

Lemma modn_addml : forall m n d, m %% d + n = m + n %[mod d].
Proof. by move=> m n d; rewrite {2}(divn_eq m d) -addnA modn_addl_mul. Qed.

Lemma modn_addmr : forall m n d, m + n %% d = m + n %[mod d].
Proof. by move=> m n d; rewrite !(addnC m) modn_addml. Qed.

Lemma modn_add2m : forall m n d, m %% d  + n %% d = m + n %[mod d].
Proof. by move=> m n d; rewrite modn_addml modn_addmr. Qed.

Lemma modn_mulml : forall m n d, m %% d * n = m * n %[mod d].
Proof.
by move=> m n d; rewrite {2}(divn_eq m d) muln_addl mulnAC modn_addl_mul.
Qed.

Lemma modn_mulmr : forall m n d, m * (n %% d) = m * n %[mod d].
Proof. by move=> m n d; rewrite !(mulnC m) modn_mulml. Qed.

Lemma modn_mul2m : forall m n d, m %% d * (n %% d) = m * n %[mod d].
Proof. by move=> m n d; rewrite modn_mulml modn_mulmr. Qed.

Lemma modn2 : forall m, m %% 2 = odd m.
Proof. by elim=> //= m IHm; rewrite -addn1 -modn_addml IHm; case odd. Qed.

Lemma divn2 : forall m, m %/ 2 = m./2.
Proof.
by move=> m; rewrite {2}(divn_eq m 2) modn2 muln2 addnC half_bit_double.
Qed.

Lemma odd_mod : forall m d, odd d = false -> odd (m %% d) = odd m.
Proof.
by move=> m d d_even; rewrite {2}(divn_eq m d) odd_add odd_mul d_even andbF.
Qed.

(** Divisibility **)

Definition dvdn d m := m %% d == 0.

Notation "m %| d" := (dvdn m d) (at level 70, no associativity) : nat_scope.

Lemma dvdn2 : forall n, (2 %| n) = ~~ odd n.
Proof. by move=> n; rewrite /dvdn modn2; case (odd n). Qed.

Lemma dvdnP : forall d m, reflect (exists k, m = k * d) (d %| m).
Proof.
move=> d m; apply: (iffP eqP) => [Hm | [k ->]]; last by rewrite modn_mull.
by exists (m %/ d); rewrite {1}(divn_eq m d) Hm addn0.
Qed.
Implicit Arguments dvdnP [d m].
Prenex Implicits dvdnP.

Lemma dvdn0 : forall d, d %| 0.
Proof. by case. Qed.

Lemma dvd0n : forall n, (0 %| n) = (n == 0).
Proof. by case. Qed.

Lemma dvdn1 : forall d, (d %| 1) = (d == 1).
Proof. by case=> [|[|n]] //; rewrite /dvdn modn_small. Qed.

Lemma dvd1n : forall m, 1 %| m.
Proof. by move=> m; rewrite /dvdn modn1. Qed.

Lemma ltn_0dvd : forall d m, m > 0 -> d %| m -> d > 0.
Proof. by do 2!case. Qed.

Lemma dvdnn: forall m, m %| m.
Proof. by move=> m; rewrite /dvdn modnn. Qed.

Lemma dvdn_mull: forall d m n, d %| n -> d %| m * n.
Proof. by move=> d m n; case/dvdnP=> n' ->; rewrite /dvdn mulnA modn_mull. Qed.

Lemma dvdn_mulr: forall d m n, d %| m -> d %| m * n.
Proof. by move=> d m n d_m; rewrite mulnC dvdn_mull. Qed.

Hint Resolve dvdn0 dvd1n dvdnn dvdn_mull dvdn_mulr.

Lemma dvdn_mul: forall d1 d2 m1 m2, d1 %| m1 -> d2 %| m2 -> d1 * d2 %| m1 * m2.
Proof.
move=> d1 d2 m1 m2; case/dvdnP=> q1 ->; case/dvdnP=> q2 ->.
by rewrite mulnCA -mulnA 2?dvdn_mull.
Qed.

Lemma dvdn_trans: forall n d m, d %| n -> n %| m -> d %| m.
Proof. move=> n d m Hn; move/dvdnP => [n1 ->]; exact: dvdn_mull. Qed.

Lemma dvdn_eq : forall d m, (d %| m) = (m %/ d * d == m).
Proof.
move=> d m; apply/eqP/eqP=> [modm0 | <-]; last exact: modn_mull.
by rewrite {2}(divn_eq m d) modm0 addn0.
Qed.

Lemma divnK : forall d m, d %| m -> m %/ d * d = m.
Proof. by move=> m d; rewrite dvdn_eq; move/eqP. Qed.

Lemma leq_divl : forall d m n, d %| m -> (m %/ d <= n) = (m <= n * d).
Proof. by case=> [[]//|d] m n dv_d_m; rewrite -(@leq_pmul2r d.+1) ?divnK. Qed.

Lemma ltn_divr : forall d m n, d %| m -> (n < m %/ d) = (n * d < m).
Proof. by move=> d m n dv_d_m; rewrite !ltnNge leq_divl. Qed.

Lemma eqn_div : forall d m n, d > 0 -> d %| m -> (n == m %/ d) = (n * d == m).
Proof. by move=> d m n d_pos dv_d_m; rewrite -(eqn_pmul2r d_pos) divnK. Qed.

Lemma eqn_mul : forall d m n, d > 0 -> d %| m -> (m == n * d) = (m %/ d == n).
Proof. by move=> d m n d_pos dv_d_m; rewrite eq_sym -eqn_div // eq_sym. Qed.

Lemma divn_mulAC : forall d m n, d %| m -> m %/ d * n = m * n %/ d.
Proof.
case=> [[]//|d] m n dv_d_m; apply/eqP.
by rewrite eqn_div ?dvdn_mulr // mulnAC divnK.
Qed.

Lemma divn_mulA : forall d m n, d %| n -> m * (n %/ d) = m * n %/ d.
Proof. by move=> d m n dv_d_m; rewrite !(mulnC m) divn_mulAC. Qed.

Lemma divn_mulCA : forall d m n,
  d %| m -> d %| n -> m * (n %/ d) = n * (m %/ d).
Proof. by move=> d m n dv_d_m dv_d_n; rewrite mulnC divn_mulAC ?divn_mulA. Qed.

Lemma divn_divr : forall m n p, p %| n -> m %/ (n %/ p) = m * p %/ n.
Proof. by move=> m n [|p] dv_n; rewrite -{2}(divnK dv_n) // divn_pmul2r. Qed.

Lemma modn_dvdm : forall m n d, d %| m -> n %% m = n %[mod d].
Proof.
move=> m n d; case/dvdnP=> q def_m.
by rewrite {2}(divn_eq n m) {3}def_m mulnA modn_addl_mul.
Qed.

Lemma dvdn_leq : forall d m, 0 < m -> d %| m -> d <= m.
Proof.
by move=> d m m_pos; case/dvdnP=> [[|k] Dm]; rewrite Dm // leq_addr in m_pos *.
Qed.

Lemma gtnNdvd : forall n d, 0 < n -> n < d -> (d %| n) = false.
Proof. by move=> n d n_pos ltnd; rewrite /dvdn eqn0Ngt modn_small ?n_pos. Qed.

Lemma eqn_dvd : forall m n, (m == n) = (m %| n) && (n %| m).
Proof.
case=> [|m] [|n] //; apply/idP/andP; first by move/eqP->; auto.
rewrite eqn_leq => [[Hmn Hnm]]; apply/andP; have:= dvdn_leq; auto.
Qed.

Lemma dvdn_pmul2l : forall p d m, 0 < p -> (p * d %| p * m) = (d %| m).
Proof. by case=> // p d m _; rewrite /dvdn modn_pmul2l // eqn_mul0. Qed.
Implicit Arguments dvdn_pmul2l [p m d].

Lemma dvdn_pmul2r : forall p d m, 0 < p -> (d * p %| m * p) = (d %| m).
Proof. by move=> n d m Hn; rewrite -!(mulnC n) dvdn_pmul2l. Qed.
Implicit Arguments dvdn_pmul2r [p m d].

Lemma dvdn_addr : forall m d n, d %| m -> (d %| m + n) = (d %| n).
Proof. by move=> n d m; move/dvdnP=> [k ->]; rewrite /dvdn modn_addl_mul. Qed.

Lemma dvdn_addl : forall n d m, d %| n -> (d %| m + n) = (d %| m).
Proof. by move=> n d m; rewrite addnC; exact: dvdn_addr. Qed.

Lemma dvdn_add : forall d m n, d %| m -> d %| n -> d %| m + n.
Proof. by move=> n d m; move/dvdn_addr->. Qed.

Lemma dvdn_add_eq : forall d m n, d %| m + n -> (d %| m) = (d %| n).
Proof. by move=> *; apply/idP/idP; [move/dvdn_addr <-| move/dvdn_addl <-]. Qed.

Lemma dvdn_subr : forall d m n, n <= m -> d %| m -> (d %| m - n) = (d %| n).
Proof. by move=> *; apply dvdn_add_eq; rewrite addnC subnK. Qed.

Lemma dvdn_subl : forall d m n, n <= m -> d %| n -> (d %| m - n) = (d %| m).
Proof. by move=> d m n Hn; rewrite -{2}(subnK Hn); move/dvdn_addr. Qed.

Lemma dvdn_sub : forall d m n, d %|m -> d %| n -> d %| m - n.
Proof.
move=> d n m; case: (leqP m n) => Hm; first by move/dvdn_subr <-.
by rewrite (eqnP (ltnW Hm)) dvdn0.
Qed.

Lemma dvdn_exp : forall k d m, 0 < k -> d %| m -> d %| (m ^ k).
Proof. by case=> // *; rewrite expnS dvdn_mulr. Qed.

Hint Resolve dvdn_add dvdn_sub dvdn_exp.

Lemma eqn_mod_dvd : forall d m n, n <= m -> (m == n %[mod d]) = (d %| m - n).
Proof.
rewrite /dvdn => d m n le_nm; apply/eqP/eqP => [eq_mod | mod_mn_0]; last first.
  by rewrite -(subnK le_nm) -modn_addmr mod_mn_0 addn0.
by rewrite (divn_eq m d) (divn_eq n d) eq_mod subn_add2r -muln_subl modn_mull.
Qed.

Lemma divn_addl : forall m n d, d %| m -> (m + n) %/ d = m %/ d + n %/ d.
Proof. by move=> m n [//|d] dv_m; rewrite -{1}(divnK dv_m) divn_addl_mul. Qed.

Lemma divn_addr : forall m n d, d %| n -> (m + n) %/ d = m %/ d + n %/ d.
Proof. by move=> m n d dv_n; rewrite addnC divn_addl // addnC. Qed.

(***********************************************************************)
(*   A function that computes the gcd of 2 numbers                     *)
(***********************************************************************)

Fixpoint gcdn_rec (m n : nat) {struct m} :=
  let n' := n %% m in if n' is 0 then m else
  if m - n'.-1 is m'.+1 then gcdn_rec (m' %% n') n' else n'.

Definition gcdn := nosimpl gcdn_rec.

Lemma gcdnE : forall m n, gcdn m n = if m == 0 then n else gcdn (n %% m) m.
Proof.
rewrite /gcdn => m; elim: m {-2}m (leqnn m) => [|s IHs] [|m] le_ms [|n] //=.
case def_n': (_ %% _) => // [n'].
have{def_n'} lt_n'm: n' < m by rewrite -def_n' -ltnS ltn_pmod.
rewrite {}IHs ?(leq_trans lt_n'm) // subn_if_gt ltnW //=; congr gcdn_rec.
by rewrite -{2}(subnK (ltnW lt_n'm)) -addSn modn_addl.
Qed.

Lemma gcdnn : idempotent gcdn.
Proof. by case=> // n; rewrite gcdnE modnn. Qed.

Lemma gcdnC : commutative gcdn.
Proof.
move=> m n; wlog lt_nm: m n / n < m.
  by case: (ltngtP n m) => [||->]; [|symmetry|rewrite gcdnn]; auto.
by rewrite gcdnE -{1}(ltn_predK lt_nm) modn_small.
Qed.

Lemma gcd0n : left_unit 0 gcdn. Proof. by case. Qed.
Lemma gcdn0 : right_unit 0 gcdn. Proof. by case. Qed.

Lemma gcd1n : left_zero 1 gcdn.
Proof. by move=> n; rewrite gcdnE modn1. Qed.

Lemma gcdn1 : right_zero 1 gcdn.
Proof. by move=> n; rewrite gcdnC gcd1n. Qed.

Lemma dvdn_gcdr : forall m n, gcdn m n %| n.
Proof.
move=> m; elim: m {-2}m (leqnn m) => [|s IHs] [|m] le_ms [|n] //.
rewrite gcdnE; case def_n': (_ %% _) => [|n']; first by rewrite /dvdn def_n'.
have lt_n's: n' < s by rewrite -ltnS (leq_trans _ le_ms) // -def_n' ltn_pmod.
rewrite /= (divn_eq n.+1 m.+1) def_n' dvdn_addr ?dvdn_mull //; last exact: IHs.
by rewrite gcdnE /= IHs // (leq_trans _ lt_n's) // ltnW // ltn_pmod.
Qed.

Lemma dvdn_gcdl : forall m n, gcdn m n %| m.
Proof. by move=> m n; rewrite gcdnC dvdn_gcdr. Qed.

Lemma ltn_0gcd : forall m n, (0 < gcdn m n) = (0 < m) || (0 < n).
Proof.
move=> [|m] [|n] //; apply: (@ltn_0dvd _ m.+1) => //; exact: dvdn_gcdl.
Qed.

Lemma gcdn_addl_mul : forall k m n, gcdn m (k * m + n) = gcdn m n.
Proof. by move=> k m n; rewrite !(gcdnE m) modn_addl_mul mulnC; case: m. Qed.

Lemma gcdn_addl: forall m n, gcdn m (m + n) = gcdn m n.
Proof. by move => m n; rewrite -{2}(mul1n m) gcdn_addl_mul. Qed.

Lemma gcdn_addr: forall m n, gcdn m (n + m) = gcdn m n.
Proof. by move=> m n; rewrite addnC gcdn_addl. Qed.

Lemma gcdn_mull : forall n m, gcdn n (m * n) = n.
Proof. by move=> n m; rewrite gcdnE modn_mull gcd0n; case defn:n=> /=. Qed.

Lemma gcdn_mulr : forall n m, gcdn n (n * m) = n.
Proof. by move=> n m; rewrite mulnC gcdn_mull. Qed.

(* Extended gcd, which computes Bezout coefficients. *)

Fixpoint bezout_rec (km kn : nat) (qs : seq nat) {struct qs} :=
  if qs is q :: qs' then bezout_rec kn (NatTrec.add_mul q kn km) qs'
  else (km, kn).

Fixpoint egcdn_rec (m n s : nat) (qs : seq nat) {struct s} :=
  if s is s'.+1 then
    let: (q, r) := edivn m n in
    if r > 0 then egcdn_rec n r s' (q :: qs) else
    if odd (size qs) then qs else q.-1 :: qs
  else [::0].

Definition egcdn m n := bezout_rec 0 1 (egcdn_rec m n n [::]).

CoInductive egcdn_spec (m n : nat) : nat * nat -> Type :=
  EgcdnSpec km kn of km * m = kn * n + gcdn m n & kn * gcdn m n < m :
    egcdn_spec m n (km, kn).

Lemma egcdnP : forall m n, m > 0 -> egcdn_spec m n (egcdn m n).
Proof.
rewrite /egcdn => m0 n0; have: (n0, m0) = bezout_rec n0 m0 [::] by [].
case: (posnP n0) => [-> /=|]; first by split; rewrite // mul1n gcdn0.
elim: {1 4}n0 {1 3 5 7}n0 {-1 4}m0 [::] (ltnSn n0) => [[]//|s IHs] n m qs /=.
move=> le_ns n_pos def_mn0 m_pos.
case: edivnP => q r def_m; rewrite n_pos /= => lt_rn.
case: posnP => [r0 {s le_ns IHs lt_rn}|r_pos]; last first.
  by apply: IHs => //=; [rewrite (leq_trans lt_rn) | rewrite natTrecE -def_m].
rewrite {r}r0 addn0 in def_m; set b := odd _; pose d := gcdn m n.
pose km := ~~ b : nat; pose kn := if b then 1 else q.-1.
rewrite (_ : bezout_rec _ _ _ = bezout_rec km kn qs); last first.
  by rewrite /kn /km; case b => //=; rewrite natTrecE addn0 muln1.
have def_d: d = n by rewrite /d def_m gcdnC gcdnE modn_mull gcd0n -[n]prednK.
have: km * m + 2 * b * d = kn * n + d.
  rewrite {}/kn {}/km def_m def_d -mulSnr; case: b; rewrite //= addn0 mul1n.
  by rewrite prednK //; apply: ltn_0dvd m_pos _; rewrite def_m dvdn_mulr.
have{def_m}: kn * d <= m.
  have q_pos : 0 < q by rewrite def_m ltn_0mul n_pos ?andbT in m_pos.
  by rewrite /kn; case b; rewrite def_d def_m leq_pmul2r // leq_pred.
have{def_d}: km * d <= n by rewrite -[n]mul1n def_d leq_pmul2r // leq_b1.
move: km {q}kn m_pos n_pos def_mn0; rewrite {}/d {}/b.
elim: qs m n => [|q qs IHq] n r kn kr n_pos r_pos /=.
  case=> -> -> {m0 n0}; rewrite !addn0 => le_kn_r _ def_d; split=> //.
  have d_pos: 0 < gcdn n r by rewrite ltn_0gcd n_pos.
  have: 0 < kn * n by rewrite def_d ltn_0add d_pos orbT.
  rewrite ltn_0mul n_pos andbT; move/ltn_pmul2l <-.
  by rewrite def_d -addn1 leq_add // mulnCA leq_mul2l le_kn_r orbT.
rewrite !natTrecE; set m:= _ + r; set km := _ * _ + kn; pose d := gcdn m n.
have ->: gcdn n r = d by rewrite [d]gcdnC gcdn_addl_mul.
have m_pos: 0 < m by rewrite ltn_0add r_pos orbT.
have d_pos: 0 < d by rewrite ltn_0gcd m_pos.
move/IHq=> {IHq} IHq le_kn_r le_kr_n def_d; apply: IHq => //; rewrite -/d.
  by rewrite muln_addl leq_add // -mulnA leq_mul2l le_kr_n orbT.
apply: (@addn_injr d); rewrite -!addnA addnn addnCA muln_addr -addnA addnCA.
rewrite /km muln_addl mulnCA mulnA -addnA; congr (_ + _).
by rewrite -def_d addnC -addnA -muln_addl -muln_addr addn_negb -mul2n.
Qed.

Lemma bezoutl : forall m n, m > 0 -> {a | a < m & m %| gcdn m n + a * n}.
Proof.
move=> m n m_pos; case: (egcdnP n m_pos) => km kn def_d lt_kn_m.
exists kn; last by rewrite addnC -def_d dvdn_mull.
apply: leq_ltn_trans lt_kn_m.
by rewrite -{1}[kn]muln1 leq_mul2l ltn_0gcd m_pos orbT.
Qed.

Lemma bezoutr : forall m n, n > 0 -> {a | a < n & n %| gcdn m n + a * m}.
Proof. by move=> m n; rewrite gcdnC; exact: bezoutl. Qed.

(* Back to the gcd. *)

Lemma dvdn_gcd : forall p m n, p %| gcdn m n = (p %| m) && (p %| n).
Proof.
move=> p m n; apply/idP/andP=> [dv_pmn | [dv_pm dv_pn]].
  by rewrite ?(dvdn_trans dv_pmn) ?dvdn_gcdl ?dvdn_gcdr.
case (posnP n) => [->|n_pos]; first by rewrite gcdn0.
case: (bezoutr m n_pos) => // km _; move/(dvdn_trans dv_pn).
by rewrite dvdn_addl // dvdn_mull.
Qed.

Lemma gcdn_mul2l : forall p m n, gcdn (p * m) (p * n) = p * gcdn m n.
Proof.
move=> p m n; case: (posnP p) => [-> //| p_pos].
elim: {m}m.+1 {-2}m n (ltnSn m) => // s IHs m n; rewrite ltnS => le_ms.
rewrite gcdnE (gcdnE m) eqn_mul0 modn_pmul2l // eqn0Ngt p_pos.
case: posnP => // m_pos; apply: IHs; apply: leq_trans le_ms.
exact: ltn_pmod.
Qed.

Lemma gcdn_modr : forall m n, gcdn m (n %% m) = gcdn m n.
Proof. by move=> m n; rewrite {2}(divn_eq n m) gcdn_addl_mul. Qed.

Lemma gcdn_modl: forall m n, gcdn (m %% n) n = gcdn m n.
Proof. by move=> m n; rewrite !(gcdnC _ n) gcdn_modr. Qed.

Lemma gcdnAC : right_commutative gcdn.
Proof.
suff dvd: forall m n p, gcdn (gcdn m n) p %| gcdn (gcdn m p) n.
  by move=> m n p; apply/eqP; rewrite eqn_dvd !dvd.
move=> m n p; rewrite !dvdn_gcd dvdn_gcdr.
by rewrite !(dvdn_trans (dvdn_gcdl _ p)) ?dvdn_gcdl ?dvdn_gcdr.
Qed.

Lemma gcdnA : associative gcdn.
Proof. by move=> m n p; rewrite !(gcdnC m) gcdnAC. Qed.

Lemma gcdnCA : left_commutative gcdn.
Proof. by move=> m n p; rewrite !gcdnA (gcdnC m). Qed.

Lemma muln_gcdl : left_distributive muln gcdn.
Proof. by move=> m n p; rewrite -!(mulnC p) gcdn_mul2l. Qed.

Lemma muln_gcdr : right_distributive muln gcdn.
Proof. by move=> m n p; rewrite gcdn_mul2l. Qed.

Lemma gcdn_def : forall d m n,
    d %| m -> d %| n -> (forall d', d' %| m -> d' %| n -> d' %| d)
  -> gcdn m n = d.
Proof.
move=> d m n dv_dm dv_dn gdv_d; apply/eqP.
by rewrite eqn_dvd dvdn_gcd dv_dm dv_dn gdv_d ?dvdn_gcdl ?dvdn_gcdr.
Qed.

Lemma gcdn_divnC : forall n m, n * (m %/ gcdn n m)  = m * (n %/ gcdn n m).
Proof. by move=> n m; rewrite divn_mulCA ?dvdn_gcdl ?dvdn_gcdr. Qed.

(* We derive the lcm directly. *)

Definition lcmn m n := m * n %/ gcdn m n.

Lemma lcmnC : commutative lcmn.
Proof. by move=> m n; rewrite /lcmn mulnC gcdnC. Qed.

Lemma lcm0n : left_zero 0 lcmn. Proof. move=> n; exact: div0n. Qed.
Lemma lcmn0 : right_zero 0 lcmn. Proof. by move=> n; rewrite lcmnC lcm0n. Qed.

Lemma lcm1n : left_unit 1 lcmn.
Proof. by move=> n; rewrite /lcmn gcd1n mul1n divn1. Qed.

Lemma lcmn1 : right_unit 1 lcmn.
Proof. by move=> n; rewrite lcmnC lcm1n. Qed.

Lemma muln_lcm_gcd : forall m n, lcmn m n * gcdn m n = m * n.
Proof. by move=> m n; apply/eqP; rewrite divnK ?dvdn_mull ?dvdn_gcdr. Qed.

Lemma ltn_0lcm : forall m n, (0 < lcmn m n) = (0 < m) && (0 < n).
Proof. by move=> m n; rewrite -ltn_0mul ltn_divr ?dvdn_mull ?dvdn_gcdr. Qed.

Lemma muln_lcmr : right_distributive muln lcmn.
Proof.
case=> // m n p; rewrite /lcmn -muln_gcdr -!mulnA divn_pmul2l // mulnCA.
by rewrite divn_mulA ?dvdn_mull ?dvdn_gcdr.
Qed.

Lemma muln_lcml : left_distributive muln lcmn.
Proof. by move=> m n p; rewrite -!(mulnC p) muln_lcmr. Qed.

Lemma lcmnA : associative lcmn.
Proof.
move=> m n p; rewrite {1 3}/lcmn mulnC !divn_mulAC ?dvdn_mull ?dvdn_gcdr //.
rewrite !divn_divl ?dvdn_mulr ?dvdn_gcdl // mulnC mulnA !muln_gcdr.
by rewrite ![_ * lcmn _ _]mulnC !muln_lcm_gcd !muln_gcdl -!(mulnC m) gcdnA.
Qed.

Lemma dvdn_lcml : forall d1 d2, d1 %| lcmn d1 d2.
Proof. by move=> d1 d2; rewrite /lcmn -divn_mulA ?dvdn_gcdr ?dvdn_mulr. Qed.

Lemma dvdn_lcmr : forall d1 d2, d2 %| lcmn d1 d2.
Proof. by move=> d1 d2; rewrite lcmnC dvdn_lcml. Qed.

Lemma dvdn_lcm : forall d1 d2 m, lcmn d1 d2 %| m = (d1 %| m) && (d2 %| m).
Proof.
case=> [|d1] [|d2] m; try by case: m => [|m]; rewrite ?lcmn0 ?andbF.
rewrite -(@dvdn_pmul2r (gcdn d1.+1 d2.+1)) ?ltn_0gcd // muln_lcm_gcd.
by rewrite muln_gcdr dvdn_gcd {1}mulnC andbC !dvdn_pmul2r.
Qed.

(* Coprime factors *)

Definition coprime m n := gcdn m n == 1.

Lemma coprime1n : forall n, coprime 1 n.
Proof. by move=> n; rewrite /coprime gcd1n. Qed.

Lemma coprimen1 : forall n, coprime n 1.
Proof. by move=> n; rewrite /coprime gcdn1. Qed.

Lemma coprime_sym : forall m n, coprime m n = coprime n m.
Proof. by move => m n; rewrite /coprime gcdnC. Qed.

Lemma coprimeP : forall n m, n > 0 ->
  reflect (exists u, u.1 * n - u.2 * m = 1) (coprime n m).
Proof.
move=> n m n_pos; apply: (iffP eqP) => [<-| [[kn km] /= kn_km_1]].
  by have [kn km kg _] := egcdnP m n_pos; exists (kn, km); rewrite kg addKn.
apply gcdn_def; rewrite ?dvd1n // => d dv_d_n dv_d_m.
by rewrite -kn_km_1 dvdn_subr ?dvdn_mull // ltnW // -ltn_0sub kn_km_1.
Qed.

Lemma modn_coprime : forall k n, O < k ->
  (exists u, (k * u) %% n = 1%N) -> coprime k n.
Proof.
move=> k n Hpos [u Hu]; apply/coprimeP; first by [].
by exists (u, k * u %/ n); rewrite /= mulnC {1}(divn_eq (k * u) n) addKn.
Qed.

Lemma gauss_inv : forall m n p,
  coprime m n -> (m * n %| p) = (m %| p) && (n %| p).
Proof.
by move=> m n p co_mn; rewrite -muln_lcm_gcd (eqnP co_mn) muln1 dvdn_lcm.
Qed.

Lemma gauss : forall m n p, coprime m n -> (m %| n * p) = (m %| p).
Proof.
move=> m [|n] p co_mn; first by case: m co_mn => [|[]] // _; rewrite !dvd1n.
by symmetry; rewrite mulnC -(@dvdn_pmul2r n.+1) ?gauss_inv // andbC dvdn_mull.
Qed.

Lemma gauss_gcdr : forall p m n, coprime p m -> gcdn p (m * n) = gcdn p n.
Proof.
move=> p m n co_pm; apply/eqP; rewrite eqn_dvd !dvdn_gcd !dvdn_gcdl /=.
rewrite andbC dvdn_mull ?dvdn_gcdr //= -(@gauss _ m) ?dvdn_gcdr //.
by rewrite /coprime gcdnAC (eqnP co_pm) gcd1n.
Qed.

Lemma gauss_gcdl : forall p m n, coprime p n -> gcdn p (m * n) = gcdn p m.
Proof. by move=> *; rewrite mulnC gauss_gcdr. Qed.

Lemma coprime_mulr : forall p m n,
  coprime p (m * n) = coprime p m && coprime p n.
Proof.
move=> p m n.
case co_pm: (coprime p m) => /=; first by rewrite /coprime gauss_gcdr.
apply/eqP=> co_p_mn; case/eqnP: co_pm; apply gcdn_def => // d dv_dp dv_dm.
by rewrite -co_p_mn dvdn_gcd dv_dp dvdn_mulr.
Qed.

Lemma coprime_mull : forall p m n,
  coprime (m * n) p = coprime m p && coprime n p.
Proof. move=> p m n; rewrite !(coprime_sym _ p); exact: coprime_mulr. Qed.

Lemma coprime_pexpl : forall k m n, 0 < k -> coprime (m ^ k) n = coprime m n.
Proof.
case=> // k m n _; elim: k => [|k IHk]; first by rewrite expn1.
by rewrite expnS coprime_mull -IHk; case coprime.
Qed.

Lemma coprime_pexpr : forall k m n, 0 < k -> coprime m (n ^ k) = coprime m n.
Proof. by move=> k m n k_pos; rewrite !(coprime_sym m) coprime_pexpl. Qed.

Lemma coprime_expl : forall k m n, coprime m n -> coprime (m ^ k) n.
Proof. by case=> [|k] p m co_pm; rewrite (coprime1n, coprime_pexpl). Qed.

Lemma coprime_expr : forall k m n, coprime m n -> coprime m (n ^ k).
Proof. by move=> k m n; rewrite !(coprime_sym m); exact: coprime_expl. Qed.

Lemma coprime_egcdn : forall n m, n > 0 ->
    coprime (egcdn n m).1 (egcdn n m).2.
Proof.
move=> n m n_pos; case: (egcdnP m n_pos) => kn km /=; move/eqP.
have [u defn] := dvdnP (dvdn_gcdl n m); have [v defm] := dvdnP (dvdn_gcdr n m).
rewrite -[gcdn n m]mul1n {1}defm {1}defn !mulnA -muln_addl addnC.
rewrite eqn_pmul2r ?ltn_0gcd ?n_pos //; move/eqP; case: kn => // kn def_knu _.
by apply/coprimeP=> //; exists (u, v); rewrite mulnC def_knu mulnC addnK.
Qed.

Section Chinese.

(***********************************************************************)
(*   The chinese remainder theorem                                     *)
(***********************************************************************)

Variables m1 m2 : nat.
Hypotheses (m1_pos : 0 < m1) (m2_pos : 0 < m2) (co_m12 : coprime m1 m2).

Lemma chinese_remainder : forall x y,
  (x == y %[mod m1 * m2]) = (x == y %[mod m1]) && (x == y %[mod m2]).
Proof.
move=> x y; wlog le_yx : x y / y <= x.
  by case/orP: (leq_total y x); last rewrite !(eq_sym (x %% _)); auto.
by rewrite !eqn_mod_dvd // gauss_inv.
Qed.

(***********************************************************************)
(*   A function that solves the chinese remainder problem              *)
(***********************************************************************)

Definition chinese r1 r2 :=
  r1 * m2 * (egcdn m2 m1).1 + r2 * m1 * (egcdn m1 m2).1.

Lemma chinese_modl : forall r1 r2, chinese r1 r2 = r1 %[mod m1].
Proof.
rewrite /chinese; case: egcdnP=> // k2 k1 def_m1 _ r1 r2.
rewrite mulnAC -mulnA def_m1 gcdnC (eqnP co_m12) muln_addr mulnA muln1.
by rewrite addnAC (mulnAC _ m1) -muln_addl modn_addl_mul.
Qed.

Lemma chinese_modr : forall r1 r2, chinese r1 r2 = r2 %[mod m2].
Proof.
rewrite /chinese; case: (egcdnP m2) => // k1 k2 def_m2 _ r1 r2.
rewrite addnC mulnAC -mulnA def_m2 (eqnP co_m12) muln_addr mulnA muln1.
by rewrite addnAC (mulnAC _ m2) -muln_addl modn_addl_mul.
Qed.

Lemma chinese_modlr : forall x, x = chinese (x %% m1) (x %% m2) %[mod m1 * m2].
Proof.
move=> x; apply/eqP.
by rewrite chinese_remainder // chinese_modl chinese_modr !modn_mod !eqxx.
Qed.

End Chinese.


(** Authors: Christian Doczkal and Jan-Oliver Kaiser *)
From mathcomp Require Import all_ssreflect.
From RegLang Require Import misc languages dfa.

Set Implicit Arguments.
Unset Printing Implicit Defensive.
Unset Strict Implicit.

Section NFA.
Variable char : finType.
Local Notation word := (word char).

(** * Nondeterministic Finite Automata.

We define both normal NFAs and NFAs with epsilon transitions
(eNFAs). For NFAs acceptance can still be defined by structural
recursion on the word. In particular, the length of an NFA run is
determined by the input word, a property that we exploit repeatedly. *)

Record nfa : Type := {
    nfa_state :> finType;
    nfa_s : { set nfa_state };
    nfa_fin : { set nfa_state };
    nfa_trans : nfa_state -> char -> nfa_state -> bool }.

Fixpoint nfa_accept (A : nfa) (x : A) w :=
  if w is a :: w' then [exists (y | nfa_trans x a y), nfa_accept y w']
                  else x \in nfa_fin A.

Definition nfa_lang (A : nfa) := [pred w | [exists s, (s \in nfa_s A) && nfa_accept s w]].

(** ** Epsilon NFAs *)

Record enfa : Type := {
  enfa_state :> finType;
  enfa_s : {set enfa_state};
  enfa_f : {set enfa_state};
  enfa_trans : option char -> enfa_state -> enfa_state -> bool }.

Section EpsilonNFA.
  Variables (N : enfa).

  (* For eNFAs, acceptance is defined relationally since structural
  recursion over the word is no longer possible. *)

  Inductive enfa_accept : N -> word -> Prop :=
    | EnfaFin q : q \in enfa_f N -> enfa_accept q [::]
    | EnfaSome p a q x : enfa_trans (Some a) p q -> enfa_accept q x -> enfa_accept p (a::x)
    | EnfaNone p q x : enfa_trans None p q -> enfa_accept q x -> enfa_accept p (x).

  Definition enfa_lang x := exists2 s, s \in enfa_s N & enfa_accept s x.

  (** We convert eNFAs to NFAs by extending the set of starting states and all
  transitions by epsipon-reachable states - also known as epsilon closure *)

  Definition eps_reach (p : N) := [set q | connect (enfa_trans None) p q].

  Lemma lift_accept p q x : q \in eps_reach p -> enfa_accept q x -> enfa_accept p x.
  Proof.
    rewrite inE => /connectP [s]. elim: s p x q => //= [p x q _ -> //| q s IHs p x q'].
    case/andP => pq ? ? H. apply: EnfaNone pq _. exact: IHs H.
  Qed.

  Definition nfa_of :=
    {| nfa_s := \bigcup_(p in enfa_s N) (eps_reach p);
       nfa_fin := enfa_f N;
       nfa_trans p a q := [exists p', enfa_trans (Some a) p p' && (q \in eps_reach p') ] |}.

  Lemma enfaE x p :
    (enfa_accept p x) <-> (exists2 q : nfa_of, q \in eps_reach p & nfa_accept q x).
  Proof. split.
    - elim => {p x} [q H|p a q x H _ [q' Hq1 Hq2]|p p' x].
      + exists q => //. by rewrite inE connect0.
      + exists p => /=; first by rewrite inE connect0.
        apply/exists_inP. exists q' => //. apply/exists_inP. by exists q.
      + move => H1 H2 [q Hq1 Hq2]. exists q => //. rewrite !inE in Hq1 *.
        exact: connect_trans (connect1 _) Hq1.
    - elim: x p => [|a x IH] p [p'] R /= H. apply: lift_accept R _. exact: EnfaFin.
      case/exists_inP : H => q /exists_inP [q' pq' qq'] H. apply: lift_accept R _.
      apply: EnfaSome pq' _. apply: IH. by exists q.
  Qed.

  Lemma nfa_ofP x : reflect (enfa_lang x) (x \in nfa_lang nfa_of).
  Proof.
    apply: (iffP exists_inP) => [[p Hp1 Hp2]|[s Hs1 /enfaE [p Hp1 Hp2]]].
    - case/bigcupP : Hp1 => s Hs H. exists s => //. by apply/enfaE; exists p.
    - exists p => //. by apply/bigcupP; exists s.
  Qed.
End EpsilonNFA.

(** ** Equivalence of DFAs and NFAs *)
(** We use the powerset construction to obtain
   a deterministic automaton from a non-deterministic one. **)
Section PowersetConstruction.

Variable A : nfa.

Definition nfa_to_dfa := {|
  dfa_s := nfa_s A;
  dfa_fin := [set X | X :&: nfa_fin A != set0];
  dfa_trans X a := [set q | [exists (p | p \in X), nfa_trans p a q]]
|}.

Lemma nfa_to_dfa_correct : nfa_lang A =i dfa_lang nfa_to_dfa.
Proof.
  move => w. rewrite !inE {2}/nfa_to_dfa /=.
  elim: w (nfa_s _) => [|a x IH] X; rewrite /= accE ?inE.
  - apply/existsP/set0Pn => [] [p] H; exists p; by rewrite inE in H *.
  - rewrite -IH /dfa_trans /=. apply/exists_inP/exists_inP.
    + case => p inX /exists_inP [q ? ?]. exists q => //. rewrite inE.
      apply/exists_inP. by exists p.
    + case => p. rewrite inE => /exists_inP [q] ? ? ?.
      exists q => //. apply/exists_inP. by exists p.
Qed.

End PowersetConstruction.

(** We also embed NFAs into DFAs. **)

Section Embed.

Variable A : dfa char.

Definition dfa_to_nfa : nfa := {|
  nfa_s := [set dfa_s A];
  nfa_fin := dfa_fin A;
  nfa_trans x a y := dfa_trans x a == y |}.

Lemma dfa_to_nfa_correct : dfa_lang A =i nfa_lang dfa_to_nfa.
Proof.
  move => w. rewrite !inE /nfa_s /=.
  elim: w (dfa_s A) => [|b w IHw] x; rewrite accE /=.
  - apply/idP/existsP => [Fx|[y /andP [/set1P ->]]//].
    exists x. by rewrite !inE eqxx.
  - rewrite IHw. apply/exists_inP/exists_inP.
    + case => y /set1P -> H. exists x; first exact: set11.
      apply/existsP. exists (dfa_trans x b). by rewrite H eqxx.
    + case => y /set1P -> {y} /existsP [z] /andP [] /eqP-> H.
      exists z; by rewrite ?set11.
Qed.

End Embed.

(** ** Operations on NFAs

To prepare the translation from regular expresstions to DFAs, we show
that finite automata are closed under all regular operations. We build
the primitive automata, complement and boolean combinations using
DFAs. *)

Definition nfa_char (a:char) :=
  {| nfa_s := [set false];
     nfa_fin := [set true];
     nfa_trans p b q := if (p,q) is (false,true) then (b == a) else false |}.

Lemma nfa_char_correct (a : char) : nfa_lang (nfa_char a) =1 pred1 [:: a].
Proof.
  move => w /=. apply/exists_inP/eqP => [[p]|].
  - rewrite inE => /eqP->. case: w => [|b [|c w]] /=; first by rewrite inE.
    + by case/exists_inP => [[/eqP->|//]].
    + case/exists_inP => [[_|//]]. by case/exists_inP.
  - move->. exists false; first by rewrite inE. apply/exists_inP.
    exists true; by rewrite //= inE.
Qed.

Definition nfa_plus (N M : nfa) :=
  {| nfa_s := [set q | match q with inl q => q \in nfa_s N | inr q => q \in nfa_s M end ];
     nfa_fin := [set q | match q with inl q => q \in nfa_fin N | inr q => q \in nfa_fin M end ];
     nfa_trans p a q := match p,a,q with
                         | inl p,a,inl q => nfa_trans p a q
                         | inr p,a,inr q => nfa_trans p a q
                         | _,_,_ => false
                         end |}.

Lemma nfa_plus_correct (N M : nfa) :
  nfa_lang (nfa_plus N M) =i plus (nfa_lang N) (nfa_lang M).
Proof.
  move => w. apply/idP/idP.
  - case/exists_inP => [[s|s]]; rewrite !inE => A B;
    apply/orP;[left|right];apply/exists_inP; exists s => //.
    + elim: w s {A} B => /= [|a w IH] s; first by rewrite inE.
      case/exists_inP => [[|]// p A /IH B]. apply/exists_inP. by exists p.
    + elim: w s {A} B => /= [|a w IH] s; first by rewrite inE.
      case/exists_inP => [[|]// p A /IH B]. apply/exists_inP. by exists p.
  - rewrite !inE. case/orP => /exists_inP [s A B];
    apply/exists_inP; [exists(inl s)|exists(inr s)]; rewrite ?inE //.
    + elim: w s {A} B => /= [|a w IH] s; first by rewrite inE.
      case/exists_inP => [p A /IH B]. apply/exists_inP. by exists (inl p).
    + elim: w s {A} B => /= [|a w IH] s; first by rewrite inE.
      case/exists_inP => [p A /IH B]. apply/exists_inP. by exists (inr p).
Qed.

Definition nfa_eps : nfa :=
  {| nfa_s := [set tt]; nfa_fin := [set tt]; nfa_trans p a q := false |}.

Lemma nfa_eps_correct: nfa_lang (nfa_eps) =i pred1 [::].
Proof.
  move => w. apply/exists_inP/idP.
  + move => [[]]. case: w => [|a w] //= _. by case/exists_inP.
  + move => /=. rewrite inE=>/eqP->. exists tt; by rewrite /= inE.
Qed.

(** The automata for concatenation and Kleene star are constructed by
taking NFAs as input and first building eNFAs which are then converted
to NFAs. *)

Section eNFAOps.

Variables A1 A2 : nfa.

Definition enfa_conc : enfa :=
  {| enfa_s := inl @: nfa_s A1;
     enfa_f := inr @: nfa_fin A2;
     enfa_trans c p q :=
       match c,p,q with
         | Some a,inl p',inl q' => nfa_trans p' a q'
         | Some a,inr p',inr q' => nfa_trans p' a q'
         | None,inl p', inr q' => (p' \in nfa_fin A1) && (q' \in nfa_s A2)
         | _,_,_ => false
       end |}.

Lemma enfa_concE (p : enfa_conc) x : enfa_accept p x ->
  match p with
    | inr p' => nfa_accept p' x
    | inl p' => exists x1 x2, [/\ x = x1 ++ x2, nfa_accept p' x1 & x2 \in nfa_lang A2]
  end.
Proof.
  elim => {p x} [[?|?] /imsetP [q] // ? [->] //||].
  - move => [p|p] a [q|q] x //.
    + move => pq _ [x1] [x2] [X1 X2 X3]. exists (a::x1); exists x2; subst; split => //.
      by apply/exists_inP; exists q.
    + move => pq _ Hq. by apply/exists_inP; exists q.
  - move => [p|p] [q|q] //= x /andP[Hp Hq] _ ?. exists [::]; exists x; split => //.
    by apply/exists_inP; exists q.
Qed.

Lemma enfa_concIr (p : A2) x : nfa_accept p x -> @enfa_accept enfa_conc (inr p) x.
Proof.
  elim: x p => [p Hp|a x IH p /= /exists_inP [q q1 q2]].
  - by constructor; rewrite mem_imset.
  - apply: (@EnfaSome enfa_conc _ _ (inr q)) => //. exact: IH.
Qed.

Lemma enfa_concIl (p : A1) x1 x2 :
  nfa_accept p x1 -> x2 \in nfa_lang A2 -> @enfa_accept enfa_conc (inl p) (x1++x2).
Proof.
  elim: x1 p => /= [p Hp /exists_inP [q q1 q2]|a x1 IH p /exists_inP [q q1 q2] H].
  - apply: (@EnfaNone enfa_conc _ (inr q)). by rewrite /= Hp. exact: enfa_concIr.
  - apply: (@EnfaSome enfa_conc _ _ (inl q)). by rewrite /= q1. exact: IH.
Qed.

Lemma enfa_concP x : reflect (enfa_lang enfa_conc x) (conc (nfa_lang A1) (nfa_lang A2) x).
Proof.
  apply: (iffP (@concP _ _ _ _)) => [[x1] [x2] [X1 [X2 X3]] |].
  - case/exists_inP : X2 => s ? ?. exists (inl s); first by rewrite /enfa_conc /= mem_imset.
    subst. exact: enfa_concIl.
  - move => [[s /imsetP [? ? [?]] /enfa_concE [x1] [x2] [? ? ?] |s]]; last by case/imsetP.
    exists x1; exists x2. repeat (split => //). apply/exists_inP. by exists s;subst.
Qed.

Definition enfa_star : enfa :=
  {| enfa_s := [set None];
     enfa_f := [set None];
     enfa_trans c p q :=
       match c,p,q with
           Some a,Some p', Some q' => q' \in nfa_trans p' a
         | None, Some p', None => p' \in nfa_fin A1
         | None, None, Some s => s \in nfa_s A1
         | _,_,_ => false
       end |}.

Lemma enfa_s_None : None \in enfa_s enfa_star.
Proof. by rewrite inE. Qed.

Lemma enfa_f_None : None \in enfa_f enfa_star.
Proof. by rewrite inE. Qed.
Hint Resolve enfa_s_None enfa_f_None.

Lemma enfa_star_cat x1 x2 (p : enfa_star) :
  enfa_accept p x1 -> enfa_lang enfa_star x2 -> enfa_accept p (x1 ++ x2).
Proof.
  elim => {p x1}.
  - move => p. rewrite inE => /eqP->. case => q. by rewrite inE => /eqP->.
  - move => p a q x /=. case: p => // p. case: q => // q pq ? IH H. exact: EnfaSome (IH H).
  - move => [p|] [q|] x //= p1 p2 IH H; exact: EnfaNone (IH H).
Qed.

Lemma enfa_starI x (p : A1) : nfa_accept p x -> @enfa_accept enfa_star (Some p) x.
Proof.
  elim: x p => /= [p H|a x IH p].
  - apply: (@EnfaNone enfa_star _ None) => //. exact: EnfaFin.
  - case/exists_inP => q q1 /IH. exact: EnfaSome.
Qed.

Lemma enfa_star_langI x : x \in nfa_lang A1 -> @enfa_accept enfa_star None x.
Proof.
  case/exists_inP => s s1 s2.
  apply: (@EnfaNone enfa_star _ (Some s)) => //. exact: enfa_starI.
Qed.

Lemma enfa_starE (o : enfa_star) x : enfa_accept o x ->
  if o is Some p
  then exists x1 x2, [/\ x = x1 ++ x2, nfa_accept p x1 & star (nfa_lang A1) x2]
  else star (nfa_lang A1) x.
Proof.
  elim => {x o}.
  - move => [q|//]. by rewrite inE; move/eqP.
  - move => [p|] a [q|] x // H acc [x1] [x2] [H1 H2 H3]. exists (a::x1); exists x2.
    rewrite H1. split => //. by apply/exists_inP; exists q.
  - move => [p|] [q|] x //=.
    + move => *. by exists [::]; exists x.
    + move => H acc [x1] [x2] [H1 H2]. rewrite H1. apply: star_cat.
      by apply/exists_inP; exists q.
Qed.

Lemma enfa_starP x : reflect (enfa_lang enfa_star x) (star (nfa_lang A1) x).
Proof. apply: (iffP idP).
  - case/starP => vv H ->. elim: vv H => /= [_|v vv].
    + exists None => //. exact: EnfaFin.
    + move => IH /andP[/andP [H1 H2] H3]. exists None => //.
      apply: enfa_star_cat (IH _) => //. exact: enfa_star_langI.
  - case => q. rewrite inE => /eqP-> {q}. exact: enfa_starE.
Qed.

Definition nfa_conc := nfa_of (enfa_conc).

Lemma nfa_conc_correct : nfa_lang nfa_conc =i conc (nfa_lang A1) (nfa_lang A2).
Proof. move => x. apply/nfa_ofP/idP => ?;exact/enfa_concP. Qed.

Definition nfa_star := nfa_of (enfa_star).
Lemma nfa_star_correct : nfa_lang nfa_star =i star (nfa_lang A1).
Proof. move => x. apply/nfa_ofP/idP => ?;exact/enfa_starP. Qed.

End eNFAOps.

(** ** Runs on NFAs *)

Section NFARun.
  Variable (M : nfa).

  Inductive nfa_run : word -> M -> seq M -> Prop :=
    | run0 p of p \in nfa_fin M : nfa_run [::] p [::]
    | runS a p q x r & q \in nfa_trans p a : nfa_run x q r -> nfa_run (a::x) p (q::r).

  Lemma nfa_acceptP x p : reflect (exists r, nfa_run x p r) (nfa_accept p x).
  Proof.
    apply: (iffP idP) => [|[r]].
    - elim: x p => [|a x IHx] p /=; first by exists [::]; constructor.
      case/exists_inP => q p1 p2. case (IHx q p2) => r ?. by exists (q::r); constructor.
    - elim: x r p => [|a x IHx] r p; first by inversion 1; subst.
      inversion 1; subst. apply/exists_inP. exists q => //. exact: IHx H4.
  Qed.

  Lemma run_size x r p : nfa_run x p r -> size x = size r.
  Proof. by elim => // {r p x} a p q r x _ _ /= ->. Qed.

  Lemma nfaP x : reflect (exists s r, s \in nfa_s M /\ nfa_run x s r) (x \in nfa_lang M).
  Proof.
    apply: (iffP exists_inP).
    - case => s ? /nfa_acceptP [r] ?. by exists s; exists r.
    - case => s [r] [? ?]. exists s => //. apply/nfa_acceptP. by exists r.
  Qed.

  Lemma run_last x p r : nfa_run x p r -> last p r \in nfa_fin M.
  Proof. by elim. Qed.

  Lemma run_trans x p r i (Hi : i < size x) : nfa_run x p r ->
    nth p (p::r) i.+1 \in nfa_trans (nth p (p::r) i) (tnth (in_tuple x) (Ordinal Hi)).
  Proof.
    move => H. elim: H i Hi => {x p r} // a p q x r tr run IH /= [|i] Hi //.
    rewrite !(set_nth_default q); try by rewrite /= -(run_size run) // ltnW.
    rewrite {1}[nth]lock (tnth_nth a) /=. rewrite ltnS in Hi.
    rewrite -{3}[i]/(nat_of_ord (Ordinal Hi)).
    by rewrite -[x]/(tval (in_tuple x)) -tnth_nth -lock IH.
  Qed.

  (** The following lemma uses [in_tuple] and [tnth] in order to avoid
  having to assume the existence of a default symbol *)

  Lemma runI x s r :
    size r = size x -> last s r \in nfa_fin M ->
    (forall i : 'I_(size x),
       nth s (s::r) i.+1 \in nfa_trans (nth s (s::r) i) (tnth (in_tuple x) i)) ->
    nfa_run x s r.
  Proof.
    elim: x s r => [|a x IHx ] s r /=.
    - move/eqP => e inF _. rewrite size_eq0 in e. rewrite (eqP e) in inF *. exact: run0.
    - case: r => // p r /eqP /=. rewrite eqSS => /eqP R1 R2 I.
      apply: runS (I ord0) _ => /=. apply: IHx => // i.
      move: (I (inord i.+1)). rewrite /tnth /= !inordK /= ?ltnS //.
      rewrite !(set_nth_default p) /= ?R1 // 1?ltnW ?ltnS //.
      by rewrite -[x]/(val (in_tuple x)) -!tnth_nth.
  Qed.

End NFARun.

(** Decidability of Language Emptiness *)

Definition nfa_inhab (N : nfa) := dfa_inhab (nfa_to_dfa N).

Lemma nfa_inhabP N : reflect (exists w, w \in nfa_lang N) (nfa_inhab N).
Proof.
  apply: (iffP (dfa_inhabP _)).
  - move => [x]. rewrite -nfa_to_dfa_correct. by exists x.
  - move => [x ?]. exists x. by rewrite -nfa_to_dfa_correct.
Qed.

Lemma nfa_regular L :
  regular L <-T->  { N : nfa  | forall x, L x <-> x \in nfa_lang N }.
Proof.
  split => [[A]|[N]] H.
  exists (dfa_to_nfa A) => x. by rewrite -dfa_to_nfa_correct.
  exists (nfa_to_dfa N) => x. by rewrite -nfa_to_dfa_correct.
Qed.

End NFA.

Arguments nfaP [char M x].


(* ********************************************** *)
(* Types and Semantics for Programming Languages  *)
(* ********************************************** *)

(* Place an X in front of the appropriate statement *)
(* [ ]  I have done Problems 1 and 2 *)
(* [ ]  I have done Problems 1 and 3 *)

Require Import Coq.Bool.Bool.
Require Import Coq.Arith.Arith.
Require Import Coq.Arith.EqNat.
Require Import Coq.omega.Omega.
Require Import Coq.Lists.List.
Import ListNotations.
Require Export Maps.
Require Export SfLib.

(* ********************************************** *)
(* Problem 1 *)
(* ********************************************** *)

Inductive last {X : Type} : list X -> X -> Prop :=
  | last_end : forall x,
       last (x :: nil) x
  | last_step : forall xs x y,
       last xs y ->
       last (x :: xs) y.

Theorem last_app : forall (X : Type) (x : X) (xs : list X),
  last xs x -> exists xs', xs = xs' ++ [x].
Proof.
  intros.
  induction xs.
  + inversion H.
  + inversion H. subst.
     - exists ([]). reflexivity.
     - apply IHxs in H3. inversion H3.
       exists (a::x1). simpl.
       rewrite <- H4. reflexivity.
Qed.

(* ********************************************** *)
(* Problem 2 *)
(* ********************************************** *)

(* Arithmetic and boolean expressions *)

Definition state := total_map nat.

Definition ble_nat := leb.

Inductive aexp : Type :=
  | ANum : nat -> aexp
  | AId : id -> aexp
  | APlus : aexp -> aexp -> aexp
  | AMinus : aexp -> aexp -> aexp
  | AMult : aexp -> aexp -> aexp.

Inductive bexp : Type :=
  | BTrue : bexp
  | BFalse : bexp
  | BEq : aexp -> aexp -> bexp
  | BLe : aexp -> aexp -> bexp
  | BNot : bexp -> bexp
  | BAnd : bexp -> bexp -> bexp.

Fixpoint aeval (st : state) (a : aexp) : nat :=
  match a with
  | ANum n => n
  | AId x => st x
  | APlus a1 a2 => (aeval st a1) + (aeval st a2)
  | AMinus a1 a2  => (aeval st a1) - (aeval st a2)
  | AMult a1 a2 => (aeval st a1) * (aeval st a2)
  end.

Fixpoint beval (st : state) (b : bexp) : bool :=
  match b with
  | BTrue       => true
  | BFalse      => false
  | BEq a1 a2   => beq_nat (aeval st a1) (aeval st a2)
  | BLe a1 a2   => ble_nat (aeval st a1) (aeval st a2)
  | BNot b1     => negb (beval st b1)
  | BAnd b1 b2  => andb (beval st b1) (beval st b2)
  end.

(* Commands *)

Inductive com : Type :=
  | CSkip : com
  | CAss : id -> aexp -> com
  | CSeq : com -> com -> com
  | CIf : bexp -> com -> com -> com
  | CWhile : bexp -> com -> com
  | CLoop : com -> bexp -> 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 "'IFB' c1 'THEN' c2 'ELSE' c3 'FI'" :=
  (CIf c1 c2 c3) (at level 80, right associativity).
Notation "'WHILE' b 'DO' c 'END'" :=
  (CWhile b c) (at level 80, right associativity).
Notation "'LOOP' c1 'WHILE' b 'DO' c2 'END'" :=
  (CLoop c1 b c2) (at level 80, right associativity).

(* Evaluation relation *)

Reserved Notation "c1 '/' st '||' st'" (at level 40, st at level 39).

Inductive ceval : com -> state -> state -> Prop :=
  | E_Skip : forall st,
      SKIP / st || st
  | E_Ass  : forall st a1 n x,
      aeval st a1 = n ->
      (x ::= a1) / st || (t_update st x n)
  | E_Seq : forall c1 c2 st st' st'',
      c1 / st  || st' ->
      c2 / st' || st'' ->
      (c1 ;; c2) / st || st''
  | E_IfTrue : forall st st' b c1 c2,
      beval st b = true ->
      c1 / st || st' ->
      (IFB b THEN c1 ELSE c2 FI) / st || st'
  | E_IfFalse : forall st st' b c1 c2,
      beval st b = false ->
      c2 / st || st' ->
      (IFB b THEN c1 ELSE c2 FI) / st || st'
  | E_WhileEnd : forall b st c,
      beval st b = false ->
      (WHILE b DO c END) / st || st
  | E_WhileLoop : forall st st' st'' b c,
      beval st b = true ->
      c / st || st' ->
      (WHILE b DO c END) / st' || st'' ->
      (WHILE b DO c END) / st || st''
  | E_LoopEnd : forall st st' c1 b c2,
       c1 / st || st' ->
       beval st' b = false ->
       (LOOP c1 WHILE b DO c2 END) / st || st'
  | E_LoopLoop : forall st st' st'' st''' c1 b c2,
       c1 / st || st' ->
       beval st' b = true ->
       c2 / st' || st'' ->
       (LOOP c1 WHILE b DO c2 END) / st'' || st''' ->
       (LOOP c1 WHILE b DO c2 END) / st || st'''

  where "c1 '/' st '||' st'" := (ceval c1 st st').

(* Assertions *)

Definition Assertion := state -> Prop.

Definition assert_implies (P Q : Assertion) : Prop :=
  forall st, P st -> Q st.

Notation "P ->> Q" :=
  (assert_implies P Q) (at level 80) : hoare_spec_scope.
Open Scope hoare_spec_scope.

Notation "P <<->> Q" :=
  (P ->> Q /\ Q ->> P) (at level 80) : hoare_spec_scope.

(* Hoare triples *)

Definition hoare_triple
           (P:Assertion) (c:com) (Q:Assertion) : Prop :=
  forall st st',
       c / st || st'  ->
       P st  ->
       Q st'.

Notation "{{ P }}  c  {{ Q }}" :=
  (hoare_triple P c Q) (at level 90, c at next level)
  : hoare_spec_scope.

(* Assertions *)

Definition bassn b : Assertion :=
  fun st => (beval st b = true).

Lemma bexp_eval_true : forall b st,
  beval st b = true -> (bassn b) st.
Proof.
  intros b st Hbe.
  unfold bassn. assumption.  Qed.

Lemma bexp_eval_false : forall b st,
  beval st b = false -> ~ ((bassn b) st).
Proof.
  intros b st Hbe contra.
  unfold bassn in contra.
  rewrite -> contra in Hbe. inversion Hbe.  Qed.

(* Assignment *)

(*
             ------------------------------ (hoare_asgn)
             {{Q [X |-> a]}} X::=a {{Q}}
*)

Definition assn_sub X a P : Assertion :=
  fun (st : state) =>
    P (t_update st X (aeval st a)).

Notation "P [ X |-> a ]" := (assn_sub X a P) (at level 10).

Theorem hoare_asgn : forall Q X a,
  {{Q [X |-> a]}} (X ::= a) {{Q}}.
Proof.
  unfold hoare_triple.
  intros Q X a st st' HE HQ.
  inversion HE. subst.
  unfold assn_sub in HQ. assumption.  Qed.

(* Consequence *)

(*
                {{P'}} c {{Q'}}
                   P ->> P'
                   Q' ->> Q
         -----------------------------   (hoare_consequence)
                {{P}} c {{Q}}
*)

Theorem hoare_consequence_pre : forall (P P' Q : Assertion) c,
  {{P'}} c {{Q}} ->
  P ->> P' ->
  {{P}} c {{Q}}.
Proof.
  intros P P' Q c Hhoare Himp.
  intros st st' Hc HP. apply (Hhoare st st').
  assumption. apply Himp. assumption. Qed.

Theorem hoare_consequence_post : forall (P Q Q' : Assertion) c,
  {{P}} c {{Q'}} ->
  Q' ->> Q ->
  {{P}} c {{Q}}.
Proof.
  intros P Q Q' c Hhoare Himp.
  intros st st' Hc HP.
  apply Himp.
  apply (Hhoare st st').
  assumption. assumption. Qed.

Theorem hoare_consequence : forall (P P' Q Q' : Assertion) c,
  {{P'}} c {{Q'}} ->
  P ->> P' ->
  Q' ->> Q ->
  {{P}} c {{Q}}.
Proof.
  intros P P' Q Q' c Hht HPP' HQ'Q.
  apply hoare_consequence_pre with (P' := P').
  apply hoare_consequence_post with (Q' := Q').
  assumption. assumption. assumption.  Qed.

(* Skip *)

(*
             --------------------  (hoare_skip)
             {{ P }} SKIP {{ P }}
*)

Theorem hoare_skip : forall P,
     {{P}} SKIP {{P}}.
Proof.
  intros P st st' H HP. inversion H. subst.
  assumption.  Qed.

(* Sequencing *)

(*
               {{ P }} c1 {{ Q }}
               {{ Q }} c2 {{ R }}
              ---------------------  (hoare_seq)
              {{ P }} c1;;c2 {{ R }}
*)

Theorem hoare_seq : forall P Q R c1 c2,
     {{Q}} c2 {{R}} ->
     {{P}} c1 {{Q}} ->
     {{P}} c1;;c2 {{R}}.
Proof.
  intros P Q R c1 c2 H1 H2 st st' H12 Pre.
  inversion H12; subst.
  apply (H1 st'0 st'); try assumption.
  apply (H2 st st'0); assumption. Qed.

(* Conditional *)

(*
              {{P /\  b}} c1 {{Q}}
              {{P /\ ~b}} c2 {{Q}}
      ------------------------------------  (hoare_if)
      {{P}} IFB b THEN c1 ELSE c2 FI {{Q}}
*)

Theorem hoare_if : forall P Q b c1 c2,
  {{fun st => P st /\ bassn b st}} c1 {{Q}} ->
  {{fun st => P st /\ ~(bassn b st)}} c2 {{Q}} ->
  {{P}} (IFB b THEN c1 ELSE c2 FI) {{Q}}.
Proof.
  intros P Q b c1 c2 HTrue HFalse st st' HE HP.
  inversion HE; subst.
  + (* "b is true" *)
    apply (HTrue st st').
      assumption.
      split. assumption.
             apply bexp_eval_true. assumption.
  + (* "b is false" *)
    apply (HFalse st st').
      assumption.
      split. assumption.
             apply bexp_eval_false. assumption. Qed.

(* While *)

(*
               {{P /\ b}} c {{P}}
        -----------------------------------  (hoare_while)
        {{P}} WHILE b DO c END {{P /\ ~b}}
    The proposition [P] is called an _invariant_ of the loop.
*)

Lemma hoare_while : forall P b c,
  {{fun st => P st /\ bassn b st}} c {{P}} ->
  {{P}} WHILE b DO c END {{fun st => P st /\ ~ (bassn b st)}}.
Proof.
  intros P b c Hhoare st st' He HP.
  (* Like we've seen before, we need to reason by induction
     on [He], because, in the "keep looping" case, its hypotheses
     talk about the whole loop instead of just [c]. *)
  remember (WHILE b DO c END) as wcom eqn:Heqwcom.
  induction He;
    try (inversion Heqwcom); subst; clear Heqwcom.
  + (* Case "E_WhileEnd" *)
    split. assumption. apply bexp_eval_false. assumption.
  + (* Case "E_WhileLoop" *)
    apply IHHe2. reflexivity.
    apply (Hhoare st st'). assumption.
      split. assumption. apply bexp_eval_true. assumption.
Qed.

Theorem hoare_loop : forall P Q c1 b c2,
  {{P}} c1 {{Q}} ->
  {{fun st => Q st /\ bassn b st}} c2 {{P}} ->
  {{P}} LOOP c1 WHILE b DO c2 END {{ fun st => Q st /\ ~(bassn b st)}}.
Proof.
    intros P Q c1 b c2 HTriple1 HTrue st st' HE HP.
    remember (LOOP c1 WHILE b DO c2 END) as wcom eqn:Heqwcom.
    induction HE;
    try (inversion Heqwcom); subst; clear Heqwcom.
    + split.
       - apply ( HTriple1 st st'). assumption. assumption.
       - apply bexp_eval_false. assumption.
    + apply IHHE3. reflexivity.
       apply (HTrue st'). assumption.
       split.
       - apply ( HTriple1 st st'). assumption. assumption.
       - apply bexp_eval_true. assumption.
Qed.

(* ********************************************** *)
(* Problem 3 *)
(* ********************************************** *)

(* Types *)

Inductive ty : Type :=
  | TBool  : ty
  | TArrow : ty -> ty -> ty
  | TNat : ty.
(* Terms *)

Inductive tm : Type :=
  | tvar : id -> tm
  | tapp : tm -> tm -> tm
  | tabs : id -> ty -> tm -> tm
  | ttrue : tm
  | tfalse : tm
  | tif : tm -> tm -> tm -> tm
  | tzero : tm
  | tsucc : tm -> tm
  | tncase : tm -> tm -> id -> tm -> tm.

(* Values *)

Inductive value : tm -> Prop :=
  | v_abs : forall x T t,
      value (tabs x T t)
  | v_true :
      value ttrue
  | v_false :
      value tfalse
  | v_succ : forall t,
      value t ->
      value (tsucc t)
  | v_zero :
       value tzero.

Hint Constructors value.

(* Substitution *)

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

Fixpoint subst (x:id) (s:tm) (t:tm) : tm :=
  match t with
  | tvar x' =>
      if beq_id x x' then s else t
  | tabs x' T t1 =>
      tabs x' T (if beq_id x x' then t1 else ([x:=s] t1))
  | tapp t1 t2 =>
      tapp ([x:=s] t1) ([x:=s] t2)
  | ttrue =>
      ttrue
  | tfalse =>
      tfalse
  | tif t1 t2 t3 =>
      tif ([x:=s] t1) ([x:=s] t2) ([x:=s] t3)
  | tsucc t =>
      tsucc ([x:=s] t)
   | tzero => tzero
   | tncase t1 t2 x' t3 =>
       tncase ([x:=s] t1)
         ([x:=s] t2)
          x' (if beq_id x x' then t3 else ([x:=s] t3))
  end

where "'[' x ':=' s ']' t" := (subst x s t).

(* Evaluation relation *)

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

Inductive step : tm -> tm -> Prop :=
  | ST_AppAbs : forall x T t12 v2,
         value v2 ->
         (tapp (tabs x T t12) v2) ==> [x:=v2]t12
  | ST_App1 : forall t1 t1' t2,
         t1 ==> t1' ->
         tapp t1 t2 ==> tapp t1' t2
  | ST_App2 : forall v1 t2 t2',
         value v1 ->
         t2 ==> t2' ->
         tapp v1 t2 ==> tapp v1  t2'
  | ST_IfTrue : forall t1 t2,
      (tif ttrue t1 t2) ==> t1
  | ST_IfFalse : forall t1 t2,
      (tif tfalse t1 t2) ==> t2
  | ST_If : forall t1 t1' t2 t3,
      t1 ==> t1' ->
      (tif t1 t2 t3) ==> (tif t1' t2 t3)
   | ST_Succ : forall t t',
       t ==> t' ->
      (tsucc t) ==> (tsucc t')
    | ST_Ncase : forall x t1 t1' t2 t3,
      t1 ==> t1' ->
      (tncase t1 t2 x t3) ==> (tncase t1' t2 x t3)
    | ST_NcaseZero : forall t2 t3 x,
       (tncase tzero t2 x t3) ==> t2
     | ST_NcaseSucc : forall x v1 t2 t3,
       value v1 ->
       (tncase (tsucc v1) t2 x t3) ==> [x:=v1] t3

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

Hint Constructors step.

Definition relation a := a -> a -> Prop.

Inductive multi {X:Type} (R: relation X) : relation X :=
  | multi_refl : forall (x : X), multi R x x
  | multi_step : forall (x y z : X),
                    R x y ->
                    multi R y z ->
                    multi R x z.

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

(* Contexts *)

Definition context := partial_map ty.

(* Typing relation *)

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

Inductive has_type : context -> tm -> ty -> Prop :=
  | T_Var : forall Gamma x T,
      Gamma x = Some T ->
      Gamma |- tvar x \in T
  | T_Abs : forall Gamma x T11 T12 t12,
      update Gamma x T11 |- t12 \in T12 ->
      Gamma |- tabs x T11 t12 \in TArrow T11 T12
  | T_App : forall T11 T12 Gamma t1 t2,
      Gamma |- t1 \in TArrow T11 T12 ->
      Gamma |- t2 \in T11 ->
      Gamma |- tapp t1 t2 \in T12
  | T_True : forall Gamma,
       Gamma |- ttrue \in TBool
  | T_False : forall Gamma,
       Gamma |- tfalse \in TBool
  | T_If : forall t1 t2 t3 T Gamma,
       Gamma |- t1 \in TBool ->
       Gamma |- t2 \in T ->
       Gamma |- t3 \in T ->
       Gamma |- tif t1 t2 t3 \in T
   | T_Zero : forall Gamma,
       Gamma |- tzero \in TNat
    | T_Succ : forall t Gamma,
         Gamma |- t \in TNat ->
         Gamma |- (tsucc t) \in TNat
     | T_Ncase : forall x t1 t2 t3 T Gamma,
          Gamma |- t1 \in TNat ->
          Gamma |- t2 \in T ->
         update Gamma x TNat |- t3 \in T ->
          Gamma |- (tncase t1 t2 x t3) \in T

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

Hint Constructors has_type.

(* Canonical Forms *)

Lemma cannonical_forms_bool : forall t,
  empty |- t \in TBool ->
  value t ->
  (t = ttrue) \/ (t = tfalse).
Proof.
  intros t HT HVal.
  inversion HVal; intros; subst; try inversion HT; auto.
Qed.

Lemma cannonical_forms_fun : forall t T1 T2,
  empty |- t \in (TArrow T1 T2) ->
  value t ->
  exists x u, t = tabs x T1 u.
Proof.
  intros t T1 T2 HT HVal.
  inversion HVal; intros; subst; try inversion HT; subst; auto.
  exists x. exists t0.  auto.
Qed.

(* Progress, by induction on type derivation *)

Theorem progress : forall t T,
     empty |- t \in T ->
     value t \/ exists t', t ==> t'.

Proof with eauto.
  intros t T Ht.
  remember (@empty ty) as Gamma.
  induction Ht; subst Gamma...
  + (* Case "T_Var" *)
    (* contradictory: variables cannot be typed in an
       empty context *)
    inversion H.

  + (* Case "T_App" *)
    (* [t] = [t1 t2].  Proceed by cases on whether [t1] is a
       value or steps... *)
    right. destruct IHHt1...
    - (* t1 is a value *)
      destruct IHHt2...
      * (* t2 is also a value *)
        assert (exists x0 t0, t1 = tabs x0 T11 t0).
        eapply cannonical_forms_fun; eauto.
        destruct H1 as [x0 [t0 Heq]]. subst.
        exists ([x0:=t2]t0)...

      * (* t2 steps *)
        inversion H0 as [t2' Hstp]. exists (tapp t1 t2')...

    - (* t1 steps *)
      inversion H as [t1' Hstp]. exists (tapp t1' t2)...

  + (* Case "T_If" *)
    right. destruct IHHt1...

    - (* t1 is a value *)
      destruct (cannonical_forms_bool t1); subst; eauto.

    - (* t1 also steps *)
      inversion H as [t1' Hstp]. exists (tif t1' t2 t3)...

    + destruct IHHt...
       right. inversion H as [t' Hstp]. exists(tsucc t')...

    + right. destruct IHHt1...
       - inversion H; subst; try solve by inversion...
       - inversion H as [t1' Hstp]. exists (tncase t1' t2 x t3)...
Qed.


(**********************************************************************
     Aux.v

     Auxillary functions & theorems for lists

                                    Laurent.Thery@inria.fr (2006)
  **********************************************************************)
Require Export List.
Require Export Arith.
Require Export Tactic.
Require Import Inverse_Image.
Require Import Wf_nat.

(**************************************
   Some properties on list operators: app, map,...
**************************************)

Section List.

Variables (A : Set) (B : Set) (C : Set).
Variable f : A ->  B.

Implicit Type l : list A.

(**************************************
  An induction theorem for list based on length
**************************************)

Theorem list_length_ind (P : list A ->  Prop) :
 (forall l1,
  (forall l2, length l2 < length l1 ->  P l2) ->  P l1) ->
 forall l,  P l.
Proof.
intros H l;
 apply well_founded_ind with (R := fun x y => length x < length y);
 auto.
apply wf_inverse_image with (R := lt); auto.
apply lt_wf.
Qed.

Definition list_length_induction (P : list A ->  Set) :
 (forall l1,
  (forall l2, length l2 < length l1 ->  P l2) ->  P l1) ->
 forall l,  P l.
Proof.
intros H l;
 apply well_founded_induction
      with (R := fun x y  => length x < length y ); auto.
apply wf_inverse_image with (R := lt); auto.
apply lt_wf.
Qed.

Theorem in_ex_app a l :
 In a l -> exists l1, exists l2 : list A , l = l1 ++ (a :: l2).
Proof.
elim l; clear l; simpl; auto.
intros H; case H.
intros a1 l H [H1|H1]; auto.
  exists (nil (A:=A)); exists l; simpl; auto.
  eq_tac; auto.
case H; auto; intros l1 [l2 Hl2]; exists (a1 :: l1); exists l2; simpl; auto.
eq_tac; auto.
Qed.

(**************************************
 Properties of nth
**************************************)

Theorem nth_nil n (a : A) : nth n nil a = a.
Proof.
elim n; simpl; auto.
Qed.

Theorem in_ex_nth (a b : A) l :
  In a l <-> exists n, n < length l /\ a = nth n l b.
Proof.
elim l; simpl; auto; clear l.
  split; [intros H; case H | intros (k, (H, _))];
  contradict H; auto with arith.
intros c l (Rec1, Rec2); split.
  intros [H1 | H1]; subst.
  exists 0; auto with arith.
  case Rec1; auto.
  intros n (H2, H3); exists (S n); auto with arith.
intros tmp; case tmp; clear tmp.
intros n; case n; auto.
  intros (H1, H2); auto.
intros n1 (H1, H2); right; apply Rec2.
exists n1; auto with arith.
Qed.

Theorem nth_app_l i r l1 l2 : i < length l1 -> nth i (l1 ++ l2) r = nth i l1 r.
Proof.
revert i l2; elim l1; simpl; auto; clear l1.
  intros i l2 H; contradict H; auto with arith.
intros a l Rec i; case i; simpl; auto with arith.
Qed.

Theorem nth_app_r i r l1 l2 : length l1 <= i -> nth i (l1 ++ l2) r = nth (i - length l1) l2 r.
Proof.
revert i l2; elim l1; simpl; auto; clear l1.
  intros; rewrite <- minus_n_O; auto.
  intros a l Rec i; case i; simpl; auto with arith.
intros l2 HH; contradict HH; auto with arith.
Qed.

Theorem nth_default i r l : length l <= i -> nth i l r = r.
Proof.
revert i; elim l; clear l; simpl; auto.
  intros i; case i; auto.
intros a l Rec i; case i; auto with arith.
intros HH; contradict HH; auto with arith.
Qed.

Theorem list_nth_eq r l1 l2 :
  length l1 = length l2 ->
  (forall n, nth n l1 r = nth n l2 r) -> l1 = l2.
Proof.
revert l2; elim l1; simpl; auto; clear l1.
  intros l2; case l2; clear l2; auto.
  intros b l2 H; discriminate.
intros a l1 Rec l2; case l2; auto; clear l2.
  intros H; discriminate.
intros b l2 H1 H2; eq_tac; auto; simpl in H1.
  apply (H2 0); auto.
apply Rec; auto with arith.
intros n; generalize (H2 (S n)); simpl; auto.
Qed.

(**************************************
 Properties on app
**************************************)

Theorem length_app l1 l2 : length (l1 ++ l2) = length l1 + length l2.
Proof.
elim l1; simpl; auto.
Qed.

Theorem app_inv_head l1 l2 l3 : l1 ++ l2 = l1 ++ l3 ->  l2 = l3.
Proof.
elim l1; simpl; auto.
intros a l H H0; apply H; injection H0; auto.
Qed.

Theorem app_inv_tail l1 l2 l3 : l2 ++ l1 = l3 ++ l1 ->  l2 = l3.
Proof.
revert l3; elim l2; simpl.
  intro l3; case l3; auto.
  intros b l H; absurd (length ((b :: l) ++ l1) <= length l1).
    simpl; rewrite length_app; auto with arith.
  rewrite <- H; auto with arith.
intros a l H l3; case l3.
  simpl; intros H1; absurd (length (a :: (l ++ l1)) <= length l1).
    simpl; rewrite length_app; auto with arith.
  rewrite H1; auto with arith.
simpl; intros b l0 H0; injection H0.
intros H1 H2; eq_tac; auto.
Qed.

Theorem app_inv_app l1 l2 l3 l4 a :
 l1 ++ l2 = l3 ++ (a :: l4) ->
  (exists l5 : list A , l1 = l3 ++ (a :: l5) ) \/
  (exists l5 , l2 = l5 ++ (a :: l4) ).
Proof.
revert l3; elim l1; simpl; auto.
  intros l3 H; right; exists l3; auto.
intros b l H l3; case l3; simpl.
  intros H0; left; exists l; eq_tac; injection H0; auto.
intros c l0 H0; case (H l0); auto.
  injection H0; auto.
intros [l5 H1].
left; exists l5; eq_tac; injection H0; auto.
Qed.

Theorem app_inv_app2 l1 l2 l3 l4 a b :
 l1 ++ l2 = l3 ++ (a :: (b :: l4)) ->
  (exists l5 : list A , l1 = l3 ++ (a :: (b :: l5)) ) \/
  ((exists l5 , l2 = l5 ++ (a :: (b :: l4)) ) \/
   l1 = l3 ++ (a :: nil) /\ l2 = b :: l4).
Proof.
revert l3; elim l1; simpl; auto.
  intros l3 H; right; left; exists l3; auto.
intros a1 l H l3; case l3; simpl.
  case l; simpl.
    intros H0; right; right; injection H0; split; auto.
    eq_tac; auto.
  intros b0 l0 H0; left; exists l0; injection H0; intros; (repeat eq_tac); auto.
intros b0 l0 H0; case (H l0); auto.
- injection H0; auto.
- intros [l5 HH1]; left; exists l5; eq_tac; auto; injection H0; auto.
- intros [H1|[H1 H2]]; auto.
  right; right; split; auto; eq_tac; auto; injection H0; auto.
Qed.

Theorem same_length_ex a l1 l2 (l3 : list B) :
 length (l1 ++ (a :: l2)) = length l3 ->
  (exists (l4 : list B),
   exists (l5 : list B) ,
   exists b : B ,
   length l1 = length l4 /\ (length l2 = length l5 /\ l3 = l4 ++ (b :: l5))   ).
Proof.
revert l3; elim l1; simpl; auto.
  intro l3; case l3; simpl; (try (intros; discriminate)).
  intros b l H; exists (nil (A:=B)); exists l; exists b; (repeat (split; auto)).
intros a0 l H l3; case l3; simpl; (try (intros; discriminate)).
intros b l0 H0.
case (H l0); auto.
intros l4 [l5 [b1 [HH1 [HH2 HH3]]]].
exists (b :: l4); exists l5; exists b1; (repeat (simpl; split; auto)).
eq_tac; auto.
Qed.

(**************************************
  Properties on map
**************************************)

Theorem in_map_inv (b : B) l :
 In b (map f l) ->  (exists a : A , In a l /\ b = f a ).
Proof.
elim l; simpl; auto.
  intros tmp; case tmp.
intros a0 l0 H [H1|H1]; auto.
  exists a0; auto.
case (H H1); intros a1 [H2 H3]; exists a1; auto.
Qed.

Theorem in_map_fst_inv a (l : list (B * C)) :
 In a (map (fst (B:=_)) l) ->  (exists c , In (a, c) l ).
Proof.
elim l; simpl; auto.
  intros H; case H.
intros a0 l0 H [H0|H0]; auto.
exists (snd a0); left; rewrite <- H0; case a0; simpl; auto.
case H; auto; intros l1 Hl1; exists l1; auto.
Qed.

Theorem length_map l :  length (map f l) = length l.
Proof.
elim l; simpl; auto.
Qed.

Theorem map_app l1 l2 :  map f (l1 ++ l2) = map f l1 ++ map f l2.
Proof.
elim l1; simpl; auto.
intros a l0 H; eq_tac; auto.
Qed.

Theorem map_length_decompose l1 (l2 : list B) l3 (l4 : list B) :
 length l1 = length l2 ->
 map f (app l1 l3) = app l2 l4 ->  map f l1 = l2 /\ map f l3 = l4.
Proof.
revert l2; elim l1; simpl; auto; clear l1.
  intros l2; case l2; simpl; auto.
  intros; discriminate.
intros a l1 Rec l2; case l2; simpl; clear l2; auto.
  intros; discriminate.
intros b l2 H1 H2.
injection H2; clear H2; intros H2 H3.
case (Rec l2); auto.
intros H4 H5; split; auto.
eq_tac; auto.
Qed.

(**************************************
  Properties of flat_map
**************************************)

Theorem in_flat_map (l : list B) (f1 : B ->  list C) a b :
 In a (f1 b) -> In b l ->  In a (flat_map f1 l).
Proof.
elim l; simpl; auto.
intros a0 l0 H H0 [H1|H1]; apply in_or_app; auto.
left; rewrite H1; auto.
Qed.

Theorem in_flat_map_ex (l : list B) (f1 : B ->  list C) a :
 In a (flat_map f1 l) -> exists b , In b l /\ In a (f1 b).
Proof.
elim l; simpl; auto.
  intros H; case H.
intros a0 l0 H H0; case in_app_or with ( 1 := H0 ); simpl; auto.
  intros H1; exists a0; auto.
intros H1; case H with ( 1 := H1 ).
intros b [H2 H3]; exists b; simpl; auto.
Qed.

End List.

(**************************************
  Propertie of list_prod
**************************************)

Theorem length_list_prod (A : Set) (l1 l2 : list A) :
  length (list_prod l1 l2) = length l1 * length l2.
Proof.
elim l1; simpl; auto.
intros a l H; rewrite length_app; rewrite length_map; rewrite H; auto.
Qed.

Theorem in_list_prod_inv (A B : Set) a l1 l2 :
 In a (list_prod l1 l2) ->
  (exists b : A , exists c : B , a = (b, c) /\ (In b l1 /\ In c l2)  ).
Proof.
elim l1; simpl; auto; clear l1.
intros H; case H.
intros a1 l1 H1 H2.
case in_app_or with ( 1 := H2 ); intros H3; auto.
  case in_map_inv with ( 1 := H3 ); intros b1 [Hb1 Hb2]; auto.
  exists a1; exists b1; split; auto.
case H1; auto; intros b1 [c1 [Hb1 [Hb2 Hb3]]].
exists b1; exists c1; split; auto.
Qed.

Definition list_eq_dec (A : Set) :
       (forall x y : A, {x = y} + {x <> y}) ->
       forall x y : list A, {x = y} + {x <> y}.
Proof.
intros dec; fix list_eq_dec 2; intros x y; case x; case y.
- left; auto.
- intros; right; discriminate.
- intros; right; discriminate.
- intros b y1 a x1.
  case (dec a b); intros H.
  case (list_eq_dec x1 y1); intros H1.
  left; apply f_equal2 with (f := @cons A); auto.
  intros; right; contradict H1; injection H1; auto.
  intros; right; contradict H; injection H; auto.
Defined.

Arguments list_eq_dec [A].

Definition In_dec (A : Set) :
       (forall x y : A, {x = y} + {x <> y}) ->
       forall (a : A) (l : list A), {In a l} + {~ In a l}.
Proof.
intros dec; fix In_dec 2; intros a l; case l.
  right; simpl; intros H; case H.
intros b l1.
case (In_dec a l1); intros H1.
  left; auto with datatypes.
case (dec a b); intros H2.
left; subst; auto with datatypes.
right; simpl; intros [H3|H3]; auto.
Defined.

Arguments In_dec [A].

Definition In_dec1 (A : Set) :
 (forall x y : A, {x = y} + {x <> y}) ->
 forall (a : A) (l : list A),
   {ll : list A * list A| l = fst ll ++ (a :: snd ll)} + {~ In a l}.
Proof.
intros dec; fix In_dec1 2; intros a l; case l.
right; simpl; intros tmp; case tmp.
  intros b l1; case (In_dec1 a l1); intros H.
  left; case H; intros ll HH; exists ((b :: fst ll), snd ll).
  rewrite HH; auto with datatypes.
case (dec a b); intros H1.
left; exists (@nil A, l1); subst; auto.
right; simpl; intros [H2 | H2]; auto.
Defined.

Arguments In_dec1 [A].

Theorem in_fold_map (A : Set) (f : nat -> nat -> A) p l1 l2 :
  In p
    (fold_right
       (fun x l =>
          map (f x) l1 ++ l) nil l2) <->
    (exists x, (exists y , In x l2 /\ In y l1 /\ p = f x y)).
Proof.
elim l2; simpl; auto; clear l2.
  split; auto.
    intros H; case H.
  intros (x, (y, (H, _))); auto.
intros a l2 (Rec1, Rec2); split; intros H.
  case in_app_or with (1 := H); clear H; intros H.
    case (in_map_inv _ _ (f a) p l1); auto.
    intros y (H1, H2).
    exists a; exists y; repeat split; auto.
  case Rec1; auto; clear Rec1 Rec2.
  intros x (y, (U1, (U2, U3))); exists x; exists y; repeat split;
  auto with arith.
case H; intros x (y, ([U1 | U1], (U2, U3))); subst; auto; clear H.
  apply in_or_app; left; auto.
  apply in_map; auto.
apply in_or_app; right; auto.
apply Rec2; auto; clear Rec1 Rec2.
exists x; exists y; repeat split; auto with arith.
Qed.


(* Exercise 086 *)

Require Import BenB.

Variable D : Set.
Variables P Q S T : D -> Prop.
Variable R : D -> D -> Prop.

Theorem exercise_001 : (forall x:D, P x -> exists y : D, P y).
Proof.
all_i a.
imp_i a1.
exi_i a.
hyp a1.
Qed.