Definition peirce := forall P Q:Prop, ((P->Q)->P)->P.
Definition classic := forall P:Prop, ~~P -> P.
Definition excluded_middle := 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).

Lemma excluded_middle_peirce : excluded_middle -> peirce.
Proof.
 unfold peirce; intros H P Q H0.
 destruct (H P) as [p | np].
 -  assumption.
 -  apply H0; intro H1; now absurd P.
Qed.

Lemma peirce_classic : peirce -> classic.
Proof.
 intros HPeirce P H0; apply (HPeirce P False).
 intro H1; now destruct H0.
Qed.

Lemma classic_excluded_middle: classic -> excluded_middle.
Proof.
 unfold excluded_middle, classic; intros H P.
 apply H. intro H0. absurd P.
 -  intro H1. apply H0. now left.
 -  apply H; intro H1; apply H0; now right.
Qed.

Lemma excluded_middle_implies_to_or :  excluded_middle -> implies_to_or.
Proof.
 intros H P Q H0;
  destruct (H P) as [p | np].
  -  right; auto.
  - now  left.
Qed.

Lemma implies_to_or_excluded_middle : implies_to_or -> excluded_middle.
Proof.
 unfold excluded_middle; intros H P; destruct (H P P);auto.
Qed.

Lemma classic_de_morgan_not_and_not : classic ->
                                      de_morgan_not_and_not.
Proof.
 unfold de_morgan_not_and_not; intros H P Q H0.
 apply H.
 intro H1; apply H0; split;intro;apply H1; auto.
Qed.

Lemma de_morgan_not_and_not_excluded_middle : de_morgan_not_and_not ->
                                              excluded_middle.
Proof.
 unfold excluded_middle; intros H P.
 apply H; intros [H1 H2]; contradiction.
Qed.


Require Import Vector Arith Bool List Nat.

(** Remove the following axiom when you've finished all the exercises. This
axoim provides a value of any type to allow the file to compile and incomplete
expressions to be used.
 *)
Axiom fill_me : forall {X : Type}, X.

(** Definitions used in the exercises **)

Definition leq : nat -> nat -> Prop :=
  fun m n => exists k, k + m = n.

Definition Even : nat -> Prop :=
  fun n => exists k, n = 2 * k.

(** Exercise 1.1

State and prove that 3 is not less than 1.

 *)

Lemma three_not_leq_one : ~ (leq 3 1).
Proof.
  exact fill_me.
Qed.

(** Exercise 1.2

Prove that any natural number is not equal to its sucessor.

Hints:

1. The following facts are available in the library:

[[
   O_S: forall n : nat, 0 <> S n

   eq_add_S: forall n m : nat, S n = S m -> n = m
]]

You can find these facts using:

[[
   Search (0 = S _).
   Search (S _ = S _ -> _ = _).
]]

2. The notation <> corresponds to not. You can find this out using:
[[
   Locate "<>".
]]
 *)

Lemma n_not_S_n : forall n, n <> S n.
Proof.
  exact fill_me.
Qed.

(** Exercise 1.3

State and prove that for every Nat n, the successor of n is not less
than or equal to n.

*)

Lemma Sn_not_leq_n : forall n, ~ (leq (S n) n).
Proof.
  exact fill_me.
Qed.

(** Exercise 1.4

State and prove that 1 is not Even.

 *)

Lemma three_is_not_even : ~ (Even 1).
Proof.
  exact fill_me.
Qed.

(** Exercise 1.5

Using induction on a Vector, define a function called [rest] that
accepts any non-nil vector and returns a new vector with the first element
removed.

Hint:

Try to use the [induction] tactic on a vector. You'll probably need to define
an auxilliary function that plays the same role as the nested [ind-Vec] in
frame 15.74 of the little typer book.
 *)

Definition rest : forall E l, Vector.t E (S l) -> Vector.t E l.
  exact fill_me.
Qed.

(** Logical exercises **)

(** Exercise 1.6

Prove that the Principle of the Excluded Middle (PEM) is equivalent to using double
negation to prove a proposition.

Hint:

To prove that double negation imples excluded middle you'll need to use the evidence
for the double negation of the exluded middle, [double_neg_pem].
 *)

Definition double_neg_pem : forall X, ~~ (X \/ ~ X) :=
  fun X pem_false => (pem_false (or_intror (fun x => (pem_false (or_introl x))))).

(** NB: This theorem can be proved with only a single quantifier. The converse is not
true with a single quantifier. It's still possible to prove that excluded middle and double
negation are equivalent but quantifiers on both sides of the implication are required ([double_neg_imples_pem]) *)
Theorem pem_X_imples_double_neg_X : forall X, (X \/ ~ X) -> ((~~ X) -> X).
Proof.
  exact fill_me.
Qed.

Theorem pem_imples_double_neg : (forall X, (X \/ ~ X)) -> (forall Y, ((~~ Y) -> Y)).
Proof.
  exact fill_me.
Qed.

Theorem double_neg_implies_pem : (forall X, ((~~ X) -> X)) -> (forall Y, (Y \/ ~ Y)).
Proof.
  exact fill_me.
Qed.


From Coq Require Import Nat.

Inductive even: nat -> Prop :=
  | evenO : even  O
  | evenS : forall n, odd n -> even (S n)
  with
    odd  : nat -> Prop :=
    | oddS : forall n, even n -> odd (S n).

Theorem even_plus_four : forall n:nat, even n -> even (4 + n).
Proof.
 intros n H.
 elim H.
  - simpl. repeat constructor.
  - simpl. repeat constructor. assumption.
Qed.


Require Import ZArith.
Require Import Reals.
Require Import Flocq.Core.Fcore_Raux.
Require Import Flocq.Core.Fcore_defs.
Require Import Flocq.Core.Fcore_float_prop.
Require Import Flocq.Calc.Fcalc_ops.
Require Import Gappa_definitions.

Lemma float2_zero :
  forall e : Z, Float2 0 e = R0 :>R.
Proof.
intro e.
apply F2R_0.
Qed.

Definition Fopp2 (x : float2) :=
  Float2 (- Fnum x) (Fexp x).

Lemma Fopp2_correct :
  forall x : float2,
  Fopp2 x = (- x)%R :>R.
Proof.
intros x.
unfold float2R, Fopp2. simpl.
apply F2R_Zopp.
Qed.

Definition Fmult2 (x y : float2) :=
  Float2 (Fnum x * Fnum y) (Fexp x + Fexp y).

Definition Fmult2_correct :
  forall x y : float2,
  Fmult2 x y = (x * y)%R :>R.
Proof.
intros (mx, ex) (my, ey).
exact (F2R_mult radix2 (Float radix2 mx ex) (Float radix2 my ey)).
Qed.

Definition shl (m : Z) (d : positive) :=
 match m with
 | Z0 => Z0
 | Zpos p => Zpos (shift_pos d p)
 | Zneg p => Zneg (shift_pos d p)
 end.

Lemma float2_shl_correct :
  forall m e : Z, forall d : positive,
  Float2 (shl m d) (e - Zpos d) = Float2 m e :>R.
Proof.
intros m e d.
replace (shl m d) with (m * Zpower_pos 2 d)%Z.
unfold float2R.
rewrite (F2R_change_exp _ (e - Zpos d) _ e).
simpl.
now replace (e - (e - Zpos d))%Z with (Zpos d) by ring.
generalize (Zgt_pos_0 d).
omega.
rewrite Zmult_comm.
destruct m as [|m|m] ; simpl.
apply Zmult_0_r.
now rewrite shift_pos_correct.
change (Zneg (shift_pos d m)) with (- Zpos (shift_pos d m))%Z.
rewrite shift_pos_correct.
now rewrite Zopp_mult_distr_r.
Qed.

Definition Fshift2 (x y : float2) :=
 match (Fexp x - Fexp y)%Z with
 | Zpos p => (shl (Fnum x) p, Fnum y, Fexp y)
 | Zneg p => (Fnum x, shl (Fnum y) p, Fexp x)
 | Z0 => (Fnum x, Fnum y, Fexp x)
 end.

Lemma Fshift2_correct :
  forall x y : float2,
  match Fshift2 x y with
  | (mx, my, e) => Float2 mx e = x :>R /\ Float2 my e = y :>R
  end.
Proof.
intros (mx, ex) (my, ey).
unfold Fshift2. simpl.
assert (ex = ex - ey + ey)%Z by ring.
pattern ex at - 1 ; rewrite H.
destruct (ex - ey)%Z as [|d|d] ; repeat split.
rewrite <- (float2_shl_correct mx _ d).
now ring_simplify (Zpos d + ey - Zpos d)%Z.
rewrite Zplus_comm.
apply float2_shl_correct.
Qed.

Definition Fplus2 (x y : float2) :=
 match Fshift2 x y with
 | (mx, my, e) => Float2 (mx + my) e
 end.

Lemma Fplus2_correct :
  forall x y : float2,
  Fplus2 x y = (x + y)%R :>R.
Proof.
intros x y.
unfold Fplus2.
generalize (Fshift2_correct x y).
destruct (Fshift2 x y) as ((mx, my), e).
intros (Hx, Hy).
rewrite <- Hx, <- Hy.
unfold float2R, F2R. simpl.
rewrite Z2R_plus.
apply Rmult_plus_distr_r.
Qed.

Definition Fminus2 (x y : float2) :=
 match Fshift2 x y with
 | (mx, my, e) => Float2 (mx - my) e
 end.

Lemma Fminus2_correct :
  forall x y : float2,
  Fminus2 x y = (x - y)%R :>R.
Proof.
intros x y.
unfold Fminus2.
generalize (Fshift2_correct x y).
destruct (Fshift2 x y) as ((mx, my), e).
intros (Hx, Hy).
rewrite <- Hx, <- Hy.
unfold float2R, F2R. simpl.
rewrite Z2R_minus.
apply Rmult_minus_distr_r.
Qed.

Definition Fcomp2 (x y : float2) :=
 match Fshift2 x y with
 | (mx, my, _) => (mx ?= my)%Z
 end.

Lemma Fcomp2_correct :
  forall x y : float2,
  Fcomp2 x y = Rcompare x y.
Proof.
intros x y.
unfold Fcomp2.
generalize (Fshift2_correct x y).
destruct (Fshift2 x y) as ((mx, my), e).
intros (Hx, Hy).
rewrite <- Hx, <- Hy.
unfold float2R, F2R. simpl.
rewrite Rcompare_mult_r.
now rewrite Rcompare_Z2R.
apply bpow_gt_0.
Qed.

Lemma power_radix_pos :
  forall r e, (0 < powerRZ (P2R r) e)%R.
intros.
apply powerRZ_lt.
change (P2R r) with (Z2R (Zpos r)).
apply (Z2R_lt 0).
exact (refl_equal _).
Qed.

Definition Feq2 (x y : float2) :=
 match Fcomp2 x y with
 | Eq => true
 | _ => false
 end.

Lemma Feq2_correct :
  forall x y : float2,
  Feq2 x y = true -> x = y :>R.
Proof.
intros x y Hb.
apply Rcompare_Eq_inv.
rewrite <- Fcomp2_correct.
revert Hb.
unfold Feq2.
now case Fcomp2.
Qed.

Definition Flt2 (x y : float2) :=
 match Fcomp2 x y with
 | Lt => true
 | _ => false
 end.

Lemma Flt2_correct :
  forall x y : float2,
  Flt2 x y = true -> (x < y)%R.
Proof.
intros x y Hb.
apply Rcompare_Lt_inv.
rewrite <- Fcomp2_correct.
revert Hb.
unfold Flt2.
now case Fcomp2.
Qed.

Definition Fle2 (x y : float2) :=
 match Fcomp2 x y with
 | Gt => false
 | _ => true
 end.

Lemma Fle2_correct :
  forall x y : float2,
  Fle2 x y = true -> (x <= y)%R.
Proof.
intros x y Hb.
apply Rcompare_not_Gt_inv.
rewrite <- Fcomp2_correct.
intros H.
unfold Fle2 in Hb.
now rewrite H in Hb.
Qed.

Inductive Fle2_prop (x y : float2) : bool -> Prop :=
  | Fle2_true : (x <= y)%R -> Fle2_prop x y true
  | Fle2_false : (y < x)%R -> Fle2_prop x y false.

Lemma Fle2_spec :
  forall x y, Fle2_prop x y (Fle2 x y).
Proof.
intros x y.
case_eq (Fle2 x y) ; intros H.
apply Fle2_true.
apply Fle2_correct.
exact H.
generalize H. clear H.
unfold Fle2.
case_eq (Fcomp2 x y) ; try (intros ; discriminate).
intros H _.
apply Fle2_false.
apply Rcompare_Gt_inv.
now rewrite <- Fcomp2_correct.
Qed.

Definition Fis0 (x : float2) :=
 match (Fnum x) with
   Z0 => true
 | _ => false
 end.

Lemma Fis0_correct :
 forall x : float2,
 Fis0 x = true -> x = R0 :>R.
intros x.
unfold Fis0.
induction x.
induction Fnum ; intro H0 ; try discriminate.
apply float2_zero.
Qed.

Definition Fpos (x : float2) :=
 match (Fnum x) with
   Zpos _ => true
 | _ => false
 end.

Lemma Fpos_correct :
  forall x : float2,
  Fpos x = true -> (0 < x)%R.
Proof.
intros (m, e) H.
unfold float2R.
apply F2R_gt_0_compat. simpl.
revert H.
unfold Fpos. simpl.
now case m.
Qed.

Definition Fneg (x : float2) :=
 match (Fnum x) with
   Zneg _ => true
 | _ => false
 end.

Lemma Fneg_correct :
  forall x : float2,
  Fneg x = true -> (x < 0)%R.
Proof.
intros (m, e) H.
unfold float2R.
apply F2R_lt_0_compat. simpl.
revert H.
unfold Fpos. simpl.
now case m.
Qed.

Definition Fpos0 (x : float2) :=
 match (Fnum x) with
   Zneg _ => false
 | _ => true
 end.

Lemma Fpos0_correct :
  forall x : float2,
  Fpos0 x = true -> (0 <= x)%R.
Proof.
intros (m, e) H.
unfold float2R.
apply F2R_ge_0_compat. simpl.
revert H.
unfold Fpos. simpl.
now case m.
Qed.

Definition Fneg0 (x : float2) :=
 match (Fnum x) with
   Zpos _ => false
 | _ => true
 end.

Lemma Fneg0_correct :
  forall x : float2,
  Fneg0 x = true -> (x <= 0)%R.
Proof.
intros (m, e) H.
unfold float2R.
apply F2R_le_0_compat. simpl.
revert H.
unfold Fpos. simpl.
now case m.
Qed.

Definition Flt2_m1 f :=
  Flt2 (Float2 (-1) 0) f.

Lemma Flt2_m1_correct :
  forall f,
  Flt2_m1 f = true ->
  (-1 < f)%R.
Proof.
intros f Hb.
generalize (Flt2_correct _ _ Hb).
unfold float2R, F2R. simpl.
now rewrite Rmult_1_r.
Qed.

Definition Fle2_m1 f :=
  Fle2 (Float2 (-1) 0) f.

Lemma Fle2_m1_correct :
  forall f,
  Fle2_m1 f = true ->
  (-1 <= f)%R.
Proof.
intros f Hb.
generalize (Fle2_correct _ _ Hb).
unfold float2R, F2R. simpl.
now rewrite Rmult_1_r.
Qed.


From Coq Require Import Arith.
From Coq Require Import Lt.
From Coq Require Export Setoid.
From Coq Require Lia.
Set Implicit Arguments.
Set Strict Implicit.

(** * 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.

Arguments full : clear implicits.
Arguments empty : clear implicits.

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

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

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

Hint Resolve equiv_refl: core.
Hint Immediate equiv_sym: core.

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

Add Relation set equiv
  reflexivity proved by equiv_refl
  symmetry proved by equiv_sym
  transitivity proved by equiv_trans
as Set_setoid.

Add Parametric Morphism a : (add a)
with signature (equiv ==> equiv) as equiv_add.
unfold equiv,add; firstorder.
Qed.

Add Parametric Morphism a : (rem a)
with signature (equiv ==> equiv) as equiv_rem.
unfold equiv,rem; firstorder.
Qed.
Hint Resolve equiv_add equiv_rem: core.

Add Morphism union
 with signature (equiv ==> equiv ==> equiv) as equiv_union.
unfold equiv,union; firstorder.
Qed.
Hint Immediate equiv_union: core.

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

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

Hint Resolve equiv_union_left equiv_union_right: core.

Add Morphism inter
 with signature (equiv ==> equiv ==> equiv) as equiv_inter.
unfold equiv,inter; firstorder.
Qed.
Hint Immediate equiv_inter: core.

Add Morphism compl
 with signature (equiv ==> equiv) as equiv_compl.
unfold equiv,union; firstorder.
Qed.
Hint Resolve equiv_compl: core.

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

(** ** 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: core.

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: core.

(** *** 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.
Qed.

(** *** 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  _ 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.
Qed.

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

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

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

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

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

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

Hint Resolve incl_refl incl_trans equiv_incl_intro: core.
Hint Immediate equiv_incl equiv_incl_sym: core.

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

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

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

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

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

Hint Immediate incl_empty_false equiv_empty_false incl_add_empty: core.

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

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

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

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

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

Hint Immediate incl_rem_add incl_add_rem: core.

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

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

Hint Immediate equiv_rem_add equiv_add_rem: core.

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

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

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

Hint Resolve add_rem_eq_equiv add_rem_diff_equiv add_equiv_in: core.

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

Hint Resolve add_rem_equiv_in: core.

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

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

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

Hint Resolve rem_add_eq_equiv rem_add_diff_equiv rem_equiv_notin: core.

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

Hint Resolve rem_add_equiv_notin: core.

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

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

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

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

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

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

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

Hint Resolve rem_not_in add_in rem_incl add_incl: core.

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

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

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

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

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

Hint Resolve union_sym union_empty_left union_empty_right
union_add_left union_add_right : core.

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

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

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

Hint Resolve union_incl_left union_incl_right union_incl_intro: core.

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.
Qed.
Hint Immediate incl_union_stable: core.

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

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

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

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

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

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

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

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 : core.

(** ** 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.
Qed.

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

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

(** ** 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.
Qed.

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

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

(** ** 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.
Qed.

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

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

(** *** 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.
Qed.

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

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

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

(** *** 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). auto with arith. apply H.
exists x; destruct FP; simpl in H.
absurd (1<1); auto with arith.
exists x0; intuition.
case (e x); auto.
case (e0 x0); case (e x0); unfold add; intuition.
subst; case (e0 x0); intuition.
Qed.

End sets.

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

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

Hint Constructors finite: core.
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 : core.
Arguments full : clear implicits.
Arguments empty : clear implicits.

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.


Lemma L1: 6*6 = 9*4.
Proof.
  reflexivity.
Qed.

Require Import ZArith.
Open Scope Z_scope.

(* you cannot use 'reflexivity here', a b are free variables
unlike 6 9 4 and no reduction can take place, not unification *)

Lemma diff_of_squares : forall a b:Z, (a+b)*(a-b) = a*a - b*b.
Proof.
  intros. ring.
Qed.

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

Check Zmult_plus_distr_l. (* forall n m p : Z, (n + m) * p = n * p + m * p *)
Check Zmult_1_l.          (* forall n : Z, 1 * n = n *)

Theorem Zmult_distr_1 : forall n x:Z, n*x+x = (n+1)*x.
Proof.
  intros n x.
  (*
  ring.
  *)
  rewrite Zmult_plus_distr_l.
  rewrite Zmult_1_l.
  reflexivity.
Qed.

(* can also use 'rewrite ... in H', 'rewrite -> ... in H' or 'rewrite <- ... in H' *)

Theorem regroup : forall x:Z, x+x+x+x+x = 5*x.
Proof.
(*
  intro x. ring.
*)
  intro. pattern x at 1. rewrite <- Zmult_1_l.
  repeat rewrite Zmult_distr_1.
  reflexivity.
Qed.

Open Scope nat_scope.
Check plus_comm.  (* forall n m : nat, n + m = m + n *)
Check plus_assoc. (* forall n m p : nat, n + (m + p) = n + m + p *)

Theorem plus_permute2: forall n m p:nat, n+m+p = n+p+m.
Proof.
  intros n m p. rewrite <- plus_assoc. rewrite plus_comm with (n:=m)(m:=p).
  rewrite plus_assoc. reflexivity.
Qed.

Lemma le_lt_S_eq : forall n p:nat, n <= p -> p < S n -> n = p.
Proof.
  intros n p. omega. (* we ll see this tactic later *)
Qed.

Check plus_lt_reg_l. (* forall n m p : nat, p + n < p + m -> n < m *)
Check plus_le_reg_l. (* forall n m p : nat, p + n <= p + m -> n <= m *)
Check plus_comm. (* forall n m : nat, n + m = m + n *)

Lemma cond_rewrite_example : forall n:nat,
  8 <= n+6 -> 3+n < 6 -> n*n = n+n.
Proof.
  intros n H0 H1.
  rewrite <- le_lt_S_eq with (p:=n)(n:=2).
  reflexivity.
  apply plus_le_reg_l with (p:=6).
  rewrite plus_comm with (n:=6)(m:=n). exact H0.
  apply plus_lt_reg_l with (p:=3). exact H1.
Qed.

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

Theorem eq_trans1 : forall (A:Type)(x y z:A), x = y -> y = z -> x = z.
Proof.
  intros A x y z eq_xy eq_yz.
  apply eq_ind with (y:=z)(x:=y)(P:= fun u => x = u).
  exact eq_xy. exact eq_yz.
Qed.

Theorem eq_trans2 : forall (A:Type)(x y z:A), x = y -> y = z -> x = z.
Proof.
  intros A x y z eq_xy eq_yz.
  rewrite <- eq_yz. exact eq_xy.
Qed.

Check Zmult_1_l. (* forall n : Z, (1 * n)%Z = n *)
SearchRewrite (1 * _).
(*
mult_1_l: forall n : nat, 1 * n = n
*)

SearchRewrite (1 * _)%Z. (* fail *)

Open Scope Z_scope.
SearchRewrite (1 * _). (* fail *)


Set Warnings "-notation-overridden,-parsing".
From LF Require Export Poly.

(* ################################################################# *)
(** * The [apply] Tactic *)

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.

(** **** Exercise: 2 stars, standard, optional (silly_ex)

    Complete the following proof without using [simpl]. *)

Theorem silly_ex :
     (forall n, evenb n = true -> oddb (S n) = true) ->
      evenb 4 = true ->
      oddb 3 = true.
Proof.
  intros eq1 eq2.
  apply eq1. apply eq2.
Qed.
(** [] *)

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

(** **** Exercise: 3 stars, standard (apply_exercise1)

    (_Hint_: You can use [apply] with previously defined lemmas, not
    just hypotheses in the context.  Remember that [Search] is
    your friend.) *)

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

(** **** Exercise: 1 star, standard, optional (apply_rewrite)

    Briefly explain the difference between the tactics [apply] and
    [rewrite].  What are the situations where both can usefully be
    applied? *)
(*
rewrite 是重写，而apply是应用定理
*)
(* ################################################################# *)

(** * The [apply with] Tactic *)

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.

(** **** Exercise: 3 stars, standard, optional (apply_with_exercise)  *)
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.
  -apply eq2.
  -apply eq1.
Qed.

(** [] *)

(* ################################################################# *)
(** * The [injection] and [discriminate] Tactics *)

Theorem S_injective : forall (n m : nat),
  S n = S m ->
  n = m.
Proof.
  intros n m H1.
  assert (H2: n = pred (S n)). { reflexivity. }
  rewrite H2. rewrite H1. reflexivity.
Qed.

Theorem S_injective' : forall (n m : nat),
  S n = S m ->
  n = m.
Proof.
  intros n m H.
  injection H. intros Hnm. apply Hnm.
Qed.

(** Here's a more interesting example that shows how [injection] can
    derive multiple equations at once. *)

Theorem injection_ex1 : forall (n m o : nat),
  [n; m] = [o; o] ->
  [n] = [m].
Proof.
  intros n m o H.
  injection H. intros H1 H2.
  rewrite H1. rewrite H2. reflexivity.
Qed.

Theorem injection_ex2 : forall (n m : nat),
  [n] = [m] ->
  n = m.
Proof.
  intros n m H.
  injection H as Hnm. rewrite Hnm.
  reflexivity. Qed.

(** **** Exercise: 1 star, standard (injection_ex3)  *)
Example injection_ex3 : forall (X : Type) (x y z : X) (l j : list X),
  x :: y :: l = z :: j ->
  y :: l = x :: j ->
  x = y.
Proof.
  intros X x y z l j H1 H2.
  injection H2 as H3 H4.
  symmetry.
  apply H3.
Qed.
(** [] *)

Theorem eqb_0_l : forall n,
   0 =? n = true -> n = 0.
Proof.
  intros n.
  destruct n as [| n'] eqn:E.
  - (* n = 0 *)
    intros H. reflexivity.
  - (* n = S n' *)
    simpl.
    intros H. discriminate H.
Qed.

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

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

(** **** Exercise: 1 star, standard (discriminate_ex3)  *)
Example discriminate_ex3 :
  forall (X : Type) (x y z : X) (l j : list X),
    x :: y :: l = [] ->
    x = z.
Proof.
  intros X x y z l j H1.
  discriminate H1.
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.

(* ################################################################# *)
(** * Using Tactics on Hypotheses *)

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

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

Theorem double_injective : forall n m,
     double n = double m ->
     n = m.
Proof.
  intros n. induction n as [| n'].
  - (* n = O *) simpl. intros m eq. destruct m as [| m'] eqn:E.
    + (* m = O *) reflexivity.
    + (* m = S m' *) discriminate eq.

  - (* n = S n' *) simpl.
    intros m eq.
    destruct m as [| m'] eqn:E.
    + (* m = O *) simpl.
      discriminate eq.
    + (* m = S m' *)
      apply f_equal.
      apply IHn'. injection eq as goal. apply goal. Qed.

(** **** Exercise: 2 stars, standard (eqb_true)  *)
Lemma injective_S : forall n m,
  n=m -> S n = S m.
Proof.
  intros n m H.
  rewrite -> H.
  reflexivity.
Qed.
Theorem eqb_true : forall n m,
    n =? m = true -> n = m.
Proof.
  intros n. induction n as [|n' ].
  -simpl. intros m eq. destruct m.
    + reflexivity.
    + discriminate eq.
  -simpl. intros m eq. destruct m.
    + discriminate eq.
    + apply injective_S. apply IHn'. apply eq.
Qed.
(** [] *)

Definition manual_grade_for_informal_proof : option (nat*string) := None.
(** **** Exercise: 3 stars, standard, recommended (plus_n_n_injective)

    Practice using "in" variants in this proof.  (Hint: use
    [plus_n_Sm].) *)

Theorem plus_n_n_injective : forall n m,
     n + n = m + m ->
     n = m.
Proof.
  intros n. induction n as [| n'].
  -simpl. intros m eq. destruct m.
    + reflexivity.
    + discriminate eq.
  -simpl. intros m eq. destruct m.
    + discriminate eq.
    + apply f_equal. apply IHn'. simpl in eq. apply S_injective' in eq.
      rewrite <- plus_n_Sm in eq.
      rewrite <- plus_n_Sm in eq.
      apply S_injective' in eq.
      apply eq.
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'].
  - (* m = O *) simpl. intros n eq. destruct n as [| n'] eqn:E.
    + (* n = O *) reflexivity.
    + (* n = S n' *) discriminate eq.
  - (* m = S m' *) intros n eq. destruct n as [| n'] eqn:E.
    + (* n = O *) discriminate eq.
    + (* n = S n' *) apply f_equal.
      apply IHm'. injection eq as goal. apply goal. Qed.

Theorem eqb_id_true : forall x y,
  eqb_id x y = true -> x = y.
Proof.
  intros [m] [n]. simpl. intros H.
  assert (H' : m = n). { apply eqb_true. apply H. }
  rewrite H'. reflexivity.
Qed.

(** **** Exercise: 3 stars, standard, recommended (gen_dep_practice)

    Prove this by induction on [l]. *)

Theorem nth_error_after_last: forall (n : nat) (X : Type) (l : list X),
     length l = n ->
     nth_error l n = None.
Proof.
  intros n X l.
  generalize dependent n.
  induction l.
  -simpl. intros n eq. destruct n.
    +reflexivity.
    +discriminate eq.
  -simpl. intros n eq. destruct n.
    +discriminate eq.
    +apply IHl. apply S_injective' in eq. rewrite -> eq. reflexivity.
Qed.
(** [] *)

(* ################################################################# *)
(** * Unfolding Definitions *)

Definition square n := n * n.

(** ... and try to prove a simple fact about [square]... *)

Lemma square_mult : forall n m, square (n * m) = square n * square m.
Proof.
  intros n m.
  simpl.
  unfold square.
  rewrite mult_assoc.
  assert (H : n * m * n = n * n * m).
    { rewrite mult_comm. apply mult_assoc. }
  rewrite H. rewrite mult_assoc. reflexivity.
Qed.

Definition foo (x: nat) := 5.

Fact silly_fact_1 : forall m, foo m + 1 = foo (m + 1) + 1.
Proof.
  intros m.
  simpl.
  reflexivity.
Qed.

Definition bar x :=
  match x with
  | O => 5
  | S _ => 5
  end.

(** ...then the analogous proof will get stuck: *)

Fact silly_fact_2 : forall m, bar m + 1 = bar (m + 1) + 1.
Proof.
  intros m.
  destruct m eqn:E.
  - simpl. reflexivity.
  - simpl. reflexivity.
Qed.

Fact silly_fact_2' : forall m, bar m + 1 = bar (m + 1) + 1.
Proof.
  intros m.
  unfold bar.
  destruct m eqn:E.
  - reflexivity.
  - reflexivity.
Qed.

(* ################################################################# *)
(** * Using [destruct] on Compound Expressions *)

Definition sillyfun (n : nat) : bool :=
  if n =? 3 then false
  else if n =? 5 then false
  else false.

Theorem sillyfun_false : forall (n : nat),
  sillyfun n = false.
Proof.
  intros n. unfold sillyfun.
  destruct (n =? 3) eqn:E1.
    - (* n =? 3 = true *) reflexivity.
    - (* n =? 3 = false *) destruct (n =? 5) eqn:E2.
      + (* n =? 5 = true *) reflexivity.
      + (* n =? 5 = false *) reflexivity.  Qed.

(** **** Exercise: 3 stars, standard, optional (combine_split)

    Here is an implementation of the [split] function mentioned in
    chapter [Poly]: *)

Fixpoint split {X Y : Type} (l : list (X*Y))
               : (list X) * (list Y) :=
  match l with
  | [] => ([], [])
  | (x, y) :: t =>
      match split t with
      | (lx, ly) => (x :: lx, y :: ly)
      end
  end.

(** Prove that [split] and [combine] are inverses in the following
    sense: *)

Theorem combine_split : forall X Y (l : list (X * Y)) l1 l2,
  split l = (l1, l2) ->
  combine l1 l2 = l.
Proof.
  intros X Y l.
  induction l as[|x l].
  -intros l1 l2 H.
    simpl in H. injection H as H1 H2. rewrite <-H1. rewrite <- H2. reflexivity.
  -intros l1 l2 H.
    destruct x as [a b].
    simpl in H.
    destruct (split l) as [lx ly].
    inversion H.
    simpl.
    assert(H': combine lx ly=l). { apply (IHl lx ly). reflexivity. }
    rewrite H'.
    reflexivity.
Qed.

(** [] *)

Definition sillyfun1 (n : nat) : bool :=
  if n =? 3 then true
  else if n =? 5 then true
  else false.

Theorem sillyfun1_odd : forall (n : nat),
     sillyfun1 n = true ->
     oddb n = true.
Proof.
  intros n eq. unfold sillyfun1 in eq.
  destruct (n =? 3) eqn:Heqe3.
  (* Now we have the same state as at the point where we got
     stuck above, except that the context contains an extra
     equality assumption, which is exactly what we need to
     make progress. *)
    - (* e3 = true *) apply eqb_true in Heqe3.
      rewrite -> Heqe3. reflexivity.
    - (* e3 = false *)
     (* When we come to the second equality test in the body
        of the function we are reasoning about, we can use
        [eqn:] again in the same way, allowing us to finish the
        proof. *)
      destruct (n =? 5) eqn:Heqe5.
        + (* e5 = true *)
          apply eqb_true in Heqe5.
          rewrite -> Heqe5. reflexivity.
        + (* e5 = false *) discriminate eq.  Qed.

(** **** Exercise: 2 stars, standard (destruct_eqn_practice)  *)
Theorem bool_fn_applied_thrice :
  forall (f : bool -> bool) (b : bool),
  f (f (f b)) = f b.
Proof.
  intros f b.
  destruct (f b) eqn:Bool.
  -destruct b eqn:Bool1.
    +rewrite -> Bool. rewrite -> Bool. reflexivity.
    + destruct (f true) eqn:Bool2.
      {rewrite-> Bool2. reflexivity. }
      {rewrite->Bool. reflexivity. }
  -destruct b eqn:flag.
    + destruct (f false) eqn:flag1.
      {rewrite ->Bool. reflexivity. }
      {rewrite ->flag1. reflexivity. }
    +rewrite -> Bool. rewrite -> Bool. reflexivity.
Qed.
(** [] *)

(* ################################################################# *)
(** * Additional Exercises *)

(** **** Exercise: 3 stars, standard (eqb_sym)  *)
Theorem eqb_sym : forall (n m : nat),
  (n =? m) = (m =? n).
Proof.
  intros n m.
  destruct (n=?m) eqn:flag.
  -apply eqb_true in flag. rewrite -> flag. rewrite <- eqb_refl. reflexivity.
  -destruct (m=?n) eqn:flag1.
    + apply eqb_true in flag1. rewrite ->flag1 in flag. rewrite <- eqb_refl in flag. discriminate flag.
    +reflexivity.
Qed.
(** [] *)

(** **** Exercise: 3 stars, advanced, optional (eqb_sym_informal)

    Give an informal proof of this lemma that corresponds to your
    formal proof above:

   Theorem: For any [nat]s [n] [m], [(n =? m) = (m =? n)].

   Proof: *)
   (* FILL IN HERE

    [] *)

(** **** Exercise: 3 stars, standard, optional (eqb_trans)  *)
Theorem eqb_trans : forall n m p,
  n =? m = true ->
  m =? p = true ->
  n =? p = true.
Proof.
  intros  n m p H1 H2.
  apply eqb_true in H1.
  apply eqb_true in H2.
  rewrite -> H2 in H1.
  rewrite -> H1.
  rewrite <- eqb_refl.
  reflexivity.
Qed.

(** [] *)

(** **** Exercise: 3 stars, advanced (split_combine)  *)

Definition split_combine_statement : Prop :=
  (* ("[: Prop]" means that we are giving a name to a
     logical proposition here.) *)
  forall( X Y:Type) (l1 :list X) (l2 :list Y),length l1 = length l2 -> split (combine l1 l2)=(l1,l2).

Theorem split_combine : split_combine_statement.
Proof.
  intros X Y l1.
  induction l1.
  -intros l2.
    intros H.  destruct l2 eqn: H1.
    +reflexivity.
    +discriminate H.
  -intros l2.
    intros H. destruct l2 eqn: H1.
    +discriminate H.
    +simpl in H. apply S_injective in H. simpl. rewrite -> IHl1. reflexivity. apply H.
Qed.
(* Do not modify the following line: *)
Definition manual_grade_for_split_combine : option (nat*string) := None.
(** [] *)

(** **** Exercise: 3 stars, advanced (filter_exercise)

    This one is a bit challenging.  Pay attention to the form of your
    induction hypothesis. *)

Lemma eq_len: forall (X:Type) (l1 l2: list X),
  l1=l2 -> length l1 =length l2.
Proof.
  intros X l1 l2.
  intros H.
  rewrite ->H.
  reflexivity.
Qed.
Lemma eq_empty: forall (X:Type) (test : X-> bool) (l :list X),
  length l=0 -> filter test l=[].
Proof.
  intros X test l.
  induction l.
  - reflexivity.
  - intros H. discriminate H.
Qed.
Theorem filter_exercise : forall (X : Type) (test : X -> bool)
                             (x : X) (l lf : list X),
     filter test l = x :: lf ->
     test x = true.
Proof.
  intros X test x l lf H.
  induction l as [|y l].
  -simpl in H.
   discriminate H.
  -simpl in H.
   destruct (test y) eqn:H1.
   +injection H as H2.
    rewrite -> H2 in H1.
    apply H1.
   +apply IHl.
    apply H.
Qed.

(** [] *)

(** **** Exercise: 4 stars, advanced, recommended (forall_exists_challenge)  *)

Fixpoint forallb {X : Type} (test : X -> bool) (l : list X) : bool:=
  match l with
  |nil =>true
  |h::l => match (test h) with
      |false =>false
      |true => forallb test l
  end
end.

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.
Example test_forallb_1 : forallb oddb [1;3;5;7;9] = true.
Proof. reflexivity. Qed.

Example test_forallb_2 : forallb negb [false;false] = true.
Proof. reflexivity. Qed.

Example test_forallb_3 : forallb evenb [0;2;4;5] = false.
Proof. reflexivity. Qed.

Example test_forallb_4 : forallb (eqb 5) [] = true.
Proof. reflexivity. Qed.

Fixpoint existsb {X : Type} (test : X-> bool) (l : list X) :bool:=
  match l with
  |nil => false
  |h::l => match (test h) with
      |true => true
      |false => existsb test l
  end
end.

Example test_existsb_1 : existsb (eqb 5) [0;2;3;6] = false.
Proof. reflexivity. Qed.

Example test_existsb_2 : existsb (andb true) [true;true;false] = true.
Proof. reflexivity. Qed.

Example test_existsb_3 : existsb oddb [1;0;0;0;0;3] = true.
Proof. reflexivity. Qed.

Example test_existsb_4 : existsb evenb [] = false.
Proof. reflexivity. Qed.

Definition existsb' {X : Type} (test : X -> bool) (l : list X) : bool:=
  negb( forallb (fun x:X =>negb(test x) ) l).

Lemma forall_existsb':forall (X :Type) (test : X -> bool)(x :X) (l :list X),
  test x =false ->
  existsb' test (x::l) = existsb' test l.
Proof.
  intros X test x l H.
  unfold existsb'.
  simpl.
  rewrite H.
  reflexivity.
Qed.
Theorem existsb_existsb' : forall (X : Type) (test : X -> bool) (l : list X),
  existsb test l = existsb' test l.
Proof.
  intros X test l.
  induction l as [|y l].
  -reflexivity.
  -simpl. destruct (test y) eqn:H1.
    +unfold existsb'. simpl. rewrite H1.
    reflexivity.
    +symmetry. rewrite forall_existsb' with (X:=X) (test:=test) (x:=y) (l:=l).
      *symmetry;apply IHl.
      *apply H1.
Qed.
(** [] *)

(* Wed Jan 9 12:02:44 EST 2019 *)


Set Warnings "-notation-overridden, -parsing".
Require Export IndProp.

(* Relations *)

Definition relation (X : Type) := X -> X -> Prop.

(* Partial Relations *)

Definition partial_function {X : Type} (R : relation X) :=
  forall x y1 y2 : X, R x y1 -> R x y2 -> y1 = y2.

Theorem next_nat_partial_function :
  partial_function next_nat.
Proof.
  unfold partial_function.
  intros. inversion H. inversion H0.
  reflexivity.
Qed.

Theorem le_not_a_partial_function :
  ~ (partial_function le).
Proof.
  unfold partial_function. unfold not.
  intros Hc.
  assert (0 = 1) as Nonsense.
  { apply Hc with (x := 0).
    - apply le_n. - apply le_S. apply le_n. }
  inversion Nonsense.
Qed.

(* Reflexive Relations *)

Definition reflexive {X : Type} (R : relation X) :=
  forall a : X, R a a.

Theorem le_refleixive : reflexive le.
Proof.
  unfold reflexive. intros.
  apply le_n.
Qed.

(* Transitive Relations *)

Definition transitive {X : Type} (R : relation X) :=
  forall a b c : X, (R a b) -> (R b c) -> (R a c).

Theorem le_trans : transitive le.
Proof.
  unfold transitive. intros.
  induction H0.
  - apply H.
  - apply le_S. apply IHle.
Qed.

(* TODO: Exercises *)

(* Symmetric and Antisymmetric Relations *)

Definition symmetric {X : Type} (R : relation X) :=
  forall a b : X, (R a b) -> (R b a).

Theorem le_not_symmetric : ~ (symmetric le).
Proof.
  unfold not. unfold symmetric.
  intros. assert (4 <= 3).
  { apply H. apply le_S. reflexivity. }
  intuition.
Qed.

Definition antisymmetric {X : Type} (R : relation X) :=
  forall a b : X, (R a b) -> (R b a) -> a = b.

Theorem le_antisymmetric : antisymmetric le.
Proof.
  unfold antisymmetric.
  intros. inversion H.
  - reflexivity.
  - intuition.
Qed.

Theorem le_step : forall n m p, n < m -> m <= S p -> n <= p.
Proof.
  Admitted.

(* Equivalence Relations *)

Definition equivalence {X : Type} (R : relation X) :=
  (reflexive R) /\ (symmetric R) /\ (transitive R).

Definition order {X : Type} (R : relation X) :=
  (reflexive R) /\ (antisymmetric R) /\ (transitive R).

Definition preorder {X : Type} (R : relation X) :=
  (reflexive R) /\ (transitive R).

Theorem le_order : order le.
Proof.
  unfold order.
  split.
  - apply le_refleixive.
  - split. + apply le_antisymmetric. + apply le_trans.
Qed.

(* Reflexive, Transitive Closure *)

(* The reflexive, transitive closure of a relation R is the
   smallest relation that contains R and that is both reflexive
   and transitive. *)

Inductive clos_refl_trans {A : Type} (R : relation A) : relation A :=
  | rt_step : forall x y, R x y -> clos_refl_trans R x y
  | rt_refl : forall x, clos_refl_trans R x x
  | rt_trans : forall x y z,
    clos_refl_trans R x y ->
    clos_refl_trans R y z ->
    clos_refl_trans R x z.

(* TODO *)


Require Export Maps MapNotations MapInterface MapFacts.

(* Constructing the empty map *)

Definition M' : Map[nat, nat] := [].
(* Equiv: Definition M' : Map[nat, nat] := empty nat. *)

(* Constructing a map with values *)

Definition N' := (M' [ 0 <- 5 ]) [1 <- 6].

(* Intuition: map [ key <- value ] *)
(* Equiv: Definition n' := add 1 6 (add 0 5 m'). *)

(*** Properties of maps *)

(** Emptiness *)
(* Remark: 'empty' is the empty map, 'is_empty' is a function bool -> dict *)
(* Remark: 'dict' is a constructor for maps *)

Example empty_is_empty'' :
  is_empty M' = true.
Proof. reflexivity. Qed.

Example empty_is_empty_with_prop :
  Empty M'.
Proof. intuition. Qed.

Example not_empty_is_not_empty' :
  is_empty N' = false.
Proof. reflexivity. Qed.

(** Cardinality: How many keys does the map have? *)

Example empty_has_zero' :
  cardinal M' = 0.
Proof. reflexivity. Qed.

Example non_zero' :
  cardinal N' = 2.
Proof. reflexivity. Qed.

(** Membership: is key X in this map? *)

Example is_member' :
  mem 1 N' = true. (* Key 1 is in N' *)
Proof. reflexivity. Qed.

Example is_member_with_prop :
  In 1 N'. (* Key 1 is in N' *)
Proof. intuition. Qed.

Example is_not_member' :
  mem 4 M' = false.
Proof. reflexivity. Qed.

(** Find: Give me the value at key X *)

(* Finding a value using convenient notation *)
(* Remark: value is 'option (element_type)' *)
Example get_value_with_notation' :
  N'[ 0 ] = Some 5.
Proof. reflexivity. Qed.

(* Finding the same value with an explicit function call *)

Example get_value_no_notation' :
  find 0 N' = Some 5.
Proof. reflexivity. Qed.

Example not_found' :
  N'[ 2 ] = None.
Proof. reflexivity. Qed.

(**
  Note that if we state something false, such as:
    M' [ 3 ] = Some 1.
  coq does not complain or fail. It simply leaves us with
  the obligation of proving false.
  Remember that M' is the empty map.
*)

(** Remove: Give me a map without key X *)

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

(* Two maps con be considered equal if all their keys are equal *)
(* However, this may not be the best defintion *)
Example remove_element :
  equal beq_nat (remove 1 (add 1 5 [])) [] = true.
Proof. reflexivity. Qed.

Example remove_element_with_prop :
  Equivb beq_nat (remove 1 (add 1 5 [])) [].
Proof. rewrite equal_iff. reflexivity. Qed.

Example remove_empty :
  Equivb beq_nat (remove 1 []) [].
Proof. rewrite equal_iff. reflexivity. Qed.

(** Mapping over elements *)

(* Add 1 to each element *)

Example map_plus' :
  equal beq_nat (map (plus 1) (add 2 6 (add 1 5 []))) (add 2 7 (add 1 6 [])) = true.
Proof. reflexivity. Qed.

(** Folding over elements *)

(* We only need the key as input here because 'fold' expects it *)
Definition mult' (key elem acc : nat) := elem * acc.

Example fold_mult' :
  fold mult' (add 2 6 (add 1 5 [])) 1 = 30.
Proof.  reflexivity. Qed.


(* Basic notions from set theory. *)

From set_theory Require Import lib fn pair.

Section Definitions.

Variable X : Type.

(* The power set *)
Definition P := X -> Prop.

Variable V : P.
Variable W : P.
Variable Y : nat -> P.

(* A function range. *)
Definition Rng {D} (f : D -> X) x := ∃d, f d = x.

(* The empty set. *)
Definition EmptySet (x : X) := False.

(* An infinite set *)
Definition Infinite := ∃f : nat -> X, Injective f /\ ∀n, V (f n).

(* A countable set *)
Definition Countable := ∃f : nat -> X, ∀x, V x -> ∃n, f n = x.

(* Singleton set *)
Definition Singleton (x y : X) := x = y.

(* V is a subset of W. *)
Definition Inclusion := ∀x, V x -> W x.

(* The difference of V relative to W is equal to V - W. *)
Definition Difference x := V x /\ ¬W x.

(* V is a proper superset of W. *)
Definition ProperSuperset := Inclusion /\ Difference ≠ EmptySet.

(* Binary union *)
Definition Union x := V x \/ W x.

(* Binary intersection *)
Definition Isect x := V x /\ W x.

(* Countable union *)
Definition ωUnion x := ∃n, Y n x.

(* Countable intersection *)
Definition ωIsect x := ∀n, Y n x.

End Definitions.

Arguments Rng {_ _}.
Arguments EmptySet {_}.
Arguments Infinite {_}.
Arguments Countable {_}.
Arguments Singleton {_}.
Arguments Inclusion {_}.
Arguments Difference {_}.
Arguments ProperSuperset {_}.
Arguments Union {_}.
Arguments Isect {_}.
Arguments ωUnion {_}.
Arguments ωIsect {_}.

Notation "'∅'" := (EmptySet).
Notation "⦃ x ⦄" := (Singleton x).
Notation "V ⊆ W" := (Inclusion V W) (at level 50).
Notation "V ⊃ W" := (ProperSuperset V W) (at level 50).
Notation "V ⧵ W" := (Difference V W) (at level 40, left associativity).
Notation "V ∪ W" := (Union V W) (at level 40, left associativity).
Notation "V ∩ W" := (Isect V W) (at level 40, left associativity).
Notation "⋃ V" := (ωUnion V) (at level 30).
Notation "⋂ V" := (ωIsect V) (at level 30).

(* This is quite useful. *)
Lemma prop_ext {X} (V W : P X) :
  V = W <-> ∀x, V x <-> W x.
Proof.
split; intros. now subst.
extensionality x; now apply propositional_extensionality.
Qed.

Section Basic_lemmas.

Variable X : Type.
Variable V : P X.
Variable W : P X.
Variable U : P X.

(* Set inclusion is transitive *)
Lemma incl_trans : U ⊆ V -> V ⊆ W -> U ⊆ W.
Proof. intros HU HV x; auto. Qed.

(* Equal sets are included in each other. *)
Lemma eq_incl : V = W -> V ⊆ W /\ W ⊆ V.
Proof. intros; now subst. Qed.

(* Sets that are included in each other are equal. *)
Lemma incl_eq : V ⊆ W -> W ⊆ V -> V = W.
Proof. intros; apply prop_ext; split; auto. Qed.

(*
If V is included in U, and W removes at least as much from U as V,
then V is included in W.
*)
Lemma diff_incl :
  V ⊆ U -> U ⧵ W ⊆ U ⧵ V -> V ⊆ W.
Proof.
intros HVU H x HV. apply HVU in HV as HU.
assert(Hx := H x). eapply contra in Hx; unfold Difference in *.
apply not_and_or in Hx as [Hx|Hx]. easy. now apply NNPP.
now intros [_ HVx].
Qed.

End Basic_lemmas.

(* Re-use basic lemmas in a non-trivial way. *)
Section Other_lemmas.

Variable X : Type.
Variable V : P X.
Variable W : P X.
Variable U : P X.
Variable Y : nat -> P X.

(* A set is empty iff it contains no elements. *)
Lemma empty : V = ∅ <-> ∀x, ¬V x.
Proof. split; intros. now rewrite H. now apply incl_eq. Qed.

(* A set is non-empty iff it contains an element. *)
Lemma not_empty :
  V ≠ ∅ <-> ∃x, V x.
Proof.
split.
- intros H; apply not_all_not_ex; intros H'; apply H.
  apply prop_ext; intros; split; unfold EmptySet; intros.
  now apply (H' x). easy.
- intros [x Hx] H; apply eq_incl in H as [H _].
  now apply (H x).
Qed.

(* The difference of V relative to ∅ is all of V. *)
Lemma diff_empty : V ⧵ ∅ = V.
Proof. apply incl_eq. now intros x [H _]. easy. Qed.

(* The empty set does not add any elements. *)
Lemma union_empty : V ∪ ∅ = V.
Proof. apply incl_eq. now intros x [H|H]. intros x H; now left. Qed.

(* If V is included in W, and W is empty, then V is empty. *)
Lemma incl_empty : V ⊆ W -> W = ∅ -> V = ∅.
Proof. intros HV HW; apply incl_eq. now rewrite <-HW. easy. Qed.

(* Intersection distributes over union. *)
Lemma isect_distr_union :
  (V ∪ W) ∩ U = (V ∩ U) ∪ (W ∩ U).
Proof.
apply incl_eq; intros x.
- intros [[HV|HW] HU]. now left. now right.
- intros [[HV HU]|[HW HU]]; split; try easy. now left. now right.
Qed.

(*
If V is included in W, then the intersection between
V and U is included in the intersection between W and U.
*)
Lemma incl_isect_incl : V ⊆ W -> V ∩ U ⊆ W ∩ U.
Proof. intros HV x [H1x H2x]. split; auto. Qed.

(*
Removing only shared elements is equal to
re-adding elements not removed by others.
*)
Lemma diff_ωisect_eq_ωunion_diff :
  V ⧵ ⋂ Y = ⋃ (λ n, V ⧵ Y n).
Proof.
apply incl_eq.
- intros x [H1x H2x]. apply not_all_ex_not in H2x as [n Hn]; now exists n.
- intros x [n [H1n H2n]]; split. easy. apply ex_not_not_all; now exists n.
Qed.

(*
Suppose V is included in W is included in U. Removing all elements in V from U
is equal to removing all elements in W and adding the elements not in V back.
*)
Lemma diff_union :
  V ⊆ W -> W ⊆ U -> U ⧵ V = (U ⧵ W) ∪ (W ⧵ V).
Proof.
intros HV HW; apply incl_eq; intros x.
- intros [H1x H2x]. destruct (classic (W x)). now right. now left.
- intros [[H1x H2x]|[H1x H2x]]; split; try easy.
  eapply contra. apply HV. easy. now apply HW.
Qed.

(* A union of countable sets is countable. *)
Lemma countable_union :
  Countable V -> Countable W -> Countable (V ∪ W).
Proof.
intros [v Hv] [w Hw].
pose(f c m := if c =? 0 then v m else w m).
pose(g n := let (c, m) := π_inv n in f c m).
exists g; intros x [Hx|Hx].
1: destruct (Hv x Hx) as [m Hm]; exists (π (0, m)).
2: destruct (Hw x Hx) as [m Hm]; exists (π (1, m)).
all: unfold g, f; now rewrite π_inv_π_id.
Qed.

(* A countable union of countable sets is countable. *)
Lemma countable_ωunion :
  (∀n, Countable (Y n)) -> Countable (⋃ Y).
Proof.
intros; apply choice in H as [F HY].
pose(f n := let (i, m) := π_inv n in F i m).
exists f; intros x [i Hx]. apply HY in Hx as [m Hm].
exists (π (i, m)); unfold f; now rewrite π_inv_π_id.
Qed.

End Other_lemmas.

(*
We used the choice axiom to prove countable_ωunion. There seems to be no way to
avoid this, except by changing the definition of Countable. This is possible
while preserving the use of classical logic; by using function relations that
can be effectively obtained.

Unfortunately this also means proofs that involve Countable must be within Type,
which would require induction on CB to be within Type. Hence proofs about CB can
then no longer use classical logic.
*)
Section Countable_ωunion_without_choice.

Definition CountableRel {X} (V : P X) := {F : nat -> X -> Prop |
  (∀n, ∃!x, F n x) /\ ∀x, V x -> ∃n, F n x}.

(* A countable union of countable sets is countable. *)
Lemma countable_rel_ωunion {X} (Y : nat -> P X) :
  (∀n, CountableRel (Y n)) -> CountableRel (⋃ Y).
Proof.
intros H;
pose(F n := sig1 (H n));
pose(HF n := sig2 (H n));
pose(G x y := let (n, i) := π_inv x in F n i y).
exists G; split; intros x; unfold G.
- destruct (π_inv x) as [n i]. apply (proj1 (HF n)).
- intros [n Hn]. apply (proj2 (HF n)) in Hn as [i Hi].
  exists (π ((n, i))). now rewrite π_inv_π_id.
Qed.

End Countable_ωunion_without_choice.


Require Import Arith.

Axiom todo : forall A, A.
Ltac todo := apply todo.

Goal True.
  exact I.
Qed.

Check True.

Print Module Init.Nat.

Parameter A B C : Prop.

Lemma AimpA : A -> A.
Proof.
  intro.
  assumption.
Qed.

Lemma imp_trans : (A -> B) -> (B -> C) -> A -> C.
Proof.
  intros.
  apply H0.
  apply H.
  assumption.
Qed.

Lemma and_comm : A /\ B -> B /\ A.
Proof.
  intro.
  destruct H.
  split; assumption.
Qed.

Lemma or_comm : A \/ B -> B \/ A.
Proof.
  intro.
  destruct H; [right | left]; assumption.
Qed.

Lemma A_imp_nnA : A -> ~~A.
Proof.
  unfold not.
  intros.
  apply H0.
  assumption.
Qed.

Lemma distr_and_or : (A\/B)/\C -> A/\C \/ B/\C.
Proof.
  intros.
  destruct H.
  destruct H.
  + left. split; assumption.
  + right. split; assumption.
Qed.

Lemma equiv_refl : A <-> A.
Proof.
  unfold iff.
  split; intro; assumption.
Qed.

(** 2.2 Classical logic *)

Lemma equiv_classic :
  (forall P, P \/ ~P) <-> (forall P, ~~P -> P).
Proof.
  unfold iff.
  split; unfold not; intros.
  - destruct H with P.
    + assumption.
    + apply H0 in H1. contradiction.
  - apply H.
    intro.
    apply H0.
    right.
    intro.
    destruct H0; left; assumption.
Qed.

(* 2.2.1 {Classical formulae in an intuitionistic world *)
(* Modelization of a definition and lemmas *)

Definition is_classical (P:Prop) := ~~P -> P.

Lemma nn_funct (P Q : Prop) : ~~ P /\ (P -> Q) -> ~~Q.
Proof.
  unfold not.
  intro.

  destruct H.
  intro.
  apply H1.
  apply H0.
  destruct H.
  intro.
  apply H1.
  apply H0.
  assumption.
Qed.

Lemma class_t : is_classical True.
Proof.
  unfold is_classical.
  unfold not.
  intro.
  trivial.
Qed.

Lemma class_f : is_classical False.
Proof.
  unfold is_classical.
  unfold not.
  intro.
  destruct H.
  intro.
  assumption.
Qed.

Lemma class_conj (P Q : Prop) : is_classical P /\ is_classical Q -> is_classical (P /\ Q).
Proof.
  unfold is_classical.
  unfold not.
  intro.
  destruct H.
  intro.
  split.
  - apply H.
    intro.
    apply H1.
    intro.
    destruct H3. apply H2. apply H3.
  - apply H0.
    intro.
    apply H1.
    intro.
    destruct H3. apply H2. apply H4.
Qed.

(* 3.1 Socrates *)
(* Modelization using axioms *)
Parameter Person:Type.
Parameter Socrate : Person.
Parameter Men Mortal : Person->Prop.

Lemma socrateMortal : Men Socrate /\ (forall P:Person, Men P -> Mortal P) -> Mortal Socrate.
Proof.
  intro.
  destruct H.
  apply H0 in H.
  assumption.
Qed.

Print socrateMortal.

(* 3.2 Drinkers paradox *)
(* Modelization using axioms + classical logic *)
Parameter EM : forall P, ~~ P -> P.

Lemma drinker : exists p:Person, ~ Mortal p -> forall q:Person, ~ (Mortal q).
Proof.
  apply EM.
  intro.
  apply H.
  exists Socrate.
  intros.
  intro.
  apply H.
  exists q.
  intro.
  contradiction.
Qed.

(* 3.3 Equality *)

(* Example *)

Goal forall x y : nat, x = S y -> y = pred x.
Proof.
  intros x y e.
  rewrite e.
  simpl.
  reflexivity.
Qed.

(* Require Import Classical.
Check NNPP. *)

(* 3.4 Groups *)
(* Modelization using axioms + equational reasoning using rewrite/reflexivity/symmetry/transivitity *)

Parameter (G:Type).
Parameter op : G -> G -> G.
Parameter inv : G -> G.
Parameter e : G.

Axiom assoc  : forall (a b c : G),  op (op a b)  c = op a  (op b c).
Axiom id_l : forall (a: G), op a e = a.
Axiom id_r : forall (a: G), op e a = a.

Axiom inv_r : forall (a:G), op a (inv a) = e.
Axiom inv_l : forall (a:G), op (inv a) a = e.

Lemma group (x y:G) : inv (op x y) = op (inv y) (inv x).
Proof.
  transitivity (op (inv y) (op (inv x) (op (op x y) (inv (op x y))))).
  - rewrite assoc.
    rewrite <- assoc with (a:=inv x) (b:=x).
    rewrite inv_l.
    rewrite id_r.
    rewrite <- assoc.
    rewrite inv_l.
    rewrite id_r.
    reflexivity.

  - rewrite inv_r.
    rewrite id_l.
    reflexivity.
Qed.


Require Import List.

(* 1.28 *)
Theorem app_length : forall {A : Set} (xs ys : list A),
                       length (xs ++ ys) = length xs + length ys.
Proof.
  intros A xs ys.
  induction xs.
  simpl.
  reflexivity.

  simpl.
  rewrite IHxs.
  reflexivity.
Qed.

(* 練習問題 *)
(* 問4.2 *)
Theorem app_assoc : forall {A:Set} (xs ys zs : list A),
                      xs ++ (ys ++ zs) = (xs ++ ys) ++ zs.
Proof.
  intros A xs ys zs.
  induction xs.
  simpl.
  reflexivity.

  simpl.
  rewrite IHxs.
  reflexivity.
Qed.

(* 問4.3 *)
Theorem app_nil : forall {A:Set} (xs: list A),
                    xs ++ nil = xs.
Proof.
  intros A xs.
  induction xs.
  simpl.
  reflexivity.

  simpl.
  rewrite IHxs.
  reflexivity.
Qed.

(* IH  Inductive Hypothesis *)

(* 問4.4 *)
Theorem app_rev : forall {A:Set} (xs ys: list A),
                    rev (xs ++ ys) = rev ys ++ rev xs.
Proof.
  intros A xs ys.
  induction xs.

  simpl.
  rewrite app_nil.
  reflexivity.

  simpl.
  rewrite IHxs.
  rewrite <- app_assoc.
  reflexivity.
Qed.

(* 問4.5 *)
Theorem rev_rev : forall {A:Set} (xs: list A),
                    rev (rev xs) = xs.
Proof.
  intros A xs.
  induction xs.

  simpl.
  reflexivity.

  simpl.
  rewrite app_rev.
  simpl.
  rewrite IHxs.
  reflexivity.
Qed.


Require Import Arith.
Require Import Omega.
Require Import Recdef.
Require Import List.
Require Import Program.Tactics.
Require Import Program.Equality.
Require Import Sorting.Permutation.
Import ListNotations.

(** * Cyclic permutations

This file contains a permutation development based on cycling:

[[
Inductive Perm2 {A}: list A -> list A -> Prop :=
| perm2_nil : Perm2 [] []
| perm2_cons : forall x y a,
    Perm2 x y -> Perm2 (a :: x) (a :: y)
| perm2_cycle : forall x y a,
    Perm2 (a :: x) y -> Perm2 (x ++ [a]) y.
]]

We prove that cycling permutations are equivalent to Coq Permutations.
As you’ve seen, though, this definition is radically difficult to work with.
There is no way I’ve found to prove anything about Perm2 directly
(the equivalent of the [Permutation_Add_inv] lemma must be assumed).

Instead we work with a stronger definition, [NatCyclePerm], about which
we can prove stronger properties. [NatCyclePerm] is a cyclic permutation
for _distinct natural numbers_:

[[
Inductive NatCyclePerm : list nat -> list nat -> Prop :=
| ncp_nil : NatCyclePerm [] []
| ncp_cons : forall is js i,
    NatCyclePerm is js ->
    ~ In i is ->
    NatCyclePerm (i::is) (i::js)
| ncp_cycle : forall is js i,
    NatCyclePerm (i::is) js -> NatCyclePerm (is++[i]) js.
]]

When the members of a set are distinct, it becomes easier to prove
properties about permutations. In particular, we can prove this strong
statement:

[[
  Lemma ncp_all is js:
    NoDup is ->
    NoDup js ->
    (forall i, In i is <-> In i js) ->
    NatCyclePerm is js.
]]

That is, if [is] and [js] are lists of distinct [nat]s, and they are subsets
of each other (every element of [is] is in [js] and vice versa), then there
exists a cycle-based permutation between [is] and [js].

But how can we go from permutations of [nat]s to permutations of anything?
We use this function, which looks up the [i]th element of a list:

[[
Fixpoint map_nth {A} is l : list A :=
  match is with
  | [] => []
  | i::is' => match nth_error l i with
              | Some a => a :: map_nth is' l
              | None => []
              end
  end.
]]

Working through the proof still involved a lot of excitement, and (as almost
every Coq development seems to require) proving facts about lists. A critical
lemma was [NoDup_nat_complete], which allows us to assert the existence of
a [NatCyclePerm] at an important point.

*)

(* ** Facts about [In] *)

Section InFacts.
  Context {A:Type}.
  Implicit Types l:list A.

  Lemma in_middle a l1 l2:
    In a (l1 ++ a :: l2).

    induction l1; intros; simpl; [ left | right ]; auto.
  Qed.

  Lemma in_add_middle a b l1 l2:
    In a (l1 ++ l2) ->
    In a (l1 ++ b :: l2).

    intros; apply in_app_or in H; intuition.
  Qed.

  Lemma in_remove_middle a b l1 l2:
    In a (l1 ++ b :: l2) ->
    a <> b ->
    In a (l1 ++ l2).

    intros; apply in_app_or in H; intuition.
    destruct H1; intuition.
  Qed.

  Lemma in_remove_left a l1 l2:
    In a (l1 ++ l2) ->
    ~ In a l1 ->
    In a l2.

    intros; apply in_app_or in H; intuition.
  Qed.

  Lemma in_remove_right a l1 l2:
    In a (l1 ++ l2) ->
    ~ In a l2 ->
    In a l1.

    intros; apply in_app_or in H; intuition.
  Qed.

End InFacts.

(** ** [AllLess]

   This predicate says that everything in a [list nat] is less than
   a number. We could’ve written it as [Forall (ge n)]. *)

Section AllLess.

  Definition AllLess n l :=
    forall i, In i l -> i < n.

  (** These facts make [AllLess] easier to work with in proofs. *)
  Lemma AllLess_cons n l i:
    AllLess n l -> i < n -> AllLess n (i :: l).

    unfold AllLess; intros.
    destruct H1; intuition.
  Qed.

  Lemma AllLess_skip {n l i}:
    AllLess n (i :: l) -> AllLess n l.

    unfold AllLess; intros; apply H; intuition.
  Qed.

  Lemma AllLess_app_1 {n l1 l2}:
    AllLess n (l1 ++ l2) -> AllLess n l1.

    unfold AllLess; intros; apply H; intuition.
  Qed.

  Lemma AllLess_app_2 {n l1 l2}:
    AllLess n (l1 ++ l2) -> AllLess n l2.

    unfold AllLess; intros; apply H; intuition.
  Qed.

  Lemma AllLess_zero_nil l:
    AllLess 0 l -> l = [].

    destruct l; intros; auto.
    assert (n < 0) by (apply H; intuition).
    omega.
  Qed.

End AllLess.

(** ** Facts about [map_nth] *)

Fixpoint map_nth {A} is l : list A :=
  match is with
  | [] => []
  | i::is' => match nth_error l i with
              | Some a => a :: map_nth is' l
              | None => []
              end
  end.

Section MapNthFacts.
  Context {A:Type}.
  Implicit Types l:list A.
  Implicit Types is js:list nat.

  (* A useful Ltac tactic *)
  Ltac map_nth_head :=
    match goal with
    | [ H : context [ AllLess (length ?l) (?a :: ?is) ] |- _ ] =>
      let M := fresh "SO" in
      let ne := fresh "ne" in
      assert (a < length l) as M by (apply H; intuition);
      rewrite <- nth_error_Some in M; simpl;
      remember (nth_error l a) as ne; destruct ne; [ clear M | contradiction ]
    end.

  (** Easy facts about [map_nth] *)

  Lemma in_map_nth_position is l a:
    In a (map_nth is l) ->
    exists i, In i is /\ i < length l /\ nth_error l i = Some a.

    revert is l a; induction is; simpl; intros.
    contradiction.
    remember (nth_error l a) as ne; destruct ne; [ | destruct H ].
    simpl in H; destruct or H; subst.
    - assert (nth_error l a <> None) by (rewrite <- Heqne; discriminate).
      rewrite nth_error_None in H.
      exists a; intuition.
    - apply IHis in H; destruct H as [x H].
      exists x; intuition.
  Qed.

  Lemma in_map_nth is l a:
    In a (map_nth is l) ->
    In a l.

    intros; apply in_map_nth_position in H.
    destruct H as [i [X [L Y]]].
    now apply nth_error_In in Y.
  Qed.

  Lemma map_nth_empty is:
    map_nth is ([]:list A) = ([]:list A).

    induction is; auto; simpl.
    rewrite IHis.
    assert (length ([]:list A) <= a) by (simpl; omega).
    rewrite <- nth_error_None in H.
    now rewrite H.
  Qed.

  Lemma map_nth_app is1 is2 l:
    AllLess (length l) is1 ->
    map_nth (is1 ++ is2) l = map_nth is1 l ++ map_nth is2 l.

    induction is1; intros AL.
    - intuition.
    - map_nth_head; now rewrite (IHis1 (AllLess_skip AL)).
  Qed.

  Lemma map_nth_cons is l a:
    map_nth (map S is) (a :: l) = map_nth is l.

    induction is; simpl; auto.
    remember (nth_error l a0) as mm; destruct mm; auto.
    now rewrite IHis.
  Qed.

  Lemma map_nth_length is l:
    AllLess (length l) is <->
    length is = length (map_nth is l).

    revert l; induction is; intros l.
    - unfold AllLess; intuition.
    - split; intros H.
      + map_nth_head; simpl; apply eq_S.
        rewrite <- IHis; now apply (AllLess_skip H).
      + unfold AllLess; intros i I; simpl in I.
        simpl in H.
        remember (nth_error l a) as ne; destruct ne; try discriminate.
        simpl in H; apply eq_add_S in H; rewrite <- IHis in H.
        assert (a < length l) by (apply nth_error_Some; rewrite <- Heqne; discriminate).
        destruct I; [ omega | now apply H ].
  Qed.

  (* NoDup is Coq’s inductive type representing the absence of
     duplicates in a list. *)
  Local Hint Constructors NoDup.

  Lemma map_nth_NoDup is l:
    NoDup is ->
    NoDup l ->
    NoDup (map_nth is l).

    remember (map_nth is l) as ks.
    revert is l Heqks; induction ks; intros is l Heqks NDi NDl; auto.
    destruct is; simpl in Heqks; [ discriminate | ].
    remember (nth_error l n) as ne; destruct ne; [ | discriminate ].
    inversion Heqks; subst; clear Heqks.
    constructor.
    + contradict NDi.
      apply in_map_nth_position in NDi.
      destruct NDi as [i [INi [INl NTHi]]].
      rewrite Heqne in NTHi.
      rewrite (NoDup_nth_error l) in NDl.
      apply (NDl _ _ INl) in NTHi.
      subst; intro H; inversion H; contradiction.
    + apply (IHks is l); auto.
      inversion NDi; auto.
  Qed.

  Lemma map_nth_nth is i j l:
    nth_error is i = Some j ->
    AllLess (length l) is ->
    nth_error (map_nth is l) i = nth_error l j.

    intros SO AL; apply nth_error_split in SO.
    destruct SO as [l1 [l2 [Hi Hl]]]; subst.

    assert (length (map_nth l1 l) = length l1) as LL1.
    symmetry; apply map_nth_length; now apply (AllLess_app_1 AL).

    rewrite map_nth_app by (apply (AllLess_app_1 AL)).
    rewrite nth_error_app2 by omega.
    rewrite LL1; rewrite minus_diag.
    simpl.
    remember (nth_error l j) as ne; destruct ne; auto.
  Qed.

  (** A critical lemma for proving [Perm2] transitivity. *)
  Lemma map_nth_compose is js l:
    AllLess (length js) is ->
    AllLess (length l) js ->
    map_nth is (map_nth js l) = map_nth (map_nth is js) l.

    revert js l; induction is; intros js l ALi ALj; auto.
    map_nth_head.
    simpl (map_nth (n :: map_nth is js) l).
    remember (nth_error l n) as ne2; destruct ne2.
    remember (nth_error (map_nth js l) a) as ne3; destruct ne3;
      rewrite map_nth_nth with (j:=n) in Heqne3; auto.
    - rewrite <- Heqne3 in Heqne2; inversion Heqne2; subst.
      rewrite (IHis _ _ (AllLess_skip ALi) ALj); reflexivity.
    - rewrite <- Heqne3 in Heqne2; discriminate.
    - symmetry in Heqne2; rewrite nth_error_None in Heqne2.
      symmetry in Heqne; apply nth_error_In in Heqne.
      apply ALj in Heqne; omega.
  Qed.

End MapNthFacts.

(** ** Facts about [NoDup] *)

Section NoDupFacts.
  Context {A:Type}.
  Implicit Types a b:A.
  Implicit Types l:list A.

  Lemma in_NoDup_inv a b l:
    NoDup (b :: l) ->
    a <> b ->
    In a (b :: l) ->
    In a l.

    intros ND neq I.
    inversion ND; destruct I; intuition.
  Qed.

  Lemma NoDup_app_swap l1 l2:
    NoDup (l1 ++ l2) <-> NoDup (l2 ++ l1).

    induction l1.
    - simpl; rewrite app_nil_r; intuition.
    - rewrite <- app_comm_cons; split; intro ND.
      + inversion ND; subst.
        assert (Add a (l2 ++ l1) (l2 ++ a :: l1)) by (apply Add_app).
        rewrite (NoDup_Add H).
        rewrite <- IHl1; split; auto.
        contradict H1; rewrite in_app_iff in *; intuition.
      + apply NoDup_remove in ND; destruct ND as [ND NI].
        apply NoDup_cons.
        contradict NI; rewrite in_app_iff in *; intuition.
        rewrite IHl1; assumption.
  Qed.

  Lemma NoDup_remove_iff a x1 x2 y:
    NoDup (x1 ++ a :: x2) ->
    NoDup (a :: y) ->
    (forall i, In i (x1 ++ a :: x2) <-> In i (a :: y)) ->
    forall i, In i (x1 ++ x2) <-> In i y.

    intros NDx NDy EQ i.
    apply NoDup_remove in NDx.
    destruct NDx as [NDx NIx].
    inversion NDy; subst.

    split; intros.
    - apply in_remove_left with (l1:=[a]).
      apply EQ.
      now apply in_add_middle.
      contradict NIx.
      inversion NIx; subst; intuition.
    - apply in_remove_middle with (b:=a).
      apply EQ.
      intuition.
      contradict H1.
      subst; assumption.
  Qed.

  Lemma NoDup_in_iff_length l1 l2:
    NoDup l1 ->
    NoDup l2 ->
    (forall i, In i l1 <-> In i l2) ->
    length l1 = length l2.

    intros NX; revert l2; induction NX;
      intros l2 NY HI.
    - destruct l2; auto.
      assert (In a (a :: l2)) by intuition.
      rewrite <- HI in H; destruct H.
    - assert (In x l2) by (rewrite <- HI; intuition).
      apply in_split in H0.
      destruct H0 as [m1 [m2 Hm2]]; subst.
      rewrite app_length; simpl.
      rewrite <- plus_n_Sm; apply eq_S.
      rewrite <- app_length.
      apply IHNX.
      apply NoDup_remove_1 with (a:=x); auto.
      symmetry; revert i.
      apply NoDup_remove_iff with (a:=x); auto.
      now constructor.
      symmetry; revert i; now assumption.
  Qed.

End NoDupFacts.

(** ** Facts about [iota]

   [iota n] counts from 0 to [n - 1], and is defined in terms of
   the library’s [seq]. *)

Definition iota n := seq 0 n.

Section IotaFacts.

  Lemma in_iota_iff n i:
    In i (iota n) <-> i < n.

    split; intros.
    apply in_seq in H; omega.
    apply in_seq; omega.
  Qed.

  Lemma iota_NoDup n:
    NoDup (iota n).

    now apply seq_NoDup.
  Qed.

  Lemma iota_length n:
    length (iota n) = n.

    now apply seq_length.
  Qed.

  Lemma iota_AllLess n:
    AllLess n (iota n).

    unfold AllLess; intros; now apply in_iota_iff.
  Qed.

  Lemma seq_app start len1 len2:
    seq start (len1 + len2) = seq start len1 ++ seq (start + len1) len2.

    revert start len2; induction len1; intros.
    - simpl; auto.
    - cbn; rewrite IHlen1; rewrite plus_Sn_m; rewrite <- plus_n_Sm; reflexivity.
  Qed.

  Lemma iota_nth n i:
    i < n -> nth_error (iota n) i = Some i.

    intros L; pose L as L'; rewrite <- iota_length in L'.
    apply nth_split with (d:=0) in L'.
    destruct L' as [l1 [l2 [IEQ L1L]]].
    unfold iota in *; rewrite (seq_nth 0 0 L) in IEQ.
    rewrite IEQ.
    rewrite nth_error_app2.
    rewrite L1L; rewrite minus_diag; now simpl.
    omega.
  Qed.

  Lemma iota_S n:
    iota (S n) = 0 :: map S (iota n).

    unfold iota; rewrite seq_shift; reflexivity.
  Qed.

  Lemma map_nth_iota {A} (xs:list A):
    map_nth (iota (length xs)) xs = xs.

    induction xs; cbn in *; auto.
    rewrite <- seq_shift.
    rewrite map_nth_cons.
    unfold iota in IHxs; now rewrite IHxs.
  Qed.

End IotaFacts.

(** ** [NoDup_nat_complete]

   This section states and proves this lemma: If a list [l] contains
   [n] [nat]s with no duplicates, and all elements of [l] are less
   than [n], then [l] contains _every_ [nat] less than [n]. We need
   it to prove that [Perm2]s are transitive.

   This is too hard to prove in a single induction, so we introduce
   a [transfer] type to let us state the induction-aware lemma,
   [NoDup_AllLess_transfer]. *)

Section NoDupNatComplete.

  Inductive transfer {A}: list A -> list A -> list A -> Prop :=
  | transfer_nil : forall ys, transfer [] ys ys
  | transfer_cons : forall xs ys1 y ys2 zs,
      transfer xs (ys1 ++ y :: ys2) zs ->
      transfer (y :: xs) (ys1 ++ ys2) zs.
  Hint Constructors transfer.

  Lemma in_transfer_iff {A} (xs ys zs:list A) a:
    transfer xs ys zs ->
    In a zs <-> In a (xs ++ ys).

    intro TR; induction TR.
    - intuition.
    - rewrite IHTR.
      repeat rewrite in_app_iff; simpl; intuition.
  Qed.

  Lemma transfer_length {A} (xs ys zs:list A):
    transfer xs ys zs ->
    length zs = length xs + length ys.

    intro TR; induction TR.
    - simpl; auto.
    - simpl; rewrite IHTR.
      repeat rewrite app_length; simpl; omega.
  Qed.

  Lemma in_transfer_rest {A} (xs ys zs:list A) a:
    transfer xs ys zs ->
    In a zs ->
    ~ In a xs ->
    In a ys.

    intros TR; induction TR; intros Iz NIx.
    - auto.
    - apply not_in_cons in NIx.
      destruct NIx as [Ny NIx].
      apply in_remove_middle with (b:=y); auto.
  Qed.

  Lemma NoDup_AllLess_transfer n xs:
    NoDup xs ->
    AllLess n xs ->
    exists ys, transfer xs ys (iota n).

    induction xs; intros ND AL.
    - exists (iota n); constructor.
    - inversion ND; subst.
      generalize (AllLess_skip AL); intro AL0.
      generalize (IHxs H2 AL0); intro IH.
      destruct IH as [ys IH].
      assert (In a ys). {
        apply (in_transfer_rest _ _ _ a IH).
        rewrite in_iota_iff; auto.
        apply AL; intuition.
        auto.
      }
      apply in_split in H.
      destruct H as [y1 [y2 H]]; subst.
      exists (y1 ++ y2); now constructor.
  Qed.

  Lemma NoDup_nat_complete i is:
    NoDup is ->
    AllLess (length is) is ->
    i < length is ->
    In i is.

    intros ND AL Less.
    generalize (NoDup_AllLess_transfer (length is) is ND AL);
      intros TR.
    destruct TR as [ys TR].
    generalize (transfer_length _ _ _ TR); intros TRlen.
    rewrite iota_length in TRlen.
    assert (length ys = 0) by omega.
    apply length_zero_iff_nil in H; subst.
    rewrite <- app_nil_r.
    rewrite <- (in_transfer_iff _ _ _ _ TR).
    now rewrite in_iota_iff.
  Qed.

End NoDupNatComplete.

(** ** [NatCyclePerm]

   This is the cycle-based permutation definition that lets us show
   reflexivity, symmetry, and transitivity without further
   assumptions. *)

Section NatCyclePerm.

  Inductive NatCyclePerm : list nat -> list nat -> Prop :=
  | ncp_nil : NatCyclePerm [] []
  | ncp_cons : forall is js i,
      NatCyclePerm is js ->
      ~ In i is ->
      NatCyclePerm (i::is) (i::js)
  | ncp_cycle : forall is js i,
      NatCyclePerm (i::is) js -> NatCyclePerm (is++[i]) js.
  Hint Constructors NatCyclePerm.

  Lemma ncp_length_eq {is js}:
    NatCyclePerm is js ->
    length is = length js.

    intro PE; induction PE; auto.
    now apply eq_S.
    rewrite app_length; simpl in *. omega.
  Qed.

  Lemma ncp_eq_nil is:
    NatCyclePerm is [] ->
    is = [].

    intros; apply ncp_length_eq in H.
    simpl; apply length_zero_iff_nil; subst; auto.
  Qed.

  Lemma ncp_refl is:
    NoDup is ->
    NatCyclePerm is is.

    induction is; auto; intros.
    constructor.
    - apply IHis; inversion H; auto.
    - inversion H; auto.
  Qed.

  Lemma ncp_app_cycle is1 is2 js:
    NatCyclePerm (is1 ++ is2) js ->
    NatCyclePerm (is2 ++ is1) js.

    revert is2; induction is1; intros.
    simpl; rewrite app_nil_r; auto.
    replace (is2 ++ a :: is1) with ((is2 ++ [a]) ++ is1).
    apply IHis1; rewrite app_assoc; apply ncp_cycle; apply H.
    rewrite <- app_assoc; apply eq_refl.
  Qed.

  (** This important lemma lets us construct a [NatCyclePerm]
      from _any_ [nat] lists that meet some simple conditions. *)
  Lemma ncp_all is js:
    NoDup is ->
    NoDup js ->
    (forall i, In i is <-> In i js) ->
    NatCyclePerm is js.

    revert is; induction js; intros is NDx NDy I.
    - assert (length is = length ([]:list nat)).
      apply NoDup_in_iff_length; auto.
      simpl in H.
      apply length_zero_iff_nil in H.
      subst; auto.
    - assert (In a is) by (apply I; intuition).
      apply in_split in H.
      destruct H as [l1 [l2 H]]; subst.
      apply ncp_app_cycle.
      rewrite <- app_comm_cons.
      constructor.
      apply ncp_app_cycle.
      apply IHjs.
      + now apply NoDup_remove_1 with (a:=a).
      + now apply NoDup_remove_1 with (a:=a) (l:=[]).
      + now apply NoDup_remove_iff with (a0:=a).
      + rewrite in_app_iff.
        rewrite or_comm.
        rewrite <- in_app_iff.
        now apply NoDup_remove_2 with (a:=a).
  Qed.

  Lemma ncp_expand is js:
    NatCyclePerm is js ->
    NoDup is
    /\ NoDup js
    /\ (forall i, In i is <-> In i js).

    intro PE; induction PE; auto.
    - repeat split; try apply NoDup_nil; auto.
    - destruct IHPE as [NDx [NDy IH]].
      split; [ now apply NoDup_cons | ].
      split; [ apply NoDup_cons;
               try rewrite <- IH; auto | ].
      intros; simpl; rewrite <- IH; intuition.
    - destruct IHPE as [NDx [NDy IH]].
      split; [ | split].
      + apply NoDup_app_swap; now assumption.
      + assumption.
      + intros; rewrite <- IH; rewrite in_app_iff.
        simpl; intuition.
  Qed.

  Lemma ncp_NoDup_is {is js}:
    NatCyclePerm is js -> NoDup is.

    intros PE; apply ncp_expand in PE; intuition.
  Qed.

  Lemma ncp_NoDup_js {is js}:
    NatCyclePerm is js -> NoDup js.

    intros PE; apply ncp_expand in PE; intuition.
  Qed.

  Lemma ncp_in_iff {is js}:
    NatCyclePerm is js -> forall i, In i is <-> In i js.

    intro PE; apply ncp_expand in PE; intuition.
  Qed.

  (** Once we have [ncp_expand] and [ncp_all], we can prove symmetry
      and transitivity. *)

  Lemma ncp_sym is js:
    NatCyclePerm is js ->
    NatCyclePerm js is.

    intros.
    apply ncp_expand in H.
    destruct_conjs.
    apply ncp_all; auto.
    split; intros; now apply H1.
  Qed.

  Lemma ncp_trans is js ks:
    NatCyclePerm is js ->
    NatCyclePerm js ks ->
    NatCyclePerm is ks.

    intros.
    apply ncp_expand in H.
    apply ncp_expand in H0.
    destruct_conjs.
    apply ncp_all; auto.
    split; intros.
    apply H2; now apply H4.
    apply H4; now apply H2.
  Qed.

  (** Given symmetry and transitivity, we can prove the equivalence
      of the library’s [Permutation] and [NatCyclePerm] (for
      duplicate-free lists). *)

  Lemma perm_ncp is js:
    NoDup is ->
    Permutation is js ->
    NatCyclePerm is js.

    intros ND PE; induction PE; auto.
    - inversion ND; subst.
      apply IHPE in H2.
      apply ncp_expand in H2.
      destruct H2 as [NDl [NDl' IN]].
      apply ncp_all; auto.
      apply NoDup_cons.
      now rewrite <- IN.
      assumption.
      intros i; simpl; rewrite <- IN; reflexivity.
    - inversion ND; subst.
      inversion H2; subst.
      apply ncp_all; auto.
      + apply NoDup_cons.
        contradict H1; simpl in *; intuition.
        apply NoDup_cons; auto.
        contradict H1; simpl in *; intuition.
      + intros i; simpl.
        intuition.
    - apply IHPE1 in ND.
      generalize (ncp_expand _ _ ND); intros H.
      destruct H as [NDl [NDl' IN]].
      apply IHPE2 in NDl'.
      now apply ncp_trans with (js:=l').
  Qed.

  Lemma ncp_perm is js:
    NatCyclePerm is js ->
    Permutation is js.

    intros ND; induction ND; auto.
    rewrite (Permutation_app_comm is [i]).
    now apply IHND.
  Qed.

End NatCyclePerm.

(** ** [Perm2] Facts

   We are finally ready to state the [Perm2] definition
   and prove it equivalent to [NatCyclePerm], and therefore
   [Permutation]. *)

Section Perm2.
  Hint Constructors NatCyclePerm.

  Inductive Perm2 {A}: list A -> list A -> Prop :=
  | perm2_nil : Perm2 [] []
  | perm2_cons : forall x y a,
      Perm2 x y -> Perm2 (a :: x) (a :: y)
  | perm2_cycle : forall x y a,
      Perm2 (a :: x) y -> Perm2 (x ++ [a]) y.
  Hint Constructors Perm2.

  Lemma perm2_length_eq {A} (xs ys:list A):
    Perm2 xs ys ->
    length xs = length ys.

    intros PE; induction PE; auto.
    simpl; now apply eq_S.
    rewrite app_length; rewrite <- IHPE; simpl. omega.
  Qed.

  Lemma ncp_perm2 {A} is js (ctx:list A):
    NatCyclePerm is js ->
    AllLess (length ctx) is ->
    Perm2 (map_nth is ctx) (map_nth js ctx).

    intros PE AL.
    induction PE; simpl.
    - auto.
    - remember (nth_error ctx i) as a.
      destruct a; constructor.
      apply IHPE; now apply (AllLess_skip AL).
    - assert (AllLess (length ctx) is) as ALX by (now apply (AllLess_app_1 AL)).
      assert (Perm2 (map_nth (i :: is) ctx) (map_nth js ctx)) as IPE.
      apply IHPE.
      apply AllLess_cons; auto; apply (AllLess_app_2 AL); intuition.
      clear IHPE.
      rewrite map_nth_app by (apply ALX).
      simpl in *.
      remember (nth_error ctx i) as a; destruct a.
      + now apply perm2_cycle.
      + symmetry in Heqa; apply nth_error_None in Heqa.
        assert (i < length ctx) by (apply AL; intuition).
        omega.
  Qed.

  Lemma perm2_np {A} (xs ys:list A):
    Perm2 xs ys ->
    exists is, NatCyclePerm is (iota (length xs))
               /\ map_nth is ys = xs.

    intros PE; induction PE.
    - exists []; repeat split; auto.
    - destruct IHPE as [is [NPE MX]].
      exists (0 :: map S is).
      apply ncp_expand in NPE.
      destruct NPE as [NDi [NDj IN]].
      split.
      + simpl length.
        rewrite iota_S; constructor.
        apply ncp_all.
        * apply FinFun.Injective_map_NoDup; auto.
          unfold FinFun.Injective; now apply eq_add_S.
        * apply FinFun.Injective_map_NoDup; auto.
          unfold FinFun.Injective; now apply eq_add_S.
        * intros; repeat rewrite in_map_iff.
          split; intros.
          destruct H as [m [S I]].
          exists m; rewrite <- IN; intuition.
          destruct H as [m [S I]].
          exists m; rewrite IN; intuition.
        * rewrite in_map_iff.
          intro H; destruct H as [m [S I]]; omega.
      + simpl.
        rewrite map_nth_cons.
        rewrite MX; auto.
    - destruct IHPE as [is [NP MX]].
      assert (length is = length (iota (length (a :: x)))) as Lis
          by (apply (ncp_length_eq NP)).
      rewrite iota_length in Lis; simpl in Lis.
      destruct is; simpl in MX; try discriminate.
      remember (nth_error y n) as b.
      destruct b; try discriminate.
      exists (is ++ [n]); split.
      + apply ncp_cycle.
        rewrite app_length; rewrite plus_comm;
          rewrite <- app_length; now apply NP.
      + inversion MX; subst.
        rewrite map_nth_app; simpl.
        now rewrite <- Heqb.
        rewrite map_nth_length.
        now apply eq_add_S.
  Qed.

  Lemma perm2_refl {A} (xs:list A):
    Perm2 xs xs.

    rewrite <- (map_nth_iota xs).
    apply ncp_perm2.
    apply ncp_refl.
    apply iota_NoDup.
    apply iota_AllLess.
  Qed.

  Lemma perm2_sym {A} (xs ys:list A):
    Perm2 xs ys -> Perm2 ys xs.

    intros.
    assert (length xs = length ys) as LE by (now apply perm2_length_eq).
    apply perm2_np in H.
    destruct H as [is [NP MX]].
    apply ncp_sym in NP.
    rewrite <- MX.
    rewrite <- (map_nth_iota ys) at 1.
    rewrite <- LE.
    apply ncp_perm2; auto.
    rewrite <- LE; now apply iota_AllLess.
  Qed.

  (* Transitivity in [Perm2] doesn’t follow immediately from
     transitivity in [NatCyclePerm], for a funny reason. The
     [perm2_np] lemma lets us construct [NatCyclePerm]s
     between [xs] and [ys], and between [ys] and [zs]---but
     unfortunately, those [NatCyclePerm]s are unrelated!
     (The [nat] list used to represent [ys] differs.) So we
     need to add another link to the transitive chain.
     That’s what NoDup_nat_complete is for. *)

  Lemma perm2_trans {A} (xs ys zs:list A):
    Perm2 xs ys ->
    Perm2 ys zs ->
    Perm2 xs zs.

    intros PX PY.
    remember (length xs) as n.
    generalize (perm2_length_eq _ _ PX); intros Heqys.
    generalize (perm2_length_eq _ _ PY); intros Heqzs.
    rewrite <- Heqn in *; rewrite <- Heqys in *.

    apply perm2_np in PX.
    destruct PX as [is [NPX MX]].
    apply perm2_np in PY.
    destruct PY as [js [NPY MZ]].
    rewrite <- Heqn in *; rewrite <- Heqys in *.
    generalize (ncp_length_eq NPX); intros Heqjs.
    generalize (ncp_length_eq NPY); intros Heqks.
    rewrite iota_length in *.

    assert (AllLess n is) as ALI. {
      unfold AllLess; intros i H.
      apply in_iota_iff.
      now apply (ncp_in_iff NPX).
    }
    assert (AllLess n js) as ALJ. {
      unfold AllLess; intros j H.
      apply in_iota_iff.
      now apply (ncp_in_iff NPY).
    }
    generalize (ncp_NoDup_is NPX); intros NDi.
    generalize (ncp_NoDup_is NPY); intros NDj.
    assert (length (map_nth is js) = n) as Heqmij. {
      pose (map_nth_length is js).
      rewrite Heqks in i.
      rewrite i in ALI.
      rewrite <- ALI; now rewrite Heqjs.
    }
    assert (forall a, In a (map_nth is js) <-> In a (iota n)) as IN. {
      intros i; split; intros.
      - apply in_map_nth in H; now apply (ncp_in_iff NPY).
      - apply NoDup_nat_complete.
        apply map_nth_NoDup; auto.
        unfold AllLess; intros ii HH.
        rewrite Heqmij.
        apply ALJ.
        now apply in_map_nth with (is0:=is).
        rewrite Heqmij; now apply in_iota_iff.
    }

    replace xs with (map_nth (map_nth is js) zs).
    replace zs with (map_nth (iota n) zs) at 2.

    - apply ncp_perm2.
      apply ncp_all; auto.
      apply map_nth_NoDup; auto.
      now apply iota_NoDup.
      rewrite <- Heqzs; unfold AllLess; intros i H.
      apply ALJ; now apply (in_map_nth is).
    - rewrite Heqzs; apply map_nth_iota.
    - rewrite <- map_nth_compose.
      now rewrite MZ.
      now rewrite Heqks.
      now rewrite <- Heqzs.
  Qed.

End Perm2.


Require Import Arith Bool.

Search ((_+_) = (_+_)).
(*
Nat.add_comm:
        forall n m : nat,
        n + m = m + n
Nat.add_assoc: forall n m p : nat, n + (m + p) = n + m + p
 *)

Proposition foo :
  forall n1 n2 n3 : nat,
    (n3 + n1) + n2 = n1 + (n2 + n3).

Proof.
  intro x.

  Restart.

  intro n1.
  intro n2.
  intro n3.

  Restart.

  intros n1 n2 n3.
  (*Note that in goals the parenthesis on LHS is gone because coq is implicitly left-to-right already.*)

  Check (Nat.add_comm n3 n1).
  rewrite -> (Nat.add_comm n3 n1).

  Check (Nat.add_assoc n1 n3 n2).
  rewrite <- (Nat.add_assoc n1 n3 n2).

  Check (Nat.add_comm n3 n2).
  rewrite -> (Nat.add_comm n3 n2).

  reflexivity.

  Restart.

  intros n1 n2 n3.

  Check (Nat.add_comm n2 n3).
  rewrite -> (Nat.add_comm n2 n3).

  Check (Nat.add_assoc n1 n3 n2).
  rewrite -> (Nat.add_assoc n1 n3 n2).

  Check (Nat.add_comm n1 n3).
  rewrite -> (Nat.add_comm n1 n3).

  reflexivity.

  Restart.

  intros n1 n2 n3.
  Check (Nat.add_comm n1 (n2 + n3)).
  rewrite -> (Nat.add_comm n1 (n2 + n3)).

  Check (Nat.add_comm n2 (n3 + n1)).
  rewrite -> (Nat.add_comm (n3 + n1) n2).

  Check (Nat.add_assoc n2 n3 n1).
  rewrite -> (Nat.add_assoc n2 n3 n1).

  reflexivity.
Qed.


From LF Require Export Basics.

Theorem plus_n_O : forall n : nat, n = n + 0.
Proof.
  intro n. induction n as [| n' IHn'].
  - reflexivity.
  - simpl. rewrite <- IHn'. reflexivity.
Qed.

Theorem minus_diag : forall n, minus n n = 0.
Proof.
  intro n. induction n as [| n' IHn'].
  - reflexivity.
  - simpl. apply IHn'.
Qed.

Theorem mult_O_r : forall n : nat, n * 0 = 0.
Proof.
  intro n. induction n as [| n' IHn'].
  - reflexivity.
  - simpl. apply IHn'.
Qed.

Theorem plus_n_Sm : forall n m : nat, S (n + m) = n + (S m).
Proof.
  intros n m.
  induction n as [|n' IHn'].
  - simpl. reflexivity.
  - simpl. rewrite IHn'. reflexivity.
Qed.

Theorem plus_comm : forall n m : nat, n + m = m + n.
Proof.
  intros n m.
  induction n as [|n' IHn'].
  - simpl. apply plus_n_O.
  - simpl. rewrite IHn'. apply plus_n_Sm.
Qed.

Theorem plus_assoc : forall n m p : nat,
    n + (m + p) = (n + m) + p.
Proof.
  intros n m p. induction n as [| n' IHn'].
  - simpl. reflexivity.
  - simpl. rewrite IHn'. reflexivity.
Qed.

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

Lemma double_plus : forall n, double n = n + n.
Proof.
  intro n; induction n as [|n' IHn'].
  - reflexivity.
  - simpl. rewrite <- plus_n_Sm. rewrite IHn'. reflexivity.
Qed.

Theorem evenb_S : forall n : nat,
    evenb (S n) = negb (evenb n).
Proof.
  intro n. induction n as [|n' IHn'].
  - reflexivity.
  - rewrite IHn'. simpl. rewrite negb_involutive.
    reflexivity.
Qed.

Theorem plus_rearrange : forall n m p q : nat,
    (n + m) + (p + q) = (m + n) + (p + q).
Proof.
  intros.
  assert (H: n + m = m + n). { apply plus_comm. }
  rewrite H. reflexivity.
Qed.