Set Implicit Arguments.
Set Strict Implicit.
Require Export Setoid.
Require Omega.

(** * Sets.v: Definition of sets as predicates over a type A *)

Section sets.
Variable A : Type.
Variable decA : forall x y :A, {x=y}+{x<>y}.

Definition set := A->Prop.
Definition full : set := fun (x:A) => True.
Definition empty : set := fun (x:A) => False.
Definition add (a:A) (P:set) : set := fun (x:A) => x=a \/ (P x).
Definition singl (a:A) :set := fun (x:A) => x=a.
Definition union (P Q:set) :set := fun (x:A) => (P x) \/ (Q x).
Definition compl (P:set) :set := fun (x:A) => ~P x.
Definition inter (P Q:set) :set := fun (x:A) => (P x) /\ (Q x).
Definition rem (a:A) (P:set) :set := fun (x:A) => x<>a /\ (P x).

(** ** Equivalence *)
Definition equiv (P Q:set) := forall (x:A), P x <-> Q x.

Implicit Arguments full [].
Implicit Arguments empty [].

Lemma equiv_refl : forall P:set, equiv P P.
unfold equiv; intuition.
Save.

Lemma equiv_sym : forall P Q:set, equiv P Q -> equiv Q P.
unfold equiv; firstorder.
Save.

Lemma equiv_trans : forall P Q R:set,
   equiv P Q -> equiv Q R -> equiv P R.
unfold equiv; firstorder.
Save.

Hint Resolve equiv_refl.
Hint Immediate equiv_sym.

(** ** Setoid structure *)
Lemma set_setoid : Setoid_Theory set equiv.
split; red; auto.
exact equiv_trans.
Qed.

Add Setoid set equiv set_setoid as Set_setoid.

Add Morphism add : equiv_add.
unfold equiv,add; firstorder.
Save.

Add Morphism rem : equiv_rem.
unfold equiv,rem; firstorder.
Save.
Hint Resolve equiv_add equiv_rem.

Add Morphism union : equiv_union.
unfold equiv,union; firstorder.
Save.
Hint Immediate equiv_union.

Lemma equiv_union_left :
  forall P1 Q P2,
   equiv P1 P2 -> equiv (union P1 Q) (union P2 Q).
auto.
Save.

Lemma equiv_union_right :
  forall P Q1 Q2 ,
   equiv Q1 Q2 -> equiv (union P Q1) (union P Q2).
auto.
Save.

Hint Resolve equiv_union_left equiv_union_right.

Add Morphism inter : equiv_inter.
unfold equiv,inter; firstorder.
Save.
Hint Immediate equiv_inter.

Add Morphism compl : equiv_compl.
unfold equiv,compl; firstorder.
Save.
Hint Resolve equiv_compl.

Lemma equiv_add_empty : forall (a:A) (P:set), ~equiv (add a P) empty.
red; unfold equiv,empty,add; intros a P eqH; assert (H:=eqH a);  intuition.
Save.

(** ** Finite sets given as an enumeration of elements *)

Inductive finite (P: set) : Type :=
   fin_eq_empty : equiv P empty -> finite P
 | fin_eq_add : forall (x:A)(Q:set),
             ~ Q x-> finite Q -> equiv P (add x Q) -> finite P.
Hint Constructors finite.

Lemma fin_empty : (finite empty).
auto.
Defined.

Lemma fin_add : forall (x:A)(P:set),
             ~ P x -> finite P -> finite (add x P).
eauto.
Defined.

Lemma fin_equiv: forall (P Q : set), (equiv P Q)->(finite P)->(finite Q).
induction 2.
apply fin_eq_empty.
apply equiv_trans with P; auto.
apply fin_eq_add with x Q0; auto.
apply equiv_trans with P; auto.
Defined.

Hint Resolve fin_empty fin_add.

(** *** Emptyness is decidable for finite sets *)
Definition isempty (P:set) := equiv P empty.
Definition notempty (P:set) := not (equiv P empty).

Lemma isempty_dec : forall P, finite P -> {isempty P}+{notempty P}.
unfold isempty,notempty; destruct 1; auto.
right; red; intros.
apply (@equiv_add_empty x Q); auto.
apply equiv_trans with P; auto.
Save.

(** *** Size of a finite set *)
Fixpoint size (P:set) (f:finite P) {struct f}: nat :=
   match f with fin_eq_empty _ => 0%nat
              | fin_eq_add _ Q _ f' _ => S (size f')
   end.

Lemma size_equiv : forall P Q  (f:finite P) (e:equiv P Q),
    (size (fin_equiv e f)) = (size f).
induction f; simpl; intros; auto.
Save.

(** ** Inclusion *)
Definition incl (P Q:set) := forall x, P x -> Q x.

Lemma incl_refl : forall (P:set), incl P P.
unfold incl; intuition.
Save.

Lemma incl_trans : forall (P Q R:set),
incl P Q -> incl Q R -> incl P R.
unfold incl; intuition.
Save.

Lemma equiv_incl : forall (P Q : set),  equiv P Q -> incl P Q.
unfold equiv, incl; firstorder.
Save.

Lemma equiv_incl_sym : forall (P Q : set), equiv P Q -> incl Q P.
unfold equiv, incl; firstorder.
Save.

Lemma equiv_incl_intro :
forall (P Q : set), incl P Q -> incl Q P -> equiv P Q.
unfold equiv, incl; firstorder.
Save.

Hint Resolve incl_refl incl_trans equiv_incl_intro.
Hint Immediate equiv_incl equiv_incl_sym.

(** ** Properties of operations on sets *)

Lemma incl_empty : forall P, incl empty P.
unfold incl,empty; intuition.
Save.

Lemma incl_empty_false : forall P a, incl P empty -> ~ P a.
unfold incl; firstorder.
Save.

Lemma incl_add_empty : forall (a:A) (P:set), ~ incl (add a P) empty.
red; unfold incl,empty,add; intros a P eqH; assert (H:=eqH a);  intuition.
Save.

Lemma equiv_empty_false : forall P a, equiv P empty -> P a -> False.
unfold equiv; firstorder.
Save.

Hint Immediate incl_empty_false equiv_empty_false incl_add_empty.

Lemma incl_rem_stable :   forall a P Q, incl P Q -> incl (rem a P) (rem a Q).
unfold incl,rem;intuition.
Save.

Lemma incl_add_stable :   forall a P Q, incl P Q -> incl (add a P) (add a Q).
unfold incl,add;intuition.
Save.

Lemma incl_rem_add_iff :
  forall a P Q, incl (rem a P) Q <-> incl P (add a Q).
unfold rem, add, incl; intuition.
case (decA x a); auto.
case (H x); intuition.
Save.

Lemma incl_rem_add:
  forall (a:A) (P Q:set),
     (P a) -> incl Q (rem a P) -> incl (add a Q) P.
unfold rem, add, incl; intros; auto.
case H1; intro; subst; auto.
case (H0 x); auto.
Save.

Lemma incl_add_rem :
  forall (a:A) (P Q:set),
     ~ Q a -> incl (add a Q) P -> incl Q (rem a P) .
unfold rem, add, incl; intros; auto.
case (decA x a); intros; auto.
subst; case H; auto.
Save.

Hint Immediate incl_rem_add incl_add_rem.

Lemma equiv_rem_add :
 forall (a:A) (P Q:set),
     (P a) -> equiv Q (rem a P)  -> equiv (add a Q) P.
intros; assert (incl Q (rem a P)); auto.
assert (incl (rem a P) Q); auto.
case (incl_rem_add_iff a P Q); auto.
Save.

Lemma equiv_add_rem :
 forall (a:A) (P Q:set),
     ~ Q a -> equiv (add a Q) P -> equiv Q (rem a P).
intros; assert (incl (add a Q) P); auto.
assert (incl P (add a Q)); auto.
case (incl_rem_add_iff a P Q); auto.
Save.

Hint Immediate equiv_rem_add equiv_add_rem.

Lemma add_rem_eq_equiv :
  forall x (P:set), equiv (add x (rem x P)) (add x P).
unfold equiv, add, rem; intuition.
case (decA x0 x); intuition.
Save.

Lemma add_rem_diff_equiv :
  forall x y (P:set),
  x<>y -> equiv (add x (rem y P)) (rem y (add x P)).
unfold equiv, add, rem; intuition.
subst; auto.
Save.

Lemma add_equiv_in :
  forall x (P:set), P x -> equiv (add x P) P.
unfold equiv, add; intuition.
subst;auto.
Save.

Hint Resolve add_rem_eq_equiv add_rem_diff_equiv add_equiv_in.

Lemma add_rem_equiv_in :
  forall x (P:set), P x -> equiv (add x (rem x P)) P.
intros; apply equiv_trans with (add x P); auto.
Save.

Hint Resolve add_rem_equiv_in.

Lemma rem_add_eq_equiv :
  forall x (P:set), equiv (rem x (add x P)) (rem x P).
unfold equiv, add, rem; intuition.
Save.

Lemma rem_add_diff_equiv :
  forall x y (P:set),
  x<>y -> equiv (rem x (add y P)) (add y (rem x P)).
intros; apply equiv_sym; auto.
Save.

Lemma rem_equiv_notin :
  forall x (P:set), ~P x -> equiv (rem x P) P.
unfold equiv, rem; intuition.
subst;auto.
Save.

Hint Resolve rem_add_eq_equiv rem_add_diff_equiv rem_equiv_notin.

Lemma rem_add_equiv_notin :
  forall x (P:set), ~P x -> equiv (rem x (add x P)) P.
intros; apply equiv_trans with (rem x P); auto.
Save.

Hint Resolve rem_add_equiv_notin.

Lemma rem_not_in : forall x (P:set), ~ rem x P x.
unfold rem; intuition.
Save.

Lemma add_in : forall x (P:set), add x P x.
unfold add; intuition.
Save.

Lemma add_in_eq : forall x y P, x=y -> add x P y.
unfold add; intuition.
Save.

Lemma add_intro : forall x (P:set) y, P y -> add x P y.
unfold add; intuition.
Save.

Lemma add_incl : forall x (P:set), incl P (add x P).
unfold incl,add; intuition.
Save.

Lemma add_incl_intro : forall x (P Q:set), (Q x) -> (incl P Q) -> (incl (add x P) Q).
unfold incl,add; intuition; subst; intuition.
Save.

Lemma rem_incl : forall x (P:set), incl (rem x P) P.
unfold incl, rem; intuition.
Save.

Hint Resolve rem_not_in add_in rem_incl add_incl.

Lemma union_sym : forall P Q : set,
      equiv (union P Q) (union Q P).
unfold equiv, union; intuition.
Save.

Lemma union_empty_left : forall P : set,
      equiv P (union P empty).
unfold equiv, union, empty; intuition.
Save.

Lemma union_empty_right : forall P : set,
      equiv P (union empty P).
unfold equiv, union, empty; intuition.
Save.

Lemma union_add_left : forall (a:A) (P Q: set),
      equiv (add a (union P Q)) (union P (add a Q)).
unfold equiv, union, add; intuition.
Save.

Lemma union_add_right : forall (a:A) (P Q: set),
      equiv (add a (union P Q)) (union (add a P) Q).
unfold equiv, union, add; intuition.
Save.

Hint Resolve union_sym union_empty_left union_empty_right
union_add_left union_add_right.

Lemma union_incl_left : forall P Q, incl P (union P Q).
unfold incl,union; intuition.
Save.

Lemma union_incl_right : forall P Q, incl Q (union P Q).
unfold incl,union; intuition.
Save.

Lemma union_incl_intro : forall P Q R, incl P R -> incl Q R -> incl (union P Q) R.
unfold incl,union; intuition.
Save.

Hint Resolve union_incl_left union_incl_right union_incl_intro.

Lemma incl_union_stable : forall P1 P2 Q1 Q2,
	incl P1 P2 -> incl Q1 Q2 -> incl (union P1 Q1) (union P2 Q2).
intros; apply union_incl_intro; unfold incl,union; intuition.
Save.
Hint Immediate incl_union_stable.

Lemma inter_sym : forall P Q : set,
      equiv (inter P Q) (inter Q P).
unfold equiv, inter; intuition.
Save.

Lemma inter_empty_left : forall P : set,
      equiv empty (inter P empty).
unfold equiv, inter, empty; intuition.
Save.

Lemma inter_empty_right : forall P : set,
      equiv empty (inter empty P).
unfold equiv, inter, empty; intuition.
Save.

Lemma inter_add_left_in : forall (a:A) (P Q: set),
      (P a) -> equiv (add a (inter P Q)) (inter P (add a Q)).
unfold equiv, inter, add; split; intuition.
subst; auto.
Save.

Lemma inter_add_left_out : forall (a:A) (P Q: set),
      ~ P a -> equiv (inter P Q) (inter P (add a Q)).
unfold equiv, inter, add; split; intuition.
subst; case H; auto.
Save.

Lemma inter_add_right_in : forall (a:A) (P Q: set),
      Q a -> equiv (add a (inter P Q)) (inter (add a P) Q).
unfold equiv, inter, add; split; intuition.
subst; auto.
Save.

Lemma inter_add_right_out : forall (a:A) (P Q: set),
      ~ Q a -> equiv (inter P Q) (inter (add a P) Q).
unfold equiv, inter, add; split; intuition.
subst; case H; auto.
Save.

Hint Resolve inter_sym inter_empty_left inter_empty_right
inter_add_left_in inter_add_left_out inter_add_right_in inter_add_right_out.

(** ** Generalized union *)
Definition gunion (I:Type)(F:I->set) : set := fun z => exists i, F i z.

Lemma gunion_intro : forall I (F:I->set) i, incl (F i) (gunion F).
red; intros; exists i; auto.
Save.

Lemma gunion_elim : forall I (F:I->set) (P:set), (forall i, incl (F i) P) -> incl (gunion F) P.
red; intros I F P H x (i,Hi).
apply (H i x); auto.
Save.

Lemma gunion_monotonic : forall I (F G : I -> set),
      (forall i, incl (F i) (G i))-> incl (gunion F) (gunion G).
intros I F G H x (i,Hi).
exists i; apply (H i x); trivial.
Save.

(** ** Removing an element from a finite set *)

Lemma finite_rem :  forall (P:set) (a:A),
   finite P -> finite (rem a P).
induction 1; intuition.
apply fin_eq_empty.
unfold rem,empty,equiv; intuition.
apply (equiv_empty_false x e); auto.
case (decA x a); intros.
apply fin_equiv with Q; subst; auto.
apply equiv_add_rem; auto.
apply fin_eq_add with x (rem a Q); auto.
subst; unfold rem; intuition.
apply equiv_trans with (rem a (add x Q)); auto.
Defined.

Lemma size_finite_rem:
   forall (P:set) (a:A) (f:finite P),
    (P a) -> size f = S (size (finite_rem a f)).
induction f;  intros.
case (equiv_empty_false a e H).
simpl; case (decA x a); simpl; intros.
case e0; unfold eq_rect_r;simpl; auto.
rewrite size_equiv; auto.
rewrite IHf; auto.
case (e a); unfold add; intuition.
case n0; auto.
Save.

(* bug lie a intuition
Lemma size_finite_rem:
   forall (P:set) (a:A) (f:finite P),
    (P a) -> size f = S (size (finite_rem a f)).
induction f;  intuition.
case (equiv_empty_false a e H).
simpl; case (decA x a); simpl; intros.
case e0; unfold eq_rect_r;simpl; auto.
rewrite size_equiv; auto.
rewrite IHf; auto.
case (e a); unfold add; intuition.
case f0; auto.
Save.
*)
Require Import Arith.

Lemma size_incl :
  forall (P:set)(f:finite P) (Q:set)(g:finite Q),
  (incl P Q)-> size f <= size g.
induction f; simpl; intros; auto with arith.
apply le_trans with (S (size (finite_rem x g))).
apply le_n_S.
apply IHf with (g:= finite_rem x g); auto.
apply incl_trans with (rem x P); auto.
apply incl_add_rem; auto.
apply incl_rem_stable; auto.
rewrite <- size_finite_rem; auto.
case (e x); intuition.
Save.

Lemma size_unique :
  forall (P:set)(f:finite P) (Q:set)(g:finite Q),
  (equiv P Q)-> size f = size g.
intros; apply le_antisym; apply size_incl; auto.
Save.

(** ** Decidable sets *)
Definition dec (P:set) := forall x, {P x}+{~ P x}.

Lemma finite_incl : forall P:set,
   finite P -> forall Q:set, dec Q -> incl Q P -> finite Q.
intros P FP; elim FP; intros; auto.
apply fin_eq_empty.
unfold empty,equiv in *|-*; intuition.
case (e x); auto.
case (X0 x); intros.
apply fin_eq_add with (x:=x) (Q:=(rem x Q0)); auto.
apply X.
unfold dec,rem.
intro y; case (decA x y); intro.
case (X0 y); subst; intuition.
case (X0 y); intuition.
case (incl_rem_add_iff x Q0 Q); intuition.
apply H1; apply incl_trans with P0; auto.
apply equiv_sym; auto.
apply X; auto.
red; intros.
case (e x0); intuition.
case H1; intuition; subst; auto.
case n0; auto.
Save.

Lemma finite_dec : forall P:set, finite P -> dec P.
red; intros P FP; elim FP; intros.
right; intro; apply (equiv_empty_false x e); auto.
case (e x0); unfold add; intuition.
case (X x0); intuition.
case (decA x0 x); intuition.
Save.

Lemma fin_add_in : forall (a:A) (P:set), finite P -> finite (add a P).
intros a P FP; case (finite_dec FP a); intro.
apply fin_equiv with P; auto.
apply equiv_sym; auto.
apply fin_add; auto.
Defined.

Lemma finite_union :
     forall P Q, finite P -> finite Q -> finite (union P Q).
intros P Q FP FQ; elim FP; intros.
apply fin_equiv with Q; auto.
apply equiv_trans with (union empty Q); auto.
apply fin_equiv with (add x (union Q0 Q)); auto.
apply equiv_trans with (union (add x Q0) Q); auto.
apply fin_add_in; auto.
Defined.

Lemma finite_full_dec : forall P:set, finite full -> dec P -> finite P.
intros; apply finite_incl with full; auto.
unfold full,incl; auto.
Save.

Require Import Lt.

(** *** Filter operation *)

Lemma finite_inter : forall P Q, dec P -> finite Q -> finite (inter P Q).
intros P Q decP FQ.
induction FQ.
constructor 1.
apply equiv_trans with (inter P empty); auto.
case (decP x); intro.
constructor 2 with x (inter P Q); auto.
unfold inter; intuition.
rewrite e.
unfold add,inter; red; intuition.
subst; auto.
apply fin_equiv with (inter P Q); auto.
rewrite e.
unfold add,inter; red; intuition.
subst; intuition.
Defined.

Lemma size_inter_empty : forall P Q (decP:dec P) (e:equiv Q empty),
   size (finite_inter decP (fin_eq_empty e))=O.
trivial.
Save.

Lemma size_inter_add_in :
     forall P Q R (decP:dec P)(x:A)(nq:~Q x)(FQ:finite Q)(e:equiv R (add x Q)),
      P x ->size (finite_inter decP (fin_eq_add nq FQ e))=S (size (finite_inter decP FQ)).
intros; simpl.
case (decP x); intro; trivial; contradiction.
Save.

Lemma size_inter_add_notin :
     forall P Q R (decP:dec P)(x:A)(nq:~Q x)(FQ:finite Q)(e:equiv R (add x Q)),
   ~ P x -> size (finite_inter decP (fin_eq_add nq FQ e))=size (finite_inter decP FQ).
intros; simpl.
case (decP x); intro; try contradiction.
rewrite size_equiv; trivial.
Save.

Lemma size_inter_incl : forall P Q (decP:dec P)(FP:finite P)(FQ:finite Q),
    (incl P Q) -> size (finite_inter decP FQ)=size FP.
intros; apply size_unique.
unfold inter; intro.
generalize (H x); intuition.
Save.

(** *** Selecting elements in a finite set *)

Fixpoint nth_finite (P:set) (k:nat) (PF : finite P) {struct PF}: (k < size PF) -> A :=
  match PF as F return (k < size F) -> A with
       fin_eq_empty H => (fun (e : k<0) => match lt_n_O k e with end)
     | fin_eq_add x Q nqx fq eqq =>
           match k as k0 return k0<S (size fq)->A with
                O => fun e => x
         | (S k1) => fun (e:S k1<S (size fq)) => nth_finite fq (lt_S_n k1 (size fq) e)
           end
  end.

(** A set with size > 1 contains at least 2 different elements **)

Lemma select_non_empty : forall (P:set), finite P -> notempty P -> sigT P.
destruct 1; intros.
case H; auto.
exists x; case (e x); intuition.
Defined.

Lemma select_diff : forall (P:set) (FP:finite P),
     (1 < size FP)%nat -> sigT (fun x => sigT (fun y => P x /\ P y /\ x<>y)).
destruct FP; simpl; intros.
absurd (1<0); omega.
exists x; destruct FP; simpl in H.
absurd (1<1); omega.
exists x0; intuition.
case (e x); auto.
case (e0 x0); case (e x0); unfold add; intuition.
subst; case (e0 x0); intuition.
Save.

End sets.

Hint Resolve equiv_refl.
Hint Resolve equiv_add equiv_rem.
Hint Immediate equiv_sym finite_dec finite_full_dec equiv_incl equiv_incl_sym equiv_incl_intro.

Hint Resolve incl_refl.
Hint Immediate incl_union_stable.
Hint Resolve union_incl_left union_incl_right union_incl_intro incl_empty rem_incl
incl_rem_stable incl_add_stable.

Hint Constructors finite.
Hint Resolve add_in add_in_eq add_intro add_incl add_incl_intro union_sym union_empty_left union_empty_right
union_add_left union_add_right finite_union equiv_union_left
equiv_union_right.
Implicit Arguments full [].
Implicit Arguments empty [].

Add Parametric Relation (A:Type) : (set A) (equiv (A:=A))
      reflexivity proved by (equiv_refl (A:=A))
      symmetry proved by (equiv_sym (A:=A))
      transitivity proved by (equiv_trans (A:=A))
as equiv_rel.

Add Parametric Relation (A:Type) : (set A) (incl (A:=A))
      reflexivity proved by (incl_refl (A:=A))
      transitivity proved by (incl_trans (A:=A))
as incl_rel.


Require Export P04.

Theorem negation_fn_applied_twice :
  forall (f : bool -> bool),
  (forall (x : bool), f x = negb x) ->
  forall (b : bool), f (f b) = b.
Proof.
  intros f.
  intros H.
  intros b.
  rewrite -> H.
  rewrite -> H.
  destruct b.
  - reflexivity.
  - reflexivity.
Qed.


(* From the standard library. *)
Require Import ZArith.
Local Open Scope Z_scope.

(** * Set theory
 *
 * A fragment of set theory using predicates.  This file contains definitions
 * and notations.  Automation is provided in Automation.v, while properties are
 * proved in SetsFacts.v.
 *)

Definition set U := U -> Prop.

(** Membership predicate. *)
Inductive is_in {U} : U -> set U -> Prop :=
  Is_in : forall x (A : set U), A x -> is_in x A.
Infix "∈" := is_in (at level 70, no associativity) : set_scope.
Local Open Scope set_scope.

(** Set inclusion. *)
Definition subset {U} (A B : set U) : Prop :=
  forall x, x ∈ A -> x ∈ B.
Infix "⊆" := subset (at level 70, no associativity) : set_scope.

(** Set equivalence.  In SetsFacts.v, we register it as a setoid, with an
 * associated database of rewriting rules. *)
Definition same {U} (A B : U -> Prop) :=
  forall x, x ∈ A <-> x ∈ B.
Infix "≡" := same (at level 79, no associativity) : set_scope.

(** Empty sets. *)
Definition empty {U} : set U := fun _ : U => False.
Notation "∅" := (@empty _) : set_scope.

(** Singletons. *)
Definition singleton {U} (x : U) : set U := fun y => y = x.
Notation "⎨ a ⎬" := (singleton a) : set_scope.

(** Sets of the form { n integer | a <= n <= b }. *)
Definition segment (x y : Z) : set Z :=
  fun n => x <= n <= y.
Notation "〚 x , y 〛" :=
  (segment x y) (at level 0, format "'〚' x ','  '/' y '〛'") : set_scope.

(** Cartesian product. *)
Definition times {U V} (A : set U) (B : set V) : set (U * V) :=
  fun p => (fst p ∈ A /\ snd p ∈ B).
Infix "×" := times (at level 39, left associativity) : set_scope.

(** Binary unions. *)
Definition bin_union {U} (A B : set U) : set U :=
  fun x => x ∈ A \/ x ∈ B.
Infix "∪" := bin_union (at level 41, right associativity) : set_scope.

(** Union of a family of sets indexed by integers [n] such that
 * [a <= n <= b]. *)
Definition param_union {U} (a b : Z) (X : Z -> set U) :=
  fun x => exists i, a <= i <= b /\ x ∈ X i.
Notation "⋃ ⎨ A , k ∈ 〚 a , b 〛 ⎬" :=
  (param_union a b (fun k => A))
    (at level 0, k at next level, A at next level) : set_scope.


Require Import List.

Section ListLexOrder.
  Variable T : Type.
  Variable cmp : T -> T -> comparison.

  Fixpoint list_lex_cmp (ls rs : list T) : comparison :=
    match ls , rs with
      | nil , nil => Eq
      | nil , _ => Lt
      | _ , nil => Gt
      | l :: ls , r :: rs =>
        match cmp l r with
          | Eq => list_lex_cmp ls rs
          | x => x
        end
    end.
End ListLexOrder.

Section Sorting.
  Variable T : Type.
  Variable cmp : T -> T -> comparison.

  Section insert.
    Variable val : T.

    Fixpoint insert_in_order (ls : list T) : list T :=
      match ls with
        | nil => val :: nil
        | l :: ls' =>
          match cmp val l with
            | Gt => l :: insert_in_order ls'
            | _ => val :: ls
          end
      end.
  End insert.

  Fixpoint sort (ls : list T) : list T :=
    match ls with
      | nil => nil
      | l :: ls =>
        insert_in_order l (sort ls)
    end.

End Sorting.

Lemma insert_in_order_inserts : forall T C x l,
  exists h t, insert_in_order T C x l = h ++ x :: t /\ l = h ++ t.
Proof.
  clear. induction l; simpl; intros.
  exists nil; exists nil; eauto.
  destruct (C x a).
  exists nil; simpl. eauto.
  exists nil; simpl. eauto.
  destruct IHl. destruct H. intuition. subst.
  rewrite H0. exists (a :: x0). exists x1. simpl; eauto.
Qed.

Require Import Permutation.

Lemma sort_permutation : forall T (C : T -> T -> _) x,
  Permutation (sort _ C x) x.
Proof.
  induction x; simpl.
  { reflexivity. }
  { destruct (insert_in_order_inserts T C a (sort T C x)) as [ ? [ ? ? ] ].
    destruct H. rewrite H. rewrite <- Permutation_cons_app. reflexivity. rewrite H0 in *. symmetry; auto. }
Qed.


Require Import Reals.
Require Import PolTac.

Open Scope R_scope.

Theorem pols_test1 x y :
  x < y -> x + x < y + x.
Proof.
intros.
pols.
auto.
Qed.

Theorem pols_test2 x y :
  0 < y -> x < x + y.
Proof.
intros.
pols.
auto.
Qed.

Theorem pols_test3 x y :
  0 < y * y ->
  (x + y) * (x - y) < x * x.
Proof.
intros.
pols.
auto with real.
Qed.

Theorem pols_test4 x y :
  x * x < y * y ->
  (x + y) * (x + y) < 2 * (x * y + y * y).
Proof.
intros.
pols.
auto.
Qed.

Theorem pols_test5 x y z :
  x * (z + 2) < y * (2 * x + 1) ->
  x * (z + y + 2) < y * (3 * x + 1).
Proof.
intros.
pols.
auto.
Qed.

Theorem polf_test1 x y :
  0 <= x -> 1 <= y -> x <= x * y.
Proof.
intros.
polf.
Qed.

Theorem polf_test2 x y :
  0 < x -> x <= x * y -> 1 <= y.
Proof.
intros H1 H2.
hyp_polf H2.
Qed.

Theorem polr_test1 x y z :
  x + z < y ->
  x + y + z < 2 * y.
Proof.
intros H.
polr H.
pols.
auto.
pols.
auto with real.
Qed.

Theorem polr_test2 x y z t u :
  t < 0 -> y = u ->
  x + z < y ->
  2 * y * t < x * t + t * u + z * t.
Proof.
intros H1 H2 H3.
polf.
polr H2; auto with real.
polr H3.
pols.
auto.
pols.
auto with real.
Qed.


Require Export Poly.

Theorem silly1 : forall(n m o p : nat),
    n = m ->
    [n;o] = [n;p] ->
    [n;o] = [m;p].
Proof.
    intros n m o p eq1 eq2.
    rewrite <- eq1.
    apply eq2.
Qed.

Theorem silly2 : forall(n m o p : nat),
    n = m ->
    (forall(q r : nat), q = r -> [q;o] = [r;p]) ->
    [n;o] = [m;p].
Proof.
    intros n m o p eq1 eq2.
    apply eq2. apply eq1.
Qed.

Theorem silly2a : forall(n m : nat),
    (n, n) = (m, m) ->
    (forall(q r : nat), (q,q) = (r,r) -> [q] = [r]) ->
    [n] = [m].
Proof.
    intros n m eq1 eq2.
    apply eq2. apply eq1.
Qed.

Theorem silly_ex :
    (forall n, evenb n = true -> oddb (S n) = true) ->
    evenb 3 = true ->
    oddb 4 = true.
Proof.
    intros.
    apply H.
    apply H0.
Qed.

Theorem silly3 : forall(n : nat),
    true = beq_nat n 5 ->
    beq_nat (S (S n)) 7 = true.
Proof.
    intros n H.
    symmetry.
    simpl.
    apply H.
Qed.

Theorem rev_exercise1: forall (l l' : list nat),
    l = rev l' ->
    l' = rev l.
Proof.
    intros.
    rewrite H.
    symmetry.
    apply rev_involutive.
Qed.

Example trans_eq_example : forall(a b c d e f : nat),
    [a;b] = [c;d] ->
    [c;d] = [e;f] ->
    [a;b] = [e;f].
Proof.
    intros a b c d e f eq1 eq2.
    rewrite -> eq1. rewrite -> eq2. reflexivity.
Qed.

Theorem trans_eq : forall(X:Type) (n m o : X),
    n = m -> m = o -> n = o.
Proof.
    intros X n m o eq1 eq2. rewrite -> eq1.
    rewrite -> eq2. reflexivity.
Qed.

Example trans_eq_example' : forall(a b c d e f : nat),
    [a;b] = [c;d] ->
    [c;d] = [e;f] ->
    [a;b] = [e;f].
Proof.
    intros a b c d e f eq1 eq2.
    apply trans_eq with (m:=[c;d]).
    apply eq1.
    apply eq2.
Qed.

Example trans_eq_exercise : forall(n m o p : nat),
    m = (minustwo o) ->
    (n + p) = m ->
    (n + p) = (minustwo o).
Proof.
    intros n m o p eq1 eq2.
    apply trans_eq with (m := m).
    apply eq2.
    apply eq1.
Qed.

Theorem eq_add_S : forall(n m : nat),
    S n = S m ->
    n = m.
Proof.
    intros n m eq. inversion eq. reflexivity.
Qed.

Theorem silly4 : forall(n m : nat),
    [n] = [m] ->
    n = m.
Proof.
    intros n o eq. inversion eq. reflexivity.
Qed.

Theorem silly5 : forall(n m o : nat),
    [n;m] = [o;o] ->
    [n] = [m].
Proof.
    intros n m o eq. inversion eq. reflexivity.
Qed.

Example sillyex1 : forall(X : Type) (x y z : X) (l j : list X),
    x :: y :: l = z :: j ->
    y :: l = x :: j ->
    x = y.
Proof.
    intros.
    inversion H0.
    reflexivity.
Qed.

Theorem silly6 : forall(n : nat),
    S n = O ->
    2 + 2 = 5.
Proof.
    intros n contra. inversion contra.
Qed.

Theorem silly7 : forall(n m : nat),
    false = true ->
    [n] = [m].
Proof.
    intros n m contra. inversion contra.
Qed.

Example sillyex2 : forall(X:Type) (x y z : X) (l j : list X),
    x :: y :: l = [] ->
    y :: l = z :: j ->
    x = z.
Proof.
    intros X x y z l j contra1 contra2.
    inversion contra1.
Qed.

Theorem f_equal : forall(A B : Type) (f: A -> B) (x y : A),
    x = y -> f x = f y.
Proof.
    intros A B f x y eq.
    rewrite eq.
    reflexivity.
Qed.

Theorem length_snoc' : forall(X : Type) (v : X)
    (l : list X) (n : nat),
    length l = n ->
    length (snoc l v) = S n.
Proof.
    intros X v l. induction l as [| v' l'].
    Case "l = []". intros n eq. rewrite <- eq. reflexivity.
    Case "l = v' :: l'". intros n eq. simpl. destruct n as [| n'].
    SCase "n = 0". inversion eq.
    SCase "n = S n'".
apply f_equal. apply IHl'. inversion eq. reflexivity.
Qed.

Theorem beq_nat_0_l : forall n,
    beq_nat 0 n = true -> n = 0.
Proof.
    intros n eq1.
    induction n as [| n'].
    Case "n = 0".
        reflexivity.
    Case "n = S n'".
        inversion eq1.
Qed.

Theorem beq_nat_0_r : forall n,
    beq_nat n 0 = true -> n = 0.
Proof.
    intros n eq1.
    induction n as [| n'].
    Case "n = 0".
        reflexivity.

    Case "n = S n'".
        inversion eq1.
Qed.

Theorem S_inj : forall(n m : nat) (b : bool),
    beq_nat (S n) (S m) = b ->
    beq_nat n m = b.
Proof.
    intros n m b H.
    simpl in H.
    apply H.
Qed.

Theorem silly3' : forall (n : nat),
    (beq_nat n 5 = true -> beq_nat (S (S n)) 7 = true) ->
        true = beq_nat n 5 ->
        true = beq_nat (S (S n)) 7.
Proof.
    intros n eq H.
    symmetry in H. apply eq in H. symmetry in H.
    apply H.
Qed.

Theorem plus_n_n_injective : forall n m,
    n + n = m + m ->
    n = m.
Proof.
    intros n. induction n as [| n'].
    intros.
    simpl in H.
    destruct m.
        reflexivity.
        inversion H.

    intros.
    destruct m.
    inversion H.
    simpl in H.
    rewrite <- plus_n_Sm in H.
    rewrite <- plus_n_Sm in H.
    apply eq_add_S in H.
    apply eq_add_S in H.
    assert (n' = m) as Heq. apply IHn'. assumption.
    rewrite Heq.
    reflexivity.
Qed.

Theorem beq_nat_true : forall n m,
    beq_nat n m = true -> n = m.
Proof.
    intros n.
    induction n as [| n'].
    intros m eq.
    destruct m.
    reflexivity.

    inversion eq.

    intros m eq.
    destruct m as [| m'].
    inversion eq.

    apply f_equal.
    apply IHn'.
    inversion eq.
    rewrite -> H0.
    reflexivity.
Qed.

Theorem double_injective_take2 : forall n m,
    double n = double m ->
    n = m.
Proof.
    intros n m.
    (* n and m are both in the context *)
    generalize dependent n.
    (* Now n is back in the goal and we can do induction on
    m and get a sufficiently general IH. *)
    induction m as [| m'].
    Case "m = O". simpl. intros n eq. destruct n as [| n'].
        SCase "n = O". reflexivity.
        SCase "n = S n'". inversion eq.
    Case "m = S m'". intros n eq. destruct n as [| n'].
        SCase "n = O". inversion eq.
        SCase "n = S n'". apply f_equal.
            apply IHm'. inversion eq. reflexivity.
Qed.

Theorem index_after_last : forall(n : nat) (X : Type) (l : list X),
    length l = n ->
    index n l = None.
Proof.
    intros n X l.
    generalize dependent n.
    induction l as [| h' l'].
    Case "l = nil".
        reflexivity.

    Case "l = h l'".
        destruct n as [| n'].
        SCase "n = 0".
            simpl. intros eq. inversion eq.

        SCase "n = S n'".
            intros eq. symmetry in eq. rewrite eq. simpl.
            apply IHl'. reflexivity.
Qed.

Theorem length_snoc''' : forall(n : nat) (X : Type)
                        (v : X) (l : list X),
            length l = n ->
            length (snoc l v) = S n.
Proof.
    intros n X v l.
    generalize dependent n.
    generalize dependent v.
    induction l as [| h l'].
    Case "l = nil".
        intros v n. intros eq. simpl in eq. symmetry in eq. rewrite eq. reflexivity.

    Case "n = h n'".
        intros v n.
        intros eq.
        simpl.
        symmetry in eq.
        rewrite eq.
        apply f_equal.
        simpl.
        apply IHl'.
        reflexivity.
Qed.


Set Implicit Arguments.
Require Import ZArith.

Inductive Z_btree : Set :=
  | Z_leaf : Z_btree
  | Z_bnode : Z -> Z_btree -> Z_btree -> Z_btree.

Check Z_btree_ind.

(*
Open Scope Z_scope.
*)

Fixpoint sum_all_values (t: Z_btree) : Z :=
  (match t with
    | Z_leaf          => 0
    | Z_bnode v t1 t2 => v + sum_all_values t1 + sum_all_values t2
  end)%Z.  (* (...)%Z or else you need to open Z_scope *)

Fixpoint zero_present (t: Z_btree) : bool :=
  match t with
    | Z_leaf              => false
    | Z_bnode (0%Z) t1 t2 => true
    | Z_bnode _ t1 t2     => if zero_present t1 then true else zero_present t2
  end.

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

Definition right_son (t: Z_btree) : Z_btree :=
  match t with
    | Z_leaf            => Z_leaf
    | Z_bnode a t1 t2   => t2
  end.

Definition fright_son (t: Z_fbtree) : Z_fbtree :=
  match t with
    | Z_fleaf           => Z_fleaf
    | Z_fnode a f       => f false
  end.

Fixpoint fsum_all_values (t:Z_fbtree) : Z :=
  (match t with
    | Z_fleaf           => 0
    | Z_fnode v f       => v + fsum_all_values (f true) + fsum_all_values (f false)
  end)%Z.

Fixpoint fzero_present (t:Z_fbtree) : bool :=
  match t with
    | Z_fleaf           => false
    | Z_fnode (0%Z) f   => true
    | Z_fnode _     f   => if fzero_present (f true) then true else fzero_present (f false)
  end.

Inductive Z_inf_branch_tree : Set :=
  | Z_inf_leaf : Z_inf_branch_tree
  | Z_inf_node : Z -> (nat -> Z_inf_branch_tree) -> Z_inf_branch_tree.

Fixpoint sum_f_acc (n:nat)(f: nat->Z)(acc: Z) :Z :=
  match n with
    | 0     => acc
    | S p   => sum_f_acc p f (acc + (f p))
  end.

Definition sum_f (n:nat)(f:nat->Z) : Z  := sum_f_acc n f 0%Z.

Fixpoint n_sum_all_values (n:nat)(t: Z_inf_branch_tree) : Z :=
  (match t with
    | Z_inf_leaf          => 0
    | Z_inf_node v f      => v + sum_f n (fun x:nat => n_sum_all_values n (f x))
  end)%Z.

Theorem plus_assoc' : forall x y z:nat, x+y+z = x+(y+z).
Proof.
  intros x y z. elim x. simpl. trivial.
  intros n H. simpl. rewrite H. trivial.
Qed.

Check eq_ind.
(*
forall (A : Type) (x : A) (P : A -> Prop),
       P x -> forall y : A, x = y -> P y
*)

Lemma plus_n_0' : forall (n:nat), n = n + 0.
Proof.
  intro n. elim n. simpl. reflexivity.
  clear n. intros n IH. simpl. pattern (n+0).
  apply eq_ind with (y:=(n+0))(x:=n).
  reflexivity. exact IH.
Qed.

Fixpoint f1 (t:Z_btree) : Z_fbtree :=
  match t with
    | Z_leaf            => Z_fleaf
    | Z_bnode v t1 t2   =>
      Z_fnode v (fun b  =>
        match b with
          | true  => (f1 t1)
          | false => (f1 t2)
         end)
   end.

Fixpoint f2 (t:Z_fbtree) : Z_btree :=
  match t with
    | Z_fleaf           => Z_leaf
    | Z_fnode v f       => Z_bnode v (f2 (f true)) (f2 (f false))
  end.

Theorem f2of1: forall (t:Z_btree), f2 (f1 t) = t.
Proof.
  intro t. elim t. simpl. reflexivity.
  clear t. intro v. intro t1. intro H1. intro t2. intro H2.
  simpl. rewrite H1. rewrite H2. reflexivity.
Qed.

Inductive btree (A:Type) : Type :=
  | leaf : btree A
  | node : A -> btree A -> btree A -> btree A.

Fixpoint translate (t:Z_btree) : btree Z :=
  match t with
    | Z_leaf          => leaf Z
    | Z_bnode v t1 t2 => node v (translate t1) (translate t2)
  end.

Fixpoint specialize (t:btree Z) : Z_btree :=
  match t with
    | leaf            => Z_leaf
    | node v t1 t2    => Z_bnode v (specialize t1) (specialize t2)
  end.

Lemma translate_specialize : forall (t:btree Z),
  translate (specialize t) = t.
Proof.
  intro t. elim t. simpl. reflexivity. clear t. intros a t1 IH1 t2 IH2. simpl.
  rewrite IH1, IH2. reflexivity.
Qed.

(* identical proof *)
Lemma specialize_translate : forall (t:Z_btree),
  specialize (translate t) = t.
Proof.
  intro t. elim t. simpl. reflexivity. clear t. intros a t1 IH1 t2 IH2. simpl.
  rewrite IH1, IH2. reflexivity.
Qed.


Inductive day : Type :=
  | monday
  | tuesday
  | wednesday
  | thursday
  | friday
  | saturday
  | sunday.

Definition next_weekday (d:day) : day :=
  match d with
  | monday => tuesday
  | tuesday => wednesday
  | wednesday => thursday
  | thursday => friday
  | friday => monday
  | saturday => monday
  | sunday => monday
  end.

Compute (next_weekday friday).

Compute (next_weekday (next_weekday saturday)).

Example test_next_weekday:
  (next_weekday (next_weekday saturday)) = tuesday.

Proof. simpl. reflexivity. Qed.

Inductive bool : Type :=
  | true
  | false.

Definition negb (b:bool) : bool :=
  match b with
  | true => false
  | false => true
  end.

Compute (negb true).

Definition andb (b1:bool) (b2:bool) : bool :=
  match b1 with
  | true => b2
  | false => false
  end.

Compute (andb true false).

Definition orb (b1:bool) (b2:bool) :bool :=
  match b1 with
  | true => true
  | false => b2
  end.

Compute (orb true false).

Notation "x && y" := (andb x y).
Notation "x || y" := (orb x y).

Example test_and1:
  (true && false && true) = false.
Proof. simpl. reflexivity. Qed.

Definition negb' (b:bool) : bool :=
  if b then false
  else true.

Compute (negb' true).

Definition andb' (b1:bool) (b2:bool) : bool :=
  if b1 then b2
  else false.

Compute (andb' true true).

Definition nandb (b1:bool) (b2:bool) :bool :=
  match b1 with
  | true => (negb b2)
  | false => true
  end.

Example test_nandb1: (nandb true false) = true.
Proof. simpl. reflexivity. Qed.
Example test_nandb2: (nandb false false) = true.
Proof. simpl. reflexivity. Qed.
Example test_nandb3: (nandb false true) = true.
Proof. simpl. reflexivity. Qed.
Example test_nandb4: (nandb true true) = false.
Proof. simpl. reflexivity. Qed.

Definition andb3 (b1:bool) (b2:bool) (b3:bool) : bool :=
  match b1 with
  | true => (andb b2 b3)
  | false => false
  end.
Example test_andb31: (andb3 true true true) = true.
Proof. simpl. reflexivity. Qed.
Example test_andb32: (andb3 false true true) = false.
Proof. simpl. reflexivity. Qed.
Example test_andb33: (andb3 true false true) = false.
Proof. simpl. reflexivity. Qed.
Example test_andb34: (andb3 true true false) = false.
Proof. simpl. reflexivity. Qed.

Check true.

Check true
    : bool.
Check (negb true)
    : bool.

Check negb.

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

Inductive color : Type :=
  | black
  | white
  | primary (p : rgb).

Definition monochrome (c : color): bool :=
  match c with
  | black => true
  | white => true
  | primary p => false
  end.

Definition isred (c : color) : bool :=
  match c with
  | black => false
  | white => false
  | primary red => true
  | primary _ => false
  end.

Inductive bit : Type :=
  | B0
  | B1.

Inductive nybble : Type :=
  | bits (b0 b1 b2 b3 : bit).

Check (bits B1 B0 B1 B0)
    : nybble.

Definition all_zero (nb : nybble) : bool :=
  match nb with
    | (bits B0 B0 B0 B0) => true
    | (bits _ _ _ _) => false
  end.

Compute (all_zero (bits B1 B0 B1 B0)).

Compute (all_zero (bits B0 B0 B0 B0)).

Module NatPlayground.
Inductive nat : Type :=
  | O
  | S (n : nat).

Definition pred (n : nat) : nat :=
  match n with
  | O => O
  | S n' => n'
  end.
End NatPlayground.

Check (S (S (S (S O)))).

Definition minustwo (n : nat) : nat :=
  match n with
    | O => O
    | S O => O
    | S (S n') => n'
  end.

Compute (minustwo 4).

Check S.
Check pred.
Check minustwo.

Compute (pred 3).

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

Compute (evenb 4).
Compute (evenb 5).
Compute (evenb (S (S O))).

Definition oddb (n:nat) : bool :=
  negb (evenb n).

Example test_oddb1: oddb 1 = true.
Proof. simpl. reflexivity. Qed.
Example test_oddb2: oddb 4 = false.
Proof. simpl. reflexivity. Qed.

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

Compute (plus 5 3).

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

Example test_mult1: (mult 3 3) = 9.
Proof. simpl. reflexivity. Qed.

Fixpoint minus (n m:nat) : nat :=
  match n, m with
  | O , _ => O
  | S _ , O => n
  | S n', S m' => minus n' m'
  end.

End NatPlayground2.

Fixpoint exp (base power : nat) : nat :=
  match power with
    | O => S O
    | S p => mult base (exp base p)
  end.

Compute (exp 3 5).

Fixpoint factorial (n:nat) : nat :=
  match n with
  | O => 1
  | S p => mult (plus p 1) (factorial p)
  end.

Example test_factorial1: (factorial 3) = 6.
Proof. simpl. reflexivity. Qed.

Example test_factorial2: (factorial 5) = (mult 10 12).
Proof. simpl. reflexivity. Qed.

Notation "x + y" := (plus x y).
Notation "x - y" := (minus x y).
Notation "x * y" := (mult x y).

Check ((0 + 1) + 1).

Fixpoint eqb (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' => eqb n' m'
         end
  end.

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

Example test_leb1: leb 2 2 = true.
Proof. simpl. reflexivity. Qed.
Example test_leb2: leb 2 4 = true.
Proof. simpl. reflexivity. Qed.
Example test_leb3: leb 4 2 = false.
Proof. simpl. reflexivity. Qed.

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

Example test_leb3': (4 <=? 2) = false.
Proof. simpl. reflexivity. Qed.

Definition ltb (n m : nat) : bool:=
  match (minus n m) with
  | O => (negb(eqb n m))
  | _ => false
  end.

Notation "x <? y" := (ltb x y) (at level 70) : nat_scope.

Example test_ltb1: (ltb 2 2) = false.
Proof. simpl. reflexivity. Qed.
Example test_ltb2: (ltb 2 4) = true.
Proof. simpl. reflexivity. Qed.
Example test_ltb3: (ltb 4 2) = false.
Proof. simpl. reflexivity. Qed.

Compute (minus 3 5).

Theorem plus_O_n : forall n : nat, 0 + n = n.
Proof.
  intros n. simpl. reflexivity. Qed.

Theorem plus_1_l : forall n:nat, 1 + n = S n.
Proof.
  intros n. reflexivity. Qed.

Theorem mult_0_l : forall n:nat, 0 * n = 0.
Proof.
  intros n. reflexivity. Qed.

Theorem plus_id_example : forall n m:nat,
  n = m ->
  n + n = m + m.

Proof.
  (* 将两个量词移到上下文中： *)
  intros n m.
  (* 将前提移到上下文中： *)
  intros H.
  (* 用前提改写目标： *)
  rewrite -> H.
  reflexivity. Qed.

Theorem plus_id_exercise : forall n m o : nat,
  n = m ->
  m = o ->
  n + m = m + o.
Proof.
  intros n m o.
  intros H J.
  rewrite -> H.
  rewrite -> J.
  reflexivity. Qed.

Check mult_n_O.

Check mult_n_Sm.

Theorem mult_n_0_m_0 : forall n m : nat,
  (n * 0) + (m * 0) = 0.

Proof.
  intros n m.
  rewrite <- mult_n_O.
  rewrite <- mult_n_O.
  reflexivity. Qed.

Theorem mult_n_1 : forall n : nat,
  n * 1 = n.
Proof.
  intros.
  rewrite <- mult_n_Sm.
  rewrite <- mult_n_O.
  reflexivity. Qed.

Theorem mult_n_2 : forall n : nat,
  n * 2 = n + n.
Proof.
  intros.
  rewrite <- mult_n_Sm.
  rewrite <- mult_n_Sm.
  rewrite <- mult_n_O.
  reflexivity. Qed.

Theorem plus_1_neq_0_firsttry : forall n : nat,
  (n + 1) =? 0 = false.
Proof.
  intros n.
  simpl. (* 无能为力! *)
Abort.

Theorem plus_1_neq_0 : forall n : nat,
  (n + 1) =? 0 = false.
Proof.
  intros n. destruct n as [| n'] eqn:E.
  - reflexivity.
  - reflexivity. Qed.

Theorem negb_involutive : forall b : bool,
  negb (negb b) = b.
Proof.
  intros b. destruct b eqn:E.
  - reflexivity.
  - reflexivity. Qed.

Theorem andb_commutative : forall b c, andb b c = andb c b.
Proof.
  intros b c. destruct b eqn:Eb.
  - destruct c eqn:Ec.
    + reflexivity.
    + reflexivity.
  - destruct c eqn:Ec.
    + reflexivity.
    + reflexivity.
Qed.

Theorem andb3_exchange :
  forall b c d, andb (andb b c) d = andb (andb b d) c.
Proof.
  intros b c d. destruct b eqn:Eb.
  - destruct c eqn:Ec.
    { destruct d eqn:Ed.
      - reflexivity.
      - reflexivity. }
    { destruct d eqn:Ed.
      - reflexivity.
      - reflexivity. }
  - destruct c eqn:Ec.
    { destruct d eqn:Ed.
      - reflexivity.
      - reflexivity. }
    { destruct d eqn:Ed.
      - reflexivity.
      - reflexivity. }
Qed.

Theorem plus_1_neq_0' : forall n : nat,
  (n + 1) =? 0 = false.
Proof.
  intros [|n].
  - reflexivity.
  - reflexivity. Qed.

Theorem andb_commutative'' :
  forall b c, andb b c = andb c b.
Proof.
  intros [] [].
  - reflexivity.
  - reflexivity.
  - reflexivity.
  - reflexivity.
Qed.

Theorem andb_true_elim2 : forall b c : bool,
  andb b c = true -> c = true.
Proof.
  intros b c. destruct c.
  - simpl. intros H. reflexivity.
  - rewrite -> andb_commutative.
               simpl.
               intros H.
               rewrite H.
               reflexivity. Qed.

Theorem zero_nbeq_plus_1 : forall n : nat,
  0 =? (n + 1) = false.
Proof.
  intros n. destruct n as [| n'] eqn:E.
  - reflexivity.
  - reflexivity.
Qed.

(*
Fixpoint funny_func (n : nat) (m : nat) : nat :=
  match n with
  | 0 => (funny_func (minus m 1) 1)
  | S n' => (funny_func (minus m 1) (funny_func m (minus n' 1)))
  end.
*)

Theorem identity_fn_applied_twice :
  forall (f : bool -> bool),
  (forall (x : bool), f x = x) ->
  forall (b : bool), f (f b) = b.
Proof.
  intros f.
  intros H.
  intros x. destruct x eqn : Ex.
  - rewrite H. rewrite H. reflexivity.
  - rewrite H. rewrite H. reflexivity.
Qed.

Theorem negation_fn_applied_twice :
  forall (f : bool -> bool),
  (forall (x : bool),  f x = negb x) ->
  forall (b : bool), f (f b) = b.
Proof.
  intros f.
  intros H.
  intros x. destruct x eqn : Ex.
  - rewrite H. rewrite H. reflexivity.
  - rewrite H. rewrite H. reflexivity.
Qed.

Theorem andb_eq_orb :
  forall (b c : bool),
  (andb b c = orb b c) ->
  b = c.
Proof.
  intros b. destruct b eqn : Eb.
  intros c. destruct c eqn : Ec.
  - reflexivity.
  - simpl.
    * intros H.
      + rewrite H. reflexivity.
  - intros c. destruct c eqn : Ec.
    * simpl.
      + intros H.
        rewrite H. reflexivity.
    * reflexivity.
Qed.

Inductive bin : Type :=
  | Z
  | A (n : bin)
  | B (n : bin).

Fixpoint incr (m:bin) : bin :=
  match m with
  | Z => B Z
  | A m' => B m'
  | B m' => A (incr m')
  end.

Compute (incr (A (B (B Z)))).

Fixpoint bin_to_nat (m:bin) : nat :=
  match m with
  | Z => O
  | A m' => plus (bin_to_nat m') (bin_to_nat m')
  | B m' => S (plus (bin_to_nat m') (bin_to_nat m'))
  end.

Compute (bin_to_nat (A (A (B Z)))).

Example test_bin_incr1 : (incr (B Z)) = A (B Z).
Proof. simpl. reflexivity. Qed.
Example test_bin_incr2 : (incr (A (B Z))) = B (B Z).
Proof. simpl. reflexivity. Qed.
Example test_bin_incr3 : (incr (B (B Z))) = A (A (B Z)).
Proof. simpl. reflexivity. Qed.
Example test_bin_incr4 : bin_to_nat (A (B Z)) = 2.
Proof. simpl. reflexivity. Qed.
Example test_bin_incr5 :
        bin_to_nat (incr (B Z)) = 1 + bin_to_nat (B Z).
Proof. simpl. reflexivity. Qed.
Example test_bin_incr6 :
        bin_to_nat (incr (incr (B Z))) = 2 + bin_to_nat (B Z).
Proof. simpl. reflexivity. Qed.


(* week_40c_flatten.v *)
(* dIFP 2014-2015, Q1, Week 40 *)
(* Olivier Danvy <danvy@cs.au.dk> *)

(* ********** *)

Require Import Arith Bool unfold_tactic.

(* ********** *)

(* Data type of binary trees of natural numbers: *)

Inductive binary_tree_nat : Type :=
  | Leaf : nat -> binary_tree_nat
  | Node : binary_tree_nat -> binary_tree_nat -> binary_tree_nat.

(* There is one base case: leaves.
   There is one induction case, with two subtrees.
*)

(* ********** *)

(* Sample of binary trees of natural numbers: *)

Definition bt_0 :=
  Leaf 42.

Definition bt_1 :=
  Node (Leaf 10)
       (Leaf 20).

Definition bt_2 :=
  Node (Node (Leaf 10)
             (Leaf 20))
       (Leaf 30).

(* ********** *)
(*
Definition unit_test_for_flatten (candidate : binary_tree_nat -> nat) :=
  (candidate bt_0 =n= 1)
  &&
  (candidate bt_1 =n= 2)
  &&
  (candidate bt_2 =n= 3)
  &&
  (candidate (Node bt_1 bt_2) =n= 5)
  .
*)
(* ********** *)

Definition specification_of_flatten (flatten : binary_tree_nat -> list nat) :=
  (forall n : nat,
     flatten (Leaf n) = n :: nil)
  /\
  (forall t1 t2 : binary_tree_nat,
     flatten (Node t1 t2) = (flatten t1) ++ (flatten t2)).

Theorem there_is_only_one_flatten :
  forall flatten1 flatten2 : binary_tree_nat -> list nat,
    specification_of_flatten flatten1 ->
    specification_of_flatten flatten2 ->
    forall t : binary_tree_nat,
      flatten1 t = flatten2 t.
Proof.
  intros flatten1 flatten2.
  unfold specification_of_flatten.
  intros [H1_leaf H1_node] [H2_leaf H2_node].
  intro t.
  induction t as [n | t1 IHt1 t2 IHt2].

  rewrite -> H2_leaf.
  apply H1_leaf.

  rewrite -> H1_node.
  rewrite -> H2_node.
  rewrite -> IHt1.
  rewrite -> IHt2.
  reflexivity.
Qed.

(* ********** *)

(* Version with append: *)

Fixpoint flatten_ds (t : binary_tree_nat) : list nat :=
  match t with
    | Leaf n => n :: nil
    | Node t1 t2 => (flatten_ds t1) ++ (flatten_ds t2)
  end.

Definition flatten_v0 (t : binary_tree_nat) : list nat :=
  flatten_ds t.

(* ********** *)

(* Version with an accumulator: *)

Fixpoint flatten_acc (t : binary_tree_nat) (a : list nat) : list nat :=
  match t with
    | Leaf n => n :: a
    | Node t1 t2 => flatten_acc t1 (flatten_acc t2 a)
  end.

Definition flatten_v1 (t : binary_tree_nat) : list nat :=
  flatten_acc t nil.

(* ********** *)

Fixpoint swap_ds (t : binary_tree_nat) : binary_tree_nat :=
  match t with
    | Leaf n => Leaf in
    | Node t1 t2 => Node (swap_ds t2) (swap_ds t1)
  end.

Definition swap_v0 (t : binary_tree_nat) : binary_tree_nat :=
  swap_ds t.

(* Prove that composing swap_v0 with itself yields the identity function. *)

(* ********** *)

(* What is the result of applying flatten_v0
   to the result of applying swap_v0 to a tree?
*)

(* ********** *)

(* end of week_40c_flatten.v *)


(* I will denote D- as a defined type.
   For example, DTrue is defined True. *)

(* -- True -- *)

(* True is a single object, 1. *)

Inductive DTrue : Type :=
| DTrue_I : DTrue.

Theorem absurdity :
  True.
Proof.
  apply I. (* I is a unique object of True. *)
  Qed.

Theorem Dabsurdity :
  DTrue.
Proof.
  apply DTrue_I. Qed.

Theorem true_useless : forall A : Prop,
  True -> A.
Proof.
  intro A. intro HTrue. Abort.
  (* We can't create anything from True. *)

(* -- False -- *)

Inductive DFalse : Type := .
(* False is type with no element. *)

Theorem false_not_provable :
  False.
Proof.
  Abort.
  (* We can't prove something is false. *)

Theorem false_always_true : forall A : Prop,
  False -> A.
Proof.
  intro A. intro HFalse. inversion HFalse. Qed.

Theorem Dfalse_always_true : forall A : Prop,
  DFalse -> A.
Proof.
  intro A. intro HFalse. inversion HFalse. Qed.

Theorem false_always_true2 : forall A : Prop,
  1 = 2 -> A.
Proof.
  intro A. intro Hneq. discriminate. Qed.

Theorem false_is_false :
  ~ False.
Proof.
  intro f. apply f. Qed.

(* -- Imply -- *)

(* Imply is a function.
   Actually, it is *computable* function. *)
Definition DImply (A : Type) (B : Type) := A -> B.

Theorem Imply_prove :
  forall (n m : nat), n = m -> S n = S m.
Proof.
  intros n m Heq. rewrite Heq. reflexivity. Qed.

Theorem Imply_left : forall (A B : Prop),
  A -> (A -> B) -> B.
Proof.
  intros A B HA HAB.
  apply HAB in HA. apply HA. Qed.

Theorem Imply_right : forall (A B : Prop),
  A -> (A -> B) -> B.
Proof.
  intros A B HA HAB.
  apply HAB. apply HA. Qed.

(* -- And -- *)

(* And is simply a pair of two type. *)
Inductive DAnd (A : Type) (B : Type) :=
| DPair (a : A) (b : B).

Theorem And_left : forall A B : Prop,
  A /\ B -> A.
Proof.
  intros A B HAB. destruct HAB as [HA HB]. apply HA. Qed.

Theorem And_right : forall A B : Prop,
  A /\ B -> B.
Proof.
  intros A B HAB. destruct HAB as [HA HB]. apply HB. Qed.

Theorem And_construct : forall A B : Prop,
  A -> B -> A /\ B.
Proof.
  intros A B HA HB. split.
  - apply HA.
  - apply HB.
  Qed.

Theorem And_commute : forall A B : Prop,
  A /\ B -> B /\ A.
Proof.
  intros A B HAB. destruct HAB as [HA HB]. split.
  - apply HB.
  - apply HA.
  Qed.

Axiom le_trans : forall n m l,
  n <= m -> m <= l -> n <= l.

Axiom le_false : forall n,
  S n <= n -> False.

Theorem And_ex : forall n m,
  n <= m /\ m <= n -> n = m.
Proof.
  intros. destruct H as [H1 H2].
  inversion H1.
  - reflexivity.
  - subst. apply le_trans with (S m0) n m0 in H2.
    + apply le_false in H2. inversion H2.
    + apply H.
  Qed.

(* -- Or -- *)

(* Or is either a left type or right type.
   You can think it as disjoint union.
   More category theoritic explanation is sum. *)
Inductive DOr (A : Type) (B : Type) :=
| DLeft (a : A)
| DRight (b : B).

Theorem Or_left : forall A B : Prop,
  A -> A \/ B.
Proof.
  intros A B HA. left. apply HA. Qed.

Theorem Or_right : forall A B : Prop,
  B -> A \/ B.
Proof.
  intros A B HB. right. apply HB. Qed.

Theorem Or_Prove : forall A B C : Prop,
  (A -> C) -> (B -> C) -> (A \/ B) -> C.
Proof.
  intros A B C HAC HBC HAB.
  destruct HAB as [HA | HB].
  - apply HAC. apply HA.
  - apply HBC. apply HB.
  Qed.

Theorem Or_commute : forall A B : Prop,
  A \/ B -> B \/ A.
Proof.
  intros A B HAB.
  destruct HAB as [HA | HB].
  - right. apply HA.
  - left. apply HB.
  Qed.

Theorem Or_ex : forall n m,
  n < m \/ n = m \/ n > m.
Proof.
  intros. induction n.
  - destruct m.
    + right. left. reflexivity.
    + left. unfold lt. apply le_n_S. apply le_0_n.
  - destruct IHn as [H1 | [H2 | H3]].
    + unfold lt in H1. inversion H1.
      * right. left. reflexivity.
      * subst. left. unfold lt. apply le_n_S. apply H.
    + subst. right. right. unfold gt. unfold lt. apply le_n.
    + right. right. unfold gt in *. unfold lt in *.
      apply le_S. apply H3.
  Qed.

(* Forall *)

(* Forall is a dependent function.
   But to implement forall, you need to use forall. *)

(* And you've seen all the examples before! *)

(* Exists *)

(* Exists is a dependent pair. *)
Inductive DExists (A : Type) (t : A -> Type) :=
| DepPair (a : A) (b : t a).

Theorem nat_0_or_minus :
  forall (n : nat), n = 0 \/ exists n', n = S n'.
Proof.
  intro. destruct n.
  - left. reflexivity.
  - right. exists n. reflexivity.
  Qed.

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

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

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

Theorem even_spec :
  forall n, even n -> exists k, n = 2 * k.
Proof.
  intros n Heven. induction Heven.
  - exists 0. simpl. reflexivity.
  - destruct IHHeven as [k Hk]. rewrite Hk. exists (S k).
    simpl. apply eq_S. rewrite <- plus_n_O. apply plus_n_Sm.
  Qed.

Theorem le_spec :
  forall n m, n <= m -> exists k, m = n + k.
Proof.
  intros. induction H.
  - exists 0. apply plus_n_O.
  - destruct IHle as [k Hk].
    exists (S k). rewrite Hk. apply plus_n_Sm.
  Qed.

Check nat_ind.

(* Recursive Functions *)

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

(* add is recursively defined (decreasing on 1st argument) *)

Fail Fixpoint false_proof (n : nat) : False :=
  false_proof n.

(* Coinduction *)
CoInductive Seq : Type :=
| CCons (n : nat) (S : Seq) : Seq.

CoFixpoint increase (n : nat) : Seq :=
  CCons n (increase (S n)).

Fail CoFixpoint wrong (n : nat) : Seq :=
  wrong (S n).

(* Equality *)

(* Equality is Refl for all element of type. *)
Inductive DEqual (A : Type) :=
| DRefl (a : A).

Theorem eq_refl' : forall (A : Type) (a : A),
  a = a.
Proof.
  intros A a. reflexivity. Qed.

Theorem eq_sym' : forall (A : Type) (a b : A) (H : a = b),
  b = a.
Proof.
  intros A a b Heq. rewrite Heq. reflexivity. Qed.

Theorem eq_trans' : forall (A : Type) (a b c : A)
  (H1 : a = b) (H2 : b = c),
  a = c.
Proof.
  intros A a b c Heq1 Heq2. rewrite Heq1. apply Heq2. Qed.

Theorem homotopy_lifting_property :
  forall (A : Type) (a b : A) (P : A -> Prop),
  a = b -> P a -> P b.
Proof.
  intros A a b P Heq HPa. rewrite Heq in HPa. apply HPa. Qed.

(* What is unprovable? *)

Definition excluded_middle := forall P : Prop,
  P \/ ~ P.

Definition peirce := forall P Q: Prop,
  ((P->Q)->P)->P.

Definition double_negation_elimination := forall P:Prop,
  ~~P -> P.

Definition de_morgan_not_and_not := forall P Q:Prop,
  ~(~P /\ ~Q) -> P\/Q.

Definition implies_to_or := forall P Q:Prop,
  (P->Q) -> (~P\/Q).

Theorem em_irrefutable : forall P : Prop,
  ~~ (P \/ ~ P).
Proof.
  intros P H. apply H.
  right. intros p. apply H. left. apply p. Qed.

Require Export Coq.omega.Omega.

Theorem And_auto : forall n m,
  n <= m /\ m <= n -> n = m.
Proof.
  intros. omega. Qed.

Theorem Or_auto : forall n m,
  n < m \/ n = m \/ n > m.
Proof.
  intros. omega. Qed.


(** Exercise: 2 starsM (if_minus_plus_reloaded) **)

(** Fill in valid decorations for the following program:

   {{ True }}
  IFB X <= Y THEN
      {{ True /\ X <= Y }} ->>
      {{ Y = X + (Y - X) }}
    Z ::= Y - X
      {{ Y = X + Z }}
  ELSE
      {{ True /\ ~(X <= Y)}} ->>
      {{ (X + Z) = X + Z }}
    Y ::= X + Z
      {{ Y = X + Z }}
  FI
    {{ Y = X + Z }}
*)

(* 1 ->
{{ True /\ X <= Y }} ->>
      {{ Y = X + (Y - X) }}
Si X <= Y entonces Y-X > 0, e Y-X+X = Y

2 ->
{{ True /\ ~(X <= Y)}} ->>
      {{ (X + Z) = X + Z }}
Se sigue directamente.
*)

(** Exercise: 2 starsM (slow_assignment) **)

(** (slow_assignment)  *)
(** A roundabout way of assigning a number currently stored in [X] to
    the variable [Y] is to start [Y] at [0], then decrement [X] until
    it hits [0], incrementing [Y] at each step. Here is a program that
    implements this idea:

        {{ X = m }}
      Y ::= 0;;
      WHILE X <> 0 DO
        X ::= X - 1;;
        Y ::= Y + 1
      END
        {{ Y = m }}

    Write an informal decorated program showing that this procedure
    is correct. *)

(* FILL IN HERE *)
(* ESQUELETO *)
(**
      {{ X = m }} ->>
      {{ I [Y |-> 0] }}
      Y ::= 0;
      WHILE X <> 0 DO
          {{ I /\ X <> 0 }} ->>
          {{ I [Y |-> Y + 1] [X |-> X - 1] }}
        X ::= X - 1;;
          {{ I [Y |-> Y + 1]
        Y ::= Y + 1
          {{ I }}
      END
        {{ I /\ ~(X <> 0) }}
        {{ Y = m }}
**)
(* SOLUCION: Y+X=m *)
(**
      {{ X = m }}
      Y :: = 0
      {{ X = m /\ Y = 0 }} ->>
      {{ X + Y = m }}
      WHILE X <> 0 DO
          {{ Y + X = m /\ X <> 0 }} ->>
          {{ (Y + 1) + (X - 1) = m  }}
        X ::= X - 1;;
          {{ (Y + 1) + X = m }}
        Y ::= Y + 1
          {{ Y + X = m }}
      END
        {{ Y + X = m /\ ~ (X <> 0) }}
        {{ Y = m }}
**)

(** Exercise: 3 stars, optional (add_slowly_decoration) **)

(** ** Exercise: Slow Addition *)

(** **** Exercise: 3 stars, optional (add_slowly_decoration)  *)
(** The following program adds the variable X into the variable Z
    by repeatedly decrementing X and incrementing Z.

      WHILE X <> 0 DO
         Z ::= Z + 1;;
         X ::= X - 1
      END

    Following the pattern of the [subtract_slowly] example above, pick
    a precondition and postcondition that give an appropriate
    specification of [add_slowly]; then (informally) decorate the
    program accordingly. *)

(* FILL IN HERE *)
(**
      {{ X = m /\ Z = n }}
      WHILE X <> 0 DO
         Z ::= Z + 1;;
         X ::= X - 1
      END
      {{ Z = n + m }} **)

(* ESQUELETO: *)
(**
      {{ X = m /\ Z = n }} ->>
      {{ I }}
      WHILE X <> 0 DO
          {{ I /\ X <> 0 }}
          {{ I [X |-> X-1] [Z |-> Z +1 ] }}
         Z ::= Z + 1;;
          {{ I [X |-> X-1] }}
         X ::= X - 1
          {{ I }}
      END
      {{ I /\ ~ (X <> 0) }} ->>
      {{ Z = n + m }} **)

(* SOLUCION: I = Z + X = n + m *)
(**
      {{ X = m /\ Z = n }} ->>
      {{ Z + X = n + m }}
      WHILE X <> 0 DO
          {{ Z + X = n + m /\ X <> 0 }} ->>
          {{ (Z + 1) + (X - 1) = n + m }}
         Z ::= Z + 1;;
          {{ Z + (X - 1) = n + m }}
         X ::= X - 1
          {{ Z + X = n + m }}
      END
      {{ Z + X = n + m /\ ~ (X <> 0) }} ->>
      {{ Z = n + m }}
**)

(** Exercise: 3 stars, optional (add_slowly_decoration) **)

(** ** Exercise: Slow Addition *)

(** **** Exercise: 3 stars, optional (add_slowly_decoration)  *)
(** The following program adds the variable X into the variable Z
    by repeatedly decrementing X and incrementing Z.

      WHILE X <> 0 DO
         Z ::= Z + 1;;
         X ::= X - 1
      END

    Following the pattern of the [subtract_slowly] example above, pick
    a precondition and postcondition that give an appropriate
    specification of [add_slowly]; then (informally) decorate the
    program accordingly. *)

(* FILL IN HERE *)
(**
      {{ X = m /\ Z = n }}
      WHILE X <> 0 DO
         Z ::= Z + 1;;
         X ::= X - 1
      END
      {{ Z = n + m }} **)

(* ESQUELETO: *)
(**
      {{ X = m /\ Z = n }} ->>
      {{ I }}
      WHILE X <> 0 DO
          {{ I /\ X <> 0 }}
          {{ I [X |-> X-1] [Z |-> Z +1 ] }}
         Z ::= Z + 1;;
          {{ I [X |-> X-1] }}
         X ::= X - 1
          {{ I }}
      END
      {{ I /\ ~ (X <> 0) }} ->>
      {{ Z = n + m }} **)

(* SOLUCION: I = Z + X = n + m *)
(**
      {{ X = m /\ Z = n }} ->>
      {{ Z + X = n + m }}
      WHILE X <> 0 DO
          {{ Z + X = n + m /\ X <> 0 }} ->>
          {{ (Z + 1) + (X - 1) = n + m }}
         Z ::= Z + 1;;
          {{ Z + (X - 1) = n + m }}
         X ::= X - 1
          {{ Z + X = n + m }}
      END
      {{ Z + X = n + m /\ ~ (X <> 0) }} ->>
      {{ Z = n + m }}
**)

(** Exercise: 3 stars, optional (parity_formal) **)

(** Translate this proof to Coq. Refer to the reduce-to-zero example
    for ideas. You may find the following two lemmas useful: *)

Lemma parity_ge_2 : forall x,
  2 <= x ->
  parity (x - 2) = parity x.
Proof.
  induction x; intro. reflexivity.
  destruct x. inversion H. inversion H1.
  simpl. rewrite <- minus_n_O. reflexivity.
Qed.

Lemma parity_lt_2 : forall x,
  ~ 2 <= x ->
  parity (x) = x.
Proof.
  intros. induction x. reflexivity. destruct x. reflexivity.
    exfalso. apply H. omega.
Qed.

Theorem parity_correct : forall m,
    {{ fun st => st X = m }}
  WHILE BLe (ANum 2) (AId X) DO
    X ::= AMinus (AId X) (ANum 2)
  END
    {{ fun st => st X = parity m }}.
Proof.
  intros.
  eapply hoare_consequence_pre with (fun st => parity (st X) = parity m).
  eapply hoare_consequence_post.
  apply hoare_while.
  - eapply hoare_consequence_pre.
  apply hoare_asgn.
  intros st H. unfold assn_sub, t_update. simpl.
  inversion H. rewrite -> parity_ge_2.
  assumption.
  unfold bassn in H1.
  apply ble_nat_true in H1.
  assumption.
  - intros st [H1 H2].
    rewrite <- H1. symmetry. apply parity_lt_2.
    unfold not. intros. unfold bassn in H2; simpl in H2.
    destruct (st X). omega. destruct n. omega. apply H2. reflexivity.
  - intros st H. rewrite H; reflexivity.
Qed.

(** Exercise: 3 starsM (factorial) **)
(** Recall that [n!] denotes the factorial of [n] (i.e., [n! =
    1*2*...*n]).  Here is an Imp program that calculates the factorial
    of the number initially stored in the variable [X] and puts it in
    the variable [Y]:

    {{ X = m }}
  Y ::= 1 ;;
  WHILE X <> 0
  DO
     Y ::= Y * X ;;
     X ::= X - 1
  END
    {{ Y = m! }}

    Fill in the blanks in following decorated program:

    {{ X = m }} ->>
    {{ X! = m! }}
  Y ::= 1;;
    {{ X! * Y = m! }}
  WHILE X <> 0 DO
       {{ X! * Y = m! /\ X <> 0 }} ->>
       {{ (X - 1)! * Y*X = m! }}                                     }}
     Y ::= Y * X;;
       {{ (X - 1)! * Y = m! }}
     X ::= X - 1
       {{ X! * Y = m! }}                                }}
  END
    {{ X! * Y = m! ~ (X <> 0) }} ->>
    {{ Y = m! }}
*)

(** Exercise: 3 starsM (Min_Hoare) **)
(* ================================================================= *)
(** ** Exercise: Min *)

(** **** Exercise: 3 stars (Min_Hoare)  *)
(** Fill in valid decorations for the following program.
  For the [=>] steps in your annotations, you may rely (silently)
  on the following facts about min **)

  Lemma lemma1 : forall x y,
    (x=0 \/ y=0) -> min x y = 0.
  Lemma lemma2 : forall x y,
    min (x-1) (y-1) = (min x y) - 1.

(**
  plus standard high-school algebra, as always.

  {{ True }} ->>
  {{ min (a,b) = min (a,b) }}
  X ::= a;;
  {{ min (X,b) = min (a,b) }}
  Y ::= b;;
  {{ 0 + min (X,Y) = min (a,b) }}
  Z ::= 0;;
  {{ Z + min (X,Y) = min (a,b) }}
  WHILE (X <> 0 /\ Y <> 0) DO
      {{ Z + min (X,Y) = min (a,b)
            /\ X <> 0 /\ Y <> 0 }} ->>
      {{ Z+1 + min (X-1,Y-1) = min (a,b) }}
    X := X - 1;;
      {{ Z+1 + min (X,Y-1) = min (a,b) }}
    Y := Y - 1;;
      {{ Z+1 + min (X,Y) = min (a,b) }}
    Z := Z + 1
      {{ Z + min (X,Y) = min (a,b) }}
  END
    {{ Z + min (X,Y) = min (a,b)
              /\ (X = 0 \/ Y = 0) }} ->>
    {{ Z = min a b }}
*)

(* INVARIANTE: Z + min (X,Y) = min (a,b) *)

(* A lo largo del bucle, siempre se cumple
que al sumar Z conel mínimo de X e Y este valor
coincide con el mínimo de los valores iniciales
de X e Y (en este caso a y b).
Por eso probamos esta opcion *)

(** Exercise: 3 starsM (two_loops) **)
(** Here is a very inefficient way of adding 3 numbers:

  X ::= 0;;
  Y ::= 0;;
  Z ::= c;;
  WHILE X <> a DO
    X ::= X + 1;;
    Z ::= Z + 1
  END;;
  WHILE Y <> b DO
    Y ::= Y + 1;;
    Z ::= Z + 1
  END

    Show that it does what it should by filling in the blanks in the
    following decorated program.

    {{ True }} ->>
    {{ c = c }}
  X ::= 0;;
    {{ c = X + c }}
  Y ::= 0;;
    {{ c = X + Y + c }}
  Z ::= c;;
    {{ Z = X + Y + c }}
  WHILE X <> a DO
      {{ Z = X + Y + c /\ X <> a }} ->>
      {{ (Z+1) = (X+1) + Y + c }}
    X ::= X + 1;;
      {{ (Z+1) = X + Y + c }}
    Z ::= Z + 1
      {{ Z = X + Y + c }}
  END;;
    {{ Z = X + Y + c /\ X = a }} ->>
    {{ Z = a + Y + c }}
  WHILE Y <> b DO
      {{ Z = a + Y + c /\ Y <> b }} ->>
      {{ Z+1 = a + Y+1 + c }}
    Y ::= Y + 1;;
      {{ Z+1 = a + Y + c }}
    Z ::= Z + 1
      {{ Z = a + Y + c }}
  END
    {{ Z = a + Y + c /\ Y = b }} ->>
    {{ Z = a + b + c }}
*)

(** [] *)

(* INVARIANTE 1: Z = X + Y + c *)
(* INVARIANTE 2: Z = a + Y + c *)

(* Al final del primer bucle X vale a,
luego permanece invariante en el segundo.
Al final del segundo Y valdrá b,
pero Y y Z cambian.
La c siempre permanece inalterada *)

(** "EJERCICIO: " Power Series *)
(** Exercise: 4 stars, optional (dpow2_down) **)
(** Here is a program that computes the series:
    [1 + 2 + 2^2 + ... + 2^m = 2^(m+1) - 1]

  X ::= 0;;
  Y ::= 1;;
  Z ::= 1;;
  WHILE X <> m DO
    Z ::= 2 * Z;;
    Y ::= Y + Z;;
    X ::= X + 1
  END

    Write a decorated program for this. *)

(* FILL IN HERE *)

(* Haciendo cuentas en papel con ejemplos
llegamos a la posibilidad del siguiente
invariante:
  Y = 2 * Z - 1 /\ Z = 2 ^ X
*)
(*
    {{ True }} ->>
    {{ 1 = 1 /\ 1 = 2^0 }}
  X ::= 0;;
    {{ 1 = 1 /\ 1 = 2 ^ X  }}
  Y ::= 1;;
    {{ Y = 2 - 1 /\ 1 = 2 ^ X  }}
  Z ::= 1;;
    {{ Y = 2 * Z - 1 /\ Z = 2 ^ X  }}
  WHILE X <> m DO
      {{ Y = 2 * Z - 1 /\ Z = 2 ^ X
               /\ X <> m }} ->>
      {{ Y + 2 * Z = 2 * 2 * Z - 1
           /\ 2 * Z = 2 ^ (X + 1) }}
    Z ::= 2 * Z ;;
      {{ Y + Z = 2 * Z - 1
           /\ Z = 2 ^ (X + 1) }}
    Y ::= Y + Z;;
      {{ Y = 2 * Z - 1 /\ Z = 2 ^ (X + 1) }}
    X ::= X + 1
      {{ Y = 2 * Z - 1 /\ Z = 2 ^ X }}
  END
    {{ Y = 2 * Z - 1 /\ Z = 2 ^ X
           /\ X = m }} ->>
    {{ Y = 2 * Z - 1 /\ Z = 2 ^ m }}
*)

(* Efectivamente, y es la suma de las potencias
de 2 y, además, en la posconticion
se cumple que Y = 2*(m+1)-1.
Por lo tanto, este invariante es válido
(comprobando que, además,
se cumplen todas las implicaciones ->> *)

(** Exercise: 1 star, optional (wp) **)

(** "EJERCICIO: " **)
(** What are the weakest preconditions of the following commands
   for the following postconditions?

  1) {{ ? }}  SKIP  {{ X = 5 }}
      X = 5

  2) {{ ? }}  X ::= Y + Z {{ X = 5 }}
      Y + Z = 5

  3) {{ ? }}  X ::= Y  {{ X = Y }}
      True

  4) {{ ? }}
     IFB X == 0 THEN Y ::= Z + 1 ELSE Y ::= W + 2 FI
     {{ Y = 5 }}
      (X = 0 /\ Z = 4) \/ (X <> 0 /\ W = 3)

  5) {{ ? }}
     X ::= 5
     {{ X = 0 }}
      False

  6) {{ ? }}
     WHILE True DO X ::= 0 END
     {{ X = 0 }}
      True
*)

(** Exercise: 3 stars, advanced, optional (is_wp_formal) **)
(** Prove formally, using the definition of [hoare_triple], that [Y <= 4]
   is indeed the weakest precondition of [X ::= Y + 1] with respect to
   postcondition [X <= 5]. *)

Theorem is_wp_example :
  is_wp (fun st => st Y <= 4)
    (X ::= APlus (AId Y) (ANum 1)) (fun st => st X <= 5).
Proof.
  unfold is_wp. split.
  - eapply hoare_consequence_pre.
    apply hoare_asgn. intros st H.
    unfold assn_sub, t_update. simpl.
    omega.
  - intros P' H.
    unfold assert_implies. intros st HP'.
    unfold hoare_triple in H.
    apply H with
      (st' := t_update st X (st Y + 1)) in HP'.
    + unfold t_update in HP'. simpl in HP'.
      omega.
    + constructor. simpl. reflexivity.
Qed.

(** Exercise: 2 stars, advanced, optional (hoare_asgn_weakest) **)
(** Show that the precondition in the rule [hoare_asgn] is in fact the
    weakest precondition. *)

Theorem hoare_asgn_weakest : forall Q X a,
  is_wp (Q [X |-> a]) (X ::= a) Q.
Proof.
  intros Q X a.
  unfold is_wp. split.
  - apply hoare_asgn.
  - intros P' H. unfold assert_implies.
    intros st HP'.
    unfold hoare_triple in H.
    apply H with
      (st' := t_update st X (aeval st a)) in HP'.
    + apply HP'.
    + constructor. reflexivity.
Qed.

(** Exercise: 3 stars, advanced (slow_assignment_dec) **)
(** In the [slow_assignment] exercise above, we saw a roundabout way
    of assigning a number currently stored in [X] to the variable [Y]:
    start [Y] at [0], then decrement [X] until it hits [0],
    incrementing [Y] at each step.  Write a formal version of this
    decorated program and prove it correct. *)

(**
      {{ X = m }}
      Y :: = 0
      {{ X = m /\ Y = 0 }} ->>
      {{ X + Y = m }}
      WHILE X <> 0 DO
          {{ Y + X = m /\ X <> 0 }} ->>
          {{ (Y + 1) + (X - 1) = m  }}
        X ::= X - 1;;
          {{ (Y + 1) + X = m }}
        Y ::= Y + 1
          {{ Y + X = m }}
      END
        {{ Y + X = m /\ ~ (X <> 0) }}
        {{ Y = m }}
**)

Example slow_assignment_dec (m:nat) : dcom := (
    {{ fun st => st X = m }}
  Y ::= ANum 0
    {{ fun st => st X = m  /\ st Y = 0}} ->>
    {{ fun st => st X + st Y = m }} ;;
  WHILE BNot (BEq (AId X) (ANum 0))
  DO {{ fun st => st Y + st X = m /\ st X <> 0 }} ->>
     {{ fun st => (st Y + 1) + (st X - 1) = m }}
    X ::= AMinus (AId X) (ANum 1)
     {{ fun st => (st Y + 1) + st X = m }} ;;
    Y ::= APlus (AId Y) (ANum 1)
     {{ fun st => st Y + st X = m }}
  END
    {{ fun st => st Y + st X = m /\ st X = 0 }} ->>
    {{ fun st => st Y = m }}
) % dcom.

Theorem slow_assignment_dec_correct : forall m,
  dec_correct (slow_assignment_dec m).
Proof.
  intros m. verify. Qed.


From Coq Require Import List.
From StructTact Require Import StructTactics ListUtil.
From Coq Require Import OrderedType OrderedTypeEx.
Import ListNotations.

Set Implicit Arguments.

Fixpoint fin (n : nat) : Type :=
  match n with
    | 0 => False
    | S n' => option (fin n')
  end.

Fixpoint fin_eq_dec (n : nat) : forall (a b : fin n), {a = b} + {a <> b}.
  refine
   (match n with
      | 0 => fun a b : fin 0 => right (match b with end)
      | S n' => fun a b : fin (S n') =>
                 match a, b with
                   | Some a', Some b' =>
                     match fin_eq_dec n' a' b' with
                       | left _ _ => left _
                       | right _ _ => right _
                     end
                   | Some a', None => right _
                   | None, Some b' => right _
                   | None, None => left eq_refl
                 end
    end); congruence.
Defined.

Fixpoint all_fin (n : nat) : list (fin n) :=
  match n with
    | 0 => []
    | S n' => None :: map (fun x => Some x) (all_fin n')
  end.

Lemma all_fin_all :
  forall n (x : fin n),
    In x (all_fin n).
Proof.
  induction n; intros.
  - solve_by_inversion.
  - simpl in *. destruct x; auto using in_map.
Qed.

Lemma all_fin_NoDup :
  forall n, NoDup (all_fin n).
Proof.
  induction n; intros; simpl; constructor.
  - intro. apply in_map_iff in H. firstorder. discriminate.
  - apply NoDup_map_injective; auto. congruence.
Qed.

Fixpoint fin_to_nat {n : nat} : fin n -> nat :=
  match n with
  | 0 => fun x : fin 0 => match x with end
  | S n' => fun x : fin (S n') =>
             match x with
             | None => 0
             | Some y => S (fin_to_nat y)
             end
  end.

Definition fin_lt {n : nat} (a b : fin n) : Prop := lt (fin_to_nat a) (fin_to_nat b).

Lemma fin_lt_Some_elim :
  forall n (a b : fin n),
    @fin_lt (S n) (Some a) (Some b) -> fin_lt a b.
Proof.
  intros.
  unfold fin_lt.
  intuition auto with arith.
Qed.

Lemma fin_lt_Some_intro :
  forall n (a b : fin n),
    fin_lt a b -> @fin_lt (S n) (Some a) (Some b).
Proof.
  intros.
  unfold fin_lt. simpl.
  intuition auto with arith.
Qed.

Lemma None_lt_Some :
  forall n (x : fin n),
    @fin_lt (S n) None (Some x).
Proof.
  unfold fin_lt. simpl. auto with arith.
Qed.

Lemma fin_lt_trans :
  forall n (x y z : fin n),
    fin_lt x y -> fin_lt y z -> fin_lt x z.
Proof.
  induction n; intros.
  - destruct x.
  - destruct x, y, z; simpl in *;
    repeat match goal with
    | [ H : fin_lt (Some _) (Some _) |- _ ] => apply fin_lt_Some_elim in H
    | [ |- fin_lt (Some _) (Some _) ] => apply fin_lt_Some_intro
    end; eauto using None_lt_Some; solve_by_inversion.
Qed.

Lemma fin_lt_not_eq :
  forall n (x y : fin n),
    fin_lt x y -> x <> y.
Proof.
  induction n; intros.
  - destruct x.
  - destruct x, y;
    repeat match goal with
    | [ H : fin_lt (Some _) (Some _) |- _ ] => apply fin_lt_Some_elim in H
    | [ |- fin_lt (Some _) (Some _) ] => apply fin_lt_Some_intro
    end; try congruence.
    + specialize (IHn f f0). concludes. congruence.
    + solve_by_inversion.
Qed.

Fixpoint fin_compare_compat (n : nat) : forall (x y : fin n), Compare fin_lt eq x y :=
  match n with
    | 0 => fun x y : fin 0 => match x with end
    | S n' => fun x y : fin (S n') =>
               match x, y with
                 | Some x', Some y' =>
                   match fin_compare_compat n' x' y' with
                     | LT pf => LT (fin_lt_Some_intro pf)
                     | EQ pf => EQ (f_equal _ pf)
                     | GT pf => GT (fin_lt_Some_intro pf)
                   end
                 | Some x', None => GT (None_lt_Some n' x')
                 | None, Some y' => LT (None_lt_Some n' y')
                 | None, None => EQ eq_refl
               end
  end.

Module Type NatValue.
  Parameter n : nat.
End NatValue.

Module fin_OT_compat (Import N : NatValue) <: UsualOrderedType.
  Definition t := fin n.
  Definition eq := @eq (fin n).
  Definition lt := @fin_lt n.
  Definition eq_refl := @eq_refl (fin n).
  Definition eq_sym := @eq_sym (fin n).
  Definition eq_trans := @eq_trans (fin n).
  Definition lt_trans := @fin_lt_trans n.
  Definition lt_not_eq := @fin_lt_not_eq n.
  Definition compare := fin_compare_compat n.
  Definition eq_dec := fin_eq_dec n.
End fin_OT_compat.

From Coq Require Import Arith Orders.

Lemma fin_lt_irrefl :
  forall n, Irreflexive (@fin_lt n).
Proof.
  intros.
  unfold Irreflexive, complement, Reflexive, fin_lt.
  intros x.
  apply Nat.lt_irrefl.
Qed.

Lemma fin_lt_strorder :
  forall n, StrictOrder (@fin_lt n).
Proof.
  intros.
  apply (Build_StrictOrder _ (@fin_lt_irrefl n) (@fin_lt_trans n)).
Qed.

Lemma fin_lt_lt_compat :
  forall n, Proper (eq ==> eq ==> iff) (@fin_lt n).
Proof.
  intros; split; intros; repeat find_rewrite; assumption.
Qed.

Lemma CompSpec_Eq_Some :
  forall n' (x' y' : fin n'),
    CompSpec eq fin_lt x' y' Eq ->
    Some x' = Some y'.
Proof.
  intros.
  apply f_equal.
  solve_by_inversion.
Qed.

Lemma CompSpec_Lt :
  forall n' (x' y' : fin n'),
    CompSpec eq fin_lt x' y' Lt ->
    fin_lt x' y'.
Proof.
  intros.
  solve_by_inversion.
Qed.

Lemma CompSpec_Gt :
  forall n' (x' y' : fin n'),
    CompSpec eq fin_lt x' y' Gt ->
    fin_lt y' x'.
Proof.
  intros.
  solve_by_inversion.
Qed.

Fixpoint fin_compare (n : nat) :
  forall (x y : fin n), { cmp : comparison | CompSpec eq fin_lt x y cmp } :=
  match n with
    | 0 => fun x y : fin 0 => match x with end
    | S n' => fun x y : fin (S n') =>
             match x, y with
               | Some x', Some y' =>
                 match fin_compare n' x' y' with
                   | exist _ Lt Hc => exist _ Lt (CompLt _ _ (fin_lt_Some_intro (CompSpec_Lt Hc)))
                   | exist _ Eq Hc => exist _ Eq (CompEq _ _ (CompSpec_Eq_Some Hc))
                   | exist _ Gt Hc => exist _ Gt (CompGt _ _ (fin_lt_Some_intro (CompSpec_Gt Hc)))
                 end
               | Some x', None => exist _ Gt (CompGt _ _ (None_lt_Some n' x'))
               | None, Some y' => exist _ Lt (CompLt _ _ (None_lt_Some n' y'))
               | None, None => exist _ Eq (CompEq _ _ eq_refl)
             end
  end.

Module fin_OT (Import N : NatValue) <: UsualOrderedType.
  Definition t := fin n.
  Definition eq := @eq (fin n).
  Definition eq_equiv := @eq_equivalence (fin n).
  Definition lt := @fin_lt n.
  Definition lt_strorder := fin_lt_strorder n.
  Definition lt_compat := fin_lt_lt_compat n.
  Definition compare := fun x y => proj1_sig (fin_compare n x y).
  Definition compare_spec := fun x y => proj2_sig (fin_compare n x y).
  Definition eq_dec := fin_eq_dec n.
End fin_OT.

Fixpoint fin_of_nat (m n : nat) : fin n + {exists p, m = n + p} :=
  match n with
    | 0 => inright (ex_intro _ _ eq_refl)
    | S n' =>
      match m with
        | 0 => inleft None
        | S m' =>
          match fin_of_nat m' n' with
            | inleft f => inleft (Some f)
            | inright pf =>
              inright (match pf with
                         | ex_intro _ x H => ex_intro _ x (f_equal _ H)
                       end)
          end
    end
  end.

Lemma fin_of_nat_fin_to_nat :
  forall (n : nat) (a : fin n),
    fin_of_nat (fin_to_nat a) n = inleft a.
Proof.
  induction n; simpl; intuition.
  destruct a; simpl in *; auto.
  now rewrite IHn.
Qed.


Require Import Nat.
Require Import ZArith.
Require Import Lia.

Theorem thm1: forall n m,
 n <= m -> exists k, n + k = m.
intros n m H. generalize dependent n.
induction m as [| m' IH].
- intros n H. inversion H.
  exists 0. lia.
- intros n H.
  inversion H.
  exists 0. lia.
  apply IH in H1. destruct H1 as [k H1].
  exists (S k). lia.
Qed.


(* A stub library on generalized harmonic numbers. *)
From mathcomp Require Import all_ssreflect all_algebra.
Require Import tactics shift bigopz.

Import Order.TTheory GRing.Theory Num.Theory.

Local Open Scope ring_scope.

(* Definition of the generalized harmonic numbers, indexed by ints. *)
(* The first argument stays in nat. *)
Definition ghn (m : nat) (n : int) : rat :=
  \sum_(1 <= k < n + 1 :> int) (k %:Q ^ m)^-1.

Lemma ghn_Sn_inhom m n : n >= 0 ->
  ghn m (int.shift 1 n) = ghn m n + ((n%:Q + 1)^m)^-1.
Proof.
move=> pn.
rewrite /ghn int.shift2Z big_int_recr /= ?rmorphD //=.
by rewrite -ler_subl_addr.
Qed.

Lemma ghn_small (m : nat) (n : int) : n <= 0 -> ghn m n = 0.
Proof. by move=> hn; rewrite /ghn big_geqz // ger_addr. Qed.

Lemma ghn1 (m : nat) : ghn m 1 = 1.
Proof. by rewrite /ghn big_int_recr //= big_nil add0r exp1rz. Qed.

Lemma ghn_Sn2 m (n_ : int) (n := n_%:Q) :  n_ + 1 != 0 ->
  ghn m (int.shift 2 n_) =
    ((n + 1) ^ m / (n + 2%:Q) ^ m + 1) * ghn m (int.shift 1 n_)
    - (n + 1) ^ m / (n + 2%:Q) ^ m * ghn m n_.
Proof.
move=> pn2.
case: (leP n_ 0) => hn.
  rewrite [in X in _ = _ - X]ghn_small // mulr0 subr0.
  rewrite {}/n; case: n_ pn2 hn => [ [] //  _ _ | n hn2].
    rewrite -[int.shift  2 0]/(int.shift 1 (int.shift 1 0)) [LHS]ghn_Sn_inhom //.
    by rewrite !int.shift2Z !add0r exp1rz mulrDl !mul1r addrC ghn1 mulr1.
  case: n hn2 => [| n] hn //.
  by rewrite !ghn_small ?mulr0 // NegzE int.shift2Z addrC !subzSS add0r oppr_le0.
rewrite ?ghn_Sn_inhom ?ltW ?addr_gt0 //=.
rewrite int.shift2R -/n.
move: (ghn m n_) => x.
apply/eqP; rewrite -subr_eq0 -!addrA addr_eq0; apply/eqP.
elim: m => [|m ->]; first by field => //.
(* The ring tactic is not able to reason under (_ ^ m) where m is a variable:
   we have to expand (_ ^_.+1) and identify p2 and p3 by hand... *)
rewrite !exprSz.
by field; rewrite /= !expfz_eq0; ring_lia.
Qed.


Require Export Basics.

Module NatList.

Inductive natprod : Type :=
  pair : nat -> nat -> natprod.
Definition fst (p : natprod) : nat :=
  match p with
  | pair x y => x
  end.
Definition snd (p: natprod) : nat :=
  match p with
  | pair x y => y
  end.

Notation "( x , y )" := (pair x y).

Eval simpl in (fst (3,5)).

Definition fst' (p:natprod):nat:=
  match p with
  | (x,y)=>x
  end.
Definition snd' (p:natprod):nat:=
  match p with
  | (x,y)=>y
  end.

Definition swap_pair (p:natprod):natprod :=
  match p with
  | (x,y)=>(y,x)
  end.

Theorem surjective_pairing' : forall (n m : nat),
  (n,m) = (fst (n,m), snd (n,m)).
Proof.
  reflexivity.  Qed.

Theorem surjective_pairing_stuck : forall (p : natprod),
  p = (fst p, snd p).
Proof.
  simpl. (* Doesn't reduce anything! *)
Admitted.

Theorem surjective_pairing : forall (p : natprod),
  p = (fst p, snd p).
Proof.
  intros p.  destruct p as (n,m).  simpl.  reflexivity.  Qed.

Require Unicode.Utf8.

Theorem snd_fst_is_swap : ∀p:natprod,
  (snd p,fst p) = swap_pair p.
Proof.
  intros p.
  destruct p.
  simpl. reflexivity.
  Qed.

Theorem fst_swap_is_snd :∀p:natprod,
  fst (swap_pair p) = snd p.
Proof.
  intros p.
  destruct p.
  simpl. reflexivity.
  Qed.

Inductive natlist : Type :=
  | nil: natlist
  | cons: nat -> natlist -> natlist.

Definition mylist:=cons 1 (cons 2 (cons 3 nil)).

Notation "x :: l" := (cons x l) (at level 60, right associativity).
Notation "[ ]" := nil.
Notation "[ x , .. , y ]" := (cons x .. (cons y nil) ..).

Definition mylist1 := 1 :: (2 :: (3 :: nil)).
Definition mylist2 := 1 :: 2 :: 3 :: nil.
Definition mylist3 := [1,2,3].

Eval simpl in 1+2.

Eval simpl in 1+2::[3].

Fixpoint repeat (n count:nat):natlist:=
  match count with
  | 0=> nil
  | S count'=>n::(repeat n count')
  end.

Eval simpl in repeat 2 10.

Fixpoint length (l:natlist):nat:=
  match l with
  | nil =>0
  | h::t=>S (length t)
  end.

Eval simpl in length (repeat 2 19).

Fixpoint app (l1 l2:natlist) :natlist:=
  match l1 with
  | nil=>l2
  |h::t=>h::(app t l2)
  end.

Notation "x ++ y" := (app x y)
                     (right associativity, at level 60).

Example test_app1:             [1,2,3] ++ [4,5] = [1,2,3,4,5].
Proof. reflexivity.  Qed.
Example test_app2:             nil ++ [4,5] = [4,5].
Proof. reflexivity.  Qed.
Example test_app3:             [1,2,3] ++ nil = [1,2,3].
Proof. reflexivity.  Qed.

Definition hd (default:nat)(l:natlist):nat:=
  match l with
  | nil=>default
  | h::t =>h
  end.

Definition tail (l:natlist):natlist:=
  match l with
  |nil=>nil
  |h::t=>t
  end.

Example test_hd1:             hd 0 [1,2,3] = 1.
Proof. reflexivity.  Qed.
Example test_hd2:             hd 0 [] = 0.
Proof. reflexivity.  Qed.
Example test_tail:            tail [1,2,3] = [2,3].
Proof. reflexivity.  Qed.

Fixpoint nonzeros(l:natlist):natlist:=
  match l with
  | nil=>nil
  | 0::t=>nonzeros t
  | h::t=>h::nonzeros t
end.

Example test_nonzeros: nonzeros [0,1,0,2,3,0,0] = [1,2,3].
Proof. simpl. reflexivity. Qed.

Fixpoint oddmembers(l:natlist):natlist:=
  match l with
  |nil=>nil
  |h::t=> match oddb h with
          | true => h::oddmembers t
          | false => oddmembers t
          end
  end.

Example test_oddmembers: oddmembers [0,1,0,2,3,0,0] = [1,3].
Proof. simpl. reflexivity. Qed.

Fixpoint countoddmembers (l:natlist):nat:=
  match l with
  |nil=>0
  |h::t=>match oddb h with
         | true=> 1+countoddmembers t
         | false=>countoddmembers t
         end
   end.

Example test_countoddmembers1: countoddmembers [1,0,3,1,4,5] = 4.
 Proof. simpl. reflexivity. Qed.
Example test_countoddmembers2: countoddmembers [0,2,4] = 0.
 Proof. simpl. reflexivity. Qed.
Example test_countoddmembers3: countoddmembers nil = 0.
 Proof. simpl. reflexivity. Qed.

Fixpoint alternate (l1 l2 : natlist) : natlist :=
  match l1,l2 with
  | nil,l=>l
  | l,nil=>l
  | h1::t1,h2::t2=>h1::h2::alternate t1 t2
  end.

Example test_alternate1: alternate [1,2,3] [4,5,6] = [1,4,2,5,3,6].
  Proof. simpl. reflexivity. Qed.
Example test_alternate2: alternate [1] [4,5,6] = [1,4,5,6].
  Proof. simpl. reflexivity. Qed.
Example test_alternate3: alternate [1,2,3] [4] = [1,4,2,3].
  Proof. simpl. reflexivity. Qed.
Example test_alternate4: alternate [] [20,30] = [20,30].
  Proof. simpl. reflexivity. Qed.

Definition bag:=natlist.

Fixpoint count(v:nat)(s:bag):nat:=
  match s with
  |nil=>0
  |h::t =>
    match beq_nat v h with
    | true => 1+count v t
    | false => count v t
    end
  end.

Example test_count1: count 1 [1,2,3,1,4,1] = 3.
  Proof. simpl. reflexivity. Qed.
Example test_count2: count 6 [1,2,3,1,4,1] = 0.
  Proof. simpl. reflexivity. Qed.

Definition sum : bag -> bag -> bag := app.

Example test_sum1: count 1 (sum [1,2,3] [1,4,1]) = 3.
  Proof. simpl. reflexivity. Qed.

Definition add (v:nat) (s:bag) : bag := cons v s.

Example test_add1: count 1 (add 1 [1,4,1]) = 3.
  Proof. simpl. reflexivity. Qed.
Example test_add2: count 5 (add 1 [1,4,1]) = 0.
  Proof. simpl. reflexivity. Qed.

Definition member (v:nat) (s:bag) : bool :=
  negb (beq_nat 0 (count v s)).

Example test_member1: member 1 [1,4,1] = true.
  Proof. simpl. reflexivity. Qed.
Example test_member2: member 2 [1,4,1] = false.
  Proof. simpl. reflexivity. Qed.

Fixpoint remove_one (v:nat) (s:bag) : bag :=
  (* When remove_one is applied to a bag without the number to remove,
     it should return the same bag unchanged. *)
  match s with
  | nil => nil
  | h::t => match beq_nat v h with
            | true => t
            | false => h::remove_one v t
            end
  end.

Example test_remove_one1: count 5 (remove_one 5 [2,1,5,4,1]) = 0.
  Proof. simpl. reflexivity. Qed.
Example test_remove_one2: count 5 (remove_one 5 [2,1,4,1]) = 0.
  Proof. simpl. reflexivity. Qed.
Example test_remove_one3: count 4 (remove_one 5 [2,1,4,5,1,4]) = 2.
  Proof. simpl. reflexivity. Qed.
Example test_remove_one4:
  count 5 (remove_one 5 [2,1,5,4,5,1,4]) = 1.
  Proof. simpl. reflexivity. Qed.

Fixpoint remove_all (v:nat) (s:bag) : bag :=
  match s with
  |nil =>nil
  | h::t=>match beq_nat v h with
          | true => remove_all v t
          | false => h::remove_all v t
          end
  end.

Example test_remove_all1: count 5 (remove_all 5 [2,1,5,4,1]) = 0.
  Proof. simpl. reflexivity. Qed.
Example test_remove_all2: count 5 (remove_all 5 [2,1,4,1]) = 0.
  Proof. simpl. reflexivity. Qed.
Example test_remove_all3: count 4 (remove_all 5 [2,1,4,5,1,4]) = 2.
  Proof. simpl. reflexivity. Qed.
Example test_remove_all4: count 5 (remove_all 5 [2,1,5,4,5,1,4,5,1,4]) = 0.
  Proof. simpl. reflexivity. Qed.

Fixpoint subset (s1:bag) (s2:bag) : bool :=
  match s1 with
  |nil=>true
  |h::t => match member h s2 with
          | true => subset t (remove_one h s2)
          | false=> false
          end
  end.

Example test_subset1: subset [1,2] [2,1,4,1] = true.
  Proof. simpl. reflexivity. Qed.
Example test_subset2: subset [1,2,2] [2,1,4,1] = false.
  Proof. simpl. reflexivity. Qed.

Theorem count_nil:∀n:nat, count n []=0.
Proof. intros n. simpl. reflexivity. Qed.

Theorem add_nil:∀n:nat,add n []=[n].
Proof. intros n. simpl. reflexivity. Qed.

Theorem beq_true:∀n:nat,beq_nat n n=true.
Proof. intros. induction n.
 Case "n=0". simpl. reflexivity.
 Case"n=Sn".  simpl. rewrite->IHn. reflexivity. Qed.

Theorem bag_count_add:∀n:nat,∀s:bag,
count n (add n s)= S (count n s).
Proof.
  intros n s.
  induction n as [|n'].
  Case "n=0". simpl. reflexivity.
  Case "n=S n'". simpl. rewrite->beq_true. reflexivity.
Qed.

(**************** Reasoning About Lists ****************)

Theorem nil_app : ∀l:natlist,
  [] ++ l = l.
Proof.
   reflexivity. Qed.

Theorem tl_length_pred : ∀l:natlist,
  pred (length l) = length (tail l).
Proof.
  intros l. (* why not induction? ie induction l as [|l'].*)
 destruct l as [| n l'].
  Case "l = nil".
    reflexivity.
  Case "l = cons n l'".
    reflexivity. Qed.

(* ###################################################### *)
(** ** Induction on Lists *)

Theorem app_ass : ∀l1 l2 l3 : natlist,
  (l1 ++ l2) ++ l3 = l1 ++ (l2 ++ l3).
Proof.
  intros l1 l2 l3. induction l1 as [| n l1'].
  Case "l1 = nil".
    reflexivity.
  Case "l1 = cons n l1'".
    simpl. rewrite -> IHl1'. reflexivity. Qed.

Theorem app_length : ∀l1 l2 : natlist,
  length (l1 ++ l2) = (length l1) + (length l2).
Proof.
  (* WORKED IN CLASS *)
  intros l1 l2. induction l1 as [| n l1'].
  Case "l1 = nil". simpl.
    reflexivity.
  Case "l1 = cons".
    simpl. rewrite -> IHl1'. reflexivity. Qed.

(*Fixpoint rev (l:natlist):natlist :=
  match l with
  |nil=>nil
  |h::t=>rev t++cons h nil
end.*)

Fixpoint snoc (l:natlist) (v:nat) : natlist :=
  match l with
  | nil    => [v]
  | h :: t => h :: (snoc t v)
  end.

(** ... and use it to define a list-reversing function [rev]
    like this: *)

Fixpoint rev (l:natlist) : natlist :=
  match l with
  | nil    => nil
  | h :: t => snoc (rev t) h
  end.

Example test_rev1:            rev [1,2,3] = [3,2,1].
Proof. reflexivity.  Qed.
Example test_rev2:            rev nil = nil.
Proof. reflexivity.  Qed.

(** Now let's prove some more list theorems using our newly
    defined [snoc] and [rev].  For something a little more challenging
    than the inductive proofs we've seen so far, let's prove that
    reversing a list does not change its length.  Our first attempt at
    this proof gets stuck in the successor case... *)

Theorem rev_length_firsttry : forall l : natlist,
  length (rev l) = length l.
Proof.
  intros l. induction l as [| n l'].
  Case "l = []".
    simpl. reflexivity.
  Case "l = n :: l'".
    (* This is the tricky case.  Let's begin as usual by simplifying. *)
    simpl.
    (* Now we seem to be stuck: the goal is an equality involving
       [snoc], but we don't have any equations in either the
       immediate context or the global environment that have
       anything to do with [snoc]!

       We can make a little progress by using the IH to rewrite the
       goal... *)
    rewrite <- IHl'.
    (* ... but now we can't go any further. *)
Admitted.

(** So let's take the equation about [snoc] that would have
    enabled us to make progress and prove it as a separate lemma. *)

Theorem length_snoc : forall n : nat, forall l : natlist,
  length (snoc l n) = S (length l).
Proof.
  intros n l. induction l as [| n' l'].
  Case "l = nil".
    reflexivity.
  Case "l = cons n' l'".
    simpl. rewrite -> IHl'. reflexivity.  Qed.

(** Now we can complete the original proof. *)

Theorem rev_length : forall l : natlist,
  length (rev l) = length l.
Proof.
  intros l. induction l as [| n l'].
  Case "l = nil".
    reflexivity.
  Case "l = cons".
    simpl. rewrite -> length_snoc.
    rewrite -> IHl'. reflexivity.  Qed.

(** For comparison, here are informal proofs of these two theorems:

    _Theorem_: For all numbers [n] and lists [l],
       [length (snoc l n) = S (length l)].

    _Proof_: By induction on [l].

    - First, suppose [l = []].  We must show
        length (snoc [] n) = S (length []),
      which follows directly from the definitions of
      [length] and [snoc].

    - Next, suppose [l = n'::l'], with
        length (snoc l' n) = S (length l').
      We must show
        length (snoc (n' :: l') n) = S (length (n' :: l')).
      By the definitions of [length] and [snoc], this
      follows from
        S (length (snoc l' n)) = S (S (length l')),
]]
      which is immediate from the induction hypothesis. [] *)

(** _Theorem_: For all lists [l], [length (rev l) = length l].

    _Proof_: By induction on [l].

      - First, suppose [l = []].  We must show
          length (rev []) = length [],
        which follows directly from the definitions of [length]
        and [rev].

      - Next, suppose [l = n::l'], with
          length (rev l') = length l'.
        We must show
          length (rev (n :: l')) = length (n :: l').
        By the definition of [rev], this follows from
          length (snoc (rev l') n) = S (length l')
        which, by the previous lemma, is the same as
          S (length (rev l')) = S (length l').
        This is immediate from the induction hypothesis. [] *)

(** Obviously, the style of these proofs is rather longwinded
    and pedantic.  After the first few, we might find it easier to
    follow proofs that give a little less detail overall (since we can
    easily work them out in our own minds or on scratch paper if
    necessary) and just highlight the non-obvious steps.  In this more
    compressed style, the above proof might look more like this: *)

(** _Theorem_:
     For all lists [l], [length (rev l) = length l].

    _Proof_: First, observe that
       length (snoc l n) = S (length l)
     for any [l].  This follows by a straightforward induction on [l].
     The main property now follows by another straightforward
     induction on [l], using the observation together with the
     induction hypothesis in the case where [l = n'::l']. [] *)

(** Which style is preferable in a given situation depends on
    the sophistication of the expected audience and on how similar the
    proof at hand is to ones that the audience will already be
    familiar with.  The more pedantic style is a good default for
    present purposes. *)

Theorem snoc_append : ∀l:natlist, ∀n:nat,
  snoc l n = l ++ [n].
Proof.
  intros l n. induction l as [|n' l'].
  Case "l=[]". simpl. reflexivity.
  Case "l=n'::l'". simpl. rewrite <- IHl'. reflexivity. Qed.

SearchAbout rev.

(* ###################################################### *)
(** ** List Exercises, Part 1 *)

Theorem app_nil_end : ∀l : natlist,
  l ++ [] = l.
Proof.
 intros l. induction l as [|n l'].
  Case "l=[]". simpl. reflexivity.
  Case "l= n::l'".
    simpl. rewrite -> IHl'. reflexivity. Qed.

Theorem rev_id :∀n:nat,rev [n]=[n].
Proof. intros n. simpl. reflexivity. Qed.

Theorem rev_dist :∀l1 l2:natlist,
rev(l1++l2)=rev l2++rev l1.
Proof. intros l1 l2. induction l1 as [|n l1'].
  Case "l1=[]". simpl. rewrite->app_nil_end. reflexivity.
  Case "l1=n::l1'".
  simpl. rewrite->IHl1'.
  rewrite->snoc_append. rewrite->snoc_append.
  rewrite->app_ass. reflexivity. Qed.

Theorem rev_involutive : ∀l : natlist,
  rev (rev l) = l.
Proof.
 intros l. induction l as [|n l'].
 Case"l=[]". simpl. reflexivity.
 Case"l=n::l'".
 simpl. rewrite->snoc_append.
 rewrite->rev_dist. rewrite->IHl'. simpl. reflexivity. Qed.

Theorem distr_rev : ∀l1 l2 : natlist,
  rev (l1 ++ l2) = (rev l2) ++ (rev l1).
Proof.
  intros l1 l2. rewrite->rev_dist. reflexivity. Qed.

Theorem app_ass4 : ∀l1 l2 l3 l4 : natlist,
  l1 ++ (l2 ++ (l3 ++ l4)) = ((l1 ++ l2) ++ l3) ++ l4.
Proof.
  intros l1 l2 l3 l4.
 rewrite->app_ass. rewrite->app_ass. reflexivity. Qed.

Lemma nonzeros_length : ∀l1 l2 : natlist,
  nonzeros (l1 ++ l2) = (nonzeros l1) ++ (nonzeros l2).
Proof.
  intros l1 l2. induction l1 as [|n l1'].
  Case "l1=[]". simpl. reflexivity.
  Case "l1=n::l1'". induction n.
    SCase "n=0". simpl. rewrite->IHl1'. reflexivity.
    SCase "n=Sn". simpl. rewrite->IHl1'. reflexivity. Qed.

(* ###################################################### *)
(** ** List Exercises, Part 2 *)

Theorem cons_snoc_append:∀l1 l2:natlist,∀n1 n2:nat,
  cons n1 l1++snoc l2 n2 = snoc (cons n1 (l1++l2)) n2.
Proof.
  intros l1 l2 n1 n2. induction l1 as [|n1' l1'].
  Case "l1=[]". simpl. reflexivity.
  Case "l1=n1'::l1'".
  simpl.
  rewrite->snoc_append. rewrite->snoc_append. rewrite->app_ass.
  reflexivity. Qed.

Theorem count_member_nonzero : ∀s : bag,
  ble_nat 1 (count 1 (1 :: s)) = true.
Proof.
  intros s. induction s as [|n l].
  Case "s=[]". simpl. reflexivity.
  Case "s=n::l". simpl. reflexivity. Qed.

(** The following lemma about [ble_nat] might help you in the next proof. *)

Theorem ble_n_Sn : forall n,
  ble_nat n (S n) = true.
Proof.
  intros n. induction n as [| n'].
  Case "0".
    simpl.  reflexivity.
  Case "S n'".
    simpl.  rewrite IHn'.  reflexivity.  Qed.

Theorem remove_decreases_count: forall (s : bag),
  ble_nat (count 0 (remove_one 0 s)) (count 0 s) = true.
Proof.
 intros s. induction s as [|n l].
 simpl. reflexivity.
 destruct n. simpl. apply ble_n_Sn.
 simpl. apply IHl. Qed.

Theorem rev_nil: rev [] = [].
Proof. simpl. reflexivity. Qed.

(*
Theorem rev_inj_conv :∀l1 l2:natlist,not (l1=l2)-> not (rev l1=rev l2).
Proof.
  intros l1 l2. induction l1 as [|n1 l1'].
  Case "l1=[]". simpl. intros H. induction l2 as [|n2 l2']. rewrite->rev_nil.*)

(* skipping this for now until I learn more coq tactics *)

Theorem rev_rev:∀l l': natlist, l=l'->rev l = rev l'.
Proof. intros l l' H. rewrite ->H. reflexivity. Qed.

Theorem flip_rev:∀l l':natlist,
rev l = l' -> l = rev l'.
Proof.
  intros l l' H. apply rev_rev in H. SearchAbout rev. rewrite-> rev_involutive in H. apply H. Qed.

(*Theorem rev_nil_inj : ∀l:natlist,rev l=[] -> l=[].
Proof.
 intros l H.
 induction l as [|n l']. reflexivity.
 inversion H. inversion H1.
 reflexivity.
 simpl. rewrite->snoc_append. destruct l'. simpl. intros H. inversion H.
  simpl. rewrite->snoc_append.
 unfold app. intros H. inversion H. simpl.
 *)
(*Theorem snoc_rev : ∀l:natlist, ∀n:nat,*)

Theorem rev_injective : ∀l1 l2 : natlist, rev l1 = rev l2 -> l1 = l2.
Proof.
  intros l1 l2 H. apply rev_rev in H. rewrite->rev_involutive in H. rewrite->rev_involutive in H. apply H. Qed.