Require Import Arith.
Require Import Coq.Logic.Eqdep_dec.
Require Import Coq.Arith.Peano_dec.
Require Import List.
Require Import Recdef.

(**
  Arithmétique
*)

(* Sur la soustraction (entière) *)
Lemma minus_Sn_n : forall (n:nat), (minus (S n) n) = (S 0).
induction n; auto.
Qed.

Lemma lt_S_r : forall (n1 n2:nat),
  (lt n1 n2) -> exists (n:nat), n2 = (S n).
destruct n2.
  intro. exfalso. apply (lt_n_0 n1). assumption.
  intro. exists n2. trivial.
Qed.

Lemma minus_lt_S : forall (n1 n2:nat),
  (lt n1 n2) -> exists (n:nat), (minus n2 n1) = (S n).
intros. elim (lt_S_r n1 n2 H). intros n H1. rewrite H1.
exists (minus n n1). rewrite minus_Sn_m.
  trivial.
  apply le_S_n. rewrite H1 in H. auto.
Qed.

(* Sur l'ordre strict 'lt' *)
Lemma lt_1_0 : forall (n:nat), (lt n 1) -> (n=0).
destruct n.
  auto.
  intro. inversion H. exfalso. apply (le_Sn_0 (S n)). assumption.
Qed.

Lemma lt_S_case : forall (m n:nat), (lt m (S n)) -> (lt m n) \/ (m=n).
intros m n. generalize m. induction n.
  intros. rewrite (lt_1_0 m0 H). tauto.
  destruct m0.
    intro. auto with arith.
    intro. elim IHn with (m:=m0); auto with arith.
Qed.

Lemma not_lt_Sn_n : forall (n:nat), not (lt (S n) n).
induction n.
  auto with arith.
  intro. auto with arith.
Qed.

(* Sur l'ordre large 'le' *)
Lemma not_le_Sn_n : forall (n:nat), not (le (S n) n).
induction n.
  auto with arith.
  intro. auto with arith.
Qed.

(* Cas sur les entiers *)
Lemma nat_compare_case : forall (n1 n2:nat),
 (lt n1 n2) \/ (n1=n2) \/ (lt n2 n1).
induction n1.
  destruct n2.
    tauto.
    left. auto with arith.
  destruct n2.
    right. right. auto with arith.
    elim (IHn1 n2).
      intro. left. auto with arith.
      intro. elim H.
        intro. right. left. auto.
        intro. right. right. auto with arith.
Qed.

(**
  Sur les listes
*)

(* Sur la longueur. *)
Lemma length_0_nil : forall (w:(list nat)),
  (length w)=0 -> w=nil.
destruct w.
  auto.
  intro. discriminate H.
Qed.

Lemma length_Sn_cons : forall (w:(list nat)) (n:nat),
  (length w)=(S n) -> exists (a:nat) (w':(list nat)), w = (cons a w').
destruct w.
  intros. discriminate H.
  intros. exists n. exists w. trivial.
Qed.

(* Principe d'induction sur la longueur des listes *)
Lemma list_length_ind_S : forall (P: (list nat) -> Prop),
  (P nil)
  -> (forall (n:nat), (forall (xs:(list nat)), (lt (length xs) (S n)) -> (P xs))
                      -> forall (xs:(list nat)), (length xs)=(S n) -> (P xs))
  -> forall (n:nat) (xs:(list nat)), (lt (length xs) (S n) -> (P xs)).
intros P P0 Plt. induction n.
  intros. assert (xs=nil).
    apply length_0_nil. apply lt_1_0. assumption.
    rewrite H0. assumption.
  intros. elim (lt_S_case (length xs) (S n) H).
    auto.
    intro. apply (Plt n); auto.
Qed.

Lemma list_length_ind : forall (P: (list nat) -> Prop),
  (P nil)
  -> (forall (n:nat), (forall (xs:(list nat)), (lt (length xs) (S n)) -> (P xs))
                      -> forall (xs:(list nat)), (length xs)=(S n) -> (P xs))
  -> forall (xs:(list nat)), (P xs).
intros. apply list_length_ind_S with (n:=(length xs)).
  assumption.
  assumption.
  auto with arith.
Qed.

(* Extension d'une liste avec des 0 (en tête) *)
Fixpoint zs (n:nat) : (list nat) :=
  match n with
      0 => nil
    | (S n) => (cons 0 (zs n))
  end.

Lemma zs_len: forall (n:nat), (length (zs n))=n.
induction n.
  auto.
  simpl. rewrite IHn. trivial.
Qed.

(* Complétion d'une liste en fonction d'une autre.
   Le résultat est une liste de la longueur de la
   plus grande.                                   *)
Definition dist (w1:(list nat)) (w2:(list nat)) :=
  (minus (length w1) (length w2)).

Definition padd (w1:(list nat)) (w2:(list nat)) :=
  (app (zs (dist w2 w1)) w1).

Lemma padd_len_lt_cons : forall (w1 w2:(list nat)),
  (lt (length w1) (length w2))
  -> exists (w:(list nat)), (padd w1 w2)=(cons 0 w).
intros. unfold padd. unfold dist.
elim (minus_lt_S (length w1) (length w2) H).
intros. rewrite H0. simpl. exists (app (zs x) w1). trivial.
Qed.

Lemma padd_len_le_len : forall (w1 w2:(list nat)),
  (le (length w1) (length w2))
  -> (length (padd w1 w2)) = (length w2).
intros. unfold padd. unfold dist. rewrite app_length.
rewrite zs_len. rewrite plus_comm.
rewrite le_plus_minus with (n:=(length w1)); trivial.
Qed.

Lemma padd_cons_0 : forall (w1 w2:(list nat)) (a:nat),
  (length w1) = (length w2) -> (padd w1 (cons a w2)) = (cons 0 w1).
intros. unfold padd. unfold dist. rewrite H. simpl length.
rewrite (minus_Sn_n (length w2)). simpl. trivial.
Qed.

(**
  Sur l'accessibilité.
  Tribute to P. Casteran:
      http://www.labri.fr/perso/casteran/Cantor/HTML/AccP.html#AccElim3
*)
Theorem AccElim2 :
forall (A B:Set)
       (RA: A -> A -> Prop) (RB: B -> B -> Prop),
 forall (P : A -> B -> Prop),
 (forall x y,
    (forall (t : A), RA t x -> forall y', Acc RB y' -> P t y') ->
    (forall (t : B), RB t y -> P x t) ->
    (P x y)) ->
  forall x y, Acc RA x -> Acc RB y -> P x y.
Proof.
 intros A B RA RB P H x y Ax; generalize y; clear y.
 elim Ax. clear Ax x; intros x HAccx Hrecx y Ay.
 elim Ay. clear Ay y. intros y HAccy Hrecy. apply H.
   auto.
   auto.
Qed.

(**
  Relation d'ordre sur les listes d'entiers considérés comme des
  ordinaux (formes normales de Cantor à exposants finis).
*)
Inductive wlt : (list nat) -> (list nat) -> Prop :=
  wlt_nil : forall (a:nat)(w:(list nat)), (wlt nil (cons (S a) w))
| wlt_0_w : forall (w1 w2:(list nat)), (wlt w1 w2) -> (wlt (cons 0 w1) w2)
| wlt_w_0 : forall (w1 w2:(list nat)), (wlt w1 w2) -> (wlt w1 (cons 0 w2))
| wlt_len : forall (w1 w2:(list nat)) (a1 a2:nat),
   (length w1 < length w2) -> (wlt (cons (S a1) w1) (cons (S a2) w2))
| wlt_lt :  forall (w1 w2:(list nat)) (a1 a2:nat),
  (length w1 = length w2) -> (lt a1 a2)
    -> (wlt (cons (S a1) w1) (cons (S a2) w2))
| wlt_wlt : forall (w1 w2:(list nat)) (a:nat),
  (length w1 = length w2) ->  (wlt w1 w2)
    -> (wlt (cons (S a) w1) (cons (S a) w2)).

(* 'nil' est minimal *)
Lemma not_wlt_nil : forall (w:(list nat)),
  not (wlt w nil).
induction w.
  intro. inversion H.
  case a.
   intro. inversion H. auto.
   intro. intro. inversion H.
Qed.

(* Lemmes d'inversion *)
Lemma wlt_0_w_inv: forall (w1 w2:(list nat)),
  (wlt (cons 0 w1) w2) -> (wlt w1 w2).
induction w2.
  intros. absurd (wlt (cons 0 w1) nil).
    apply (not_wlt_nil (cons 0 w1)).
    assumption.
  intro. inversion H.
    assumption.
    apply wlt_w_0. auto.
Qed.

Lemma wlt_w_0_inv: forall (w1 w2:(list nat)),
  (wlt w1 (cons 0 w2)) -> (wlt w1 w2).
induction w1.
  intros. inversion H. assumption.
  intros. inversion H.
    apply wlt_0_w. auto.
    assumption.
Qed.

(* Autres résultats négatifs *)
Lemma not_wlt_len_left : forall (w1 w2:(list nat)) (a:nat),
  (le (length w2) (length w1)) -> not (wlt (cons (S a) w1) w2).
induction w2.

  intros. apply not_wlt_nil.

  intros. destruct a.
    intro. absurd (wlt (cons (S a0) w1) w2).
      apply IHw2.
        apply le_trans with (m:=(length (cons 0 w2))).
          auto with arith.
          assumption.
        apply wlt_w_0_inv. assumption.
    intro. inversion H0.
      assert (lt (length (cons (S a) w2)) (length w2)).
        apply le_lt_trans with (m := (length w1)); assumption.
        apply (not_lt_Sn_n (length w2)). assumption.
      rewrite H4 in H. apply (not_le_Sn_n (length w2)); assumption.
      rewrite H4 in H. apply (not_le_Sn_n (length w2)); assumption.
Qed.

Lemma not_wlt_Sn_0 : forall (w1 w2:(list nat)) (a:nat),
  (length w1) = (length w2) -> not (wlt (cons (S a) w1) (cons 0 w2)).
intros. intro. inversion H0.
  apply (not_wlt_len_left w1 w2 a).
    rewrite H. auto with arith.
    apply wlt_w_0_inv. assumption.
Qed.

Lemma not_wlt_len: forall (w1 w2:(list nat)) (a:nat),
  (length w2 <= length w1) -> not (wlt (cons (S a) w1) w2).
induction w2.
  intros. intro. exfalso. apply (not_wlt_nil (cons (S a) w1)). assumption.
  intro. case a.
    intro. intro. apply IHw2 with (a:=a0).
      apply le_trans with (m:=(length (cons 0 w2))).
        simpl. auto with arith.
        assumption.
      apply wlt_w_0_inv. assumption.
    intros. intro. inversion H0.
      apply (lt_irrefl (length w1)).
        simpl in H. apply lt_trans with (m:=(length w2)); assumption.
      rewrite H4 in H. apply (le_Sn_n (length w2)). assumption.
      rewrite H4 in H. apply (le_Sn_n (length w2)). assumption.
Qed.

(* Invariance de 'wlt' pour la complétion à 0 (en tête) *)
Lemma wlt_wlt_zs_right : forall (n:nat) (w1 w2:(list nat)),
  (wlt w1 w2) -> (wlt w1 (app (zs n) w2)).
induction n.
  auto.
  intros. simpl. apply wlt_w_0. auto.
Qed.

Lemma wlt_zs_wlt_right : forall (n:nat) (w1 w2:(list nat)),
  (wlt w1 (app (zs n) w2)) -> (wlt w1 w2).
induction n.
  auto.
  simpl. intros. apply IHn. apply wlt_w_0_inv. assumption.
Qed.

Lemma wlt_wlt_zs_left : forall (n:nat) (w1 w2:(list nat)),
  (wlt w1 w2) -> (wlt (app (zs n) w1) (w2)).
induction n.
  auto.
  intros. simpl. apply wlt_0_w. auto.
Qed.

(* Caractérisation en fonction de la longueur:
   si '(wlt w1 w2)' et '#w2 < #w1' alors 'w1' commence par des 0 *)
Lemma wlt_gt_length : forall (w1 w2:(list nat)),
  (wlt w1 w2) -> (lt (length w2) (length w1))
  -> exists (n:nat) (w:(list nat)),
       (w1 = (app (zs n) w))
       /\ (length w)=(length w2)
       /\ (wlt w w2).
induction w1.

  intros. exfalso. apply (lt_n_0 (length w2)). auto.

  intros. simpl in H0. assert (length w2 <= length w1).
    apply lt_n_Sm_le. assumption.
    destruct a.
      elim (le_lt_or_eq (length w2) (length w1) H1).
        intro. elim IHw1 with (w2:=w2).
          intros z H3. elim H3. intros w1' H4. decompose [and] H4.
          exists (S z). exists w1'. split.
              simpl. rewrite H5. trivial.
              tauto.
          apply wlt_0_w_inv. assumption.
         assumption.
        intro. exists (S 0). exists w1. split.
          simpl. trivial.
          split.
            rewrite H2. trivial.
            apply wlt_0_w_inv. assumption.
      exfalso. apply (not_wlt_len w1 w2 a); assumption.
Qed.

(**
   Restriction de l'ordre aux listes de même longueur.
   (avec complémentation possible à 0):
   c'est l'ordre lexicographique.
*)
(* La relation sur les listes de même longueur *)
Inductive wlt_pad : (list nat) -> (list nat) -> Prop :=
  wlt_pad_len : forall (a:nat) (w1 w2:(list nat)),
    (le (length w1) (length w2)) ->
     (wlt_pad (padd  w1 (cons (S a) w2)) (cons (S a) w2))
| wlt_pad_lt : forall (a1 a2:nat) (w1 w2:(list nat)),
    (length w1) = (length w2) -> (lt a1 a2) ->
     (wlt_pad (cons (S a1) w1) (cons (S a2) w2))
| wlt_pad_wlt_pad : forall (a:nat) (w1 w2:(list nat)),
    (length w1) = (length w2) -> (wlt_pad w1 w2) ->
     (wlt_pad (cons a w1) (cons a w2)).

(* Relations entre l'ordre sur toute liste et l'ordre restreint. *)
Lemma wlt_wlt_pad : forall (w1 w2:(list nat)),
  (length w1) = (length w2) -> (wlt w1 w2)
  -> (wlt_pad w1 w2).
intros w1 w2. generalize w1. clear w1. induction w2.

  intros. exfalso. apply (not_wlt_nil w1). assumption.

  destruct w1.

    intros. discriminate H.

    intros. inversion H0.
    (* 1: wlt_0_w *)
    destruct a.
      apply wlt_pad_wlt_pad.
        auto.
        apply IHw2.
          auto.
          apply wlt_w_0_inv. assumption.
      rewrite <- (padd_cons_0 w1 w2 a).
        apply wlt_pad_len. injection H. intro. rewrite H5. auto with arith.
        auto.
    (* 2: wlt_w_0 *)
    destruct n.
      apply wlt_pad_wlt_pad.
        auto with arith.
        apply IHw2.
          auto with arith.
          apply wlt_w_0_inv. apply wlt_0_w_inv. rewrite <- H1 in H0. assumption.
      exfalso. apply (not_wlt_Sn_0 w1 w2 n).
        auto with arith.
        rewrite <- H1 in H0. assumption.
    (* 3 *)
    exfalso. apply (lt_irrefl (length w2)). injection H.
    intro. rewrite H6 in H2. assumption.
    (* 4 *)
    apply wlt_pad_lt.
      auto with arith.
      assumption.
    (* 5 *)
    apply wlt_pad_wlt_pad.
      auto with arith.
      apply IHw2.
        auto with arith.
        assumption.
Qed.

Lemma wlt_wlt_pad_zs : forall (w1 w2:(list nat)),
  (length w1) < (length w2) -> (wlt w1 w2)
  -> (wlt_pad (padd w1 w2) w2).
intros. apply wlt_wlt_pad.
  apply padd_len_le_len. auto with arith.
  apply wlt_wlt_zs_left. assumption.
Qed.

(**
  Accessibilité pour l'ordre restreint.
*)
Lemma Acc_wlt_pad_ind : forall (n:nat),
  (forall (w:(list nat)), (lt (length w) (S n)) -> Acc wlt_pad w)
    -> forall (w:(list nat)), (length w)=(S n) -> Acc wlt_pad w.
intros. elim (length_Sn_cons w n H0). intros a H1. elim H1. clear H1.
intros w' H1. rewrite H1. rewrite H1 in H0. clear H1. generalize H0.
pattern a, w'.
apply AccElim2 with (RA:=lt) (RB:=wlt_pad).

  intros a' w'' H1 H2 H3. apply Acc_intro. intros w''' H4.
  inversion H4.

    elim (padd_len_lt_cons  w1 (cons (S a0) w'')).
      intros w0 H9. rewrite H9. apply H1.
        rewrite <- H5. auto with arith.
        apply H.
          assert (lt (length (cons 0 w0)) (S (S n))).
            rewrite <- H9. rewrite padd_len_le_len.
              rewrite H5. rewrite H3. auto with arith.
              simpl. auto with arith.
            auto with arith.
          rewrite <- H9. rewrite padd_len_le_len.
            rewrite H5. assumption.
            simpl. auto with arith.
      simpl. auto with arith.

    apply H1.
      rewrite <- H5. auto with arith.
      apply H.
        rewrite H8. rewrite <- H3. auto with arith.
      simpl. rewrite H8. auto.

    apply H2.
      assumption.
      simpl. rewrite H8. auto.

  apply lt_wf.

  apply H.
    rewrite <- H0. auto with arith.

Qed.

Lemma Acc_wlt_pad_nil : (Acc wlt_pad nil).
apply Acc_intro. intros. inversion H.
Qed.

Lemma Acc_wlt_pad : forall (w:(list nat)), (Acc wlt_pad w).
induction w using list_length_ind.
  apply Acc_wlt_pad_nil.
  apply Acc_wlt_pad_ind with (n:=n); assumption.
Qed.

(**
  De l'accessibilté pour l'ordre restreint à l'accessibilité
  pour l'ordre sur tout liste.
*)
Lemma Acc_wlt_zs_Acc_wlt : forall (n:nat) (w:(list nat)),
  (Acc wlt (app (zs n) w)) -> (Acc wlt w).
intros. apply Acc_intro. intros w' H0. apply H.
apply wlt_wlt_zs_right. assumption.
Qed.

Lemma Acc_wlt_Acc_wlt_zs : forall (n:nat) (w:(list nat)),
  (Acc wlt w) -> (Acc wlt (app (zs n) w)).
intros. apply Acc_intro. intros w' H0. apply H.
apply wlt_zs_wlt_right with (n:=n). assumption.
Qed.

Lemma Acc_wlt_pad_Acc_wlt : forall (w:(list nat)),
  (Acc wlt_pad w) -> (Acc wlt w).
intros. elim H. intros w' H0 H1. apply Acc_intro.
intros w'' H2. elim (nat_compare_case (length w'') (length w')).
  (* #w'' < #w' *)
  intro. apply Acc_wlt_zs_Acc_wlt with (n:=(dist w' w'')).
  apply H1. apply wlt_wlt_pad_zs; assumption.
  (* #w'' = #w4 \/ #w' < #w'' *)
  intro. elim H3.
    (* #w'' = #w' *)
    intro. apply H1. apply wlt_wlt_pad; assumption.
    (* #w' < #w'' *)
    intro. elim (wlt_gt_length w'' w' H2 H4). intros a H5.
    elim H5. intro w0. intro. decompose [and] H6.
    rewrite H7. apply Acc_wlt_Acc_wlt_zs. apply H1.
    apply wlt_wlt_pad; assumption.
Qed.

(**
  L'ordre sur toute liste est bien fondé !
*)
Theorem Acc_wlt : forall (w:(list nat)), (Acc wlt w).
intro. apply Acc_wlt_pad_Acc_wlt.
apply Acc_wlt_pad.
Qed.

(**
   Sur wlt
*)
Lemma wlt_len_gen : forall (w1 w2:list nat) (a:nat),
  (lt (length w1) (length (cons (S a) w2))) -> (wlt w1 (cons (S a) w2)).
induction w1.
  intros. apply wlt_nil.
  intros. destruct a.
    apply wlt_0_w. apply IHw1. apply lt_trans with (m:=(length (cons 0 w1))).
      auto with arith.
      assumption.
    apply wlt_len. auto with arith.
Qed.

Lemma wlt_lt_gen : forall (a1 a2:nat) (w1 w2:list nat),
  (length w1) = (length w2) -> (lt a1 a2)
    -> (wlt (cons a1 w1) (cons a2 w2)).
intros. destruct a2.
  exfalso. apply (lt_n_0 a1). assumption.
  destruct a1.
    apply wlt_0_w. apply wlt_len_gen. rewrite H. auto with arith.
    apply wlt_lt; auto with arith.
Qed.

Lemma wlt_wlt_gen : forall (a:nat) (w1 w2:list nat),
  (length w1) = (length w2) -> (wlt w1 w2)
  -> (wlt (cons a w1) (cons a w2)).
destruct a.
  intros. apply wlt_0_w. apply wlt_w_0. assumption.
  intros. apply wlt_wlt; assumption.
Qed.

Lemma wlt_wf_ind : forall (P: (list nat) -> Prop),
  (forall (w1:list nat), (forall (w2:list nat), (wlt w2 w1) -> P w2) -> P w1)
  -> forall (w:list nat), P w.
intros. apply well_founded_ind with (R:=wlt).
  unfold well_founded. apply Acc_wlt.
  intros. apply H. assumption.
Qed.

(* Utilitaire pour la définition des ordres *)
Definition make_mwlt (A:Set) (m : A -> list nat) (a1 a2:A) :=
  (wlt (m a1) (m a2)).

(** Un ordre basé sur une mesure ordinale est bien fondé *)
Lemma Acc_wlt_eq :
  forall (A:Set) (m: A -> list nat) (w:list nat) (x:A) ,
    w = (m x) -> (Acc (fun x1 x2 : A => wlt (m x1) (m x2)) x).
induction w using wlt_wf_ind. intros. apply Acc_intro. intros.
  apply H with (w2:=(m y)).
    rewrite H0. assumption.
    trivial.
Qed.

Lemma Acc_mwlt : forall (A:Set) (m: A -> list nat),
  forall (x:A), (Acc (fun x1 x2 => (wlt (m x1) (m x2))) x).
intros. apply Acc_wlt_eq with (w:=(m x)). trivial.
Qed.

(**
  Applications avec Program Fixpoint
*)
Require Coq.Program.Wf.

(* Tactique pour les preuves de bonne fondation. *)
Ltac by_Acc_mwlt mwlt :=
  unfold Wf.MR; unfold well_founded; intros; unfold mwlt; apply Acc_mwlt.

(* Ordre lexicographique sur les entiers *)
Definition wm_natxnat (xy:nat*nat) :=
  match xy with
    (x,y) => (cons x (cons y nil))
  end.

Definition lex_natxnat :=
  (make_mwlt (nat*nat) wm_natxnat).

Lemma lex_natxnat_fst : forall (x1 y1 x2 y2:nat),
  (lt x1 x2) -> (lex_natxnat (x1,y1) (x2,y2)).
intros. unfold lex_natxnat. unfold make_mwlt. simpl.
apply wlt_lt_gen; auto.
Qed.

Lemma lex_natxnat_snd : forall (x y1 y2:nat),
  (lt y1 y2) -> (lex_natxnat (x,y1) (x,y2)).
intros. unfold lex_natxnat. unfold make_mwlt. simpl.
apply wlt_wlt_gen.
  auto.
  apply wlt_lt_gen; auto.
Qed.

Program Fixpoint ack_like (xy:nat*nat) {wf lex_natxnat xy} : nat :=
  match xy with
    (0, y) => (S y)
  | (S x, 0) => (ack_like (x, S 0))
  | (S x, S y) => (ack_like (x, (x + y))) +  (ack_like (S x, y))
  end.

Obligation 1.
apply lex_natxnat_fst.
auto with arith.
Qed.

Obligation 2.
apply lex_natxnat_fst.
auto with arith.
Qed.

Obligation 3.
apply lex_natxnat_snd.
auto with arith.
Qed.

Obligation 4.
by_Acc_mwlt lex_natxnat.
Defined.

Program Fixpoint ack (xy:nat*nat) {wf lex_natxnat xy} : nat :=
  match xy with
    (0, y) => (S y)
  | (S x, 0) => (ack (x, S 0))
  | (S x, S y) => (ack (x, ack (S x, y)))
  end.

Obligation 1.
apply lex_natxnat_fst.
auto with arith.
Qed.

Obligation 2.
apply lex_natxnat_snd.
auto with arith.
Qed.

Obligation 3.
apply lex_natxnat_fst. inversion Heq_xy. auto with arith.
Qed.

Obligation 4.
by_Acc_mwlt lex_natxnat.
Defined.

(* Ordre lexicographique sur les longueurs des listes *)
Definition wm_listxlist (A:Set) (xys: list A * list A) :=
  match xys with
    (xs,ys) => (wm_natxnat (length xs, length ys))
  end.

Definition lex_listxlist (A:Set) :=
  (make_mwlt (list A * list A) (wm_listxlist A)).

Parameter ltb : nat -> nat -> bool.

Program Fixpoint merge (xys: list nat * list nat) {wf (lex_listxlist nat) xys} : list nat :=
  match xys with
      (nil, ys) => ys
    | (xs, nil) => xs
    | (cons x xs, cons y ys) =>
      if (ltb x y) then (cons x (merge (xs, (cons y ys))))
      else (cons y (merge ((cons x xs), ys)))
  end.

Obligation 1.
unfold lex_listxlist. unfold make_mwlt. simpl.
apply wlt_lt_gen; auto with arith.
Qed.

Obligation 2.
unfold lex_listxlist. unfold make_mwlt. simpl. apply wlt_wlt_gen.
  auto.
  apply wlt_lt_gen; auto with arith.
Qed.

Obligation 4.
by_Acc_mwlt lex_natxnat.
Defined.

(* Ordre sur les listes d'entiers:
     ordre lexicographique sur la taille et le premier élément *)
Definition m_list (xs:list nat) :=
  match xs with
      nil => nil
    | (cons x xs) => (cons (length (cons x xs)) (cons x nil))
  end.

Definition lt_list  :=
  (make_mwlt (list nat) m_list).

Program Fixpoint sum_list (xs:list nat) {wf lt_list xs} : nat :=
  match xs with
      nil => 0
    | (cons 0 xs) => (sum_list xs)
    | (cons (S x) xs) => S (sum_list (cons x xs))
  end.

Obligation 1.
unfold lt_list. unfold make_mwlt. simpl. destruct xs.
  simpl. apply wlt_nil.
  simpl. apply wlt_lt_gen; auto with arith.
Qed.

Obligation 2.
unfold lt_list. unfold make_mwlt. simpl. apply wlt_wlt_gen.
  auto.
  apply wlt_lt_gen; auto with arith.
Qed.

Obligation 3.
by_Acc_mwlt lex_natxnat.
Defined.

(* Analogue sur les listes de listes *)
Definition m_listlist (A:Set) (xss : list (list A)) :=
  match xss with
      nil => nil
    | (cons xs _) => (cons (length xss) (cons (length xs) nil))
  end.

Definition lt_listlist (A:Set) (xss yss : list (list A)) :=
  (wlt (m_listlist A xss) (m_listlist A yss)).

Parameter A:Set.

Program Fixpoint list_concat (xss : list (list A))
        {wf (lt_listlist A) xss} : list A :=
  match xss with
      nil => nil
    | (cons nil xss) => (list_concat xss)
    | (cons (cons x xs) xss) => (cons x (list_concat (cons xs xss)))
  end.

Obligation 1.
unfold lt_listlist. destruct xss.
  simpl. apply wlt_nil.
  simpl. apply wlt_lt_gen; auto with arith.
Qed.

Obligation 2.
unfold lt_listlist. simpl. apply wlt_wlt_gen.
  auto.
  apply wlt_lt_gen; auto with arith.
Qed.

Obligation 3.
by_Acc_mwlt lex_natxnat.
Defined.

(* Sur la longueur des listes *)
Definition mw_list (A:Set) (xs: list A) :=
  (cons (length xs) nil).

Definition lt_len_list (A:Set) :=
  (make_mwlt (list A) (mw_list A)).

Program Fixpoint bubble (xs:list nat) {wf (lt_len_list nat) xs} : list nat :=
  match xs with
      nil => nil
    | (cons x nil) => (cons x nil)
    | (cons x1 (cons x2 xs)) =>
      if (ltb x1 x2) then (cons x1 (bubble (cons x2 xs)))
      else (cons x2 (bubble (cons x1 xs)))
  end.

Obligation 1.
unfold lt_len_list. unfold make_mwlt. unfold mw_list. simpl.
apply wlt_lt_gen; auto with arith.
Qed.

Obligation 2.
unfold lt_len_list. unfold make_mwlt. unfold mw_list. simpl.
apply wlt_lt_gen; auto with arith.
Qed.

Obligation 3.
by_Acc_mwlt lt_len_list.
Defined.

(* Le peigne *)
Inductive btree (A:Set) : Set :=
  Empty : (btree A)
| Node : (btree A) -> A -> (btree A) -> (btree A).

Arguments  Empty {A}.
Arguments Node [A] _ _ _.

Fixpoint btree_size (A:Set) (bt:btree A) :=
  match bt with
      Empty => 0
    | (Node bt1 x bt2) => S (plus (btree_size A bt1) (btree_size A bt2))
  end.

Definition m_btree (A:Set) (bt:btree A) :=
  match bt with
      Empty => nil
    | (Node bt1 x bt2) => (cons (btree_size A bt) (cons (btree_size A bt1) nil))
  end.

Definition lt_btree (A:Set) (bt1 bt2:btree A) :=
  (wlt (m_btree A bt1) (m_btree A bt2)).

Program Fixpoint to_list (bt:btree A)
        {wf (lt_btree A) bt} : list A :=
  match bt with
      Empty => nil
    | (Node Empty x bt) => (cons x (to_list bt))
    | (Node (Node bt1 x1 bt2) x2 bt3) => (to_list (Node bt1 x1 (Node bt2 x2 bt3)))
  end.

Obligation 1.
unfold lt_btree. destruct bt.
  simpl. apply wlt_nil.
  simpl. apply wlt_lt_gen; auto with arith.
Qed.

Obligation 2.
unfold lt_btree. simpl. rewrite <- plus_Snm_nSm. simpl.
rewrite plus_assoc. apply wlt_wlt_gen.
  auto.
  apply wlt_lt_gen; auto with arith.
Qed.

Obligation 3.
by_Acc_mwlt lt_btree.
Defined.

(* Theory *)
Axiom g1 : nat -> nat.
Axiom g2 : nat -> nat -> nat.
Axiom g3 : nat -> nat -> nat.
Axiom g4 : nat -> nat -> nat.
Axiom g5 : nat -> nat -> nat -> nat.
Axiom g6 : nat -> nat -> nat -> nat.
Axiom g7 : nat -> nat -> nat -> nat.
Axiom h1 : nat -> nat -> nat -> nat.
Axiom h2 : nat -> nat -> nat -> nat.
Axiom h3 : nat -> nat -> nat -> nat -> nat -> nat.

Definition wm_nat3 (xyz:nat * nat * nat) :=
  match xyz with
      (0, y, 0) => nil
    | (0, y, S z) => (cons (S z) nil)
    | (S x, 0, z) => (cons (S x) (cons 0 nil))
    | (S x, S y, z) => (cons (S x) (cons (S y) nil))
  end.

Definition rlex_nat3 :=
  (make_mwlt (nat * nat * nat) wm_nat3).

Program Fixpoint f (xyz : nat * nat * nat) {wf rlex_nat3 xyz} : nat :=
  match xyz with
      (0, y, 0) => (g1 y)
    | (0, y, S z) => (h1 y z (f (0, (g2 y z), z)))
    | (S x, 0, z) => (h2 x z (f (x, (g3 x z), (g4 x z))))
    | (S x, S y, z) =>
         (h3 x y z (f (x, (g5 x y z), (g6 x y z)))
                   (f (S x, y, (g7 x y z))))
  end.

Lemma rlex_nat3_1 : forall (y z m : nat),
  (rlex_nat3 (0, y, z) (0, m, S z)).
intros. unfold rlex_nat3. unfold make_mwlt. destruct z.
  simpl. apply wlt_nil.
  simpl. apply wlt_lt; auto with arith.
Qed.

Lemma rlex_nat3_2 : forall (x z m1 m2 : nat),
  (rlex_nat3 (x, m1, m2) (S x, 0, z)).
unfold rlex_nat3. unfold make_mwlt. destruct x.
  destruct m2.
    simpl. apply wlt_nil.
    simpl. apply wlt_len; auto with arith.
  intros. destruct m1.
    simpl. apply wlt_lt; auto with arith.
    simpl. apply wlt_lt; auto with arith.
Qed.

Lemma rlex_nat3_3 : forall (x y z m1 m2 : nat),
  (rlex_nat3 (x, m1, m2) (S x, S y, z)).
unfold rlex_nat3. unfold make_mwlt. destruct x.
  intros. destruct m2.
    simpl. apply wlt_nil.
    simpl. apply wlt_len; auto with arith.
  intros. destruct m1.
    simpl. apply wlt_lt; auto with arith.
    simpl. apply wlt_lt; auto with arith.
Qed.

Lemma rlex_nat3_4 : forall (x y z m : nat),
  (rlex_nat3 (S x, y, m) (S x, S y, z)).
unfold rlex_nat3. unfold make_mwlt. destruct y.
  intros. simpl. apply wlt_wlt.
    auto with arith.
    simpl. apply wlt_0_w. apply wlt_nil.
  intros. simpl. apply wlt_wlt.
    auto with arith.
    apply wlt_lt; auto with arith.
Qed.

Obligation 1.
apply rlex_nat3_1.
Qed.

Obligation 2.
apply rlex_nat3_2.
Qed.

Obligation 3.
apply rlex_nat3_3.
Qed.

Obligation 4.
apply rlex_nat3_4.
Qed.

Obligation 5.
by_Acc_mwlt wm_nat3.
Defined.

(* Bootstrap *)
Parameter eqb : nat -> nat -> bool.

Program Fixpoint listordi (xsys : list nat * list nat) {wf (lex_listxlist nat) xsys} : bool :=
  match xsys with
    (_, nil) => false
  | (xs, (cons 0 ys)) => (listordi (xs, ys))
  | (nil, (cons (S y) ys)) => true
  | ((cons 0 xs), (cons (S y) ys)) => (listordi (xs, (cons (S y) ys)))
  | ((cons (S x) xs), (cons (S y) ys)) =>
     (orb (ltb (length xs) (length ys))
	  (andb (eqb (length xs) (length ys))
		(orb (ltb x y) (listordi (xs, ys)))))
  end.

Obligation 1.
unfold lex_listxlist. unfold make_mwlt. simpl.
apply wlt_wlt_gen.
  auto.
  apply wlt_lt_gen; auto with arith.
Qed.

Obligation 2.
unfold lex_listxlist. unfold make_mwlt. simpl.
apply wlt_lt_gen; auto with arith.
Qed.

Obligation 3.
unfold lex_listxlist. unfold make_mwlt. simpl.
apply wlt_lt_gen; auto with arith.
Qed.

Obligation 4.
by_Acc_mwlt lex_natxnat.
Defined.

(* Dershowitz/Manna: "counting tips of binary trees" *)

Fixpoint list_btree_size (A:Set) (bts:list (btree A)) : nat :=
  match bts with
      nil => 0
    | (cons bt bts) => (plus (btree_size A bt) (list_btree_size A bts))
  end.

Definition wm_list_btree (A:Set) (bts:list (btree A)) : (list nat) :=
  (cons (list_btree_size A bts) (cons (length bts) nil)).

Definition lt_list_btree (A:Set) :=
  (make_mwlt (list (btree A)) (wm_list_btree A)).

Program Fixpoint count_tips (bts:(list (btree A)))
        {wf (lt_list_btree A) bts} : nat :=
  match bts with
      nil => 0
    | (cons Empty bts) => S (count_tips bts)
    | (cons (Node bt1 x bt2) bts) => (count_tips (cons bt1 (cons bt2 bts)))
  end.

Obligation 1.
unfold lt_list_btree. unfold make_mwlt. unfold wm_list_btree.
simpl. apply wlt_wlt_gen.
  auto.
  apply wlt_lt_gen; auto with arith.
Qed.

Obligation 2.
unfold lt_list_btree. unfold make_mwlt. unfold wm_list_btree.
apply wlt_lt_gen.
  auto.
  simpl. rewrite plus_assoc. auto with arith.
Qed.

Obligation 3.
by_Acc_mwlt lt_list_btree.
Defined.

Print Assumptions count_tips.


(* Simple inductive types: lists *)

Inductive list_nat :=
  nil
| cons : nat -> list_nat -> list_nat.

Check (cons 2 (cons 3 nil)).
(* [2, 3] *)

(* Mutual inductive types: even/odd lists *)

Inductive oddList :=
  ocons : nat -> evenList -> oddList
with evenList :=
  enil
| econs : nat -> oddList -> evenList.

(* indexed inductive types: vectors (fixed-size lists) *)
Inductive vector : nat -> Type :=
  vnil : vector 0
| vcons : forall n, nat -> vector n -> vector (1 + n).

Check (vcons _ 2 (vcons _ 3 vnil)).

(* inductive-inductive type: contextes and types of a dependent type theory
Γ ⊢ and Γ ⊢ A type
*)
(*
Inductive context :=
  cnil : context
| cext : forall (Γ : context), types Γ -> context
                                      (*
Γ ⊢   Γ ⊢ A
-----------
  Γ, A ⊢
                                      *)
  with types : context -> Type :=
    (* Γ ⊢ N type *)
    N : forall Γ, types Γ.

*)

(* Transport hell example:

   rev_append vector1 vector2 = rev vector1 ++ vector2
   rev_append [1,2] [3,4] = [2,1,3,4]

 *)
Fixpoint rev_append n1 (v1 : vector n1) n2 (v2 : vector n2)
         { struct v1 } : vector (n1 + n2).

  refine (
  match v1 with
    vnil => v2
  | vcons n1' hd tl =>
    rev_append n1' tl (1 + n2) (vcons n2 hd v2)
               end).

Check plus_n_Sm.

(* other example : lib.agda in omegatt *)


Require Import QArith.
Require Import Omega.
Require Import QvecArith PerceptronDef.
Require Import TerminationRefinement. (* needs inner_perceptron_MCE_sum_m_w *)

(************************************************************************************************************
         Defines an injection from natural numbers to rationals and proves some basic properties.
 ************************************************************************************************************)

Fixpoint inject_nat (n : nat) : Q :=
match n with
| O => 0
| S n' => 1 + (inject_nat n')
end.

Lemma Qnat_le : forall (A B : nat),
  (A <= B)%nat -> (inject_nat A) <= (inject_nat B).
Proof.
  intros. induction H. apply Qle_refl. simpl. rewrite <- Qplus_0_l.
  unfold Qplus; rewrite Qred_correct.
  apply (Qplus_le_compat 0 1 (inject_nat A) (inject_nat m)).
  unfold Qle. simpl. omega. apply IHle. Qed.

Lemma Qnat_lt : forall (A B : nat),
  (A < B)%nat -> (inject_nat A) < (inject_nat B).
Proof.
  intros. induction H. simpl. rewrite <- Qplus_0_l at 1. unfold Qplus; rewrite Qred_correct.
  apply Qplus_lt_le_compat. reflexivity. apply Qle_refl. simpl. rewrite <- Qplus_0_l.
  unfold Qplus; rewrite Qred_correct. apply Qplus_lt_le_compat. reflexivity.
  apply Qlt_le_weak. apply IHle. Qed.

Lemma Qnat_le_0 : forall (A : nat),
  0 <= (inject_nat A).
Proof.
  intros. induction A. apply Qle_refl. simpl. unfold Qplus; rewrite Qred_correct.
  apply (Qplus_le_compat 0 _ 0). apply Qlt_le_weak. reflexivity. apply IHA. Qed.

Lemma Square_preserves_le : forall (A B : Q),
  0 <= A -> 0 <= B ->
  A <= B -> A*A <= B*B.
Proof.
  intros. unfold Qle in H, H0, H1. unfold Qmult; repeat rewrite Qred_correct.
  unfold Qle. simpl. simpl in H, H0, H1.
  rewrite Z.mul_1_r in H, H0. assert (forall (A B C D : Z), (A*B*(C*D) = (A*C)*(B*D))%Z).
  intros. repeat rewrite <- Z.mul_assoc. rewrite (Z.mul_assoc B0 C D).
  rewrite (Z.mul_comm B0 C). rewrite (Z.mul_assoc C B0 D). reflexivity.
  repeat rewrite Pos2Z.inj_mul. rewrite H2. rewrite (H2 (Qnum B) _ _ _).
  apply (Zmult_le_compat _ _ _ _ H1 H1); apply (Z.mul_nonneg_nonneg _ _ H (Zle_0_pos _)). Qed.

 (****************************************************************************************
  Show that any element in MCE must be in T. Therefore properties of elements of T holds
  for elements of MCE.
  ****************************************************************************************)
Lemma In_inner_perceptron_MCE_In_T : forall {n : nat} (T : list ((Qvec n)*bool))
      (w0 : Qvec (S n)) (L : list ((Qvec n)*bool)) (w : Qvec (S n)) (f : Qvec n) (l : bool),
  inner_perceptron_MCE T w0 = Some (L, w) -> List.In (f, l) L -> List.In (f, l) T.
Proof.
  intros n T. induction T; intros. inversion H.
  destruct a as [f' l']. simpl in H. destruct (correct_class (Qvec_dot w0 (consb f')) l').
  apply IHT with w0 L w f l in H. right. apply H. apply H0.
  destruct (inner_perceptron_MCE T (Qvec_plus w0 (Qvec_mult_class l' (consb f')))) eqn:H1.
  destruct p as [L' w']. inversion H; subst; clear H.
  inversion H0. left. apply H. right. apply IHT with _ _ _ f l in H1. apply H1. apply H.
  inversion H; subst; clear H. inversion H0. left. apply H. inversion H. Qed.

Lemma In_MCE_In_T : forall {n : nat} (E : nat ) (T : list ((Qvec n)*bool)) (w0 : Qvec (S n)) (f : Qvec n) (l : bool),
  List.In (f, l) (MCE E T w0) -> List.In (f, l) T.
Proof.
  intros n E. induction E; intros. inversion H.
  simpl in H. destruct (inner_perceptron_MCE T w0) eqn: H0. destruct p as [L w'].
  apply List.in_app_or in H. inversion H.
  apply In_inner_perceptron_MCE_In_T with _ _ _ _ f l in H0. apply H0. apply H1.
  apply IHE in H1. apply H1. inversion H. Qed.

 (****************************************************************************************
                This section Proves the lower bound A*k^2 of length (MCE ...)
  ****************************************************************************************)
Definition limit_A {n : nat} (T : list ((Qvec n)*bool)) (wStar: Qvec (S n)) : Q :=
  Qmult (min_element_product wStar T) (min_element_product wStar T).

Lemma correct_class_w_dot_f_pos : forall {n : nat} (w : Qvec (S n)) (f : Qvec n) (l : bool),
 correct_class (Qvec_dot w (consb f)) l = true ->
 (Qvec_dot w (Qvec_mult_class l (consb f))) > 0.
Proof.
  intros. destruct l; unfold correct_class in H. simpl.
  destruct (class (Qvec_dot w (consb f))) eqn:H0. simpl in H.
  unfold class in H0. apply Bool.negb_true_iff in H.
  apply Qle_bool_imp_le in H0. apply Qeq_bool_neq in H.
  apply (Qle_neq_lt _ _ H0). unfold not. intros. apply H.
  symmetry. apply H1. inversion H.
  destruct (class (Qvec_dot w (consb f))) eqn:H0. inversion H. simpl in H.
  unfold class in H0. simpl in H0.
  assert (0 > (Qvec_dot w (consb f))). apply Qnot_le_lt. unfold not. intros.
  apply Qle_bool_iff in H1. rewrite H0 in H1. inversion H1.
  unfold Qvec_mult_class. rewrite Qvec_dot_mult_neg_1. unfold Qmult; rewrite Qred_correct.
  unfold Qlt. simpl. unfold Qlt in H1. simpl in H1.
  destruct (Qnum (Qvec_dot w (consb f))); try inversion H1.
  rewrite Z.mul_1_r. rewrite Z.mul_1_r in H1.
  apply Z.sgn_pos_iff. reflexivity. Qed.

Lemma correct_class_T_limit_A_pos : forall {n : nat} (T : list ((Qvec n)*bool)) (w : Qvec (S n)),
  correctly_classifiedP T w -> (limit_A T w) > 0.
Proof.
  intros n T; induction T; intros. reflexivity.
  inversion H; subst.
  unfold limit_A, min_element_product. fold (min_element_product w T).
  destruct T. apply correct_class_w_dot_f_pos in H4. unfold Qmult; rewrite Qred_correct.
  apply Qsquare_gt_0. unfold not. intros. apply Qlt_not_le in H4. apply H4.
  rewrite H0. apply Qle_refl.
  destruct (Qle_bool (Qvec_dot w (Qvec_mult_class l (consb f)))).
  apply correct_class_w_dot_f_pos in H4. unfold Qmult; rewrite Qred_correct.
  apply Qsquare_gt_0. unfold not. intros. apply Qlt_not_le in H4. apply H4.
  rewrite H0. apply Qle_refl. apply IHT in H2.
  unfold limit_A in H2. apply H2. Qed.

Lemma correct_class_T_min_element_product : forall {n : nat} (T : list ((Qvec n)*bool)) (w : Qvec (S n)),
  correctly_classifiedP T w -> 0 < (min_element_product w T).
Proof.
  intros. induction T. simpl. reflexivity. inversion H; subst. apply IHT in H2.
  apply correct_class_w_dot_f_pos in H4. destruct T. simpl. apply H4.
  unfold min_element_product. fold (min_element_product w (List.cons p T)).
  destruct (Qle_bool _ _); assumption. Qed.

Lemma correct_class_T_Qvec_normsq_wstar : forall {n : nat} (T : list ((Qvec n)*bool)) (w : Qvec (S n)),
  correctly_classifiedP T w -> (Qvec_normsq w) > 0 \/ T = List.nil.
Proof.
  intros n T; induction T; intros. right. reflexivity. inversion H; subst. apply IHT in H2.
  inversion H2. left. apply H0. subst. left. apply correct_class_w_dot_f_pos in H4.
  inversion H; subst. apply correct_class_w_dot_f_pos in H7. apply Qlt_not_eq in H7.
  apply Qnot_eq_sym in H7. apply Qvec_dot_Not_Qvec_zero in H7. destruct H7 as [Hw Hlf].
  apply (Qvec_normsq_Not_Qvec_Zero w Hw). Qed.

Lemma correct_class_T_Qvec_sum_dot_inner_perceptron_MCE : forall {n : nat}
                                   (T M: list ((Qvec n)*bool)) (wstar w0 w : Qvec (S n)),
  correctly_classifiedP T wstar -> inner_perceptron_MCE T w0 = Some (M, w) -> 0 <= Qvec_sum_dot wstar M.
Proof.
  intros n T M wstar; generalize dependent M; induction T; intros. inversion H0. destruct a as [f l].
  simpl in H0. inversion H; subst. destruct (correct_class (Qvec_dot w0 (consb f)) l). apply (IHT _ _ _ H5 H0).
  destruct (inner_perceptron_MCE T (Qvec_plus w0 (Qvec_mult_class l (consb f)))) eqn:H1. destruct p as [M' w'].
  inversion H0; subst. simpl. apply IHT in H1. apply correct_class_w_dot_f_pos in H6.
  apply Qlt_le_weak in H6. unfold Qplus; rewrite Qred_correct. apply (Qplus_le_compat 0 _ 0 _ H6 H1).
  apply H5. inversion H0; subst. simpl. apply correct_class_w_dot_f_pos in H6. apply Qlt_le_weak.
  unfold Qplus; rewrite Qred_correct. rewrite Qplus_0_r. apply H6. Qed.

Lemma correct_class_T_Qvec_sum_dot_MCE : forall {n : nat} (E : nat) (T : list ((Qvec n)*bool)) (w w0 : Qvec (S n)),
  correctly_classifiedP T w -> 0 <= Qvec_sum_dot w (MCE E T w0).
Proof.
  intros n E; induction E; intros. apply Qle_refl. unfold MCE. destruct (inner_perceptron_MCE T w0) eqn:H0.
  destruct p as [L w']. fold (MCE E T w'). rewrite Qvec_sum_dot_append.
  apply correct_class_T_Qvec_sum_dot_inner_perceptron_MCE with (wstar := w) in H0.
  apply IHE with (w0 := w') in H. unfold Qplus; rewrite Qred_correct.
  apply (Qplus_le_compat 0 _ 0 _ H0 H). apply H. apply Qle_refl. Qed.

Lemma Constant_le_element_le_sum_min_product : forall {n : nat} (L : list ((Qvec n)*bool)) (w : Qvec (S n)) (A : Q),
  0 < A ->
  (forall (f : Qvec n) (l : bool), List.In (f, l) L ->
   A <= (Qvec_dot w (Qvec_mult_class l (consb f)))) ->
   (0 <= (Qvec_sum_dot w L)) /\
  A * (inject_nat (length L)) <= (Qvec_sum_dot w L).
Proof.
  intros n L; induction L; intros. simpl. split; [|unfold Qmult; rewrite Qmult_0_r]; apply Qle_refl.
  destruct a as [f l]. simpl. unfold Qplus, Qmult; repeat rewrite Qred_correct.
  rewrite Qmult_plus_distr_r. rewrite Qmult_1_r.
  assert (H1 := H0 f l). assert (H2 : forall f l, List.In (f, l) L ->
  A <= (Qvec_dot w (Qvec_mult_class l (consb f)))). intros.
  assert (H3 : List.In (f0, l0) (List.cons (f, l) L)). right. apply H2. apply (H0 _ _ H3).
  assert (H3 := IHL w A H H2). assert (List.In (f, l) (List.cons (f, l) L)). left. reflexivity.
  apply H1 in H4. split. apply (Qplus_le_compat 0 _ 0 _). apply Qlt_le_weak in H.
  apply (Qle_trans 0 A _ H H4). apply H3. apply Qplus_le_compat. apply H4.
  unfold Qmult in H3; rewrite Qred_correct in H3; apply H3. Qed.

Lemma Element_T_le_limit_A : forall {n : nat} (T : list ((Qvec n)*bool)) (w : Qvec (S n)) (f : Qvec n) (l : bool),
 List.In (f, l) T -> min_element_product w T <= Qvec_dot w (Qvec_mult_class l (consb f)).
Proof.
  intros n T w; induction T; intros. inversion H. destruct a as [f' l']. inversion H. inversion H0; subst.
  unfold min_element_product. fold (min_element_product w T). destruct T. apply Qle_refl.
  destruct (Qle_bool _ _) eqn:H1. apply Qle_refl.
  assert (~ (Qvec_dot w (Qvec_mult_class l (consb f))) <= (min_element_product w (p :: T))).
  unfold not. intros. apply Qle_bool_iff in H2. rewrite H1 in H2. inversion H2.
  apply Qnot_le_lt in H2. apply Qlt_le_weak in H2. apply H2. apply IHT in H0.
  destruct T. inversion H. inversion H1; subst; apply Qle_refl. inversion H1.
  unfold min_element_product. fold (min_element_product w (p :: T)).
  destruct (Qle_bool _ _) eqn:H1. apply Qle_bool_iff in H1. apply (Qle_trans _ _ _ H1 H0).
  apply H0. Qed.

Lemma linearly_separable_lower_bound : forall {n : nat} (T : list ((Qvec n)*bool)) (w0 : Qvec (S n)),
  linearly_separable T -> (exists (A B : Q), forall (E : nat),
  0 < A /\ 0 < B /\
  A*(inject_nat (length (MCE E T w0)))*(inject_nat (length (MCE E T w0))) <=
  B*(Qvec_normsq (Qvec_sum (MCE E T w0)))).
Proof.
  intros. unfold linearly_separable in H. destruct H as [wstar H]. assert (H0 := H). assert (H1 := H).
  apply correct_class_T_limit_A_pos in H. apply correct_class_T_Qvec_normsq_wstar in H0.
  exists (limit_A T wstar). inversion H0. exists (Qvec_normsq wstar).
  intros E. split. apply H. split. apply H2.
  { apply (Qle_trans _ ((Qvec_dot wstar (Qvec_sum (MCE E T w0)))*(Qvec_dot wstar (Qvec_sum (MCE E T w0)))) _).
    { rewrite Qvec_dot_sum_eq. assert (H3 := H1). apply correct_class_T_min_element_product in H3.
      unfold limit_A. unfold Qmult; repeat rewrite Qred_correct. repeat rewrite <- Qmult_assoc.
      rewrite (Qmult_assoc _ (inject_nat _) (inject_nat _)).
      rewrite (Qmult_comm (min_element_product _ _) (inject_nat _)). repeat rewrite <- Qmult_assoc.
      rewrite Qmult_assoc. assert (H4 := Square_preserves_le (QArith_base.Qmult (min_element_product wstar T)
      (inject_nat (length (MCE E T w0)))) (Qvec_sum_dot wstar (MCE E T w0))). unfold Qmult in H4;
      repeat rewrite Qred_correct in H4. apply H4.
      rewrite <- (Qmult_0_l (inject_nat (length (MCE E T w0)))).
      apply Qlt_le_weak in H3. apply (Qmult_le_compat_r _ _ _ H3 (Qnat_le_0 _)).
      apply (correct_class_T_Qvec_sum_dot_MCE _ _ _ _ H1).
      rewrite <- (Qred_correct (QArith_base.Qmult (min_element_product _ _) _)).
      apply Constant_le_element_le_sum_min_product. apply H3.
      intros. apply In_MCE_In_T in H5. apply (Element_T_le_limit_A _ wstar _ _ H5).
    } apply Cauchy_Schwarz_inequality.
  } exists 1. intros E. split. apply H. split. reflexivity. subst. unfold limit_A. simpl.
  unfold Qmult at 3. simpl. unfold Qmult; repeat rewrite Qred_correct.
  repeat rewrite (Qmult_1_l). destruct E; simpl; rewrite Qmult_0_l; apply Qvec_normsq_nonneg. Qed.

 (****************************************************************************************
        This section will contains the proof of upper bound B*k on length (MCE ...)
  ****************************************************************************************)
Definition limit_B {n : nat} (T : list ((Qvec n)*bool)) (w0 : Qvec (S n)): Q :=
  Qminus (max_element_normsq T) (Qmult (2#1) (min_element_product w0 T)).

Lemma not_correct_z_mu_neg: forall {n:nat} (f : Qvec n) (l:bool) (w: Qvec (S n)),
  correct_class (Qvec_dot w (consb f)) l = false ->
  ((Qvec_dot w (Qvec_mult_class l (consb f)))) <= 0.
Proof.
  intros. unfold correct_class in H. destruct l.
  destruct (class (Qvec_dot w (consb f))) eqn:H0. simpl in H.
  apply Bool.negb_false_iff in H. apply Qeq_bool_iff in H.
  unfold Qvec_mult_class. rewrite H. apply Qle_refl.
  unfold class in H0. simpl. apply Qnot_lt_le. unfold not. intros.
  apply Qlt_le_weak in H1. apply Qle_bool_iff in H1. rewrite H0 in H1.
  inversion H1. apply andb_false_iff in H. unfold Qvec_mult_class.
  rewrite Qvec_dot_mult_neg_1. inversion H. apply eqb_false_iff in H0.
  assert (class (Qvec_dot w (consb f)) <> false). unfold not. intros.
  apply H0. symmetry. apply H1. apply not_false_is_true in H1.
  unfold class in H1. apply Qle_bool_iff in H1. unfold Qmult; rewrite Qred_correct.
  unfold Qle. unfold Qle in H1.
  simpl. simpl in H1. destruct (Qnum (Qvec_dot w (consb f))). reflexivity.
  rewrite Z.mul_1_r in H1. rewrite Z.mul_1_r. apply Zlt_le_weak. apply Zlt_neg_0.
  rewrite Z.mul_1_r in H1. assert (H2 := Zlt_neg_0 p). exfalso.
  apply Zle_not_lt in H1. apply H1. apply H2.
  apply Bool.negb_false_iff in H0. apply Qeq_bool_iff in H0. rewrite H0.
  unfold Qmult; rewrite Qred_correct. rewrite Qmult_0_r. apply Qle_refl. Qed.

Lemma inner_perceptron_MCE_mu_neg: forall {n:nat} (T L: (list ((Qvec n)*bool))) (w0 w: Qvec (S n)),
  inner_perceptron_MCE T w0 = Some (L, w) -> (Qmult (2#1) (min_element_product w0 T)) <= 0.
Proof.
  intros n T; induction T; intros; unfold Qmult; repeat rewrite Qred_correct. inversion H.
  destruct a as [f l]. simpl in H.
  destruct (correct_class (Qvec_dot w0 (consb f)) l) eqn:H0.
  { apply IHT in H. destruct T. simpl in H. unfold Qmult in H. rewrite Qmult_1_r in H.
    unfold Qle in H. simpl in H. omega. unfold min_element_product.
    fold (min_element_product w0 (List.cons p T)). destruct (Qle_bool _ _) eqn:H1.
    apply Qle_bool_iff in H1. apply Qmult_le_l with (z := 2#1) in H1. unfold Qmult in H.
    rewrite Qred_correct in H. apply (Qle_trans _ _ _ H1 H). reflexivity. unfold Qmult in H;
    rewrite Qred_correct in H; apply H.
  } apply not_correct_z_mu_neg in H0.
    destruct T. simpl. apply Qmult_le_l with (z := 2#1) in H0. rewrite Qmult_0_r in H0.
    apply H0. reflexivity. unfold min_element_product. fold (min_element_product w0 (List.cons p T)).
    destruct (Qle_bool _ _) eqn:H1. apply Qmult_le_l with (z := 2#1) in H0. rewrite Qmult_0_r in H0.
    apply H0. reflexivity.
    assert (Qvec_dot w0 (Qvec_mult_class l (consb f)) > (min_element_product w0 (p :: T))).
    apply Qnot_le_lt. unfold not. intros. apply Qle_bool_iff in H2. rewrite H1 in H2. inversion H2.
    apply Qlt_le_weak in H2. rewrite <- (Qmult_0_r (2#1)). apply Qmult_le_l. reflexivity.
    apply (Qle_trans _ _ _ H2 H0). Qed.

Theorem mu_neg_or_pos: forall {n:nat} (w0 : Qvec (S n)) (T : (list ((Qvec n)*bool))),
  (2#1)*(min_element_product w0 T) <= 0
  \/ (forall (E : nat), length (MCE E T w0) = 0%nat).
Proof.
  intros. induction T. right; intros. destruct E; reflexivity.
  inversion IHT. left. destruct a as [f l]. destruct T. simpl in H.
  unfold Qle in H. simpl in H. omega. unfold min_element_product.
  fold (min_element_product w0 (List.cons p T)). destruct (Qle_bool _ _) eqn:H0.
  apply Qle_bool_iff in H0. apply Qmult_le_l with (z := 2#1) in H0.
  unfold Qmult; rewrite Qred_correct; unfold  Qmult in H; rewrite Qred_correct in H.
  apply (Qle_trans _ _ _ H0 H). reflexivity. apply H.
  destruct (inner_perceptron_MCE (a :: T) w0) eqn:H0. destruct p as [L w].
  apply inner_perceptron_MCE_mu_neg in H0. left. apply H0.
  right. intros. destruct E. reflexivity. unfold MCE. rewrite H0. reflexivity. Qed.

Theorem max_element_normsq_pos : forall {n : nat} (T : (list ((Qvec n)*bool))),
  max_element_normsq T > 0.
Proof.
  intros. induction T. simpl. reflexivity.
  destruct a as [f l].
  destruct T.
  { simpl. apply Qvec_consb_gt_0.
  } unfold max_element_normsq. fold (max_element_normsq (List.cons p T)).
  destruct Qge_bool; [apply Qvec_consb_gt_0 | apply IHT ]. Qed.

Theorem limit_B_pos_or_MCE_nil : forall {n : nat} (w0 : Qvec (S n)) (T : (list ((Qvec n)*bool))),
  limit_B T w0 > 0 \/ (forall (E : nat), length (MCE E T w0) = 0%nat).
Proof.
  intros n w T. assert (H := mu_neg_or_pos w T). inversion H.
  left. assert (H1 := max_element_normsq_pos T). unfold limit_B.
  apply Qopp_le_compat in H0. assert (0 = - 0). reflexivity. rewrite <- H2 in H0.
  unfold Qminus. apply (Qplus_lt_le_compat 0 _ 0 _ H1 H0).
  right. apply H0. Qed.

Lemma MCE_Qvec_sum_normsq_expand : forall {n : nat} (E : nat) (T : list ((Qvec n)*bool)) (w0 : Qvec (S n)),
  Qvec_normsq (Qvec_sum (MCE E T w0)) == (Qvec_sum_normsq (MCE E T w0)) +
                              (2#1)*((Qvec_foil w0 (MCE E T w0)) - (Qvec_sum_dot w0 (MCE E T w0))).
Proof.
  intros. assert (H := Qvec_normsq_eq_sum_normsq_foil (MCE E T w0)).
  rewrite H; clear H. assert (H := Qvec_foil_0_w (Qvec_zero (S n)) w0 (MCE E T w0)).
  rewrite Qvec_plus_Qvec_zero in H. rewrite H. reflexivity. Qed.

Lemma Qvec_foil_inner_perceptron_MCE_w0_le_0 : forall {n : nat} (T M : list ((Qvec n)*bool)) (w0 w: Qvec (S n)),
  inner_perceptron_MCE T w0 = Some (M, w) -> Qvec_foil w0 M <= 0.
Proof.
  intros n T; induction T; intros. inversion H. destruct a as [f l].
  inversion H. destruct (correct_class (Qvec_dot w0 (consb f)) l) eqn:H2.
  apply (IHT _ _ _ H1). destruct (inner_perceptron_MCE T (Qvec_plus w0 (Qvec_mult_class l (consb f)))) eqn:H3.
  { destruct p as [M' w']. inversion H1; subst. simpl. apply IHT in H3.
    apply not_correct_z_mu_neg in H2. unfold Qplus; rewrite Qred_correct.
    apply (Qplus_le_compat _ 0 _ 0 H2 H3).
  } simpl in H1. inversion H1; subst. simpl. unfold Qplus; rewrite Qred_correct.
  rewrite Qplus_0_r. apply (not_correct_z_mu_neg _ _ _ H2). Qed.

Lemma Qvec_foil_MCE_w0_le_0 : forall {n : nat} (E : nat) (T : list ((Qvec n)*bool)) (w0 : Qvec (S n)),
  Qvec_foil w0 (MCE E T w0) <= 0.
Proof.
  intros n E. induction E; intros. apply Qle_refl.
  simpl. destruct (inner_perceptron_MCE T w0) eqn:H.
  { destruct p as [M w]. rewrite Qvec_foil_append. assert (H0 := H).
    apply Qvec_foil_inner_perceptron_MCE_w0_le_0 in H.
    apply inner_perceptron_MCE_sum_m_w in H0. rewrite Qvec_sum_sum_class. rewrite <- H0.
    assert (H1 := IHE T w). unfold Qplus; rewrite Qred_correct; apply (Qplus_le_compat _ 0 _ 0 H H1).
  } apply Qle_refl. Qed.

Lemma Constant_le_element_le_sum : forall {n : nat} (L : list ((Qvec n)*bool)) (w : Qvec (S n)) (A : Q),
  0 < A ->
  (forall (f : Qvec n) (l : bool), List.In (f, l) L ->
  (Qvec_normsq (consb f)) + ((-2#1)*(Qvec_dot w (Qvec_mult_class l (consb f)))) <= A) ->
  (Qvec_sum_normsq L) + ((-2#1)*(Qvec_sum_dot w L)) <= A * (inject_nat (length L)).
Proof.
  intros n L. induction L; intros. simpl. unfold Qmult; rewrite Qred_correct;
  repeat rewrite Qmult_0_r. apply Qle_refl.
  destruct a as [f l]. unfold Qvec_sum_normsq. fold (Qvec_sum_normsq L).
  unfold Qvec_sum_dot. fold (Qvec_sum_dot w L). simpl. unfold Qplus, Qmult; repeat rewrite Qred_correct.
  repeat rewrite Qmult_plus_distr_r. rewrite Qmult_1_r. repeat rewrite <- Qplus_assoc.
  rewrite (Qplus_assoc (Qvec_sum_normsq L) _ _).
  rewrite (Qplus_comm (Qvec_sum_normsq L) _). repeat rewrite <- Qplus_assoc. rewrite Qplus_assoc.
  apply Qplus_le_compat. assert (H1 := H0 f l). unfold Qplus, Qmult in H1; repeat rewrite Qred_correct in H1;
  apply H1. left. reflexivity. assert (H1 := IHL w A H). unfold Qplus, Qmult in H1;
  repeat rewrite Qred_correct in H1. apply H1. intros. apply H0. right. apply H2. Qed.

Lemma Qmult_neg_le : forall (x y z : Q),
  z < 0 -> x <= y -> z * y <= z * x.
Proof.
  intros. unfold Qmult; repeat rewrite Qred_correct.
  unfold Qle. unfold Qle in H0. simpl. unfold Qlt in H.
  simpl in H. rewrite Z.mul_1_r in H. destruct x, y, z. simpl.
  simpl in H0. simpl in H. repeat rewrite (Pos.mul_comm Qden1 _).
  repeat rewrite Pos2Z.inj_mul. repeat rewrite Z.mul_assoc.
  apply Zmult_le_compat_r. repeat rewrite <- Z.mul_assoc.
  apply Z.mul_le_mono_nonpos_l. apply (Zlt_le_weak _ _ H).
  apply H0. apply Zle_0_pos. Qed.

Lemma Element_T_le_limit_B : forall {n : nat} (T : list ((Qvec n)*bool)) (w : Qvec (S n)) (f : Qvec n) (l : bool),
 List.In (f, l) T ->
       (Qvec_normsq (consb f)) + ((-2#1)*(Qvec_dot w (Qvec_mult_class l (consb f)))) <= (limit_B T w).
Proof.
  intros n T. induction T; intros. inversion H. unfold limit_B.
  unfold Qminus. unfold Qmult at 2. rewrite <- Qred_opp. rewrite Qopp_mult_distr_l.
  fold (Qmult (Qopp (2#1)) (min_element_product w (a :: T))).
  assert (- (2#1) = (-2#1)). reflexivity. repeat rewrite H0; clear H0. inversion H.
  { subst. unfold max_element_normsq, min_element_product. fold (max_element_normsq T).
    fold (min_element_product w T). destruct T. unfold Qplus; rewrite Qred_correct. apply Qle_refl.
    unfold Qge_bool. destruct (Qle_bool (max_element_normsq _) _) eqn:H0.
    destruct (Qle_bool (Qvec_dot _ _) _) eqn:H1. unfold Qplus; rewrite Qred_correct; apply Qle_refl.
    assert (min_element_product w (p :: T) < Qvec_dot w (Qvec_mult_class l (consb f))).
    apply Qnot_le_lt. unfold not. intros. apply Qle_bool_iff in H2. rewrite H1 in H2. inversion H2.
    unfold Qplus. rewrite Qred_correct. apply Qplus_le_compat. apply Qle_refl. apply Qlt_le_weak in H2.
    apply Qmult_neg_le. reflexivity. apply H2.
    assert (Qvec_normsq (consb f) <= max_element_normsq (p :: T)).
    apply Qlt_le_weak. apply Qnot_le_lt. unfold not. intros.
    apply Qle_bool_iff in H1. rewrite H0 in H1. inversion H1. unfold Qplus; rewrite Qred_correct.
    apply (Qplus_le_compat _ _ _ _ H1). clear H0. clear H1.
    destruct (Qle_bool (Qvec_dot w _) _) eqn:H2. apply Qle_refl.
    apply Qmult_neg_le. reflexivity. apply Qlt_le_weak. apply Qnot_le_lt.
    red. intros. apply Qle_bool_iff in H0. rewrite H2 in H0. inversion H0.
  } apply IHT with (w := w) in H0. destruct a as [f' l'].
  unfold max_element_normsq, min_element_product. fold (max_element_normsq T). fold (min_element_product w T).
  destruct T. inversion H. inversion H1; subst. unfold Qplus; rewrite Qred_correct. apply Qle_refl. inversion H1.
  unfold Qge_bool. destruct (Qle_bool (max_element_normsq _) _) eqn:H1. apply Qle_bool_iff in H1.
  destruct (Qle_bool (Qvec_dot w _) _) eqn:H2. unfold Qopp; simpl. apply Qle_bool_iff in H2.
  unfold limit_B in H0. apply (Qle_trans _ _ _ H0). apply (Qplus_le_compat _ _ _ _ H1).
  unfold Qmult. rewrite <- Qred_opp.
  rewrite Qopp_mult_distr_l. apply Qmult_neg_le. reflexivity. apply H2.
  apply (Qle_trans _ _ _ H0). unfold limit_B. unfold Qminus. unfold Qmult.
  rewrite <- Qred_opp. rewrite Qopp_mult_distr_l.
  apply (Qplus_le_compat _ _ _ _ H1). assert (-(2#1) = -2#1). reflexivity. rewrite H3.
  apply Qle_refl. apply (Qle_trans _ _ _ H0). unfold limit_B. unfold Qminus.
  unfold Qmult. rewrite <- Qred_opp. rewrite Qopp_mult_distr_l. apply Qplus_le_compat. apply Qle_refl.
  apply Qmult_neg_le. reflexivity. clear H1. destruct (Qle_bool (Qvec_dot w _) _) eqn:H1.
  apply Qle_bool_iff in H1. apply H1. apply Qle_refl. Qed.

(* The upper bound of errors does not require T to be linearly seperable *)
Lemma MCE_upper_bound : forall {n : nat} (T : list ((Qvec n)*bool)) (w0 : Qvec (S n)),
 exists (B : Q), forall (E : nat),
 0 < B /\
 Qvec_normsq (Qvec_sum (MCE E T w0)) <= B * inject_nat (length (MCE E T w0)).
Proof.
  intros. assert (H := limit_B_pos_or_MCE_nil w0 T). inversion H.
  { exists (limit_B T w0). intros E. split. apply H0.
    unfold limit_B, Qminus. unfold Qmult. rewrite <- Qred_opp.
    rewrite Qopp_mult_distr_l. assert (-(2#1) = (-2#1)). reflexivity.
    rewrite H1; clear H1. rewrite MCE_Qvec_sum_normsq_expand.
    assert ((Qvec_sum_normsq (MCE E T w0)) + (2#1)*((Qvec_foil w0 (MCE E T w0)) - (Qvec_sum_dot w0 (MCE E T w0)))
                                       <= (Qvec_sum_normsq (MCE E T w0)) + (-2#1)*(Qvec_sum_dot w0 (MCE E T w0))).
    unfold Qminus. unfold Qmult, Qplus; repeat rewrite Qred_correct.
    rewrite Qmult_plus_distr_r. assert (H3 := Qvec_foil_MCE_w0_le_0 E T w0).
    apply Qplus_le_compat. apply Qle_refl. rewrite <- (Qplus_0_l (_ (-2#1) (Qvec_sum_dot _ _))).
    apply Qplus_le_compat. rewrite <- (Qmult_0_r (2#1)). apply Qmult_le_l. reflexivity. apply H3.
    rewrite <- Qopp_mult_distr_r. rewrite Qopp_mult_distr_l. rewrite <- Qred_correct.
    fold (Qmult (Qopp (2#1)) (Qvec_sum_dot w0 (MCE E T w0))). rewrite <- (Qred_correct (_ (-2#1) _)) .
    fold (Qmult (-2#1) (Qvec_sum_dot w0 (MCE E T w0))). apply Qmult_neg_le; [reflexivity | apply Qle_refl].
    apply (Qle_trans _ _ _ H1). apply Constant_le_element_le_sum. unfold limit_B, Qminus in H0.
    unfold Qmult in H0. rewrite <- Qred_opp in H0.
    rewrite Qopp_mult_distr_l in H0. apply H0. intros. apply In_MCE_In_T in H2.
    apply Element_T_le_limit_B with (w:= w0) in H2. unfold limit_B in H2. unfold Qminus in H2.
    unfold Qmult in H2. rewrite <- Qred_opp in H2. rewrite Qopp_mult_distr_l in H2. apply H2.
  } exists 1. intros E. split. reflexivity. rewrite H0. simpl. assert (H1 := H0 E). unfold Qmult.
  rewrite Qmult_0_r. destruct (MCE E T w0); simpl. rewrite Qvec_normsq_Qvec_0. apply Qle_refl. inversion H1. Qed.

 (****************************************************************************************
    Combine Upper and Lower Bound into single Lemma.
  ****************************************************************************************)
Lemma linearly_separable_bound: forall {n : nat} (T : list ((Qvec n)*bool)) (w0 : Qvec (S n)),
  linearly_separable T -> (exists (A B C : Q), forall (E : nat),
  0 < A /\ 0 < B /\ 0 < C /\
  A * (inject_nat (length (MCE E T w0))) *(inject_nat (length (MCE E T w0))) <=
  B * Qvec_normsq (Qvec_sum (MCE E T w0)) <=
  C * (inject_nat (length (MCE E T w0)))).
Proof.
  intros. apply (linearly_separable_lower_bound T w0) in H. destruct H as [A [B H]].
  assert (H0 := MCE_upper_bound T w0). destruct H0 as [C H0].
  exists A. exists B. exists (B*C). intros. split. apply (H E). split. apply (H E). split.
  rewrite <- (Qmult_0_l C). unfold Qmult; rewrite Qred_correct. apply Qmult_lt_r. apply (H0 E). apply (H E).
  split. apply H. unfold Qmult; repeat rewrite Qred_correct. rewrite (Qmult_comm B _). rewrite <- Qmult_assoc.
  rewrite (Qmult_comm _ (_ C _)). apply Qmult_le_compat_r. assert (H1 := H0 E).
  unfold Qmult in H1; rewrite Qred_correct in H1. apply H1. apply Qlt_le_weak. apply (H E). Qed.


Require Import Unicode.Utf8.
Require Import Classical.

(* Level 1 *)
(* `split`: Prove each part of a conjunction separately *)
(* Goal of the form `A ∧ B` *)

Lemma example_1_adv_add (P Q : Prop) (p : P) (q : Q) : P ∧ Q.
Proof.
  split.
  exact p.
  apply q.
Qed.

(* Level 2 *)
(* `destruct f as [g h]`: Split conjunction hypothesis into two child hypotheses *)
(* Hypothesis of the form `A ∧ B` *)

Lemma and_symm (P Q : Prop) : P ∧ Q → Q ∧ P.
Proof.
  intro f.
  destruct f as [p q].
  split.
  exact q.
  exact p.
Qed.

(* Level 3 *)

Lemma and_trans (P Q R : Prop) : P ∧ Q → Q ∧ R → P ∧ R.
Proof.
  intro f.
  intro g.
  destruct f as [p q].
  destruct g as [q' r].
  split.
  exact p.
  exact r.
Qed.

(* Level 4 *)

Lemma iff_trans (P Q R : Prop) : (P ↔ Q) → (Q ↔ R) → (P ↔ R).
Proof.
  intro f.
  intro g.
  destruct f as [pq qp].
  destruct g as [gr rg].
  split.
  intro p.
  apply gr.
  apply pq.
  exact p.
  intro r.
  apply qp.
  apply rg.
  exact r.
Qed.

(* Level 5 *)
(* Lean `apply f.1` ~ Coq ??? *)

Lemma iff_trans' (P Q R : Prop) : (P ↔ Q) → (Q ↔ R) → (P ↔ R).
Proof.
  intro f.
  intro g.
  rewrite f.
  rewrite g.
  reflexivity.
Qed.

(* Level 6 *)
(* `left`: Prove LHS of disjunction *)
(* Goal of the form `A ∨ B` *)

(* `right`: Prove RHS of disjunction *)
(* Goal of the form `A ∨ B` *)

Lemma example_6_adv_add (P Q : Prop) : Q → (P ∨ Q).
Proof.
  intro q.
  right.
  exact q.
Qed.

(* Level 7 *)
(* `destruct f as [g|h]`: Split disjunction hypothesis into two child hypotheses *)
(* Hypothesis of the form `A ∨ B` *)

Lemma or_symm (P Q : Prop) : P ∨ Q → Q ∨ P.
Proof.
  intro f.
  destruct f as [p|q].
  right.
  exact p.
  left.
  exact q.
Qed.

(* Level 8 *)
(* `assumption`: Solve goal that is already a hypothesis *)
(* `tactic1; tactic2`: Run tactic2 on all sub-goals produced by tactic1 *)

Lemma and_or_distrib_left (P Q R : Prop) : P ∧ (Q ∨ R) ↔ (P ∧ Q) ∨ (P ∧ R).
Proof.
  split.
  intro f.
  destruct f as [p qr].
  destruct qr as [q|r].
  left.
  split; assumption.
  right.
  split; assumption.
  intro f.
  destruct f as [pq|pr].
  destruct pq as [p q].
  split.
  exact p.
  left.
  exact q.
  destruct pr as [p r].
  split.
  exact p.
  right.
  exact r.
Qed.

(* Level 9 *)
(* `exfalso`: Change any goal into `False` *)

Lemma contra (P Q : Prop) : (P ∧ ¬ P) → Q.
Proof.
  intro f.
  destruct f as [p np].
  exfalso.
  apply np.
  exact p.
Qed.

(* Level 10 *)
(* `destruct (classic P) as [p|np]`: Do case distinction on `P` *)
(* In other words, handle cases `P` and `¬P` separately *)
(* Requires classical logic `Classical` *)

Lemma contrapositive2 (P Q : Prop) : (¬ Q → ¬ P) → (P → Q).
Proof.
  intro f.
  intro p'.
  destruct (classic P) as [p|np];
  destruct (classic Q) as [q|nq];
  tauto.
Qed.


Require Export P01.

(** **** Problem #2: 1 star (factorial) *)
(** Recall the standard factorial function:
<<
    factorial(0)  =  1
    factorial(n)  =  n * factorial(n-1)     (if n>0)
>>
    Translate this into Coq.

    Note that plus and multiplication are already defined in Coq.
    use "+" for plus and "*" for multiplication.
*)

Eval compute in 3 * 5.
Eval compute in 3+5*6.

Fixpoint factorial (n:nat) : nat :=
  match n with
  | O => 1
  | S n' => n * factorial n' end.

Example test_factorial1:          (factorial 3) = 6.
Proof. reflexivity. Qed.
Example test_factorial2:          (factorial 5) = 10 * 12.
Proof. reflexivity. Qed.


(* A sorting example :
   (C) Yves Bertot, Pierre Casteran
*)

(**
This version uses some new features of Coq : Type Classes and User Defined Relations.

The function called "aux" in the book has been renamed to "insert" and "equiv" has
been renamed to "permutation".
*)

Require Import List  ZArith RelationClasses Morphisms
               Extraction.
Open Scope Z_scope.

Inductive sorted : list Z -> Prop :=
  | sorted0 : sorted nil
  | sorted1 : forall z:Z, sorted (z :: nil)
  | sorted2 :
      forall (z1 z2:Z) (l:list Z),
        z1 <= z2 ->
        sorted (z2 :: l) -> sorted (z1 :: z2 :: l).

Hint Constructors sorted :  sort.

Lemma sort_2357 :
 sorted (2 :: 3 :: 5 :: 7 :: nil).
Proof.
 auto with sort zarith.
Qed.

(**
  inversion lemma
*)

Theorem sorted_inv :
 forall (z:Z) (l:list Z), sorted (z :: l) -> sorted l.
Proof.
 intros z l H; inversion H; auto with sort.
Qed.

(*  Number of occurrences of z in l *)

Fixpoint nb_occ (z:Z) (l:list Z) {struct l} : nat :=
  match l with
  | nil => 0%nat
  | (z' :: l') =>
      match Z_eq_dec z z' with
      | left _ => S (nb_occ z l')
      | right _ => nb_occ z l'
      end
  end.

Example ex0 : nb_occ 3 (3 :: 7 :: 3 :: nil) = 2%nat.
Proof. reflexivity. Qed.

(* list l' is a permutation of list l *)

Definition permutation (l l':list Z) : Prop :=
    forall z:Z, nb_occ z l = nb_occ z l'.

(* permutation is an equivalence ! *)

Instance permutation_refl : Reflexive permutation.
Proof.
 intro x; red; trivial.
Qed.

Instance  permutation_sym : Symmetric permutation.
Proof.
 intros x y Hxy ; unfold permutation; auto.
Qed.

Instance permutation_trans : Transitive permutation.
Proof.
 intros l l' l'' H H0 z; rewrite H; now apply H0.
Qed.

Lemma permutation_cons :
 forall (z:Z) (l l':list Z), permutation l l' ->
                             permutation (z :: l) (z :: l').
Proof.
 intros z l l' H z'; simpl; case (Z_eq_dec z' z); auto.
Qed.

Instance cons_proper : Proper (eq ==> permutation ==> permutation) (@cons Z).
Proof.
 intros x y Hxy l l' Hll'; subst y; now apply permutation_cons.
Qed.

Lemma permutation_transpose :
 forall (a b:Z) (l l':list Z),
   permutation l l' ->
   permutation (a :: b :: l) (b :: a :: l').
Proof.
 intros a b l l' H z; simpl.
 case (Z_eq_dec z a); case (Z_eq_dec z b);
  simpl; case (H z); auto.
Qed.

Hint Resolve permutation_cons permutation_refl permutation_transpose : sort.

(* insertion of z into l at the right place
   (assuming l is sorted)
*)

Fixpoint insert (z:Z) (l:list Z)  : list Z :=
  match l with
  | nil => z :: nil
  | cons a l' =>
      match Z_le_gt_dec z a with
      | left _ =>  z :: a :: l'
      | right _ => a :: (insert z l')
      end
  end.

Lemma insert_permutation : forall (l:list Z) (x:Z),
                  permutation (x :: l) (insert x l).
Proof.
 induction l as [|a l0 H]; simpl ; auto with sort.
 -  intros x; case (Z_le_gt_dec x a);
      simpl; auto with sort.
    +  intro H0; apply permutation_trans with (a :: x :: l0);
       auto with sort.
Qed.

Lemma insert_sorted :
 forall (l:list Z) (x:Z), sorted l -> sorted (insert x l).
Proof.
 intros l x H; induction  H; simpl; auto with sort.
 -  case (Z_le_gt_dec x z); simpl;  auto with sort zarith.
 -   revert H H0 IHsorted; simpl;
     case (Z_le_gt_dec x z2) ,  (Z_le_gt_dec x z1);
       simpl; auto with sort zarith.
Qed.

(* the sorting function *)

Definition sort :
  forall l:list Z, {l' : list Z | permutation l l' /\ sorted l'}.
 induction l as [| a l IHl].
 -  exists (nil (A:=Z)); split; auto with sort.
 -  case IHl; intros l' [H0 H1].
    exists (insert a l'); split.
    + transitivity (a::l').
      * now  rewrite H0.
      * apply insert_permutation.
    +  now apply insert_sorted.
Defined.

Extraction "insert-sort" insert sort.


Require Import HoTT Nat.

Fixpoint plus (n m : nat) :=
  match n with
    | O => m
    | S n' => S (n' + m)
  end

where "n + m" := (plus n m) : nat_scope.

Definition lt (n m : nat) := {k : nat & n + S k = m}.
Notation "n < m" := (lt n m) (at level 70) : nat_scope.

Theorem O_S : forall n : nat, O <> S n.
Proof.
  intros n H. apply nat_encode in H. contradiction.
Defined.

Lemma plus_n_Sm : forall n m : nat, n + S m = S (n + m).
Proof.
  intro n. induction n.
  - reflexivity.
  - intro m. apply (ap S). apply IHn.
Defined.

Lemma n_lt_O : forall n, ~ (n < O).
Proof.
  intros n w.
  induction w as [m p].
  simpl in p.
  apply (O_S (n + m)).
  path_via (n + S m).
  apply plus_n_Sm.
Defined.

Lemma plus_n_O : forall n, n = n + O.
Proof.
  induction n; simpl.
  - reflexivity.
  - apply (ap S IHn).
Defined.

Lemma plus_comm : forall n m, n + m = m + n.
Proof.
  induction n.
  - intro m. apply plus_n_O.
  - intro m. refine (_ @ (plus_n_Sm _ _)^). apply (ap S). apply IHn.
Defined.

Lemma plus_n_k : forall n k, n + k = O -> n = O.
Proof.
  induction n.
  - reflexivity.
  - intros k p. simpl in p. contradiction (O_S _ p^).
Defined.

Lemma plus_O_r (n : nat) : n + O = n.
Proof.
  induction n.
  - reflexivity.
  - apply (ap S IHn).
Defined.

Lemma cancelL_plus : forall n m k, n + m = n + k -> m = k.
Proof.
  induction n.
  - intros m k p. apply p.
  - intros m k p. apply IHn. apply S_inj. apply p.
Defined.

Lemma cancelR_plus : forall n m k, m + n = k + n -> m = k.
Proof.
  induction n.
  - intros m k p.
    path_via (m + O). symmetry. apply plus_O_r.
    path_via (k + O). apply plus_O_r.
  - intros m k p. apply IHn.
    apply S_inj. simpl.
    path_via (m + S n). symmetry. apply plus_n_Sm.
    path_via (k + S n). apply plus_n_Sm.
Defined.

Global Instance ishprop_lt : forall n m, IsHProp (n < m).
Proof.
  intros n m. apply hprop_allpath. intros x y.
  induction x as [k p], y as [r q].
  apply path_sigma_hprop. simpl.
  apply (S_inj _ _). apply (cancelL_plus n).
  path_via m.
Defined.

Lemma S_predn (n : nat) : n <> O -> S (pred n) = n.
Proof.
  induction n; intro p; [contradiction p |]; reflexivity.
Defined.

Fixpoint minus (n m : nat) : nat :=
  match n, m with
    | O, _ => n
    | S k, O => n
    | S k, S l => k - l
  end

where "n - m" := (minus n m) : nat_scope.

Lemma minus_O_r (n : nat) : n - O = n.
Proof.
  by induction n.
Defined.

Lemma minus_n_n (n : nat) : n - n = O.
Proof.
  induction n.
  - reflexivity.
  - apply IHn.
Defined.

Lemma not_nltn (n : nat) : ~ (n < n).
Proof.
  intro p. induction p as [k p].
  apply (O_S k). symmetry.
  apply (cancelL_plus n).
  path_via n.
  symmetry. apply plus_O_r.
Defined.

Fixpoint mult (n m : nat) : nat :=
  match n with
    | O => O
    | S n' => m + n' * m
  end

where "n * m" := (mult n m) : nat_scope.

Lemma cancelL_plus_lt (n m k : nat) : (n + m < n + k) -> (m < k).
Proof.
  induction n.
  - apply idmap.
  - intro p. apply IHn.
    destruct p as [l r]. exists l. apply S_inj. path_via (S n + m + S l).
Defined.

Lemma plus_assoc : forall n m k, (n + m) + k = n + (m + k).
Proof.
  induction n.
  - reflexivity.
  - intros m k. simpl. apply (ap S (IHn m k)).
Defined.

Lemma mult_1_r (n : nat) : n * 1 = n.
Proof.
  induction n.
  - reflexivity.
  - simpl. apply (ap S IHn).
Defined.

Lemma mult_O_r (n : nat) : n * O = O.
Proof.
  induction n.
  - reflexivity.
  - apply IHn.
Defined.

Lemma nat_dist_l (n m k : nat) : n * (m + k) = (n * m) + (n * k).
Proof.
  induction n.
  - reflexivity.
  - refine ((ap (plus (m + k)) IHn) @ _).
    refine (_ @ (plus_assoc _ _ _)).
    refine ((plus_assoc _ _ _)^ @ _).
    apply (ap (fun s => s + (n * k))).
    refine ((plus_assoc _ _ _) @ _).
    refine (_ @ (plus_assoc _ _ _)^).
    apply (ap (plus m)).
    apply plus_comm.
Defined.

Lemma nat_dist_r (n m k : nat) : (n + m) * k = (n * k) + (m * k).
Proof.
  induction n.
  - reflexivity.
  - refine (_ @ (plus_assoc _ _ _)^).
    apply (ap (plus k) IHn).
Defined.

Lemma mult_assoc (n m k : nat) : (n * m) * k = n * (m * k).
Proof.
  induction n.
  - reflexivity.
  - simpl.
    refine (_ @ (ap (fun s => (m * k) + s) IHn)).
    apply (nat_dist_r m (n * m) k).
Defined.

Lemma mult_comm (n m : nat) : n * m = m * n.
Proof.
  induction n.
  - symmetry. apply mult_O_r.
  - refine ((ap (plus m) IHn) @ _).
    refine (_ @ (nat_dist_l m 1 n)^).
    f_ap. symmetry. apply mult_1_r.
Defined.

(** * Exponential *)

Fixpoint exp (b e : nat) :=
  match e with
    | O => S O
    | S e' => b * (exp b e')
  end.

Lemma exp_sum (b n m : nat) : (exp b (n + m)) = (exp b n) * (exp b m).
Proof.
  induction n.
  - symmetry. apply plus_O_r.
  - refine (_ @ (mult_assoc _ _ _)^). simpl. f_ap.
Defined.

Lemma exp_power (b n m : nat) : (exp (exp b n) m) = (exp b (n * m)).
Proof.
  induction m.
  - apply (ap (exp b) (mult_O_r n))^.
  - refine ((ap (mult (exp b n)) IHm) @ _).
    refine ((exp_sum _ _ _)^ @ _). f_ap.
    refine (_ @ (mult_comm _ _)^).
    simpl. f_ap. apply mult_comm.
Defined.

(** * Factorial *)

Fixpoint fact (n : nat) : nat :=
  match n with
    | O => (S O)
    | S n' => S n' * fact n'
  end.

Lemma fact_ne_O : forall n : nat, fact n <> O.
Proof.
  induction n.
  - intro p. apply (O_S _ p^).
  - simpl. intro p. apply plus_n_k in p. contradiction.
Defined.

Lemma O_lt_Sn (n : nat) : O < S n.
Proof.
  exists n. reflexivity.
Defined.

Definition le (n m : nat) := {k : nat & n + k = m}.
Notation "n <= m" := (le n m) (at level 70) : nat_scope.

Lemma le_partition (n : nat) : forall m, (m <= n) + (n < m).
Proof.
  induction n, m.
  - left. exists O. reflexivity.
  - right. apply O_lt_Sn.
  - left. exists (S n). reflexivity.
  - destruct (IHn m) as [H | H]; [left | right];
      destruct H as [k p]; exists k; simpl; apply (ap S); apply p.
Defined.

(** * Division *)

Fixpoint sgn (n : nat) :=
  match n with
    | O => O
    | S n' => (S O)
  end.

Definition adf (n m : nat) := (n - m) + (m - n).

Lemma dec_nat (n m : nat) : (n = m) + ~ (n = m).
Admitted.

Fixpoint rem (n m : nat) :=
  match n with
    | O => O
    | S n' => match m with
                | O => O
                | S m' => match (dec_nat (rem n' (S m')) m') with
                            | inl _ => O
                            | inr _ => S (rem n' (S m'))
                          end
              end
  end.

Fixpoint quot (n m : nat) :=
  match n with
    | O => O
    | S n' => match m with
                | O => O
                | S m' => match (dec_nat (rem (S n') m') O) with
                            | inl _ => S (quot n' (S m'))
                            | inr _ => quot n' (S m')
                          end
              end
  end.

Definition nPk (n k : nat) :=
  match (le_partition n k) with
    | inl _ => quot (fact n) (fact (n - k))
    | inr _ => O
  end.

Definition nCk (n k : nat) := quot (nPk n k) (fact k).

Lemma quot_n_1 (n : nat) : quot n 1 = n.
Proof.
  induction n.
  - reflexivity.
  - simpl. destruct (dec_nat O O).
    + apply (ap S IHn).
    + contradiction (n0 1).
Defined.

Lemma quot_n_n (n : nat) : (n <> O) -> (quot n n = 1%nat).
Admitted.

Lemma quot_plus (n m d : nat) : (quot n d) + (quot m d) = quot (n + m) d.
Admitted.

Lemma quot_mult (n1 n2 d1 d2 : nat)
  : (quot n1 d1) * (quot n2 d2) = quot (n1 * n2) (d1 * d2).
Admitted.

Lemma nCO (n : nat) : nCk n O = (S O).
Proof.
  induction n.
  - unfold nCk. unfold nPk. simpl. destruct (dec_nat O O).
    + simpl. destruct (dec_nat O O).
      * reflexivity.
      * contradiction (n 1).
    + contradiction (n 1).
  - unfold nCk in *. unfold nPk in *. simpl in *.
    refine ((quot_n_1 _) @ _). apply quot_n_n. apply (fact_ne_O (S n)).
Defined.

Lemma nCn (n : nat) : nCk n n = (S O).
Proof.
  induction n.
  - unfold nCk. refine ((quot_n_1 _) @ _).
    unfold nPk. simpl. destruct (dec_nat O O).
    + reflexivity.
    + contradiction (n 1).
  - unfold nCk. simpl. unfold nPk.
    destruct (le_partition (S n) (S n)).
    + rewrite minus_n_n. rewrite quot_n_1. apply quot_n_n.
      apply (fact_ne_O (S n)).
    + destruct l as [m p].
      contradiction (O_S m). symmetry.
      apply (cancelL_plus (S n)). refine (p @ _).
      symmetry. apply plus_O_r.
Defined.

Lemma nPO (n : nat) : nPk n O = (S O).
Proof.
  induction n.
  - unfold nPk. simpl. destruct (dec_nat O O).
    + reflexivity.
    + contradiction (n 1).
  - unfold nPk. simpl. apply quot_n_n.
    apply (fact_ne_O (S n)).
Defined.

Lemma OPO : nPk O O = (S O).
Proof.
  unfold nPk. simpl. destruct (dec_nat O O).
  - reflexivity.
  - contradiction (n 1).
Defined.

Lemma OPn (n : nat) : (n <> O) -> (nPk O n = O).
Proof.
  intro p. unfold nPk. destruct (le_partition O n).
  - contradiction p. destruct l as [m q]. apply (plus_n_k _ _ q).
  - reflexivity.
Defined.

Lemma nPn (n : nat) : nPk n n = fact n.
Proof.
  induction n.
  - unfold nPk. simpl. destruct (dec_nat O O).
    + reflexivity.
    + contradiction (n 1).
  - unfold nPk. simpl. destruct (le_partition n n).
    + path_via (quot (fact (S n)) (S O)).
      * f_ap. path_via (fact O). f_ap. apply minus_n_n.
      * apply quot_n_1.
    + contradiction (not_nltn _ l).
Defined.

Lemma SnPSk (n k : nat) : nPk (S n) (S k) = (S n) * (nPk n k).
Proof.
  unfold nPk. simpl. destruct (le_partition n k).
  - symmetry.
    path_via (quot (fact n) (fact (n - k)) + quot (n * (fact n)) (fact (n - k))).
    + f_ap. path_via (quot n 1 * quot (fact n) (fact (n - k))).
      * f_ap. symmetry. apply quot_n_1.
      * refine ((quot_mult _ _ _ _) @ _). f_ap. apply plus_O_r.
    + apply quot_plus.
  - simpl. symmetry. apply mult_O_r.
Defined.

Lemma nP1 (n : nat) : nPk n 1 = n.
Proof.
  induction n.
  - reflexivity.
  - unfold nPk. destruct (le_partition (S n) 1).
    + refine ((quot_plus _ _ _)^ @ _).
      path_via (1 + quot (n * fact n) (fact ((S n) - 1))).
      * refine (ap (fun s => s + quot (n * fact n) (fact ((S n) - 1))) _).
        simpl. path_via (quot (fact n) (fact n)). f_ap. f_ap. apply minus_O_r.
        apply quot_n_n. apply (fact_ne_O n).
      * apply (ap S). path_via (quot (n * fact n) (1 * fact n)).
        f_ap. simpl. refine (ap fact (minus_O_r n) @ (plus_O_r _)^).
        refine ((quot_mult _ _ _ _)^ @ _).
        refine (_ @ (quot_n_1 n)). refine (_ @ (mult_1_r _)).
        apply (ap (mult (quot n 1))). apply quot_n_n. apply fact_ne_O.
    + destruct l as [m p].
      simpl in p. apply S_inj in p.
      contradiction (O_S (n + m)). refine (p^ @ _).
      apply plus_n_Sm.
Defined.

Lemma foo (n k : nat)
  : quot n.+1 k.+1 = 1 + quot (nPk n k.+1) (fact k.+1).
Proof.
  induction k.
  - refine ((quot_n_1 _) @ _). apply (ap S).
    symmetry. refine ((quot_n_1 _) @ (nP1 _)).
Admitted.

Lemma SnCSk (n k : nat) : nCk (S n) (S k) = (nCk n k) + (nCk n (S k)).
Proof.
Admitted.


Require Import nat.
Require Import syntax.
Require Import state.
Require Import fold_constants.

Example fold_aexp1 : fold_constants_aexp
    (AMult (APlus (ANum 1) (ANum 2)) (AKey x)) = AMult (ANum 3) (AKey x).
Proof. reflexivity. Qed.

Example fold_aexp2 : fold_constants_aexp
    (AMinus
        (AKey x)
        (APlus
            (AMult
                (ANum 0)
                (ANum 6))
             (AKey y))) =
    (AMinus
        (AKey x)
        (APlus
            (ANum 0)
            (AKey y))).
Proof. reflexivity. Qed.

Example fold_bexp1 : fold_constants_bexp
    (BAnd BTrue (BNot (BAnd BFalse BTrue))) = BTrue.
Proof. reflexivity. Qed.

Example fold_bexp2 : fold_constants_bexp
    (BAnd (BEq (AKey x) (AKey y))
          (BEq (ANum 0)
               (AMinus (ANum 2) (APlus (ANum 1) (ANum 2))))) =
    BAnd (BEq (AKey x) (AKey y)) BTrue.
Proof. reflexivity. Qed.

Example fold_com1 : fold_constants_com
    (x ::= APlus (ANum 4) (ANum 5) ;;
     y ::= AMinus (AKey x) (ANum 3);;
     IFB BEq (AMinus (AKey x) (AKey y))
             (APlus (ANum 2) (ANum 4))
     THEN
        SKIP
     ELSE
        y ::= ANum 0
     FI;;
     IFB BLe (ANum 0)
             (AMinus (ANum 4) (APlus (ANum 2) (ANum 1)))
     THEN
        y ::= ANum 0
     ELSE
        SKIP
     FI;;
     WHILE BEq (AKey y) (ANum 0) DO
        x ::= APlus (AKey x) (ANum 1)
     END)
     =
     (x ::= ANum 9;;
      y ::= AMinus (AKey x) (ANum 3);;
      IFB BEq (AMinus (AKey x) (AKey y)) (ANum 6)
      THEN
        SKIP
      ELSE
        y ::= ANum 0
      FI;;
      y ::= ANum 0;;
      WHILE BEq (AKey y) (ANum 0) DO
        x ::= APlus (AKey x) (ANum 1)
      END).
Proof. reflexivity. Qed.


Require Import Ring.
Definition v2 (A : Type) := A -> A -> A.
(* Really it should be a linear function. *)

Definition xhat {A : Type} : v2 A := fun  x y => x.
Definition yhat {A : Type} : v2 A := fun  x y => y.

Class SemiRing (A : Type) :=
  {
    plus : A -> A -> A ;
    one : A ;
    zero : A ;
    times : A -> A -> A ;
    (* Plus all the laws. *)

  }.

Search Nat.add.
Locate "+".
Instance seminat : SemiRing nat := {
                        plus := Nat.add;
                        one := 1;
                        zero := 0;
                        times := Nat.mul
                                }.
Definition vadd {A : Type} {ringa : SemiRing A} (v : v2 A) (w : v2 A) : v2 A :=
  fun x1 y1 => plus (v x1 y1) (w x1 y1).

Compute vadd xhat yhat 1 2.

Definition smul {A : Type} {ringa : SemiRing A} (s : A) (v : v2 A) : v2 A :=
  fun x1 y1 => times s (v x1 y1).

Definition dot {A : Type} {ringa : SemiRing A} (v : v2 A) (w : v2 A) : A :=
  plus (times (v one zero) (w one zero)) (times (v zero one ) (w zero one)).

Compute dot xhat yhat.
Compute dot xhat xhat.


(* looked this one up  *)

Inductive bin : Type :=
  | Z
  | B0 (n : bin)
  | B1 (n : bin).

Fixpoint incr (m : bin) : bin :=
   match m with
   | Z => B1 Z
   | B0 n => B1 n
   | B1 n => B0 (incr n)
   end.

Fixpoint bin_to_nat (m:bin) : nat :=
  match m with
  | Z => O
  | B0 n => 2 * bin_to_nat n
  | B1 n => 1 + 2 * bin_to_nat n
  end.

Example test_bin_incr1 : (incr (B1 Z)) = B0 (B1 Z).
Proof. simpl. reflexivity. Qed.

Example test_bin_incr2 : (incr (B0 (B1 Z))) = B1 (B1 Z).
Proof. simpl. reflexivity. Qed.

Example test_bin_incr3 : (incr (B1 (B1 Z))) = B0 (B0 (B1 Z)).
Proof. simpl. reflexivity. Qed.

Example test_bin_incr5 : bin_to_nat (incr (B1 Z)) = 1 + bin_to_nat (B1 Z).
Proof. simpl. reflexivity. Qed.

Example test_bin_incr6 : bin_to_nat (incr (incr (B1 Z))) = 2 + bin_to_nat (B1 Z).
Proof. simpl. reflexivity. Qed.


Set Warnings "-notation-overridden,-parsing,-deprecated-hint-without-locality".
From LF Require Export Logic.
From Coq Require Import Lia.

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

  Theorem ev_4 : ev 4.
Proof. apply ev_SS. apply ev_SS. apply ev_0. Qed.

Theorem ev_plus4 : forall n, ev n -> ev (4 + n).
Proof.
  intros n. simpl. intros Hn.
  apply ev_SS. apply ev_SS. apply Hn.
Qed.

Theorem ev_double : forall n,
  ev (double n).
Proof.
intros.
induction n.
simpl.
apply ev_0.
simpl.
apply ev_SS.
exact 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 as [ | n' E'] eqn:EE.
  - (* E = ev_0 : ev 0 *)
    left. reflexivity.
  - (* E = ev_SS n' E' : ev (S (S n')) *)
    right. exists n'. split. reflexivity. apply E'.
Qed.

Theorem ev_minus2 : forall n,
  ev n -> ev (pred (pred n)).
Proof.
  intros n E.
  destruct E as [| n' E'] eqn:EE.
  - (* E = ev_0 *) simpl. apply ev_0.
  - (* E = ev_SS n' E' *) simpl. apply E'.
Qed.

Theorem  evSS_ev_remember : forall n,
  ev (S (S n)) -> ev n.
  Proof.
  intros n E.
  remember (S (S n)) as k eqn:Hk.
  destruct E as [|n' E'] eqn:EE.
  discriminate Hk.
  injection Hk as Heq.
  rewrite <- Heq.
  exact 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].
  (* We are in the E = ev_SS n' E' case now. *)
  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.
  exact 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 n contra. inversion contra. Qed.

Lemma ev_Even : forall  n,
  ev n -> Even n.
Proof.
  intros n E.
  induction E as [|n' E' IH].
  - (* E = ev_0 *)
    unfold Even. exists 0. reflexivity.
  - (* E = ev_SS n' E'
       with IH : Even E' *)
    unfold Even in IH.
    destruct IH as [k Hk].
    rewrite Hk.
    unfold Even. exists (S k). simpl. 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.
induction H.
apply H0.
simpl.
apply ev_SS.
apply IHev.
Qed.

Theorem ev_ev__ev : forall n m,
  ev (n+m) -> ev n -> ev m.
Proof.
intros.
induction H0.
simpl in H.
exact H.
simpl in H.

inversion H.
apply IHev in H2.
exact H2.
Qed.

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).

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

Inductive square_of : nat -> nat -> Prop :=
  | sq n : square_of n (n * n).
Inductive next_nat : nat -> nat -> Prop :=
  | nn n : next_nat n (S n).
Inductive next_ev : nat -> nat -> Prop :=
  | ne_1 n (H: ev (S n)) : next_ev n (S n)
  | ne_2 n (H: ev (S (S n))) : next_ev n (S (S n)).

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
.

Inductive subseq : list nat -> list nat -> Prop :=
| empty k: subseq [] k
| extend a b c (H:subseq a b): subseq a (c::b)
| same a b c (H:subseq a b): subseq (c::a) (c::b)
.

Theorem subseq_refl : forall (l : list nat), subseq l l.
Proof.
intros.
induction l.
apply (empty []).
apply (same).
apply IHl.
Qed.

Lemma lemma1: forall (x:nat) l1 l2, (x::l1) ++ l2 = x::(l1++l2).
intros.
induction l1.
reflexivity.
simpl.
reflexivity.
Qed.

Theorem subseq_app : forall (l1 l2 l3 : list nat),
  subseq l1 l2->
  subseq l1 (l2 ++ l3).
Proof.
intros.
induction H.
apply empty.
rewrite lemma1.
apply extend.
exact IHsubseq.
rewrite lemma1.
apply same.
exact 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.
inversion H.
apply empty.
intros.
apply extend.
apply IHsubseq in H.
exact H.
intros.
inversion H.
apply empty.
apply extend.
apply IHsubseq.
apply H3.
apply same.
apply IHsubseq.
apply H3.
Qed.

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).

Fixpoint reg_exp_of_list {T} (l : list T) :=
  match l with
  | [] => EmptyStr
  | x :: l' => App (Char x) (reg_exp_of_list l')
  end.

  Lemma MStar1 :
 forall T s (re : reg_exp T) ,
    s =~ re ->
    s =~ Star re.
    Proof.
    intros.
    assert (forall X (l:list X), l++[] = l).
    induction l.
    reflexivity.
    simpl.
    rewrite IHl.
    reflexivity.
    rewrite <- (H0 T s).
    apply (MStarApp s [] re).
    exact H.
    apply MStar0.
    Qed.

Lemma empty_is_empty : forall T (s : list T),
  ~ (s =~ EmptySet).
Proof.
  intros.
  unfold not.
  intros.
  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.
  destruct H.
  apply MUnionL.
  exact H.
  apply MUnionR.
  exact 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.
  induction ss.
  simpl.
  apply MStar0.
  simpl.
  apply MStarApp.
  apply H.
  simpl.
  left.
  reflexivity.
  apply IHss.
  intros.
  apply H.
  simpl.
  right.
  apply H0.
  Qed.

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

Lemma re_not_empty_correct : forall T (re : reg_exp T),
  (exists s, s =~ re) <-> re_not_empty re = true.
Proof.
  intros.
  split.
  intros.
  destruct H.
  induction H.
  reflexivity.
  reflexivity.
  simpl.
  rewrite IHexp_match1, IHexp_match2.
  reflexivity.
  simpl.
  rewrite IHexp_match.
  reflexivity.
  simpl.
  rewrite IHexp_match.
  destruct (re_not_empty re1).
  reflexivity.
  reflexivity.
  simpl.
  reflexivity.
  simpl.
  reflexivity.
  intros.
  induction re.
  simpl in H.
  discriminate 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.
  destruct H.
  destruct H0.
  exists (x++x0).
  apply MApp.
  exact H.
  exact H0.
  simpl in H.
  apply orb_true_iff in H.
  destruct H.
  apply IHre1 in H.
  destruct H.
  exists x.
  apply MUnionL.
  exact H.
  apply IHre2 in H.
  destruct H.
  exists x.
  apply MUnionR.
  exact H.
  exists [].
  apply MStar0.
  Qed.

  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.
  (* WORKED IN CLASS *)
  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.
  split.
  intros.
  inversion H.
  reflexivity.
  unfold not in H1.
  apply H1 in H0.
  destruct H0.
  intros.
  rewrite H0 in H.
  inversion H.
  exact H1.
  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' IHl'].
  - (* l =  *)
    simpl. intros H. apply H. reflexivity.
  - (* l = m :: l' *)
    simpl.  destruct (eqbP n m) as [H | H].
    + (* n = m *)
      intros _. rewrite H. left. reflexivity.
    + (* n <> m *)
      intros H'. right. apply IHl'. apply H'.
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.
  induction l.
  simpl.
  intros.
  intros f.
  destruct f.
  simpl.
  destruct (eqbP n x).
  intros.
  simpl in H0.
  discriminate H0.
  intros.
  intros f.
  destruct f.
  apply H.
  symmetry.
  exact H1.
  apply IHl.
  apply H0.
  apply H1.

 Qed.

Inductive nostutter {X:Type} : list X -> Prop :=
| emptylist: nostutter []
| single x:  nostutter [x]
| diff x y l (H:nostutter (y::l)) (K: x<>y) : nostutter (x::y::l).

Inductive merge {X:Type} : list X -> list X -> list X -> Prop:=
| doubleempty: merge [] [] []
| left x y z l(H:merge y z l) : merge (x::y) z (x::l)
| right x y z l ( H:merge y z l): merge y (x::z) (x::l).

Theorem add_in_front_same: forall X (x:X) l1 l2, l1=l2-> x::l1=x::l2.
intros.
rewrite H.
reflexivity.
Qed.
Theorem filtertest:
forall (X:Type) l l1 l2 (test: X->bool), merge l1 l2 l-> forallb test l1=true ->
forallb  (fun x => negb (test x)) l2 = true -> filter test l =l1.
intros.
induction H.
reflexivity.
simpl.
simpl in H0.
destruct (test x) eqn:K.
apply add_in_front_same.
apply IHmerge.
apply H0.
apply H1.
discriminate H0.
simpl.
destruct (test x) eqn:k.
simpl in H1.
rewrite k in H1.
simpl in H1.
discriminate H1.
apply IHmerge.
apply H0.
simpl in H1.
rewrite k in H1.
simpl in H1.
exact H1.
Qed.