(* ------------------ Descriptions--------------------------------------------------

 In this file we define the concept of Stable Set, Cliq and Coloring for an undirected
 graph.  We also define boolean functions to check these properties. We connect these
 properties with boolean functions using reflection lemmas.

 Predicate              Boolean function       Joining Lemma
 Stable G I             stable G I             stableP
 Max_I_in G I           max_I_in G I           max_I_inP
 Cliq G K               cliq G K               cliqP
 Max_K_in G K           max_K_in G K           max_K_inP
 Coloring_of G f        coloring_of G f        coloring_ofP

 (Max_I_in G I) declares that I is a maximum size stable set in G.
 (Max_K_in G I) declares that K is a maximum size cliq in G.

 Definition Stable_in (G: dG)(I: list A):= I [<=] G /\ IsOrd I /\ Stable G I.
 Definition Cliq_in (G: dG)(K: list A):Prop := K [<=] G /\ IsOrd K /\ Cliq G K.

 Definition i_num (G: dG)(n:nat):= exists I, Max_I_in G I /\ |I|=n.
 Definition cliq_num (G: dG)(n:nat):= exists K, Max_K_in G K /\ |K|=n.

 Definition clrs_of (f:A->nat) (l:list A): list nat:= (img f l).
 Definition chrom_num (G: dG) (n: nat):=
                              exists f, Best_coloring_of G f /\ | clrs_of f G | = n.

 We also define the notion of a perfect graph as follows:

 Definition Nice (G: dG): Prop:= forall n, cliq_num G n -> chrom_num G n.
 Definition Perfect (G: dG): Prop:= forall G1, Ind_subgraph G1 G -> Nice G1.

---------------------------------------------------------------------------------------*)

Require Export DecUG.

Set Implicit Arguments.

Section MoreOnDecidableGraphs.

  Context { A: ordType }.

  (*------------  Stable set and independence number in a graph G ------------*)
  Definition Stable (G: dG)(I: list A): Prop:=
    (forall x y, In x I-> In y I -> edg G x y = false).
  Definition stable (G: dG)(I: list A):=
    (forall_xyb (fun x y => edg G x y == false) I).

  Definition Stable_in (G: dG)(I: list A):= I [<=] G /\ IsOrd I /\ Stable G I.

  Lemma Stable_elim (G:dG)(I: list A)(x y:A): Stable G I -> In x I-> In y I-> edg G x y = false.
  Proof. { intros H Hx Hy.  unfold Stable in H. specialize (H x y Hx Hy) as H'. auto. } Qed.
  Lemma Stable_in_elim (G:dG)(I: list A): Stable_in G I -> Stable G I.
  Proof. intro H; apply H. Qed.
  Lemma Stable_in_elim1 (G: dG)(I: list A): Stable_in G I -> I [<=] G.
  Proof. intro H; apply H. Qed.
  Lemma Stable_in_elim2 (G:dG)(I: list A): Stable_in G I -> IsOrd I.
  Proof. intro H; apply H. Qed.

  Lemma stableP (G: dG)(I: list A): reflect (Stable G I) (stable G I).
  Proof. { apply reflect_intro. split;unfold stable; unfold Stable.
         {  intro H.  apply /forall_xyP; intros; apply /eqP; auto. }
         {  intro H. move /forall_xyP in H. intros x y H1 H2; apply /eqP; auto. } } Qed.
  Lemma nil_is_stable (G: dG): stable G nil.
  Proof. unfold stable. apply /forall_xyP. auto. Qed.

  Hint Resolve Stable_in_elim Stable_in_elim1 Stable_in_elim2: core.
  Hint Resolve stableP nil_is_stable: core.

  Definition Max_I_in (G: dG)(I: list A):= Max_sub_in G I (fun I => stable G I).
  Definition max_I_in (G: dG)(I: list A):= max_sub_in G I (fun I => stable G I).

  Lemma max_I_inP (G: dG)(I:list A): reflect (Max_I_in G I)(max_I_in G I).
  Proof. apply max_sub_inP; auto. Qed.

  Lemma exists_Max_I_in (G: dG): exists I, Max_I_in G I.
  Proof. { specialize (exists_largest_in G (fun I=> stable G I)).
         intro H.
         assert (Ha: exists X : list A, In X (pw G) /\ (fun I : list A => stable G I) X).
         { exists nil. split; auto. }
         apply H in Ha as Hb. destruct Hb as [I0 Hb]. exists I0.
         unfold Max_I_in; unfold Max_sub_in;destruct Hb as [Hb Hc]; destruct Hc as [Hc Hd].
         split.
         {  auto. }
         split.
         { eauto. }
         split.
         { auto. }
         { intros. apply Hd. auto. auto. } } Qed.

  Definition i_num (G:dG)(n:nat):= exists I, Max_I_in G I /\ |I|=n.
  Lemma i_num_of (G: dG): exists n, i_num G n.
  Proof. { specialize (exists_Max_I_in G) as HI. destruct HI as [I H].
           exists (|I|). unfold i_num. exists I. split; auto.  } Qed.

  (* Use of above lemma can be:  destruct (i_num_of G) as [n H]. *)

  Lemma Max_I_in_elim1 (G: dG)(I: list A): Max_I_in G I -> Stable G I.
  Proof. intro H. apply /stableP. apply H.  Qed.
  Lemma Max_I_in_elim2 (G: dG)(I: list A): Max_I_in G I -> Stable_in G I.
  Proof. intro H. unfold Stable_in. split. eauto.  split. eauto. apply /stableP. apply H.  Qed.

  Lemma Max_I_in_elim3 (G: dG)(I X: list A):
    Max_I_in G I ->  IsOrd X -> X [<=] G-> Stable G X -> |X| <= |I|.
  Proof. { intros H H1 H2 H3. destruct H as [Ha H]; destruct H as [Hb H].
           apply H; auto. apply /stableP;auto.  } Qed.

  Lemma Max_I_in_elim (G: dG)(I X: list A):
    Max_I_in G I ->  Stable_in G X -> |X| <= |I|.
  Proof. intros H H1. eapply Max_I_in_elim3 with (G:=G). all:auto. eauto. Qed.

  Lemma Max_I_in_intro (G: dG)( I: list A):
    Stable_in G I -> (forall I', Stable_in G I' -> |I'| <= |I|) -> Max_I_in G I.
  Proof. { intros H H1. unfold Max_I_in. unfold Max_sub_in.
         split. auto. split. apply H. split. apply /stableP. apply H.
         intros I' H2 H3. apply H1. split. auto. split. eauto.
         apply /stableP;auto. } Qed.

   Hint Resolve max_I_inP exists_Max_I_in Max_I_in_elim1 Max_I_in_elim2 : core.

  Lemma i_num_same (G: dG)(n m:nat): i_num G n -> i_num G m -> n=m.
  Proof. {  intros Hn Hm.
           destruct Hn as [I1 Hn]. destruct Hm as [I2 Hm].
           cut (n<=m /\ m<=n). omega.
           destruct Hn as [Hn1 Hn2]. destruct Hm as [Hm1 Hm2].
           unfold Max_I_in in Hn1.  unfold Max_I_in in Hm1.
           split; subst n; subst m; eapply Max_I_in_elim3;eauto. } Qed.

  Hint Resolve i_num_same : core.

  Lemma Stable_in_HG (H G:dG)(I: list A): Ind_subgraph H G-> Stable_in H I-> Stable_in G I.
  Proof. { unfold Stable_in. intros h0 h1. unfold Ind_subgraph in h0.
         destruct h0 as [h0 h]. destruct h1 as [h2 h1]. destruct h1 as [h3 h1].
         repeat try (split;auto). unfold Stable. intros x y h4 h5.
         replace (edg G x y) with (edg H x y). apply h1;auto. auto. } Qed.

  Lemma i_num_HG (H G: dG)(m n:nat): Ind_subgraph H G-> i_num H m -> i_num G n-> m<=n.
  Proof. { intro h. unfold i_num. intros h1 h2.
         destruct h1 as [I h1]. destruct h1 as [h1 hm].
         destruct h2 as [Ig h2]. destruct h2 as [h2 hn].
         assert (h3: Stable_in G I).
         { cut (Stable_in H I). eauto using Stable_in_HG. auto. }
         subst n. subst m.  eapply Max_I_in_elim; eauto. } Qed.

  Hint Immediate Stable_in_HG i_num_HG:core.

  (*-----  Cliq and the Cliq number for a given graph G ----------------------*)

  Definition Cliq (G:dG)(K: list A):Prop := (forall x y, In x K-> In y K -> x=y \/ edg G x y).
  Definition cliq (G:dG)(K: list A):bool:= forall_xyb (fun x y=> (x==y) || edg G x y) K.

  Definition Cliq_in (G:dG)(K: list A):Prop := K [<=] G /\ IsOrd K /\ Cliq G K.

  Lemma Cliq_elim (G:dG)(K: list A)(x y:A): Cliq G K -> In x K-> In y K-> x<>y -> edg G x y.
  Proof. { intros H Hx Hy H1.  unfold Cliq in H. specialize (H x y Hx Hy) as H'.
           destruct H'. contradiction. auto. } Qed.
  Lemma Cliq_in_elim (G:dG)(K: list A): Cliq_in G K -> Cliq G K.
  Proof. intro H; apply H. Qed.
  Lemma Cliq_in_elim1 (G:dG)(K: list A): Cliq_in G K -> K [<=] G.
  Proof. intro H; apply H. Qed.
  Lemma Cliq_in_elim2 (G:dG)(K: list A): Cliq_in G K -> IsOrd K.
  Proof. intro H; apply H. Qed.

  Lemma cliqP (G: dG)(K: list A): reflect (Cliq G K) (cliq G K).
  Proof. { apply reflect_intro. split;unfold cliq; unfold Cliq.
           {  intro H. apply /forall_xyP.  intros x y H0 H1. apply /orP.
              specialize (H x y H0 H1) as H2. destruct H2; auto. }
           {  intro H. move /forall_xyP in H. intros x  y H0 H1.
              specialize (H x y H0 H1) as H2. move /orP in H2. destruct H2; auto. } } Qed.

   Lemma nil_is_cliq (G: dG): cliq G nil.
   Proof. unfold cliq. apply /forall_xyP. auto. Qed.

   Hint Resolve Cliq_in_elim Cliq_in_elim1 Cliq_in_elim2: core.
   Hint Resolve Cliq_elim cliqP nil_is_cliq: core.

  Definition Max_K_in (G: dG)(K: list A):= Max_sub_in G K (fun K => cliq G K).
  Definition max_K_in (G: dG)(K: list A):= max_sub_in G K (fun K => cliq G K).

  Lemma max_K_inP (G: dG)(K:list A): reflect (Max_K_in G K)(max_K_in G K).
  Proof. apply max_sub_inP; auto. Qed.

  Lemma exists_Max_K_in (G: dG): exists K, Max_K_in G K.
  Proof. { specialize (exists_largest_in G (fun K=> cliq G K)).
         intro H.
         assert (Ha: exists X : list A, In X (pw G) /\ (fun K : list A => cliq G K) X).
         { exists nil. split; auto. }
         apply H in Ha as Hb. destruct Hb as [K0 Hb]. exists K0.
         unfold Max_K_in; unfold Max_sub_in;destruct Hb as [Hb Hc]; destruct Hc as [Hc Hd].
         split.
         {  auto. }
         split.
         { eauto. }
         split.
         { auto. }
         { intros. apply Hd. auto. auto. } } Qed.

  Definition cliq_num (G:dG)(n:nat):= exists K, Max_K_in G K /\ |K|=n.

  Lemma cliq_num_of (G: dG): exists n, cliq_num G n.
  Proof. { specialize (exists_Max_K_in G) as HK. destruct HK as [K H].
           exists (|K|). unfold cliq_num. exists K. split;auto.  } Qed.

  (* Use of above lemma can be :  destruct (cliq_num_of G) as [n H]. *)

  Lemma Max_K_in_elim1 (G: dG)(K: list A): Max_K_in G K -> Cliq G K.
  Proof. intro H. apply /cliqP. apply H.  Qed.
  Lemma Max_K_in_elim2 (G: dG)(K: list A): Max_K_in G K -> Cliq_in G K.
  Proof. intro H. unfold Cliq_in. split. eauto.  split. eauto. apply /cliqP. apply H.  Qed.
  Lemma Max_K_in_elim3 (G: dG)(K X: list A):
    Max_K_in G K ->  IsOrd X -> X [<=] G-> Cliq G X -> |X| <= |K|.
  Proof. { intros H H1 H2 H3. destruct H as [Ha H]; destruct H as [Hb H].
           apply H; auto. apply /cliqP;auto. } Qed.

  Lemma Max_K_in_elim (G: dG)(K X: list A):
    Max_K_in G K ->  Cliq_in G X -> |X| <= |K|.
  Proof. intros H H1. eapply Max_K_in_elim3 with (G:=G). all:auto. eauto. Qed.

  Lemma Max_K_in_intro (G: dG)( K: list A):
    Cliq_in G K -> (forall K', Cliq_in G K' -> |K'| <= |K|) -> Max_K_in G K.
  Proof. { intros H H1. unfold Max_K_in. unfold Max_sub_in.
         split. auto. split. apply H. split. apply /cliqP. apply H.
         intros K' H2 H3. apply H1. split. auto. split. eauto.
         apply /cliqP;auto. } Qed.

  Hint Resolve max_K_inP exists_Max_K_in Max_K_in_elim1 Max_K_in_elim2 : core.

  Lemma cliq_num_same (G: dG)(n m:nat): cliq_num G n -> cliq_num G m -> n=m.
  Proof.  {  intros Hn Hm.
           destruct Hn as [K1 Hn]. destruct Hm as [K2 Hm].
           cut (n<=m /\ m<=n). omega.
           destruct Hn as [Hn1 Hn2]. destruct Hm as [Hm1 Hm2].
           unfold Max_K_in in Hn1.  unfold Max_K_in in Hm1.
           split; subst n; subst m; eapply Max_K_in_elim3;eauto. } Qed.

  Hint Resolve cliq_num_same:core.

  Lemma Cliq_in_HG (H G:dG)(K: list A): Ind_subgraph H G-> Cliq_in H K-> Cliq_in G K.
  Proof. { unfold Cliq_in. intros h0 h1. unfold Ind_subgraph in h0.
         destruct h0 as [h0 h]. destruct h1 as [h2 h1]. destruct h1 as [h3 h1].
         repeat try (split;auto). unfold Cliq. intros x y h4 h5.
         replace (edg G x y) with (edg H x y). apply h1;auto. auto. } Qed.
  Lemma cliq_num_HG (H G: dG)(m n:nat): Ind_subgraph H G-> cliq_num H m -> cliq_num G n-> m<=n.
  Proof. { intro h. unfold cliq_num. intros h1 h2.
         destruct h1 as [I h1]. destruct h1 as [h1 hm].
         destruct h2 as [Ig h2]. destruct h2 as [h2 hn].
         assert (h3: Cliq_in G I).
         { cut (Cliq_in H I). eauto using Cliq_in_HG. auto. }
         subst n. subst m.  eapply Max_K_in_elim; eauto. } Qed.

  Hint Immediate Cliq_in_HG cliq_num_HG:core.

   (*------ Concepts of Coloring and the chromatic number of a graph G ------------------*)
  Definition Coloring_of (G: dG)(f: A-> nat): Prop:=
    forall x y, In x G-> In y G -> edg G x y -> f x <> f y.

  Definition coloring_of (G: dG)(f: A-> nat):bool:=
    forall_xyb (fun x y => negb (edg G x y)|| negb (f x == f y)) G.
  Lemma coloring_ofP (G: dG)(f: A->nat): reflect (Coloring_of G f)(coloring_of G f).
  Proof. { apply reflect_intro. unfold coloring_of;unfold Coloring_of.
         split.
         { intro H; apply /forall_xyP; intros x y Hx Hy; apply /impP.
           intro H1; apply /negP; move /eqP; apply H;auto. }
         { move /forall_xyP. intro H. intros x y Hx Hy.
           specialize (H x y Hx Hy) as H1; move /impP in H1; intro H2.
           apply H1 in H2 as H3; move /negP in H3; move /eqP; auto. } } Qed.

  Lemma exists_coloring (G: dG): exists f, Coloring_of G f.
  Proof. { exists ( fun x => idx x G).  unfold Coloring_of.
         intros x y Hx Hy HE. apply diff_index. all: auto.
         eapply no_self_edg;eauto. } Qed.

  Definition clrs_of (f:A->nat) (l:list A): list nat:= (img f l).

   Definition Best_coloring_of (G: dG) (f:A->nat): Prop :=
     Coloring_of G f /\ (forall f1, Coloring_of G f1 -> | clrs_of f G | <= | clrs_of f1 G|).

   Definition chrom_num (G: dG) (n: nat):= exists f, Best_coloring_of G f /\ | clrs_of f G | = n.

   Lemma best_clrs_same_size (G: dG)(f1 f2: A->nat):
     Best_coloring_of G f1 -> Best_coloring_of G f2 -> |clrs_of f1 G|=|clrs_of f2 G|.
   Proof.  { intros h1 h2. destruct h1 as [h1a h1];destruct h2 as [h2a h2].
           cut((| clrs_of f1 G |) <= (| clrs_of f2 G |)).
           cut ((| clrs_of f2 G |) <= (| clrs_of f1 G |)). omega. all: eauto. } Qed.
   Lemma chrom_num_same (G:dG)(n m:nat): chrom_num G n-> chrom_num G m -> n=m.
   Proof. { intros h1 h2. destruct h1 as [f1 h1]. destruct h1 as [h1a h1].
          destruct h2 as [f2 h2]. destruct h2 as [h2a h2]. subst m;subst n.
          apply best_clrs_same_size;auto. } Qed.

   Lemma clrs_of_inc (K1: list A)(K2: list A)(f:A-> nat):
     K1 [<=] K2 -> (clrs_of f K1) [<=] (clrs_of f K2).
   Proof.  unfold clrs_of; auto. Qed.
   Lemma clrs_of_inc1 (K1: list A)(K2: list A)(f: A->nat):
     K1 [<=] K2 -> |(clrs_of f K1)| <= |(clrs_of f K2)|.
   Proof. unfold clrs_of; auto. Qed.

   Hint Resolve chrom_num_same clrs_of_inc clrs_of_inc1: core.

   Lemma coloring_of_HG (H G: dG)(f: A-> nat): Ind_subgraph H G-> Coloring_of G f-> Coloring_of H f.
   Proof. { unfold Coloring_of. intros h0 h1. unfold Ind_subgraph in h0.
            destruct h0 as [h0 h]. intros x y h2 h3 h4.
            apply h1. all: try auto. replace (edg G x y) with (edg H x y); auto. } Qed.
   Lemma chrom_num_HG (H G: dG)(m n: nat): Ind_subgraph H G-> chrom_num H m-> chrom_num G n-> m<=n.
   Proof. { intro h. unfold chrom_num. intros h1 h2.
           destruct h1 as [fh h1]. destruct h1 as [h1 hm].
           destruct h2 as [fg h2]. destruct h2 as [h2 hn].
           assert (h3: Coloring_of H fg).
           { cut (Coloring_of G fg). eauto using coloring_of_HG. apply h2.  }
           subst n. subst m.
           cut ( (| clrs_of fh H |) <= (| clrs_of fg H |)).
           cut ( (| clrs_of fg H |) <= (| clrs_of fg G |)). omega.
           cut (H [<=] G). auto. apply h.  apply h1; auto. } Qed.

   Hint Immediate coloring_of_HG chrom_num_HG: core.

   (*----- Think about the proof of existence of a best coloring----------------------------*)

   (*-------- Concepts of nice graph and  perfect graphs -------------------------------- *)
   Definition Nice (G: dG): Prop:= forall n, cliq_num G n -> chrom_num G n.
   Definition Perfect (G: dG): Prop:= forall G1, Ind_subgraph G1 G -> Nice G1.

   Lemma perfect_is_nice (G: dG): Perfect G -> Nice G.
   Proof.  unfold Perfect. intros H; apply H. auto.  Qed.

   Hint Resolve perfect_is_nice: core.

   Lemma perfect_sub_perfect (G H: dG): Perfect G-> Ind_subgraph H G-> Perfect H.
   Proof. unfold Perfect. intros. cut (Ind_subgraph G1 G). auto. eauto. Qed.

   (*---------  More colors needed than the largest cliq size --------------------------*)

   Lemma clrs_on_a_cliq  (G: dG)(K: list A)(f: A->nat):
     Cliq_in G K-> Coloring_of G f -> |K| = |clrs_of f K|.
   Proof. { intros H H1.
            unfold clrs_of. match_up (|K|) (| img f K|).
            { auto. }
            { cut (| img f K| <= |K|).
              move /ltP in H0. intro H2. omega. auto. }
            { move /ltP in H0.
              assert (H2: ~ one_one_on K f).
              { cut(NoDup K). eauto. unfold Cliq_in in H.
                cut (IsOrd K). auto. apply H. }
              unfold one_one_on in H2. unfold Coloring_of in H1.
              absurd (forall x y : A, In x K -> In y K -> x <> y -> f x <> f y).
              apply H2. intros x y Hx Hy Hxy.
              destruct H as [Ha H]. destruct H as [Hb H].
              apply H1;auto.  eapply Cliq_elim;eauto. } }  Qed.

   Lemma more_clrs_than_cliq_size (G: dG)(K: list A)(f: A->nat):
     Cliq_in G K-> Coloring_of G f -> |K| <= |clrs_of f G|.
   Proof. { intros H H1.
          assert (H2: | K | = |clrs_of f K|).
          { unfold clrs_of. match_up (|K|) (| img f K|).
            { auto. }
            { cut (| img f K| <= |K|).
              move /ltP in H0. intro H2. omega. auto. }
            { move /ltP in H0.
              assert (H2: ~ one_one_on K f).
              { cut(NoDup K). eauto. unfold Cliq_in in H.
                cut (IsOrd K). auto. apply H. }
              unfold one_one_on in H2. unfold Coloring_of in H1.
              absurd (forall x y : A, In x K -> In y K -> x <> y -> f x <> f y).
              apply H2. intros x y Hx Hy Hxy.
              destruct H as [Ha H]. destruct H as [Hb H].
              apply H1;auto.  eapply Cliq_elim;eauto. } }
          cut (|clrs_of f K| <= | clrs_of f G|). omega.
          destruct H as [H H']. auto. } Qed.

   Lemma more_clrs_than_cliq_num (G: dG)(n:nat)(f: A->nat):
     cliq_num G n-> Coloring_of G f -> n <= |clrs_of f G|.
   Proof. { intros H H1. destruct H as [K H]. destruct H as [Ha H].
          assert (H2: Cliq_in G K); auto. subst n.
          apply more_clrs_than_cliq_size;auto. } Qed.

   (*---------Some other properties of graph --------------------------*)

   Lemma nice_intro (G: dG)(n:nat):
     cliq_num G n -> (exists f, Coloring_of G f /\ |clrs_of f G|= n)-> Nice G.
   Proof. { intros H H1 m H2. assert (Hnm: n=m); eauto; subst m. clear H2.
          destruct H1 as [f H1].
          unfold chrom_num. exists f.
          destruct H1 as [H1 HR]. split.
          { unfold Best_coloring_of. split.
            { auto. }
            rewrite HR. intro f1. apply more_clrs_than_cliq_num;auto. }
          { auto. } } Qed.

   Hint Immediate perfect_sub_perfect more_clrs_than_cliq_size more_clrs_than_cliq_num: core.
   Hint Immediate nice_intro: core.

End MoreOnDecidableGraphs.

 Hint Resolve Stable_in_elim Stable_in_elim1 Stable_in_elim2: core.
 Hint Resolve stableP nil_is_stable: core.
 Hint Resolve max_I_inP exists_Max_I_in Max_I_in_elim1 Max_I_in_elim2 : core.
 Hint Resolve i_num_same:core.
 Hint Immediate Stable_in_HG i_num_HG:core.

 Hint Resolve Cliq_in_elim Cliq_in_elim1 Cliq_in_elim2: core.
 Hint Resolve  Cliq_elim cliqP nil_is_cliq: core.
 Hint Resolve max_K_inP exists_Max_K_in  Max_K_in_elim1 Max_K_in_elim2: core.
 Hint Resolve cliq_num_same:core.
 Hint Immediate Cliq_in_HG cliq_num_HG:core.

 Hint Resolve chrom_num_same clrs_of_inc clrs_of_inc1: core.
 Hint Immediate coloring_of_HG chrom_num_HG: core.

 Hint Resolve perfect_is_nice: core.
 Hint Immediate perfect_sub_perfect more_clrs_than_cliq_size more_clrs_than_cliq_num: core.
 Hint Resolve clrs_on_a_cliq: core.
 Hint Immediate nice_intro: core.


Require Import Coq.Arith.Div2.
Require Import Coq.NArith.NArith.
Require Import Coq.ZArith.ZArith.
Require Import N_Z_nat_conversions.
Require Export Lia Nlia.

Set Implicit Arguments.

Fixpoint mod2 (n : nat) : bool :=
  match n with
    | 0 => false
    | 1 => true
    | S (S n') => mod2 n'
  end.

Ltac rethink :=
  match goal with
    | [ H : ?f ?n = _ |- ?f ?m = _ ] => replace m with n; simpl; auto
  end.

Theorem mod2_S_double : forall n, mod2 (S (2 * n)) = true.
  induction n; simpl; intuition; rethink.
Qed.

Theorem mod2_double : forall n, mod2 (2 * n) = false.
  induction n; simpl; intuition; rewrite <- plus_n_Sm; rethink.
Qed.

Theorem div2_double : forall n, div2 (2 * n) = n.
  induction n; simpl; intuition; rewrite <- plus_n_Sm; f_equal; rethink.
Qed.

Theorem div2_S_double : forall n, div2 (S (2 * n)) = n.
  induction n; simpl; intuition; f_equal; rethink.
Qed.

Notation pow2 := (Nat.pow 2).

Fixpoint Npow2 (n : nat) : N :=
  match n with
    | O => 1
    | S n' => 2 * Npow2 n'
  end%N.

Theorem untimes2 : forall n, n + (n + 0) = 2 * n.
  auto.
Qed.

Section strong.
  Variable P : nat -> Prop.

  Hypothesis PH : forall n, (forall m, m < n -> P m) -> P n.

  Lemma strong' : forall n m, m <= n -> P m.
    induction n; simpl; intuition; apply PH; intuition.
    elimtype False; lia.
  Qed.

  Theorem strong : forall n, P n.
    intros; eapply strong'; eauto.
  Qed.
End strong.

Theorem div2_odd : forall n,
  mod2 n = true
  -> n = S (2 * div2 n).
  induction n as [n] using strong; simpl; intuition.

  destruct n as [|n]; simpl in *.
    discriminate.
  destruct n as [|n]; simpl in *; intuition.
  do 2 f_equal.
  replace (div2 n + S (div2 n + 0)) with (S (div2 n + (div2 n + 0))); auto.
Qed.

Theorem div2_even : forall n,
  mod2 n = false
  -> n = 2 * div2 n.
  induction n as [n] using strong; simpl; intuition.

  destruct n as [|n]; simpl in *; intuition.
  destruct n as [|n]; simpl in *.
    discriminate.
  f_equal.
  replace (div2 n + S (div2 n + 0)) with (S (div2 n + (div2 n + 0))); auto.
Qed.

Theorem drop_mod2 : forall n k,
  2 * k <= n
  -> mod2 (n - 2 * k) = mod2 n.
  induction n as [n] using strong; intros.

  do 2 (destruct n; simpl in *; repeat rewrite untimes2 in *; intuition).

  destruct k; simpl in *; intuition.

  destruct k; simpl; intuition.
  rewrite <- plus_n_Sm.
  repeat rewrite untimes2 in *.
  simpl; auto.
  apply H; lia.
Qed.

Theorem div2_minus_2 : forall n k,
  2 * k <= n
  -> div2 (n - 2 * k) = div2 n - k.
  induction n as [n] using strong; intros.

  do 2 (destruct n; simpl in *; intuition; repeat rewrite untimes2 in * ).
  destruct k; simpl in *; intuition.

  destruct k; simpl in *; intuition.
  rewrite <- plus_n_Sm.
  apply H; lia.
Qed.

Theorem div2_bound : forall k n,
  2 * k <= n
  -> k <= div2 n.
  intros ? n H; case_eq (mod2 n); intro Heq.

  rewrite (div2_odd _ Heq) in H.
  lia.

  rewrite (div2_even _ Heq) in H.
  lia.
Qed.

Lemma two_times_div2_bound: forall n, 2 * Nat.div2 n <= n.
Proof.
  eapply strong. intros n IH.
  destruct n.
  - constructor.
  - destruct n.
    + simpl. constructor. constructor.
    + simpl (Nat.div2 (S (S n))).
      specialize (IH n). lia.
Qed.

Lemma div2_compat_lt_l: forall a b, b < 2 * a -> Nat.div2 b < a.
Proof.
  induction a; intros.
  - lia.
  - destruct b.
    + simpl. lia.
    + destruct b.
      * simpl. lia.
      * simpl. apply lt_n_S. apply IHa. lia.
Qed.

(* otherwise b is made implicit, while a isn't, which is weird *)
Arguments div2_compat_lt_l {_} {_} _.

Lemma pow2_add_mul: forall a b,
  pow2 (a + b) = (pow2 a) * (pow2 b).
Proof.
  induction a; destruct b; firstorder auto with arith; simpl.
  repeat rewrite Nat.add_0_r.
  rewrite Nat.mul_1_r; auto.
  repeat rewrite Nat.add_0_r.
  rewrite IHa.
  simpl.
  repeat rewrite Nat.add_0_r.
  rewrite Nat.mul_add_distr_r; auto.
Qed.

Lemma mult_pow2_bound: forall a b x y,
  x < pow2 a -> y < pow2 b -> x * y < pow2 (a + b).
Proof.
  intros.
  rewrite pow2_add_mul.
  apply Nat.mul_lt_mono_nonneg; lia.
Qed.

Lemma mult_pow2_bound_ex: forall a c x y,
  x < pow2 a -> y < pow2 (c - a) -> c >= a -> x * y < pow2 c.
Proof.
  intros.
  replace c with (a + (c - a)) by lia.
  apply mult_pow2_bound; auto.
Qed.

Lemma lt_mul_mono' : forall c a b,
  a < b -> a < b * (S c).
Proof.
  induction c; intros.
  rewrite Nat.mul_1_r; auto.
  rewrite Nat.mul_succ_r.
  apply lt_plus_trans.
  apply IHc; auto.
Qed.

Lemma lt_mul_mono : forall a b c,
  c <> 0 -> a < b -> a < b * c.
Proof.
  intros.
  replace c with (S (c - 1)) by lia.
  apply lt_mul_mono'; auto.
Qed.

Lemma zero_lt_pow2 : forall sz, 0 < pow2 sz.
Proof.
  induction sz; simpl; lia.
Qed.

Lemma one_lt_pow2:
  forall n,
    1 < pow2 (S n).
Proof.
  intros.
  induction n.
  simpl; lia.
  remember (S n); simpl.
  lia.
Qed.

Lemma one_le_pow2 : forall sz, 1 <= pow2 sz.
Proof.
  intros. pose proof (zero_lt_pow2 sz). lia.
Qed.

Lemma pow2_ne_zero: forall n, pow2 n <> 0.
Proof.
  intros.
  pose proof (zero_lt_pow2 n).
  lia.
Qed.

Lemma mul2_add : forall n, n * 2 = n + n.
Proof.
  induction n; lia.
Qed.

Lemma pow2_le_S : forall sz, (pow2 sz) + 1 <= pow2 (sz + 1).
Proof.
  induction sz; simpl; auto.
  repeat rewrite Nat.add_0_r.
  rewrite pow2_add_mul.
  repeat rewrite mul2_add.
  pose proof (zero_lt_pow2 sz).
  lia.
Qed.

Lemma pow2_bound_mono: forall a b x,
  x < pow2 a -> a <= b -> x < pow2 b.
Proof.
  intros.
  replace b with (a + (b - a)) by lia.
  rewrite pow2_add_mul.
  apply lt_mul_mono; auto.
  pose proof (zero_lt_pow2 (b - a)).
  lia.
Qed.

Lemma pow2_inc : forall n m,
  0 < n -> n < m ->
    pow2 n < pow2 m.
Proof.
  intros.
  generalize dependent n; intros.
  induction m; simpl.
  intros. inversion H0.
  unfold lt in H0.
  rewrite Nat.add_0_r.
  inversion H0.
  apply Nat.lt_add_pos_r.
  apply zero_lt_pow2.
  apply Nat.lt_trans with (pow2 m).
  apply IHm.
  exact H2.
  apply Nat.lt_add_pos_r.
  apply zero_lt_pow2.
Qed.

Lemma pow2_S: forall x, pow2 (S x) = 2 * pow2 x.
Proof. intros. reflexivity. Qed.

Lemma mod2_S_S : forall n,
  mod2 (S (S n)) = mod2 n.
Proof.
  intros.
  destruct n; auto; destruct n; auto.
Qed.

Lemma mod2_S_not : forall n,
  mod2 (S n) = if (mod2 n) then false else true.
Proof.
  intros.
  induction n; auto.
  rewrite mod2_S_S.
  destruct (mod2 n); replace (mod2 (S n)); auto.
Qed.

Lemma mod2_S_eq : forall n k,
  mod2 n = mod2 k ->
  mod2 (S n) = mod2 (S k).
Proof.
  intros.
  do 2 rewrite mod2_S_not.
  rewrite H.
  auto.
Qed.

Theorem drop_mod2_add : forall n k,
  mod2 (n + 2 * k) = mod2 n.
Proof.
  intros.
  induction n.
  simpl.
  rewrite Nat.add_0_r.
  replace (k + k) with (2 * k) by lia.
  apply mod2_double.
  replace (S n + 2 * k) with (S (n + 2 * k)) by lia.
  apply mod2_S_eq; auto.
Qed.

Lemma mod2sub: forall a b,
  b <= a ->
  mod2 (a - b) = xorb (mod2 a) (mod2 b).
Proof.
  intros. remember (a - b) as c. revert dependent b. revert a. revert c.
  change (forall c,
    (fun c => forall a b, b <= a -> c = a - b -> mod2 c = xorb (mod2 a) (mod2 b)) c).
  apply strong.
  intros c IH a b AB N.
  destruct c.
  - assert (a=b) by lia. subst. rewrite Bool.xorb_nilpotent. reflexivity.
  - destruct c.
    + assert (a = S b) by lia. subst a. simpl (mod2 1). rewrite mod2_S_not.
      destruct (mod2 b); reflexivity.
    + destruct a; [lia|].
      destruct a; [lia|].
      simpl.
      apply IH; lia.
Qed.

Theorem mod2_pow2_twice: forall n,
  mod2 (pow2 n + (pow2 n + 0)) = false.
Proof.
  intros.
  replace (pow2 n + (pow2 n + 0)) with (2 * pow2 n) by lia.
  apply mod2_double.
Qed.

Theorem div2_plus_2 : forall n k,
  div2 (n + 2 * k) = div2 n + k.
Proof.
  induction n; intros.
  simpl.
  rewrite Nat.add_0_r.
  replace (k + k) with (2 * k) by lia.
  apply div2_double.
  replace (S n + 2 * k) with (S (n + 2 * k)) by lia.
  destruct (Even.even_or_odd n).
  - rewrite <- even_div2.
    rewrite <- even_div2 by auto.
    apply IHn.
    apply Even.even_even_plus; auto.
    apply Even.even_mult_l; repeat constructor.

  - rewrite <- odd_div2.
    rewrite <- odd_div2 by auto.
    rewrite IHn.
    lia.
    apply Even.odd_plus_l; auto.
    apply Even.even_mult_l; repeat constructor.
Qed.

Lemma pred_add:
  forall n, n <> 0 -> pred n + 1 = n.
Proof.
  intros; rewrite pred_of_minus; lia.
Qed.

Lemma pow2_zero: forall sz, (pow2 sz > 0)%nat.
Proof.
  induction sz; simpl; auto; lia.
Qed.

Theorem Npow2_nat : forall n, nat_of_N (Npow2 n) = pow2 n.
  induction n as [|n IHn]; simpl; intuition.
  rewrite <- IHn; clear IHn.
  case_eq (Npow2 n); intuition.
Qed.

Theorem pow2_N : forall n, Npow2 n = N.of_nat (pow2 n).
Proof.
  intro n.
  apply nat_of_N_eq. rewrite Nat2N.id. apply Npow2_nat.
Qed.

Lemma Z_of_N_Npow2: forall n, Z.of_N (Npow2 n) = (2 ^ Z.of_nat n)%Z.
Proof.
  intros.
  rewrite pow2_N.
  rewrite nat_N_Z.
  rewrite Nat2Z.inj_pow.
  reflexivity.
Qed.

Lemma pow2_S_z:
  forall n, Z.of_nat (pow2 (S n)) = (2 * Z.of_nat (pow2 n))%Z.
Proof.
  intros.
  replace (2 * Z.of_nat (pow2 n))%Z with
      (Z.of_nat (pow2 n) + Z.of_nat (pow2 n))%Z by lia.
  simpl.
  repeat rewrite Nat2Z.inj_add.
  ring.
Qed.

Lemma pow2_le:
  forall n m, (n <= m)%nat -> (pow2 n <= pow2 m)%nat.
Proof.
  intros.
  assert (exists s, n + s = m) by (exists (m - n); lia).
  destruct H0; subst.
  rewrite pow2_add_mul.
  pose proof (pow2_zero x).
  replace (pow2 n) with (pow2 n * 1) at 1 by lia.
  apply mult_le_compat_l.
  lia.
Qed.

Lemma Zabs_of_nat:
  forall n, Z.abs (Z.of_nat n) = Z.of_nat n.
Proof.
  unfold Z.of_nat; intros.
  destruct n; auto.
Qed.

Lemma Npow2_not_zero:
  forall n, Npow2 n <> 0%N.
Proof.
  induction n; simpl; intros; [discriminate|].
  destruct (Npow2 n); auto.
  discriminate.
Qed.

Lemma Npow2_S:
  forall n, Npow2 (S n) = (Npow2 n + Npow2 n)%N.
Proof.
  simpl; intros.
  destruct (Npow2 n); auto.
  rewrite <-Pos.add_diag.
  reflexivity.
Qed.

Lemma Npow2_pos: forall a,
    (0 < Npow2 a)%N.
Proof.
  intros.
  destruct (Npow2 a) eqn: E.
  - exfalso. apply (Npow2_not_zero a). assumption.
  - constructor.
Qed.

Lemma minus_minus: forall a b c,
  c <= b <= a ->
  a - (b - c) = a - b + c.
Proof. intros. lia. Qed.

Lemma even_odd_destruct: forall n,
  (exists a, n = 2 * a) \/ (exists a, n = 2 * a + 1).
Proof.
  induction n.
  - left. exists 0. reflexivity.
  - destruct IHn as [[a E] | [a E]].
    + right. exists a. lia.
    + left. exists (S a). lia.
Qed.

Lemma mul_div_undo: forall i c,
    c <> 0 ->
    c * i / c = i.
Proof.
  intros.
  pose proof (Nat.div_mul_cancel_l i 1 c) as P.
  rewrite Nat.div_1_r in P.
  rewrite Nat.mul_1_r in P.
  apply P; auto.
Qed.

Lemma mod_add_r: forall a b,
    b <> 0 ->
    (a + b) mod b = a mod b.
Proof.
  intros. rewrite <- Nat.add_mod_idemp_r by lia.
  rewrite Nat.mod_same by lia.
  rewrite Nat.add_0_r.
  reflexivity.
Qed.

Lemma mod2_cases: forall (n: nat), n mod 2 = 0 \/ n mod 2 = 1.
Proof.
  intros.
  assert (n mod 2 < 2). {
    apply Nat.mod_upper_bound. congruence.
  }
  lia.
Qed.

Lemma div_mul_undo: forall a b,
    b <> 0 ->
    a mod b = 0 ->
    a / b * b = a.
Proof.
  intros.
  pose proof Nat.div_mul_cancel_l as A. specialize (A a 1 b).
  replace (b * 1) with b in A by lia.
  rewrite Nat.div_1_r in A.
  rewrite mult_comm.
  rewrite <- Nat.divide_div_mul_exact; try assumption.
  - apply A; congruence.
  - apply Nat.mod_divide; assumption.
Qed.

Lemma Smod2_1: forall k, S k mod 2 = 1 -> k mod 2 = 0.
Proof.
  intros k C.
  change (S k) with (1 + k) in C.
  rewrite Nat.add_mod in C by congruence.
  pose proof (Nat.mod_upper_bound k 2).
  assert (k mod 2 = 0 \/ k mod 2 = 1) as E by lia.
  destruct E as [E | E]; [assumption|].
  rewrite E in C. simpl in C. discriminate.
Qed.

Lemma mod_0_r: forall (m: nat),
    m mod 0 =
    ltac:(match eval hnf in (1 mod 0) with | 0 => exact 0 | _ => exact m end).
Proof.
  intros. reflexivity.
Qed.

Lemma sub_mod_0: forall (a b m: nat),
    a mod m = 0 ->
    b mod m = 0 ->
    (a - b) mod m = 0.
Proof.
  intros. assert (m = 0 \/ m <> 0) as C by lia. destruct C as [C | C].
  - subst. cbn in *. now subst.
  - assert (a - b = 0 \/ b < a) as D by lia. destruct D as [D | D].
    + rewrite D. apply Nat.mod_0_l. assumption.
    + apply Nat2Z.inj. simpl.
      rewrite Zdiv.mod_Zmod by assumption.
      rewrite Nat2Z.inj_sub by lia.
      rewrite Zdiv.Zminus_mod.
      rewrite <-! Zdiv.mod_Zmod by assumption.
      rewrite H. rewrite H0.
      apply Z.mod_0_l.
      lia.
Qed.

Lemma mul_div_exact: forall (a b: nat),
    b <> 0 ->
    a mod b = 0 ->
    b * (a / b) = a.
Proof.
  intros. edestruct Nat.div_exact as [_ P]; [eassumption|].
  specialize (P H0). symmetry. exact P.
Qed.


From sorting Require Export Utils.
From sorting Require Export Sorted.

(** * Definition  *)

Fixpoint select (x : nat) (l : list nat) : nat * list nat :=
  match l with
  |  nil => (x, nil)
  |  h :: t => if x <=? h
                 then let (j, l') := select x t in (j, h :: l')
                 else let (j, l') := select h t in (j, x :: l')
  end.

Fixpoint selsort (l : list nat) (n : nat) {struct n} :=
  match l, n with
  | x :: r, S n' => let (y,r') := select x r
                 in y :: selsort r' n'
  | nil, _ => nil
  | _ :: _, O => nil
  end.

Definition selection_sort (l : list nat) :=
  selsort l (length l).

(** * Correctness goal  *)

Definition selection_sort_correct : Prop :=
  is_a_sorting_algorithm selection_sort.

(** * Permutations *)

Lemma select_perm:
  forall (x : nat) (l : list nat),
    let (y, r) := select x l in Permutation (x :: l) (y :: r).
Proof.
  intros x l; revert x.
  induction l; intros; simpl in *. {
    apply Permutation_refl.
  } {
    unfold select.
    bdestruct (x <=? a); fold select. {
      specialize (IHl x).
      destruct (select x l) eqn:Seq.
      apply perm_trans with (a :: n :: l0). {
        apply Permutation_sym.
        apply perm_trans with (a :: x :: l). {
          now apply perm_skip.
        } {
          apply perm_swap.
        }
      } {
        apply perm_swap.
      }
    } {
      specialize (IHl a).
      destruct (select a l) eqn:Seq.
      apply perm_trans with (x :: n :: l0). {
        now apply perm_skip.
      } {
        apply perm_swap.
      }
    }
  }
Qed.

Lemma selsort_perm:
  forall (n : nat) (l : list nat), length l = n -> Permutation l (selsort l n).
Proof.
  induction n. {
    intros.
    destruct l. {
      apply perm_nil.
    } {
      inversion H.
    }
  } {
    intros.
    destruct l. {
      intros.
      inversion H.
    } {
      simpl.
      destruct (select n0 l) eqn:Seq.
      apply perm_trans with (n1 :: l0). {
        assert (let (y, r) := select n0 l in Permutation (n0 :: l) (y :: r)). {
          apply (select_perm n0 l).
        }
        destruct (select n0 l).
        inv Seq.
        apply H0.
      } {
        apply perm_skip.
        apply IHn.
        assert (length (n0::l) = (length (n1::l0))). {
          apply Permutation_length.
          assert (let (y, r) := select n0 l in Permutation (n0 :: l) (y :: r)). {
            apply (select_perm n0 l).
          }
          destruct (select n0 l).
          inv Seq.
          apply H0.
        }
        inv H0.
        inv H.
        reflexivity.
      }
    }
  }
Qed.

Theorem selection_sort_perm:
  forall (l : list nat), Permutation l (selection_sort l).
Proof.
  unfold selection_sort.
  intros.
  apply selsort_perm.
  reflexivity.
Qed.

(** * [select] selects the smallest element of a list *)

Lemma select_smallest_aux:
  forall (x : nat) (al : list nat) (y : nat) (bl : list nat),
    Forall (fun z => y <= z) bl ->
    select x al = (y,bl) ->
    y <= x.
Proof.
  intros.
  pose (select_perm x al).
  rewrite H0 in y0.
  apply (Permutation_in x) in y0. {
    destruct y0. {
      omega.
    } {
      rewrite Forall_forall in H.
      apply H.
      apply H1.
    }
  } {
    apply in_eq.
  }
Qed.

Theorem select_smallest:
  forall (x : nat) (al : list nat) (y : nat) (bl : list nat),
    select x al = (y,bl) ->
    Forall (fun z => y <= z) bl.
Proof.
  intros x al.
  revert x.
  induction al; intros; simpl in *. {
    inv H.
    easy.
  } {
    bdestruct (x <=? a). {
      destruct select eqn:Seq.
      inv H.
      apply Forall_cons. {
        apply (le_trans y x a). {
          apply (select_smallest_aux x al y l). {
            apply (IHal x y l).
            easy.
          } {
            easy.
          }
        } {
          easy.
        }
      } {
        apply (IHal x y l).
        easy.
      }
    } {
      destruct (select a al) eqn:?H.
      inv H.
      apply Forall_cons. {
        assert (y <= a). {
          apply (select_smallest_aux a al y l). {
            apply (IHal a y l).
            apply H1.
          } {
            apply H1.
          }
        }
        omega.
      } {
        apply (IHal a y l).
        easy.
      }
    }
  }
Qed.

(** * A list applied with selection sort is sorted **)

Lemma selection_sort_sorted_aux:
  forall (y : nat) (bl : list nat),
   sorted (selsort bl (length bl)) ->
   Forall (fun z : nat => y <= z) bl ->
   sorted (y :: selsort bl (length bl)).
Proof.
  induction bl. {
    simpl.
    intros.
    apply sorted_1.
  } {
    intros.
    simpl in *.
    destruct select eqn:Seq.
    apply sorted_cons. {
      rewrite Forall_forall in H0.
      apply H0.
      apply Permutation_in with (n :: l). {
        pose (select_perm a bl).
        rewrite Seq in y0.
        apply Permutation_sym.
        apply y0.
      } {
        apply in_eq.
      }
    } {
      apply H.
    }
  }
Qed.

Theorem selection_sort_sorted:
  forall (al : list nat), sorted (selection_sort al).
Proof.
  intros.
  unfold selection_sort.
  remember (length al) as n.
  generalize dependent al.
  induction n. {
    intros.
    simpl.
    destruct al. {
      apply sorted_nil.
    } {
      apply sorted_nil.
    }
  } {
    intros.
    destruct al. {
      apply sorted_nil.
    } {
      unfold selsort.
      fold selsort.
      destruct (select n0 al) eqn:Seq.
      pose (select_perm n0 al).
      rewrite Seq in y.
      apply Permutation_length in y.
      rewrite <- Heqn in y.
      inversion y.
      apply (selection_sort_sorted_aux n1 l). {
        rewrite <- H0.
        apply IHn.
        apply H0.
      } {
        apply (select_smallest n0 al n1 l).
        apply Seq.
      }
    }
  }
Qed.

(** * Wrapping up **)

Theorem selection_sort_is_correct:
  selection_sort_correct.
Proof.
  split.
  apply selection_sort_perm.
  apply selection_sort_sorted.
Qed.


Section LPPO_1.
Variable D: Set.
Variable c d e :D.
Variable P Q T: D-> Prop.
(*1*)
Theorem pred_008 : ~(forall x, P x) -> ~ forall x, P x /\ Q x.
Proof.
intros.
intro.
apply H.
intro.
destruct H.
intro x0.
apply H0.
Qed.
(*2*)
Theorem pred_013 : (exists x, P x \/ Q x) -> (forall x, ~Q x) -> exists x, P x.
Proof.
intro.
destruct H.
exists x.
destruct H.
assumption.
apply H0 in H.
contradiction.
Qed.
(*3*)
Theorem pred_025 : ~(forall x, P x /\ Q x) /\ (forall x, P x) -> ~forall x, Q x.
Proof.
intros.
intro.
destruct H.
apply H.
intro.
split.
apply H1.
apply H0.
Qed.
(*4*)
Theorem pred_035 : (forall y, Q y -> ~exists x, P x) /\ (forall x, P x) -> forall y, ~Q y.
Proof.
intro.
destruct H.
intros.
intro.
apply H in H1.
apply H1.
exists y.
apply H0.
Qed.
(*5*)
Theorem pred_067 : (forall x, ~P x) -> ~exists x, P x.
Proof.
intros.
intro.
destruct H0.
apply H in H0.
assumption.
Qed.
End LPPO_1.
Section LPPO_2.
Variable A : Set.
Variables (P Q : A -> Prop)
(R : A -> A -> Prop).
(*6*)
Lemma forall_imp_dist : (forall x:A, P x -> Q x) ->
(forall x:A, P x) ->
forall x: A, Q x.
Proof.
intros.
apply H.
apply H0.
Qed.
(*7*)
Lemma forall_perm : (forall x y:A, R x y) -> forall y x, R x y.
Proof.
intros.
apply H.
Qed.
(*8*)
Lemma forall_delta : (forall x y:A, R x y) -> forall x, R x x.
Proof.
intros.
apply H.
Qed.
(*9*)
Lemma exists_or_dist : (exists x: A, P x \/ Q x) <->
(exists x, P x) \/ (exists x , Q x).
Proof.
split.
intros.
destruct H.
destruct H.
left.
exists x.
assumption.
right.
exists x.
assumption.
intros.
destruct H.
destruct H.
exists x.
left.
assumption.
destruct H.
exists x.
right.
assumption.
Qed.
(*10*)
Lemma exists_imp_dist : (exists x: A, P x -> Q x) ->
(forall x:A, P x) ->
exists x:A, Q x.
Proof.
intros.
destruct H.
exists x.
apply H.
apply H0.
Qed.
(*11*)
Lemma not_empty_forall_exists : forall a:A,
(forall x:A, P x) ->
exists x:A, P x.
Proof.
intros.
exists a.
apply H.
Qed.
(*12*)
Lemma not_ex_forall_not : ~(exists x:A, P x) <-> forall x:A, ~P x.
Proof.
split.
intros.
intro.
apply H.
exists x.
assumption.
intros.
intro.
destruct H0.
apply H in H0.
assumption.
Qed.
End LPPO_2.


Set Implicit Arguments.

Inductive nat : Set :=
  | O : nat
  | S : nat -> nat.

Inductive nat' : Set := O' | S'(_:nat').  (* alternative syntax *)

Inductive even : nat -> Prop :=
  | even_O  : even O
  | even_SS : forall n:nat, even n -> even (S (S n)).

Inductive list (A:Set) : Set :=
  | nil : list A
  | cons: A -> list A -> list A.

Inductive list' (A:Set) : Set := nil' | cons'(_:A)(_:list' A).

(* Variant is like Inductive but no recursive definitionof types *)

Inductive sum (A B: Set) : Set := left : A -> sum A B | right : B -> sum A B.

Inductive tree (A B:Set) : Set :=
  | node : A -> forest A B -> tree A B
  with forest (A B:Set) : Set :=
    | leaf    : B -> forest A B
    | cons''  : tree A B -> forest A B -> forest A B.

CoInductive stream (A:Set): Set :=
  | seq : A -> stream A -> stream A.

Definition head {A:Set}(x:stream A) : A := let (a,s):=x in a.
Definition tail {A:Set}(x:stream A) : stream A := let (a,s):=x in s.

CoInductive Eq {A:Set} : stream A -> stream A -> Prop :=
  eq: forall s1 s2: stream A,
    head s1 = head s2 -> Eq (tail s1) (tail s2) -> Eq s1 s2.

Fixpoint add(n m:nat) (* {struct n} *): nat :=
  match n with
    | O   => m
    | S p => S (add p m)
  end.

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

Fixpoint nat_match
  {C:Set} (f0:C) (fS: nat -> C -> C) (n:nat) : C :=
    match n with
      | O     => f0
      | S p   => fS p (nat_match f0 fS p)
    end.

Fixpoint mod2 (n:nat) : nat :=
  match n with
    | O   => O
    | S p => match p with
              | O   => S O
              | S q => mod2 q
            end
  end.

Eval compute in mod2 (S (S (S (S O)))).
Eval compute in mod2 (S (S (S (S (S O))))).

Fixpoint even' (n : nat) : Prop :=
  match n with
    | O   => True
    | S p => odd' p
  end
  with odd'(n : nat) : Prop :=
    match n with
      | O   => False
      | S p => even' p
    end.

Eval compute in even' (S (S (S (S O)))).
Eval compute in odd' (S (S (S (S O)))).
Eval compute in even' (S (S (S (S (S O))))).
Eval compute in odd' (S (S (S (S (S O))))).

CoFixpoint from (n : nat) : stream nat :=
  seq n (from (S n)).

Definition integers := from O.

Fixpoint sub (n:nat) : stream nat :=
  match n with
    | O   => integers
    | S p => tail (sub p)
  end.

Definition id (n:nat) : nat := head (sub n).

Eval compute in id O.
Eval compute in id (S O).
Eval compute in id( S (S O)).

Lemma same : forall n:nat, id n = n.
Proof.
  intro n. elim n.
    clear n. unfold id. simpl. reflexivity.
    clear n. intros n IH. unfold id. unfold id in IH.
    unfold sub. fold sub.
Abort.

Eval compute in from O.
Eval compute in head (from O).
Eval compute in tail (from O).


Require Import SetoidClass.
Require groups.

Module Make(Import M: groups.T).

Class ring (F: Set) (s: Setoid F) (op1 op2: F -> F -> F) (zero one: F) (inv1: F -> F)
                     (g1: @group F s op1 zero inv1) :=
{
  r_assoc     : forall {a b c}, op2 (op2 a b) c == op2 a (op2 b c);
  r_identity  : forall {a}, op2 one a == a;
  r_inverser  : forall a: F, op1 (inv1 a) a == zero;
  r_idsdiffer : ~ one == zero;
  r_comm      : forall {a b}, op1 a b == op1 b a;
  r_distrib   : forall {a b c}, (op2 a (op1 b c)) == op1 (op2 a b) (op2 a c)
}.
Check ring.

Require Import Psatz.
Require Import Nsatz.
Require Import ZArith.
Open Scope Z_scope.

Definition zmult (n m: Z):= n * m.
Definition zid2 := 1%Z.

Program Instance Zeq_setoid : Setoid Z :=
  { equiv := eq ; setoid_equiv := eq_equivalence }.

(** < Z, +, *, 0, 1, ^{-1+} > as a ring instance **)
Program Instance ring_integers: (@ring Z (Zeq_setoid) _ zmult _ zid2 _ group_integers).
Obligation 1. unfold zmult. rewrite Zmult_assoc. reflexivity. Qed.
Next Obligation. destruct a; reflexivity. Qed.
Next Obligation. unfold zadd, zinv, zid. omega. Qed.
Next Obligation. unfold zadd. omega. Qed.
Next Obligation. unfold zadd, zmult. apply Zmult_plus_distr_r. Qed.
Check ring_integers.

Require Import Psatz.
Require Import Nsatz.
Require Import QArith.
Open Scope Q_scope.

Definition qmult (n m: Q) := n * m.
Definition qid2 := 1.

(** < Q, +, *, 0, 1, ^{-1+} > as a ring instance **)
Program Instance ring_rationals: `(@ring Q (Qeq_setoid) _ qmult _ qid2 _ group_rationals).
Obligation 1. unfold qmult. symmetry. apply Qmult_assoc. Qed.
Next Obligation. unfold qmult, qid2. apply Qmult_1_l. Qed.
Next Obligation. unfold qadd, qinv, qid. rewrite Qplus_comm, Qplus_opp_r. reflexivity. Qed.
Next Obligation. unfold qadd. apply Qplus_comm. Qed.
Next Obligation. unfold qadd, qmult. apply Qmult_plus_distr_r. Qed.
Check ring_rationals.

Require Import ZArith_base.
Require Import Rdefinitions.
Require Import Coq.Reals.Raxioms.
Local Open Scope R_scope.

Definition rmult (n m: R) := n * m.
Definition rid2 := 1.

(** < R, +, *, 0, 1, ^{-1+} > as a ring instance **)
Program Instance ring_reals: `(@ring R _ _ rmult _ rid2 _ group_reals).
Obligation 1. unfold rmult. apply Rmult_assoc. Qed.
Next Obligation. unfold rmult, rid2. apply Rmult_1_l. Qed.
Next Obligation. unfold radd, rinv, rid. rewrite Rplus_comm, Rplus_opp_r. reflexivity. Qed.
Next Obligation. unfold rid, rid2. apply R1_neq_R0. Qed.
Next Obligation. unfold radd. apply Rplus_comm. Qed.
Next Obligation. unfold radd, rmult. apply  Rmult_plus_distr_l. Qed.
Check ring_reals.

End Make.


Require Import ZArith.
Require Import Bool.
Open Scope Z_scope.

Inductive Z_fbtree : Set :=
 | Z_fleaf : Z_fbtree
 | Z_fnode : Z  -> (bool -> Z_fbtree) -> Z_fbtree.

Fixpoint fzero_present (t:Z_fbtree) : bool :=
 match t with
  | Z_fleaf => false
  | Z_fnode v f => match v with 0 => true
                              | _ => orb (fzero_present (f true))
                                         (fzero_present (f false))
                   end
 end.


From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat div.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

(* Unset Printing Notations. *)

(** Use SSReflect tactics.
    DO NOT use automation like [tauto], [intuition], [firstorder], etc.,
    except for [by], [done], [exact] tactic(al)s. *)

(** * Exercise *)

Lemma demorgan (A B : Prop) : ~ (A \/ B) -> (~ A /\ ~ B).
Restart.
move => nab.
move : conj.
apply.
- move => a.
  apply : nab.
  apply : or_introl.
  exact a.
move => b.
apply : nab.
apply : or_intror.
exact b.
Qed.

Lemma nlem (A : Prop):
  ~ (A \/ ~ A) -> A.
Restart.
move => noana.
move : (demorgan noana).
case.
move => na nna.
apply : False_ind.
exact (nna na).
Qed.

(** Hint: you might want to use a separate lemma here to make progress.
Or, use the `have` tactic: `have: statement` creates a new subgoal and asks
you to prove the statement. This is like a local lemma. *)

(** * Exercise *)

Lemma weak_Peirce (A B : Prop) :
  ((((A -> B) -> A) -> A) -> B) -> B.
Restart.
move => f.
apply : (f).
move => g.
apply : (g).
move => a.
apply : (f).
move => h.
exact a.
Qed.

(** * Exercise *)

(* Prove that having a general fixed-point combinator in Coq would be incosistent *)

Definition FIX := forall A : Type, (A -> A) -> A.

Lemma fix_inconsistent :
  FIX -> False.
Restart.
move => f.
move : (@f False).
apply.
exact id.
Qed.

Section Boolean.
(** * Exercise *)

Lemma negbNE b : ~~ ~~ b -> b.
Restart.
rewrite /negb.
move : b.
case.
- exact id.
- exact id.
Qed.

(** * Exercise *)

Lemma negbK : involutive negb.
Restart.
rewrite /involutive /negb /cancel.
case.
-  by [].
by [].
Qed.

(** * Exercise *)

Lemma negb_inj : injective negb.
Restart.
rewrite /injective /negb.
case.
- case.
  - by [].
  - by [].
case.
  - by [].
  - by [].
Qed.

End Boolean.

(** * Exercise *)

Fixpoint triple (n : nat) : nat :=
  if n is n'.+1 then (triple n').+3
  else n.

Lemma triple_mul3 n :
  triple n = 3 * n.
Restart.
elim : n.
- exact erefl.
move => n ih /=.
rewrite mulnS /=.
rewrite /addn /addn_rec /Nat.add.
exact (congr1 (fun x => S (S (S x))) ih).
Qed.

(** Hints:
- use the /= action to simplify your goal: e.g. move=> /=.
- use `Search (<pattern>)` to find a useful lemma about multiplication
*)

(** * Exercise
Prove by it induction: you may re-use the addnS and addSn lemmas only *)

Lemma plus_two_inj (n m : nat) : S (S n) = S (S m) -> eq n m.
Restart.
case.
exact.
Qed.

Lemma zz_plus (n : nat) : O = addn n n -> eq O n.
Restart.
case : n.
- exact.
exact.
Qed.

Lemma plus_zz (n : nat) : addn n n = O -> eq n O.
Restart.
case : n.
- exact.
exact.
Qed.

Lemma two_is_double_one (n : nat) : S (S O) = addn n n -> eq (S O) n.
Restart.
elim : n.
- exact.
move => n ih.
rewrite (addSn n (S n)).
rewrite (addnS n n).
move => h.
move : (plus_two_inj h).
move => h2.
move : (zz_plus h2).
move => h3.
exact (congr1 S h3).
Qed.

Lemma double_inj m n :
  m + m = n + n -> m = n.
Restart.
move : n m.
elim.
- apply : plus_zz.
move => n h1.
case.
- apply : zz_plus.
move => k.
rewrite (addSn k (S k)).
rewrite (addnS k k).
rewrite (addSn n (S n)).
rewrite (addnS n n).
move => h2.
move : (plus_two_inj h2).
move => h3.
move : (h1 k h3).
apply : (congr1 S).
Qed.

(* This is a harder exercise than the previous ones but
   the tactics you already know are sufficient *)

(** * Optional exercise
    [negb \o odd] means "even".
    The expression here says, informally,
    the sum of two numbers is even if the summands have the same "evenness",
    or, equivalently, "even" is a morphism from [nat] to [bool] with respect
    to addition and equivalence correspondingly.
    Hint: [Unset Printing Notations.] and [rewrite /definition] are your friends :)
 *)

Lemma s_flips_odd (n : nat) : odd (S n) = negb (odd n).
Restart.
elim : n.
- exact.
exact.
Qed.

Lemma rneutral_z (n : nat) : addn n O = n.
elim : n.
- exact.
move => n ih.
rewrite (addSn n O).
exact (congr1 S ih).
Qed.

Lemma rneutral_true (b : bool) : (Equality.op (Equality.class bool_eqType) b true) = b.
Restart.
case : b.
- exact.
exact.
Qed.

Check s_flips_odd.
Check rneutral_z.
Check rneutral_true.

Lemma even_add :
  {morph (negb \o odd) : x y / x + y >-> x == y}.
Restart.
rewrite /morphism_2 /eq_op /(comp negb odd).
elim.
- exact.
move => n ih.
case.
- rewrite (addSn n O).
  rewrite (rneutral_z n).
  rewrite (s_flips_odd n).
  rewrite /(negb (odd O)).
  rewrite /(odd O).
  rewrite (rneutral_true (negb (negb (odd n)))).
  exact.
have h1 : forall (a b : bool), (Equality.op (Equality.class bool_eqType) (negb a) b) = negb (Equality.op (Equality.class bool_eqType) a b).
case.
- exact.
case.
- exact.
exact.
move => k.
rewrite (s_flips_odd n).
rewrite (h1 (negb (odd n)) (negb (odd (S k)))).
rewrite /(addSn n (S k)).
exact (congr1 negb (ih (S k))).
Qed.

(** * Optional exercise *)

Definition LEM (Q : Prop) := or Q (not Q).
Definition DNE (Q : Prop) := not (not Q) -> Q.

Lemma LEM_implies_DNE : forall Q : Prop, (LEM Q) -> (DNE Q).
Restart.
rewrite /LEM /DNE.
move => q.
case.
- exact.
move => nq nnq.
apply : (False_ind q (nnq nq)).
Qed.

Lemma nn_LEM : forall Q, not (not (LEM Q)).

Restart.
rewrite /LEM.
move => q.
move => h1.
move : (nlem h1).
move => vq.
move : (h1 (or_introl vq)).
exact.
Qed.

Lemma DNE_implies_LEM : (forall Q, DNE Q) -> (forall P, LEM P).
Restart.
move => dne.
move => p.
apply : (dne).
move => h1.
move : (nn_LEM h1).
exact.
Qed.

Reset DNE_iff_nppp.

Lemma DNE_iff_nppp :
  (forall P, ~ ~ P -> P) <-> (forall P, (~ P -> P) -> P).
Restart.
split.
- move => h1.
  move => p.
  move : (DNE_implies_LEM h1).
  move => h2.
  move : (h2 p).
  case.
  - exact.
  move => np.
  move => h3.
  exact (h3 np).
move => h1 p.
apply : LEM_implies_DNE.
apply : (h1).
move => h2.
move : (nn_LEM h2).
exact.
Qed.

(** * Optional exercise *)

Lemma leq_add1l p m n :
  m <= n -> m <= p + n.
Restart.
move : (leq0n p).
apply : leq_add.
Qed.

(** Hint: this lemmas does not require induction, just look for a couple lemmas *)

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

(*
More fun with functions, OPTIONAL
*)

Section PropertiesOfFunctions.

Lemma comp_assoc (a b c d: Type) (f : c -> d) (g : b -> c) (h : a -> b) : (f \o g) \o h =1 f \o (g \o h).
Restart.
done.
Qed.

Lemma comp_sym (a b : Type) (f g : a -> b) : f =1 g -> g =1 f.
Restart.
rewrite /eqfun.
move => fg.
move => x.
move : (fg x).
exact.
Qed.

Lemma comp_assoc_both
      (a b c d : Type)
      (g1 g2 : c -> d) (f : b -> c) (h1 h2 : a -> b)
  : (g1 \o f) \o h1 =1 (g2 \o f) \o h2
    -> g1 \o (f \o h1) =1 g2 \o (f \o h2).
Proof.
  move => k1.
  move : (comp_assoc g1 f h1) (comp_assoc g2 f h2).
  move => //.
Qed.

Lemma comp_assoc_both_r
      (a b c d : Type)
      (g1 g2 : c -> d) (f : b -> c) (h1 h2 : a ->b) :
  g1 \o (f \o h1) =1 g2 \o (f \o h2) -> (g1 \o f) \o h1 =1 (g2 \o f) \o h2.
Proof.
  done.
Qed.

Section SurjectiveEpic.

Context {A B : Type}.

(* https://en.wikipedia.org/wiki/Surjective_function *)
(** Note: This definition is too strong in Coq's setting, see [epic_surj] below *)

Definition surjective (f : A -> B) :=
  exists g : B -> A, f \o g =1 id.

(** This is a category-theoretical counterpart of surjectivity:
    https://en.wikipedia.org/wiki/Epimorphism *)

Definition epic (f : A -> B) :=
  forall C (g1 g2 : B -> C), g1 \o f =1 g2 \o f -> g1 =1 g2.

(** * Optional exercise *)

Lemma surj_epic f : surjective f -> epic f.
Restart.
rewrite /surjective /epic.
case.
move => x.
move => h1.
move => c.
move => g1 g2.
move => eg12f.
have xx : (x =1 x).
exact.
move : (eq_comp eg12f xx).
move : (comp_assoc g1 f x).
move => h2 h3.
move : (comp_assoc g2 f x).
move => h4.
move : (comp_sym h2).
move => h5.
move : (ftrans h5 h3).
move => h6.
move : (ftrans h6 h4).
have gg1 : g1 =1 g1.
exact.
have gg2 : g2 =1 g2.
exact.
move : (eq_comp gg1 h1) (eq_comp gg2 h1).
move => s1 s2.
move => s3.
move : (ftrans (comp_sym s1) s3).
move => s4.
move : (ftrans s4 s2).
exact.
Qed.

(** * Optional exercise *)

Lemma epic_surj f : epic f -> surjective f.
  (** Why is this not provable? *)
Abort.

End SurjectiveEpic.

Section EpicProperties.

Context {A B C : Type}.

(** * Optional exercise *)

Lemma epic_comp (f : B -> C) (g : A -> B) :
  epic f -> epic g -> epic (f \o g).
Restart.
rewrite /epic.
move => epic_f epic_g D g1 g2.
set ef := epic_f D.
set eg := epic_g D.
move => h1.
set h2 := ftrans (comp_assoc g1 f g) h1.
set h3 := (ftrans h2 (comp_sym (comp_assoc g2 f g))).
set h4 := (eg (g1 \o f) (g2 \o f) h3).
exact (ef g1 g2 h4).
Qed.

(** * Optional exercise *)

Lemma comp_epicl (f : B -> C) (g : A -> B) :
  epic (f \o g) -> epic f.
Restart.
rewrite /epic.
move => epic_fg.
move => D g1 g2.
move => h1.
have gg : g =1 g.
exact.
set efg := epic_fg D g1 g2.
set h2 := (comp_assoc_both (eq_comp h1 gg)).
exact (efg h2).
Qed.

(** * Optional exercise *)

Lemma retraction_epic (f : B -> A) (g : A -> B) :
  (f \o g =1 id) -> epic f.
Restart.
rewrite /epic.
move => h1 D g1 g2 h2.
have gg : g =1 g.
exact.
set h3 := comp_assoc_both (eq_comp h2 gg).
have g1g1 : g1 =1 g1.
exact.
have g2g2 : g2 =1 g2.
exact.
have g1fg : g1 \o (f \o g) =1 g1.
move : (eq_comp g1g1 h1).
exact.
have g2fg : g2 \o (f \o g) =1 g2.
move : (eq_comp g2g2 h1).
exact.
exact (ftrans (comp_sym g1fg) (ftrans h3 g2fg)).
Qed.

End EpicProperties.

(** The following section treats some properties of injective functions:
    https://en.wikipedia.org/wiki/Injective_function *)

Section InjectiveMonic.

Context {A B C : Type}.

(** This is a category-theoretical counterpart of injectivity:
    https://en.wikipedia.org/wiki/Monomorphism *)

Definition monic (f : B -> C) :=
  forall A (g1 g2 : A -> B), f \o g1 =1 f \o g2 -> g1 =1 g2.

(** * Optional exercise *)

Lemma inj_monic f : injective f -> monic f.
Restart.
rewrite /injective /monic /comp /eqfun.
move => h1 D.
move => g1 g2.
move => h2.
move => x.
exact (h1 (g1 x) (g2 x) (h2 x)).
Qed.

(** * Optional exercise *)

Lemma monic_inj f : monic f -> injective f.
Restart.
rewrite /injective /monic /comp /eqfun.
move => h1.
move => x1 x2.
set lx1 : unit -> B := fun _ => x1.
set lx2 : unit -> B := fun _ => x2.
set h2 := h1 unit lx1 lx2.
move => h3.
have h4 : forall x : unit, f (lx1 x) = f (lx2 x).
case.
rewrite /lx1 /lx2.
exact h3.
move : (h2 h4).
apply.
exact tt.
Qed.

End InjectiveMonic.

Section MonicProperties.

Context {A B C : Type}.

(** * Optional exercise *)

Lemma monic_comp (f : B -> C) (g : A -> B) :
  monic f -> monic g -> monic (f \o g).
Restart.
rewrite /monic.
move => h1 h2.
move => D.
move => g1 g2.
move => h3.
set h4 := ftrans (comp_sym (comp_assoc f g g1)) h3.
set h5 := ftrans h4 (comp_assoc f g g2).
exact (h2 D g1 g2 (h1 D (g \o g1) (g \o g2) h5)).
Qed.

(** * Optional exercise *)
Lemma comp_monicr (f : B -> C) (g : A -> B) :
  monic (f \o g) -> monic g.
Proof.
  rewrite /monic.
  have ff : f =1 f.
  by exact.
  move => h1 D g1 g2 h2.
  set h3 := (eq_comp ff h2).
  set h4 := (@comp_assoc_both_r _ _ _ _ f f g g1 g2 h3).
  exact (h1 D g1 g2 h4).
Qed.

(** * Optional exercise *)
Lemma section_monic (f : B -> A) (g : A -> B) :
  (g \o f =1 id) -> monic f.
Proof.
  rewrite /monic.
  move => h1.
  move => D.
  move => g1 g2.
  have gg : g =1 g.
    by done.
  move => h2.
  move : (comp_assoc_both_r (eq_comp gg h2)).
  have gfg1 : (g \o f) \o g1 =1 g1.
    - have ig1 :id \o g1 =1 g1.
        by done.
        have g1g1 : g1 =1 g1.
        by done.
        have p1 : (g \o f) \o g1 =1 id \o g1.
        exact (eq_comp h1 g1g1).
        by done.
   have gfg2 : (g \o f) \o g2 =1 g2.
    - have ig2 :id \o g2 =1 g2.
        by done.
        have g2g2 : g2 =1 g2.
        by done.
        have p1 : (g \o f) \o g2 =1 id \o g2.
        exact (eq_comp h1 g2g2).
          by done.
move => h3.
move : (ftrans (comp_sym gfg1) (ftrans h3 gfg2)).
done.
Qed.

End MonicProperties.

End PropertiesOfFunctions.


Set Implicit Arguments.
Require Import List.

Inductive In (A:Type) (y:A) : list A -> Prop :=
  | InHead : forall (xs:list A), In y (cons y xs)
  | InTail : forall (x:A) (xs:list A), In y xs -> In y (cons x xs).

Inductive Prefix (A:Type) : list A -> list A -> Prop :=
  | PreNil : forall (l:list A), Prefix nil l
  | PreCons : forall (x:A) (l1 l2:list A), Prefix l1 l2 -> Prefix (x::l1) (x::l2).

Inductive SubList (A:Type) : list A -> list A -> Prop :=
  | SLnil : forall (l:list A), SubList nil l
  | SLcons1 : forall (x:A) (l1 l2:list A), SubList l1 l2 -> SubList (x::l1) (x::l2)
  | SLcons2 : forall (x:A) (l1 l2:list A), SubList l1 l2 -> SubList l1 (x::l2).

Lemma ex1 : SubList (5::3::nil)  (5::7::3::4::nil).
Proof.
  constructor.
  constructor.
  constructor.
  constructor.
Qed.

Lemma ex1b : forall (A:Type) (l:list A), SubList l l.
Proof.
  intros.
  induction l.
  - constructor.
  - constructor.
    assumption.
Qed.

Lemma ex1c : forall (A B:Type) (f:A->B) (l1 l2:list A), SubList l1 l2 -> SubList (map f l1) (map f l2).
Proof.
  intros.
  induction H.
  - constructor.
  - simpl.
    constructor.
    assumption.
  - simpl.
    constructor.
    assumption.
Qed.

Lemma ex1d : forall (A:Type) (x:A) (l : list A), In x l -> exists l1, exists l2, l = l1 ++ (x::l2).
Proof.
  intros.
  induction H.
  exists nil. exists xs. simpl. reflexivity.
  destruct IHIn as [I1 H1]. destruct H1 as [I2 H1]. exists (x0::I1). exists I2.  rewrite <-app_comm_cons.
  rewrite H1. reflexivity.
Qed.

Fixpoint drop (A:Type) (n:nat) (l : list A)  : list A :=
  match n with
  | 0 => l (* Caso seja drop 0, o resultado é a lista *)
  | S n' => drop n' (tl l) (* Caso seja outro valor, retira-se 1 ao valor e faz-se sobre a cauda *)
  end.

Lemma ex2a : drop 2 (5::7::3::4::nil) = 3::4::nil.
Proof.
  constructor.
Qed.

Lemma ex2b : forall (A:Type) (n:nat) (l:list A), SubList (drop n l) l.
Proof.
  intros H n.
  induction n.
  - induction l.
    * constructor.
    * constructor.
      apply IHl.
  - induction l.
    * simpl.
      apply IHn.
    * constructor.
      simpl.
      apply IHn.
Qed.

Inductive Sorted : list nat -> Prop :=
  | sorted0 : Sorted nil  (* Caso vazio *)
  | sorted1 : forall a:nat, Sorted (a :: nil) (* Ultimo elemento da lista *)
  | sorted2 : forall (a1 a2:nat) (l:list nat), a1 <= a2 -> Sorted (a2 :: l) -> Sorted (a1 :: a2 :: l). (* Caso geral *)

Lemma ex3a : forall (x y:nat) (l:list nat), x<=y -> (Sorted (y::l)) -> Sorted (x::l).
Proof.
  intros.
  induction l.
  - constructor.
  - constructor.
    + rewrite H. inversion H0. exact H3.
    + inversion H0. exact H5.

Qed.

Lemma sorted2 : forall (x y:nat) (l:list nat), Sorted(x::y::l) -> x<=y. (* Auxiliar para o caso em que temos 2 valores da lista no Sorted*)
Proof.
  intros.
  inversion H.
  assumption.
Qed.

Lemma sortedAux: forall (x y:nat) (l:list nat), x<=y -> Sorted(x::y::l) -> Sorted(x::l). (* Mais uma auxiliar para o caso em que temos 2 valores da lista*)
Proof.
  intros.
  inversion H0.
  generalize H5.
  generalize H3.
  apply ex3a.
Qed.

Lemma ex3b : forall (x y:nat) (l:list nat), (In y l) /\ (Sorted (x::l)) -> x <= y.
Proof.
  intros.
  induction H.
  induction H.
  - generalize H0. apply sorted2.
  - inversion H0.
    apply IHIn.
    generalize H0.
    apply sortedAux.
    assumption.
Qed.

Lemma ex4a : forall (A:Type) (l:list A), Prefix l l.
Proof.
  intros.
  induction l.
  - constructor.
  - constructor.
    assumption.
Qed.

Lemma concatenate_extra : forall (A:Type) (l1 l2:list A), Prefix l1 l2 -> exists l3:list A, l2 = l1 ++ l3.
Proof.
  intros.
  induction H.
  - exists l.
    rewrite app_nil_l.
    trivial.
  - destruct IHPrefix.
    exists x0.
    rewrite H0.
    apply app_comm_cons.
Qed.

Lemma concatenate_prefix : forall (A:Type) (l1 l2:list A), Prefix l1 (l1++l2).
Proof.
  intros.
  induction l1.
  - simpl. constructor.
  - simpl. constructor. exact IHl1.
Qed.

Lemma ex4_b : forall (A:Type) (l1 l2 l3:list A), Prefix l1 l2 /\ Prefix l2 l3 -> Prefix l1 l3.
Proof.
  intros.
  destruct H as [H1 H2].
  apply concatenate_extra in H1.
  destruct H1.
  apply concatenate_extra in H2.
  destruct H2.
  rewrite  H0.
  rewrite  H.
  assert(((l1++x)++x0)=(l1++(x++x0))).
  - apply app_assoc_reverse.
  - rewrite H1.
    apply concatenate_prefix.
Qed.

Lemma concatenate_aux : forall (A:Type) (x:A) (l1 l2:list A), l1 = l2 -> x::l1 = x::l2.
Proof.
  intros.
  rewrite H.
  trivial.
Qed.

Lemma ex4c : forall (A:Type) (l1 l2:list A), Prefix l1 l2 /\ Prefix l2 l1 -> l1 = l2.
Proof.
  intros.
  destruct H.
  induction H.
  - inversion H0. trivial.
  - apply concatenate_aux.
    apply IHPrefix.
    inversion H0.
    exact H2.
Qed.


Module Sqrt.

Require Import Compare_dec.
Require Import Arith.Mult.
Require Import Arith.Plus.
Require Import Omega.

(**
  *   Definition of sqrt.
  *)

(** Note: natural numbers in Coq are represented as lists:
  0 = O;  1 = S O;  2 = S (S O);  5 = S (S (S (S (S O)))).
  Infix operators can have a prefix form:
  a <= b <=> le a b;
  a < b <=> lt a b;
  a > b <=> lt a b;
  this operators return truth. They are not computable.
  A computable analog of 'le' is 'leb'. It returns boolean:
  leb: nat -> nat -> bool.
  It can be used as a condition in an if-statement
*)

(** ** auxilary function - emulating iteration with tail recursion.
   guess monotonically decreasing on each call while its square > n
   function is guaranteed to terminate. (proven automatically due
   to the form of the function (destructive recursion)

  Construction "match n with A x y z => ... | B a b c => ... end"
  performs destruction of its argument n by all possible constructors.

 *)
Fixpoint guess_sqrt (n guess: nat): nat :=
  match n with
      | O => O
      | S x => match guess with
                 | O => O
                 | S prv =>
                   if (leb (guess * guess) n) then guess else guess_sqrt n prv
               end
  end.

(** ** wrapper interface function

  *)
Function sqrt (n: nat) := guess_sqrt n n.

(**
  *   Testing of the defined function.

  *)

Eval compute in (sqrt 10).

(**

  * Correctness proof: $sqrt(n)^2 <= n < (sqrt(n)+1)^2 $

   The main theorem is proven last.

  *)

(** ** A boolean can either be equal to true, or false.
   this lemma helps consider cases in analysis of an if-expression

  *)
Lemma true_or_false: forall a : bool, a=true \/ a=false.
intro.
induction a.
tauto.
tauto.
Qed.

(** *** guess_sqrt is 0 if the first argument is 0

  *)
Lemma guess_0_is_0: forall m: nat, guess_sqrt 0 m = 0.
Proof.
induction m.
simpl.
auto.
unfold guess_sqrt.
auto.
Qed.

Lemma guess_le: forall n g:nat, (guess_sqrt n g)*(guess_sqrt n g) <= n.
Proof.
intros.
destruct n.
- rewrite guess_0_is_0.
  auto.
- induction g.
  + unfold guess_sqrt.
    omega.
  + unfold guess_sqrt.
    fold guess_sqrt.
    pose proof true_or_false.
    specialize H with (leb (S g*S g) (S n)).
    decompose sum H.
    * rewrite H0.
      apply leb_complete in H0.
      assumption.
    * rewrite H0.
      apply leb_complete_conv in H0.
      apply IHg.
Qed.

Lemma guess_gt: forall n g: nat, (n < S g * S g) ->
                                 n < (S (guess_sqrt n g))*(S (guess_sqrt n g)).
Proof.
  intros.
  destruct n.
  - rewrite guess_0_is_0.
    auto.
  - induction g.
    auto.
    unfold guess_sqrt; fold guess_sqrt.
    pose proof true_or_false.
    specialize H0 with (leb (S g*S g) (S n)).
    decompose sum H0.
    + rewrite H1.
      assumption.
    + rewrite H1.
      apply leb_complete_conv in H1.
      apply IHg.
      apply H1.
Qed.

(** *** The holy grail: complete correctness proof, combining together two
   parts, proven before.

  *)
Theorem true_sqrt: forall n :nat, le ((sqrt n)*(sqrt n)) n /\ lt n (S (sqrt n) * S (sqrt n)).
unfold sqrt.
intros.
split.
- apply guess_le.
- apply guess_gt.
  simpl.
  apply le_lt_n_Sm.
  apply le_plus_l.
Qed.

(** *** So far, it is formally proven (modulo Coq core), that:
1) sqrt n terminates for any natural n and 2) x = sqrt n satisfies specification : $(sqrt\ n)^{2} <= n < (1+sqrt\ n)^{2}$
  *)
End Sqrt.


(**
Objectif de ce suppport de TD :
initiation aux relations ou prédicats définis inductivement,
pour préparer la définition des sémantiques relationnelles.
*)

(* Les exercices sont faciles, progressifs, et sont prévus
   pour une durée d'environ 1/2h).
*)

(* ------------------------------------------------------------ *)
(** * Relations ou prédicats définis inductivement *)

(** ** Prédicats à 1 argument sur un type énuméré  *)

(** Commençons par un prédicat très simple qui indique comment
    sélectionner quelques valeurs dans un type énuméré. *)

Inductive coul : Set :=
| violet : coul
| indigo : coul
| bleu : coul
| vert : coul
| jaune : coul
| orange : coul
| rouge : coul
.

(** Rappel : on ne peut PAS définir un autre type qui partage des
    constructeurs avec un type déjà défini. *)
Fail Inductive coulfeu : Set :=
| vert : coulfeu
| orange : coulfeu
| rouge : coulfeu
.

Definition ATTENTION_QUESTION_EN_COMMENTAIRE_1 : bool.
Proof.

(**
Pourquoi interdire à un constructeur d'être dans des types inductifs différents ?
 *)
(* Répondre ici
Pour ne pas créer d'ambiguïté en utilisant le constructeur concerné
 *)
Admitted.

(** Mais on peut définir un prédicat sur coul qui est démontrable
    pour vert orange et rouge (et seulement pour ces derniers). *)

Inductive estCoulfeu : coul -> Prop :=
| Fver : estCoulfeu vert
| Fora : estCoulfeu orange
| Frou : estCoulfeu rouge
.

(** Par exemple on peut démontrer que vert satisfait ce prédicat. *)
Example exemple_feu_vert : estCoulfeu vert.
Proof.
  apply Fver.
Qed.

(** Certains feux de circulation ne présentent que les deux couleurs
    vert et rouge. *)

Inductive feu2couls : coul -> Prop :=
| F2ver : feu2couls vert
| F2rou : feu2couls rouge
.

(** On veut démontrer que le second prédicat implique le premier. *)

Lemma feu2couls_estCoulfeu : forall c, feu2couls c -> estCoulfeu c.
Proof.
  intro c.
  (** On essaie d'abord un raisonnement par cas sur [c].*)
  destruct c.
  (** Beaucoup de cas inutiles (et qui requièrent une technique spéciale).
      Donc on essaye une meilleure stratégie. *)
  Undo 1.
  (** Introduction de l'hypothèse sur [c]. *)
  intro f2c.
  (** Il suffit de raisonner par cas sur les deux façons
      dont [f2c] peut être construite *)
  refine (match f2c with F2ver => _ | F2rou => _ end).
  clear.
  (** Même chose en utilisant la tactique destruct sur l'HYPOTHÈSE [f2c] *)
  Undo 2.
  destruct f2c as [ (*F2ver*) | (*F2rou*) ].
  - apply Fver.
  - refine Frou.
Qed.

(** Exercice *)

(** Sur le modèle du prédicat estCoulfeu, définir un autre prédicat nommé boivr,
    qui sélectionne les couleurs bleu, orange, indigo, vert et rouge. *)

(* Inductive boivr à compléter *)

Inductive boivr : coul -> Prop :=
|Fble : boivr bleu
|Foran : boivr orange
|Findi : boivr indigo
|Fvert : boivr vert
|Froug : boivr rouge
.

(** Démontrer ensuite : *)

Lemma estCoulfeu_boivr : forall c, estCoulfeu c -> boivr c.
Proof.
  (** compléter *)
  intro c.
  intro ecf.
  destruct ecf as [(*Fver*) | (*Fora*) | (*Frou*)].
  -apply Fvert.
  -apply Foran.
  -refine Froug.
Qed.

(** ** Relations à 2 arguments sur un type énuméré *)

(** Les relations inductives permettent de représenter des fonction partielles
    i.e., qui ne sont pas définies partout. Voici un exemple où coulsuiv
    est définie pour vert, orange et rouge, mais pas pour les autres couleurs
    prévues dans coul. *)

Inductive coulsuiv : coul -> coul -> Prop :=
| CSv : coulsuiv vert orange
| CSo : coulsuiv orange rouge
| CSr : coulsuiv rouge vert
.

(** Exercice (même technique qu'auparavant) *)

Lemma coulsuiv_estCoulfeu : forall c1 c2, coulsuiv c1 c2 -> estCoulfeu c1.
Proof.
  (** compléter *)
  intros a b c.
  destruct c as [(*Fver*) | (*Fora*) | (*Frou*)].
  - apply Fver.
  - apply Fora.
  - apply Frou.
Qed.

(** ** Prédicat even sur nat *)

(** De même que les types inductifs de données peuvent être récursifs,
    par exemple nat ou aexp, les prédicats inductifs peuvent être
    récursifs. C'est le cas de even, présenté au CM4. *)

Inductive even : nat -> Prop :=
| E0 : even 0
| E2 : forall n, even n -> even (S (S n))
.

(** Exercice : démontrer que 6 est pair. *)

Example ev10 : even 10.
Proof.
  refine (E2 8 _).
  apply (E2 6).
  apply E2.
  (** compléter *)
  apply E2.
  apply E2.
  apply E0.
Qed.

Print ev10.

Definition ATTENTION_QUESTION_EN_COMMENTAIRE_2 : bool.
(** Exercice :
    - quel est le type et la signification de E2 4 ?
    - quel est le type et la signification de E2 5 ?
*)
(* Répondre ici
E2 4: Prop. C'est une soustraction de 2 depuis 6
E2 5: Prop. C'est une soustraction de 2 depuis 7
 *)
Admitted.

(** Entiers atteignables en ajoutant des 2 ou des 7 en partant de 0. *)
Inductive p2p7 : nat -> Prop :=
| PP0 : p2p7 0
| PP2 : forall n, p2p7 n -> p2p7 (2 + n)
| PP7 : forall n, p2p7 n -> p2p7 (7 + n)
.

(** Exercice : démontrer de 3 façons que 11 est atteignable par p2p7. *)
Example p2p7_11_methode1 : p2p7 11.
Proof.
  (** Compléter ici *)
  refine (PP7 4 _).
  apply PP2.
  apply PP2.
  apply PP0.
Qed.

Example p2p7_11_methode2 : p2p7 11.
Proof.
  (** Compléter ici *)
  refine (PP2 9 _).
  apply PP7.
  apply PP2.
  apply PP0.
Qed.

Example p2p7_11_methode23 : p2p7 11.
Proof.
  (** Compléter ici *)
  refine (PP2 9 _).
  apply PP2.
  apply PP7.
  apply PP0.
Qed.

Print p2p7_11_methode2.

(** Démontrer que tout entier pair satisfait p2p7. *)

Theorem even_p2p7 : forall n, even n -> p2p7 n.
Proof.
  intros n en.
  (** Comme il y a une infinité d'entiers pairs, une preuve par cas
      ne suffit pas. On procède par récurrence structurelle sur les
      façons de démontrer [even n], autrement les formes possibles
      d'arbres de preuve pour [en].
      On a deux cas, celui où [en] est [E0], et celui où [en]
      est de la forme [E2 n' en'], avec [en' : even n'] ;
      dans ce dernier cas, on a droit à une hypothèse de récurrence
      sur en', assurant que [n'] satisfait p2p7.
  *)
  induction en as [ (*E0*) | (*E2*) n' evn' Hrec_evn'].
  - apply PP0.
  - (** Facultatif : mise sous une forme clairement adaptée à p2p7 *)
    change (p2p7 (2 + n')).
    (** Utilisation du constructeur approprié de p2p7 *)
    apply PP2.
    (** Utilisation de l'hypothèse de récurrence *)
    apply Hrec_evn'.
Qed.

(** Il est instructif de démontrer le même théorème par une
    fonction récursive. *)

Fixpoint fct_even_p2p7 n (en : even n) : p2p7 n :=
  match en with
  | E0 => PP0
  | E2 n' evn' => PP2 n' (fct_even_p2p7 n' evn')
  end.

(** On peut transformer un arbre de preuve de [even 4]
    en un arbre de preuve de [p2p7 4] *)
Compute fct_even_p2p7 4 (E2 2 (E2 0 E0)).

(** La somme de deux entiers pairs est paire *)
Lemma even_plus : forall n m, even n -> even m -> even (n + m).
Proof.
  intros n m evn evm.
  (** Compléter par récurrence structurelle sur evn *)
  induction evn as [ (*E0*) | (*E2*) n' evn' Hrec_evn'].
  -refine (evm).
  - change(even (S (S (n'+m)))).  apply E2.
    apply Hrec_evn'.

Qed.

(** Exercice facultatif :
    en donner une preuve sous forme de fonction. *)

Fixpoint fct_even_plus n m (evn : even n) (evm : even m) : even (n + m).
  (** A compléter *)
Admitted.

(* Les multiples de 4 sont pairs *)
Inductive mul4 : nat -> Prop :=
| M4_0 : mul4 0
| M4_4 : forall n, mul4 n -> mul4 (S (S (S (S n))))
.

Lemma mul4_even : forall n, mul4 n -> even n.
Proof.
  intros n m4n.
  (** Terminer par récurrence structurelle sur [m4n] *)
  induction m4n as [(*M4_0*) | (*M4_4*)].
  - apply (E0).
  - apply E2.
    apply E2.
    apply IHm4n.
Qed.


Theorem identity : forall A B : Prop, A -> B -> A.
Proof.
    intros.
    exact H.
Qed.

Theorem forward_small : forall A B : Prop, A -> (A -> B) -> B.
Proof.
    intros A B.
    intros poA atob.
    pose (poB := atob poA).
    exact poB.
Qed.

Theorem backward_small : forall A B : Prop, A -> (A -> B) -> B.
Proof.
    intros A B.
    intros poA atob.
    refine (atob _).
    exact poA.
Qed.

Theorem backward_huge : (forall A B C : Prop, A -> (A->B) -> (A->B->C) -> C).
Proof.
    intros A B C.
    intros a ab abc.
    refine (abc _ _).
    exact a.
    refine (ab _).
    exact a.
Qed.

Inductive Or (A B : Prop) : Prop :=
    | inlS : A -> Or A B
    | inrS : B -> Or A B.

Inductive And (A B : Prop) : Prop :=
    | conjS : A -> B -> And A B.

Notation "A || B" := (Or A B) : my_scope.
Notation "A && B" := (And A B) : my_scope.

Open Scope my_scope.

Theorem or_commutes : forall A B, A || B -> B || A.
Proof.
    intros A B.
    intros A_or_B.
    case A_or_B.
    intros proof_of_A.
    refine (inrS _ _ _).
    exact proof_of_A.
    intros proof_of_B.
    refine (inlS _ _ _).
    exact proof_of_B.
Qed.

Theorem and_commutes : forall A B, A && B -> B && A.
Proof.
    intros A B.
    intros A_and_B.
    case A_and_B.
    intros proof_of_A proof_of_B.
    refine (conjS _ _ _ _).
    exact proof_of_B.
    exact proof_of_A.
Qed.


From Hammer Require Import Hammer.

Require Import Rbase.
Require Import Rfunctions.
Require Import PartSum.
Local Open Scope R_scope.

Definition C (n p:nat) : R :=
INR (fact n) / (INR (fact p) * INR (fact (n - p))).

Lemma pascal_step1 : forall n i:nat, (i <= n)%nat -> C n i = C n (n - i).
Proof. hammer_hook "Binomial" "Binomial.pascal_step1".
intros; unfold C; replace (n - (n - i))%nat with i.
rewrite Rmult_comm.
reflexivity.
apply plus_minus; rewrite plus_comm; apply le_plus_minus; assumption.
Qed.

Lemma pascal_step2 :
forall n i:nat,
(i <= n)%nat -> C (S n) i = INR (S n) / INR (S n - i) * C n i.
Proof. hammer_hook "Binomial" "Binomial.pascal_step2".
intros; unfold C; replace (S n - i)%nat with (S (n - i)).
cut (forall n:nat, fact (S n) = (S n * fact n)%nat).
intro; repeat rewrite H0.
unfold Rdiv; repeat rewrite mult_INR; repeat rewrite Rinv_mult_distr.
ring.
apply INR_fact_neq_0.
apply INR_fact_neq_0.
apply not_O_INR; discriminate.
apply INR_fact_neq_0.
apply INR_fact_neq_0.
apply prod_neq_R0.
apply not_O_INR; discriminate.
apply INR_fact_neq_0.
intro; reflexivity.
apply minus_Sn_m; assumption.
Qed.

Lemma pascal_step3 :
forall n i:nat, (i < n)%nat -> C n (S i) = INR (n - i) / INR (S i) * C n i.
Proof. hammer_hook "Binomial" "Binomial.pascal_step3".
intros; unfold C.
cut (forall n:nat, fact (S n) = (S n * fact n)%nat).
intro.
cut ((n - i)%nat = S (n - S i)).
intro.
pattern (n - i)%nat at 2; rewrite H1.
repeat rewrite H0; unfold Rdiv; repeat rewrite mult_INR;
repeat rewrite Rinv_mult_distr.
rewrite <- H1; rewrite (Rmult_comm (/ INR (n - i)));
repeat rewrite Rmult_assoc; rewrite (Rmult_comm (INR (n - i)));
repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym.
ring.
apply not_O_INR; apply minus_neq_O; assumption.
apply not_O_INR; discriminate.
apply INR_fact_neq_0.
apply INR_fact_neq_0.
apply prod_neq_R0; [ apply not_O_INR; discriminate | apply INR_fact_neq_0 ].
apply not_O_INR; discriminate.
apply INR_fact_neq_0.
apply prod_neq_R0; [ apply not_O_INR; discriminate | apply INR_fact_neq_0 ].
apply INR_fact_neq_0.
rewrite minus_Sn_m.
simpl; reflexivity.
apply lt_le_S; assumption.
intro; reflexivity.
Qed.

Lemma pascal :
forall n i:nat, (i < n)%nat -> C n i + C n (S i) = C (S n) (S i).
Proof. hammer_hook "Binomial" "Binomial.pascal".
intros.
rewrite pascal_step3; [ idtac | assumption ].
replace (C n i + INR (n - i) / INR (S i) * C n i) with
(C n i * (1 + INR (n - i) / INR (S i))); [ idtac | ring ].
replace (1 + INR (n - i) / INR (S i)) with (INR (S n) / INR (S i)).
rewrite pascal_step1.
rewrite Rmult_comm; replace (S i) with (S n - (n - i))%nat.
rewrite <- pascal_step2.
apply pascal_step1.
apply le_trans with n.
apply le_minusni_n.
apply lt_le_weak; assumption.
apply le_n_Sn.
apply le_minusni_n.
apply lt_le_weak; assumption.
rewrite <- minus_Sn_m.
cut ((n - (n - i))%nat = i).
intro; rewrite H0; reflexivity.
symmetry ; apply plus_minus.
rewrite plus_comm; rewrite le_plus_minus_r.
reflexivity.
apply lt_le_weak; assumption.
apply le_minusni_n; apply lt_le_weak; assumption.
apply lt_le_weak; assumption.
unfold Rdiv.
repeat rewrite S_INR.
rewrite minus_INR.
cut (INR i + 1 <> 0).
intro.
apply Rmult_eq_reg_l with (INR i + 1); [ idtac | assumption ].
rewrite Rmult_plus_distr_l.
rewrite Rmult_1_r.
do 2 rewrite (Rmult_comm (INR i + 1)).
repeat rewrite Rmult_assoc.
rewrite <- Rinv_l_sym; [ idtac | assumption ].
ring.
rewrite <- S_INR.
apply not_O_INR; discriminate.
apply lt_le_weak; assumption.
Qed.

Lemma binomial :
forall (x y:R) (n:nat),
(x + y) ^ n = sum_f_R0 (fun i:nat => C n i * x ^ i * y ^ (n - i)) n.
Proof. hammer_hook "Binomial" "Binomial.binomial".
intros; induction  n as [| n Hrecn].
unfold C; simpl; unfold Rdiv;
repeat rewrite Rmult_1_r; rewrite Rinv_1; ring.
pattern (S n) at 1; replace (S n) with (n + 1)%nat; [ idtac | ring ].
rewrite pow_add; rewrite Hrecn.
replace ((x + y) ^ 1) with (x + y); [ idtac | simpl; ring ].
rewrite tech5.
cut (forall p:nat, C p p = 1).
cut (forall p:nat, C p 0 = 1).
intros; rewrite H0; rewrite <- minus_n_n; rewrite Rmult_1_l.
replace (y ^ 0) with 1; [ rewrite Rmult_1_r | simpl; reflexivity ].
induction  n as [| n Hrecn0].
simpl; do 2 rewrite H; ring.

set (N := S n).
rewrite Rmult_plus_distr_l.
replace (sum_f_R0 (fun i:nat => C N i * x ^ i * y ^ (N - i)) N * x) with
(sum_f_R0 (fun i:nat => C N i * x ^ S i * y ^ (N - i)) N).
replace (sum_f_R0 (fun i:nat => C N i * x ^ i * y ^ (N - i)) N * y) with
(sum_f_R0 (fun i:nat => C N i * x ^ i * y ^ (S N - i)) N).
rewrite (decomp_sum (fun i:nat => C (S N) i * x ^ i * y ^ (S N - i)) N).
rewrite H; replace (x ^ 0) with 1; [ idtac | reflexivity ].
do 2 rewrite Rmult_1_l.
replace (S N - 0)%nat with (S N); [ idtac | reflexivity ].
set (An := fun i:nat => C N i * x ^ S i * y ^ (N - i)).
set (Bn := fun i:nat => C N (S i) * x ^ S i * y ^ (N - i)).
replace (pred N) with n.
replace (sum_f_R0 (fun i:nat => C (S N) (S i) * x ^ S i * y ^ (S N - S i)) n)
with (sum_f_R0 (fun i:nat => An i + Bn i) n).
rewrite plus_sum.
replace (x ^ S N) with (An (S n)).
rewrite (Rplus_comm (sum_f_R0 An n)).
repeat rewrite Rplus_assoc.
rewrite <- tech5.
fold N.
set (Cn := fun i:nat => C N i * x ^ i * y ^ (S N - i)).
cut (forall i:nat, (i < N)%nat -> Cn (S i) = Bn i).
intro; replace (sum_f_R0 Bn n) with (sum_f_R0 (fun i:nat => Cn (S i)) n).
replace (y ^ S N) with (Cn 0%nat).
rewrite <- Rplus_assoc; rewrite (decomp_sum Cn N).
replace (pred N) with n.
ring.
unfold N; simpl; reflexivity.
unfold N; apply lt_O_Sn.
unfold Cn; rewrite H; simpl; ring.
apply sum_eq.
intros; apply H1.
unfold N; apply le_lt_trans with n; [ assumption | apply lt_n_Sn ].
reflexivity.
unfold An; fold N; rewrite <- minus_n_n; rewrite H0;
simpl; ring.
apply sum_eq.
intros; unfold An, Bn.
change (S N - S i)%nat with (N - i)%nat.
rewrite <- pascal;
[ ring
| apply le_lt_trans with n; [ assumption | unfold N; apply lt_n_Sn ] ].
unfold N; reflexivity.
unfold N; apply lt_O_Sn.
rewrite <- (Rmult_comm y); rewrite scal_sum; apply sum_eq.
intros; replace (S N - i)%nat with (S (N - i)).
replace (S (N - i)) with (N - i + 1)%nat; [ idtac | ring ].
rewrite pow_add; replace (y ^ 1) with y; [ idtac | simpl; ring ];
ring.
apply minus_Sn_m; assumption.
rewrite <- (Rmult_comm x); rewrite scal_sum; apply sum_eq.
intros; replace (S i) with (i + 1)%nat; [ idtac | ring ]; rewrite pow_add;
replace (x ^ 1) with x; [ idtac | simpl; ring ];
ring.
intro; unfold C.
replace (INR (fact 0)) with 1; [ idtac | reflexivity ].
replace (p - 0)%nat with p; [ idtac | apply minus_n_O ].
rewrite Rmult_1_l; unfold Rdiv; rewrite <- Rinv_r_sym;
[ reflexivity | apply INR_fact_neq_0 ].
intro; unfold C.
replace (p - p)%nat with 0%nat; [ idtac | apply minus_n_n ].
replace (INR (fact 0)) with 1; [ idtac | reflexivity ].
rewrite Rmult_1_r; unfold Rdiv; rewrite <- Rinv_r_sym;
[ reflexivity | apply INR_fact_neq_0 ].
Qed.


Require Import ZArith.
Require Import Arith.

Open Scope Z_scope.

Fixpoint sum_f (f:nat -> Z) (n:nat)  : Z :=
  match n with
  | O => f O
  | S p => sum_f f p + f n
  end.

Theorem sum_n : forall n:nat, 2 * sum_f Z_of_nat n =
                              Z_of_nat n * (Z_of_nat n + 1).
Proof.
 induction n as [| p IHp].
 -  reflexivity.
 -  lazy beta iota zeta delta [sum_f]; fold sum_f.
     rewrite Zmult_plus_distr_r; rewrite IHp.
     rewrite inj_S ; unfold Zsucc ; ring.
Qed.


Require Import Nat Arith.

Inductive Nat : Type := succ : Nat -> Nat |  zero : Nat.

Inductive Lst : Type := nil : Lst | cons : Nat -> Lst -> Lst.

Inductive Tree : Type := node : Nat -> Tree -> Tree -> Tree |  leaf : Tree.

Inductive Pair : Type := mkpair : Nat -> Nat -> Pair
with ZLst : Type := zcons : Pair -> ZLst -> ZLst |  znil : ZLst.

Fixpoint append (append_arg0 : Lst) (append_arg1 : Lst) : Lst
           := match append_arg0, append_arg1 with
              | nil, x => x
              | cons x y, z => cons x (append y z)
              end.

Fixpoint rev (rev_arg0 : Lst) : Lst
           := match rev_arg0 with
              | nil => nil
              | cons x y => append (rev y) (cons x nil)
              end.

Fixpoint qreva (qreva_arg0 : Lst) (qreva_arg1 : Lst) : Lst
           := match qreva_arg0, qreva_arg1 with
              | nil, x => x
              | cons z x, y => qreva x (cons z y)
              end.

Lemma append_nil : forall (x : Lst), append x nil = x.
Proof.
  intros.
  induction x.
  - reflexivity.
  - simpl. rewrite IHx. reflexivity.
Qed.

Lemma append_assoc : forall (x y z : Lst), append (append x y) z = append x (append y z).
Proof.
  intros.
  induction x.
  - reflexivity.
  - simpl. rewrite IHx. reflexivity.
Qed.

Theorem theorem0 : forall (x : Lst) (y : Lst), eq (rev (qreva x y)) (append (rev y) x).
Proof.
  induction x.
  - intros. simpl. rewrite append_nil. reflexivity.
  - intros. simpl. rewrite IHx. simpl. rewrite append_assoc. simpl. reflexivity.
Qed.


From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

(** Some basic functions *)

Definition const {A B} (a : A) :=
  fun _ : B => a.

Definition flip {A B C} (f : A -> B -> C) : B -> A -> C :=
  fun b a => f a b.

Arguments const {A B} a _ /.
Arguments flip {A B C} f b a /.

(* move to logic_exercises *)
Section IntLogic.

Variables A B C D : Prop.

Lemma axiomK :
  A -> B -> A.
Proof. exact: const. Qed.

(* note: flip is more general *)
Lemma contraposition :
  (A -> ~ B) -> (B -> ~ A).
Proof. exact: flip. Qed.

Lemma p_imp_np_iff_np : (A -> ~A)  <->  ~A.
Proof.
(* a step-by-step solution *)
split.
- rewrite /not. move=> a_na. move=> a. exact: (a_na a a).
move=> na _. exact: na.

Restart.
(* a more idiomatic solution *)
by split=> // a_na a; apply: a_na.
(**
Explanation: the proof of the last branch of the step-by-step proof
is trivial, so it can be handled with [//].
This leaves us with just the first subgoal.
[move=> a_na. move=> a.] can be merged into [move=> a_na a.]
which itself can be melded into the preceeding [split] tactic.

The [tac1; tac2] construction allows us to apply [tac2] tactic
to all the subgoals we are left with after applying [tac1] tactic.
 *)
Qed.

(* We can generalize the previous lemma into *)
Lemma p_p_q_iff_p_q :
  (A -> A -> B)  <->  (A -> B).
Proof. by split=> // a_na a; apply: a_na. Qed.

Lemma p_is_not_equal_not_p :
  ~ (A <-> ~ A).
Proof.
(** The "defective" form of [move] tactic brings the goal to
    the head normal form (hnf).
    Defective here means "not combined with anything else".
 *)
move.
(** Amounts to "unfold all definitions" in this case.
    The goal after applying [compute] tactic can be
    easier to understand, but this really depends on
    how much experience you have with unfolding those
    definitions mentally.
 *)
compute.
(** Now that we have conjunction as the top of the goal stack,
    we can have access to the individual conjuncts.
 *)
case. move=> aaf af_a.
(** Parentheses around a hypothesis let us reuse it later,
    had we omitted those, we would have it erased from the context.
 *)
apply: (aaf).
- apply: af_a. move=> a. exact: (aaf a a).
apply: af_a. move=> a. exact: (aaf a a).   (* duplication! *)

Restart.

(** A refactored version of the above proof *)
case=> aaf af_a.
(** We use [have ident : statement by tactic] form to prove [A] beforehand
    and call it [a] in the context.
  *)
have a: A by apply: af_a=> a; apply: aaf.
by apply: aaf.
Qed.

Lemma not_not_lem :
  ~ ~ (A \/ ~ A).
Proof.
move=> not_lem.
apply: (not_lem).
right.
move=> a.
apply: not_lem.
left.
exact: a.

Restart.

(** a shorter version *)
move=> not_lem; apply: (not_lem); right=> a.
by apply: not_lem; left.
Qed.

Lemma constructiveDNE :
  ~ ~ ~ A  ->  ~ A.
Proof.
move=> nnna.
move=> a.
apply: nnna.
move=> na.
apply: na.
exact: a.

Restart.

(** A shorter version *)
by move=> nnna a; apply: nnna.
Qed.

End IntLogic.

(* Boolean logic (decidable fragment enjoys classical laws) *)

Section BooleanLogic.

Lemma LEM_decidable a :
  a || ~~ a.
Proof.
by case: a.
(** the rest of the proof is by computation *)
Qed.

Lemma disj_implb a b :
  a || (a ==> b).
Proof.
by case: a.
(** Here we only need to case analyse on [a].
    Make sure you understand why.
    (Hint: look at the definitions and see if knowing the form
           of [b] is really needed here)
 *)
Qed.

Lemma iff_is_if_and_only_if a b :
  (a ==> b) && (b ==> a) = (a == b).
Proof. by case: a; case: b. Qed.

Lemma implb_trans : transitive implb.
Proof.
rewrite /transitive. move=> b a c. case: a.
- move=> /=. (* simplify goal *)
  (* The head of the goal is an (implicit) equation [b = true].
     How to check it? *)
  move->.  (* rewrite with the head of the goal stack *)
  move=> /=.
  by [].
by [].

Restart.

(** A more idiomatic version *)
by move=> b [] c //= ->.

(** Explanation:

[by move=> b [] c //= ->]
             ^    ^
             |    |
             |    solve trivial goals (//) and simplify (/=) combined
             |
             inplace case analysis ([case: a])
*)
Qed.

Lemma triple_compb (f : bool -> bool) :
  f \o f \o f =1 f.
Proof.
by case=> /=; case Et: (f true); case Ef: (f false); rewrite ?Ef ?Et.
Qed.

(* negb \o odd means "even" *)
Lemma even_add :
  {morph (negb \o odd) : x y / x + y >-> x == y}.
Proof.
move=> x y /=.
by rewrite odd_add negb_add eqb_negLR negbK.
Qed.

End BooleanLogic.

(* some properties of functional composition *)

Section eq_comp.
Variables A B C D : Type.

Lemma compA (f : A -> B) (g : B -> C) (h : C -> D) :
  h \o g \o f = h \o (g \o f).
Proof. by []. Qed.

Lemma eq_compl (f g : A -> B) (h : B -> C) :
  f =1 g -> h \o f =1 h \o g.
Proof. by move=> eq_fg; apply: eq_comp. Qed.

Lemma eq_compr (f g : B -> C) (h : A -> B) :
  f =1 g -> f \o h =1 g \o h.
Proof. by move=> eq_fg; apply: eq_comp. Qed.

Lemma eq_idl (g1 g2 : A -> B) (f : B -> B) :
  f =1 id -> f \o g1 =1 f \o g2 -> g1 =1 g2.
Proof.
move=> f_id g12f a.
move: (g12f a). move=> /=.
rewrite f_id. rewrite f_id.
done.

Restart.

(* idiomatic solution *)
by move=> f_id g12f a; move: (g12f a)=> /=; rewrite !f_id.
Qed.

Lemma eq_idr (f1 f2 : A -> B) (g : A -> A) :
  g =1 id -> f1 \o g =1 f2 \o g -> f1 =1 f2.
Proof.
by move=> g_id f12g a; move: (f12g a)=> /=; rewrite g_id.
Qed.

End eq_comp.


Require Import Bool Arith List Cpdt.CpdtTactics.
Set Implicit Arguments.
Set Asymmetric Patterns.

Inductive binop : Set := Plus | Times.

Inductive exp : Set :=
| Const : nat -> exp
| Binop : binop -> exp -> exp -> exp.

Definition binopDenote (b : binop) : nat -> nat -> nat :=
  match b with
  | Plus => plus
  | Times => mult
  end.

Fixpoint expDenote (e : exp) : nat :=
  match e with
  | Const n => n
  | Binop b e1 e2 => binopDenote b (expDenote e1) (expDenote e2)
  end.

Eval simpl in expDenote (Const 42).

Eval simpl in expDenote (Binop Plus (Const 2) (Const 2)).

Eval simpl in expDenote (Binop Times (Binop Plus (Const 2) (Const 2)) (Const 7)).

Inductive instr : Set :=
| iConst : nat -> instr
| iBinop : binop -> instr.

Definition prog := list instr.
Definition stack := list nat.

Definition instrDenote (i : instr) (s : stack) : option stack :=
  match i with
  | iConst n => Some (n :: s)
  | iBinop b =>
    match s with
    | arg1 :: arg2 :: s' => Some (binopDenote b arg1 arg2 :: s')
    | _ => None
    end
  end.

Fixpoint progDenote (p : prog) (s : stack) : option stack :=
  match p with
  | nil => Some s
  | i :: p' =>
    match instrDenote i s with
    | None => None
    | Some s' => progDenote p' s'
    end
  end.

Fixpoint compile (e : exp) : prog :=
  match e with
  | Const n => iConst n :: nil
  | Binop b e1 e2 => compile e2 ++ compile e1 ++ iBinop b :: nil
  end.

Eval simpl in compile (Const 42).

Eval simpl in compile (Binop Plus (Const 2) (Const 2)).

Eval simpl in compile (Binop Times (Binop Plus (Const 2) (Const 2)) (Const 7)).

Eval simpl in progDenote (compile (Const 42)) nil.

Eval simpl in progDenote (compile (Binop Plus (Const 2) (Const 2))) nil.

Eval simpl in progDenote (compile (Binop Times (Binop Plus (Const 2) (Const 2)) (Const 7))) nil.

Theorem compile_correct : forall e, progDenote (compile e) nil = Some (expDenote e :: nil).

Abort.

Lemma compile_correct' : forall e p s,
    progDenote (compile e ++ p) s = progDenote p (expDenote e :: s).
  induction e.
  intros.
  unfold compile.
  unfold expDenote.
  unfold progDenote at 1.
  simpl.
  fold progDenote.
  reflexivity.
  intros.
  unfold compile.
  fold compile.
  unfold expDenote.
  fold expDenote.
  rewrite app_assoc_reverse.
  rewrite IHe2.
  rewrite app_assoc_reverse.
  rewrite IHe1.
  unfold progDenote at 1.
  simpl.
  fold progDenote.
  reflexivity.
Abort.

Lemma compile_correct' : forall e p s,
    progDenote (compile e ++ p) s = progDenote p (expDenote e :: s).
  induction e; crush.
Qed.

Theorem compile_correct : forall e,
    progDenote (compile e) nil = Some (expDenote e :: nil).
  intros.
  rewrite (app_nil_end (compile e)).
  rewrite compile_correct'.
  reflexivity.
Qed.

Inductive type : Set := Nat | Bool.

Inductive tbinop : type -> type -> type -> Set :=
| TPlus : tbinop Nat Nat Nat
| TTimes : tbinop Nat Nat Nat
| TEq : forall t, tbinop t t Bool
| TLt : tbinop Nat Nat Bool.

Inductive texp : type -> Set :=
| TNConst : nat -> texp Nat
| TBConst : bool -> texp Bool
| TBinop : forall t1 t2 t, tbinop t1 t2 t -> texp t1 -> texp t2 -> texp t.

Definition typeDenote (t : type) : Set :=
  match t with
  | Nat => nat
  | Bool => bool
  end.

Definition tbinopDenote arg1 arg2 res (b : tbinop arg1 arg2 res)
  : typeDenote arg1 -> typeDenote arg2 -> typeDenote res :=
  match b with
  | TPlus => plus
  | TTimes => mult
  | TEq Nat => beq_nat
  | TEq Bool => eqb
  | TLt => leb
  end.

Fixpoint texpDenote t (e : texp t) : typeDenote t :=
  match e with
  | TNConst n => n
  | TBConst b => b
  | TBinop _ _ _ b e1 e2 => (tbinopDenote b) (texpDenote e1) (texpDenote e2)
  end.

Eval simpl in texpDenote (TNConst 42).

Eval simpl in texpDenote (TBConst true).

Eval simpl in texpDenote (TBinop TTimes (TBinop TPlus (TNConst 2) (TNConst 2)) (TNConst 7)).

Eval simpl in texpDenote (TBinop (TEq Nat) (TBinop TPlus (TNConst 2) (TNConst 2)) (TNConst 7)).

Eval simpl in texpDenote (TBinop TLt (TBinop TPlus (TNConst 2) (TNConst 2)) (TNConst 7)).

Definition tstack : Set := list type.

Inductive tinstr : tstack -> tstack -> Set :=
| TiNConst : forall s, nat -> tinstr s (Nat :: s)
| TiBConst : forall s, bool -> tinstr s (Bool :: s)
| TiBinop : forall arg1 arg2 res s,
    tbinop arg1 arg2 res
    -> tinstr (arg1 :: arg2 :: s) (res :: s).

Inductive tprog : tstack -> tstack -> Set :=
| TNil : forall s, tprog s s
| TCons : forall s1 s2 s3,
    tinstr s1 s2
    -> tprog s2 s3
    -> tprog s1 s3.

Fixpoint vstack (ts : tstack) : Set :=
  match ts with
  | nil => unit
  | t :: ts' => typeDenote t * vstack ts'
  end%type.

Definition tinstrDenote ts ts' (i : tinstr ts ts') : vstack ts -> vstack ts' :=
  match i with
  | TiNConst _ n => fun s => (n, s)
  | TiBConst _ b => fun s => (b, s)
  | TiBinop _ _ _ _ b =>
    fun s =>
      let '(arg1, (arg2, s')) := s in
      ((tbinopDenote b) arg1 arg2, s')
  end.

Fixpoint tprogDenote ts ts' (p : tprog ts ts') : vstack ts -> vstack ts' :=
  match p with
  | TNil _ => fun s => s
  | TCons _ _ _ i p' => fun s => tprogDenote p' (tinstrDenote i s)
  end.

Fixpoint tconcat ts ts' ts'' (p : tprog ts ts') : tprog ts' ts'' -> tprog ts ts'' :=
  match p with
  | TNil _ => fun p' => p'
  | TCons _ _ _ i p1 => fun p' => TCons i (tconcat p1 p')
  end.

Fixpoint tcompile t (e : texp t) (ts : tstack) : tprog ts (t :: ts) :=
  match e with
  | TNConst n => TCons (TiNConst _ n) (TNil _)
  | TBConst b => TCons (TiBConst _ b) (TNil _)
  | TBinop _ _ _ b e1 e2 =>
    tconcat (tcompile e2 _) (tconcat (tcompile e1 _) (TCons (TiBinop _ b) (TNil _)))
  end.

Print tcompile.

Eval simpl in tprogDenote (tcompile (TNConst 42) nil) tt.

Eval simpl in tprogDenote (tcompile (TBConst true) nil) tt.

Eval simpl in tprogDenote (tcompile (TBinop TTimes (TBinop TPlus (TNConst 2) (TNConst 2)) (TNConst 7)) nil) tt.

Eval simpl in tprogDenote (tcompile (TBinop (TEq Nat) (TBinop TPlus (TNConst 2) (TNConst 2)) (TNConst 7)) nil) tt.

Eval simpl in tprogDenote (tcompile (TBinop TLt (TBinop TPlus (TNConst 2) (TNConst 2)) (TNConst 7)) nil) tt.

Lemma tconcat_correct : forall ts ts' ts'' (p : tprog ts ts') (p' : tprog ts' ts'') (s : vstack ts),
    tprogDenote (tconcat p p') s =
    tprogDenote p' (tprogDenote p s).
  induction p; crush.
Qed.

Hint Rewrite tconcat_correct.

Lemma tcompile_correct' : forall t (e : texp t) ts (s : vstack ts),
    tprogDenote (tcompile e ts) s = (texpDenote e, s).
  induction e; crush.
Qed.

Hint Rewrite tcompile_correct'.

Theorem tcompile_correct : forall t (e : texp t),
    tprogDenote (tcompile e nil) tt = (texpDenote e, tt).
  crush.
Qed.


(*|
############################################################
Coq theorem proving: Simple fraction law in peano arithmetic
############################################################

:Link: https://stackoverflow.com/q/59120093
|*)

(*|
Question
********

I am learning coq and am trying to prove equalities in peano
arithmetic.

I got stuck on a simple fraction law.

We know that ``(n + m) / 2 = n / 2 + m / 2`` from primary school. In
peano arithmetic this does only hold if n and m are even (because then
division produces correct results).
|*)

Require Import Arith Even.

Compute (3 / 2) + (5 / 2). (*3*)
Compute (3 + 5) / 2. (*4*)

(*| So we define: |*)

Theorem fraction_addition: forall n m: nat ,
    even n -> even m ->  Nat.div2 n + Nat.div2 m = Nat.div2 (n + m).

(*|
From my understanding this is a correct and provable theorem. I tried
an inductive proof, e.g.
|*)

  intros n m en em. induction n.
  - reflexivity.
  - (* .unfold *)
Abort. (* .none *)

(*|
So I don't find a way to apply the induction hypothesis.

After long research of the standard library and documentation, i don't
find an answer.
|*)

(*|
Answer (Anton Trunov)
*********************

You need to strengthen your induction hypothesis in cases like this.
One way of doing this is by proving an induction principle like this
one:
|*)

From Coq Require Import Arith Even.
Lemma nat_ind2 (P : nat -> Prop) :
  P 0 -> P 1 -> (forall n, P n -> P (S n) -> P (S (S n))) ->
  forall n, P n.
Proof.
  now intros P0 P1 IH n; enough (H : P n /\ P (S n)); [|induction n]; intuition.
Qed.

(*| ``nat_ind2`` can be used as follows: |*)

Theorem fraction_addition n m :
  even n -> even m -> Nat.div2 n + Nat.div2 m = Nat.div2 (n + m).
Proof.
  induction n using nat_ind2.
  (* here goes the rest of the proof *)
Admitted.

(*|
Answer (larsr)
**************

You can also prove your theorem without induction if you are ok with
using the standard library.

If you use ``Even m`` in your hypothesis (which says ``exists n, m =
2*m``) then you can use simple algebraic rewrites with lemmas from the
standard library.
|*)

Require Import PeanoNat.
Import Nat.

Goal forall n m, Even n -> Even m -> n / 2 + m / 2 = (n + m) / 2.
  inversion 1; inversion 1.
  subst.
  rewrite <- mul_add_distr_l.
  rewrite ?(mul_comm 2).
  rewrite ?(div_mul); auto.
Qed.

(*|
The question mark just means "rewrite as many (zero or more) times as
possible".

``inversion 1`` does inversion on the first inductive hypothesis in
the goal, in this case first ``Even n`` and then ``Even m``. It gives
us ``n = 2 * x`` and ``m = 2 * x0`` in the context, which we then
substitute.

Also note ``even_spec: forall n : nat, even n = true <-> Even n``, so
you can use ``even`` if you prefer that, just rewrite with
``even_spec`` first...
|*)