(* Copyright 2012-2015 by Adam Petcher.				*
 * Use of this source code is governed by the license described	*
 * in the LICENSE file at the root of the source tree.		*)

Set Implicit Arguments.

Require Import FCF.FCF.
Require Import FCF.CompFold.
Require Import FCF.RndListElem.
Require Import Permutation.

Local Open Scope list_scope.

Theorem removeFirst_In_length :
  forall (A : Set)(eqd : EqDec A)(ls : list A)(a : A),
    In a ls ->
    length (removeFirst (EqDec_dec _ ) ls a) = pred (length ls).

  induction ls; intuition; simpl in *.
  intuition; subst.
  destruct (EqDec_dec eqd a0 a0); intuition.

  destruct (EqDec_dec eqd a0 a); subst.
  trivial.
  simpl.
  rewrite IHls.
  destruct ls; simpl in *; intuition.

  trivial.
Qed.

Fixpoint addInAllLocations(A : Type)(a : A)(ls : list A) :=
  match ls with
    | nil =>  (a :: nil) :: nil
    | a' :: ls' =>
      (a :: ls) :: map (fun x => a' :: x) (addInAllLocations a ls')
  end.

Fixpoint getAllPermutations(A : Type)(ls : list A) :=
  match ls with
    | nil => nil :: nil
    | a :: ls' =>
      let perms' := getAllPermutations ls' in
        flatten (map (addInAllLocations a) perms')
  end.

Theorem addInAllLocations_not_nil :
  forall (A : Type) l (a : A),
    addInAllLocations a l = nil -> False.

  induction l; intuition; unfold addInAllLocations in *; simpl in *.
  inversion H.
  inversion H.

Qed.

Theorem getAllPermutations_not_nil :
  forall (A : Type)(ls : list A),
    getAllPermutations ls = nil -> False.

  induction ls; intuition; simpl in *.
  inversion H.

  case_eq (getAllPermutations ls); intuition.
  rewrite H0 in H.
  simpl in *.
  apply app_eq_nil in H.
  intuition.
  eapply addInAllLocations_not_nil; eauto.
Qed.

Theorem addInAllLocations_perm :
  forall (A : Type) x0 (a : A) ls2,
    In ls2 (addInAllLocations a x0) ->
    Permutation ls2 (a :: x0).

  induction x0; intuition; simpl in *.
  intuition; subst.
  eapply Permutation_refl.

  intuition; subst.
  eapply Permutation_refl.

  eapply in_map_iff in H0.
  destruct H0.
  intuition; subst.
  eapply perm_trans.
  2:{
    eapply perm_swap.
  }
  eapply perm_skip.
  eapply IHx0.
  trivial.

Qed.

Theorem getAllPermutations_perms :
  forall (A : Set)(ls1 ls2 : list A),
    In ls2 (getAllPermutations ls1) ->
    Permutation ls1 ls2.

  induction ls1; intuition; simpl in *.
  intuition.
  subst.
  econstructor.

  eapply in_flatten in H.
  destruct H.
  intuition.
  eapply in_map_iff in H0.
  destruct H0.
  intuition.
  subst.
  eapply addInAllLocations_perm in H1.
  eapply perm_trans.
  2:{
    eapply Permutation_sym.
    eauto.
  }
  eapply perm_skip.
  eapply IHls1.
  trivial.

Qed.

Section ShuffleList.

  Variable A : Set.
  Hypothesis A_EqDec : EqDec A.

  Definition shuffle(ls : list A) :=
    o <-$ rndListElem _ (getAllPermutations ls);
    ret
    match o with
      | None => nil
      | Some x => x
    end.

  Theorem shuffle_perm :
    forall (ls1 ls2 : list A),
      In ls2 (getSupport (shuffle ls1)) ->
      Permutation ls2 ls1.

    intuition.
    unfold shuffle in *.
    repeat simp_in_support.
    destruct x.
    eapply Permutation_sym.
    eapply getAllPermutations_perms.
    apply rndListElem_support in H0.
    trivial.

    apply rndListElem_support_None in H0.
    exfalso.
    eapply getAllPermutations_not_nil.
    eauto.

  Qed.

   Fixpoint permute(ls : list A)(sigma : list nat) : list A :=
    match sigma with
      | nil => nil
      | n :: sigma' =>
        match (nth_error ls n) with
          | None => nil
          | Some a => a :: (permute ls sigma')
        end
  end.

   Theorem nth_error_not_None :
     forall (ls : list A)(n : nat),
       n < length ls ->
       nth_error ls n = None ->
       False.

     induction ls; destruct n; intuition; simpl in *.
     lia.
     lia.
     inversion H0.
     eapply IHls; eauto.
     lia.
   Qed.

   Theorem permute_length_eq :
     forall (sigma : list nat)(ls : list A),
       (forall n, In n sigma -> n < length ls) ->
       length (permute ls sigma) = length sigma.

     induction sigma; intuition; simpl in *.
     case_eq (nth_error ls a); intuition.
     simpl.
     f_equal.
     eapply IHsigma; intuition.

     exfalso.
     eapply nth_error_not_None.
     eapply H.
     intuition.
     trivial.
   Qed.

   Theorem shuffle_Permutation :
     forall (ls1 ls2 : list A),
       In ls2 (getSupport (shuffle ls1)) ->
       Permutation ls1 ls2.

     intuition.

     unfold shuffle in *.
     repeat simp_in_support.
     destruct x.
     eapply rndListElem_support in H0.
     eapply getAllPermutations_perms.
     trivial.

     eapply rndListElem_support_None in H0.
     exfalso.
     eapply getAllPermutations_not_nil.
     eauto.

    Qed.

    Theorem shuffle_wf :
      forall ls,
        well_formed_comp (shuffle ls).

      intuition.
      unfold shuffle.
      wftac.
      eapply rndListElem_wf.

    Qed.

End ShuffleList.

Definition RndPerm(n : nat) :=
  shuffle _ (allNatsLt n).

Theorem list_pred_map_both':
  forall (A B C D : Set) (lsa : list A) (lsb : list B)
    (P : C -> D -> Prop) (f : A -> C)(g : B -> D),
  list_pred (fun (a : A) (b : B) => P (f a) (g b)) lsa lsb ->
  list_pred P (map f lsa) (map g lsb).

  intuition.
  eapply list_pred_impl.
  eapply list_pred_map_both.
  eauto.
  intuition.
  destruct H0.
  destruct H0.
  intuition; subst.
  trivial.

Qed.

Theorem addInAllLocations_pred :
  forall (A B : Set) (R : A -> B -> Prop) (a : list A) (b : list B),
    list_pred R a b ->
    forall a1 a2,
      R a1 a2 ->
  list_pred (list_pred R) (addInAllLocations a1 a) (addInAllLocations a2 b).

  induction 1; intuition; simpl in *.

  econstructor.
  econstructor.
  trivial.
  econstructor.
  econstructor.

  econstructor.
  repeat econstructor;assumption.

  eapply list_pred_map_both'.
  eapply list_pred_impl.
  eauto.
  intuition.
  econstructor; assumption.

Qed.

Theorem getAllPermutations_pred :
  forall (A B : Set)(R : A -> B -> Prop)(lsa : list A)(lsb : list B),
  list_pred R lsa lsb ->
     list_pred (list_pred R) (getAllPermutations lsa) (getAllPermutations lsb).

  induction 1; intuition; simpl in *.
  econstructor.
  econstructor.
  econstructor.

  eapply list_pred_flatten_both.
  eapply list_pred_map_both'.
  eapply list_pred_impl.
  eauto.
  intuition.

  eapply addInAllLocations_pred; intuition.
Qed.

Theorem nth_error_app_Some :
  forall (A : Set)(ls : list A) n (a a' : A),
    nth_error ls n = Some a ->
    nth_error (ls ++ (a' :: nil)) n = Some a.

  induction ls; destruct n; intuition; simpl in *.
  inversion H.
  inversion H.

  eapply IHls.
  trivial.

Qed.

Theorem nth_error_app_length :
  forall (A : Set)(ls : list A) (a : A),
    nth_error (ls ++ (a :: nil)) (length ls) = Some a.

  induction ls; intuition; simpl in *.

Qed.

Theorem allNats_nth_pred :
  forall (A : Set)(ls : list A),
   list_pred (fun (a : A) (b : nat) => nth_error ls b = Some a) ls
     (allNatsLt (length ls)).

  induction ls using rev_ind; intuition; simpl in *.
  econstructor.

  rewrite app_length.
  simpl.
  rewrite plus_comm.
  simpl.

  eapply list_pred_app_both.
  eapply list_pred_impl.
  eapply IHls.
  intuition.

  eapply nth_error_app_Some; intuition.

  econstructor.

  eapply  nth_error_app_length .

  econstructor.

Qed.

Theorem permute_nth_equiv :
  forall (A : Set)(ls : list A) a b,
  list_pred (fun (a0 : A) (b0 : nat) => nth_error ls b0 = Some a0) a b ->
  a = permute ls b.

  induction a; inversion 1; intuition; simpl in *.
  subst.

  rewrite H2.
  f_equal.
  eapply IHa.
  trivial.
Qed.

Theorem getAllPerms_permute_eq :
  forall (A : Set)(ls : list A),
  list_pred (fun (a : list A) (b : list nat) => a = permute ls b)
     (getAllPermutations ls) (getAllPermutations (allNatsLt (length ls))).

  intuition.

  generalize (@getAllPermutations_pred _ _ (fun a b => nth_error ls b = Some a) ls (allNatsLt (length ls))) ; intros.
  eapply list_pred_impl.
  eapply H.

  eapply allNats_nth_pred.

  intuition.

  eapply permute_nth_equiv.
  trivial.

Qed.

Theorem list_pred_nth_exists :
  forall (A B : Set)(P : A -> B -> Prop) lsa lsb,
    list_pred P lsa lsb ->
    forall n a,
      nth_option lsa n = Some a -> exists b, nth_option lsb n = Some b /\ P a b.

  induction 1; intuition; simpl in *.
  discriminate.

  destruct n.
  inversion H1; clear H1; subst.
  econstructor; intuition.

  edestruct IHlist_pred; eauto.

Qed.

Theorem rndListElem_pred :
  forall (A B : Set)(eqda : EqDec A)(eqdb : EqDec B)(P : A -> B -> Prop)(lsa : list A)(lsb : list B),
    list_pred P lsa lsb ->
    comp_spec (fun a b =>
      match a with
        | None => b = None
        | Some a' => exists b', b = Some b' /\ P a' b'
      end) (rndListElem _ lsa) (rndListElem _ lsb).

  intuition.
  unfold rndListElem in *.
  case_eq (length lsa); intuition.
  erewrite <- list_pred_length_eq; eauto.
  rewrite H0.
  eapply comp_spec_ret; intuition.

  erewrite <- list_pred_length_eq; eauto.
  rewrite H0.
  comp_skip.
  apply None.
  apply None.
  eapply comp_spec_ret; intuition.

  case_eq (nth_option lsa b); intuition.

  edestruct list_pred_nth_exists; eauto.

  exfalso.
  eapply nth_option_not_None; eauto.
  apply RndNat_support_lt in H1.
  lia.
Qed.

Theorem shuffle_RndPerm_spec :
  forall (A : Set)(eqd : EqDec A)(ls : list A),
    comp_spec (fun a b => a = permute ls b)
    (shuffle eqd ls)
    (shuffle _ (allNatsLt (length ls))).

  intuition.
  unfold shuffle in *.

  comp_skip.
  eapply rndListElem_pred.
  eapply getAllPerms_permute_eq.

  simpl in H1.
  eapply comp_spec_ret; intuition.
  destruct a.
  destruct H1.
  intuition.
  subst.
  trivial.

  subst.
  simpl.
  intuition.
Qed.

Theorem shuffle_RndPerm_spec_eq :
  forall (A : Set)(eqd : EqDec A)(ls : list A),
    comp_spec eq
    (shuffle eqd ls)
    (x <-$ RndPerm (length ls); ret permute ls x).

  intuition.
  eapply comp_spec_eq_trans.
  eapply comp_spec_eq_symm.
  eapply comp_spec_right_ident.
  comp_skip.
  eapply shuffle_RndPerm_spec.
  eapply comp_spec_ret; intuition.

Qed.

Theorem RndPerm_In_support :
  forall n ls,
    In ls (getSupport (RndPerm n)) ->
    Permutation (allNatsLt n) ls.

  intuition.
  eapply shuffle_Permutation.
  eapply H.
Qed.

Theorem RndPerm_In_support_length :
  forall n ls,
    In ls (getSupport (RndPerm n)) ->
    length ls = n.

  intuition.
  erewrite Permutation_length.
  2:{
    eapply Permutation_sym.
    eapply RndPerm_In_support.
    eauto.
  }
  eapply allNatsLt_length.
Qed.

Theorem RndPerm_wf :
  forall n,
    well_formed_comp (RndPerm n).

  intuition.
  unfold RndPerm.
  eapply shuffle_wf.

Qed.


Require Import ProofCheckingEuclid.euclidean_axioms.
Require Import ProofCheckingEuclid.euclidean_defs.

Section Euclid.

Context `{Ax:euclidean_neutral_ruler_compass}.

Lemma lemma_s_cut :
	forall A B C D E,
	BetS A E B ->
	BetS C E D ->
	nCol A B C ->
	nCol A B D ->
	Cut A B C D E.
Proof.
	intros A B C D E.
	intros BetS_A_E_B.
	intros BetS_C_E_D.
	intros nCol_A_B_C.
	intros nCol_A_B_D.

	unfold Cut.
	split.
	exact BetS_A_E_B.
	split.
	exact BetS_C_E_D.
	split.
	exact nCol_A_B_C.
	exact nCol_A_B_D.
Qed.

End Euclid.


From Hammer Require Import Hammer.

Require Import QArith.

Lemma Qopp_lt_compat: forall p q : Q, p < q -> - q < - p.
Proof. hammer_hook "Qround" "Qround.Qopp_lt_compat".
intros (a1,a2) (b1,b2); unfold Qle, Qlt; simpl.
rewrite !Z.mul_opp_l; omega.
Qed.

Hint Resolve Qopp_lt_compat : qarith.

Local Coercion inject_Z : Z >-> Q.

Definition Qfloor (x:Q) := let (n,d) := x in Z.div n (Zpos d).
Definition Qceiling (x:Q) := (-(Qfloor (-x)))%Z.

Lemma Qfloor_Z : forall z:Z, Qfloor z = z.
Proof. hammer_hook "Qround" "Qround.Qfloor_Z".
intros z.
simpl.
auto with *.
Qed.

Lemma Qceiling_Z : forall z:Z, Qceiling z = z.
Proof. hammer_hook "Qround" "Qround.Qceiling_Z".
intros z.
unfold Qceiling.
simpl.
rewrite Zdiv_1_r.
auto with *.
Qed.

Lemma Qfloor_le : forall x, Qfloor x <= x.
Proof. hammer_hook "Qround" "Qround.Qfloor_le".
intros [n d].
simpl.
unfold Qle.
simpl.
replace (n*1)%Z with n by ring.
rewrite Z.mul_comm.
apply Z_mult_div_ge.
auto with *.
Qed.

Hint Resolve Qfloor_le : qarith.

Lemma Qle_ceiling : forall x, x <= Qceiling x.
Proof. hammer_hook "Qround" "Qround.Qle_ceiling".
intros x.
apply Qle_trans with (- - x).
rewrite Qopp_involutive.
auto with *.
change (Qceiling x:Q) with (-(Qfloor(-x))).
auto with *.
Qed.

Hint Resolve Qle_ceiling : qarith.

Lemma Qle_floor_ceiling : forall x, Qfloor x <= Qceiling x.
Proof. hammer_hook "Qround" "Qround.Qle_floor_ceiling".
eauto with qarith.
Qed.

Lemma Qlt_floor : forall x, x < (Qfloor x+1)%Z.
Proof. hammer_hook "Qround" "Qround.Qlt_floor".
intros [n d].
simpl.
unfold Qlt.
simpl.
replace (n*1)%Z with n by ring.
ring_simplify.
replace (n / ' d * ' d + ' d)%Z with
(('d * (n / 'd) + n mod 'd) + 'd - n mod 'd)%Z by ring.
rewrite <- Z_div_mod_eq; auto with*.
rewrite <- Z.lt_add_lt_sub_r.
destruct (Z_mod_lt n ('d)); auto with *.
Qed.

Hint Resolve Qlt_floor : qarith.

Lemma Qceiling_lt : forall x, (Qceiling x-1)%Z < x.
Proof. hammer_hook "Qround" "Qround.Qceiling_lt".
intros x.
unfold Qceiling.
replace (- Qfloor (- x) - 1)%Z with (-(Qfloor (-x) + 1))%Z by ring.
change ((- (Qfloor (- x) + 1))%Z:Q) with (-(Qfloor (- x) + 1)%Z).
apply Qlt_le_trans with (- - x); auto with *.
rewrite Qopp_involutive.
auto with *.
Qed.

Hint Resolve Qceiling_lt : qarith.

Lemma Qfloor_resp_le : forall x y, x <= y -> (Qfloor x <= Qfloor y)%Z.
Proof. hammer_hook "Qround" "Qround.Qfloor_resp_le".
intros [xn xd] [yn yd] Hxy.
unfold Qle in *.
simpl in *.
rewrite <- (Zdiv_mult_cancel_r xn ('xd) ('yd)); auto with *.
rewrite <- (Zdiv_mult_cancel_r yn ('yd) ('xd)); auto with *.
rewrite (Z.mul_comm ('yd) ('xd)).
apply Z_div_le; auto with *.
Qed.

Hint Resolve Qfloor_resp_le : qarith.

Lemma Qceiling_resp_le : forall x y, x <= y -> (Qceiling x <= Qceiling y)%Z.
Proof. hammer_hook "Qround" "Qround.Qceiling_resp_le".
intros x y Hxy.
unfold Qceiling.
cut (Qfloor (-y) <= Qfloor (-x))%Z; auto with *.
Qed.

Hint Resolve Qceiling_resp_le : qarith.

Add Morphism Qfloor with signature Qeq ==> eq as Qfloor_comp.
Proof.
intros x y H.
apply Z.le_antisymm.
auto with *.
symmetry in H; auto with *.
Qed.

Add Morphism Qceiling with signature Qeq ==> eq as Qceiling_comp.
Proof.
intros x y H.
apply Z.le_antisymm.
auto with *.
symmetry in H; auto with *.
Qed.

Lemma Zdiv_Qdiv (n m: Z): (n / m)%Z = Qfloor (n / m).
Proof. hammer_hook "Qround" "Qround.Zdiv_Qdiv".
unfold Qfloor. intros. simpl.
destruct m as [ | | p]; simpl.
now rewrite Zdiv_0_r, Z.mul_0_r.
now rewrite Z.mul_1_r.
rewrite <- Z.opp_eq_mul_m1.
rewrite <- (Z.opp_involutive (Zpos p)).
now rewrite Zdiv_opp_opp.
Qed.


Inductive a_tag : Type :=
  | Tag : nat -> a_tag.

Check Tag 3.

Fixpoint beq_nat (n m : nat) : bool :=
  match n with
  | O => match m with
         | O => true
         | S m' => false
         end
  | S n' => match m with
            | O => false
            | S m' => beq_nat n' m'
            end
  end.

Theorem beq_refl : forall x : nat, true = beq_nat x x.
Proof.
  intros x.
  induction x.
  - (* base *) simpl. reflexivity.
  - (* i.h. *) simpl. rewrite IHx. reflexivity.
Qed.

Definition beq_tag (a b : a_tag) : bool :=
  match a, b with
  | Tag a', Tag b' => beq_nat a' b'
  end.

Compute eq 1 2.

Compute beq_tag (Tag 2) (Tag 5).
Compute beq_tag (Tag 5) (Tag 5).

Theorem beq_tag_refl : forall x, true = beq_tag x x.
Proof.
  intros x.
  simpl.
  unfold beq_tag.
  case x.
  - (* match b with Tag b' => beq_nat a' b', but a' = b' because of beq_tag x x *)
  exact beq_refl.
Qed.

Inductive partial_map : Type :=
  | empty : partial_map
  | record : a_tag -> nat -> partial_map -> partial_map.

Definition update (d : partial_map)
                  (x : a_tag) (value : nat)
                  : partial_map :=
  record x value d.

Definition test  := update empty (Tag 1) 2.
Definition test' := update test (Tag 3) 4.
Compute test'.

Inductive natoption : Type :=
  | None : natoption
  | Some : nat -> natoption.

Fixpoint find (x : a_tag) (d : partial_map) : natoption :=
  match d with
  | empty         => None
  | record y v d' => if beq_tag x y
                     then Some v
                     else find x d'
  end.

Compute find (Tag 1) test'.
Compute find (Tag 2) test'.
Compute find (Tag 3) test'.
Compute find (Tag 4) test'.
Compute find (Tag 5) test'.

Theorem update_eq : forall (d : partial_map) (x : a_tag) (v: nat),
  find x (update d x v) = Some v.
Proof.
  intros d x v.
  simpl.
  rewrite <- beq_tag_refl.
  reflexivity.
Qed.

Theorem update_neq : forall (d : partial_map) (x y : a_tag) (o: nat),
    beq_tag x y = false -> find x (update d y o) = find x d.
Proof.
  intros d x y o.
  intros beq_tag_x_neq_y.
  simpl.
  rewrite beq_tag_x_neq_y.
  reflexivity.
Qed.

Inductive baz : Type :=
  | Baz1 : baz -> baz
  | Baz2 : baz -> bool -> baz.

(*
How many elements does the type baz have?
Since the inductive definition does not have a base case, we have 0 elements.
We can't construct any elements.
*)

(*
Found this after my answer:
https://cs.stackexchange.com/questions/29365/baz-num-elts-exercise-from-software-foundations?answertab=votes#tab-top

There's a bijection between baz and False.
*)

Definition injective : forall {t1 t2}, (t1 -> t2) -> Prop := fun t1 t2 f1 => forall x1 x2, f1 x1 = f1 x2 -> x1 = x2.
Definition surjective : forall {t1 t2}, (t1 -> t2) -> Prop := fun t1 t2 f1 => forall x1, exists x2, f1 x2 = x1.
Definition bijective : forall {t1 t2}, (t1 -> t2) -> Prop := fun t1 t2 f1 => injective f1 /\ surjective f1.

Theorem baz_False : baz -> False.
Proof.
  induction 1. exact IHbaz. exact IHbaz.
Qed.

Goal exists f1 : baz -> False, bijective f1.
Proof.
  exists baz_False. unfold bijective, injective, surjective. firstorder.
  assert (H2 := baz_False x1). firstorder.
  assert (H2 := x1). firstorder.
Qed.


(* Exercise coq_tree_02 *)

(* Let us start with the definition of a binary tree of
   natural numbers, from the previous exercise *)

Inductive nat_tree : Set :=
  | leaf : nat_tree
  | node : nat_tree -> nat -> nat_tree -> nat_tree.

Print plus.

(* Now define the function 'mirror' that return a mirror
   image of a tree.
   For instance:

               a              a
             /   \          /   \
   mirror(  b     d   ) =  d     b
   	     \    /\       /\   /
	      c  e  f     f  e c
*)

Fixpoint mirror (T : nat_tree) : nat_tree :=
  match T return nat_tree with
  | leaf => leaf
  | node l n r => node (mirror r) n (mirror l)
  end.

(* Now, let us check this function on the example presented
   above *)

Lemma mirror_ex : forall a b c d e f,
  mirror (node
      (node leaf b (node leaf c leaf))
      a
      (node (node leaf e leaf) d (node leaf f leaf))) =
  node
    (node (node leaf f leaf) d (node leaf e leaf))
    a
    (node (node leaf c leaf) b leaf).

Proof.
intros.
unfold mirror.
reflexivity.
Qed.


Require Import Nat.
Require Import Arith.

Module Export LambdaCalc.

(* A lambda calculus term using de Bruijn indices. The nat parameter
   indicates the number of bound variables. *)
Inductive lambda (n : nat) : Set :=
  | Var : forall (idx : nat), idx < n -> lambda n
  | Lambda : lambda (S n) -> lambda n
  | Apply : lambda n -> lambda n -> lambda n.

Definition raiseIndex {n : nat} (l : lambda n) : lambda (S n).
  induction l.
  - apply (Var (S n) idx). constructor. exact l.
  - apply Lambda. exact IHl.
  - apply Apply.
    * exact IHl1.
    * exact IHl2.
Defined.

Definition addIndex {n : nat} (depth : nat) (l : lambda n) : lambda (S n).
  induction l.
  - destruct (ltb idx depth).
    * apply raiseIndex. exact (Var n idx l).
    * apply (Var (S n) (S idx)). apply le_n_S. exact l.

  - apply Lambda. exact IHl.

  - apply Apply. exact IHl1. exact IHl2.
Defined.

Fixpoint subst' {n : nat} (depth : nat) (ltD : depth <= n)
  (l : lambda (S n)) (x : lambda n) : lambda n.
  destruct l.

  - destruct (gt_dec idx depth).
    * apply (Var n (pred idx)). unfold gt in g. unfold lt in g.
      destruct idx.
      -- exfalso. inversion g.
      -- simpl. apply le_S_n. exact l.
    * destruct (lt_dec idx depth).
      -- pose (ltN := le_trans (S idx) depth n l0 ltD).
         apply (Var n idx). exact ltN.
      -- exact x.

  - apply Lambda.
    exact (subst' (S n) (S depth) (le_n_S depth n ltD) l (addIndex 0 x)).

  - apply Apply.
    exact (subst' n depth ltD l1 x).
    exact (subst' n depth ltD l2 x).
Defined.

(* Substitutes x into l for the de Bruijn index 0. *)
Definition subst {n : nat} (l : lambda (S n)) (x : lambda n) : lambda n :=
  subst' 0 (le_0_n n) l x.

(* A small step evaluation relationship. *)
Reserved Notation "t1 '/' n '==>' t2" (at level 40).
Inductive step (n : nat) : lambda n -> lambda n -> Prop :=
  | LambdaEval : forall (l l' : lambda (S n)), l / (S n) ==> l'
      -> Lambda n l / n ==> Lambda n l'
  | ApplyEval1 : forall (l1 l2 l1' : lambda n), l1 / n ==> l1'
      -> Apply n l1 l2 / n ==> Apply n l1' l2
  | ApplyEval2 : forall (l1 l2 l2' : lambda n), l2 / n ==> l2'
      -> Apply n l1 l2 / n ==> Apply n l1 l2'
  | ApplyFun : forall (l : lambda (S n)) (x : lambda n),
      (Apply n (Lambda n l) x) / n ==> subst l x
where "t1 '/' n '==>' t2" := (step n t1 t2).

Reserved Notation "t1 '/' n '==>*' t2" (at level 40).
Inductive steps (n : nat) : lambda n -> lambda n -> Prop :=
  | EvalRefl : forall (l : lambda n), steps n l l
  | EvalMany : forall (l1 l2 l3 : lambda n), l1 / n ==> l2
      -> l2 / n ==>* l3 -> l1 / n ==>* l3
where "t1 '/' n '==>*' t2" := (steps n t1 t2).

Theorem lift_step {n : nat} {l l' : lambda n} (s : l / n ==> l')
  : l / n ==>* l'.
Proof.
  apply (EvalMany n l l' l').
  exact s.
  exact (EvalRefl n l').
Qed.

Theorem trans_steps {n : nat} {l1 l2 l3 : lambda n} (evs1 : l1 /n ==>* l2)
  (evs2 : l2 / n ==>* l3) : l1 / n ==>* l3.
Proof.
  induction evs1.
  induction evs2.

  - apply EvalRefl.

  - apply (EvalMany n l1 l2 l3). exact H. exact evs2.

  - apply IHevs1 in evs2. apply (EvalMany n l1 l2 l3). exact H. exact evs2.
Qed.

Theorem lift_lambda {n : nat} {l l' : lambda (S n)}
  (evs : l / (S n) ==>* l') : Lambda n l / n ==>* Lambda n l'.
Proof.
  induction evs.

  - apply EvalRefl.

  - apply LambdaEval in H.
    apply (EvalMany n (Lambda n l1) (Lambda n l2) (Lambda n l3)).
    exact H.
    exact IHevs.
Qed.

Theorem lift_apply {n : nat} {l1 l1' l2 l2' : lambda n}
  (evs1 : l1 / n ==>* l1') (evs2 : l2 / n ==>* l2')
  : Apply n l1 l2 / n ==>* Apply n l1' l2'.
Proof.
  induction evs1.
  induction evs2.

  - apply EvalRefl.

  - apply (ApplyEval2 n l l1 l2) in H.
    apply (EvalMany n (Apply n l l1) (Apply n l l2) (Apply n l l3)).
    exact H.
    exact IHevs2.

  - assert (Apply n l1 l2 / n ==> Apply n l0 l2).
    * apply (ApplyEval1 n l1 l2 l0). exact H.
    * apply (EvalMany n (Apply n l1 l2) (Apply n l0 l2) (Apply n l3 l2')).
      exact H0.
      exact IHevs1.
Qed.

End LambdaCalc.


Require Export ZArith.
Require Export List.
Require Export Arith.
Require Export Omega.
Require Export Zwf.
Require Export Relations.
Require Export Inverse_Image.
Require Export Transitive_Closure.
Require Export Zdiv.

Open Scope nat_scope.

Theorem verif_divide :
    forall m p:nat, 0 < m -> 0 < p ->
    (exists q:nat, m = q*p)->(Z_of_nat m mod Z_of_nat p = 0)%Z.
Proof.
 intros m p Hltm Hltp (q, Heq); rewrite Heq.
 rewrite inj_mult.
 replace (Z_of_nat q * Z_of_nat p)%Z with (0 + Z_of_nat q * Z_of_nat p)%Z;
    try ring.
 rewrite Z_mod_plus; auto.
 omega.
Qed.

Theorem divisor_smaller :
    forall m p:nat, 0 < m -> forall q:nat, m = q*p -> q <= m.
Proof.
 intros m p Hlt; case p.
 -  intros q Heq; rewrite Heq in Hlt; rewrite mult_comm in Hlt.
    elim (lt_irrefl 0);exact Hlt.
 -  intros p' q; case q.
    +  intros Heq; rewrite Heq in Hlt.
       elim (lt_irrefl 0);exact Hlt.
    +  intros q' Heq; rewrite Heq.
       rewrite mult_comm; simpl; auto with arith.
Qed.

Fixpoint check_range (v:Z)(r:nat)(sr:Z){struct r} : bool :=
  match r with
    O => true
  | S r' =>
    match (v mod sr)%Z with
      Z0 => false
    | _ => check_range v r' (Zpred sr)
    end
  end.

Definition check_primality (n:nat) :=
  check_range (Z_of_nat n)(pred (pred n))(Z_of_nat (pred n)).

(** Tests :

Compute check_primality 2333.

Compute check_primality 2330.
*)

Fixpoint check_range' (v:Z)(r:nat){struct r} : bool :=
  match r with
    0 => true | 1 => true
  | S r' =>
      match (v mod Z_of_nat r)%Z with
      | 0%Z => false
      | _ => check_range' v r'
      end
  end.

Definition check_primality' (n:nat) :=
  check_range' (Zpos (P_of_succ_nat (pred n)))(pred (pred n)).

Theorem Zabs_nat_0 : forall x:Z, Zabs_nat x = 0 -> (x = 0)%Z.
Proof.
 intros x; case x.
 -  simpl; auto.
 -  intros p Heq; elim (lt_irrefl 0).
    pattern 0 at 2; rewrite <- Heq.
    simpl; apply lt_O_nat_of_P.
 -  intros p Heq; elim (lt_irrefl 0).
    pattern 0 at 2; rewrite <- Heq.
    simpl; apply lt_O_nat_of_P.
Qed.

Theorem Z_to_nat_and_back :
 forall x:Z, (0 <= x)%Z -> (Z_of_nat (Zabs_nat x))=x.
Proof.
 intros x; case x.
 -  auto.
 -  intros p Hd; elim p.
    +  unfold Zabs_nat; intros p' Hrec; rewrite nat_of_P_xI.
       rewrite inj_S.
       rewrite inj_mult.
       rewrite Zpos_xI.
       unfold Zsucc.
       rewrite Hrec.
       simpl; auto.
    +  unfold Zabs_nat.
       intros p' Hrec; rewrite nat_of_P_xO.
       rewrite inj_mult.
       rewrite Zpos_xO.
       unfold Zsucc.
       rewrite Hrec.
       simpl; auto.
    +  simpl; auto.
 - intros p' Hd; elim Hd;auto.
Qed.

Theorem check_range_correct :
  forall (v:Z)(r:nat)(rz:Z),
  (0 < v)%Z ->
  Z_of_nat (S r) = rz -> check_range v r rz = true ->
  ~ (exists k:nat, k <= (S r) /\ k <> 1 /\
                       (exists q:nat, Zabs_nat v = q*k)).
Proof.
 intros v r; elim r.
 -  intros rz Hlt H1 H2 Hex; case Hex; intros k; case k.
   +  intros (Hle, (Hne1, (q, Heq))).
      rewrite mult_comm in Heq; simpl in Heq.
      rewrite (Zabs_nat_0 _ Heq) in Hlt.
      elim (Zlt_irrefl 0); assumption.
   +  intros k' (Hle, (Hne1, (q, Heq))).
      inversion Hle.
      assert (H':k'=0).
      * assumption.
      * rewrite H' in Hne1; elim Hne1;auto.
      * assert (H': S k' <= 0) by  assumption.
        inversion H'.
-  intros r' Hrec rz Hlt H1 H2 Hex; case Hex; intros k; case k.
   +  intros (Hle, (Hne1, (q, Heq))).
      rewrite mult_comm in Heq; simpl in Heq.
      rewrite (Zabs_nat_0 _ Heq) in Hlt.
      elim (Zlt_irrefl 0); assumption.
   +  intros k' (Hle, (Hne1, (q, Heq))).
      inversion Hle.
      rewrite <- H1 in H2.
      rewrite <- (Z_to_nat_and_back v) in H2.
      assert (Hmod:(Z_of_nat (Zabs_nat v) mod Z_of_nat (S (S r')) = 0)%Z).
      *  apply verif_divide.
         replace 0 with (Zabs_nat 0%Z).
         apply Zabs_nat_lt.
         omega.
         simpl; auto.
         auto with arith.
         exists q.
         assert (H': k' = S r') by assumption.
         rewrite <- H';auto.
      *   unfold check_range in H2.
         rewrite Hmod in H2; discriminate H2.
      *  omega.
      *  unfold check_range in H2; fold check_range in H2.
         case_eq ((v mod rz)%Z).
         intros Heqmod.
         rewrite Heqmod in H2.
         discriminate H2.
         intros pmod Heqmod; rewrite Heqmod in H2.
         elim (Hrec (Zpred rz) Hlt).
         rewrite <- H1.
         rewrite inj_S.
         rewrite inj_S.
         rewrite inj_S.
         rewrite <- Zpred_succ.
         auto.
         assumption.
         exists (S k').
         repeat split;auto.
         exists q; assumption.
         intros p Hmod.
         elim (Z_mod_lt v rz).
         rewrite Hmod.
         unfold Zle; simpl; intros Hle'; elim Hle';auto.
         rewrite <- H1.
         rewrite inj_S.
         unfold Zsucc.
         generalize (Zle_0_nat (S r')).
         intros; omega.
Qed.

Theorem nat_of_P_Psucc :
 forall p:positive, nat_of_P (Psucc p) = S (nat_of_P p).
Proof.
 intros p; elim p.
 -  simpl; intros p'; rewrite nat_of_P_xO.
    intros Heq; rewrite Heq; rewrite nat_of_P_xI; ring.
 - intros p' Heq; simpl.
   rewrite nat_of_P_xI.
   rewrite nat_of_P_xO;auto.
 -  auto.
Qed.

Theorem nat_to_Z_and_back:
 forall n:nat, Zabs_nat (Z_of_nat n) = n.
Proof.
 intros n; elim n.
 -  auto.
 - intros n'; simpl; case n'.
  + simpl; auto.
  +  intros n''; simpl; rewrite nat_of_P_Psucc.
     intros Heq; rewrite Heq; auto.
Qed.

Theorem check_correct :
  forall p:nat, 0 < p -> check_primality p = true ->
  ~(exists k:nat, k <> 1 /\ k <> p /\ (exists q:nat, p = q*k)).
Proof.
 unfold lt; intros p Hle; elim Hle.
 -  intros Hcp (k, (Hne1, (Hne1bis, (q, Heq))));
   rewrite mult_comm in Heq.
    assert (Hle' : k < 1).
   +  elim (le_lt_or_eq k 1); try(intuition; fail).
      apply divisor_smaller with (2:= Heq); auto.
   + case_eq k.
     intros Heq'; rewrite Heq' in Heq; simpl in Heq; discriminate Heq.
     intros; omega.
 -  intros p' Hlep' Hrec; unfold check_primality.
    assert (H':(exists p'':nat, p' = (S p''))).
    +  inversion Hlep'.
       exists 0; auto.
       eapply ex_intro;eauto.
    +  elim H'; intros p'' Hp''; rewrite Hp''.
       repeat rewrite <- pred_Sn.
       intros Hcr Hex.
       elim check_range_correct with (3:= Hcr).
       rewrite inj_S; generalize (Zle_0_nat (S p'')).
       intros; omega.
       auto.
       elim Hex; intros k (Hne1, (HneSSp'', (q, Heq))); exists k.
       split.
       assert (HkleSSp'': k <= S (S p'')).
       * apply (divisor_smaller (S (S p'')) q).
         auto with arith.
         rewrite mult_comm.
         assumption.
       *  omega.
       * split.
         assumption.
         exists q; now rewrite nat_to_Z_and_back.
Qed.

Theorem prime_2333 :
 ~(exists k:nat, k <> 1 /\ k <> 2333 /\ (exists q:nat, 2333 = q*k)).
Proof.
 Time apply check_correct; auto with arith.
(**Finished transaction in 132. secs (131.01u,0.62s)*)
Time Qed.

Theorem reflection_test :
 forall x y z t u:nat, x+(y+z+(t+u)) = x+y+(z+(t+u)).
Proof.
 intros; repeat rewrite plus_assoc; auto.
Qed.

Inductive bin : Set := node : bin->bin->bin | leaf : nat->bin.

Fixpoint flatten_aux (t fin:bin){struct t} : bin :=
  match t with
  | node t1 t2 => flatten_aux t1 (flatten_aux t2 fin)
  | x => node x fin
  end.

Fixpoint flatten (t:bin) : bin :=
  match t with
  | node t1 t2 => flatten_aux t1 (flatten t2)
  | x => x
  end.

Compute
  flatten
     (node (leaf 1) (node (node (leaf 2)(leaf 3)) (leaf 4))).

Fixpoint bin_nat (t:bin) : nat :=
  match t with
  | node t1 t2 => bin_nat t1 + bin_nat t2
  | leaf n => n
  end.

Eval lazy beta iota delta [bin_nat] in
 (bin_nat
   (node (leaf 1) (node (node (leaf 2) (leaf 3)) (leaf 4)))).

Theorem flatten_aux_valid :
 forall t t':bin, bin_nat t + bin_nat t' = bin_nat (flatten_aux t t').
Proof.
 intros t; elim t; simpl; auto.
 intros t1 IHt1 t2 IHt2 t'; rewrite <- IHt1; rewrite <- IHt2.
 rewrite plus_assoc; trivial.
Qed.

Theorem flatten_valid : forall t:bin, bin_nat t = bin_nat (flatten t).
Proof.
 intros t; elim t; simpl; auto.
 intros t1 IHt1 t2 IHt2; rewrite <- flatten_aux_valid; rewrite <- IHt2.
 trivial.
Qed.

Theorem flatten_valid_2 :
  forall t t':bin, bin_nat (flatten t) = bin_nat (flatten t')->
  bin_nat t = bin_nat t'.
Proof.
 intros; rewrite (flatten_valid t); rewrite (flatten_valid t');
 auto.
Qed.

Theorem reflection_test' :
 forall x y z t u:nat, x+(y+z+(t+u))=x+y+(z+(t+u)).
Proof.
 intros.
 change
   (bin_nat
      (node (leaf x)
         (node (node (leaf y) (leaf z))
               (node (leaf t)(leaf u)))) =
    bin_nat
      (node (node (leaf x)(leaf y))
         (node (leaf z)
               (node (leaf t)(leaf u))))).
 apply flatten_valid_2; auto.
Qed.

Ltac model v :=
  match v with
  | (?X1 + ?X2) =>
    let r1 := model X1
              with r2 := model X2 in constr:(node r1 r2)
  | ?X1 => constr:(leaf X1)
  end.

Ltac assoc_eq_nat :=
  match goal with
  | [ |- (?X1 = ?X2 :>nat) ] =>
   let term1 := model X1 with term2 := model X2 in
   (change (bin_nat term1 = bin_nat term2);
    apply flatten_valid_2;
    lazy beta iota zeta delta [flatten flatten_aux bin_nat];
    auto)
  end.

Theorem reflection_test'' :
 forall x y z t u:nat, x+(y+z+(t+u)) = x+y+(z+(t+u)).
Proof.
 intros; assoc_eq_nat.
Qed.

Section assoc_eq.
Variables (A : Type)(f : A->A->A)
  (assoc : forall x y z:A, f x (f y z) = f (f x y) z).

Fixpoint bin_A (l:list A)(def:A)(t:bin){struct t} : A :=
  match t with
  | node t1 t2 => f (bin_A l def t1)(bin_A l def t2)
  | leaf n => nth n l def
  end.

Theorem flatten_aux_valid_A :
 forall (l:list A)(def:A)(t t':bin),
 f (bin_A l def t)(bin_A l def t') = bin_A l def (flatten_aux t t').
Proof.
 intros l def t; elim t; simpl; auto.
 intros t1 IHt1 t2 IHt2 t';  rewrite <- IHt1; rewrite <- IHt2.
 symmetry; apply assoc.
Qed.

Theorem flatten_valid_A :
 forall (l:list A)(def:A)(t:bin),
   bin_A l def t = bin_A l def (flatten t).
Proof.
 intros l def t; elim t; simpl; trivial.
 intros t1 IHt1 t2 IHt2; rewrite <- flatten_aux_valid_A; now rewrite <- IHt2.
Qed.

Theorem flatten_valid_A_2 :
 forall (t t':bin)(l:list A)(def:A),
   bin_A l def (flatten t) = bin_A l def (flatten t')->
   bin_A l def t = bin_A l def t'.
Proof.
 intros t t' l def Heq.
 rewrite (flatten_valid_A l def t); now rewrite (flatten_valid_A l def t').
Qed.

End assoc_eq.

Ltac term_list f l v :=
  match v with
  | (f ?X1 ?X2) =>
    let l1 := term_list f l X2 in term_list f l1 X1
  | ?X1 => constr:(cons X1 l)
  end.

Ltac compute_rank l n v :=
  match l with
  | (cons ?X1 ?X2) =>
    let tl := constr:(X2) in
    match constr:(X1 = v) with
    | (?X1 = ?X1) => n
    | _ => compute_rank tl (S n) v
    end
  end.

Ltac model_aux l f v :=
  match v with
  | (f ?X1 ?X2) =>
    let r1 := model_aux l f X1 with r2 := model_aux l f X2 in
      constr:(node r1 r2)
  | ?X1 => let n := compute_rank l 0 X1 in constr:(leaf n)
  | _ => constr:(leaf 0)
  end.

Ltac model_A A f def v :=
  let l := term_list f (nil (A:=A)) v in
  let t := model_aux l f v in
  constr:(bin_A A f l def t).

Ltac assoc_eq A f assoc_thm :=
  match goal with
  | [ |- (@eq A ?X1 ?X2) ] =>
  let term1 := model_A A f X1 X1
  with term2 := model_A A f X1 X2 in
  (change (term1 = term2);
   apply flatten_valid_A_2 with (1 := assoc_thm); auto)
  end.

Theorem reflection_test3 :
 forall x y z t u:Z, (x*(y*z*(t*u)) = x*y*(z*(t*u)))%Z.
Proof.
 intros; assoc_eq Z Zmult Zmult_assoc.
Qed.

Fixpoint nat_le_bool (n m:nat){struct m} : bool :=
  match n, m with
  | O, _ => true
  | S _, O => false
  | S n, S m => nat_le_bool n m
  end.

Fixpoint insert_bin (n:nat)(t:bin){struct t} : bin :=
  match t with
  | leaf m => match nat_le_bool n m with
              | true => node (leaf n)(leaf m)
              | false => node (leaf m)(leaf n)
              end
  | node (leaf m) t' => match nat_le_bool n m with
                        | true => node (leaf n) t
                        | false =>
                            node (leaf m)(insert_bin n t')
                        end
  | t => node (leaf n) t
  end.

Fixpoint sort_bin (t:bin) : bin :=
  match t with
  | node (leaf n) t' => insert_bin n (sort_bin t')
  | t => t
  end.

Section commut_eq.
(** this section contains some primed versions of previous constructions
   (for avoiding Reset commands)

*)

 Variables (A : Type)(f : A->A->A).
 Hypothesis comm : forall x y:A, f x y = f y x.
 Hypothesis assoc : forall x y z:A, f x (f y z) = f (f x y) z.

 Fixpoint bin_A' (l:list A)(def:A)(t:bin){struct t} : A :=
   match t with
   | node t1 t2 => f (bin_A' l def t1)(bin_A' l def t2)
   | leaf n => nth n l def
   end.

 Theorem flatten_aux_valid_A' :
  forall (l:list A)(def:A)(t t':bin),
   f (bin_A' l def t)(bin_A' l def t') = bin_A' l def (flatten_aux t t').
 Proof.
  intros l def t; elim t; simpl; auto.
  intros t1 IHt1 t2 IHt2 t';  rewrite <- IHt1; rewrite <- IHt2.
  symmetry; apply assoc.
 Qed.

 Theorem flatten_valid_A' :
  forall (l:list A)(def:A)(t:bin),
    bin_A' l def t = bin_A' l def (flatten t).
 Proof.
  intros l def t; elim t; simpl; trivial.
  intros t1 IHt1 t2 IHt2; rewrite <- flatten_aux_valid_A'; rewrite <- IHt2.
  trivial.
 Qed.

Theorem flatten_valid_A_2' :
 forall (t t':bin)(l:list A)(def:A),
   bin_A' l def (flatten t) = bin_A' l def (flatten t')->
   bin_A' l def t = bin_A' l def t'.
Proof.
 intros t t' l def Heq.
 rewrite (flatten_valid_A' l def t); rewrite (flatten_valid_A' l def t').
 trivial.
Qed.

Theorem insert_is_f : forall (l:list A)(def:A)(n:nat)(t:bin),
   bin_A' l def (insert_bin n t) =
   f (nth n l def) (bin_A' l def t).
Proof.
 intros l def n t; elim t.
 intros t1; case t1.
 intros t1' t1'' IHt1 t2 IHt2.
 simpl.
 auto.
 intros n0 IHt1 t2 IHt2.
 simpl.
 case (nat_le_bool n n0).
 simpl.
 auto.
 simpl.
 rewrite IHt2.
 repeat rewrite assoc; rewrite (comm (nth n l def)); auto.
 simpl.
 intros n0; case (nat_le_bool n n0); auto.
 rewrite comm; auto.
Qed.

Theorem sort_eq : forall (l:list A)(def:A)(t:bin),
    bin_A' l def (sort_bin t) = bin_A' l def t.
Proof.
 intros l def t; elim t.
 intros t1 IHt1; case t1.
 auto.
 intros n t2 IHt2; simpl; rewrite insert_is_f.
 rewrite IHt2; auto.
 auto.
Qed.

Theorem sort_eq_2 :
 forall (l:list A)(def:A)(t1 t2:bin),
   bin_A' l def (sort_bin t1) = bin_A' l def (sort_bin t2)->
   bin_A' l def t1 = bin_A' l def t2.
Proof.
 intros l def t1 t2.
 rewrite <- (sort_eq l def t1); rewrite <- (sort_eq l def t2).
 trivial.
Qed.

End commut_eq.

Ltac term_list' f l v :=
  match v with
  | (f ?X1 ?X2) =>
    let l1 := term_list' f l X2 in term_list' f l1 X1
  | ?X1 => constr:(cons X1 l)
  end.

Ltac compute_rank' l n v :=
  match l with
  | (cons ?X1 ?X2) =>
    let tl := constr:(X2) in
    match constr:(X1 = v) with
    | (?X1 = ?X1) => n
    | _ => compute_rank' tl (S n) v
    end
  end.

Ltac model_aux' l f v :=
  match v with
  | (f ?X1 ?X2) =>
    let r1 := model_aux' l f X1 with r2 := model_aux' l f X2 in
      constr:(node r1 r2)
  | ?X1 => let n := compute_rank' l 0 X1 in constr:(leaf n)
  | _ => constr:(leaf 0)
  end.

Ltac comm_eq' A f assoc_thm comm_thm :=
  match goal with
  | [ |- (?X1 = ?X2 :>A) ] =>
    let l := term_list' f (nil (A:=A)) X1 in
    let term1 := model_aux' l f X1
    with term2 := model_aux' l f X2 in
    (change (bin_A' A f l X1 term1 = bin_A' A f l X1 term2);
      apply flatten_valid_A_2' with (1 := assoc_thm);
      apply sort_eq_2 with (1 := comm_thm)(2 := assoc_thm);
      auto)
  end.

Theorem reflection_test4 : forall x y z:Z, (x+(y+z) = (z+x)+y)%Z.
Proof.
 intros x y z. comm_eq' Z Zplus Zplus_assoc Zplus_comm.
Qed.


Module Nats.

Fixpoint eqb (n m : nat) : bool :=
    match n with
    | O =>  match m with
            | O => true
            | S _ => false
            end
    | S n' => match m with
            | O => false
            | S m' => eqb n' m'
            end
    end.

Notation "x =? y" := (eqb x y) (at level 70).

End Nats.

Module Lists.

Import Nats.

Notation "x :: xs" := (cons x xs)(at level 60, right associativity).
Notation "[ ]" := nil.
Notation "[ x ; .. ; y ]" := (cons x .. (cons y nil) .. ).
Notation "x ++ y" := (app x y) (at level 60, right associativity).

Fixpoint rev {X: Type} (l: list X) : list X :=
    match l with
    | nil => nil
    | x::xs => (rev xs) ++ [x]
    end.

Fixpoint nth_err {X: Type} (l: list X) (n: nat) : option X :=
    match l with
    | [] => None
    | x::xs => if n =? 0 then Some x else nth_err xs (pred n)
    end.

Fixpoint split {X Y: Type} (l: list (X * Y))
    : (list X) * (list Y) :=
    match l with
    | nil => (nil, nil)
    | cons (x, y) ls => match (split ls) with
                    | (p, q) => (cons x p, cons y q)
    end
    end.

End Lists.


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

Require Import NAxioms NSub NDiv NGcd.

(** * Least Common Multiple *)

(** Unlike other functions around, we will define lcm below instead of
  axiomatizing it. Indeed, there is no "prior art" about lcm in the
  standard library to be compliant with, and the generic definition
  of lcm via gcd is quite reasonable.

  By the way, we also state here some combined properties of div/mod
  and gcd.
*)

Module Type NLcmProp
 (Import A : NAxiomsSig')
 (Import B : NSubProp A)
 (Import C : NDivProp A B)
 (Import D : NGcdProp A B).

(** Divibility and modulo *)

Lemma mod_divide : forall a b, b~=0 -> (a mod b == 0 <-> (b|a)).
Proof.
 intros a b Hb. split.
 intros Hab. exists (a/b). rewrite mul_comm.
  rewrite (div_mod a b Hb) at 1. rewrite Hab; now nzsimpl.
 intros (c,Hc). rewrite Hc. now apply mod_mul.
Qed.

Lemma divide_div_mul_exact : forall a b c, b~=0 -> (b|a) ->
 (c*a)/b == c*(a/b).
Proof.
 intros a b c Hb H.
 apply mul_cancel_l with b; trivial.
 rewrite mul_assoc, mul_shuffle0.
 assert (H':=H). apply mod_divide, div_exact in H'; trivial.
 rewrite <- H', (mul_comm a c).
 symmetry. apply div_exact; trivial.
 apply mod_divide; trivial.
 now apply divide_mul_r.
Qed.

(** Gcd of divided elements, for exact divisions *)

Lemma gcd_div_factor : forall a b c, c~=0 -> (c|a) -> (c|b) ->
 gcd (a/c) (b/c) == (gcd a b)/c.
Proof.
 intros a b c Hc Ha Hb.
 apply mul_cancel_l with c; try order.
 assert (H:=gcd_greatest _ _ _ Ha Hb).
 apply mod_divide, div_exact in H; try order.
 rewrite <- H.
 rewrite <- gcd_mul_mono_l; try order.
 f_equiv; symmetry; apply div_exact; try order;
  apply mod_divide; trivial; try order.
Qed.

Lemma gcd_div_gcd : forall a b g, g~=0 -> g == gcd a b ->
 gcd (a/g) (b/g) == 1.
Proof.
 intros a b g NZ EQ. rewrite gcd_div_factor.
 now rewrite <- EQ, div_same.
 generalize (gcd_nonneg a b); order.
 rewrite EQ; apply gcd_divide_l.
 rewrite EQ; apply gcd_divide_r.
Qed.

(** The following equality is crucial for Euclid algorithm *)

Lemma gcd_mod : forall a b, b~=0 -> gcd (a mod b) b == gcd b a.
Proof.
 intros a b Hb. rewrite (gcd_comm _ b).
 rewrite <- (gcd_add_mult_diag_r b (a mod b) (a/b)).
 now rewrite add_comm, mul_comm, <- div_mod.
Qed.

(** We now define lcm thanks to gcd:

    lcm a b = a * (b / gcd a b)
            = (a / gcd a b) * b
            = (a*b) / gcd a b

   Nota: [lcm 0 0] should be 0, which isn't garantee with the third
   equation above.
*)

Definition lcm a b := a*(b/gcd a b).

Instance lcm_wd : Proper (eq==>eq==>eq) lcm.
Proof. unfold lcm. solve_proper. Qed.

Lemma lcm_equiv1 : forall a b, gcd a b ~= 0 ->
  a * (b / gcd a b) == (a*b)/gcd a b.
Proof.
 intros a b H. rewrite divide_div_mul_exact; try easy. apply gcd_divide_r.
Qed.

Lemma lcm_equiv2 : forall a b, gcd a b ~= 0 ->
  (a / gcd a b) * b == (a*b)/gcd a b.
Proof.
 intros a b H. rewrite 2 (mul_comm _ b).
 rewrite divide_div_mul_exact; try easy. apply gcd_divide_l.
Qed.

Lemma gcd_div_swap : forall a b,
 (a / gcd a b) * b == a * (b / gcd a b).
Proof.
 intros a b. destruct (eq_decidable (gcd a b) 0) as [EQ|NEQ].
 apply gcd_eq_0 in EQ. destruct EQ as (EQ,EQ'). rewrite EQ, EQ'. now nzsimpl.
 now rewrite lcm_equiv1, <-lcm_equiv2.
Qed.

Lemma divide_lcm_l : forall a b, (a | lcm a b).
Proof.
 unfold lcm. intros a b. apply divide_factor_l.
Qed.

Lemma divide_lcm_r : forall a b, (b | lcm a b).
Proof.
 unfold lcm. intros a b. rewrite <- gcd_div_swap.
 apply divide_factor_r.
Qed.

Lemma divide_div : forall a b c, a~=0 -> (a|b) -> (b|c) -> (b/a|c/a).
Proof.
 intros a b c Ha Hb (c',Hc). exists c'.
 now rewrite <- divide_div_mul_exact, Hc.
Qed.

Lemma lcm_least : forall a b c,
 (a | c) -> (b | c) -> (lcm a b | c).
Proof.
 intros a b c Ha Hb. unfold lcm.
 destruct (eq_decidable (gcd a b) 0) as [EQ|NEQ].
 apply gcd_eq_0 in EQ. destruct EQ as (EQ,EQ'). rewrite EQ in *. now nzsimpl.
 assert (Ga := gcd_divide_l a b).
 assert (Gb := gcd_divide_r a b).
 set (g:=gcd a b) in *.
 assert (Ha' := divide_div g a c NEQ Ga Ha).
 assert (Hb' := divide_div g b c NEQ Gb Hb).
 destruct Ha' as (a',Ha'). rewrite Ha', mul_comm in Hb'.
 apply gauss in Hb'; [|apply gcd_div_gcd; unfold g; trivial using gcd_comm].
 destruct Hb' as (b',Hb').
 exists b'.
 rewrite mul_shuffle3, <- Hb'.
 rewrite (proj2 (div_exact c g NEQ)).
 rewrite Ha', mul_shuffle3, (mul_comm a a'). f_equiv.
 symmetry. apply div_exact; trivial.
 apply mod_divide; trivial.
 apply mod_divide; trivial. transitivity a; trivial.
Qed.

Lemma lcm_comm : forall a b, lcm a b == lcm b a.
Proof.
 intros a b. unfold lcm. rewrite (gcd_comm b), (mul_comm b).
 now rewrite <- gcd_div_swap.
Qed.

Lemma lcm_divide_iff : forall n m p,
  (lcm n m | p) <-> (n | p) /\ (m | p).
Proof.
 intros. split. split.
 transitivity (lcm n m); trivial using divide_lcm_l.
 transitivity (lcm n m); trivial using divide_lcm_r.
 intros (H,H'). now apply lcm_least.
Qed.

Lemma lcm_unique : forall n m p,
 0<=p -> (n|p) -> (m|p) ->
 (forall q, (n|q) -> (m|q) -> (p|q)) ->
 lcm n m == p.
Proof.
 intros n m p Hp Hn Hm H.
 apply divide_antisym; trivial.
 now apply lcm_least.
 apply H. apply divide_lcm_l. apply divide_lcm_r.
Qed.

Lemma lcm_unique_alt : forall n m p, 0<=p ->
 (forall q, (p|q) <-> (n|q) /\ (m|q)) ->
 lcm n m == p.
Proof.
 intros n m p Hp H.
 apply lcm_unique; trivial.
 apply H, divide_refl.
 apply H, divide_refl.
 intros. apply H. now split.
Qed.

Lemma lcm_assoc : forall n m p, lcm n (lcm m p) == lcm (lcm n m) p.
Proof.
 intros. apply lcm_unique_alt. apply le_0_l.
 intros. now rewrite !lcm_divide_iff, and_assoc.
Qed.

Lemma lcm_0_l : forall n, lcm 0 n == 0.
Proof.
 intros. apply lcm_unique; trivial. order.
 apply divide_refl.
 apply divide_0_r.
Qed.

Lemma lcm_0_r : forall n, lcm n 0 == 0.
Proof.
 intros. now rewrite lcm_comm, lcm_0_l.
Qed.

Lemma lcm_1_l : forall n, lcm 1 n == n.
Proof.
 intros. apply lcm_unique; trivial using divide_1_l, le_0_l, divide_refl.
Qed.

Lemma lcm_1_r : forall n, lcm n 1 == n.
Proof.
 intros. now rewrite lcm_comm, lcm_1_l.
Qed.

Lemma lcm_diag : forall n, lcm n n == n.
Proof.
 intros. apply lcm_unique; trivial using divide_refl, le_0_l.
Qed.

Lemma lcm_eq_0 : forall n m, lcm n m == 0 <-> n == 0 \/ m == 0.
Proof.
 intros. split.
 intros EQ.
 apply eq_mul_0.
 apply divide_0_l. rewrite <- EQ. apply lcm_least.
  apply divide_factor_l. apply divide_factor_r.
 destruct 1 as [EQ|EQ]; rewrite EQ. apply lcm_0_l. apply lcm_0_r.
Qed.

Lemma divide_lcm_eq_r : forall n m, (n|m) -> lcm n m == m.
Proof.
 intros n m H. apply lcm_unique_alt; trivial using le_0_l.
 intros q. split. split; trivial. now transitivity m.
 now destruct 1.
Qed.

Lemma divide_lcm_iff : forall n m, (n|m) <-> lcm n m == m.
Proof.
 intros n m. split. now apply divide_lcm_eq_r.
 intros EQ. rewrite <- EQ. apply divide_lcm_l.
Qed.

Lemma lcm_mul_mono_l :
  forall n m p, lcm (p * n) (p * m) == p * lcm n m.
Proof.
 intros n m p.
 destruct (eq_decidable p 0) as [Hp|Hp].
  rewrite Hp. nzsimpl. rewrite lcm_0_l. now nzsimpl.
 destruct (eq_decidable (gcd n m) 0) as [Hg|Hg].
  apply gcd_eq_0 in Hg. destruct Hg as (Hn,Hm); rewrite Hn, Hm.
  nzsimpl. rewrite lcm_0_l. now nzsimpl.
 unfold lcm.
 rewrite gcd_mul_mono_l.
 rewrite mul_assoc. f_equiv.
 now rewrite div_mul_cancel_l.
Qed.

Lemma lcm_mul_mono_r :
 forall n m p, lcm (n * p) (m * p) == lcm n m * p.
Proof.
 intros n m p. now rewrite !(mul_comm _ p), lcm_mul_mono_l, mul_comm.
Qed.

Lemma gcd_1_lcm_mul : forall n m, n~=0 -> m~=0 ->
 (gcd n m == 1 <-> lcm n m == n*m).
Proof.
 intros n m Hn Hm. split; intros H.
 unfold lcm. rewrite H. now rewrite div_1_r.
 unfold lcm in *.
 apply mul_cancel_l in H; trivial.
 assert (Hg : gcd n m ~= 0) by (red; rewrite gcd_eq_0; destruct 1; order).
 assert (H' := gcd_divide_r n m).
 apply mod_divide in H'; trivial. apply div_exact in H'; trivial.
 rewrite H in H'.
 rewrite <- (mul_1_l m) in H' at 1.
 now apply mul_cancel_r in H'.
Qed.

End NLcmProp.


From QuickChick Require Import QuickChick.
Inductive natural : Type := Succ : natural -> natural |  Zero : natural.
Derive Show for natural. Derive Arbitrary for natural.  Instance Dec_Eq_natural : Dec_Eq natural. Proof. dec_eq. Qed.
Inductive lst : Type := Cons : natural -> lst -> lst |  Nil : lst.

Inductive tree : Type := Node : natural -> tree -> tree -> tree |  Leaf : tree.

Inductive Pair : Type := mkpair : natural -> natural -> 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 len (len_arg0 : lst) : natural
           := match len_arg0 with
              | Nil => Zero
              | Cons x y => Succ (len y)
              end.

Fixpoint rotate (rotate_arg0 : natural) (rotate_arg1 : lst) : lst
           := match rotate_arg0, rotate_arg1 with
              | Zero, x => x
              | Succ n, Nil => Nil
              | Succ n, Cons y x => rotate n (append x (Cons y Nil))
              end.

Lemma append_assoc: forall l1 l2 l3,
  append l1 (append l2 l3) = append (append l1 l2) l3.
Proof.
induction l1.
  - simpl. intros. rewrite IHl1. reflexivity.
  - reflexivity.
Qed.

Lemma lem3: forall l, append l Nil = l.
Proof.
induction l.
  - simpl. rewrite IHl. reflexivity.
  - reflexivity.
Qed.

Theorem theorem0 : forall (x : lst) (y : lst), eq (rotate (len x) (append x y)) (append y x).
Proof.
induction x.
- intros. simpl.
  rewrite <- append_assoc. rewrite IHx.
  rewrite <- append_assoc. reflexivity.
- intros. simpl. rewrite lem3. reflexivity.
Qed.


Theorem ch3 :
forall P Q I O : Prop,
  (P -> I) ->
  (Q -> O) ->
  ((I /\ O) -> False) ->
  P ->
  ~Q.
(*

前提

  P:詠彦くんは午前六時にイリナちゃんと館内にいた。
  Q:周防さんが午前六時にイリナちゃんが館外を歩くのを見た。
  I:イリナちゃんは午前六時に館内にいた。
  O:イリナちゃんは午前六時に館外にいた。

  P -> I:
    詠彦くんは午前六時にイリナちゃんと館内にいた　ならば
    イリナちゃんは午前六時に館内にいた。

  Q -> Q
    周防さんが午前六時にイリナちゃんが館外を歩くのを見た　ならば
    イリナちゃんは午前六時に館外にいた。

  (I /\ O) -> False:
    イリナちゃんは午前六時に館内にいた　かつ　イリナちゃんは午前六時に館外にいた　ならば
    矛盾である。

  P:
    詠彦くんは午前六時にイリナちゃんと館内にいた。

結論

  ~Q:周防さんの証言が偽だった。

*)
Proof.
  intros P Q I O A1 A2 A3 A4.
  intro.
  apply A3.
  split.
  -
    apply A1.
    apply A4.
  -
    apply A2.
    apply H.
Qed.

From mathcomp
Require Import ssreflect.

Theorem ch3_ssr :
forall P Q I O : Prop,
  (P -> I) ->
  (Q -> O) ->
  ((I /\ O) -> False) ->
  P ->
  ~Q.
Proof.
  move=> P Q I O A1 A2 A3 A4.
  rewrite /not.
  move=> Q_is_true.
  apply: A3.
  split.
  -
    apply: A1.
    done.
  -
    apply: A2.
    done.
Qed.


Require Export study04.
Require Export study01. (*ないと何故かble_natを認識しない*)

Module st05.

Definition plus_fact : Prop := 2 + 2 = 4.
Check plus_fact.
Theorem plus_fact_is_true : plus_fact.
Proof. reflexivity. Qed.
Definition strange_prop : Prop :=
  (2+2=5)->(99+26=42).
Check ble_nat.
Definition strange_prop2 : Prop :=
  forall n, (ble_nat n 17 = true) -> (ble_nat n 99 = true).
Definition even (n:nat) : Prop :=
  evenb n = true.
Check even.
Check even 2.
Check even 3.
Definition even_n__even_SSn (n:nat) : Prop :=
  (even n) -> (even (S (S n))).
Definition between (n m o: nat) : Prop :=
  andb (ble_nat n o) (ble_nat o m) = true.
Definition teen : nat->Prop := between 13 19.
Definition true_for_zero (P:nat->Prop) : Prop :=
  P 0.
Definition true_for_n__true_for_Sn (P:nat->Prop) (n:nat) : Prop :=
  P n -> P (S n).
Definition preserved_by_S (P:nat->Prop) : Prop :=
  forall n', P n' -> P (S n').
Definition true_for_all_numbers (P:nat->Prop) : Prop :=
  forall n, P n.
Definition our_nat_induction (P:nat->Prop) : Prop :=
     (true_for_zero P) ->
     (preserved_by_S P) ->
     (true_for_all_numbers P).

Inductive good_day : day -> Prop :=
  | gd_sat : good_day saturday
  | gd_sun : good_day sunday.
Theorem gds : good_day sunday.
Proof. apply gd_sun. Qed.
Inductive day_before : day -> day -> Prop :=
  | db_tue : day_before tuesday monday
  | db_wed : day_before wednesday tuesday
  | db_thu : day_before thursday wednesday
  | db_fri : day_before friday thursday
  | db_sat : day_before saturday friday
  | db_sun : day_before sunday saturday
  | db_mon : day_before monday sunday.
Inductive fine_day_for_singing : day -> Prop :=
  | fdfs_any : forall d:day, fine_day_for_singing d.
Theorem fdfs_wed : fine_day_for_singing wednesday.
Proof. apply fdfs_any. Qed.

Definition fdfs_wed' : fine_day_for_singing wednesday :=
  fdfs_any wednesday.
Check fdfs_wed.
Check fdfs_wed'.
Check fdfs_any.
Check fdfs_any wednesday.
Check fine_day_for_singing wednesday.
(* "OK"な日とは(1)良い日であるか(2)OKな日の前日である*)
Inductive ok_day : day -> Prop :=
  | okd_gd : forall d,
      good_day d ->
      ok_day d
  | okd_before : forall d1 d2,
      ok_day d2 ->
      day_before d2 d1 ->
      ok_day d1.
Definition okdw : ok_day wednesday :=
  okd_before wednesday thursday
    (okd_before thursday friday
       (okd_before friday saturday
         (okd_gd saturday gd_sat)
         db_sat)
       db_fri)
    db_thu.
Theorem okdw' : ok_day wednesday.
Proof.
  apply okd_before with (d2:=thursday).
    apply okd_before with (d2:=friday).
      apply okd_before with (d2:=saturday).
          apply okd_gd. apply gd_sat.
          apply db_sat.
      apply db_fri.
  apply db_thu.
Qed.
Print okdw'.

Definition okd_before2 := forall d1 d2 d3,
  ok_day d3 ->
  day_before d2 d1 ->
  day_before d3 d2 ->
  ok_day d1.
Theorem okd_before2_valid : okd_before2.
Proof.
  unfold okd_before2.
  intros d1 d2 d3 H1 H2 H3.
  apply okd_before with (d2:=d2).
  apply okd_before with (d2:=d3).
  apply H1. apply H3. apply H2.
Qed.
Print okd_before2_valid.

Check nat_ind.

Inductive yesno : Type :=
  | yes : yesno
  | no : yesno.

Check yesno_ind.

Inductive rgb : Type :=
  | red : rgb
  | green : rgb
  | blue : rgb.
Check rgb_ind.

Inductive natlist : Type :=
  | nnil : natlist
  | ncons : nat -> natlist -> natlist.

Check natlist_ind.

Inductive natlist1 : Type :=
  | nnil1 : natlist1
  | nsnoc1 : natlist1 -> nat -> natlist1.

Check natlist1_ind.

Inductive ExSet : Type :=
  | con1 : bool -> ExSet
  | con2 : nat -> ExSet -> ExSet.

Check ExSet_ind.

Inductive list (X:Type) : Type :=
  | nil : list X
  | cons : X -> list X -> list X.

Check list_ind.

Inductive tree (X:Type) : Type :=
  | leaf : X -> tree X
  | node : tree X -> tree X -> tree X.

Check tree_ind.

Inductive mytype (X:Type) : Type :=
  | constr1 : X -> mytype X
  | constr2 : nat -> mytype X
  | constr3 : mytype X -> nat -> mytype X.

Check mytype_ind.

Inductive foo (X Y:Type) : Type :=
  | bar : X -> foo X Y
  | baz : Y -> foo X Y
  | quux : (nat -> foo X Y) -> foo X Y.

Check foo_ind.

Inductive foo' (X:Type) : Type :=
  | C1 : list X -> foo' X -> foo' X
  | C2 : foo' X.

Check foo'_ind.

Definition P_m0r (n:nat) : Prop :=
  n * 0 = 0.
Definition P_m0r' : nat -> Prop :=
  fun n => n * 0 = 0.

Theorem mult_0_r'' : forall n:nat,
  P_m0r n.
Proof.
  apply nat_ind. reflexivity.
  unfold P_m0r. simpl. intros n' IHn'.
  apply IHn'.
Qed.

Inductive ev : nat -> Prop :=
  | ev_o : ev 0
  | ev_SS : forall n:nat, ev n -> ev (S (S n)).

Theorem four_ev' : ev 4.
Proof.
  apply ev_SS. apply ev_SS. apply ev_o.
Qed.
Print four_ev'.
Definition four_ev : ev 4 :=
  ev_SS 2 (ev_SS 0 ev_o).

Theorem ev_plus4' : forall n, ev n -> ev (4 + n).
Proof.
  intros n H. apply ev_SS. apply ev_SS.
  apply H.
Qed.
Print ev_plus4'.
Definition ev_plus4 : forall n, ev n -> ev (4 + n) :=
  fun (n : nat) (H : ev n) => ev_SS (S (S n))
  (ev_SS n H).

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

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

Theorem ev_even : forall n,
  ev n -> even n.
Proof.
  intros n E. induction E as [| n' E'].
  unfold even. reflexivity.
  unfold even. unfold even in IHE'.
  simpl. apply IHE'.
Qed.

Theorem ev_sum : forall n m,
  ev n -> ev m -> ev (n+m).
Proof.
  intros n m En Em.
  induction En.
  apply Em.
  simpl. apply ev_SS.
  apply IHEn.
Qed.

Theorem SSev_evn : forall n,
  ev (S (S n)) -> ev n.
Proof.
  intros n E.
  inversion E.
  apply H0.
Qed.
(* I が現在のコンテキストにおいて帰納的に宣言された仮定 P を
参照しているとします。 ここで、inversion I は、Pの
コンストラクタごとにサブゴールを生成します。
各サブゴールにおいて、 コンストラクタが P を証明するのに
必要な条件によって I が置き換えられます。 サブゴールのうち
いくつかは矛盾が存在するので、 inversion はそれらを除外します。
残っているのは、元のゴールが成り立つことを示すのに必要なサブゴールです。*)

Theorem SSSSev_even : forall n,
  ev (S (S (S (S n)))) -> ev n.
Proof.
  intros n E.
  inversion E.
  inversion H0.
  apply H2.
Qed.

Theorem even5_nonsense :
  ev 5 -> 2 + 2 = 9.
Proof.
  intros E.
  inversion E.
  inversion H0.
  inversion H2.
Qed.

Theorem ev_minus2' : forall n,
  ev n -> ev (pred (pred n)).
Proof.
  intros n E.
  inversion E.
  simpl. rewrite <- H in E.
  apply E.
  simpl. apply H.
Qed.

Theorem ev_ev_even : forall n m,
  ev (n+m) -> ev n -> ev m.
Proof.
  intros n m Enm En.
  induction En.
  simpl in Enm. apply Enm.
  apply IHEn. simpl in Enm.
  inversion Enm. apply H0.
Qed.
(*Enm についての帰納法はダメ*)

Theorem ev_plus_plus : forall n m p,
  ev (n+m) -> ev (n+p) -> ev (m+p).
Proof.
  intros n m p E1 E2.
  assert (H1:ev((n+n)+(m+p))).
  replace ((n+n)+(m+p)) with ((n+m)+(n+p)).
  apply ev_sum with (n:=n+m) (m:=n+p).
  apply E1. apply E2.
  replace (n+m+(n+p)) with (n+(m+n)+p).
  replace (m+n) with (n+m).
  rewrite plus_assoc. rewrite plus_assoc.
  reflexivity.
  rewrite plus_comm. reflexivity.
  rewrite plus_assoc. rewrite plus_assoc.
  reflexivity.
  apply ev_ev_even with (n:=n+n)(m:=m+p) in H1.
  apply H1.
  rewrite <- double_plus.
  apply double_even.
Qed.

Inductive MyProp : nat -> Prop :=
  | MyProp1 : MyProp 4
  | MyProp2 : forall n:nat, MyProp n -> MyProp (4 + n)
  | MyProp3 : forall n:nat, MyProp (2 + n) -> MyProp n.

Theorem MyProp_ten : MyProp 10.
Proof.
  apply MyProp3. simpl.
  apply MyProp2. apply MyProp2.
  apply MyProp1.
Qed.

Theorem MyProp_0 : MyProp 0.
Proof.
  apply MyProp3. apply MyProp3. apply MyProp1.
Qed.

Theorem MyProp_plustwo : forall n:nat, MyProp n
  -> MyProp (S (S n)).
Proof.
  intros n E. replace (S (S n)) with (2+n).
  apply MyProp3. apply MyProp2. apply E.
  reflexivity.
Qed.

Theorem MyProp_ev : forall n:nat,
  ev n -> MyProp n.
Proof.
  intros n E.
  induction E. apply MyProp_0.
  apply MyProp_plustwo. apply IHE.
Qed.

Theorem ev_MyProp : forall n:nat,
  MyProp n -> ev n.
Proof.
  intros n E.
  induction E.
  apply ev_SS. apply ev_SS. apply ev_o.
  apply ev_SS. apply ev_SS. apply IHE.
  apply ev_minus2 in IHE. simpl in IHE.
  apply IHE.
Qed.

About MyProp_ev.
Print MyProp_ev.
Locate plus_comm.


From mathcomp Require Import all_ssreflect.

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

----------------------------------------------------------
#
#
** The Coq proof assistant and the Mathematical Components library

Objective: learn the Coq system in the MC library

*** Roadmap

- #lesson 1#: Programs
  - #exercise# and #solution#

- #lesson 2#: Proofs
  - #exercise# and #solution#

- #lesson 3#: Boolean reflection
  - #exercise# and #solution#

- #lesson 4#: Libraries
  - #exercise# and #solution#

*** Teaching material

- Slides and exercises
  #https://www-sop.inria.fr/teams/marelle/types18/#
- Coq (#software#
  and #user manual#)
- Mathematical Components
  (#software# and
  #book#)

#
(notes)
#
You don't need to install Coq in order to follow this
class, you just need a recent browser thanks to
#jsCoq#.
#

#

#
#

----------------------------------------------------------
#
#
** Lesson 1: summary

- functions
- simple data
- containers
- symbolic computations
- higher order functions and mathematical notations

#
#

----------------------------------------------------------
#
#
** Functions

Functions are built using the [fun .. => ..] syntax.
The command [Check] verifies that a term is well typed.

#
#
*)
Check (fun n => 1 + n + 1).
(**
#
#

Notice that the type of [n] was inferred and that
the whole term has type [nat -> nat], where [->]
is the function space.

Function application is written by writing the function
on the left of the argument (eg, not as in the mathematical
practice).

#
#
*)
Check 2.
Check (fun n => 1 + n + 1) 2.
(**
#
#

Notice how [2] has a type that fits, and hence
the type of the function applied to [2] is [nat].

Terms (hence functions) can be given a name using
the [Definition] command. The command offers some
syntactic sugar for binding the function arguments.

#
#
*)
Definition f := (fun n => 1 + n + 1).
(* Definition f n := 1 + n + 1. *)
(* Definition f (n : nat) := 1 + n + 1. *)
(**
#
#

Named terms can be printed.

#
#
*)
Print f.
(**
#
#

Coq is able to compute with terms, in particular
one can obtain the normal form via the [Eval lazy in]
command.

#
#
*)
Eval lazy in f 2.
(**
#
#

Notice that "computation" is made of many steps.
In particular [f] has to be unfolded (delta step)
and then the variable substituted for the argument
(beta).

#
#
*)
Eval lazy delta [f] in f 2.
Eval lazy delta [f] beta in f 2.
(**
#
#

Nothing but functions (and their types) are built-in in Coq.
All the rest is defined, even [1], [2] and [+] are not primitive.

#

#

#
(notes)
#

This slide corresponds to
section 1.1 of
#the Mathematical Components book#
#

#

#
#

----------------------------------------------------------
#
#
** Data types

Data types can be declared using the [Inductive] command.

Many of them are already available in the Coq library called
[Prelude] that is automatically loaded. We hence just print
them.

[Inductive bool := true | false.]

#
#
*)
Print bool.
(**
#
#

This command declares a new type [bool] and declares
how the terms (in normal form) of this type are built.
Only [true] and [false] are canonical inhabitants of
[bool].

To use a boolean value Coq provides the [if..then..else..]
syntax.

#
#
*)
Definition twoVtree (b : bool) := if b then 2 else 3.
Eval lazy in twoVtree true.
Eval lazy delta in twoVtree true.
Eval lazy delta beta in twoVtree true.
Eval lazy delta beta iota in twoVtree true.
(**
#
#

We define a few boolean operators that will come in handy
later on.

#
#
*)
Definition andb (b1 b2 : bool) := if b1 then b2 else false.
Definition orb (b1 b2 : bool) := if b1 then true else b2.

Infix "&&" := andb.
Infix "||" := orb.

Check true && false || false.
(**
#
#

The [Infix] command lets one declare infix notations.
Precendence and associativity is already declared in the
prelude of Coq, here we just associate the constants
[andb] and [orb] to these notataions.

Natural numbers are defined similarly to booleans:

[Inductive nat := O | S (n : nat).]

#
#
*)
Print nat.
(**
#
#

Coq provides a special notation for literals, eg [3],
that is just sugar for [S (S (S O))].

The Mathematical Components library adds on top of that
the postfix [.+1], [.+2], .. for iterated applications
of [S] to terms other than [O].

#
#
*)
Check 3.
Check (fun x => (x + x).+2).
Eval lazy in (fun x => (x + x).+2) 1.
(**
#
#

In order to use natural numbers Coq provides two
tools. An extended [if..then..else..] syntax to
extract the argument of [S] and the [Fixpoint]
command to define recusrsive functions.

#
#
*)
Definition pred (n : nat) :=
  if n is p.+1 then p else 0.

Eval lazy in pred 7.
(**
#
#

Notice that [p] is a binder. When the [if..then..else..]
is evaluated, and [n] put in normal form, then if it
is [S t] the variable [p] takes [t] and the then-branch
is taken.

Now lets define addition using recursion

#
#
*)
Fixpoint addn n m :=
  if n is p.+1 then (addn p m).+1 else m.
Infix "+" := addn.
Eval lazy in 3 + 2.
(**
#
#

The [if..then..else..] syntax is just sugar for
[match..with..end].

#
#
*)
Print addn.
(**
#
#

Let's now write the equality test for natural numbers

#
#
*)
Fixpoint eqn n m :=
  match n, m with
  | 0, 0 => true
  | p.+1, q.+1 => eqn p q
  | _, _ => false
  end.
Infix "==" := eqn.
Eval lazy in 3 == 4.
(**
#
#

Other examples are subtraction and order

#
#
*)
Fixpoint subn m n : nat :=
  match m, n with
  | p.+1, q.+1 => subn p q
  | _ , _ => m
  end.

Infix "-" := subn.

Eval lazy in 3 - 2.
Eval lazy in 2 - 3. (* truncated *)

Definition leq m n := m - n == 0.

Infix "<=" := leq.

Eval lazy in 4 <= 5.
(**
#
#

#

#

#
(notes)
#

All the constants defined in this slide are already
defined in Coq's prelude or in Mathematical Components.
The main difference is that [==] is not specific to
[nat] but overloaded (it works for most data types).
This topic is to be developed in lesson 4.

This slide corresponds to
section 1.2 of
#the Mathematical Components book#
#

#

#
#

#
#

----------------------------------------------------------
#
#
** Containers

Containers let one aggregate data, for example to form a
pair or a list.  The interesting characteristic of containers
is that they are polymorphic: the same container can be used
to hold terms of many types.

[Inductive seq (A : Type) := nil | cons (hd : A) (tl : seq A).]

#
#
*)
Check nil.
Check cons 3 [::].
(**
#
#

We learn that [[::]] is a notation for the empty sequence
and that the type parameter [?A] is implicit.

#
#
*)
Check 1 :: nil.
Check [:: 3; 4; 5 ].
(**
#
#

The infix [::] notation stands for [cons]. This one is mostly
used to pattern match a sequence.

The notation [[:: .. ; .. ]] can be used to form sequences
by separating the elements with [;]. When there are no elements
what is left is [[::]] that is the empty seqeunce.

And of course we can use sequences with other data types

#
#
*)
Check [:: 3; 4; 5 ].
Check [:: true; false; true ].
(**
#
#

Let's now define the [size] function.

#
#
*)
Fixpoint size A (s : seq A) :=
  if s is _ :: tl then (size tl).+1 else 0.

Eval lazy in size [:: 1; 8; 34].
(**
#
#

Given that the contents of containers are of an
arbitrary type many common operations are parametrized
by functions that are specific to the type of the
contents.

[[
Fixpoint map A B (f : A -> B) s :=
if s is e :: tl then f e :: map f tl else nil.
]]

#
#
*)
Definition l := [:: 1; 2; 3].
Eval lazy in [seq x.+1 | x <- l].
(**
#
#

The #seq#
library of Mathematical Components contains many combinators. Their syntax
is documented in the header of the file.

#

#

#
(notes)
#

This slide corresponds to
section 1.3 of
#the Mathematical Components book#
#

#

#
#

----------------------------------------------------------
#
#
** Symbols

The section mecanism is used to describe a context under
which definitions are made. Coq lets us not only define
terms, but also compute with them in that context.

We use this mecanism to talk about symbolic computation.

#
#
*)
Section symbols.
Variables x : nat.

Eval lazy in pred x.+1 .
Eval lazy in pred x .
(**
#
#

Computation can take place in presence of variables
as long as constructors can be consumed. When no
more constructors are available computation is
stuck.

Let's not look at a very common higher order
function.

#
#
*)

Fixpoint foldr A T f (a : A) (s : seq T) :=
  if s is x :: xs then f x (foldr f a xs) else a.
(**
#
#

The best way to understand what [foldr] does
is to postulate a virable [f] and compute.

#
#
*)

Variable f : nat -> nat -> nat.

Eval lazy in foldr f    3 [:: 1; 2 ].

(**
#
#

If we plug [addn] in place of [f] we
obtain a term that evaluates to a number.

#
#
*)

Eval lazy in foldr addn 3 [:: 1; 2 ].

End symbols.

(**
#
#

#
(notes)
#

This slide corresponds to
sections 1.4 and 1.5 of
#the Mathematical Components book#
#

#

#
#

----------------------------------------------------------
#
#
** Higher order functions and mathematical notations

Let's try to write this formula in Coq

#$$ \sum_{i=1}^n (i * 2 - 1) = n ^ 2 $$#

We need a bit of infrastruture

#
#
*)
Fixpoint iota m n := if n is u.+1 then m :: iota m.+1 u else [::].

Eval lazy in iota 0 5.

(**
#
#

Combining [iota] and [foldr] we can get pretty
close to the LaTeX source for the formula above.

#
#
*)

Notation "\sum_ ( m <= i < n ) F" :=
  (foldr (fun i a => F + a) 0 (iota m (n-m))).

Check \sum_(1 <= x < 5) (x * 2 - 1).
Eval lazy in \sum_(1 <= x < 5) (x * 2 - 1).
(**
#
#

#

#

#
(notes)
#

This slide corresponds to
section 1.6 of
#the Mathematical Components book#
#

#

#
#

----------------------------------------------------------
#
#
** Lesson 1: sum up

- [fun .. => ..]
- [Check]
- [Definition]
- [Print]
- [Eval lazy]
- [Indcutive] declarations [bool], [nat], [seq].
- [match .. with .. end] and [if .. is .. then .. else ..]
- [Fixpoint]
- [andb] [orb] [eqn] [leq] [addn] [subn] [size] [foldr]

#
#

*)


(* summations on a ring-like (semiring, ring, field) *)

Set Nested Proofs Allowed.

Require Import Utf8 Arith.
Import List List.ListNotations.

Require Import Misc RingLike PermutationFun.

Notation "'∑' ( i = b , e ) , g" :=
  (iter_seq b e (λ c i, (c + g)%L) 0%L)
  (at level 45, i at level 0, b at level 60, e at level 60,
   right associativity,
   format "'[hv  ' ∑  ( i  =  b ,  e ) ,  '/' '[' g ']' ']'").

Notation "'∑' ( i ∈ l ) , g" :=
  (iter_list l (λ c i, (c + g)%L) 0%L)
  (at level 45, i at level 0, l at level 60,
   right associativity,
   format "'[hv  ' ∑  ( i  ∈  l ) ,  '/' '[' g ']' ']'").

Section a.

Context {T : Type}.
Context (ro : ring_like_op T).
Context {rp : ring_like_prop T}.
Context {Hom : rngl_has_opp_or_subt = true}.

Theorem fold_left_rngl_add_fun_from_0 : ∀ A a l (f : A → _),
  (fold_left (λ c i, c + f i) l a =
   a + fold_left (λ c i, c + f i) l 0)%L.
Proof.
intros.
apply fold_left_op_fun_from_d. {
  apply rngl_add_0_l.
} {
  apply rngl_add_0_r.
} {
  apply rngl_add_assoc.
}
Qed.

Theorem all_0_rngl_summation_list_0 : ∀ A l (f : A → T),
  (∀ i, i ∈ l → f i = 0%L)
  → ∑ (i ∈ l), f i = 0%L.
Proof.
intros * Hz.
apply iter_list_all_d; [ | | | easy ]. {
  apply rngl_add_0_l.
} {
  apply rngl_add_0_r.
} {
  apply rngl_add_assoc.
}
Qed.

Theorem all_0_rngl_summation_0 : ∀ b e f,
  (∀ i, b ≤ i ≤ e → f i = 0%L)
  → ∑ (i = b, e), f i = 0%L.
Proof.
intros * Hz.
apply iter_seq_all_d; [ | | | easy ]. {
  apply rngl_add_0_l.
} {
  apply rngl_add_0_r.
} {
  apply rngl_add_assoc.
}
Qed.

Theorem rngl_summation_list_split_first : ∀ A (l : list A) d f,
  l ≠ []
  → ∑ (i ∈ l), f i = (f (hd d l) + ∑ (i ∈ tl l), f i)%L.
Proof.
intros * Hlz.
apply iter_list_split_first; [ | | | easy ]. {
  apply rngl_add_0_l.
} {
  apply rngl_add_0_r.
} {
  apply rngl_add_assoc.
}
Qed.

Theorem rngl_summation_list_split_last : ∀ A (l : list A) d f,
  l ≠ []
  → ∑ (i ∈ l), f i = (∑ (i ∈ removelast l), f i + f (last l d))%L.
Proof.
intros * Hlz.
now apply iter_list_split_last.
Qed.

Theorem rngl_summation_list_split : ∀ A (l : list A) f n,
  ∑ (i ∈ l), f i = (∑ (i ∈ firstn n l), f i + ∑ (i ∈ skipn n l), f i)%L.
Proof.
intros.
rewrite <- firstn_skipn with (n := n) (l := l) at 1.
unfold iter_list.
rewrite fold_left_app.
now rewrite fold_left_rngl_add_fun_from_0.
Qed.

Theorem rngl_summation_split_first : ∀ b k g,
  b ≤ k
  → ∑ (i = b, k), g i = (g b + ∑ (i = S b, k), g i)%L.
Proof.
intros * Hbk.
apply iter_seq_split_first; [ | | | easy ]. {
  apply rngl_add_0_l.
} {
  apply rngl_add_0_r.
} {
  apply rngl_add_assoc.
}
Qed.

Theorem rngl_summation_split_last : ∀ b k g,
  b ≤ k
  → (∑ (i = b, k), g i = ∑ (i = S b, k), g (i - 1)%nat + g k)%L.
Proof.
intros * Hbk.
now apply iter_seq_split_last.
Qed.

Theorem rngl_summation_split : ∀ j g b k,
  b ≤ S j ≤ S k
  → (∑ (i = b, k), g i = ∑ (i = b, j), g i + ∑ (i = j+1, k), g i)%L.
Proof.
intros * Hbjk.
apply iter_seq_split; [ | | | easy ]. {
  apply rngl_add_0_l.
} {
  apply rngl_add_0_r.
} {
  apply rngl_add_assoc.
}
Qed.

Theorem rngl_summation_split3 : ∀ j g b k,
  b ≤ j ≤ k
  → ∑ (i = b, k), g i =
       (∑ (i = S b, j), g (i - 1)%nat + g j + ∑ (i = j + 1, k), g i)%L.
Proof.
intros * Hj.
apply iter_seq_split3; [ | | | easy ]. {
  apply rngl_add_0_l.
} {
  apply rngl_add_0_r.
} {
  apply rngl_add_assoc.
}
Qed.

Theorem rngl_summation_eq_compat : ∀ g h b k,
  (∀ i, b ≤ i ≤ k → (g i = h i)%L)
  → (∑ (i = b, k), g i = ∑ (i = b, k), h i)%L.
Proof.
intros * Hgh.
now apply iter_seq_eq_compat.
Qed.

Theorem rngl_summation_list_eq_compat : ∀ A g h (l : list A),
  (∀ i, i ∈ l → (g i = h i)%L)
  → (∑ (i ∈ l), g i = ∑ (i ∈ l), h i)%L.
Proof.
intros * Hgh.
now apply iter_list_eq_compat.
Qed.

Theorem rngl_summation_succ_succ : ∀ b k g,
  (∑ (i = S b, S k), g i = ∑ (i = b, k), g (S i))%L.
Proof.
intros b k g.
apply iter_seq_succ_succ.
Qed.

Theorem rngl_summation_list_empty : ∀ A g (l : list A),
  l = [] → ∑ (i ∈ l), g i = 0%L.
Proof.
intros * Hl.
now apply iter_list_empty.
Qed.

Theorem rngl_summation_empty : ∀ g b k,
  k < b → (∑ (i = b, k), g i = 0)%L.
Proof.
intros * Hkb.
now apply iter_seq_empty.
Qed.

Theorem rngl_summation_list_add_distr :
  ∀ A g h (l : list A),
  (∑ (i ∈ l), (g i + h i) =
  (∑ (i ∈ l), g i) + ∑ (i ∈ l), h i)%L.
Proof.
intros Hic *.
apply iter_list_distr. {
  apply rngl_add_0_l.
} {
  apply rngl_add_comm.
} {
  apply rngl_add_assoc.
}
Qed.

Theorem rngl_summation_add_distr : ∀ g h b k,
  (∑ (i = b, k), (g i + h i) =
   ∑ (i = b, k), g i + ∑ (i = b, k), h i)%L.
Proof.
intros g h b k.
apply iter_seq_distr. {
  apply rngl_add_0_l.
} {
  apply rngl_add_comm.
} {
  apply rngl_add_assoc.
}
Qed.

Theorem rngl_summation_shift : ∀ s b g k,
  s ≤ b ≤ k
  → ∑ (i = b, k), g i = ∑ (i = b - s, k - s), g (s + i)%nat.
Proof.
intros s b g k Hbk.
now apply (iter_shift s).
Qed.

Theorem rngl_summation_rshift : ∀ b e f,
  ∑ (i = b, e), f i = ∑ (i = S b, S e), f (i - 1)%nat.
Proof.
intros.
rewrite rngl_summation_succ_succ.
apply rngl_summation_eq_compat.
intros i Hi.
now rewrite Nat_sub_succ_1.
Qed.

Theorem rngl_opp_summation :
  rngl_has_opp = true →
  ∀ b e f, ((- ∑ (i = b, e), f i) = ∑ (i = b, e), (- f i))%L.
Proof.
intros Hro *.
apply iter_seq_inv. {
  now apply rngl_opp_0.
} {
  intros.
  rewrite fold_rngl_sub; [ | easy ].
  rewrite rngl_add_comm.
  now apply rngl_opp_add_distr.
}
Qed.

Theorem rngl_summation_rtl : ∀ g b k,
  (∑ (i = b, k), g i = ∑ (i = b, k), g (k + b - i)%nat)%L.
Proof.
intros g b k.
apply iter_seq_rtl. {
  apply rngl_add_0_l.
} {
  apply rngl_add_0_r.
} {
  apply rngl_add_comm.
} {
  apply rngl_add_assoc.
}
Qed.

Theorem mul_iter_list_distr_l : ∀ A B a (la : list B) f
    (add mul : A → A → A) d
    (mul_add_distr_l : ∀ y z, mul a (add y z) = add (mul a y) (mul a z)),
  mul a (iter_list la (λ c i, add c (f i)) d) =
  iter_list la (λ c i, add c (mul a (f i))) (mul a d).
Proof.
intros.
clear Hom.
unfold iter_list.
revert d.
induction la as [| a1]; intros; [ easy | cbn ].
rewrite IHla.
f_equal.
apply mul_add_distr_l.
Qed.

Theorem mul_iter_list_distr_r : ∀ A B a (la : list B) f
    (add mul : A → A → A) d
    (mul_add_distr_r : ∀ y z, mul (add y z) a = add (mul y a) (mul z a)),
  mul (iter_list la (λ c i, add c (f i)) d) a =
  iter_list la (λ c i, add c (mul (f i) a)) (mul d a).
Proof.
intros.
clear Hom.
unfold iter_list.
revert d.
induction la as [| a1]; intros; [ easy | cbn ].
rewrite IHla.
f_equal.
apply mul_add_distr_r.
Qed.

Theorem rngl_mul_summation_list_distr_l : ∀ A a (la : list A) f,
  (a * (∑ (i ∈ la), f i) = ∑ (i ∈ la), a * f i)%L.
Proof.
intros.
rewrite mul_iter_list_distr_l; [ | apply rngl_mul_add_distr_l ].
now rewrite rngl_mul_0_r.
Qed.

Theorem rngl_mul_summation_distr_l : ∀ a b e f,
  (a * (∑ (i = b, e), f i) = ∑ (i = b, e), a * f i)%L.
Proof.
intros.
apply rngl_mul_summation_list_distr_l.
Qed.

Theorem rngl_mul_summation_list_distr_r : ∀ A a (la : list A) f,
  ((∑ (i ∈ la), f i) * a = ∑ (i ∈ la), f i * a)%L.
Proof.
intros.
rewrite mul_iter_list_distr_r; [ | intros; apply rngl_mul_add_distr_r ].
now rewrite rngl_mul_0_l.
Qed.

Theorem rngl_mul_summation_distr_r : ∀ a b e f,
  ((∑ (i = b, e), f i) * a = ∑ (i = b, e), f i * a)%L.
Proof.
intros.
apply rngl_mul_summation_list_distr_r.
Qed.

Theorem rngl_summation_list_only_one : ∀ A g (a : A),
  (∑ (i ∈ [a]), g i = g a)%L.
Proof.
intros.
unfold iter_list; cbn.
apply rngl_add_0_l.
Qed.

Theorem rngl_summation_only_one : ∀ g n, ∑ (i = n, n), g i = g n.
Proof.
intros g n.
apply iter_seq_only_one, rngl_add_0_l.
Qed.

Theorem rngl_summation_list_cons : ∀ A (a : A) la f,
  (∑ (i ∈ a :: la), f i = f a + ∑ (i ∈ la), f i)%L.
Proof.
intros.
apply iter_list_cons. {
  apply rngl_add_0_l.
} {
  apply rngl_add_0_r.
} {
  apply rngl_add_assoc.
}
Qed.

Theorem rngl_summation_list_app : ∀ A (la lb : list A) f,
  ∑ (i ∈ la ++ lb), f i = (∑ (i ∈ la), f i + ∑ (i ∈ lb), f i)%L.
Proof.
intros.
rewrite iter_list_app.
unfold iter_list.
apply fold_left_rngl_add_fun_from_0.
Qed.

Theorem rngl_summation_list_concat : ∀ A (ll : list (list A)) (f : A → T),
  ∑ (a ∈ concat ll), f a = ∑ (l ∈ ll), ∑ (a ∈ l), f a.
Proof.
intros.
induction ll as [| l]; cbn. {
  rewrite rngl_summation_list_empty; [ | easy ].
  now rewrite rngl_summation_list_empty.
}
rewrite rngl_summation_list_app.
rewrite rngl_summation_list_cons.
f_equal.
apply IHll.
Qed.

Theorem rngl_summation_summation_list_flat_map : ∀ A B la (f : A → list B) g,
  (∑ (a ∈ la), ∑ (b ∈ f a), g b) = ∑ (b ∈ flat_map f la), g b.
Proof.
intros.
induction la as [| a]; cbn. {
  now apply rngl_summation_list_empty.
}
rewrite rngl_summation_list_cons.
rewrite rngl_summation_list_app.
f_equal; apply IHla.
Qed.

Theorem rngl_summation_summation_list_swap : ∀ A B la lb (f : A → B → T),
  ∑ (a ∈ la), (∑ (b ∈ lb), f a b) =
  ∑ (b ∈ lb), (∑ (a ∈ la), f a b).
Proof.
intros.
induction la as [| a]. {
  rewrite rngl_summation_list_empty; [ | easy ].
  erewrite rngl_summation_list_eq_compat. 2: {
    intros b Hb.
    now rewrite rngl_summation_list_empty.
  }
  now rewrite all_0_rngl_summation_list_0.
}
rewrite rngl_summation_list_cons.
symmetry.
erewrite rngl_summation_list_eq_compat. 2: {
  intros b Hb.
  now rewrite rngl_summation_list_cons.
}
cbn.
rewrite rngl_summation_list_add_distr.
now f_equal.
Qed.

Theorem rngl_summation_summation_exch : ∀ g k,
  (∑ (j = 0, k), (∑ (i = 0, j), g i j) =
   ∑ (i = 0, k), ∑ (j = i, k), g i j)%L.
Proof.
intros g k.
induction k; [ easy | ].
rewrite rngl_summation_split_last; [ | easy ].
rewrite rngl_summation_succ_succ.
erewrite rngl_summation_eq_compat. 2: {
  intros i Hi.
  now rewrite Nat_sub_succ_1.
}
cbn.
rewrite IHk.
symmetry.
rewrite rngl_summation_split_last; [ | easy ].
rewrite rngl_summation_succ_succ.
erewrite rngl_summation_eq_compat. 2: {
  intros i Hi.
  now rewrite Nat_sub_succ_1.
}
cbn.
erewrite rngl_summation_eq_compat. 2: {
  intros i Hi.
  rewrite rngl_summation_split_last; [ | flia Hi ].
  rewrite rngl_summation_succ_succ.
  erewrite rngl_summation_eq_compat. 2: {
    intros j Hj.
    now rewrite Nat_sub_succ_1.
  }
  easy.
}
cbn.
rewrite rngl_summation_add_distr.
rewrite <- rngl_add_assoc.
f_equal.
symmetry.
rewrite rngl_summation_split_last; [ | easy ].
rewrite rngl_summation_succ_succ.
rewrite rngl_summation_only_one.
f_equal.
apply rngl_summation_eq_compat.
intros i Hi.
now rewrite Nat_sub_succ_1.
Qed.

Theorem fold_left_add_seq_add : ∀ b len i g,
  fold_left (λ (c : T) (j : nat), (c + g i j)%L)
    (seq (b + i) len) 0%L =
  fold_left (λ (c : T) (j : nat), (c + g i (i + j)%nat)%L)
    (seq b len) 0%L.
Proof.
intros.
revert b i.
induction len; intros; [ easy | cbn ].
do 2 rewrite rngl_add_0_l.
rewrite fold_left_rngl_add_fun_from_0; symmetry.
rewrite fold_left_rngl_add_fun_from_0; symmetry.
f_equal; [ now rewrite Nat.add_comm | ].
now rewrite <- IHlen.
Qed.

Theorem rngl_summation_summation_shift : ∀ g k,
  (∑ (i = 0, k), (∑ (j = i, k), g i j) =
   ∑ (i = 0, k), ∑ (j = 0, k - i), g i (i + j)%nat)%L.
Proof.
intros g k.
apply rngl_summation_eq_compat; intros i Hi.
unfold iter_seq, iter_list.
rewrite Nat.sub_0_r.
rewrite Nat.sub_succ_l; [ | now destruct Hi ].
now rewrite <- fold_left_add_seq_add, Nat.add_0_l.
Qed.

Theorem rngl_summation_ub_add_distr : ∀ a b f,
  (∑ (i = 0, a + b), f i)%L = (∑ (i = 0, a), f i + ∑ (i = S a, a + b), f i)%L.
Proof.
intros.
rewrite (rngl_summation_split a); [ | flia ].
now rewrite Nat.add_1_r.
Qed.

Theorem rngl_summation_summation_distr : ∀ a b f,
  (∑ (i = 0, a), ∑ (j = 0, b), f i j)%L =
  (∑ (i = 0, (S a * S b - 1)%nat), f (i / S b)%nat (i mod S b))%L.
Proof.
intros.
revert b.
induction a; intros. {
  unfold iter_seq at 1, iter_list at 1.
  cbn - [ "mod" "/" ].
  rewrite rngl_add_0_l, Nat.add_sub.
  apply rngl_summation_eq_compat.
  intros i Hi.
  rewrite Nat.div_small; [ | flia Hi ].
  rewrite Nat.mod_small; [ easy | flia Hi ].
}
rewrite rngl_summation_split_last; [ | easy ].
rewrite rngl_summation_succ_succ.
erewrite rngl_summation_eq_compat. 2: {
  intros i Hi.
  erewrite rngl_summation_eq_compat. 2: {
    intros j Hj.
    now rewrite Nat_sub_succ_1.
  }
  easy.
}
remember (S a) as x.
cbn - [ "mod" "/" ]; subst x.
rewrite IHa.
rewrite Nat.sub_0_r.
rewrite (Nat.add_comm b).
rewrite rngl_summation_ub_add_distr.
rewrite (rngl_summation_split_last _ (S a * S b)); [ | cbn; flia ].
symmetry.
rewrite (rngl_summation_shift 1); [ | cbn; flia ].
symmetry.
rewrite Nat.sub_diag.
rewrite <- rngl_add_assoc.
f_equal. {
  apply rngl_summation_eq_compat.
  intros i Hi.
  now rewrite (Nat.add_comm 1 i), Nat.add_sub.
} {
  rewrite Nat.div_mul; [ | easy ].
  rewrite Nat.mod_mul; [ | easy ].
  destruct b. {
    unfold iter_seq at 1, iter_list at 1.
    cbn - [ "mod" "/" ].
    rewrite rngl_add_0_l.
    rewrite rngl_summation_empty; [ | flia ].
    now rewrite rngl_add_0_r.
  }
  symmetry.
  rewrite (rngl_summation_shift (S (S a * S (S b)))); [ | flia ].
  symmetry.
  rewrite Nat.sub_diag.
  replace (S a * S (S b) + S b - S (S a * S (S b))) with b. 2: {
    cbn.
    rewrite <- Nat.add_succ_l.
    rewrite Nat.sub_add_distr.
    now do 2 rewrite Nat.add_sub.
  }
  rewrite rngl_summation_split_first; [ | easy ].
  f_equal.
  rewrite rngl_summation_succ_succ.
  apply rngl_summation_eq_compat.
  intros i Hi.
  rewrite Nat.add_succ_comm.
  rewrite Nat.div_add_l; [ | easy ].
  rewrite (Nat.div_small (S i)); [ | flia Hi ].
  f_equal; [ symmetry; apply Nat.add_0_r | ].
  rewrite Nat_mod_add_l_mul_r; [ | easy ].
  symmetry.
  apply Nat.mod_small; flia Hi.
}
Qed.

Theorem rngl_summation_list_permut : ∀ A (eqb : A → _),
  equality eqb →
  ∀ (la lb : list A) f,
  permutation eqb la lb
  → (∑ (i ∈ la), f i = ∑ (i ∈ lb), f i)%L.
Proof.
intros * Heqb * Hl.
apply (iter_list_permut Heqb); [ | | | | easy ]. {
  apply rngl_add_0_l.
} {
  apply rngl_add_0_r.
} {
  apply rngl_add_comm.
} {
  apply rngl_add_assoc.
}
Qed.

Theorem rngl_summation_seq_summation : ∀ b len f,
  len ≠ 0
  → (∑ (i ∈ seq b len), f i = ∑ (i = b, b + len - 1), f i)%L.
Proof.
intros * Hlen.
now apply iter_list_seq.
Qed.

Theorem rngl_summation_list_mul_summation_list :
  ∀ A B li lj (f : A → T) (g : B → T),
  ((∑ (i ∈ li), f i) * (∑ (j ∈ lj), g j))%L =
  ∑ (i ∈ li), (∑ (j ∈ lj), f i * g j).
Proof.
intros.
induction li as [| ai]. {
  rewrite rngl_summation_list_empty; [ symmetry | easy ].
  rewrite rngl_summation_list_empty; [ symmetry | easy ].
  now apply rngl_mul_0_l.
}
do 2 rewrite rngl_summation_list_cons.
rewrite rngl_mul_add_distr_r.
rewrite IHli.
now rewrite rngl_mul_summation_list_distr_l.
Qed.

Theorem rngl_summation_mul_summation : ∀ bi bj ei ej f g,
  ((∑ (i = bi, ei), f i) * (∑ (j = bj, ej), g j))%L =
  ∑ (i = bi, ei), (∑ (j = bj, ej), f i * g j).
Proof.
intros.
apply rngl_summation_list_mul_summation_list.
Qed.

Theorem rngl_summation_list_map :
  ∀ A B (f : A → B) (g : B → _) l,
  ∑ (j ∈ map f l), g j = ∑ (i ∈ l), g (f i).
Proof.
intros.
unfold iter_list.
rewrite List_fold_left_map.
now apply rngl_summation_list_eq_compat.
Qed.

Theorem rngl_summation_list_change_var : ∀ A B (l : list A) f g (h : _ → B),
  (∀ i, i ∈ l → g (h i) = i)
  → ∑ (i ∈ l), f i = ∑ (i ∈ map h l), f (g i).
Proof.
intros * Hgh.
rewrite rngl_summation_list_map.
apply rngl_summation_list_eq_compat.
intros i Hi.
now rewrite Hgh.
Qed.

Theorem rngl_summation_change_var : ∀ A b e f g (h : _ → A),
  (∀ i, b ≤ i ≤ e → g (h i) = i)
  → ∑ (i = b, e), f i = ∑ (i ∈ map h (seq b (S e - b))), f (g i).
Proof.
intros * Hgh.
apply rngl_summation_list_change_var.
intros i Hi.
apply in_seq in Hi.
apply Hgh.
flia Hi.
Qed.

Theorem rngl_summation_le_compat :
  rngl_is_ordered = true →
  ∀ b e g h,
  (∀ i, b ≤ i ≤ e → (g i ≤ h i)%L)
  → (∑ (i = b, e), g i ≤ ∑ (i = b, e), h i)%L.
Proof.
intros Hor * Hgh.
unfold iter_seq.
remember (S e - b) as n eqn:Hn.
revert b Hn Hgh.
induction n as [| n IHn]; intros; [ now apply rngl_le_refl | ].
unfold iter_list; cbn.
do 2 rewrite rngl_add_0_l.
rewrite fold_left_rngl_add_fun_from_0.
remember (g b + _)%L as x.
rewrite fold_left_rngl_add_fun_from_0.
subst x.
apply rngl_add_le_compat; [ easy | apply Hgh; flia Hn | ].
apply IHn; [ flia Hn | ].
intros i Hbie.
apply Hgh; flia Hbie.
Qed.

Theorem rngl_summation_filter : ∀ A l f (g : A → T),
  ∑ (a ∈ filter f l), g a = ∑ (a ∈ l), if f a then g a else 0%L.
Proof.
intros.
induction l as [| b]; [ easy | cbn ].
rewrite rngl_summation_list_cons.
remember (f b) as fb eqn:Hfb; symmetry in Hfb.
destruct fb. {
  rewrite rngl_summation_list_cons; f_equal.
  apply IHl.
} {
  rewrite rngl_add_0_l.
  apply IHl.
}
Qed.

End a.

Arguments all_0_rngl_summation_0 {T}%type {ro rp} (b e)%nat (f g)%function.
Arguments all_0_rngl_summation_list_0 {T}%type {ro rp} A%type l%list.
Arguments rngl_summation_list_split_first {T}%type {ro rp} A%type l%list.
Arguments rngl_mul_summation_list_distr_l {T ro rp}.
Arguments rngl_mul_summation_list_distr_r {T ro rp}.
Arguments rngl_mul_summation_distr_l {T ro rp} Hom a b e f.
Arguments rngl_mul_summation_distr_r {T ro rp} Hom a b e f.
Arguments rngl_opp_summation {T}%type {ro rp} Hop (b e)%nat.
Arguments rngl_summation_add_distr {T}%type {ro rp} _ _ (b k)%nat.
Arguments rngl_summation_change_var {T ro} A%type (b e)%nat.
Arguments rngl_summation_eq_compat {T ro} _ _ (b k)%nat.
Arguments rngl_summation_filter {T ro rp} A%type l%list.
Arguments rngl_summation_list_app {T}%type {ro rp} A%type (la lb)%list.
Arguments rngl_summation_list_change_var {T ro} (A B)%type l%list.
Arguments rngl_summation_list_concat {T ro rp} A%type ll%list.
Arguments rngl_summation_list_cons {T ro rp} A%type a la%list.
Arguments rngl_summation_list_map {T ro} (_ _)%type.
Arguments rngl_summation_list_mul_summation_list {T ro rp}.
Arguments rngl_summation_list_only_one {T}%type {ro rp} A%type.
Arguments rngl_summation_list_permut {T ro rp} [A]%type _ _ (la lb)%list.
Arguments rngl_summation_list_split {T}%type {ro rp} A%type l%list _ n%nat.
Arguments rngl_summation_mul_summation {T}%type {ro rp} Hom (bi bj ei ej)%nat.
Arguments rngl_summation_only_one {T}%type {ro rp} g%function n%nat.
Arguments rngl_summation_rtl {T}%type {ro rp} _ (b k)%nat.
Arguments rngl_summation_shift {T}%type {ro} (s b)%nat _%function k%nat.
Arguments rngl_summation_split {T}%type {ro rp} j%nat g%function (b k)%nat.
Arguments rngl_summation_split_first {T}%type {ro rp} (b k)%nat.
Arguments rngl_summation_split3 {T}%type {ro rp} j%nat _ (b k)%nat.
Arguments rngl_summation_summation_distr {T}%type {ro rp} (a b)%nat.
Arguments rngl_summation_summation_exch {T ro rp} g k%nat.
Arguments rngl_summation_summation_list_flat_map {T ro rp} (A B)%type la%list.
Arguments rngl_summation_summation_list_swap {T ro rp} (_ _)%type (_ _)%list.


Require Import Coq.Lists.List.
Require Import Coq.Bool.Bool.
Require Import Coq.Lists.List.
Require Import Coq.Bool.Bool.
Require Import Coq.Structures.OrdersFacts.
Require Import Omega.
Require Import Coq.Logic.ClassicalFacts.

(*The recursion tree for quickSort*)
Inductive qs_tree : list nat -> Type :=
| qs_tree_base : qs_tree nil
| qs_tree_step : forall ( x: nat) (xs: list nat),
  qs_tree (filter (fun y => leb y  x) (xs)) ->
  qs_tree (filter (fun y => negb (leb y x)) (xs)) ->
    qs_tree (cons x xs).

(*The fixpoint which evaluates a recursion tree*)
Fixpoint qs_helper (l : list nat) (q : qs_tree l) {struct q} : list nat :=
  match q with
  | qs_tree_base => nil
  | qs_tree_step x xs q0 q1 =>
      (qs_helper (filter (fun y : nat => leb y x) xs) q0) ++ (x ::
        (qs_helper (filter (fun y : nat => negb (leb y x)) xs) q1))
  end.

Require Import Coq.Sorting.Sorted.

(*Create the recursion tree for a given list*)
  (*Redefine lemmas from libraries to be opaque*)
Lemma leb_correct : forall m n:nat, m <= n -> leb m n = true.
Proof.
  induction m as [| m IHm]. trivial.
  destruct n. intro H. elim (le_Sn_O _ H).
  intros. simpl in |- *. apply IHm. apply le_S_n. assumption.
Defined.

Lemma leb_correct_conv : forall m n:nat, m < n -> leb n m = false.
Proof.
  intros.
  generalize (leb_complete n m).
  destruct (leb n m); auto.
  intros.
  elim (lt_irrefl _ (lt_le_trans _ _ _ H (H0 (refl_equal true)))).
Defined.

Lemma not_true_is_false : forall b:bool, b <> true -> b = false.
destruct b.
intros.
red in H; elim H.
reflexivity.
intros abs.
reflexivity.
Defined.

Lemma gt_leb_conv: forall (a: nat) (a0 : nat),(a > a0) -> (a0 <= a).
Proof.
intros.
intuition.
Defined.

  (*New facts about filters*)
Lemma filter_commutative: forall (xs : list nat) (f1 : nat -> bool) (f2 : nat -> bool),
   (filter f2 (filter f1 xs))
= (filter f1 (filter f2 xs)).
Proof.
intros.
induction xs.
simpl. (*base case*)
intuition.
simpl. (*step*)
destruct (bool_dec (f1 a) true).
destruct (bool_dec (f2 a) true).
rewrite e.
rewrite e0.
simpl.
rewrite e.
rewrite e0.
rewrite IHxs.
intuition. (*case f1,!f2*)
apply not_true_is_false in n.
rewrite n; rewrite e.
simpl.
rewrite n.
intuition. (*case !f1,f2*)
apply not_true_is_false in n.
destruct (bool_dec (f2 a) true).
rewrite n;rewrite e.
simpl.
rewrite n.
intuition.
apply not_true_is_false in n0.
rewrite n;rewrite n0.
intuition.
Defined.

Lemma filter_combine: forall (xs : list nat) (f1 :nat -> bool) (f2 : nat -> bool),
filter f1 (filter f2 xs) = filter ( fun x: nat => (f1 x) && f2 x) xs.
Proof.
intros.
induction xs.
simpl.
reflexivity.
simpl.
destruct (bool_dec (f1 a) true); intros. (*case f1,f2*)
destruct (bool_dec (f2 a) true); intros.
rewrite e; rewrite e0.
simpl.
rewrite e.
rewrite IHxs.
intuition. (*case f1,!f2*)
apply not_true_is_false in n as e0.
rewrite e; rewrite e0.
simpl.
intuition. (*case !f1,f2*)
apply not_true_is_false in n as e.
destruct (bool_dec (f2 a) true); intros.
rewrite e; rewrite e0.
simpl.
rewrite e.
intuition. (*case !f1,!f2*)
apply not_true_is_false in n0 as e0.
rewrite e; rewrite e0.
intuition.
Defined.

  (*lemma f1 -> f2 then (filter f2 (filter f1 xs)) = filter f2 xs*)
  (*made specific for convienience*)
Lemma filter_nat_helper_right: forall (a : nat) (b :nat) (xs : list nat), (a>=b)->
  (filter (fun x0 : nat => negb(x0 <=? a))) (filter (fun x0 : nat => negb(x0 <=? b)) xs)=
(filter (fun y : nat => negb(y <=? a)) xs).
Proof.
intros.
induction xs. (*induction xs*)
simpl. (*base case*)
intuition.
simpl. (*step*)
destruct (le_gt_dec a0 b). (*case a0 <= b*)
apply leb_correct in l as l1.
rewrite l1; simpl.
apply (le_trans a0 b a) in l.
apply leb_correct in l.
rewrite l; simpl.
intuition.
intuition.
apply leb_correct_conv in g. (*case a0 > b*)
rewrite g; simpl.
destruct (le_gt_dec a0 a).
apply leb_correct in l.
rewrite l; simpl.
intuition.
apply leb_correct_conv in g0.
rewrite g0; simpl.
rewrite IHxs.
intuition.
Defined.

Lemma filter_nat_helper_left: forall (xs : list nat) (a:nat) (b:nat),
  (b > a) -> (filter (fun y : nat => (y <=? a) && (y <=? b)) xs) = filter (fun y : nat => y <=? a) xs.
Proof.
intros.
induction xs.
simpl. (*base case*)
intuition.
simpl. (*step*)
destruct (le_lt_dec a0 a). (*case a0 <= a*)
apply (gt_le_trans b a a0) in H.
apply leb_correct in l.
rewrite l.
apply gt_leb_conv in H.
apply leb_correct in H.
rewrite H.
rewrite andb_true_l.
rewrite IHxs.
intuition.
intuition. (*case a < a0*)
apply leb_correct_conv in l.
rewrite l.
rewrite andb_false_l.
intuition.
Defined.

(*Vital lemma: convert list to recursion tree for quickSort*)
Lemma create_qs_tree: forall (l : list nat), (qs_tree l).
Proof.
intros.
induction l. (*induction l*)
constructor. (*base*)
constructor. (*step*)
induction IHl. (*induction on IH : qs_tree*)
constructor. (*base*)
simpl. (*step left side*)
destruct (le_lt_dec x a). (*case x in left branch*)
apply leb_correct in l.
rewrite l.
constructor. (*recurse*)
rewrite filter_commutative. (*left recursion branch*)
intuition.
rewrite filter_commutative. (*right recursion branch*)
intuition.
apply leb_correct_conv in l as l2. (*if head xs not left*)
rewrite l2.
apply (filter_nat_helper_left xs a x) in l.
rewrite filter_combine in IHIHl1.
rewrite <- l.
intuition.
induction IHl. (*recurse right branch*)
simpl.
constructor.
simpl.
destruct (le_gt_dec x a). (*if head xs not in right branch*)
apply leb_correct in l as l0;
rewrite l0.
simpl.
intuition.
apply (filter_nat_helper_right a x xs) in l.
rewrite <- l.
intuition. (*if head xs in right branch*)
apply leb_correct_conv in g.
rewrite g.
simpl.
constructor. (*recurse*)
rewrite filter_commutative.
intuition.
rewrite filter_commutative.
intuition.
Defined.

(*Definition quickSort creates recursion tree for given list and hands it to qs_helper which executes it*)
Definition quickSort (ls :list nat) := qs_helper ls (create_qs_tree ls).

(*Test  quickSort*)

Definition l := 5 :: 3 :: 0 :: nil.
Eval compute in ((quickSort l)).

(*Proof Correctness quickSort*)
  (*Note this prove uses that this holds for the recursion tree made by our definition xs*)
Lemma qs_contains : forall (xs : list nat) (x : nat),
  (In x xs) -> (In x (quickSort xs)).
Proof.
intros.
unfold quickSort.
induction (create_qs_tree xs). (*induction on recursion tree*)
intuition. (*base*)
simpl.  (*step*)
destruct H. (*split x = x0 or x in xs*)
rewrite <- H. (*case x = x0*)
simpl.
intuition. (*case x in xs*)
apply in_or_app. (*split x left or right after sorting*)
destruct (le_gt_dec x x0).
(*case x <= x0*)
pose proof (filter_In (fun y => leb y  x0) x (xs)) as filter_In.
apply leb_correct in l0.
intuition.
(*case x > x0*)
pose proof (filter_In (fun y => negb (leb y  x0)) x (xs)) as filter_In.
apply leb_correct_conv in g.
apply negb_true_iff in g.
intuition.
Qed.

  (*Note this proof does not use that the recursion tree is made by our definition
    (This is slightly more powerfull but harder to prove)*)
Lemma qs_maintains : forall (xs : list nat) (x : nat) (conc : qs_tree xs),
  (In x (qs_helper xs conc))-> (In x xs).
Proof.
intros.
induction conc. (*induction on conc*)
intuition. (*base*)
simpl in H. (*step*)
apply in_app_or in H.
destruct H. (*case x is in the left side*)
intuition.
apply filter_In in H0.
intuition.
unfold In in H. (*case x is the pivot*)
destruct H.
unfold In.
intuition. (*case x is in the right side*)
intuition.
apply filter_In in H0.
intuition.
Qed.

Lemma qs_In_equiv : forall (xs : list nat) (x : nat),
  (In x (quickSort xs)) <-> ( In x xs).
Proof.
intros.
intuition.
unfold quickSort in H.
apply (qs_maintains xs x (create_qs_tree xs)).
intuition.
apply qs_contains.
intuition.
Qed.

(*Other easier to use definition of HdRel only one way conversion is needed*)
Lemma HdRel_redef : forall (xs : list nat) (a : nat) (f : nat-> nat -> Prop),
  (forall (x:nat), (In x xs) -> (f a x)) -> (HdRel f a xs).
Proof.
intros.
induction xs.
constructor.
constructor.
apply H.
intuition.
Qed.

(*if we have two sorted arrays xls,xrs
  and every element in xls is smaller then every element in xrs then xls++xrs is sorted*)
Lemma sorted_comb : forall (xls: list nat) (xrs: list nat),
  (Sorted le xls) -> (Sorted le xrs) ->
  (forall (x:nat), (In x xls) -> (HdRel le x xrs)) ->
      Sorted le (xls ++ xrs).
Proof.
intros.
induction xls. (*induction on xls*)
simpl. (*base*)
intuition.
simpl. (*step*)
constructor. (*prove sorted properties*)
apply Sorted_inv in H. (*tail is sorted / holds by IH*)
intuition.
apply Sorted_inv in H. (*head is smaller then all elements in tail*)
intuition.
destruct xls. (*case xrs is empty*)
destruct xrs. (*case xls is also empty*)
simpl.
constructor. (*HdRel holds by definition*)
simpl. (*get head of nill++xls*)
apply H1.
constructor.
intuition. (*get head of xrs*)
constructor.
apply HdRel_inv in H3.
intuition.
Qed.

(*final goal proof that quickSort sorts a list*)
Lemma qs_sorted : forall (xs: list nat),
  Sorted le (quickSort xs).
Proof.
intros.
unfold quickSort. (*unfold quickSort*)
induction (create_qs_tree (xs)). (*induction on recursion tree*)
simpl. (*step recursion tree is empty (then by def xs is empty*)
intuition. (*node recursion tree*)
simpl. (*to prove left recursion results appended by right recursion result is sorted*)
apply sorted_comb. (*IH left is sorted*)
intuition. (*to prove pivot appended right recursion is sorted*)
constructor.
intuition. (*IH right is sorted*)
apply HdRel_redef. (*to prove x is smaller then everything in the right branch*)
intros.
apply qs_maintains in H. (*use In x xs <-> In x quickSort xs*)
apply filter_In in H. (*effect of filter*)
intuition.
apply negb_true_iff in H1.
apply leb_complete_conv in H1.
intuition.
intuition. (*to prove everything in the right branch is smaller then everything in pivot + left*)
apply HdRel_redef.
intuition.
apply qs_maintains in H. (*use In x xs <-> In x quickSort xs*)
apply filter_In in H. (*effect of filter*)
apply in_inv in H0. (*trivial clean up basic algebra differences*)
intuition.
apply leb_complete in H2.
rewrite <- H.
intuition.
apply qs_maintains in H.
apply filter_In in H.
intuition.
apply negb_true_iff in H3.
apply leb_complete in H2.
apply leb_complete_conv in H3.
intuition.
Qed.