Set Warnings "-notation-overridden,-parsing,-deprecated-hint-without-locality".
From LF Require Export Tactics.

Example and_exercise :
  forall n m : nat, n + m = 0 -> n = 0 /\ m = 0.
Proof.
  intros.
  split.
  induction n.
  reflexivity.
  discriminate H.
  induction m.
  reflexivity.
  assert (forall n m, n+ S m = S (n+m)).
  induction n0.
  reflexivity.
  intros.
  simpl.
  rewrite IHn0.
  reflexivity.
  rewrite H0 in H.
  discriminate H.
  Qed.

Lemma and_example2 :
  forall n m : nat, n = 0 /\ m = 0 -> n + m = 0.
Proof.
  (* WORKED IN CLASS *)
  intros n m H.
  destruct H as [Hn Hm].
  rewrite Hn. rewrite Hm.
  reflexivity.
Qed.

Lemma and_example3 :
  forall n m : nat, n + m = 0 -> n * m = 0.
Proof.
  (* WORKED IN CLASS *)
  intros n m H.
  apply and_exercise in H.
  destruct H as [Hn Hm].
  rewrite Hn. reflexivity.
Qed.

Lemma proj1 : forall P Q : Prop,
  P /\ Q -> P.
Proof.
  intros P Q HPQ.
  destruct HPQ as [HP _].
  apply HP. Qed.

Theorem and_assoc : forall P Q R : Prop,
  P /\ (Q /\ R) -> (P /\ Q) /\ R.
Proof.
  intros P Q R [HP [HQ HR]].
  split. split.
  apply HP. apply HQ. apply HR. Qed.

Lemma factor_is_O:
  forall n m : nat, n = 0 \/ m = 0 -> n * m = 0.
Proof.
  (* This pattern implicitly does case analysis on
     n = 0 \/ m = 0 *)
  intros n m [Hn | Hm].
  - (* Here, n = 0 *)
    rewrite Hn. reflexivity.
  - (* Here, m = 0 *)
    rewrite Hm. rewrite <- mult_n_O.
    reflexivity.
Qed.

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

Lemma zero_or_succ :
  forall n : nat, n = 0 \/ n = S (pred n).
Proof.
  (* WORKED IN CLASS *)
  intros [|n'].
  - left. reflexivity.
  - right. reflexivity.
Qed.

Module MyNot.
Definition not (P:Prop) := P -> False.
Notation "~ x" := (not x) : type_scope.
Check not : Prop -> Prop.
End MyNot.

Theorem ex_falso_quodlibet : forall (P:Prop),
  False -> P.
Proof.
  (* WORKED IN CLASS *)
  intros P contra.
  destruct contra. Qed.

Theorem contrapositive : forall (P Q : Prop),
  (P -> Q) -> (~Q -> ~P).
Proof.
  intros .
  unfold not.
  unfold not in H0.
  intros.
  apply H in H1.
  apply H0 in H1.
  destruct H1.
  Qed.

Theorem not_both_true_and_false : forall P : Prop,
  ~ (P /\ ~P).
Proof.
  intros.
  unfold not.
  intros.
  destruct H.
  apply H0 in H.
  destruct H.
  Qed.

Theorem not_true_is_false' : forall b : bool,
  b <> true -> b = false.
Proof.
  intros [] H. (* note implicit destruct b here *)
  - (* b = true *)
    unfold not in H.
    exfalso. (* <=== *)
    apply H. reflexivity.
  - (* b = false *) reflexivity.
Qed.

Lemma True_is_true : True.
Proof. apply I. Qed.

Definition disc_fn (n: nat) : Prop :=
  match n with
  | O => True
  | S _ => False
  end.

Theorem disc : forall n, ~ (O = S n).
Proof.
  intros n H1.
  assert (H2 : disc_fn O). { simpl. apply I. }
  rewrite H1 in H2. simpl in H2. apply H2.
Qed.

Module MyIff.
Definition iff (P Q : Prop) := (P -> Q) /\ (Q -> P).
Notation "P <-> Q" := (iff P Q)
                      (at level 95, no associativity)
                      : type_scope.
End MyIff.

Theorem or_distributes_over_and : forall P Q R : Prop,
  P \/ (Q /\ R) <-> (P \/ Q) /\ (P \/ R).
Proof.
  intros.
  split.
  intros.
  split.
  destruct H.
  left. apply H.
  destruct H.
  right.
  exact H.
  destruct H.
  left.
  exact H.
  destruct H.
  right.
  exact H0.
  intros.
  destruct H.
  destruct H.
  destruct H0.
  left.
  exact H.
  left.
  exact H.
  destruct H0.
  left.
  exact H0.
  right.
  split .
  exact H.
   exact H0.
   Qed.

From Coq Require Import Setoids.Setoid.

Lemma mul_eq_0 : forall n m, n * m = 0 <-> n = 0 \/ m = 0.
intros n.
induction n.
induction m.
split.
left.
reflexivity.
reflexivity.
split.
left.
reflexivity.
reflexivity.
induction m.
split.
right.
reflexivity.
simpl.
assert (forall n, n*0=0).
induction n0.
reflexivity.
simpl.
exact IHn0.
intros.
apply H.
split.
intros.
simpl in H.
discriminate H.
intros. destruct H.
discriminate H.
discriminate H.
Qed.

Theorem or_assoc :
  forall P Q R : Prop, P \/ (Q \/ R) <->(P \/ Q) \/ R.
Proof.
  intros P Q R. split.
  - intros [H | [H | H]].
    + left. left. apply H.
    + left. right. apply H.
    + right. apply H.
  - intros [[H | H] | H].
    + left. apply H.
    + right. left. apply H.
    + right. right. apply H.
Qed.

Lemma mul_eq_0_ternary :
  forall n m p, n * m * p = 0 <-> n = 0 \/ m = 0 \/ p = 0.
Proof.
  intros n m p.
  rewrite mul_eq_0. rewrite mul_eq_0. rewrite or_assoc.
  reflexivity.
Qed.

Definition Even x := exists n : nat, x = double n.
Lemma four_is_even : Even 4.
Proof.
  unfold Even. exists 2. reflexivity.
Qed.

Theorem exists_example_2 : forall n,
  (exists m, n = 4 + m) ->
  (exists o, n = 2 + o).
Proof.
  (* WORKED IN CLASS *)
  intros n [m Hm]. (* note implicit destruct here *)
  exists (2 + m).
  apply Hm. Qed.

Theorem dist_not_exists : forall (X:Type) (P : X -> Prop),
  (forall x, P x) -> ~ (exists x, ~ P x).
Proof.
  intros.
  unfold not.
  intros.
  destruct H0 as [x E] .
  apply E in H.
  destruct H.
  Qed.

Theorem dist_exists_or : forall (X:Type) (P Q : X -> Prop),
  (exists x, P x \/ Q x) <-> (exists x, P x) \/ (exists x, Q x).
Proof.
  intros.
  split.
  intros.
  destruct H.
  destruct H.
  left.
  exists x.
  exact H.
  right.
  exists x.
  exact H.
  intros.
 destruct H.
 destruct H.
 exists x.
 left.
 exact H.
 destruct H.
 exists x.
 right.
 exact H.
 Qed.
 Fixpoint In {A : Type} (x : A) (l : list A) : Prop :=
  match l with
  | [] => False
  | x' :: l' => x' = x \/ In x l'
  end.

Theorem In_map :
  forall (A B : Type) (f : A-> B) (l : list A) (x : A),
         In x l->
         In (f x) (map f l).
Proof.
  intros A B f l x.
  induction l as [|x' l' IHl'].
  - (* l = nil, contradiction *)
    simpl. intros [].
  - (* l = x' :: l' *)
    simpl. intros [H | H].
    + rewrite H. left. reflexivity.
    + right. apply IHl'. apply H.
Qed.

Theorem In_map_iff :
  forall (A B : Type) (f : A-> B) (l : list A) (y : B),
         In y (map f l) <->
         exists x, f x = y /\ In x l.
Proof.
  intros A B f l y. split.
  intros. induction l.
  simpl in H.
  destruct H.
  simpl in H. destruct H.
  exists x.
  split.
  apply H.
  simpl.
  left.
  reflexivity.
  apply IHl in H.
  destruct H.
  exists x0.
  split.
  destruct H.
  exact H.
  simpl.
  right.
  destruct H.
  exact H0.
  intros.
  destruct H.
  destruct H.
  induction l.
  simpl in H0.
  destruct H0.
  simpl.

  simpl in H0.
  destruct H0.
  left.
  rewrite H0.
  exact H.
  apply IHl in H0.
  right.
  exact H0.
  Qed.
  Theorem In_app_iff : forall A l l' (a:A),
  In a (l++l') <-> In a l \/ In a l'.
Proof.
  intros A l. induction l as [|a' l' IH].
  intros.
  induction l'.
  simpl.
  split.
  intros.
  destruct H.
  intros.
  destruct H.
  destruct H.
  destruct H.
  simpl.
  split.
  intros.
  destruct H.
  right. left. exact H.
  right. right. exact H.
  simpl in IHl'.
  intros.
  destruct H.
  destruct H.
  exact H.
  intros.
  split.
  intros.
  simpl in H.
  destruct H.
  left.
  simpl.
  left.
  exact H.
  rewrite IH in H.
  destruct H.
  left.
  simpl.
  right.
  exact H.
  right.
  exact H.
  intros.
  destruct H.
  simpl.
  simpl in H.
  destruct H.
  left.
  exact H.
  right.
  apply IH.
  left.
  exact H.
  simpl.
  right.
  apply IH.
  right.
  exact H.
  Qed.

 Fixpoint All {T} (P : T -> Prop) (l : list T) : Prop :=
 match l with
  |nil => True
  |x :: l => (P x) /\ (All P l)
 end.
 Theorem All_In :
  forall T (P : T-> Prop) (l : list T),
    (forall x, In x l-> P x) <->
    All P l.
Proof.
  intros.
  split.
  intros.
  induction l.
  exact I.
  simpl.
  split.
  simpl in H.
  apply H.
  left.
  reflexivity.
  apply IHl.
  intros.
  apply H.
  simpl.
  right.
  exact H0.
  intros.
  induction l.
  destruct H0.
  destruct H.
  destruct H0.
  rewrite H0 in H.
  exact H.
  apply IHl in H1.
  exact H1.
  exact H0.
  Qed.

Fixpoint rev_append {X} (l1 l2 : list X) : list X :=
  match l1 with
  | [] => l2
  | x :: l1' => rev_append l1' (x :: l2)
  end.
Axiom functional_extensionality : forall {X Y: Type}
                                    {f g : X -> Y},
  (forall (x:X), f x = g x) -> f = g.
Definition tr_rev {X} (l : list X) : list X :=
  rev_append l [].
Lemma append_comm: forall X (x y z: list X), x++y++z = (x++y)++z.
intros X x.
induction x.
reflexivity.
simpl.
intros.
rewrite IHx.
reflexivity.
Qed.
Lemma con_one : forall X (x:X) y, [x] ++ y = x::y.
intros.
generalize dependent x.
induction y.
reflexivity.
intros.
simpl.
reflexivity.
Qed.
Lemma lemma: forall X (x y:list X) , rev_append x y = (rev_append x []) ++ y.
intros.
generalize dependent y.
induction x.
reflexivity.
intros y.
simpl.
rewrite IHx, IHx with [x].
rewrite <- append_comm.
rewrite con_one.
reflexivity.
Qed.

Theorem tr_rev_correct : forall X, @tr_rev X = @rev X.
Proof.
intros.
apply functional_extensionality.
intros.
induction x.
reflexivity.
simpl.
unfold tr_rev.
simpl.
unfold tr_rev in IHx.
rewrite <- IHx.
rewrite lemma.
reflexivity.
Qed.

Lemma even_double : forall k, even (double k) = true.
Proof.
  intros k. induction k as [|k' IHk'].
  - reflexivity.
  - simpl. apply IHk'.
Qed.

Lemma even_double_conv : forall n, exists k,
  n = if even n then double k else S (double k).
  induction n.
  exists 0.
  reflexivity.
  destruct IHn .
  rewrite even_S.
  destruct (even n).
  exists x.
  simpl.
  rewrite H.
  reflexivity.
  exists (S x).
  rewrite H.
  reflexivity.
  Qed.

Theorem even_bool_prop : forall n,
  even n = true <-> Even n.
  Proof.
  split.
  destruct (even_double_conv n) as [k Hk].
  intros.
  rewrite H in Hk.
  exists k.
  exact Hk.
  intros [k Hk].
  rewrite Hk.
  apply even_double.
  Qed.

Theorem eqb_eq : forall n1 n2 : nat,
  n1 =? n2 = true <-> n1 = n2.
Proof.
  intros n1 n2. split.
  - apply eqb_true.
  - intros H. rewrite H. assert (forall n, n=? n = true).
  induction n. reflexivity. simpl. rewrite IHn. reflexivity.
  apply H0.
Qed.

Theorem andb_true_iff : forall b1 b2:bool,
  b1 && b2 = true <-> b1 = true /\ b2 = true.
Proof.
  intros.
  split.
  destruct b1, b2 .
  split.
  reflexivity.
  reflexivity.
  simpl.
  intros.
  destruct H.
  split.
  reflexivity.
  reflexivity.
  simpl.
  intros.
  destruct H.
  split.
  reflexivity.
  reflexivity.
  intros.
  destruct H.
  split.
  reflexivity.
  reflexivity.
  intros.
  destruct H.
  rewrite H, H0.
  reflexivity.
  Qed.
Theorem orb_true_iff : forall b1 b2,
  b1 || b2 = true <-> b1 = true \/ b2 = true.
Proof.
  intros.
  split.
  destruct b1, b2.
  intros.
  left.
  reflexivity.
  left.
  reflexivity.
  right.
  reflexivity.
  intros.
  destruct H.
  right.
  reflexivity.
  intros.
  destruct H.
  rewrite H.
  reflexivity.
  rewrite H.
  destruct b1.
  reflexivity.
  reflexivity.
  Qed.

Theorem eqb_neq : forall x y : nat,
  x =? y = false <-> x <> y.
Proof.
intros.
split.
  intros.
  generalize dependent x.
  induction y.
  induction x.
  intros.
  simpl in H.
  discriminate H.
  intros.
  destruct H.
  induction x.
  unfold not.
  intros.
  discriminate H.
  unfold not.
  intros.
  discriminate H.
  intros x.
  induction x.
  intros.
  unfold not.
  intros.
  discriminate H0.
  intros.
  unfold not.
  intros.
  injection  H0.
  intros.
  simpl in H.
  apply IHy in H.
  unfold not in H.
  apply H in H1.
  apply H1.
  intros.
  unfold not in H.
  generalize dependent y.
   induction x.
   induction y.
   intros.
   destruct H.
   reflexivity.
   intros.
   reflexivity.
   induction y. intros.
   reflexivity.
   intros.
   simpl.
   apply IHx.
   intros.
   assert (S x = S y).
   rewrite H0.
   reflexivity.
   apply H in H1.
   exact H1.
   Qed.

Fixpoint eqb_list {A : Type} (eqb : A -> A -> bool)
                  (l1 l2 : list A) : bool:=
match l1, l2 with
| [], [] => true
| _, [] => false
| [], _ => false
| h::t, h'::t' => if eqb h h' then eqb_list eqb t t' else false
end.

Theorem eqb_list_true_iff :
  forall A (eqb : A -> A -> bool),
    (forall a1 a2, eqb a1 a2 = true <-> a1 = a2) ->
    forall l1 l2, eqb_list eqb l1 l2 = true <-> l1 = l2.

Proof.
intros.
generalize dependent eqb .
generalize dependent l2 .
induction l1.
intros.
induction l2.
split.
reflexivity.
reflexivity.
split.
discriminate.
simpl.
discriminate.
induction l2.
intros.
split.
discriminate.
discriminate.
intros.
split.
simpl.
destruct (eqb x x0) eqn:K.
intros. apply IHl1 in H0.
rewrite H0. apply H in K.
rewrite K.
reflexivity.
intros. apply H.
discriminate.
simpl . destruct (eqb x x0) eqn:K.
intros. apply IHl1. intros.
apply H.
injection H0.
intros. exact H1.
intros.
injection H0.
intros. apply H in H2.
rewrite K in H2.
discriminate H2.
Qed.
Theorem forallb_true_iff : forall X test (l : list X),
  forallb test l = true <-> All (fun x => test x = true) l.
Proof.
intros.
generalize dependent test.
induction l.
intros.
split.
reflexivity.
reflexivity.
intros.
split.
intros.
simpl.
split.
simpl in H.
destruct (test x) eqn:K in H.
exact K.
discriminate H.
simpl in H.
destruct (test x) eqn:K in H.
apply IHl in H.
exact H.
discriminate H.
intros.
simpl.
destruct (test x) eqn:K.
apply IHl.
simpl in H.
destruct H.
exact H0.
simpl in H. destruct H.
rewrite H in K.
discriminate K.
Qed.
Theorem restricted_excluded_middle : forall P b,
  (P <-> b = true) -> P \/ ~P.
Proof.
  intros P [] H.
  - left. rewrite H. reflexivity.
  - right. rewrite H. intros contra. discriminate contra.
Qed.

Theorem restricted_excluded_middle_eq : forall (n m : nat),
  n = m \/ n <> m.
Proof.
  intros n m.
  apply (restricted_excluded_middle (n = m) (n =? m)).
  symmetry.
  apply eqb_eq.
Qed.

Theorem excluded_middle_irrefutable: forall (P:Prop),
  ~~ (P \/ ~ P).
Proof.
  unfold not. intros P H.
  apply H.
  right.
  intros. destruct H.
  left.
  apply H0.
  Qed.

Definition excluded_middle := forall P : Prop,
  P \/~ P.
Theorem not_exists_dist :
  excluded_middle ->
  forall (X:Type) (P : X -> Prop),
    ~ (exists x, ~ P x) -> (forall x, P x).
Proof.
intros.
unfold not in H0.
unfold excluded_middle in H.
assert (P x \/ ~ (P x)).
apply H.
destruct H1.
exact H1.
destruct H0.
exists x.
exact H1.
Qed.

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

Theorem thm1: excluded_middle  -> peirce .
Proof.
intros.
unfold excluded_middle in H.
unfold peirce.
intros.
assert (P \/ ~P).
apply H.
destruct H1.
exact H1.
unfold not in H1.
apply H0.
intros.
apply H1 in H2.
destruct H2.
Qed.

Theorem thm2: peirce  -> double_negation_elimination .
unfold peirce.
unfold double_negation_elimination.
intros.
unfold not in H0.
apply H with (Q:=False).
intros.
apply H0 in H1.
destruct H1.
Qed.

Theorem thm3: double_negation_elimination  -> de_morgan_not_and_not .
Proof.
unfold double_negation_elimination.
unfold de_morgan_not_and_not.
intros.
unfold not in H0.
unfold not in H.

assert (((P \/ Q -> False) -> False) -> P \/ Q).
apply H.
apply H1.
intros.
assert (forall P Q:Prop,((P -> False) /\ (Q -> False) -> False)->((P \/ Q -> False) -> False)).
intros.
apply H3.
split.
intros.
assert (P0 \/ Q0).
left.
exact H5.
apply H4 in H6.
exact H6.
intros.
assert (P0\/Q0).
right.
exact H5.
apply H4 in H6.
exact H6.
apply H3 in H0.
exact H0.
exact H2.
Qed.

Theorem thm4: de_morgan_not_and_not  -> implies_to_or .
Proof.
unfold de_morgan_not_and_not.
unfold implies_to_or.
intros.
assert(~ (~ ~P /\ ~ Q) -> ~P \/ Q).
apply H.
destruct H1.
unfold not.
intros.
destruct H1.
assert (P->False).
intros.
apply H0 in H3.
apply H2 in H3.
exact H3.
apply H1 in H3.
exact H3.
left.
apply H1.
right.
apply H1.
Qed.

Theorem thm5: implies_to_or  -> excluded_middle .
Proof.
unfold implies_to_or.
unfold excluded_middle.
intros.
assert((P -> P) -> ~ P \/ P).
apply H.
assert (P->P).
intros.
exact H1.
apply H0 in H1.
destruct H1.
right.
exact H1.
left.
exact H1.
Qed.


(* Comments in Coq are as in Ocaml and SML:  they start with a left-paren
   and asterisk, and are closed with an asterisk and right-paren. *)

Require Import Arith.

(* [Require Import Arith.] is a top-level command that tells Coq to import
   the definitions from the [Arith] library (arithmetic) and to make the
   definitions available at the top-level.  All top-level commands end
   with a period.
*)

Definition four : nat := 4.

(* A top-level definition begins with the keyword [Definition], followed
   by an identifier (in this case [four]) that we want to use, a colon,
   a type, [:=], and then an expression followed by a period.
   Here the type of the number [4] is [nat] which stands for natural number.  *)

Definition four' := 2 + 2.
(* You can leave off the type information and Coq can often infer it.
   But it can't always infer types, and it's good documentation to put
   the types on complicated definitions. *)

Eval compute in four'.
Eval compute in four + four'.
(* [Eval compute in <exp>.] lets you evaluate an expression to see the
   resulting value and type. *)

Check four'.
(* [Check <exp>] lets you check the type of an expression. *)

Print four'.
(* [Print <identifier>] lets you see the definition of the identifier. *)

Definition four'' := (6 - 4) * 2.

Check four''.
Eval compute in four''.
Print four''.

Definition inc (x:nat) : nat := x + 1.
(* To define a function, we just make a parameterized definition.*)

Check inc.
Eval compute in inc.
Eval compute in inc four.

Definition inc' x := x + 1.
(* As in Ocaml, we can leave off the types and Coq can usually infer them,
   but not always. *)

Check inc'.
Print inc'.
Eval compute in inc' four.

Definition inc'' := fun (x:nat) => x + 1.
(* Parameterized definitions are just short-hand for a regular definition
   using a lambda expression. *)

Check inc''.
Eval compute in inc'' four.

Definition add1 x y := x + y.
Definition add2 (x:nat) (y:nat) := x + y.
Definition add3 (x y:nat) := x + y.
(* When the types are the same, we can group parameters as in [add']. *)
Definition add4 := fun x => fun y => x + y.
(* Multiple parameters are just iterated lambdas. *)

Check add1.
Check add2.
Check add3.
Check add4.
Eval compute in add1 5 4.
Eval compute in add2 5 4.

Definition inc''' := add1 1.
Eval compute in inc'''.
Eval compute in inc''' 4.

Inductive bool : Type :=
| true
| false.
(* An inductive definition is just like an Ocaml datatype definition,
   though the syntax is a little different.  Here, we are defining
   a new [Type] called [bool] with constructors [true] and [false].
   Unlike Ocaml, we can (and generally need to) provide the type of
   each data constructor, hence both [true] and [false] are defined
   as constructors that immediately return a [bool].

   Notice that when we evaluate this definition, Coq says that not
   only is [bool] defined, but also [bool_rect], [bool_ind], and
   [bool_rec].  We'll discuss those later on when we start talking
   about proving things.
*)
Check true.
Check false.
Print bool.

Definition negb (b:bool) : bool :=
  match b with
    | true => false
    | false => true
  end.
(* The definition above shows how we use pattern-matching to tear apart
   an inductive type, in this case a [bool].  The syntax is similar to
   Ocaml except that we use "=>" for the guard instead of "->" and we
   have to put an "end" to terminate the "match". *)

Check negb.
Eval compute in negb true.
Eval compute in negb false.

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

Eval compute in andb true false.
Eval compute in andb true true.

Definition orb b1 b2 :=
  match b1 with
    | true => true
    | _ => b2
  end.

Eval compute in orb true false.
Eval compute in orb true true.

(* The [Arith] module defines this [nat] type already.  It is a way to
   represent the natural numbers, with a base case of zero, "0" and
   successor constructor [S]. Notice that the type of [S] declares
   it to take a [nat] as an argument, before returning a [nat].

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

type nat = O | S of nat
*)

Print nat.

(*
   A digression:

   In informal math, we tend to think of a "type" as a set of
   objects.  For instance, we think of [nat] as the set of
   objects {0,1,2,3,...}.  But we can also form sets out of
   sets.  For instance, we can have {nat,bool,string}.  Technically,
   to avoid circularities, [nat] is considered a "small" set,
   and {nat,bool,string} is considered a "large" set, sometimes
   called a class.  Stratifying our sets is necessary to avoid
   constructions such as S = { s : set | s is not contained in s }
   (Russell's paradox.)

   In Coq, the identifier [Set] refers to a universe of
   types, including {nat,bool,string,...}.  So in some sense,
   the identifier [Set] names a class of types.  We sometimes
   say that [Set] is the type of the collection
   {nat,bool,string,...}. When we build
   certain kinds of new types out of elements of [Set], then we
   have to move up to a new universe.  Internally, that universe
   is called Type_1.  (Actually, [Set] is represented as Type_0
   internally.)  And if we build certain types out of Type_1,
   we have to move up to Type_2.  So Coq has an infinite hierarchy
   Set a.k.a. Type_0, Type_1, Type_2, ...

   Now figuring out where in this hierarchy a definition should go
   isn't that hard, and in fact, Coq automagically infers this
   for you.  When you write [Type], you are really writing [Type_x]
   and Coq is later solving for [x] to make sure your definitions
   don't contain a circularity.  In fact, with the exception of
   [Set] and one more very special universe, [Prop], you can't
   even explicitly say at what level you want a given definition.

   For now, we can just ignore this and use [Type] everywhere.
*)
Check O.
Check 0.   (* the numeral 0 is just notation for the constructor O *)
Eval compute in 0.
Eval compute in 3.
Check S.
Check S 0. (* 1,2,3 are short-hand for (S O), (S (S O)) and (S (S (S O))). *)
Check S (S (S 0)).

Definition is_zero (n:nat) : bool :=
  match n with
    | 0 => true
    | S _ => false
  end.

Fixpoint add'' (n m:nat) : nat :=
  match m with
    | 0 => n
    | S m' => S (add'' n m')
  end.
(* We construct recursive functions by using the keyword "Fixpoint". *)

Eval compute in add'' 4 3.
Print add''.

Definition add5 :=
  fix local_add (n m:nat) : nat :=
  match n with
    | 0 => m
    | S n' => S (local_add n' m)
  end.
(* Alternatively, we can use a "fix" expression which builds a recursive
   functions, similar to the way "fun" builds a non-recursive function.
*)

Eval compute in add5 4 3.
Print add5.

(* Pairs *)
Definition p1 : nat * nat := (3,4).  (* pair of nats *)
Definition p2 : nat * bool := (3, true).  (* nat and bool *)
Definition p3 : nat * bool * nat := (3,true,2).

Eval compute in add3 (fst p1) (snd p1).
(* [fst] extracts the first component of a pair, and [snd]
   extracts the second component. *)

Eval compute in fst p3.
Eval compute in snd p3.

Print pair.
Eval compute in match p1 with
                  | pair x y => x + y
                end.
Locate "_ * _".

(* Notice that [(3,true,2)] is really short-hand for [((3,true),2)].
   and [nat * bool * nat] is short for [(nat * bool) * nat]. *)

(* Options *)
Definition opt1 : option nat := None.
Definition opt2 : option nat := Some 4.
(* An [option t] is either [None] or [Some] applied to a value of type [t].
   Notice that unlike Ocaml, we write [option nat] instead of [nat option].
*)
Print option.

Fixpoint subtract (m n:nat) : option nat :=
  match m, n with
    | _, 0 => Some m
    | 0, S _ => None
    | S m', S n' => subtract m' n'
  end.
Eval compute in subtract 5 2.
Eval compute in subtract 2 5.

Definition subt (m n:nat) : nat :=
  match subtract m n with
    | None => 0
    | Some i => i
  end.
Eval compute in subt 5 2.
Eval compute in subt 2 5.

(* Sums *)
Locate "_ + _".
Print sum.

Definition s1 : nat + bool := inl 3.
Definition s2 : nat + bool := inr true.
(* We build something of type [t1 + t2] by using either [inl] or
   [inr].  It's important to provide Coq enough type information
   that it can figure out what the other type is. *)

Definition add_nat_or_bool (s1 s2: nat + bool) : nat + bool :=
  match s1, s2 with
    | inl n1, inl n2 => inl (n1 + n2)
    | inr b1, inr b2 => inr (orb b1 b2)
    | _, _ => inr false
  end.

(* Lists *)
Require Import List.
Print list.
Definition l1 : list nat := nil.
Definition l2 : list nat := 3::2::1::nil.
Definition l3 : list bool := true::false::nil.
Definition l4 : list (nat + bool) := (inl 3)::(inr true)::nil.

Fixpoint append (l1 l2:list nat) : list nat :=
  match l1 with
    | nil => l2
    | h::t => h::(append t l2)
  end.

Eval compute in append l2 l2.

Fixpoint add_list (l1 l2:list nat) : option (list nat) :=
  match l1, l2 with
    | nil, nil => Some nil
    | n1::l1, n2::l2 =>
      match add_list l1 l2 with
        | None => None
        | Some l => Some ((n1+n2)::l)
      end
    | _, _ => None
  end.

Eval compute in add_list l2 l2.
Eval compute in add_list l2 (1::nil).
(* Polymorphism *)

Fixpoint generic_append (A:Type) (l1 l2: list A) : list A :=
  match l1 with
    | nil => l2
    | h::t => h::(generic_append A t l2)
  end.
(* Unlike Ocaml, we make type parameters explicit in Coq.  Here,
   we've defined a generic append function, which abstracts over
   a type [A].  Notice that the types of the arguments [l1] and
   [l2] depend upon [A], as does the result type.  Notice also
  that when we call this function, we must provide an actual
  type for the instantiation of [A].
*)

Eval compute in generic_append bool l3 l3.
Eval compute in generic_append nat l1 l2.
Eval compute in generic_append _ l3 l3.
(* Coq can usually figure out what the types are, and we can
   leave out the type by just putting an underscore there
   instead.  But there are cases where it can't figure it
   out (e.g., generic_append _ nil nil).
*)

Fixpoint generic_append' {A:Type} (l1 l2:list A) : list A :=
  match l1 with
    | nil => l2
    | h::t => h::(generic_append' t l2)
  end.
(* The curly braces tell Coq to make an argument implicit.  That
   means it's up to Coq to fill in the argument for you.  Notice
   that in the recursive call, we didn't have to specify the type. *)

Eval compute in generic_append' l1 l1.
Eval compute in generic_append' l2 l2.
Eval compute in generic_append' nil nil.

(* This won't work though:
Definition foo := generic_append' nil nil.
   We can fix it by either giving enough information in the context
   or by using "@" to override the implicit arguments:
*)
Definition foo : list nat := generic_append' nil nil.
Definition foo1 := @generic_append' nat nil nil.


From LF Require Export induction.
Module NatList.

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.

Inductive natprod : Type :=
  | pair (n1 n2 : nat).

Check (pair 3 5).

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

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

Compute (fst (pair 3 5)).

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

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

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

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

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

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

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

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

Inductive natlist : Type :=
  | nil
  | cons (n : nat) (l : natlist).

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

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

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

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

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

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

Notation "x ++ y" := (app x y)
                     (right associativity, at level 60).
Example test_app1: [1;2;3] ++ [4;5] = [1;2;3;4;5].
Proof. reflexivity. Qed.
Example test_app2: nil ++ [4;5] = [4;5].
Proof. reflexivity. Qed.
Example test_app3: [1;2;3] ++ nil = [1;2;3].
Proof. reflexivity. Qed.

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

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

Example test_hd1: hd 0 [1;2;3] = 1.
Proof. reflexivity. Qed.
Example test_hd2: hd 0 [] = 0.
Proof. reflexivity. Qed.
Example test_tl: tl [1;2;3] = [2;3].
Proof. reflexivity. Qed.

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

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

Fixpoint oddmembers (l:natlist) : natlist :=
  match l with
  | nil => nil
  | h :: t => if oddb h
      then h :: oddmembers t
      else oddmembers t
  end.

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

Definition countoddmembers (l:natlist) : nat :=
  length (oddmembers l).

Example test_countoddmembers2:
  countoddmembers [0;2;4] = 0.
Proof. simpl. reflexivity. Qed.

Example test_countoddmembers3:
  countoddmembers nil = 0.
Proof. simpl. reflexivity. Qed.

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

Example test_alternate1:
  alternate [1;2;3] [4;5;6] = [1;4;2;5;3;6].
Proof. simpl. reflexivity. Qed.

Example test_alternate2:
  alternate [1] [4;5;6] = [1;4;5;6].
Proof. simpl. reflexivity. Qed.

Example test_alternate3:
  alternate [1;2;3] [4] = [1;4;2;3].
Proof. simpl. reflexivity. Qed.

Example test_alternate4:
  alternate [] [20;30] = [20;30].
Proof. simpl. reflexivity. Qed.

Definition bag := natlist.

Fixpoint count (v:nat) (s:bag) : nat :=
  match s with
  | nil => 0
  | h :: t => if eqb h v
      then 1 + (count v t)
      else count v t
  end.

Example test_count1: count 1 [1;2;3;1;4;1] = 3.
Proof. simpl. reflexivity. Qed.

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

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

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

Definition add (v:nat) (s:bag) : bag := sum s [v].

Example test_add1: count 1 (add 1 [1;4;1]) = 3.
Proof. simpl. reflexivity. Qed.

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

Definition member (v:nat) (s:bag) : bool :=
   leb 1 (count v s).

Example test_member1: member 1 [1;4;1] = true.
Proof. simpl. reflexivity. Qed.

Example test_member2: member 2 [1;4;1] = false.
Proof. reflexivity. Qed.

Fixpoint remove_one (v:nat) (s:bag) : bag :=
  match s with
  | nil => nil
  | h :: t => if eqb h v
      then t
      else h :: remove_one v t
  end.

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

Example test_remove_one2:
  count 5 (remove_one 5 [2;1;4;1]) = 0.
Proof. reflexivity. Qed.

Example test_remove_one3:
  count 4 (remove_one 5 [2;1;4;5;1;4]) = 2.
Proof. reflexivity. Qed.

Example test_remove_one4:
  count 5 (remove_one 5 [2;1;5;4;5;1;4]) = 1.
Proof. reflexivity. Qed.

Fixpoint remove_all (v:nat) (s:bag) : bag :=
  match s with
  | nil => nil
  | h :: t => if eqb h v
      then remove_all v t
      else h :: remove_all v t
  end.

Example test_remove_all1: count 5 (remove_all 5 [2;1;5;4;1]) = 0.
Proof. reflexivity. Qed.

Example test_remove_all2: count 5 (remove_all 5 [2;1;4;1]) = 0.
Proof. reflexivity. Qed.

Example test_remove_all3: count 4 (remove_all 5 [2;1;4;5;1;4]) = 2.
Proof. reflexivity. Qed.

Example test_remove_all4: count 5 (remove_all 5 [2;1;5;4;5;1;4;5;1;4]) = 0.
Proof. reflexivity. Qed.

Fixpoint subset (s1:bag) (s2:bag) : bool :=
  match s1 with
  | nil => match s2 with
           | nil => true
           | h :: t => true
           end
  | h :: t => match s2 with
              | nil => false
              | h2 :: t2 =>
                  if leb (count h s1) (count h s2)
                  then subset t s2
                  else false
              end
  end.

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

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

Definition manual_grade_for_bag_theorem : option (nat*string) := None.

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

Theorem tl_length_pred : forall l:natlist,
  pred (length l) = length (tl l).
Proof.
  intros l.
  destruct l as [| n l'].
  - reflexivity.
  - reflexivity.
Qed.

Theorem app_assoc : forall l1 l2 l3 : natlist,
  (l1 ++ l2) ++ l3 = l1 ++ (l2 ++ l3).
Proof.
  intros l1 l2 l3.
  induction l1 as [| n l1' IHl1'].
  - reflexivity.
  - simpl.
    rewrite -> IHl1'.
    reflexivity.
Qed.

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

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

Theorem rev_length_firsttry : forall l : natlist,
  length (rev l) = length l.
Proof.
  intros l. induction l as [| n l' IHl'].
  - (* l =  *)
    reflexivity.
  - (* l = n :: l' *)
    (* This is the tricky case.  Let's begin as usual
       by simplifying. *)
    simpl.
    (* Now we seem to be stuck: the goal is an equality
       involving ++, but we don't have any useful equations
       in either the immediate context or in the global
       environment!  We can make a little progress by using
       the IH to rewrite the goal... *)
       rewrite <- IHl'.
    (* ... but now we can't go any further. *)
Abort.

Theorem app_length : forall l1 l2 : natlist,
  length (l1 ++ l2) = (length l1) + (length l2).
Proof.
  intros l1 l2.
  induction l1 as [| n l1' IHl1'].
  - reflexivity.
  - simpl.
    rewrite -> IHl1'. reflexivity.
Qed.

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

Theorem app_nil_r : forall l : natlist,
  l ++ [] = l.
Proof. induction l as [| n l' IHl'].
  - reflexivity.
  - simpl.
    rewrite -> IHl'.
    reflexivity.
Qed.

Theorem concat_empty: forall l: natlist,
  l ++ [] = l.
Proof.
  induction l as [| n l' IHl'].
  - reflexivity.
  - simpl.
    rewrite -> IHl'.
    reflexivity.
Qed.

Theorem rev_app_distr: forall l1 l2 : natlist,
  rev (l1 ++ l2) = rev l2 ++ rev l1.
Proof.
  intros l1 l2.
  induction l1 as [| n l' IHl'].
  - simpl.
    rewrite -> concat_empty.
    reflexivity.
  - simpl.
    rewrite -> IHl'.
    rewrite -> app_assoc.
    reflexivity.
Qed.

Theorem rev_involutive : forall l : natlist,
  rev (rev l) = l.
Proof.
  induction l as [| n l' IHl'].
  - simpl. reflexivity.
  - simpl.
    rewrite -> rev_app_distr.
    rewrite -> IHl'.
    simpl.
    reflexivity.
Qed.

Theorem app_assoc4 : forall l1 l2 l3 l4 : natlist,
  l1 ++ (l2 ++ (l3 ++ l4)) = ((l1 ++ l2) ++ l3) ++ l4.
Proof.
  intros .
  rewrite -> app_assoc.
  rewrite -> app_assoc.
  reflexivity.
Qed.

Lemma nonzeros_app : forall l1 l2 : natlist,
  nonzeros (l1 ++ l2) = (nonzeros l1) ++ (nonzeros l2).
Proof.
  intros l1 l2.
  induction l1 as [| n l1' IHl'].
  - simpl.
    reflexivity.
  - destruct n as [| n' IHn'].
    + simpl.
      rewrite IHl'.
      reflexivity.
    + simpl.
      rewrite IHl'.
      reflexivity.
Qed.

Fixpoint eqblist (l1 l2 : natlist) : bool :=
  match l1, l2 with
  | nil, nil => true
  | nil, h :: t => false
  | h :: t, nil => false
  | h1 :: t1, h2 :: t2 =>
      if eqb h1 h2
      then eqblist t1 t2
      else false
  end.

Example test_eqblist1 :
  (eqblist nil nil = true).
Proof. simpl. reflexivity. Qed.

Example test_eqblist2 :
  eqblist [1;2;3] [1;2;3] = true.
Proof. simpl. reflexivity. Qed.

Example test_eqblist3 :
  eqblist [1;2;3] [1;2;4] = false.
Proof. simpl. reflexivity. Qed.

Theorem eqb_reflx : forall n: nat,
  eqb n n = true.
Proof.
  induction n as [| n' IHn'].
  simpl.
  reflexivity.
  simpl.
  rewrite -> IHn'.
  reflexivity.
Qed.

Theorem eqblist_refl : forall l:natlist,
  true = eqblist l l.
Proof.
  induction l as [| n l' IHl'].
  - reflexivity.
  - simpl.
    rewrite <- IHl'.
    rewrite -> eqb_reflx.
    reflexivity.
Qed.

Theorem count_member_nonzero : forall (s : bag),
  1 <=? (count 1 (1 :: s)) = true.
Proof.
  induction s as [| n s' IHs'].
  - simpl.
    reflexivity.
  - simpl.
    reflexivity.
Qed.

Theorem leb_n_Sn : forall n,
  n <=? (S n) = true.
Proof.
  intros n. induction n as [| n' IHn'].
  - simpl.
    reflexivity.
  - simpl.
    rewrite IHn'.
    reflexivity.
Qed.

Theorem remove_does_not_increase_count: forall (s : bag),
  (count 0 (remove_one 0 s)) <=? (count 0 s) = true.
Proof.
  induction s as [| n s' IHs'].
  - simpl.
    reflexivity.
  - destruct n as [| n'].
    + simpl.
      rewrite -> leb_n_Sn.
      reflexivity.
    + simpl.
      rewrite -> IHs'.
      reflexivity.
Qed.

Theorem rev_injective: forall (l1 l2 : natlist),
  rev l1 = rev l2 -> l1 = l2.
Proof.
  intros l1 l2 H.
  rewrite <- rev_involutive.
  rewrite <- H.
  rewrite -> rev_involutive.
  reflexivity.
Qed.

Definition manual_grade_for_rev_injective : option (nat*string) := None.

Fixpoint nth_bad (l:natlist) (n:nat) : nat :=
  match l with
  | nil => 42 (* arbitrary! *)
  | a :: l' => match n =? O with
               | true => a
               | false => nth_bad l' (pred n)
               end
  end.

Inductive natoption : Type :=
  | Some (n : nat)
  | None.

Fixpoint nth_error (l:natlist) (n:nat) : natoption :=
  match l with
  | nil => None
  | a :: l' => match n =? O with
               | true => Some a
               | false => nth_error l' (pred n)
               end
  end.
Example test_nth_error1 : nth_error [4;5;6;7] 0 = Some 4.
Proof. reflexivity. Qed.
Example test_nth_error2 : nth_error [4;5;6;7] 3 = Some 7.
Proof. reflexivity. Qed.
Example test_nth_error3 : nth_error [4;5;6;7] 9 = None.
Proof. reflexivity. Qed.

Fixpoint nth_error' (l:natlist) (n:nat) : natoption :=
  match l with
  | nil => None
  | a :: l' => if n =? O
      then Some a
      else nth_error' l' (pred n)
  end.

Definition option_elim (d : nat) (o : natoption) : nat :=
  match o with
  | Some n' => n'
  | None => d
  end.

Definition hd_error (l : natlist) : natoption :=
  match l with
  | nil => None
  | h :: t => Some h
  end.

Example test_hd_error1 : hd_error [] = None.
Proof. simpl. reflexivity. Qed.

Example test_hd_error2 : hd_error [1] = Some 1.
Proof. simpl. reflexivity. Qed.

Example test_hd_error3 : hd_error [5;6] = Some 5.
Proof. simpl. reflexivity. Qed.

Theorem option_elim_hd : forall (l:natlist) (default:nat),
  hd default l = option_elim default (hd_error l).
Proof.
  simpl.
  induction l.
  simpl.
  reflexivity.
  simpl.
  reflexivity.
Qed.

End NatList.

Inductive id : Type :=
  | Id (n : nat).

Definition eqb_id (x1 x2 : id) :=
  match x1, x2 with
  | Id n1, Id n2 => n1 =? n2
  end.

Theorem eqb_id_refl : forall x, true = eqb_id x x.
Proof.
  intros .
  destruct x.
  simpl.
  induction n.
  simpl.
  reflexivity.
  simpl.
  rewrite -> IHn.
  reflexivity.
Qed.

Module PartialMap.
Export NatList.
Inductive partial_map : Type :=
  | empty
  | record (i : id) (v : nat) (m : partial_map).

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

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

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

End PartialMap.

Inductive baz : Type :=
  | Baz1 (x : baz)
  | Baz2 (y : baz) (b : bool).

Definition manual_grade_for_baz_num_elts : option (nat*string) := None.


Structure EstructuraDeMonoide
            (C : Set)
            (e : C)
            (op : C -> C -> C) :=
  mkEstructuraDeMonoide {
    EM_assoc  : forall x y z,  op (op x y) z = op x (op y z) ;
    EM_neut_l : forall x,      op e x = x ;
    EM_neut_r : forall x,      op x e = x
  }.

Structure EstructuraDeGrupo
            (C : Set)
            (e : C)
            (op : C -> C -> C)
            (inv : C -> C) :=
  mkEstructuraDeGrupo {
    EG_monoide : EstructuraDeMonoide C e op ;
    EG_inv_r   : forall x,      op x (inv x) = e
  }.

Structure Grupo := mkGrupo {
  C   : Set ;           (* carrier *)
  e   : C ;             (* elemento neutro *)
  op  : C -> C -> C ;   (* operación binaria *)
  inv : C -> C ;        (* inverso *)

  es_grupo : EstructuraDeGrupo C e op inv
}.

Definition carrier (G : Grupo) : Set := C G.

Section Ejemplo_Grupo_ℤ2.

  Inductive ℤ2_carrier : Set :=
    | O : ℤ2_carrier
    | I : ℤ2_carrier.

  Let f (x : ℤ2_carrier) (y : ℤ2_carrier) : ℤ2_carrier :=
    match x with
    | O => y
    | I => match y with
           | O => I
           | I => O
           end
    end.

   Eval compute in (f (f O I) (f I I)).

   (* f asociativa *)
   Lemma ℤ2_G1 : forall a b c,  f (f a b) c = f a (f b c).
     intros a b c.
     case a; case b; case c; trivial.
   Qed.

   (* O neutro a izquierda *)
   Lemma ℤ2_G2 : forall a,  f O a = a.
     trivial.
   Qed.

   (* O neutro a derecha *)
   Lemma ℤ2_G3 : forall a,  f a O = a.
     intros a.
     case a; trivial.
   Qed.

   (* Cada elemento es inverso de sí mismo. *)
   Lemma ℤ2_G4 : forall a,  f a a = O.
     intros a.
     case a; trivial.
   Qed.

   Definition ℤ2 : Grupo :=
     mkGrupo
       ℤ2_carrier   (* carrier *)
       O            (* elemento neutro *)
       f            (* operación binaria *)
       (fun x => x) (* inverso *)
       (mkEstructuraDeGrupo _ _ _ _
         (mkEstructuraDeMonoide _ _ _ ℤ2_G1 ℤ2_G2 ℤ2_G3)
         ℤ2_G4).

End Ejemplo_Grupo_ℤ2.

Notation "x · y" := (op _ x y) (at level 20).
Notation "x ⁻¹"  := (inv _ x) (at level 5).
Notation "1"     := (e _).

Section Propiedades_Básicas.

    Variable G : Grupo.

    Lemma assoc : forall x y z : carrier G,  (x · y) · z = x · (y · z).
      intros.
      apply (EM_assoc (carrier G) (e G) (op G)).
      apply (EG_monoide (carrier G) (e G) (op G) (inv G)).
      apply es_grupo.
    Qed.

    Lemma neut_l : forall x : carrier G,  1 · x = x.
      intros.
      apply (EM_neut_l (carrier G) (e G) (op G)).
      apply (EG_monoide (carrier G) (e G) (op G) (inv G)).
      apply es_grupo.
    Qed.

    Lemma neut_r : forall x : carrier G,  x · 1 = x.
      intros.
      apply (EM_neut_r (carrier G) (e G) (op G)).
      apply (EG_monoide (carrier G) (e G) (op G) (inv G)).
      apply es_grupo.
    Qed.

    Lemma inv_r : forall x : carrier G,  x · x⁻¹ = 1.
      intros.
      apply (EG_inv_r (carrier G) (e G) (op G) (inv G)).
      apply es_grupo.
    Qed.

    Lemma cancel_r :  forall x y z : carrier G,  x·z = y·z  ->  x = y.
      intros x y z H.
      assert ( x·(z·z⁻¹) = y·(z·z⁻¹) ) as H'.
        rewrite <-? assoc.
        rewrite H.
        reflexivity.
      rewrite inv_r, ? neut_r in H'.
      assumption.
    Qed.

    Lemma inv_l : forall x : carrier G,  x⁻¹ · x = 1.
      intros x.
      apply cancel_r with (z := x⁻¹).
      rewrite assoc, inv_r, neut_r, neut_l.
      reflexivity.
    Qed.

    Lemma cancel_l : forall x y z : carrier G,  z·x = z·y  ->  x = y.
      intros x y z H.
      assert ( (z⁻¹·z)·x = (z⁻¹·z)·y ) as H'.
        rewrite ? assoc, H; reflexivity.
      rewrite inv_l, ? neut_l in H'.
      assumption.
    Qed.

    (* Inverso del neutro *)
    Lemma inv_1 : 1⁻¹ = (1 : carrier G).
      apply cancel_l with 1.
      rewrite inv_r.
      rewrite neut_r.
      reflexivity.
    Qed.

    (* Inverso del producto *)
    Lemma inv_xy : forall x y : carrier G,  (x · y)⁻¹ = y⁻¹ · x⁻¹.
      intros x y.
      apply cancel_l with (x · y).
      rewrite inv_r, assoc.
      replace (y·(y⁻¹·x⁻¹)) with ((y·y⁻¹)·x⁻¹).
      rewrite inv_r, neut_l, inv_r.
      reflexivity.
      apply assoc.
    Qed.

    (* Inverso del inverso *)
    Lemma inv_inv : forall x : carrier G, x⁻¹⁻¹ = x.
      intro x.
      apply cancel_l with x⁻¹.
      rewrite inv_r.
      rewrite inv_l.
      reflexivity.
    Qed.

End Propiedades_Básicas.

Section Grupo_Simétrico.

  Require Import ProofIrrelevance.
  Require Import FunctionalExtensionality.
  Load Defs.

  (* El grupo simétrico depende de un parámetro: un conjunto X *)
  Variable X : Set.

  Let composición (f g : X -> X) := fun x => f (g x).

  Let Id (x : X) := x.

  Notation "f ∘ g" := (composición f g) (at level 20).

  Lemma composición_id :
    forall f g,  f ∘ g = Id  ->  forall x,  f (g x) = x.
  Proof.
    intros f g H x.
    apply equal_f with x in H.
    compute in H.
    assumption.
  Qed.

  Let inversas (F G : X -> X) := F ∘ G = Id  /\  G ∘ F = Id.

  (* El siguiente va a ser el carrier del grupo simétrico.
   * Sus elementos son tuplas de la forma (F, G, inv_FG)
   * donde   F G : X -> X
   *         inv_FG : inversas F G
   * (inv_FG es evidencia de que F y G son inversas).
   *)
  Structure Permutación := mkPerm {
                             F      : X -> X ;
                             G      : X -> X ;
                             inv_FG : inversas F G
                           }.

  (* Lema técnico: toda permutación está determinada por F y G.
   * Usa proof_irrelevance.
   *)
  Lemma perm_eq :
    forall σ τ,
      F σ = F τ  ->  G σ = G τ  ->  σ = τ.
  Proof.
    intros σ τ eq_F eq_G.
    destruct σ as (F1, G1, inv1).
    destruct τ as (F2, G2, inv2).
    assert (F1 = F2) as Fs. assumption.
    assert (G1 = G2) as Gs. assumption.
    destruct Fs, Gs.
    replace inv1 with inv2.
    reflexivity.
    apply proof_irrelevance.
  Qed.

  (* La operación del grupo simétrico es la composición. *)
  Let sym_op (σ τ : Permutación) : Permutación.
    apply mkPerm with (F := F σ ∘ F τ) (G := G τ ∘ G σ).
    split.
      (* F ∘ G *)
      apply functional_extensionality.
      intro x; unfold composición.
      rewrite (composición_id (F τ) (G τ)).
      rewrite (composición_id (F σ) (G σ)).
      reflexivity.
      apply (inv_FG σ).
      apply (inv_FG τ).

      (* G ∘ F *)
      apply functional_extensionality.
      intro x; unfold composición.
      rewrite (composición_id (G σ) (F σ)).
      rewrite (composición_id (G τ) (F τ)).
      reflexivity.
      apply (inv_FG τ).
      apply (inv_FG σ).
  Defined.

  (* El elemento neutro es la identidad. *)
  Let sym_e : Permutación.
    apply mkPerm with (F := Id) (G := Id).
    split; apply functional_extensionality; compute; reflexivity.
  Defined.

  (* La inversa de una permutación. *)
  Let sym_inv (σ : Permutación) : Permutación.
    destruct σ as (F, G, inv_FG).
    apply mkPerm with (F := G) (G := F).
    split.
    apply inv_FG.
    apply inv_FG.
  Defined.

  (* sym_op es asociativa *)
  Lemma sym_G1 : forall σ τ ρ, sym_op (sym_op σ τ) ρ = sym_op σ (sym_op τ ρ).
    intros σ τ ρ.
    apply perm_eq.
    reflexivity.
    reflexivity.
  Qed.

  (* sym_e neutro a izquierda *)
  Lemma sym_G2 : forall σ, sym_op sym_e σ = σ.
    intros.
    apply perm_eq.
    reflexivity.
    reflexivity.
  Qed.

  (* sym_e neutro a derecha *)
  Lemma sym_G3 : forall σ, sym_op σ sym_e = σ.
    intros.
    apply perm_eq.
    reflexivity.
    reflexivity.
  Qed.

  (* sym_inv inversa a derecha *)
  Lemma sym_G4 : forall σ, sym_op σ (sym_inv σ) = sym_e.
    intros σ.
    destruct σ as (F, G, inv_FG).
    apply perm_eq.
    simpl.
    apply inv_FG.
    apply inv_FG.
  Qed.

  (* El grupo simétrico *)
  Definition Sym : Grupo :=
    mkGrupo
       Permutación  (* carrier *)
       sym_e        (* elemento neutro *)
       sym_op       (* operación binaria *)
       sym_inv      (* inverso *)
       (mkEstructuraDeGrupo _ _ _ _
         (mkEstructuraDeMonoide _ _ _ sym_G1 sym_G2 sym_G3)
         sym_G4).

End Grupo_Simétrico.

Notation "φ $ x" := (π1 φ x) (at level 20).

Section Morfismos.

    Variable G H : Grupo.

    Definition es_morfismo (f : carrier G -> carrier H) : Prop :=
        (forall x y,  f (x · y) = f x · f y).

    Definition Morfismo :=
      { f : carrier G -> carrier H | es_morfismo f }.

    Lemma morfismo_en_prod : forall φ : Morfismo, forall x y, φ $ (x · y) = (φ $ x) · (φ $ y).
      intros.
      apply (π2 φ).
    Qed.

    Lemma morfismo_en_1 : forall φ : Morfismo, φ $ 1 = 1.
      intro φ.
      assert ((φ $ 1) · (φ $ 1) = φ $ 1).
      rewrite <- morfismo_en_prod.
      rewrite neut_l.
      reflexivity.
      apply cancel_r with (φ $ 1).
      rewrite neut_l.
      assumption.
    Qed.

    Lemma morfismo_en_inv : forall (φ : Morfismo) x, φ $ x⁻¹ = (φ $ x)⁻¹.
    Proof.
      intros φ x.
      apply cancel_r with (φ $ x).
      rewrite inv_l.
      rewrite <- morfismo_en_prod.
      rewrite inv_l.
      apply morfismo_en_1.
    Qed.

    Definition es_monomorfismo (f : carrier G -> carrier H) : Prop :=
      es_morfismo f /\
      forall x y,  f x = f y  ->  x = y.

    Lemma morfismo_eq : forall φ ψ : Morfismo, π1 φ = π1 ψ -> φ = ψ.
    Proof.
      intros φ ψ eq_π1.
      destruct φ as (f, f_mor).
      destruct ψ as (g, g_mor).
      assert (f = g) as eq_fg. assumption.
      destruct eq_fg.
      replace g_mor with f_mor.
      reflexivity.
      apply proof_irrelevance.
    Qed.

    Lemma morf_equal : forall φ ψ : Morfismo, forall x, φ = ψ -> φ $ x = ψ $ x.
      intros φ ψ x eq.
      destruct eq.
      reflexivity.
    Qed.

    Definition G_sub := { f : carrier G -> carrier H | es_monomorfismo f }.

End Morfismos.

(* ↪ == \hookrightarrow *)
Notation "G ↪ H" := (G_sub G H) (at level 20).

Definition Endomorfismo (G : Grupo) := Morfismo G G.

Section Teorema_de_Cayley.

  Variable G : Grupo.

  Let X := carrier G.

  (* Dado un x, denota la permutación que multiplica a izquierda por x. *)
  Definition μ (x : X) : Permutación X.
    apply mkPerm with (F := fun y => x·y) (G := fun y => x⁻¹·y).
    split.
      (* F ∘ G = Id *)
      apply functional_extensionality; intros y.
      rewrite <- assoc.
      rewrite inv_r.
      rewrite neut_l.
      reflexivity.
      (* G ∘ F = Id *)
      apply functional_extensionality; intros y.
      rewrite <- assoc.
      rewrite inv_l.
      rewrite neut_l.
      reflexivity.
  Defined.

  (* μ es homomórfico para el producto *)
  Lemma μ_hom_op : forall x y : X,  μ (x · y) = (μ x : carrier (Sym X)) · μ y.
    intros x y.
    apply perm_eq.
    (* multiplicar por (x · y) *)
    apply functional_extensionality.
    intro z.
    simpl.
    apply assoc.

    (* multiplicar por (x · y)⁻¹ *)
    apply functional_extensionality.
    intro z.
    simpl.
    rewrite inv_xy.
    apply assoc.
  Qed.

End Teorema_de_Cayley.

Theorem Cayley : forall G : Grupo, { X : Set & G ↪ Sym X }.
Proof.
  intro G.
  exists (carrier G).
  exists (μ G).
  split.

  (* morfismo *)
  unfold es_morfismo.
  intros x y.
  apply μ_hom_op.  (* homomórfico para el producto *)

  (* monomorfismo *)
  intros x y permx_eq_permy.
  replace x with (F _ (μ G x) 1).
  replace y with (F _ (μ G y) 1).
  rewrite permx_eq_permy.
  reflexivity.
  simpl. apply neut_r.
  simpl. apply neut_r.
Qed.

Definition es_abeliano (G : Grupo) := forall x y : carrier G, x · y = y · x.

Definition GrupoAbeliano := { G | es_abeliano G }.

Structure Anillo := mkAnillo {
  RC    : Set ;                           (* carrier *)

  R0    : RC ;                            (* 0 *)
  Radd  : RC -> RC -> RC ;                (* + *)
  Ropp  : RC -> RC ;                      (* - *)

  R1    : RC ;                            (* elemento neutro *)
  Rmul  : RC -> RC -> RC ;                (* operación binaria *)

  R_es_grupo_add    : EstructuraDeGrupo RC R0 Radd Ropp ;
  R_comm            : forall x y : RC, Radd x y = Radd y x ;

  R_es_monoide_mul  : EstructuraDeMonoide RC R1 Rmul ;

  R_distr_l : forall x y z : RC, Rmul x (Radd y z) = Radd (Rmul x y) (Rmul x z) ;
  R_distr_r : forall x y z : RC, Rmul (Radd y z) x = Radd (Rmul y x) (Rmul z x)
}.

Definition R_carrier (A : Anillo) : Set := RC A.

Definition tiene_estructura_de_anillo (X : Set) := exists A : Anillo, R_carrier A = X.

Notation "x + y" := (Radd _ x y).
Notation "x · y" := (Rmul _ x y) (at level 20).
Notation "0" := (R0 _).
Notation "1" := (R1 _).

Section Anillo_Propiedades_Basicas.

  Variable A : Anillo.

  Lemma R_mul_neut_l : forall x : R_carrier A,  1 · x = x.
    intros.
    apply (EM_neut_l _ _ _ (R_es_monoide_mul A)).
  Qed.

  Lemma R_mul_neut_r : forall x : R_carrier A,  x · 1 = x.
    intros.
    apply (EM_neut_r _ _ _ (R_es_monoide_mul A)).
  Qed.

  Lemma R_mul_assoc : forall x y z : R_carrier A,  (x · y) · z = x · (y · z).
    intros.
    apply (EM_assoc _ _ _ (R_es_monoide_mul A)).
  Qed.

End Anillo_Propiedades_Basicas.

Section Anillo_Endomorfismos_Grupo_Abeliano.

  Variable G : Grupo.

  Hypothesis G_abeliano : es_abeliano G.

  Notation "0"     := (e G).
  Notation "x + y" := (op G x y).
  Notation "- x"   := (inv G x).

  (* Endomorfismo que manda todo al 1 del grupo *)
  Definition end_0 : Endomorfismo G.
    exists (fun x => 0).
    unfold es_morfismo.
    rewrite neut_r.
    reflexivity.
  Defined.

  (* Operación entre endomorfismos que calcula la suma punto a punto *)
  Definition end_add : Endomorfismo G -> Endomorfismo G -> Endomorfismo G.
    intros φ ψ.
    exists (fun x => (φ $ x) + (ψ $ x)).
    unfold es_morfismo.
    intros x y.
    rewrite ? morfismo_en_prod.
    apply cancel_l with (-φ $ x).
    rewrite <-? assoc, ? inv_l, ? neut_l.
    apply cancel_r with (-ψ $ y).
    rewrite ->? assoc, ? inv_r, ? neut_r.
    apply G_abeliano.
  Defined.

  (* Operación que dado un endomorfismo devuelve su opuesto aditivo punto a punto  *)
  Definition end_neg : Endomorfismo G -> Endomorfismo G.
    intro φ.
    exists (fun x => -φ $ x).
    unfold es_morfismo.
    intros.
    rewrite ? morfismo_en_prod.
    rewrite G_abeliano.
    apply inv_xy.
  Defined.

  Lemma end_add_assoc : forall α β γ : Endomorfismo G, end_add (end_add α β) γ = end_add α (end_add β γ).
    intros. apply morfismo_eq. apply functional_extensionality.
    intro. apply assoc.
  Qed.

  Lemma end_0_neut_l : forall φ : Endomorfismo G, end_add end_0 φ = φ.
    intro. apply morfismo_eq. apply functional_extensionality.
    intro. apply neut_l.
  Qed.

  Lemma end_0_neut_r : forall φ : Endomorfismo G, end_add φ end_0 = φ.
    intro. apply morfismo_eq. apply functional_extensionality.
    intro. apply neut_r.
  Qed.

  Lemma end_neg_inv_r : forall φ : Endomorfismo G, end_add φ (end_neg φ) = end_0.
    intro. apply morfismo_eq. apply functional_extensionality.
    intro. apply inv_r.
  Qed.

  Lemma end_add_comm : forall φ ψ : Endomorfismo G, end_add φ ψ = end_add ψ φ.
    intros. apply morfismo_eq. apply functional_extensionality.
    intro. apply G_abeliano.
  Qed.

  (* Endomorfismo identidad *)
  Definition end_1 : Endomorfismo G.
    exists (fun x => x).
    unfold es_morfismo.
    reflexivity.
  Defined.

  (* Producto de endomorfismos: la composición *)
  Definition end_mul : Endomorfismo G -> Endomorfismo G -> Endomorfismo G.
    intros φ ψ.
    exists (fun x => φ $ (ψ $ x)).
    unfold es_morfismo.
    intros x y.
    rewrite ? morfismo_en_prod.
    reflexivity.
  Defined.

  Lemma end_mul_assoc : forall α β γ, end_mul (end_mul α β) γ = end_mul α (end_mul β γ).
    intros. apply morfismo_eq. apply functional_extensionality.
    intro. reflexivity.
  Qed.

  Lemma end_1_neut_l : forall φ, end_mul end_1 φ = φ.
    intro. apply morfismo_eq. apply functional_extensionality.
    intro. reflexivity.
  Qed.

  Lemma end_1_neut_r : forall φ, end_mul φ end_1 = φ.
    intro. apply morfismo_eq. apply functional_extensionality.
    intro. reflexivity.
  Qed.

  Lemma end_distr_l : forall α β γ, end_mul α (end_add β γ) = end_add (end_mul α β) (end_mul α γ).
    intros. apply morfismo_eq. apply functional_extensionality.
    intro.
    simpl.
    rewrite morfismo_en_prod.
    reflexivity.
  Qed.

  Lemma end_distr_r : forall α β γ, end_mul (end_add β γ) α = end_add (end_mul β α) (end_mul γ α).
    intros. apply morfismo_eq. apply functional_extensionality.
    intro.
    reflexivity.
  Qed.

  Definition AnilloEndomorfismos :=
    mkAnillo (Endomorfismo G)
             end_0 end_add end_neg
             end_1 end_mul
             (mkEstructuraDeGrupo _ _ _ _
                   (mkEstructuraDeMonoide _ _ _
                     end_add_assoc end_0_neut_l end_0_neut_r)
                   end_neg_inv_r)
             end_add_comm
             (mkEstructuraDeMonoide _ _ _
                end_mul_assoc end_1_neut_l end_1_neut_r)
             end_distr_l
             end_distr_r.

  Lemma G_abeliano_implica_End_anillo :
          tiene_estructura_de_anillo (Endomorfismo G).
  Proof.
    exists AnilloEndomorfismos.
    reflexivity.
  Qed.

End Anillo_Endomorfismos_Grupo_Abeliano.

Section Morfismo_Anillos.

  Variable A B : Anillo.

  Definition es_R_morfismo (f : R_carrier A -> R_carrier B) : Prop :=
       f 1 = 1
    /\ (forall x y,  f (x + y) = f x + f y)
    /\ (forall x y,  f (x · y) = f x · f y).

  Definition es_R_monomorfismo (f : R_carrier A -> R_carrier B) : Prop :=
       es_R_morfismo f
    /\ forall x y, f x = f y -> x = y.

  Definition R_Morfismo :=
    { f : R_carrier A -> R_carrier B | es_R_morfismo f }.

  Lemma R_morfismo_eq :
    forall φ ψ : R_Morfismo, π1 φ = π1 ψ -> φ = ψ.
  Proof.
    intros φ ψ eq.
    destruct φ as (f, f_mor).
    destruct ψ as (g, g_mor).
    assert (f = g) as f_eq_g.
    assumption.
    destruct f_eq_g.
    replace f_mor with g_mor.
    reflexivity.
    apply proof_irrelevance.
  Qed.

  Definition R_sub :=
    { f : R_carrier A -> R_carrier B | es_R_monomorfismo f }.

End Morfismo_Anillos.

Definition R_grupo_aditivo (A : Anillo) : Grupo :=
  mkGrupo (R_carrier A) (R0 A) (Radd A) (Ropp A) (R_es_grupo_add A).

Definition R_grupo_ab_aditivo (A : Anillo) : GrupoAbeliano.
  exists (R_grupo_aditivo A).
  unfold es_abeliano.
  intros.
  apply (R_comm A).
Defined.

(** ↪ == \hookrightarrow **)
Notation "A ↪ B" := (R_sub A B) (at level 20).

Section Pseudo_Cayley_Anillos.

  Variable A : Anillo.

  Let G : GrupoAbeliano := R_grupo_ab_aditivo A.
  Let Endo := AnilloEndomorfismos (π1 G) (π2 G).

  Definition Rμ (x : R_carrier A) : R_carrier Endo.
    exists (fun y => Rmul _ x y).
    intros y z.
    apply (R_distr_l A).
  Defined.

End Pseudo_Cayley_Anillos.

Theorem RCayley :
  forall A : Anillo,
    { G : GrupoAbeliano   &
      A ↪ AnilloEndomorfismos (π1 G) (π2 G)
    }.
Proof.
  intro A.
  exists (R_grupo_ab_aditivo A).
  exists (Rμ A).
  split.
    (* morfismo de anillos *)
    split.
      (* 1 *)
      apply morfismo_eq.
      apply functional_extensionality.
      intro.
      simpl.
      apply R_mul_neut_l.
    split.
      (* suma *)
      intros x y.
      apply morfismo_eq.
      apply functional_extensionality.
      intro z.
      simpl.
      apply R_distr_r.
      (* producto *)
      intros x y.
      apply morfismo_eq.
      apply functional_extensionality.
      intro z.
      simpl.
      apply R_mul_assoc.

    (* monomorfismo *)
    intros x y Hmul.
    assert (Rμ A x $ 1 = Rμ A y $ 1) as Hmul'.
      apply morf_equal. assumption.
    simpl in Hmul'.
    rewrite ? R_mul_neut_r in Hmul'.
    assumption.
Qed.


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

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

Inductive natural : Set :=
| Zero : natural
| Succ : natural -> natural.

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) {struct plus_arg0}
  : natural :=
  match plus_arg0 with
  | Zero => plus_arg1
  | Succ n => Succ (plus n plus_arg1)
  end.

Fixpoint mult (mult_arg0 : natural) (mult_arg1 : natural) {struct mult_arg0}
  : natural :=
  match mult_arg0 with
  | Zero => Zero
  | Succ n => plus (mult n mult_arg1) mult_arg1
  end.

Definition synth (lf1 : natural) (y : natural) (x : natural) : natural :=
  plus (mult x y) lf1.


Require Import Shared.FiniteTypes.FinTypes.
Require Import Shared.Vectors.Vectors.
Require Import Shared.Vectors.VectorDupfree.

Definition Fin_initVect (n : nat) : Vector.t (Fin.t n) n :=
  tabulate (fun i : Fin.t n => i).

Lemma Fin_initVect_dupfree n :
  dupfree (Fin_initVect n).
Proof.
  unfold Fin_initVect.
  apply dupfree_tabulate_injective.
  firstorder.
Qed.

Lemma Fin_initVect_full n k :
  Vector.In k (Fin_initVect n).
Proof.
  unfold Fin_initVect.
  apply in_tabulate. eauto.
Qed.

Definition Fin_initVect_nth (n : nat) (k : Fin.t n) :
  Vector.nth (Fin_initVect n) k = k.
Proof. unfold Fin_initVect. apply nth_tabulate. Qed.

Instance Fin_finTypeC n : finTypeC (EqType (Fin.t n)).
Proof.
  constructor 1 with (enum := Fin_initVect n).
  intros x. cbn in x.
  eapply dupfreeCount.
  - eapply tolist_dupfree. apply Fin_initVect_dupfree.
  - eapply tolist_In. apply Fin_initVect_full.
Qed.


(* infotheo: information theory and error-correcting codes in Coq             *)
(* Copyright (C) 2020 infotheo authors, license: LGPL-2.1-or-later            *)
Require Import Reals Lra.
From mathcomp Require Import all_ssreflect.
From mathcomp Require Import Rstruct.
Require Import Reals_ext ssrR Rbigop fdist proba.

(* Coq/SSReflect/MathComp, Morikita, Sect. 7.2, using tuple *)

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

Local Open Scope reals_ext_scope.
Local Open Scope tuple_ext_scope.
Local Open Scope R_scope.

Definition ps := [tuple 1/2; 1/3; 1/6].
Definition p : {ffun 'I_3 -> R} := [ffun i => tnth ps i].

Lemma p_nonneg : [forall a : 'I_3, 0 <b= p a].
Proof.
apply/forallP => a.
rewrite /p ffunE.
apply/all_tnthP: a => /=.
rewrite !andb_idr => * //; apply/leRP; lra.
Qed.

Definition p' : [finType of 'I_3] ->R+ := mkNNFinfun p_nonneg.

Lemma p_sum1 : \sum_(i in 'I_3) p' i == 1.
Proof.
apply/eqP.
rewrite 3!big_ord_recl big_ord0 /=.
rewrite /p !ffunE !(tnth_nth 0) /=.
by field.
Qed.

Local Open Scope fdist_scope.
Local Open Scope proba_scope.

Definition P : {fdist 'I_3} := FDist.mk p_sum1.

Definition X : {RV P -> R} := (fun i => INR i.+1).

Lemma expected : `E X = 5/3.
Proof.
rewrite /Ex.
rewrite 3!big_ord_recl big_ord0 /=.
rewrite /X !ffunE !(tnth_nth 0) /=.
cbv; by field.
Qed.

Lemma variance : `V X = 5/9.
Proof.
rewrite VarE expected /Ex /X /sq_RV /comp_RV /=.
rewrite 3!big_ord_recl big_ord0 /=.
rewrite !ffunE !(tnth_nth 0) /=.
cbv; by field.
Qed.


Require Import Coq.omega.Omega.
Require Import natural.
Require Import logic.

Delimit Scope int_scope with int.
Open Scope int_scope.

Inductive int: Type :=
| Z_pos: nat -> int
| Z_neg: nat -> int.

Definition Z_plus (z w: int) :=
match z, w with
| Z_pos n, Z_pos m => Z_pos (n + m)
| Z_pos n, Z_neg m => if m <? n then Z_pos (n - (S m)) else Z_neg (m - n)
| Z_neg n, Z_pos m => if n <? m then Z_pos (m - (S n)) else Z_neg (n - m)
| Z_neg n, Z_neg m => Z_neg (S n + m)
end.

Notation "z '+' w" := (Z_plus z w) (at level 50, left associativity) : int_scope.
Notation "z '+Z' w" := (Z_plus z w) (at level 50, left associativity) : type_scope.

(** negation of an integer: z |-> -z *)
Definition Z_opp (z: int): int :=
match z with
| Z_pos n => if n =? 0 then Z_pos 0 else Z_neg (pred n)
| Z_neg n => Z_pos (S n)
end.

Notation "'-' z" := (Z_opp z) (at level 35, right associativity) : int_scope.
Notation "'-Z' z" := (Z_opp z) (at level 35, right associativity) : type_scope.

(** subtraction *)
Definition Z_minus (z w: int) := z + - w.

Notation "z '-' w" := (Z_minus z w) (at level 50, left associativity) : int_scope.
Notation "z '-Z' w" := (Z_minus z w) (at level 50, left associativity) : type_scope.

(** multiplication *)
Definition Z_mult (z w: int): int :=
match z, w with
  | Z_pos n, Z_pos m => Z_pos (n * m)
  | Z_pos n, Z_neg m => - Z_pos (n * (S m))
  | Z_neg n, Z_pos m => - Z_pos ((S n) * m)
  | Z_neg n, Z_neg m => Z_pos ((S n) * (S m))
end.

Notation "z '*' w" := (Z_mult z w) (at level 40, left associativity) : int_scope.
Notation "z '*Z' w" := (Z_mult z w) (at level 40, left associativity) : type_scope.

(** plus_assoc *)
Theorem Z_1: forall x y z: int, (x + y) + z = x + (y + z).
Proof. destruct x, y, z.
  (* CASE 1 *)
  simpl. rewrite plus_assoc. reflexivity.

  (* CASE 2 *)
  simpl. remember (n1 <? n0) as b; destruct b; symmetry in Heqb.
    (* n1 < n0 *)
    rewrite N_ltb_true__lt in Heqb.
    assert (n1 < n + n0) by omega.
    rewrite <- N_ltb_true__lt in H.
    rewrite H. unfold lt in Heqb.
    apply (N_minus_plus n0 (S n1)) in Heqb.
    remember (n0 - (S n1))%nat as k.
    rewrite <- Heqb. repeat rewrite plus_assoc.
    rewrite N_plus_minus.
    reflexivity.

    (* n1 >= n0 *)
    rewrite N_ltb_false__ge in Heqb.
    remember (n1 <? n + n0) as c; destruct c; symmetry in Heqc.
      (* n1 < n + n0 *)
      rewrite N_ltb_true__lt in Heqc.
      apply N_minus_plus in Heqb.
      remember (n1 - n0)%nat as k.
      rewrite <- Heqb in Heqc; repeat rewrite (plus_comm _ n0) in Heqc.
      rewrite <- N_cons_lt_plus in Heqc.
      rewrite <- N_ltb_true__lt in Heqc.
      rewrite Heqc. rewrite <- Heqb.
      assert (Tmp: S (k + n0)%nat = (n0 + (S k))%nat) by omega.
      rewrite Tmp. rewrite <- N_minus_distr, N_plus_minus. reflexivity.

      (* n1 >= n + n0 *)
      rewrite N_ltb_false__ge in Heqc.
      apply N_minus_plus in Heqb.
      remember (n1 - n0)%nat as k.
      rewrite <- Heqb in Heqc; repeat rewrite (plus_comm _ n0) in Heqc.
      unfold ge in Heqc. rewrite <- N_cons_le_plus in Heqc.
      rewrite N_le__ge, <- N_ltb_false__ge in Heqc.
      rewrite Heqc, <- Heqb.
      rewrite (plus_comm n n0), <- N_minus_distr, N_plus_minus. reflexivity.

  (* CASE 3 *)
  simpl. remember (n0 <? n) as b; remember (n0 <? n1) as c;
  destruct b, c; symmetry in Heqb, Heqc.
    (* n0 < n /\ n0 < n1 *)
    rewrite N_ltb_true__lt in Heqb, Heqc.
    unfold lt in Heqb, Heqc. unfold Z_plus.
    rewrite (plus_comm _ n1). rewrite <- N_plus_minus_diff.
    rewrite (plus_comm n1 n). rewrite N_plus_minus_diff. reflexivity.
    apply Heqc. apply Heqb.

    (* n0 < n /\ n0 >= n1 *)
    rewrite N_ltb_true__lt in Heqb; rewrite N_ltb_false__ge in Heqc.
    unfold Z_plus. assert (n0 - n1 < n) by omega. rewrite <- N_ltb_true__lt in H.
    rewrite H. assert (S (n0 - n1) = ((S n0) - n1)%nat) by omega.
    rewrite H0. rewrite N_minus_plus_distr. reflexivity.
    apply Heqb. apply le_S. apply Heqc.

    (* n0 >= n /\ n0 < n1 *)
    unfold Z_plus.
    rewrite N_ltb_true__lt in Heqc.
    rewrite N_ltb_false__ge in Heqb.
    assert (n0 - n < n1) by omega.
    rewrite <- N_ltb_true__lt in H.
    rewrite H. assert (S (n0 - n) = ((S n0) - n)%nat) by omega.
    rewrite H0. rewrite <- N_minus_plus_distr. rewrite plus_comm. reflexivity.
    apply Heqc. apply le_S; apply Heqb.

    (* n0 >= n /\ n0 >= n1 *)
    remember (n0 - n1 <? n) as d; destruct d; symmetry in Heqd; unfold Z_plus;
    rewrite N_ltb_false__ge in Heqb, Heqc.
      (* n0 >= n /\ n0 >= n1 /\ n0 - n1 < n *)
      rewrite N_ltb_true__lt in Heqd.
      assert (n0 - n < n1) by omega.
      rewrite <- N_ltb_true__lt in H.
      rewrite H.
      assert (forall a b: nat, a >= b -> S (a - b)%nat = ((S a) - b)%nat) by (intros; omega).
      repeat rewrite H0.
      rewrite <- N_plus_minus_distr.
      rewrite <- N_plus_minus_distr.
      pose proof ((N_minus_plus n0 n1) Heqc) as PM.
      pose proof ((N_minus_plus n0 n) Heqb) as PM1.
      rewrite (plus_comm n1 n). reflexivity.
      omega. omega. omega. omega. omega. omega.

      (* n0 >= n /\ n0 >= n1 /\ n0 - n1 >= n *)
      rewrite N_ltb_false__ge in Heqd.
      assert (n0 - n >= n1) by omega.
      rewrite <- N_ltb_false__ge in H.
      rewrite H.
      repeat rewrite N_minus_distr.
      rewrite (plus_comm n n1). reflexivity.

  (* CASE 4 *)
  simpl. remember (n0 <? n) as b; destruct b; simpl; unfold Z_plus; symmetry in Heqb.
    (* n0 < n *)
    rewrite N_ltb_true__lt in Heqb.
    remember (S (n0 + n1) <? n) as c; destruct c; simpl; symmetry in Heqc.
      (* n0 < n /\ S (n0 + n1) < n *)
      rewrite N_ltb_true__lt in Heqc.
      assert (n1 < n - S n0) by omega.
      rewrite <- N_ltb_true__lt in H.
      rewrite H.
      rewrite N_minus_distr.
      rewrite <- plus_n_Sm. reflexivity.

      (* n0 < n /\ S (n0 + n1) >= n *)
      rewrite N_ltb_false__ge in Heqc.
      assert (n1 >= n - S n0) by omega.
      rewrite <- N_ltb_false__ge in H.
      rewrite H.
      destruct n. inversion Heqb.
      assert ((S n - S n0)%nat = (n - n0)%nat) by omega.
      rewrite H0. repeat rewrite <- N_plus_minus_distr.
      rewrite (plus_comm n1 n0). reflexivity.
      omega. omega.

    (* n0 >= n *)
    rewrite N_ltb_false__ge in Heqb.
    assert (S (n0 + n1) >= n) by omega.
    rewrite <- N_ltb_false__ge in H.
    rewrite H.
    destruct n. assert ((n0 - 0)%nat = n0) by omega. rewrite H0. reflexivity.
    assert (S (n0 - S n + n1) = (n0 + n1 - n)%nat).
      apply (N_minus_plus n0 (S n)) in Heqb.
      remember ((n0 - S n)%nat) as k.
      rewrite <- Heqb.
      rewrite <- plus_assoc.
      rewrite (plus_comm (S n)).
      rewrite plus_assoc.
      assert ((k + n1 + S n - n)%nat = S(k + n1)) by omega.
      rewrite H0. reflexivity.
    rewrite H0. reflexivity.

  (* CASE 5 *)
  simpl. remember (n <? n0) as b; destruct b; simpl; unfold Z_plus; symmetry in Heqb.
    (* n < n0 *)
    rewrite N_ltb_true__lt in Heqb.
    assert (n < n0 + n1) by omega.
    rewrite <- N_ltb_true__lt in H.
    rewrite H.
    rewrite (plus_comm n0 n1).
    rewrite N_plus_minus_diff.
    rewrite (plus_comm n1 _).
    reflexivity.
    apply Heqb.

    (* n >= n0 *)
    remember (n <? n0 + n1) as c; destruct c; simpl; symmetry in Heqc;
    rewrite N_ltb_false__ge in Heqb.
      (* n >= n0 /\ n < n0 + n1 *)
      rewrite N_ltb_true__lt in Heqc.
      assert (n - n0 < n1) by omega.
      rewrite <- N_ltb_true__lt in H.
      rewrite H.
      assert (S (n - n0) = (S n - n0)%nat) by omega.
      rewrite H0.
      rewrite <- N_plus_minus_distr.
      rewrite plus_comm.
      reflexivity.
      unfold ge; rewrite plus_comm.
      apply Heqc.
      apply le_S, Heqb.

      (* n >= n0 /\ n < n0 + n1 *)
      rewrite N_ltb_false__ge in Heqc.
      assert (n - n0 >= n1) by omega.
      rewrite <- N_ltb_false__ge in H.
      rewrite H.
      rewrite N_minus_distr.
      reflexivity.

  (* CASE 6 *)
  simpl. remember (n <? n0) as b; remember (n1 <? n0) as c;
  destruct b, c; symmetry in Heqb, Heqc.
    (* n < n0 /\ n1 < n0 *)
    rewrite N_ltb_true__lt in Heqb, Heqc.
    unfold lt in Heqb, Heqc. unfold Z_plus.
    remember (n1 <? n0 - S n) as d; destruct d; symmetry in Heqd; unfold Z_plus.
      (* n < n0 /\ n1 < n0 /\ n1 < n0 - S n *)
      rewrite N_ltb_true__lt in Heqd.
      assert (n < n0 - S n1) by omega.
      rewrite <- N_ltb_true__lt in H.
      rewrite H.
      repeat rewrite N_minus_distr.
      rewrite plus_comm. reflexivity.

      (* n < n0 /\ n1 < n0 /\ n1 >= n0 - S n *)
      rewrite N_ltb_false__ge in Heqd.
      assert (n >= n0 - S n1) by omega.
      rewrite <- N_ltb_false__ge in H.
      rewrite H.
      repeat rewrite <- N_plus_minus_distr.
      assert ((n1 + S n)%nat = (n + S n1)%nat) by omega.
      rewrite H0. reflexivity.
      omega. omega. omega. omega.

    (* n < n0 /\ n1 >= n0 *)
    rewrite N_ltb_true__lt in Heqb; rewrite N_ltb_false__ge in Heqc.
    unfold Z_plus. assert (n1 >= n0 - S n) by omega. rewrite <- N_ltb_false__ge in H.
    rewrite H.
    repeat rewrite <- N_plus_minus_distr.
    rewrite plus_comm. rewrite N_plus_minus_diff. reflexivity.
    omega. omega. omega.

    (* n >= n0 /\ n1 < n0 *)
    rewrite N_ltb_true__lt in Heqc.
    rewrite N_ltb_false__ge in Heqb.
    unfold Z_plus.
    assert (n >= n0 - S n1) by omega.
    rewrite <- N_ltb_false__ge in H.
    rewrite H. simpl. rewrite plus_n_Sm.
    rewrite <- N_minus_plus_distr. reflexivity.
    omega. omega.

    (* n >= n0 /\ n1 >= n0 *)
    unfold Z_plus; rewrite N_ltb_false__ge in Heqb, Heqc.
    assert ((S (n - n0) + n1)%nat = (S (n + (n1 - n0)))%nat) by omega.
    rewrite H. reflexivity.

  (* CASE 7 *)
  simpl. remember (S (n + n0) <? n1) as b; destruct b; symmetry in Heqb.
    (* S (n + n0) < n1 *)
    rewrite N_ltb_true__lt in Heqb.
    assert (n0 < n1) by omega.
    rewrite <- N_ltb_true__lt in H.
    rewrite H.
    assert (n < n1 - S n0) by omega.
    rewrite <- N_ltb_true__lt in H0.
    rewrite H0.
    rewrite N_minus_distr.
    rewrite plus_comm, plus_n_Sm.
    reflexivity.

    (* S (n + n0) >= n1 *)
    rewrite N_ltb_false__ge in Heqb.
    assert (n >= n1 - S n0) by omega.
    rewrite <- N_ltb_false__ge in H.
    remember (n0 <? n1) as c; destruct c; symmetry in Heqc.
      (* S (n + n0) >= n1 /\ n0 < n1 *)
      rewrite N_ltb_true__lt in Heqc.
      rewrite H.
      destruct n1.
      inversion Heqc.
      assert ((S n1 - S n0)%nat = (n1 - n0)%nat) by omega.
      rewrite H0; clear H0.
      rewrite <- N_plus_minus_distr.
      reflexivity.
      omega. omega.

      (* S (n + n0) >= n1 /\ n0 >= n1 *)
      rewrite N_ltb_false__ge in Heqc.
      destruct n1. assert ((n0 - 0)%nat = n0) by omega.
      rewrite H0. reflexivity.
      assert ((n + n0 - n1)%nat = (S n + n0 - S n1)%nat) by omega.
      rewrite H0. rewrite N_plus_minus_diff. reflexivity. omega.

  (* CASE 8 *)
  simpl. rewrite <- plus_assoc, (plus_n_Sm n). reflexivity.
Qed.

(** plus_comm *)
Theorem Z_2: forall x y: int, x + y = y + x.
Proof. destruct x, y.
  - simpl. rewrite (plus_comm n n0). reflexivity.
  - reflexivity.
  - reflexivity.
  - simpl. rewrite (plus_comm n n0). reflexivity.
Qed.

(** zero as an identity for plus *)
Theorem Z_3: forall x: int, x + Z_pos 0 = x.
Proof. destruct x.
  - simpl. rewrite plus_0_r. reflexivity.
  - simpl. assert ((n - 0)%nat%nat = n) by omega. rewrite H. reflexivity.
Qed.

(** inverse element for plus *)
Theorem Z_4: forall x: int, x + - x = Z_pos 0.
Proof. destruct x.
  - destruct n.
    + simpl. reflexivity.
    + simpl. assert (n < S n) by omega. rewrite <- N_ltb_true__lt in H.
      rewrite H. assert ((n - n)%nat%nat = 0) by omega. rewrite H0. reflexivity.
  - simpl. assert (n < S n) by omega. rewrite <- N_ltb_true__lt in H.
    rewrite H. assert ((n - n)%nat%nat = 0) by omega. rewrite H0. reflexivity.
Qed.

(** mult_assoc *)
Theorem Z_5: forall x y z: int, (x * y) * z = x * (y * z).
Proof.
  assert (L: forall n n0 n1: nat, (n1 + (n0 + n * S n0) * S n1)%nat
          = (n1 + n0 * S n1 + n * S (n1 + n0 * S n1))%nat).
    intros; simpl. assert (S (n1 + n0 * S n1) = ((S n0) * (S n1))%nat) by reflexivity.
    rewrite H. rewrite mult_plus_distr_r, plus_assoc, mult_assoc. reflexivity.

  destruct x, y, z; simpl.
  - rewrite mult_assoc. reflexivity.
  - destruct n0. zero.
    destruct n. zero. simpl.
    rewrite mult_plus_distr_r, <- mult_assoc, plus_assoc.
    reflexivity.
  - destruct n. zero. destruct (n1 + n0 * n1 =? 0); reflexivity.
    assert (((S n * S n0)%nat =? 0) = false) by reflexivity.
    rewrite H. destruct n1.
      zero. simpl. zero. simpl. rewrite <- L. reflexivity.
  - destruct n. zero. simpl. rewrite <- L. reflexivity.
  - destruct n0. zero.
    simpl. destruct n1. zero. simpl. rewrite L. reflexivity.
  - destruct n0. zero. simpl. rewrite L. reflexivity.
  - destruct n1. zero. simpl. zero. simpl. rewrite L. reflexivity.
  - rewrite L. reflexivity.
Qed.

(** mult_comm *)
Theorem Z_6: forall x y: int, x * y = y * x.
Proof. destruct x, y; simpl.
  - rewrite mult_comm. reflexivity.
  - destruct n. zero. rewrite (mult_comm (S n)). reflexivity.
  - destruct n0. zero. rewrite (mult_comm (S n0)). reflexivity.
  - assert (forall a b: nat, S (b + a * S b) = ((S a) * (S b))%nat) by reflexivity.
    repeat rewrite H. rewrite mult_comm. reflexivity.
Qed.

(** one as an identity for mult *)
Theorem Z_7: forall x: int, x * Z_pos 1 = x.
Proof. destruct x; simpl; assert ((n * 1)%nat = n%nat) by omega; rewrite H; reflexivity. Qed.

(** left distribution law *)
Theorem Z_8: forall x y z: int, x * (y + z) = x * y + x * z.
Proof. destruct x, y, z; simpl.
  - rewrite mult_plus_distr_l. reflexivity.
  - destruct n. zero. destruct (n1 <? n0); zero.
    simpl. assert (forall a b: nat, (b + a * b)%nat = ((S a) * b)%nat) by reflexivity.
    repeat rewrite H.
    assert ((n1 + n * S n1 <? S n * n0) = ((S n) * (S n1) <=? S n * n0)) by reflexivity.
    rewrite H0.
    pose proof (N_cons_le_mult_pos (S n) (S n1) n0) as F.
    assert (F1: S n > 0) by omega. apply F in F1.
    repeat rewrite <- N_leb_true__le in F1.
    remember (S n * S n1 <=? S n * n0) as b; destruct b.
    assert ((S n1 <=? n0) = true) by (rewrite F1; reflexivity).
    unfold Nat.ltb. rewrite H1. remember ((n0 - S n1)%nat) as k.
    rewrite H. assert (S (n1 + n * S n1) = ((S n) * (S n1))%nat).
      rewrite <- H. reflexivity.
    rewrite H2. rewrite <- (N_minus_plus n0 (S n1)).
    rewrite <- Heqk. rewrite mult_plus_distr_l.
    rewrite N_plus_minus. reflexivity. rewrite N_leb_true__le in H1. apply H1.
    assert ((S n1 <=? n0) = false).
      rewrite N_leb_true__le in F1.
      rewrite N_le__ge in F1.
      assert (false = true -> False) by discriminate.
      assert (n0 < S n1). rewrite N_lt__gt, <- N_nle__gt.
      pose proof (contrapositive (n0 >= S n1) (false = true)) as P.
      destruct F1.
      apply P in H2. apply H2. unfold not. apply H1.
      rewrite N_leb_false__gt. unfold gt. apply H2.
    rewrite N_leb_false__gt in H1. assert (n1 >= n0) by omega.
    rewrite <- N_ltb_false__ge in H2. rewrite H2.
    rewrite N_ltb_false__ge in H2. remember ((n1 - n0)%nat) as k.
    rewrite <- (N_minus_plus n1 n0). rewrite <- Heqk.
    assert (S (k + n0) = (S k + n0)%nat) by reflexivity.
    rewrite H3, mult_plus_distr_l.
    assert ((k + n0 + (n * S k + n * n0))%nat = (k + n * S k + (n0 + n * n0))%nat) by omega.
    rewrite H4. simpl. rewrite N_plus_minus. reflexivity. apply H2.

Admitted.

(** Z is an integral domain *)
Theorem Z_9: forall x y: int, x * y = Z_pos 0 -> x = Z_pos 0 \/ y = Z_pos 0.
Proof. Admitted.

(** natural order for Z *)
Definition Z_leb (z w: int): bool := (** x <=? y iff *)
match z, w with
  | Z_pos n, Z_pos m => n <=? m
  | Z_pos n, Z_neg m => false
  | Z_neg n, Z_pos m => true
  | Z_neg n, Z_neg m => m <=? n
end.

Notation "z '<=?Z' w" := (Z_leb z w) (at level 70, no associativity) : type_scope.
Notation "z '<?Z' w" := (negb Z_leb w z) (at level 70, no associativity) : type_scope.
Notation "z '>=?Z' w" := (Z_leb w z) (at level 70, no associativity) : type_scope.
Notation "z '>?Z' w" := (negb Z_leb z w) (at level 70, no associativity) : type_scope.

Definition Z_le (z w: int): Prop := (** x <=? y iff *)
match z, w with
  | Z_pos n, Z_pos m => n <= m
  | Z_pos n, Z_neg m => False
  | Z_neg n, Z_pos m => True
  | Z_neg n, Z_neg m => m <= n
end.

Notation "z '<=Z' w" := (Z_le z w) (at level 70, no associativity) : type_scope.
Notation "z '<Z' w" := (~ Z_le w z) (at level 70, no associativity) : type_scope.
Notation "z '>=Z' w" := (Z_le w z) (at level 70, no associativity) : type_scope.
Notation "z '>Z' w" := (~ Z_le z w) (at level 70, no associativity) : type_scope.

Lemma Z_neg_diff__lt: forall x y: int, x - y <Z Z_pos 0 <-> x <Z y.
Proof. assert (N: (0 =? 0) = true) by reflexivity.
  intros. destruct x, y; split; intros; unfold Z_le; simpl; simpl in H.
  - destruct n0. rewrite N in H.
    rewrite N_nle__gt in H. inversion H.
    assert ((S n0 =? 0) = false) by reflexivity. rewrite H0 in H. simpl in H.
    remember (n0 <? n) as b; destruct b.
    omega. symmetry in Heqb; rewrite N_ltb_false__ge in Heqb. omega.
  - destruct n0. rewrite N_nle__gt in H; inversion H.
    rewrite N_nle__gt in H. simpl. assert (n0 >= n) by omega.
    rewrite <- N_ltb_false__ge in H0. rewrite H0. easy.
  - rewrite N_nle__gt in H; inversion H.
  - easy.
  - easy.
  - destruct n0; simpl; apply H.
  - unfold not; intros. assert (n < S n0) by omega.
    rewrite <- N_ltb_true__lt in H1.
    rewrite H1 in H. omega.
  - assert (n >= S n0) by omega.
    rewrite <- N_ltb_false__ge in H0.
    rewrite H0. easy.
Qed.

Lemma Z_no_diff__eq: forall x y: int, x - y = Z_pos 0 <-> x = y.
Proof. assert (N: (0 =? 0) = true) by reflexivity.
  intros. destruct x, y; split; intros; simpl; simpl in H.
  - destruct n0. simpl in H. rewrite plus_0_r in H. apply H.
    simpl in H. remember (n0 <? n) as b; destruct b.
    symmetry in Heqb. rewrite N_ltb_true__lt in Heqb. unfold lt in Heqb.
    rewrite N_le__lt_eq in Heqb. destruct Heqb.
    rewrite N_lt__gt in H0. rewrite N_gt__pos_minus in H0.
    inversion H. rewrite H2 in H0. easy.
    rewrite H0; reflexivity.
    inversion H.
  - destruct n0. zero. apply H.
    simpl. inversion H. simpl.
    assert ((n0 <? S n0) = true). rewrite N_ltb_true__lt. omega.
    rewrite H0. assert ((n0 - n0)%nat = 0) by omega.
    rewrite H2; reflexivity.
  - inversion H. rewrite <- plus_n_Sm in H1. inversion H1.
  - inversion H.
  - destruct n0. simpl in H. assert (n = (n - 0)%nat) by omega.
    rewrite <- H0 in H. apply H. simpl in H. inversion H.
  - inversion H.
  - remember (n <? S n0) as b; destruct b. inversion H.
    rewrite <- N_le__zero_minus in H1. symmetry in Heqb.
    rewrite N_ltb_true__lt in Heqb. assert (n = n0) by omega.
    rewrite H0; reflexivity. inversion H.
  - inversion H. assert ((n0 <? S n0) = true). rewrite N_ltb_true__lt. omega.
    rewrite H0. assert ((n0 - n0)%nat = 0) by omega. rewrite H2. reflexivity.
Qed.

Lemma Z_opp_involutive: forall x: int, - - x = x.
Proof. destruct x; unfold Z_opp; simpl. destruct n. zero. zero. reflexivity. Qed.

Lemma Z_opp_lt_imp: forall x y: int, x <Z y -> -y <Z -x.
Proof. destruct x, y; unfold Z_opp, Z_le; simpl; intros.
  - destruct n0. rewrite N_nle__gt in H. inversion H. rewrite N_nle__gt in H.
    simpl. destruct n. zero. easy. simpl. omega.
  - easy.
  - destruct n0. zero. easy. zero. easy.
  - omega.
Qed.

Lemma Z_opp_distr: forall x y: int, - (x + y) = - x + - y.
Proof. destruct x, y.
  - simpl. destruct n, n0; zero. rewrite plus_n_Sm. reflexivity.
  - simpl. remember (n0 <? n) as b; remember (n =? 0) as c; destruct b, c; symmetry in Heqb, Heqc; simpl.
    + rewrite N_eqb_true__eq in Heqc. rewrite Heqc in Heqb. easy.
    + remember (n - S n0 =? 0) as d; destruct d; symmetry in Heqd.
      rewrite N_eqb_true__eq in Heqd. rewrite N_ltb_true__lt in Heqb.
      assert (n = S n0) by omega.
      assert (Init.Nat.pred n < S n0) by omega.
      rewrite <- N_ltb_true__lt in H0.
      rewrite H0. rewrite H. simpl. rewrite N_minus_itself. reflexivity.
      rewrite N_ltb_true__lt in Heqb. rewrite N_eqb_false__ne in Heqd. rewrite N_nonzero__pos in Heqd.
      assert (Init.Nat.pred n >= S n0) by omega.
      rewrite <- N_ltb_false__ge in H. rewrite H. simpl.
      assert (Init.Nat.pred (n - S n0) = (Init.Nat.pred n - S n0)%nat) by omega.
      rewrite H0. reflexivity.
    + rewrite N_eqb_true__eq in Heqc. rewrite Heqc. zero.
    + rewrite N_ltb_false__ge in Heqb. assert (Init.Nat.pred n < S n0) by omega.
      rewrite <- N_ltb_true__lt in H. rewrite H.
      assert (S (n0 - n) = (n0 - Init.Nat.pred n)%nat). destruct n0. inversion Heqb.
      rewrite H0 in Heqc. simpl in Heqc. inversion Heqc.
      destruct n. simpl in Heqc. inversion Heqc. omega.
      rewrite H0. reflexivity.
  - unfold Z_opp, Z_plus.
    remember (n <? n0) as b; remember (n0 =? 0) as c; destruct b, c; symmetry in Heqb, Heqc; simpl.
    + rewrite N_eqb_true__eq in Heqc. rewrite Heqc in Heqb. rewrite N_ltb_true__lt in Heqb. inversion Heqb.
    + rewrite N_ltb_true__lt in Heqb. remember (n0 - S n =? 0) as d; destruct d; symmetry in Heqd; simpl.
      rewrite N_eqb_false__ne in Heqc. rewrite N_eqb_true__eq in Heqd.
      assert (n0 = S n) by omega. rewrite H. simpl. assert (n < S n) by omega.
      rewrite <- N_ltb_true__lt in H0. rewrite H0. rewrite N_minus_itself. reflexivity.
      rewrite N_eqb_false__ne in Heqc, Heqd. assert (Init.Nat.pred n0 >= S n) by omega.
      rewrite <- N_ltb_false__ge in H. rewrite H.
      assert (Init.Nat.pred (n0 - S n) = (Init.Nat.pred n0 - S n)%nat) by omega.
      rewrite H0. reflexivity.
    + rewrite N_eqb_true__eq in Heqc. rewrite Heqc. zero.
    + rewrite N_ltb_false__ge in Heqb. rewrite N_eqb_false__ne in Heqc.
      assert (Init.Nat.pred n0 < S n) by omega.
      rewrite <- N_ltb_true__lt in H. rewrite H.
      assert (S (n - n0) = (n - Init.Nat.pred n0)%nat) by omega.
      rewrite H0. reflexivity.
  - simpl. rewrite plus_n_Sm. reflexivity.
Qed.

Lemma Z_opp_distr_minus: forall x y: int, - (x - y) = y - x.
Proof. unfold Z_minus. intros. rewrite (Z_opp_distr x (-y)). rewrite Z_opp_involutive. apply Z_2. Qed.

Lemma Z_opp_lt: forall x y: int, x <Z y <-> -y <Z -x.
Proof. split; intros.
  - apply Z_opp_lt_imp. apply H.
  - rewrite <- (Z_opp_involutive y), <- (Z_opp_involutive x).
    apply Z_opp_lt_imp. apply H.
Qed.

Lemma Z_pos_diff__gt: forall x y: int, x - y >Z Z_pos 0 <-> x >Z y.
Proof. intros. rewrite <- Z_opp_distr_minus. rewrite Z_opp_lt. rewrite Z_opp_involutive.
  assert (-Z Z_pos 0 = Z_pos 0) by reflexivity. rewrite H. rewrite Z_neg_diff__lt.
  reflexivity.
Qed.

Lemma Z_10_0: forall x: int,
    (  x <Z Z_pos 0 /\ ~ x = Z_pos 0 /\ ~ x >Z Z_pos 0) \/
    (~ x <Z Z_pos 0 /\   x = Z_pos 0 /\ ~ x >Z Z_pos 0) \/
    (~ x <Z Z_pos 0 /\ ~ x = Z_pos 0 /\   x >Z Z_pos 0).
Proof.
  destruct x.
  - destruct n. right. left. split. simpl. omega. split. simpl. reflexivity. simpl. omega.
    right. right. split. simpl. omega. split. unfold not. intros. inversion H. simpl. omega.
  - left. split. simpl. omega. split. unfold not. intros. inversion H. simpl. easy.
Qed.

(** trichotomy *)
Theorem Z_10: forall x y: int,
  (  x <Z y /\ ~ x = y /\ ~ x >Z y) \/
  (~ x <Z y /\   x = y /\ ~ x >Z y) \/
  (~ x <Z y /\ ~ x = y /\   x >Z y).
Proof.
  intros. rewrite <- Z_neg_diff__lt. rewrite <- Z_no_diff__eq. rewrite <- (Z_pos_diff__gt x y).
  apply Z_10_0.
Qed.

(** trichotomy *)
Corollary Z_10_1: forall x y: int, x <Z y \/ x = y \/ x >Z y.
Proof.
  intros.
  pose proof (Z_10 x y).
  destruct H; destruct H.
  - left. apply H.
  - destruct H. destruct H0. right. left. apply H0.
  - destruct H. destruct H0. right. right. apply H1.
Qed.

Lemma Z_plus_0_l: forall x: int, Z_pos 0 + x = x.
Proof. destruct x.
  - simpl. reflexivity.
  - simpl. zero.
Qed.

(** transitivity *)
Lemma Z_11_0: forall x y: int, x <Z Z_pos 0 -> y <Z Z_pos 0 -> x + y <Z Z_pos 0.
Proof. destruct x, y; intros.
  - simpl in H. rewrite N_nle__gt in H; inversion H.
  - simpl in H. rewrite N_nle__gt in H; inversion H.
  - simpl in H0. rewrite N_nle__gt in H0; inversion H0.
  - simpl. easy.
Qed.

(** transitivity *)
Theorem Z_11: forall x y z: int, x <Z y -> y <Z z -> x <Z z.
Proof. intros x y z. rewrite <- (Z_neg_diff__lt x y). rewrite <- (Z_neg_diff__lt x z). rewrite <- (Z_neg_diff__lt y z).
  assert ((x - y) + (y - z) = x - z).
  { unfold Z_minus. rewrite Z_1. rewrite <- (Z_1 (- y)).
    assert (- y + y = Z_pos 0). destruct y.
    simpl; destruct n; zero. assert (n < S n) by omega.
    rewrite <- N_ltb_true__lt in H. rewrite H. reflexivity.
    simpl. assert (n < S n) by omega. rewrite <- N_ltb_true__lt in H. rewrite H. zero.
    rewrite H. rewrite Z_plus_0_l. reflexivity. }
  rewrite <- H. apply (Z_11_0 (x - y) (y - z)).
Qed.

(** addition preserves the order *)
Theorem Z_12: forall x y z: int, x <Z y -> x + z <Z y + z.
Proof. intros x y z. rewrite <- (Z_neg_diff__lt x y). rewrite <- (Z_neg_diff__lt (x + z) (y + z)).
  unfold Z_minus. rewrite Z_1. rewrite Z_opp_distr. rewrite (Z_2 (-y) (-z)). rewrite <- (Z_1 z).
  rewrite Z_4. rewrite (Z_2 (Z_pos 0)). rewrite Z_3. intros. apply H.
Qed.

(** mult by positive number preserves the order *)
Theorem Z_13: forall x y z: int, x <Z y /\ z >Z Z_pos 0 -> x * z <Z y * z.
Proof.

Admitted.

(** Z is not a trivial ring *)
Theorem Z_14: 0 <> 1.
Proof. unfold not. intros. inversion H. Qed.

Lemma Z_not_not_equal: forall z w: int, z = w <-> ~ z <> w.
Proof.
Admitted.

Lemma Z_mult_0: forall z: int, z * Z_pos 0 = Z_pos 0.
Proof.
  destruct z; zero.
Qed.

Lemma Z_mult_neg_1: forall z: int, - z = - (Z_pos 1) * z.
Proof.
  destruct z; simpl; zero.
Qed.

Close Scope int_scope.


(*
  Copyright 2023 ZhengPu Shi
  This file is part of CoqMatrix. It is distributed under the MIT
  "expat license". You should have recieved a LICENSE file with it.

  purpose   : Chapter 1, Introduction to Vectors
  author    : ZhengPu Shi
  date      : 2023.03

  remark    :
  1. reference: Introduction to Linear Algebra, by Gilbert Strang
 *)

(** There is no implementation of sqrt, thus vlen cannot be defined. *)
(* Require Import VectorQ. *)

Require Import VectorR.

(** Set initial scope *)
Open Scope nat_scope.
(* Open Scope Q_scope. *)
Open Scope R_scope.
Open Scope mat_scope.
Open Scope vec_scope.

(** ** 1.1 Vectors and Linear Combination  *)
Section sec_1_1.

  (** Linear Combination of: c * v + d * w *)
  Definition lc {n : nat} (v w : vec n) (c d : A) := c c* v + d c* w.

  (* Example  *)
  Let v := mk_vec2 1 1.
  Let w := mk_vec2 2 3.

  Goal lc v w 1 1 == mk_vec2 3 4.
  Proof. lma. Qed.

  Goal lc v w 2 1 == mk_vec2 4 5.
  Proof. lma. Qed.

  Goal lc v w 3 5 == mk_vec2 13 18.
  Proof. lma. Qed.

  (** Verify these special linear combinations: *)
  Section special_linear_combinations.

    (* 1v + 1w = v + w *)
    Lemma lc_eq_add : forall {n} (v w : vec n), lc v w 1 1 == v + w.
    Proof. lma. Qed.

    (* 1v - 1w = v - w *)
    Lemma lc_eq_sub : forall {n} (v w : vec n), lc v w 1 (-1) == v - w.
    Proof. lma. Qed.

    (* 0v + 0w = 0 *)
    Lemma lc_eq_zero : forall {n} (v w : vec n), lc v w 0 0 == vec0.
    Proof. lma. Qed.

    (* cv + 0w = c.v *)
    Lemma lc_eq_scal : forall {n} (v w : vec n) (c : A), lc v w c 0 == c c* v.
    Proof. lma. Qed.

  End special_linear_combinations.

  (** Example for 3D vector *)
  Goal let v := mk_vec3 1 1 (-1) in
       let w := mk_vec3 2 3 4 in
       lc v w 1 1 == mk_vec3 3 4 3.
  Proof. lma. Qed.

  (** Linear combination of several vectors (more than 2) *)
  Reset lc.

  Definition lc {n : nat} (l : list (A * (vec n))%type) :=
    let l' := map (fun x : A * vec n => let (c,v) := x in c c* v) l in
    fold_left vadd l' vec0.

  (** Example in page 5 *)
  Goal let u := mk_vec3 1 0 3 in
       let v := mk_vec3 1 2 1 in
       let w := mk_vec3 2 3 (-1) in
       lc [(1,u);(4,v);(-2,w)] == mk_vec3 1 2 9.
  Proof. lma. Qed.

End sec_1_1.

(** ** 1.2 Lengths and Dot Products *)
Section sec_1_2.

  Infix "⋅" := vdot : vec_scope.
  Notation "v| v |" := (vlen v) : vec_scope.

  (** A vector is a unit vector *)
  Section vunit.

    (** unit vector in xy plane *)
    Let i := mk_vec2 1 0.
    Let j := mk_vec2 0 1.

    (** make an angle "theta" with the x axis *)
    Let u θ := mk_vec2 (cos θ) (sin θ).

    (** if theta = 0, then u is i *)
    Goal u 0 == i.
    Proof. lma; cbv; ra. Qed.

    (** if theta = 90 degree (π/2), then u is j *)
    Goal u (PI/2) == j.
    Proof. lma; cbv; ra. Qed.

    (** at any angle, u is a unit vector *)
    Goal forall θ, vunit (u θ).
    Proof. intros. cbv. autorewrite with R. auto. Qed.

  End vunit.

  (** Convert any non-zero vector to a unit vector *)
  Section vnormalize.

    Let u := mk_vec3 2 2 1.

    (** length of us is 3 *)
    Let len_of_u : v| u | = 3.
    Proof. cbv. solve_sqrt_eq. Qed.

    (** normalize u to unit vector *)
    Goal vnormalize u == mk_vec3 (2/3) (2/3) (1/3).
    Proof. lma. all: rewrite len_of_u; cbv; ra. Qed.

  End vnormalize.

  (** The angle between two vectors *)
  Section angle.

    (** Angle of two vectors *)
    Parameter angle_of_vec : forall {n} (u v : vec n), R.
    Infix "∠" := angle_of_vec (at level 70) : vec_scope.

    (** Two vectors are perpendicular *)
    Section perp.

      (** Two vectors u and w are perpendicular *)
      Definition perpendicular {n} (u v : vec n) : Prop := u ∠ v = PI/2.
      Infix "⟂" := perpendicular (at level 70) : vec_scope.

      (** Pythagoras Law. *)
      Axiom PythagorasLaw2D : forall (a b : vec 2),
          let c := a - b in
          a ⟂ b <-> (Rsqr (v|a|) + Rsqr (v|b|))%A = Rsqr (v|c|).

      (** v ⟂ w, iff v ⋅ w = 0 *)
      Lemma perpendicular_iff_dot0_2D : forall (u v : vec 2), u ⟂ v <-> u ⋅ v = 0.
      Proof.
        intros. split; intros H.
        - apply PythagorasLaw2D in H.
          destruct u as [u], v as [v]. cbv in *.
          ring_simplify in H. autorewrite with R in *.
          rewrite ?Rsqr_sqrt in H; ra.
        - apply PythagorasLaw2D.
          destruct u as [u], v as [v]. cbv in *.
          ring_simplify. autorewrite with R in *.
          rewrite ?Rsqr_sqrt; ra.
      Qed.
    End perp.

    (** The angle of two unit vectors *)
    Section angle_vunit.

      (** the cosine of angle of two unit vectors *)
      Axiom cosine_angle_of_vuint : forall {n} (u v : vec n),
          vunit u -> vunit v -> cos (u ∠ v) = u ⋅ v.

      (** if u = (cos θ, sin θ), i = (1,0), then u⋅i=cos θ.
        That is the cosine of the angle between them. *)

      (** after rotation through any angle α, their angle still is θ *)

    End angle_vunit.

    (** The angle of two vectors (needn't be unit vector) *)
    Section angle.

      (** the cosine of angle of two vectors *)
      Axiom cosine_angle_of_vec : forall {n} (u v : vec n),
          vnonzero u -> vnonzero v ->
          cos (u ∠ v) = (vnormalize u) ⋅ (vnormalize v).

      (** “Schwarz inequality” for dot products.
          more correctly, Cauchy-Schwarz-Buniakowsky inequality *)
      Lemma schwarz_ineq_vdot : forall {n} (v w : vec n), Rabs (v⋅w) <= v|v | * v|w|.
      Proof.
        intros.
        destruct (decidable v vec0), (decidable w vec0).
        - (* v = 0, w = 0 *)
          assert (v ⋅ w == 0)%A.
          { rewrite v0. rewrite vdot_0_l. easy. }
          rewrite H. autorewrite with R.
          ?
          hnf. ra.
            rewrite v1.
            rewrite v0.
          Set Printing All.

          rewrite v0.

        - (* v = 0, w <> 0 *)
        - (* v = 0, w <> 0 *)
        - (* v = 0, w <> 0 *)

        pose proof (cosine_angle_of_vec v w).
        assert (vnormalize v ⋅ vnormalize w
        unfold vnormalize in H.
        assert
        s hnf in *.

      Admitted.

      (** Triangle inequality *)
      Lemma triangle_ineq : forall {n} (v w : vec n), v|v + w| <= v|v | + v|w|.
      Admitted.

    End angle.

    (**

  End angle.

End sec_1_2.


Inductive natural : Type := Succ : natural -> natural |  Zero : natural.

Inductive lst : Type := Cons : natural -> lst -> lst |  Nil : lst.

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

Inductive Pair : Type := mkpair : natural -> natural -> Pair
with Zlst : Type := zcons : Pair -> Zlst -> Zlst |  znil : Zlst.

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) : natural
           := match plus_arg0, plus_arg1 with
              | Zero, n => n
              | Succ n, m => Succ (plus n m)
              end.

Fixpoint double (double_arg0 : natural) : natural
           := match double_arg0 with
              | Zero => Zero
              | Succ n => Succ (Succ (double n))
              end.

Lemma lem: forall m n, Succ (plus m n) = plus m (Succ n).
Proof.
   induction m.
   - intros. simpl. rewrite IHm. reflexivity.
   - intros. reflexivity.
Qed.

Theorem theorem0 : forall (x : natural), eq (double x) (plus x x).
Proof.
   induction x.
   - simpl. f_equal. rewrite IHx. apply lem.
   - reflexivity.
Qed.