Set Warnings "-notation-overridden,-parsing".
From LF Require Export Logic.
From Coq Require Export Lia.

Fixpoint div2(n:nat):=
  match n with
    0 => 0
  | 1 => 0
  | S (S n) => S (div2 n)
  end.

Definition f(n:nat):=
  if even n then div2 n
  else (3 * n) + 1.

Inductive reaches_1: nat -> Prop :=
  | term_done: reaches_1 1
  | term_more (n:nat) : reaches_1 (f n) -> reaches_1 n.

Conjecture collatz: forall n, reaches_1 n.

Module LePlayground.

Inductive le:nat->nat->Prop:=
  | le_n (n : nat) : le n n
  | le_S (n m : nat) : le n m -> le n (S m).
End LePlayground.

Inductive clos_trans {X: Type} (R: X->X->Prop):X->X->Prop:=
  | t_step (x y: X): R x y -> clos_trans R x y
  | t_trans (x y z: X):
    clos_trans R x y ->
    clos_trans R y z ->
    clos_trans R x z.

Inductive clos_reflex_trans {X: Type} (R: X->X->Prop):X->X->Prop:=
  | t_step' (x y: X): R x y -> clos_reflex_trans R x y
  | t_reflex' (x: X): clos_reflex_trans R x x
  | t_trans' (x y z: X):
    clos_reflex_trans R x y ->
    clos_reflex_trans R y z ->
    clos_reflex_trans R x z.

Inductive clos_reflex_symm_trans {X: Type} (R: X->X->Prop):X->X->Prop:=
  | t_step'' (x y: X): R x y -> clos_reflex_symm_trans R x y
  | t_reflex'' (x: X): clos_reflex_symm_trans R x x
  | t_symm'' (x y: X): R x y -> clos_reflex_symm_trans R y x
  | t_trans'' (x y z: X):
    clos_reflex_symm_trans R x y ->
    clos_reflex_symm_trans R y z ->
    clos_reflex_symm_trans R x z.

Inductive Perm3 {X:Type}: list X -> list X -> Prop :=
| perm3_swap12 (a b c:X):
  Perm3 [a;b;c] [b;a;c]
| perm3_swap23 (a b c:X):
  Perm3 [a;b;c] [a;c;b]
| perm3_trans (l1 l2 l3: list X):
  Perm3 l1 l2 -> Perm3 l2 l3 -> Perm3 l1 l3.

(* Evenness (yet again) *)

Inductive ev:nat -> Prop :=
 | ev_0 : ev 0
 | ev_SS (n:nat) (H:ev n): ev (S (S n)).

Theorem ev_double: forall n,
  ev (double n).
Proof.
  induction n. simpl. apply ev_0.
  simpl. apply ev_SS. apply IHn.
Qed.

Theorem ev_inversion: forall n:nat,
  ev n ->
  (n = 0) \/ (exists n', n = S (S n') /\ ev n').
Proof.
  intros n E. destruct E.
  - left. reflexivity.
  - right. exists n. split. reflexivity. apply E.
Qed.

Theorem evSS_ev:forall n, ev (S (S n)) -> ev n.
Proof.
  intros n H. apply ev_inversion in H. destruct H as [H0|H1].
  - discriminate H0.
  - destruct H1 as [n' [Hnm Hev]]. injection Hnm as Heq. rewrite Heq. apply Hev.
Qed.

Theorem evSS_ev': forall n,
  ev (S (S n)) -> ev n.
Proof.
  intros n E. inversion E as [|n' E' Heq]. apply E'.
Qed.

Theorem one_not_even: ~ ev 1.
Proof.
  intros H. apply ev_inversion in H. destruct H as [|[m [Hm _]]].
  - discriminate H.
  - discriminate Hm.
Qed.

Theorem one_not_even': ~ ev 1.
Proof.
  intros H. inversion H.
Qed.

Theorem SSSSev__even:forall n,
  ev (S (S (S (S n)))) -> ev n.
Proof.
  intros. inversion H. inversion H1. apply H3.
Qed.

Theorem ev5_nonsense:
  ev 5 -> 2 + 2 = 9.
Proof.
  intros. inversion H. inversion H1. inversion H3.
Qed.

Theorem inversion_ex1:forall n m o:nat,
  [n; m] = [o; o] -> [n] = [m].
Proof.
  intros n m o H. inversion H. reflexivity.
Qed.

Theorem inversion_ex2:forall n:nat,
  S n = O -> 2 + 2 = 5.
Proof.
  intros. inversion H.
Qed.

Lemma ev_Even:forall n,
  ev n -> Even n.
Proof.
  intros n E.
  induction E as [|n' E' IH].
  - unfold Even. exists 0. reflexivity.
  - unfold Even in IH.
    destruct IH as [k Hk].
    rewrite Hk.
    unfold Even. exists (S k). reflexivity.
Qed.

Theorem ev_Even_iff: forall n,
  ev n <-> Even n.
Proof.
  intros n. split.
  - apply ev_Even.
  - unfold Even. intros [k Hk]. rewrite Hk. apply ev_double.
Qed.

Theorem ev_sum: forall n m, ev n -> ev m -> ev (n + m).
Proof.
  intros n m Hn Hm. induction Hn.
  - apply Hm.
  - replace (S (S n) + m) with (S (S (n + m))).
    + apply ev_SS. apply IHHn.
    + reflexivity.
Qed.

Inductive ev':nat->Prop:=
  | ev'_0:ev' 0
  | ev'_2:ev' 2
  | ev'_sum n m (Hn: ev' n) (Hm : ev' m) : ev' (n + m).

Theorem ev'_ev:forall n, ev' n <-> ev n.
Proof.
  induction n. split. intros. apply ev_0. intros. apply ev'_0. split.
  - intros. induction H. apply ev_0. apply (ev_SS 0 ev_0).
    apply (ev_sum n0 m IHev'1 IHev'2).
  - intros. induction H. apply ev'_0. apply (ev'_sum 2 n0 ev'_2 IHev).
Qed.

Theorem ev_ev__ev:forall n m,
  ev (n+m) -> ev n -> ev m.
Proof.
  intros n m Hnm Hn. induction Hn. apply Hnm.
  inversion Hnm. apply (IHHn H0).
Qed.

Theorem ev_plus_plus:forall n m p,
  ev(n+m) -> ev(n+p) -> ev(m+p).
Proof.
  intros n m p Hnm Hnp.
  assert (ev ((n+m)+(n+p))). apply (ev_sum (n+m) (n+p) Hnm Hnp).
  replace (n+m+(n+p)) with (n+n+(m+p)) in H.
  assert (ev (n+n)). { rewrite <- (double_plus n). apply ev_double. }
  apply (ev_ev__ev (n+n) (m+p) H H0).
  rewrite add_assoc. rewrite add_assoc. replace (n+n+m) with (n+m+n).
  reflexivity. rewrite add_comm. rewrite add_assoc. reflexivity.
Qed.

(* Inductive Relations *)

Module Playground.

Inductive le:nat->nat->Prop:=
|le_n(n:nat):le n n
|le_S(n m:nat) (H:le n m): le n (S m).
Notation "n <= m" := (le n m).

Theorem test_le1: 3<=3. Proof. apply le_n. Qed.
Theorem test_le2: 3<=6. Proof. apply le_S. apply le_S. apply le_S. apply le_n.
Qed.
Theorem test_le3:(2<=1)->2+2=5. Proof. intros H. inversion H. inversion H2. Qed.

Definition lt (n m:nat) := le (S n) m.
Notation "m < n" := (lt m n).
End Playground.

Inductive total_relation:nat->nat->Prop:=
  total_r n m: total_relation n m.

Theorem total_relation_is_total:forall n m, total_relation n m.
Proof. intros. apply (total_r n m). Qed.

Inductive empty_relation:nat->nat->Prop:=.
Theorem empty_relation_is_empty: forall n m, ~ empty_relation n m.
Proof. intros n m H. inversion H. Qed.

Lemma le_trans: forall m n o, m<=n -> n <= o -> m <= o.
Proof.
  intros m n o Hmn Hno. induction Hno. apply Hmn. apply (le_S m m0 IHHno).
Qed.

Theorem O_le_n:forall n, 0 <= n.
Proof.
    induction n. apply le_n. apply le_S. apply IHn.
Qed.

Theorem n_le_m__Sn_le_Sm:forall n m, n <= m -> S n <= S m.
Proof.
  intros n m H. induction H. apply le_n. apply le_S. apply IHle.
Qed.

Theorem Sn_le_Sm__n_le_m:forall n m, S n <= S m -> n <= m.
Proof.
  intros n m H. inversion H. apply le_n. assert (n <= S n).
  - apply le_S. apply le_n.
  - apply (le_trans _ _ _ H2 H1).
Qed.

Theorem lt_ge_cases: forall n m, n<m \/ n>=m.
Proof.
  unfold lt. unfold ge.
  induction n. induction m. right. apply le_n. left. apply n_le_m__Sn_le_Sm.
  apply O_le_n.
  induction m. right. apply O_le_n. destruct (IHn m).
  - left. apply (n_le_m__Sn_le_Sm _ _ H).
  - right. apply (n_le_m__Sn_le_Sm _ _ H).
Qed.

Theorem le_plus_l: forall a b, a <= a + b.
Proof.
  induction a. intros. apply O_le_n.
  intros b. apply (n_le_m__Sn_le_Sm _ _ (IHa b)).
Qed.

Theorem plus_le: forall n1 n2 m,
  n1 + n2 <= m -> n1 <= m /\ n2 <= m.
Proof.
  induction n1. intros. split. apply O_le_n. apply H.
  induction n2. intros. split. rewrite add_comm in H. apply H. apply O_le_n.
  intros. inversion H. split. apply le_plus_l. rewrite add_comm. apply
  le_plus_l.
  split. apply n_le_m__Sn_le_Sm. assert (n1 <= S n1 + S n2). replace (S n1) with
  (n1 + 1). rewrite <- add_assoc. apply le_plus_l. apply add_comm.
  apply (le_trans _ _ _ H2 H0).
  assert (n2 <= S n1 + S n2). replace (S n2) with (n2 + 1). rewrite add_assoc.
  replace (S n1 + n2) with (n2 + S n1). rewrite <- add_assoc. apply le_plus_l.
  apply add_comm. apply add_comm.
  apply n_le_m__Sn_le_Sm. apply (le_trans _ _ _ H2 H0).
Qed.

Theorem add_le_cases: forall n m p q,
  n + m <= p + q -> n <= p \/ m <= q.
Proof.
  induction n. intros. left. apply O_le_n.
  intros. destruct p.
  - rewrite add_comm in H. simpl in H. assert (m <= m + S n). { apply le_plus_l.
  } right. apply (le_trans _ _ _ H0 H).
  - rewrite plus_Sn_m in H. rewrite plus_Sn_m in H. apply Sn_le_Sm__n_le_m in H.
  apply IHn in H. destruct H. left. apply n_le_m__Sn_le_Sm. apply H.
  right. apply H.
Qed.

Theorem plus_le_compat_l: forall n m p,
  n <= m -> p + n <= p + m.
Proof.
  induction p.
  - intros. apply H.
  - intros. rewrite plus_Sn_m. rewrite plus_Sn_m. apply n_le_m__Sn_le_Sm. apply
  (IHp H).
Qed.

Theorem plus_le_compat_r: forall n m p,
  n <= m -> n + p <= m + p.
Proof.
  intros. rewrite add_comm. replace (m + p) with (p + m). apply
  plus_le_compat_l. apply H. apply add_comm.
Qed.

Theorem le_plus_trans: forall n m p,
  n <= m -> n <= m + p.
Proof.
  intros. assert (m <= m + p). replace m with (m + 0). rewrite <- add_assoc.
  apply plus_le_compat_l. simpl. apply O_le_n. apply add_comm. apply (le_trans _
_  _ H H0).
Qed.

Theorem n_lt_m__n_le_m: forall n m,
  n < m -> n <= m.
Proof.
  unfold lt. intros. assert (n <= S n). apply le_S. apply le_n. apply (le_trans
  _ _ _ H0 H).
Qed.

Theorem plus_lt: forall n1 n2 m,
  n1 + n2 < m -> n1 < m /\ n2 < m.
Proof.
  unfold lt. intros. destruct m. inversion H. apply Sn_le_Sm__n_le_m in H.
  apply plus_le in H. destruct H. split. apply n_le_m__Sn_le_Sm. apply H. apply
  n_le_m__Sn_le_Sm. apply H0.
Qed.

Theorem leb_complete: forall n m,
  n <=? m = true -> n <= m.
Proof.
  induction n. intros. apply O_le_n. intros. destruct m. discriminate H. simpl
  in H. apply n_le_m__Sn_le_Sm. apply IHn, H.
Qed.

Theorem leb_correct: forall n m,
  n <= m -> n <=? m = true.
Proof.
  induction n.
  - intros. simpl. reflexivity.
  - induction m. intros. inversion H. intros. apply Sn_le_Sm__n_le_m in H. apply
  IHn in H. simpl. apply H.
Qed.

Theorem leb_iff: forall n m,
  n <=? m = true <-> n <= m.
Proof.
  split. apply leb_complete. apply leb_correct.
Qed.

Theorem leb_true_trans: forall n m o,
  n <=? m = true -> m <=? o = true -> n <=? o = true.
Proof.
  intros. rewrite leb_iff in H. rewrite leb_iff in H0. rewrite leb_iff. apply
  (le_trans _ _ _ H H0).
Qed.

Module R.
  Inductive R: nat -> nat -> nat -> Prop :=
  | c1 : R 0 0 0
  | c2 m n o (H: R m n o): R (S m) n (S o)
  | c3 m n o (H: R m n o): R m (S n) (S o)
  | c4 m n o (H: R (S m) (S n) (S (S o))): R m n o
  | c5 m n o (H: R m n o): R n m o
  .
  Definition fR (n:nat) (m:nat): nat := n + m.
  Theorem R_equiv_fR: forall n m o, R m n o <-> fR m n = o.
  Proof.
    unfold fR.
    split.
    - intros H. induction H.
      + reflexivity.
      + rewrite plus_Sn_m. rewrite IHR. reflexivity.
      + rewrite <- plus_n_Sm. rewrite IHR. reflexivity.
      + rewrite plus_Sn_m in IHR. injection IHR as IHR. rewrite <- plus_n_Sm in
    IHR. injection IHR as IHR. apply IHR.
      + rewrite add_comm. apply IHR.
    - generalize dependent m. generalize dependent n. induction o. intros. assert (m+n <= 0). replace (m+n) with 0. apply le_n.
    apply plus_le in H0. destruct H0. inversion H0. inversion H1. apply c1.
      + intros. destruct m. simpl in H. rewrite H. apply c3. apply IHo.
      reflexivity.
        apply c2. apply IHo. rewrite plus_Sn_m in H. injection H as H. apply H.
  Qed.
End R.

Inductive subseq : list nat -> list nat -> Prop :=
  | subseq0: subseq [] []
  | subseq1 (x: nat) (l1 l2: list nat) (H: subseq l1 l2): subseq l1 (x::l2)
  | subseq2 (x: nat) (l1 l2: list nat) (H: subseq l1 l2): subseq (x::l1) (x::l2)
.

Theorem subseq_refl: forall (l : list nat), subseq l l.
Proof.
  induction l.
  - apply subseq0.
  - apply (subseq2 x l l IHl).
Qed.

Lemma subseq_nil: forall l: list nat,
  subseq [] l.
Proof.
  induction l. apply subseq0. apply (subseq1 _ _ _ IHl).
Qed.

Theorem subseq_app: forall l1 l2 l3: list nat,
  subseq l1 l2 -> subseq l1 (l2 ++ l3).
Proof.
  induction l1.
  - intros. apply subseq_nil.
  - intros. induction H. apply subseq_nil. simpl. apply subseq1. apply IHsubseq.
    simpl. apply subseq2. apply IHsubseq.
Qed.

Theorem subseq_trans: forall (l1 l2 l3: list nat),
  subseq l1 l2 -> subseq l2 l3 -> subseq l1 l3.
Proof.
  intros. generalize dependent l1. induction H0. intros. apply H.
  - intros. apply IHsubseq in H. apply (subseq1 _ _ _ H).
  - intros. inversion H. apply subseq1. apply IHsubseq. apply H3.
    apply subseq2. apply IHsubseq. apply H3.
Qed.

(* A Digression on Notation *)

Inductive reg_exp (T : Type) : Type :=
  | EmptySet
  | EmptyStr
  | Char (t : T)
  | App (r1 r2 : reg_exp T)
  | Union (r1 r2 : reg_exp T)
  | Star (r : reg_exp T).
Arguments EmptySet {T}.
Arguments EmptyStr {T}.
Arguments Char {T} _.
Arguments App {T} _ _.
Arguments Union {T} _ _.
Arguments Star {T} _.

Reserved Notation "s =~ re" (at level 80).

Inductive exp_match {T} : list T -> reg_exp T -> Prop :=
  | MEmpty : [] =~ EmptyStr
  | MChar x : [x] =~ (Char x)
  | MApp s1 re1 s2 re2
             (H1 : s1 =~ re1)
             (H2 : s2 =~ re2)
           : (s1 ++ s2) =~ (App re1 re2)
  | MUnionL s1 re1 re2
                (H1 : s1 =~ re1)
              : s1 =~ (Union re1 re2)
  | MUnionR re1 s2 re2
                (H2 : s2 =~ re2)
              : s2 =~ (Union re1 re2)
  | MStar0 re : [] =~ (Star re)
  | MStarApp s1 s2 re
                 (H1 : s1 =~ re)
                 (H2 : s2 =~ (Star re))
               : (s1 ++ s2) =~ (Star re)

  where "s =~ re" := (exp_match s re).

Example reg_exp_ex1: [1] =~ Char 1.
Proof.
  apply MChar.
Qed.

Example reg_exp_ex2: [1; 2] =~ App (Char 1) (Char 2).
Proof.
  apply (MApp [1]). apply MChar. apply MChar.
Qed.

Example reg_exp_ex3: ~([1;2] =~ Char 1).
Proof.
  intros H. inversion H.
Qed.

Fixpoint reg_exp_of_list {T} (l : list T) :=
  match l with
  | [] => EmptyStr
  | x :: l' => App (Char x) (reg_exp_of_list l')
  end.
Example reg_exp_ex4 : [1; 2; 3] =~ reg_exp_of_list [1; 2; 3].
Proof.
  simpl. apply (MApp [1]). apply MChar. apply (MApp [2]). apply MChar.
  apply (MApp [3]). apply MChar. apply MEmpty.
Qed.

Lemma MStar1: forall T s (re:reg_exp T),
  s =~ re -> s =~ Star re.
Proof.
  intros. rewrite <- (app_nil_r _ s). apply MStarApp. apply H. apply MStar0.
Qed.

Lemma empty_is_empty: forall T (s: list T),
  ~ (s =~ EmptySet).
Proof.
  intros T s H. inversion H.
Qed.

Lemma MUnion': forall T (s: list T) (re1 re2: reg_exp T),
  s =~ re1 \/ s =~ re2 -> s =~ Union re1 re2.
Proof.
  intros T s re1 re2 H. destruct H.
  - apply MUnionL. apply H.
  - apply MUnionR. apply H.
Qed.

Lemma MStar': forall T (ss: list (list T)) (re: reg_exp T),
  (forall s, In s ss -> s =~ re) -> fold app ss [] =~ Star re.
Proof.
  intros T. induction ss.
  - intros. simpl. apply MStar0.
  - intros. simpl. apply (MStarApp x).
    + apply H. left. reflexivity.
    + apply IHss. intros. apply H. right. apply H0.
Qed.

Fixpoint re_chars {T} (re : reg_exp T) : list T :=
  match re with
  | EmptySet => []
  | EmptyStr => []
  | Char x => [x]
  | App re1 re2 => re_chars re1 ++ re_chars re2
  | Union re1 re2 => re_chars re1 ++ re_chars re2
  | Star re => re_chars re
  end.

Theorem in_re_match : forall T (s : list T) (re : reg_exp T) (x : T),
  s =~ re ->
  In x s ->
  In x (re_chars re).
Proof.
  intros T s re x Hmatch Hin.
  induction Hmatch
    as [| x'
        | s1 re1 s2 re2 Hmatch1 IH1 Hmatch2 IH2
        | s1 re1 re2 Hmatch IH | re1 s2 re2 Hmatch IH
        | re | s1 s2 re Hmatch1 IH1 Hmatch2 IH2].
  (* WORKED IN CLASS *)
  - (* MEmpty *)
    simpl in Hin. destruct Hin.
  - (* MChar *)
    simpl. simpl in Hin.
    apply Hin.
  - (* MApp *)
    simpl. rewrite In_app_iff. rewrite In_app_iff in Hin.
    destruct Hin as [Hin | Hin].
    + (* In x s1 *)
      left. apply (IH1 Hin).
    + (* In x s2 *)
      right. apply (IH2 Hin).
  - (* MUnionL *)
    simpl. rewrite In_app_iff.
    left. apply (IH Hin).
  - (* MUnionR *)
    simpl. rewrite In_app_iff.
    right. apply (IH Hin).
  - (* MStar0 *)
    destruct Hin.
  - (* MStarApp *)
    simpl. rewrite In_app_iff in Hin.
    destruct Hin as [Hin | Hin].
    + (* In x s1 *)
      apply (IH1 Hin).
    + (* In x s2 *)
      apply (IH2 Hin).
Qed.

Fixpoint re_not_empty {T: Type} (re: reg_exp T): bool :=
  match re with
  | EmptySet => false
  | EmptyStr => true
  | Char x => true
  | App re1 re2 => (re_not_empty re1) && (re_not_empty re2)
  | Union re1 re2 => re_not_empty re1 || re_not_empty re2
  | Star re => true
  end.

Lemma re_not_empty_correct: forall T (re: reg_exp T),
  (exists s, s =~ re) <-> re_not_empty re = true.
Proof.
  intros T. split; induction re; intros.
  - inversion H. inversion H0.
  - inversion H. simpl. reflexivity.
  - inversion H. simpl. reflexivity.
  - inversion H. simpl. inversion H0. rewrite andb_true_iff. split.
    + apply IHre1. exists s1. apply H4.
    + apply IHre2. exists s2. apply H5.
  - inversion H. simpl. rewrite orb_true_iff. inversion H0.
    + left. apply IHre1. exists x. apply H3.
    + right. apply IHre2. exists x. apply H3.
  - simpl. reflexivity.
  - inversion H.
  - exists []. apply MEmpty.
  - exists [t]. apply MChar.
  - simpl in H. apply andb_true_iff in H. destruct H. apply IHre1 in H. apply
  IHre2 in H0. inversion H. inversion H0. exists (x ++ x0). apply (MApp x).
  apply H1. apply H2.
  - simpl in H. apply orb_true_iff in H. destruct H.
    + apply IHre1 in H. inversion H. exists x. apply MUnionL. apply H0.
    + apply IHre2 in H. inversion H. exists x. apply MUnionR. apply H0.
  - exists []. apply MStar0.
Qed.

Lemma star_app: forall T (s1 s2: list T) (re: reg_exp T),
  s1 =~ Star re ->
  s2 =~ Star re ->
  s1 ++ s2 =~ Star re.
Proof.
  intros T s1 s2 re H1.
  remember (Star re) as re'.
  generalize dependent s2.
  induction H1.
  - discriminate.
  - discriminate.
  - discriminate.
  - discriminate.
  - discriminate.
  - injection Heqre' as Heqre''. intros. apply H.
  - injection Heqre' as Heqre''. intros. rewrite <- app_assoc.
    apply MStarApp. apply H1_. apply IHexp_match2. rewrite Heqre''. reflexivity.
    apply H.
Qed.

Lemma MStar'': forall T (s: list T) (re: reg_exp T),
  s =~ Star re ->
  exists ss: list (list T), s = fold app ss [] /\ forall s', In s' ss -> s' =~ re.
Proof.
  intros. remember (Star re) as re'. induction H.
  - discriminate.
  - discriminate.
  - discriminate.
  - discriminate.
  - discriminate.
  - exists []. split. reflexivity. intros. destruct H.
  - apply IHexp_match2 in Heqre' as Heqre''. inversion Heqre''. exists (s1::x). split.
  destruct H1. simpl. rewrite H1. reflexivity. intros. simpl in H2. injection
  Heqre' as Heqre'. destruct H2. rewrite <- H2. rewrite <- Heqre'. apply H.
  destruct H1. apply H3. apply H2.
Qed.

Module Pumping.

Fixpoint pumping_constant {T} (re: reg_exp T): nat :=
  match re with
  | EmptySet => 1
  | EmptyStr => 1
  | Char _ => 2
  | App re1 re2 => pumping_constant re1 + pumping_constant re2
  | Union re1 re2 => pumping_constant re1 + pumping_constant re2
  | Star r => pumping_constant r
  end.

Lemma pumping_constant_ge_1: forall T (re: reg_exp T), pumping_constant re >= 1.
Proof.
  intros. induction re.
  - apply le_n.
  - apply le_n.
  - apply le_S. apply le_n.
  - simpl. apply le_trans with (n := pumping_constant re1). apply IHre1. apply le_plus_l.
  - simpl. apply le_trans with (n := pumping_constant re1). apply IHre1. apply
  le_plus_l.
  - simpl. apply IHre.
Qed.

Lemma pumping_consant_0_false: forall T (re: reg_exp T), pumping_constant re = 0
-> False.
Proof.
  intros. assert (pumping_constant re >= 1). apply pumping_constant_ge_1.
  inversion H0. rewrite <- H2 in H. discriminate H. rewrite <- H1 in H.
  discriminate H.
Qed.

Fixpoint napp {T} (n: nat) (l: list T): list T :=
  match n with
  | 0 => []
  | S n' => l ++ napp n' l
end.

Lemma napp_star:
  forall T m s1 s2 (re: reg_exp T), s1 =~ re -> s2 =~ Star re -> napp m s1 ++ s2
  =~ Star re.
Proof.
  intros T. induction m. intros.
  - simpl. apply H0.
  - intros. simpl. rewrite <- app_assoc. apply MStarApp. apply H. apply IHm.
  apply H. apply H0.
Qed.

Lemma weak_pumping: forall T (re: reg_exp T) s,
  s =~ re -> pumping_constant re <= length s -> exists s1 s2 s3,
    s = s1 ++ s2 ++ s3 /\ s2 <> [] /\ forall m, s1 ++ napp m s2 ++ s3 =~ re.
Proof.
  intros T re s Hmatch.
  induction Hmatch.
  - simpl. intros contra. inversion contra.
  - simpl. intros contra. inversion contra. inversion H0.
  - simpl. intros. rewrite app_length in H. apply add_le_cases in H. destruct H.
    + apply IHHmatch1 in H. destruct H. destruct H. destruct H. destruct H.
    destruct H0. exists x. exists x0. exists (x1 ++ s2). split.
      * rewrite H. rewrite <- app_assoc. rewrite <- app_assoc. reflexivity.
      * split. apply H0. intros. rewrite app_assoc. rewrite app_assoc. apply
      MApp. rewrite <- app_assoc. apply H1. apply Hmatch2.
    + apply IHHmatch2 in H. destruct H. destruct H. destruct H. destruct H.
    destruct H0. exists (s1++x). exists x0. exists x1. split.
      * rewrite H. rewrite app_assoc. reflexivity.
      * split. apply H0. intros. assert (s1 ++ (x ++ napp m x0 ++ x1) = (s1 ++ x)
      ++ napp m x0 ++ x1). rewrite app_assoc. reflexivity. rewrite <- H2. apply
      MApp. apply Hmatch1. apply H1.
  - simpl. intros. apply plus_le in H. destruct H. apply IHHmatch in H. destruct
  H. destruct H. destruct H. destruct H. destruct H1. exists x. exists x0.
  exists x1. split. apply H. split. apply H1. intros. apply MUnionL. apply H2.
  - simpl. intros. apply plus_le in H. destruct H. apply IHHmatch in H0. destruct
  H0. destruct H0. destruct H0. destruct H0. destruct H1. exists x. exists x0.
  exists x1. split. apply H0. split. apply H1. intros. apply MUnionR. apply H2.
  - simpl. intros contra. inversion contra. apply pumping_consant_0_false in H0.
  destruct H0.
  - simpl. intros. rewrite app_length in H. simpl in IHHmatch2. destruct s1.
    + simpl. simpl in H. apply IHHmatch2 in H. destruct H. destruct H. destruct
    H. exists x. exists x0. exists x1. apply H.
    + simpl. exists []. exists (x :: s1). exists s2. split. reflexivity. split.
    intros contra. discriminate. intros. simpl. apply napp_star. apply Hmatch1.
    apply Hmatch2.
Qed.

Lemma pumping: forall T (re: reg_exp T) s,
  s =~ re -> pumping_constant re <= length s -> exists s1 s2 s3,
    s = s1 ++  s2 ++ s3 /\
    s2 <> [] /\
    length s1 + length s2 <= pumping_constant re /\
    forall m, s1 ++ napp m s2 ++ s3 =~ re.
Proof.
  intros T re s Hmatch.
  induction Hmatch.
  - simpl. intros contra. inversion contra.
  - simpl. intros contra. inversion contra. inversion H0.
  - simpl. intros. rewrite app_length in H. apply add_le_cases in H. destruct H.
    + apply IHHmatch1 in H. destruct H as [s3[s4[s5[H[H0[]]]]]].
    exists s3, s4, (s5 ++ s2). split. rewrite H. rewrite <- app_assoc. rewrite
    <- app_assoc. reflexivity. split. apply H0. split. apply le_plus_trans.
    apply H1. intros. rewrite app_assoc. rewrite app_assoc. apply MApp. rewrite
    <- app_assoc. apply H2. apply Hmatch2.
    + apply IHHmatch2 in H. destruct H as [s3[s4[s5[H[H0[]]]]]]. destruct
    (lt_ge_cases (pumping_constant re1) (length s1)).
      * apply n_lt_m__n_le_m in H3. apply IHHmatch1 in H3. destruct H3 as [s6[s7[s8[H4[H5[]]]]]].
    exists s6, s7, (s8 ++ s2). split. rewrite H4. rewrite <- app_assoc. rewrite
    <- app_assoc. reflexivity. split. apply H5. split. apply le_plus_trans.
    apply H3. intros. rewrite app_assoc. rewrite app_assoc. apply MApp. rewrite
    <- app_assoc. apply H6. apply Hmatch2.
      * exists (s1 ++ s3), s4, s5. split. rewrite H. rewrite app_assoc.
      reflexivity. split. apply H0. rewrite app_length. split. apply le_trans
      with (n := (pumping_constant re1) + (length s3 + length s4)). rewrite <-
      add_assoc. apply plus_le_compat_r. apply H3. apply plus_le_compat_l. apply
      H1. intros. replace ((s1 ++ s3) ++ napp m s4 ++ s5) with (s1 ++ (s3 ++
      napp m s4 ++ s5)). apply MApp. apply Hmatch1. apply H2. apply app_assoc.
  - simpl. intros. apply plus_le in H. destruct H. apply IHHmatch in H. destruct
  H as [s2[s3[s4[H[H1[]]]]]]. exists s2, s3, s4. split. apply H. split. apply
  H1. split. apply le_plus_trans. apply H2. intros. apply MUnionL. apply H3.
  - simpl. intros. apply plus_le in H. destruct H. apply IHHmatch in H0. destruct
  H0 as [s3[s4[s5[H0[H1[]]]]]]. exists s3, s4, s5. split. apply H0. split. apply
  H1. split. replace (pumping_constant re1 + pumping_constant re2) with
  (pumping_constant re2 + pumping_constant re1). apply le_plus_trans. apply H2.
  apply add_comm. intros. apply MUnionR. apply H3.
  - intros. inversion H. apply pumping_consant_0_false in H1. inversion H1.
  - simpl. intros. rewrite app_length in H. simpl in IHHmatch2. destruct
  (lt_ge_cases (pumping_constant re) (length s1)).
    + apply n_lt_m__n_le_m in H0. apply IHHmatch1 in H0. destruct H0 as
    [s3[s4[s5[H0[H1[]]]]]]. exists s3, s4, (s5 ++ s2). split. rewrite H0.
    rewrite <- app_assoc. rewrite <- app_assoc. reflexivity. split. apply H1.
    split. apply H2. intros. rewrite app_assoc. rewrite app_assoc. apply
    MStarApp. rewrite <- app_assoc. apply H3. apply Hmatch2.
    + destruct s1. simpl in H. apply IHHmatch2 in H. destruct H as
    [s3[s4[s5[H[H1[]]]]]]. exists s3, s4, s5. split. apply H. split. apply H1.
    split. apply H2. apply H3.
      exists [], (x :: s1), s2. split. reflexivity. split. intros contra.
      inversion contra. split. apply H0. intros. apply napp_star. apply Hmatch1.
      apply Hmatch2.
Qed.

End Pumping.

Inductive reflect (P: Prop): bool -> Prop :=
  | ReflectT (H: P): reflect P true
  | ReflectF (H: ~P): reflect P false.

Theorem iff_reflect: forall P b, (P <-> b = true) -> reflect P b.
Proof.
  intros P b H. destruct b eqn:Eb.
  - apply ReflectT. rewrite H. reflexivity.
  - apply ReflectF. rewrite H. intros H'. discriminate.
Qed.

Theorem reflect_iff: forall P b, reflect P b -> (P <-> b = true).
Proof.
  intros P b H. split. intros. destruct H. reflexivity. apply H in H0. inversion
  H0. destruct H. intros. apply H. intros. discriminate.
Qed.

Lemma eqbP: forall n m, reflect (n = m) (n =? m).
Proof.
  intros n m. apply iff_reflect. rewrite eqb_eq. reflexivity.
Qed.

Theorem filter_not_empty_In: forall n l,
  filter (fun x => n =? x) l <> [] -> In n l.
Proof.
  intros n l. induction l as [|m l'].
  - simpl. intros. apply H. reflexivity.
  - simpl. destruct (eqbP n m).
    + intros _. rewrite H. left. reflexivity.
    + intros. right. apply IHl'. apply H0.
Qed.

Fixpoint count n l :=
  match l with
  | [] => 0
  | m :: l' => (if n =? m then 1 else 0) + count n l'
  end.

Theorem eqbP_practice: forall n l,
  count n l = 0 -> ~(In n l).
Proof.
  intros n l Hcount. induction l as [|m l' IHl'].
  - intros H. simpl in H. apply H.
  - intros H. simpl in Hcount, H. destruct (eqbP n m).
    + discriminate.
    + apply IHl' in Hcount. destruct H. symmetry in H. apply H0 in H. apply H.
    apply Hcount in H. apply H.
Qed.

Inductive nostutter {X:Type}: list X -> Prop :=
  | nostutter_nil: nostutter []
  | nostutter_one (x: X): nostutter [x]
  | nostutter_cons (x: X) (y: X) (l: list X) (H: nostutter (y::l)) (H2: x <> y):
  nostutter (x::(y::l))
.

Example test_nostutter_1: nostutter [3;1;4;1;5;6].
Proof.
  repeat constructor; apply eqb_neq; auto.
Qed.

Example test_nostutter_2: nostutter (@nil nat).
Proof.
  repeat constructor; apply eqb_neq; auto.
Qed.

Example test_nostutter_3: nostutter [5].
  Proof. repeat constructor; auto. Qed.

Example test_nostutter_4: not (nostutter [3;1;1;4]).
Proof. intro.
  repeat match goal with
    h: nostutter _ |- _ => inversion h; clear h; subst
  end.
  contradiction; auto.
Qed.

Inductive merge {X: Type}: list X -> list X -> list X -> Prop :=
  | merge_nil: merge [] [] []
  | merge_l (x: X) (a b c: list X) (H: merge a b c): merge (x::a) b (x::c)
  | merge_r (x: X) (a b c: list X) (H: merge a b c): merge a (x::b) (x::c)
.

Theorem merge_filter: forall (X: Set) (test: X -> bool) (l l1 l2: list X),
  merge l1 l2 l ->
  All (fun n => test n = true) l1 ->
  All (fun n => test n = false) l2 ->
  filter test l = l1.
Proof.
  intros. induction H.
  - reflexivity.
  - simpl in H0. destruct H0. simpl. rewrite H0. replace (filter test c) with a.
  reflexivity. symmetry. apply IHmerge. apply H2. apply H1.
  - simpl in H1. destruct H1. simpl. rewrite H1. apply IHmerge. apply H0. apply
  H2.
Qed.

Theorem filter_challenge_2: forall (test: nat -> bool) (sub l: list nat),
  (subseq sub l) -> All (fun n => test n = true) sub -> length sub <= length
  (filter test l).
Proof.
  intros. induction H.
  - simpl. apply le_n.
  - simpl. apply IHsubseq in H0. apply le_trans with (n := length (filter test
  l2)). apply H0. destruct (test x). simpl. apply le_S. apply le_n. apply le_n.
  - simpl. simpl in H0. destruct H0. apply IHsubseq in H1. rewrite H0. simpl.
  apply n_le_m__Sn_le_Sm. apply H1.
Qed.

Inductive pal {X:Type}: list X -> Prop :=
  | pal_nil: pal []
  | pal_one (x:X): pal [x]
  | pal_add (x:X) (l: list X) (H: pal l): pal (x :: l ++ [x])
.

Theorem pal_app_rev: forall {X:Type} (l: list X),
  pal (l ++ (rev l)).
Proof.
  intros. induction l.
  - simpl. apply pal_nil.
  - simpl. rewrite app_assoc. apply pal_add. apply IHl.
Qed.

Theorem rev_involutive: forall (X:Type) (l: list X),
  rev (rev l) = l.
Proof.
  induction l as [| n l IHl].
  - reflexivity.
  - simpl. rewrite -> rev_app_distr. rewrite -> IHl. reflexivity.
Qed.

Theorem pal_rev: forall (X:Type) (l: list X), pal l -> l = rev l.
Proof.
  intros. induction H.
  - reflexivity.
  - reflexivity.
  - assert ([x] ++ l ++ [x] = ([x] ++ l) ++ [x]). apply app_assoc.
    rewrite <- (rev_involutive _ ([x] ++ l)) in H0. simpl in H0. simpl. rewrite
    H0. simpl. rewrite <- IHpal. reflexivity.
Qed.

Lemma rev_app_distr : forall X (l1 l2 : list X),
  rev (l1 ++ l2) = rev l2 ++ rev l1.
Proof.
intros X l1 l2. induction l1 as [| n l1' IHl1'].
- simpl. rewrite -> app_nil_r. reflexivity.
- simpl. rewrite -> IHl1'. rewrite -> app_assoc. reflexivity.
Qed.

Lemma palindrome_converse': forall X (n: nat) (l:list X),
  length l <= n -> l = rev l -> pal l.
Proof.
  intros X. induction n.
  - intros. inversion H. destruct l. apply pal_nil. discriminate.
  - intros. destruct l. apply pal_nil. simpl in *. destruct (rev l) as [] eqn:E.
    + rewrite H0. apply pal_one.
    + injection H0 as H0. rewrite H1. apply pal_add. apply IHn. apply leb_iff in
    H. simpl in H. apply leb_iff in H. rewrite H1 in H. rewrite app_length in H.
    apply le_trans with (n := length l0 + length [x]). apply le_plus_l. apply H.
    rewrite H1 in E. rewrite rev_app_distr in E. rewrite H0 in E. simpl in E.
    injection E as E. rewrite E. reflexivity.
Qed.

Theorem palindrome_converse: forall {X: Type} (l: list X),
  l = rev l -> pal l.
Proof.
  intros X l H. apply palindrome_converse' with (n := length l). apply le_n.
  apply H.
Qed.

Inductive disjoint {X}: (list X) -> (list X) -> Prop :=
  | disjoint_nil: disjoint [] []
  | disjoint_l (x:X) (l1 l2:list X) (H: disjoint l1 l2) (HI: ~(In x l2)) : disjoint (x::l1) l2
  | disjoint_r (x:X) (l1 l2:list X) (H: disjoint l1 l2) (HI: ~(In x l1)) : disjoint l1 (x::l2)
.

Inductive NoDup {X}: list X -> Prop :=
  | NoDup_nil: NoDup []
  | NoDup_add (x:X) (l:list X) (H:NoDup l) (HI: ~(In x l)) : NoDup (x::l)
.

Theorem app_no_dup_disjoint: forall X (l1 l2: list X),
  NoDup (l1 ++ l2) -> disjoint l1 l2.
Proof.
  intros X. induction l1 as [|x' l1].
  - intros l2 H. induction l2. apply disjoint_nil. apply disjoint_r. apply IHl2.
  inversion H. apply H1. intros contra. simpl in contra. apply contra.
  - intros l2 H. simpl in *. inversion H. apply IHl1 in H1. apply disjoint_l.
  apply H1. unfold not in *. intros. apply HI. apply In_app_iff. right. apply H3.
Qed.

Lemma in_split: forall (X:Type) (x:X) (l: list X),
  In x l -> exists l1 l2, l = l1 ++ x :: l2.
Proof.
  intros X x. induction l.
  - intros. destruct H.
  - intros. destruct H.
    + exists nil, l. rewrite H. reflexivity.
    + apply IHl in H. destruct H as [l1[l2]]. exists (x0::l1), l2. rewrite H. reflexivity.
Qed.

Inductive repeats {X:Type}: list X -> Prop :=
  | repeats_rep (x:X) (xs: list X) (H: In x xs): repeats (x::xs)
  | repeats_add (x:X) (xs: list X) (H: repeats xs): repeats (x::xs)
.

Lemma remove {X:Type}: forall (x:X) (xs:list X),
  In x xs -> exists xs', (forall x', x<>x' -> In x' xs -> In x' xs') /\ (length
  xs = S(length xs')).
Proof.
  intros. apply in_split in H. destruct H as [l1[l2]]. exists (l1 ++ l2).
  rewrite H. intros. clear H. split.
  - intros. apply In_app_iff in H0. apply In_app_iff. destruct H0. left. apply
  H0. simpl in H0. destruct H0. apply H in H0. destruct H0. right. apply H0.
  - rewrite app_length. simpl. rewrite app_length. replace (S (length l2)) with
  (1 + length l2). replace (S (length l1 + length l2)) with (1 + length l1 +
  length l2).
  rewrite add_assoc. rewrite (add_comm (length l1) 1). reflexivity. reflexivity. reflexivity.
Qed.

Theorem pigeonhole_principle: excluded_middle -> forall (X:Type) (l1 l2: list X),
  (forall x, In x l1 -> In x l2) -> length l2 < length l1 -> repeats l1.
Proof.
  intros ex. induction l1.
  - intros. inversion H0.
  - intros. destruct (ex (In x l1)).
    + apply repeats_rep. apply H1.
    + apply repeats_add. assert (In x l2). { apply H. simpl. left. reflexivity. }
      apply (remove x l2) in H2. destruct H2 as [l2'[]]. apply (IHl1 l2').
      * intros. apply H2. intros contra. rewrite <- contra in H4. apply H1 in
      H4. apply H4. apply H. simpl. right. apply H4.
      * rewrite H3 in H0. simpl in H0. apply Sn_le_Sm__n_le_m in H0. apply H0.
Qed.

(* TODO: Extended Exercise: A Verified Regular-Expression Matcher *)


Require Import QArith Quote List.
Require Import CpdtTactics.

Local Open Scope Q_scope.

Inductive Exp : Set :=
| Const : Q -> Exp
| Plus : Exp -> Exp -> Exp
| Minus : Exp -> Exp -> Exp
| Mult : Exp -> Exp -> Exp
| Var : index -> Exp.

Definition bindings := varmap Q.

Fixpoint denote (G : bindings) (e : Exp) : Q :=
  match e with
  | Const x => x
  | Plus x y => denote G x + denote G y
  | Minus x y => denote G x - denote G y
  | Mult x y => denote G x * denote G y
  | Var idx => varmap_find 0 idx G
  end.

Definition Coefficients := list (index * Q).

Fixpoint denoteCo (G : bindings) (ks : Coefficients) : Q :=
  match ks with
  | nil => 0
  | (var, k) :: ks' => varmap_find 0 var G * k + denoteCo G ks'
  end.

Fixpoint addCo (ks : Coefficients) var k : Coefficients :=
  match ks with
  | nil => (var, k) :: nil
  | (var', k') :: ks' => if index_eq var var' then
                           (var, k + k') :: ks'
                         else
                           (var', k') :: addCo ks' var k
  end.

Definition Equation := prod Coefficients Q.

Notation "x <- e1 ; e2" :=
  match e1 with
  | Some x => e2
  | None => None
  end
    (right associativity, at level 60).

Fixpoint toQ (e : Exp) : option Q :=
  match e with
  | Const x => Some x
  | Plus x y => x' <- toQ x ; y' <- toQ y ; Some (x' + y')
  | Minus x y => x' <- toQ x ; y' <- toQ y ; Some (x' - y')
  | Mult x y => x' <- toQ x ; y' <- toQ y ; Some (x' * y')
  | _ => None
  end.

Fixpoint add (eq : Equation) (e : Exp) (sign : Q) : option Equation :=
  match eq with
  | (l, r) =>  match e with
               | Const x => Some (l, r + sign * x)
               | Var idx => Some (addCo l idx sign, r)
               | Plus x y => eq' <- add eq x sign ; add eq' y sign
               | Minus x y => eq' <- add eq x sign; add eq' y (- sign)
               | Mult x y => let eq1 := x' <- toQ x ; add eq y (x' * sign) in
                             let eq2 := y' <- toQ y ; add eq x (y' * sign)
                             in
                             if eq1 then eq1 else eq2
               end
  end.

Definition denoteEquation (G : bindings) (eq : Equation) :=
  match eq with
  | (l, r) => denoteCo G l + r
  end.

Definition normalize (e : Exp) : option Equation :=
  add (nil, 0) e 1.

Ltac letpairs :=
  repeat
    match goal with
    | [|- context[let (_, _) := ?p in _]] => rewrite (surjective_pairing p); simpl;
                                             try rewrite <- (surjective_pairing p)
    end;
  repeat
    match goal with
    | [H : context[let (_, _) := ?p in _] |- _] => rewrite (surjective_pairing p) in H; simpl in H;
                                                   try rewrite <- (surjective_pairing p) in H
    end.

Ltac do_notation_case :=
  match goal with
  | [H : context[_ <- ?x ; _] |- _] => let Heq := fresh in
                                       destruct x eqn:Heq; try solve [inversion H]
  end.

Ltac if_case :=
  match goal with
  | [H : context[if ?x then _ else _] |- _] => let Heq := fresh in destruct x eqn:Heq
  | [|- context[if ?x then _ else _]] => let Heq := fresh in destruct x eqn:Heq
  end.

Ltac newvar T k :=
  let x := fresh in
  evar (x : T); let y := eval unfold x in x
                  in clear x; k y.

Ltac inst_hyp H :=
  match type of H with
  | forall (_ : _ = _), _ => match goal with
                             | [x : _ = _ |- _] => specialize (H x)
                             end || specialize (H (eq_refl _)) || fail 1
  | forall (_ : ?T), _ => newvar T ltac:(fun x => specialize (H x)); inst_hyp H
  | _ => fail
  end.

Ltac inst_hyps :=
  repeat match goal with
         | [H : forall _, _ |- _] => inst_hyp H
         end.

Ltac some_inversion :=
  repeat match goal with
         | [H : Some _ = Some _ |- _] => injection H; clear H; intro
         end.

Ltac rewrite_with_hyps :=
  repeat match goal with
         | [ H : _ |- _ ] => rewrite H
         end.

Lemma toQ_correct : forall e q G,
    toQ e = Some q -> denote G e = q.
Proof.
  induction e;
  simpl;
  intros;
  repeat do_notation_case;
  inversion H;
  solve [reflexivity | inst_hyps; crush].
Qed.

Lemma add_correct : forall e eq eq' sign G,
    add eq e sign = Some eq' ->
    denoteEquation G eq' == denoteEquation G eq + sign * denote G e.
Proof.
  unfold denoteEquation.

  induction e; simpl; intros; letpairs.

  (* Const *)
  inversion H; simpl; ring.

  (* Plus *)
  do_notation_case. inst_hyps. letpairs. rewrite_with_hyps. ring.

  (* Minus *)
  do_notation_case. inst_hyps. letpairs. rewrite_with_hyps. ring.

  (* Mult *)
  do_notation_case;
    try if_case;
    try some_inversion;
    try do_notation_case;
    inst_hyps;
    letpairs;
    subst;
    match goal with
    | [H : toQ _ = Some _ |- _] =>  apply (toQ_correct _ _ G) in H
    end;
    rewrite_with_hyps;
    ring.

  (* Variable *)
  some_inversion.
  subst.
  simpl.
  induction (fst eq); simpl.
  ring.
  letpairs.
  if_case; simpl.
  apply index_eq_prop in H.
  subst.
  ring.
  letpairs.
  rewrite <- Qplus_assoc.
  rewrite_with_hyps.
  ring.
Qed.

Theorem normalize_correct : forall e eq,
    normalize e = Some eq -> forall G, denote G e == denoteEquation G eq.
Proof.
  unfold normalize.
  intros.
  assert (L := add_correct e (nil, 0) eq 1 G H).
  simpl in L.
  ring_simplify in L.
  symmetry.
  assumption.
Qed.

Lemma equation_addition : forall a b c d,
    a == b -> c == d -> a + c == b + d.
Proof.
  crush.
Qed.

Lemma left_constant : forall G ks q r,
    denoteEquation G (ks, q) == r <-> denoteCo G ks == r - q.
Proof.
  split; intros; unfold denoteEquation in *;
  first [rewrite H | rewrite <- H];
  ring.
Qed.

Ltac add_together :=
  assert (H_sum : 0 == 0) by reflexivity;
  repeat
    match goal with
    | [H_sum : _ |- _] => fail
    | [H : ?l == ?r |- _] => match goal with
                             | [_ : done H |- _] => fail 1
                             | _ => assert (done H) by constructor;
                                 apply (equation_addition l r _ _ H) in H_sum
                             end
    end;
  un_done.

Ltac someOut e :=
  match eval compute in e with
  | Some ?x => x
  end.

Ltac reify :=
  add_together;
  repeat match goal with
         | [H : ?l == ?r |- _] =>
           match l with
           | denoteCo _ _ => fail 1
           | _ =>
             quote denote [Qmake xI xO xH Z0 Zpos Zneg]
               in l using (fun d =>
                             match d with
                             | denote _ ?e =>
                               change (d == r) in H;
                             let eq := (someOut (normalize e))
                             in rewrite (normalize_correct e eq) in H;
                             auto;
                             rewrite left_constant in H
                             end)
           end
         end;
  repeat match goal with
         | [H : denoteCo _ _ == _ |- _] => simpl in H; ring_simplify in H
         end;
  match goal with
  | [|- ?l == ?r ] =>
    quote denote [Qmake xI xO xH Z0 Zpos Zneg]
      in l using (fun d =>
                    match d with
                    | denote _ ?e =>
                      change (d == r);
                    let eq := (someOut (normalize e))
                    in rewrite (normalize_correct e eq);
                    auto;
                    rewrite left_constant;
                    simpl;
                    ring_simplify
                    end)
  end.

Ltac finish :=
  match goal with
  | [H : _ == ?r |- _ == ?r] => rewrite <- H; ring
  end.

Theorem test : forall x y z,
    (2 # 1) * (x - (3 # 2) * y) == 15 # 1 ->
    z + (8 # 1) * x == 20 # 1 ->
    (-6 # 2) * y + (10 # 1) * x + z == 35 # 1.
Proof.
  intros.
  reify.
  finish.
Qed.


(*Ejericio 10 . formalizar y r
su validez;

1. Si es falso que si un objeto flota en el agua es menos denso
   que ésta, entonces se puede caminar sobre ella.

2. Es claro que no se puede caminar sobre el agua.

3. Si un objeto es menos denso que el agua entonces puede
   desplazar una cantidad de agua igual a su propio peso.

4. Un objeto puede desplazar una cantidad de agua igual a su
   propio peso solo si flota en el agua.

Por lo tanto, un objeto flota en el agua si y solo si
es menos denso que ésta.*)

Axiom classic : forall P:Prop, P \/ ~ P.

Lemma NNPP : forall p:Prop, ~ ~ p -> p.
Proof.
intros.
elim (classic p).
intro.
assumption.
intro.
elim (H H0).
Qed.

Section razonamiento.
Variables p q r s t : Prop.
Hypothesis H0: p -> (q \/ r).
Hypothesis H1: s -> ~q.
Hypothesis H2: t-> ~r.
Hypothesis H3: p /\ t.
Lemma conclu :q.
Proof.
destruct H0.
destruct H3.
apply H.
apply H.
destruct H2.
apply H3.
apply H.
Qed.
End razonamiento.

Section razonamiento2.

Variables p q r s : Prop.

Lemma neg_ant: (~(p -> q) -> r) -> (~r -> ~~(p -> q)).
Proof.
intros.
intro.
apply H0.
apply H.
assumption.
Qed.

Hypothesis H0: ~(p -> q) -> r.
Hypothesis H1: ~r.
Hypothesis H2: q -> s.
Hypothesis H3: s -> p.
Lemma res: p <-> q.
Proof.
split.
apply neg_ant in H0.
apply NNPP in H0.
assumption.
assumption.
intro.
apply H2 in H.
apply H3 in H.
assumption.
Qed.

End razonamiento2.


(* Contribution to the Coq Library   V6.3 (July 1999)                       *)
(****************************************************************************)
(*                 The Calculus of Inductive Constructions                  *)
(*                                                                          *)
(*                                Projet Coq                                *)
(*                                                                          *)
(*                     INRIA                        ENS-CNRS                *)
(*              Rocquencourt                        Lyon                    *)
(*                                                                          *)
(*                                Coq V5.11                                 *)
(*                              Feb 2nd 1996                                *)
(*                                                                          *)
(*                (notations and layout updated March 2009)                 *)
(****************************************************************************)
(*                               Schroeder.v                                *)
(****************************************************************************)
(* This file is distributed under the terms of the                          *)
(* GNU Lesser General Public License Version 2.1                            *)
(****************************************************************************)

(**  If A is of cardinal less than B and conversely, then A and B           *)
(**  are equipollent                                                        *)
(**  In other words, if there is an injective map from A to B and           *)
(**  an injective map from B to A then there exists a map from A onto B.    *)

(**                  (based on a proof by Fraenkel)                         *)

Set Nested Proofs Allowed.
Require Import Ensembles.      (* Ensemble, In, Included, Setminus *)
Require Import Relations_1.    (* Relation, Transitive *)
Require Import Powerset.       (* Inclusion_is_transitive *)
Require Import Classical_Prop. (* classic *)

Require Import Setminus_fact.
Require Import Sums.
Require Import Functions.
Require Import Equipollence.

Section Schroeder_Bernstein.

(****************************************************************************)
(** We need the decidability of the belonging relation on sets              *)
(** This is equivalent to classical logic                                   *)

Definition in_or_not_in (U : Type) (x : U) (A : Ensemble U) :=
  classic (In U A x).

(****************************************************************************)
(**  A and B are sets of elements in the univers U                          *)

Variable U : Type.

Let SU := Ensemble U.

Variable A B : SU.  (* A and B are sets of elements in the univers U *)

  Section Bijection.

  (**************************************************************************)
  (** We now show that if f and g are injections resp from A to B and from  *)
  (** B to A, then there is a subset J of A s.t. h, defined to be f on A    *)
  (** and the converse of g on A\J is a bijection from A to B               *)

  Variable f g : Relation U.  (* f and g are relations *)

  Hypothesis f_inj : injection U A B f. (* f and g are injections *)
  Hypothesis g_inj : injection U B A g.

  Let Imf : Ensemble U -> Ensemble U := Im U f.
  Let Img : Ensemble U -> Ensemble U := Im U g.

  (** Constructing J s.t. g(B\f(J))=A\J *)

    (** (Setminus U A C) denotes the difference A\C         *)
    (** (Included U A C) means that A is included in C  *)

    Let F (C : SU) := Setminus U A (Img (Setminus U B (Imf C))).

    Let D (C : SU) := Included U C (F C).

    Let J := Set_Sum U D.

  (**  We show that so-built J is the subset we are looking for *)

    (** J is Tarski's fix-point of F, a function which is growing *)
    (** w.r.t. inclusion                                          *)

    (** Lemma: F is growing *)

      Lemma F_growing :
       forall C C' : SU, Included U C C' -> Included U (F C) (F C').
      Proof.
        intros; unfold F in |- *.
        apply Setminus_contravariant.
        unfold Img in |- *.
        apply Im_stable_par_incl.
        apply Setminus_contravariant.
        unfold Imf in |- *.
        apply Im_stable_par_incl.
        assumption.
      Qed.

    (** We show F(J)=A\Img(B\Imf(J))=J *)

       (** First left-to-right inclusion *)

         (** Lemma: J_is_in_FJ (Included U J (F J))  *)

         Lemma J_is_in_FJ : Included U J (F J).
         Proof.
           unfold J in |- *.
           apply Set_Sum_is_majoring.
           intros C C_in_D.
           cut (Transitive (Ensemble U) (Included U)).
             2: apply Inclusion_is_transitive.
           intro Incl_is_trans.
           unfold Transitive in Incl_is_trans.
           apply Incl_is_trans with (F C).
           (* Show C subset of (F C) *)
             assumption.
           (* Show (F C) subset of (F (Set_Sum U D)) *)
             apply F_growing.
             apply Set_Sum_is_minoring.
             assumption.
         Qed.

       (** Then right-to-left inclusion *)

         (** Lemma: FJ_is_in_J (Included U (F J) J)  *)

         Lemma FJ_is_in_J : Included U (F J) J.
         Proof.
           unfold J in |- *.
           apply Set_Sum_is_minoring.
           red in |- *.
           red in |- *.
           apply F_growing.
           exact J_is_in_FJ.
         Qed.

  (** We show that h, which is f on J and g elsewhere, is a bijection *)

    Inductive h (x y : U) : Prop :=
      | hl_intro : In U J x -> f x y -> h x y
      | hr_intro : Setminus U B (Imf J) y -> g y x -> h x y.

  (** Theorem: h_bij (bijection U A B h) *)

  Theorem h_bij : bijection U A B h.

    (** h is from A to B *)
    Lemma h1 : Rel U A B h.
    Proof.
        apply Rel_intro; do 2 intro; intro h_x_y.
        (* h is on A *)
          elim h_x_y.
          (* on J : f is from A to B *)
            elim f_inj.
            intro f_Rel; intros.
            elim f_Rel.
            intros f_sur_A f_sur_B.
            apply f_sur_A with y; assumption.

        (* on A\J: g is from B to A *)
          elim g_inj.
          intro g_Rel; intros.
          elim g_Rel.
          intros g_sur_B g_sur_A.
          apply g_sur_A with y; assumption.

      (* h is on B *)
        elim h_x_y.
        (* On J : f is from A to B *)
          elim f_inj.
          intro f_Rel; intros.
          elim f_Rel.
          intros f_sur_A f_sur_B.
          apply f_sur_B with x; assumption.

        (* On A\J: g is from B to A *)
        elim g_inj.
        intro g_Rel; intros.
        elim g_Rel.
        intros g_sur_B g_sur_A.
        apply g_sur_B with x; assumption.

    Qed.

    (** h satisfies to_at_most_one_output *)
    Lemma h2 : to_at_most_one_output U h.
    Proof.
      red in |- *; intros x y z h_x_y h_x_z.
      elim h_x_y.

      (* on J *)
        elim h_x_z.
        (* case when (h x y) or (h x z) behaves as f: ok *)
          elim f_inj.
          unfold to_at_most_one_output in |- *; intros f_Rel f_au_plus_1_im; intros.
          apply f_au_plus_1_im with x; assumption.

        (* case when (h x y) behaves as f and (h x z) as g: contradiction *)
          do 2 intro; intro x_in_J; intro.
          cut (Included U J (F J)).
            unfold Included in |- *; unfold F in |- *;
             unfold Setminus in |- *; intro Hyp.
            elim (Hyp x x_in_J).
            intros x_in_A x_in_non_Img.
            elim x_in_non_Img.
            red in |- *.
            red in |- *.
            apply Im_intro with z; assumption.
          exact J_is_in_FJ.

      (* on A\J *)
        elim h_x_z.
        (* case when (h x y) behaves as g and (h x z) as f: contradiction *)
          intro x_in_J; intros.
          cut (Included U J (F J)).
            unfold Included in |- *; unfold F in |- *;
             unfold Setminus in |- *; intro Hyp.
            elim (Hyp x x_in_J).
            intros x_in_A x_in_non_Img.
            elim x_in_non_Img.
            red in |- *.
            red in |- *.
            apply Im_intro with y; assumption.
          exact J_is_in_FJ.

        (* case when (h x y) and (h x z) behaves as g: ok *)
          elim g_inj.
          unfold from_at_most_one_input in |- *; do 3 intro; intro g_au_plus_1_ant;
           intros.
          apply g_au_plus_1_ant with x; assumption.

    Qed.

    (** h satisfies to_at_least_one_output *)
    Lemma h3 : to_at_least_one_output U A h.
    Proof.
      red in |- *.
      intros.
      elim (in_or_not_in U x (Img (Setminus U B (Imf J)))).

      (* on A\J *)
      unfold Img in |- *; intro x_in_Img.
      elim x_in_Img.
      intros y g_y_x H1.
      exists y.
      apply hr_intro; assumption.

      (* on J *)
      intros.
        (* from f function, we deduce that f satisfies to_at_least_one_output *)
        elim f_inj.
        unfold to_at_least_one_output in |- *; do 2 intro; intro f_au_moins_1_im;
         intro.
        elim (f_au_moins_1_im x H).
        intros y f_x_y.
        exists y.
        apply hl_intro.
          apply FJ_is_in_J.
          red in |- *; red in |- *; red in |- *.
          split; assumption.
        assumption.

    Qed.

    (** h satisfies from_at_most_one_input *)
    Lemma h4 : from_at_most_one_input U h.
    Proof.
      red in |- *; do 3 intro; intros h_x_z h_y_z.
      elim h_x_z.

      (* on J *)
        elim h_y_z.
        (* case when (h x y) and (h x z) behave as f: ok *)
          elim f_inj.
          intros.
          cut (forall x y z : U, f x z -> f y z -> x = y).
          intro Hyp; apply Hyp with z; assumption.
          assumption.

        (* show that one cannot have (f x z) and (g z y) with x in J and
            z outside of (Imf J) without contradiction *)
          unfold Setminus in |- *; intro z_in_Setminus_B_Imf_J; intros.
          elim z_in_Setminus_B_Imf_J.
          intros z_in_B z_in_non_Imf_J.
          elim z_in_non_Imf_J.
          red in |- *.
          red in |- *.
          apply Im_intro with x; assumption.

      (* on A\J *)
        elim h_y_z.
        (* show that one cannot (f y z) and (g z x) with x in J and
            z outside (Imf J) without contradiction *)
          unfold Setminus in |- *; do 2 intro; intro z_in_Setminus_B_Imf_J;
           intros.
          elim z_in_Setminus_B_Imf_J.
          intros z_in_B z_in_non_Imf_J.
          elim z_in_non_Imf_J.
          red in |- *.
          red in |- *.
          apply Im_intro with y; assumption.

        (* from g function, one deduces that g satisfies to_at_most_one_output,
           which means from_at_most_one_input for h *)
          elim g_inj.
          intros.
          cut (forall z x y : U, g z x -> g z y -> x = y).
          intro Hyp; apply Hyp with z; assumption.
          assumption.

    Qed.

    (** h satisfies from_at_least_one_input *)
    Lemma h5 : from_at_least_one_input U B h.
    Proof.
      red in |- *.
      intros.
      elim (in_or_not_in U y (Imf J)).

      (* on J *)
      unfold Imf in |- *; intro y_in_Imf.
        (* from f injective, one deduces that f satisfies from_at_least_one_input *)
          elim y_in_Imf.
          intros x f_x_y; intro.
          exists x.
          apply hl_intro; assumption.

      (* on A\J *)
        intros.
        (* from g injective, one deduces g satisfies to_at_least_one_output,
           which means from_at_least_one_input for h *)
          elim g_inj.
          unfold to_at_least_one_output in |- *; do 2 intro; intro g_au_moins_1_im;
           intro.
          elim (g_au_moins_1_im y H).
          intros x g_y_x.
          exists x.
          apply hr_intro.
          red in |- *.
          split; assumption.
          assumption.

    Qed.

    (** We can now resume the proof of h_bij *)

    Proof.
    exact (bijection_intro U A B h h1 h2 h3 h4 h5).
    Qed.

  End Bijection.

(**    Schroeder-Bernstein-Cantor Theorem     *)

Theorem Schroeder : A <=_card B -> B <=_card A -> A =_card B.

Proof.

  intros A_inf_B B_inf_A.
  elim A_inf_B.
  intros.
  elim B_inf_A.
  intros.
  apply equipollence_intro with (h f f0).
  apply h_bij; assumption.

Qed.

End Schroeder_Bernstein.

                           (* The end *)

(* $Id$ *)


Require Import List Arith Omega Lia.
Import ListNotations.

Inductive expr : Type :=
| Const : nat -> expr
| Plus : expr -> expr -> expr.

Fixpoint eval_expr (e : expr) : nat :=
  match e with
  | Const n => n
  | Plus e1 e2 => eval_expr e1 + eval_expr e2
  end.

Fixpoint eval_expr_tail' (e : expr) (acc : nat) : nat :=
  match e with
  | Const n => n + acc
  | Plus e1 e2 => eval_expr_tail' e2 (eval_expr_tail' e1 acc)
  end.

Definition eval_expr_tail e := eval_expr_tail' e 0.

Fixpoint eval_expr_cont' {A} (e : expr) (k : nat -> A) : A :=
  match e with
  | Const n => k n
  | Plus e1 e2 => eval_expr_cont' e2 (fun n2 =>
                  eval_expr_cont' e1 (fun n1 => k (n1 + n2)))
  end.

Definition eval_expr_cont (e : expr) : nat :=
  eval_expr_cont' e (fun n => n).

Lemma silly1 : forall e n, eval_expr_tail' e n = n + eval_expr_tail' e 0.
Proof.
  induction e;intros;simpl. omega.
  rewrite (IHe1 n). rewrite (IHe2 (n + eval_expr_tail' e1 0)).
  rewrite (IHe2 (eval_expr_tail' e1 0)). omega.
Qed.

Theorem eval_expr_tail_correct : forall e, eval_expr_tail e = eval_expr e.
Proof.
  induction e;unfold eval_expr_tail in *;simpl.
  omega. rewrite IHe1. rewrite silly1. auto.
Qed.

Lemma silly2 : forall {A : Type} e (k : nat -> A), eval_expr_cont' e k
                            = k (eval_expr e).
Proof.
  induction e;intros;simpl. auto.
  rewrite (IHe2 (fun n2 : nat => eval_expr_cont' e1 (fun n1 : nat => k (n1 + n2)))).
  rewrite (IHe1 (fun n1 : nat => k (n1 + eval_expr e2))). auto.
Qed.

Theorem eval_expr_cont_correct : forall e, eval_expr_cont e = eval_expr e.
Proof.
  induction e;unfold eval_expr_cont in *;simpl. auto.
  rewrite (silly2 _ (fun n2 : nat => eval_expr_cont' e1 (fun n1 : nat => n1 + n2))).
  rewrite (silly2 _ (fun n1 : nat => n1 + eval_expr e2)). auto.
Qed.

Inductive instr := Push (n : nat) | Add.

Definition prog := list instr.

Definition stack := list nat.

Fixpoint run (p : prog) (s : stack) : stack :=
  match p with
  | [] => s
  | i :: p' => let s' :=
                  match i with
                  | Push n => n :: s
                  | Add => match s with
                          | a1 :: a2 :: s' => a1 + a2 :: s'
                          | _ => s
                          end
                  end in
              run p' s'
  end.

Fixpoint compile (e : expr) : prog :=
  match e with
  | Const n => [Push n]
  | Plus e1 e2 => compile e1 ++ compile e2 ++ [Add]
  end.

Lemma silly3 : forall p1 p2 s, run (p1 ++ p2) s = run p2 (run p1 s).
Proof. induction p1;intros;simpl;auto. Qed.

Theorem compile_correct_extend : forall e s, run (compile e) s = eval_expr e :: s.
Proof.
  induction e;intros;simpl;auto.
  repeat rewrite silly3. rewrite IHe2. rewrite IHe1. simpl. rewrite plus_comm. auto.
Qed.

Theorem compile_correct : forall e, run (compile e) [] = [eval_expr e].
Proof. intros; apply (compile_correct_extend e []). Qed.


(* author: Dimitur Krustev *)
(* started: 20170526 *)

Require Import ZArith List.

Open Scope Z_scope.

Definition Model := Z.

Definition model : Model := 0.

Inductive Msg := Increment | Decrement.

Definition update (msg: Msg) (model: Model) : Model :=
  match msg with
  | Increment => model + 1
  | Decrement => model - 1
  end.

(* *** *)

Theorem update_ok: forall (msgs: list Msg) (model: Model),
  let decrements := filter (fun msg =>
    match msg with Decrement => true | _ => false end) msgs in
  let increments := filter (fun msg =>
    match msg with Increment => true | _ => false end) msgs in
  fold_left (fun model msg => update msg model) msgs model
    = model + Zlength increments - Zlength decrements.
Proof.
  induction msgs.
  - simpl. unfold Zlength. simpl. intros. unfold Model in *. ring.
  - simpl. destruct a.
    + simpl. intros. rewrite Zlength_cons.
      rewrite IHmsgs.
      unfold Model in *. ring.
    + simpl. intros. rewrite Zlength_cons.
      rewrite IHmsgs.
      unfold Model in *. ring.
Qed.

(* *** *)

Extraction Language Haskell.
Require ExtrHaskellBasic.
Require ExtrHaskellZInt.

Recursive Extraction update.


Add LoadPath "C:\Users\spide\Documents\Tareas\VerificacionFormal\Tareas\Tarea3\Tarea3VFLuisBLluis" as camino.

(** Tarea 3 Verificación Formal
    Luis B. Lluis LL11
    El siguiente script contiene las notaciones y definiciones
    para números por paridad.
    Este script es una concatenación
    de scripts bn2.v , orderbn.v
    de Favio Ezequiel Miranda.
  Dependencias: NONE
  Contenido
  1.- bn2----------------no depends
      bn sucBN predBN toN toBN plusBN
  3.- orderbn------------depends bn2
      ltBN lteqBN

*)

(** 1.------------- bn-----------------------*)
(*Datatype for our numerical system with 0, U and D*)
Inductive BN :=
  Z: BN
| U: BN -> BN
| D: BN -> BN.

(* Successor function for BN numbers  *)
Fixpoint sucBN (b:BN) : BN :=
  match b with
      Z => U Z
    | U x => D x (*S(U x) = S(2x + 1) = 2x + 2 = D x*)
    | D x => U (sucBN x) (*S(D x)= S(2x + 2) = S(S(2x + 1)) = S(2x + 1) + 1  *)
                 (* 2(S(x)) + 1 = 2(x+1) + 1 = (2x + 2) + 1 = S(2x + 1) + 1*)
  end.

(* Predeccesor function with error *)

Parameter (undefBN: BN). (* we assume a constant undefBN:BN representing an undefined BN number *)

Fixpoint predBN (b:BN): BN :=
 match b with
  Z => undefBN
 |U Z => Z
 |U x => D (predBN x)
 |D x => U x
 end.

(* Conversion functions *)

(* Recursive function that converts a number of type BN
 to its respective natural number*)
Fixpoint toN (b:BN) : nat :=
  match b with
      Z => 0
    | U x => 2*(toN x) + 1
    | D x => 2*(toN x) + 2
  end.

(* Converts a nat value to BN value.
   Inverse of the above one.*)
Fixpoint toBN (n: nat) : BN :=
  match n with
      0 => Z
    | S x => sucBN (toBN x)
  end.

(* Definition of sum of BN elements*)

Fixpoint plusBN (a b : BN) : BN :=
  match a,b with
    | Z, b => b
    | a, Z  => a
    | U x, U y => D(plusBN x y)
    | D x, U y => U(sucBN (plusBN x y))
    | U x, D y => U(sucBN (plusBN x y))
    | D x, D y => D(sucBN (plusBN x y))
  end.

Notation "a ⊞ b" := (plusBN a b) (at level 60).

(** 3.----------------------- orderbn *)
Inductive ltBN : BN -> BN -> Prop :=
 | ltBNZU : forall (a:BN), ltBN Z (U a)
 | ltBNZD : forall (a:BN), ltBN Z (D a)
 | ltBNUU : forall (a b:BN), ltBN a b -> ltBN (U a) (U b)
 | ltBNUDeq : forall (a :BN), ltBN (U a) (D a)
 | ltBNUD : forall (a b:BN), ltBN a b -> ltBN (U a) (D b)
 | ltBNDU : forall (a b:BN), ltBN a b -> ltBN (D a) (U b)
 | ltBNDD : forall (a b:BN), ltBN a b -> ltBN (D a) (D b).

Inductive lteqBN: BN -> BN -> Prop :=
 | lteqBNref: forall (a:BN), lteqBN a a
 | lteqBNl: forall (a b: BN), ltBN a b -> lteqBN a b.

Notation "a <BN b" := (ltBN a b) (at level 70).
Notation "a <BN b <BN c" := (ltBN a b /\ ltBN b c) (at level 70, b at next level).

Notation "a ≤BN b" := (lteqBN a b) (at level 70).


Require Import List.

Inductive swap_once: list nat -> list nat -> Prop :=
| OnceSwap1: forall h1 h2 t, swap_once (h1 :: h2 :: t) (h2 :: h1 :: t)
| OnceSwap2: forall h t1 t2, swap_once t1 t2 -> swap_once (h :: t1) (h :: t2).

Inductive is_odd_permutation: list nat -> list nat -> Prop :=
| OddPermutation1: forall l1 l2,
    swap_once l1 l2 -> is_odd_permutation l1 l2
| OddPermutation2: forall l1 l2 l3 l4,
    swap_once l1 l2 -> swap_once l2 l3 -> is_odd_permutation l3 l4 ->
    is_odd_permutation l1 l4.

Definition task := forall l1 l2, NoDup l1 -> is_odd_permutation l1 l2 -> l1 <> l2.


(**************************************************************************)
(*   Mechanised Framework for Local Interactions & Distributed Algorithms *)
(*   P. Courtieu, L. Rieg, X. Urbain                                      *)
(*   PACTOLE project                                                      *)
(*                                                                        *)
(*   This file is distributed under the terms of the CeCILL-C licence     *)
(*                                                                        *)
(**************************************************************************)

Require Import Reals.
Require Import SetoidList.
Require Import SetoidDec.
Require Import Pactole.Util.Coqlib.
Require Export Pactole.Spaces.RealVectorSpace.

Class RealMetricSpace (T : Type) {S : Setoid T} `{@EqDec T S} {VS : RealVectorSpace T} := {
  dist : T -> T -> R;

  dist_defined : forall u v, dist u v = 0%R <-> u == v;
  dist_sym : forall u v, dist v u = dist u v;
  triang_ineq : forall u v w, (dist u w <= dist u v + dist v w)%R}.

Arguments dist T%type _ _ _ _ u%VS v%VS.

Instance dist_compat `{RealMetricSpace} : Proper (equiv ==> equiv ==> Logic.eq) dist.
Proof.
intros x x' Hx y y' Hy. apply Rle_antisym.
+ replace (dist x' y') with (0 + dist x' y' + 0)%R by ring. symmetry in Hy.
  rewrite <- dist_defined in Hx. rewrite <- dist_defined in Hy.
  rewrite <- Hx at 1. rewrite <- Hy. eapply Rle_trans. apply triang_ineq.
  rewrite Rplus_assoc. apply Rplus_le_compat_l, triang_ineq.
+ replace (dist x y) with (0 + dist x y + 0)%R by ring. symmetry in Hx.
  rewrite <- dist_defined in Hx. rewrite <- dist_defined in Hy.
  rewrite <- Hx at 1. rewrite <- Hy. eapply Rle_trans. apply triang_ineq.
  rewrite Rplus_assoc. apply Rplus_le_compat_l, triang_ineq.
Qed.

Lemma dist_nonneg `{RealMetricSpace} : forall u v, (0 <= dist u v)%R.
Proof.
intros x y. apply Rmult_le_reg_l with 2%R.
+ apply Rlt_R0_R2.
+ do 2 rewrite double. rewrite Rplus_0_r.
  assert (Hx : equiv x x) by reflexivity. rewrite <- dist_defined in Hx. rewrite <- Hx.
  setoid_rewrite dist_sym at 3. apply triang_ineq.
Qed.

Lemma dist_same `{RealMetricSpace} : forall u, (dist u u = 0)%R.
Proof. intro. rewrite dist_defined. reflexivity. Qed.

Section MaxDist.
Context `{RealMetricSpace}.

(** Maximum distance of a list of points to a point. *)
Definition max_dist_pt_list pt := max_list (fun pt' => dist pt pt').

Lemma max_dist_pt_list_nonneg : forall pt l, 0 <= max_dist_pt_list pt l.
Proof using . intros. apply max_list_aux_min. Qed.

Lemma max_dist_pt_list_app : forall pt l1 l2,
  max_dist_pt_list pt (l1 ++ l2) = Rmax (max_dist_pt_list pt l1) (max_dist_pt_list pt l2).
Proof using . intros. apply max_list_app. Qed.

Global Instance max_dist_pt_list_compat :
  Proper (equiv ==> equivlistA equiv ==> eq) max_dist_pt_list.
Proof using . intros ? ? Heq1. apply max_list_compat. intros ? ? Heq2. now rewrite Heq1, Heq2. Qed.

Lemma max_dist_pt_list_le : forall pt l pt1,
  InA equiv pt1 l -> dist pt pt1 <= max_dist_pt_list pt l.
Proof using . intros. apply max_list_le; trivial; now apply dist_compat. Qed.

Lemma max_dist_pt_list_ex : forall pt l, l <> nil ->
  exists pt1, InA equiv pt1 l /\ dist pt pt1 = max_dist_pt_list pt l.
Proof using .
intros pt l Hl. destruct (max_list_ex (dist pt) Hl) as [pt' [Hin Heq]].
rewrite Rmax_left in Heq; try apply dist_nonneg; [].
eauto.
Qed.

Lemma max_dist_pt_list_eq_0 : forall pt l,
  max_dist_pt_list pt l = 0%R <-> forall x, InA equiv x l -> x == pt.
Proof using .
intros pt l. unfold max_dist_pt_list.
rewrite (max_list_eq_0 (dist_compat _ _ (reflexivity pt)) (dist_nonneg pt)).
setoid_rewrite dist_sym. setoid_rewrite dist_defined.
reflexivity.
Qed.

(** Maximum distance of between lists of points. *)
Definition max_dist_list_list l1 l2 : R :=
  max_list (fun pt => max_dist_pt_list pt l2) l1.

Global Instance max_dist_list_list_compat :
  Proper (equivlistA equiv ==> equivlistA equiv ==> eq) max_dist_list_list.
Proof using .
repeat intro. apply max_list_compat; trivial; [].
repeat intro. now apply max_dist_pt_list_compat.
Qed.

Lemma max_dist_list_list_le : forall pt1 l1 pt2 l2,
  InA equiv pt1 l1 -> InA equiv pt2 l2 -> dist pt1 pt2 <= max_dist_list_list l1 l2.
Proof using .
intros. transitivity (max_dist_pt_list pt1 l2).
- now apply max_dist_pt_list_le.
- now apply (max_list_le (fun x y Hxy => max_dist_pt_list_compat x y Hxy _ _ (reflexivity l2))).
Qed.

Lemma max_dist_list_list_ex : forall l1 l2, l1 <> nil -> l2 <> nil ->
  exists pt1 pt2, InA equiv pt1 l1 /\ InA equiv pt2 l2 /\ dist pt1 pt2 = max_dist_list_list l1 l2.
Proof using .
intros l1 l2 Hl1 Hl2.
destruct (max_list_ex (fun pt => max_dist_pt_list pt l2) Hl1) as [pt1 [Hin1 Heq1]].
destruct (max_dist_pt_list_ex pt1 _ Hl2) as [pt2 [Hin2 Heq2]].
exists pt1, pt2. repeat split; auto.
unfold max_dist_list_list. rewrite Heq1, Heq2.
rewrite Rmax_left; trivial; [].
transitivity (dist pt1 pt2).
- apply dist_nonneg.
- now apply max_dist_pt_list_le.
Qed.

Lemma max_dist_list_list_cons_le : forall pt l,
  max_dist_list_list l l <= max_dist_list_list (pt :: l) (pt :: l).
Proof using .
intros pt [| pt' l].
- cbn. repeat rewrite Rmax_left; apply dist_nonneg.
- destruct (@max_dist_list_list_ex (pt' :: l) (pt' :: l))
    as [pt1 [pt2 [Hpt1 [Hpt2 Heq]]]]; try discriminate; [].
  rewrite <- Heq. apply max_dist_list_list_le; now right.
Qed.

End MaxDist.