Require Import OrdersFacts.
Require Import OrdersTac.
Require Import QArith.
Require Import QOrderedType.

(* Auxiliary facts about Q that don't seem to be readily to
   hand in the standard library. *)

Local Open Scope Q.

Lemma Q_mul_pos_pos : forall p q : Q, 0 < p -> 0 < q -> 0 < p * q.
Proof.
  intros p q; unfold Qlt; simpl; rewrite ?Z.mul_1_r; apply Z.mul_pos_pos.
Qed.

Definition QPos := { x : Q | 0 < x }.

Delimit Scope QPos_scope with QPos.

Local Open Scope QPos.

Module Type OrderedTypeFullWithOrderFunctions :=
  OrderedTypeFull <+ HasBoolOrdFuns <+ BoolOrdSpecs.

Module QPos
 <: BooleanDecidableType
 <: OrderedTypeFullWithOrderFunctions
 <: LtBool
 <: TotalOrder.

Definition t := QPos.

Local Notation "!" := proj1_sig.

Definition eq (p q : t) := (!p == !q)%Q.
Definition lt (p q : t) := (!p < !q)%Q.
Definition le (p q : t) := (!p <= !q)%Q.
Definition compare (p q : t) := (!p ?= !q)%Q.

Infix "==" := eq : QPos_scope.
Infix "<" := lt : QPos_scope.
Infix "<=" := le : QPos_scope.
Infix "?=" := compare (at level 70, no associativity) : QPos_scope.

Instance eq_equiv : Equivalence eq.
Proof.
  split; unfold eq; [intros p | intros p q | intros p q r]; apply Q_Setoid.
Qed.

Instance lt_strorder : StrictOrder lt.
Proof.
  split; unfold lt; [ intros q ; unfold complement | intros p q r];
  apply QOrder.TO.lt_strorder.
Qed.

Instance lt_compat : Proper (eq==>eq==>iff) lt.
Proof.
  split; unfold lt; unfold eq in H, H0; rewrite H; rewrite H0; trivial.
Qed.

Lemma le_lteq p q : p <= q <-> p < q \/ p == q.
Proof. split; unfold eq, le, lt; apply Qle_lteq. Qed.

Lemma lt_total p q : p < q \/ p == q \/ q < p.
Proof. unfold eq, lt; apply QOrder.TO.lt_total. Qed.

Lemma eq_dec p q : { p == q } + { ~ p == q }.
Proof. unfold eq; apply QOrder.TO.eq_dec. Qed.

Definition eqb p q := if eq_dec p q then true else false.
Definition leb p q := match p ?= q with | Gt => false | _ => true end.
Definition ltb p q := match p ?= q with | Lt => true | _ => false end.

Infix "=?" := eqb (at level 70, no associativity) : QPos_scope.
Infix "<=?" := leb (at level 70, no associativity) : QPos_scope.
Infix "<?" := ltb (at level 70, no associativity) : QPos_scope.

Lemma eqb_eq p q : (p =? q) = true <-> p == q.
Proof. unfold eq, eqb; destruct (eq_dec p q); intuition. Qed.

Lemma ltb_lt p q : (p <? q) = true <-> p < q.
Proof.
  unfold ltb, lt, compare; rewrite Qlt_alt; case (!p ?= !q)%Q; split; easy.
Qed.

Lemma leb_le p q : (p <=? q) = true <-> p <= q.
Proof.
  unfold leb, le, compare; rewrite Qle_alt; case (!p ?= !q)%Q; split; easy'.
Qed.

Lemma compare_spec p q : CompareSpec (p == q) (p < q) (q < p) (p ?= q).
Proof.
  unfold eq, lt, compare; case Qcompare_spec; now constructor.
Qed.

Include OrderedTypeFullFacts.

(* Arithmetic *)

Definition one : t.
  refine (exist _ (inject_Z 1) _); easy.
Defined.

Definition two : t.
  refine (exist _ (inject_Z 2) _); easy.
Defined.

Notation "1" := one : QPos_scope.
Notation "2" := two : QPos_scope.

(* Multiplication: definition and order. *)

Definition mul (p q : t) : t.
  refine (exist _ (!p * !q) _); destruct p, q; now apply Q_mul_pos_pos.
Defined.

Infix "*" := mul : QPos_scope.

(* Basic facts about multiplication. *)

Lemma mul_assoc p q r : p * (q * r) == (p * q) * r.
Proof.
  apply Qmult_assoc.
Qed.

Lemma mul_comm p q : p * q == q * p.
Proof.
  apply Qmult_comm.
Qed.

Lemma mul_1_l p : 1 * p == p.
Proof.
  apply Qmult_1_l.
Qed.

Lemma mul_1_r p : p * 1 == p.
Proof.
  apply Qmult_1_r.
Qed.

(* Multiplication and order. *)

Lemma mul_le_mono_l p q r : q <= r  <->  p * q <= p * r.
Proof.
  split; apply Qmult_le_l; now destruct p.
Qed.

Lemma mul_le_mono_r p q r : q <= r  <->  q * p <= r * p.
Proof.
  split; apply Qmult_le_r; now destruct p.
Qed.

Lemma mul_lt_mono_l p q r :  q < r  <->  p * q < p * r.
Proof.
  split; apply Qmult_lt_l; now destruct p.
Qed.

Lemma mul_lt_mono_r p q r :  q < r  <->  q * p < r * p.
Proof.
  split; apply Qmult_lt_r; now destruct p.
Qed.

(* Reciprocal. *)

Definition inv (p : t) : t.
  refine (exist _ (/ !p)%Q _); apply Qinv_lt_0_compat; now destruct p.
Defined.

Notation "/ x" := (inv x).

Lemma mul_inv_r p : p * /p == 1.
Proof.
  apply Qmult_inv_r; destruct p; simpl; QOrder.order.
Qed.

(* Division. *)

Definition div (p q : t) : t := p * /q.

Infix "/" := div : QPos_scope.

(* QPos and the positive type. *)

Definition from_pos (m : positive) : t.
  refine (exist _ (inject_Z (' m)) _); apply Pos2Z.is_pos.
Defined.

Lemma as_fraction (p : t) :
  exists (m n : positive), p == (from_pos m) / (from_pos n).
Proof.
  destruct p; exists (Z.to_pos (Qnum x)), (Qden x); unfold eq; simpl; rewrite Z2Pos.id.
  unfold Qeq; simpl; ring.
  unfold Qlt in q; simpl in q; ring_simplify in q; easy.
Qed.

End QPos.

(* Re-export notations. *)

Infix "==" := QPos.eq : QPos_scope.
Infix "<" := QPos.lt : QPos_scope.
Infix "<=" := QPos.le : QPos_scope.
Notation "p > q" := (q < p) (only parsing) : QPos_scope.
Notation "p >= q" := (q <= p) (only parsing) : QPos_scope.

Infix "?=" := QPos.compare (at level 70, no associativity) : QPos_scope.
Infix "=?" := QPos.eqb (at level 70, no associativity) : QPos_scope.
Infix "<=?" := QPos.leb (at level 70, no associativity) : QPos_scope.
Infix "<?" := QPos.ltb (at level 70, no associativity) : QPos_scope.

Infix "*" := QPos.mul : QPos_scope.
Infix "/" := QPos.div : QPos_scope.
Notation "/ p" := (QPos.inv p) : QPos_scope.

Notation "1" := QPos.one : QPos_scope.
Notation "2" := QPos.two : QPos_scope.

Notation "x < y < z" := ((x < y) /\ (y < z)) : QPos_scope.
Notation "x <= y < z" := ((x <= y) /\ (y < z)) : QPos_scope.
Notation "x < y <= z" := ((x < y) /\ (y <= z)) : QPos_scope.
Notation "x <= y <= z" := ((x <= y) /\ (y <= z)) : QPos_scope.

(* Additional results about QPos. *)

Lemma QPos_le_eq p q : p == q  ->  p <= q.
Proof.
  intro p_eq_q. rewrite p_eq_q. unfold QPos.le. destruct q. simpl. auto with qarith.
Qed.

Lemma QPos_le_antisymm q r : q <= r -> r <= q -> q == r.
Proof.
  unfold QPos.le, QPos.eq; destruct q, r; simpl.
  auto with qarith.
Qed.

Lemma QPos_le_refl q : q <= q.
Proof.
  unfold QPos.le; destruct q; simpl; auto with qarith.
Qed.

(* Positive rationals to and from positive integers. *)

Definition QPos_num (q : QPos) : positive := Z.to_pos (Qnum (proj1_sig q)).
Definition QPos_den (q : QPos) : positive := Qden (proj1_sig q).

Definition QPos_from_pos (p : positive) : QPos.
  refine (exist _ (inject_Z (' p)) _); apply Pos2Z.is_pos.
Defined.

Lemma QPos_num_positive (q : Q) : (0 < q)%Q -> ('Z.to_pos (Qnum q) = Qnum q)%Z.
Proof.
  intros q_positive; apply Z2Pos.id; revert q_positive;
  unfold Qlt; now rewrite Z.mul_1_r.
Qed.

Lemma Q_as_fraction (q : Q) : (inject_Z (Qnum q) / inject_Z (' Qden q) == q)%Q.
Proof.
  unfold Qeq; simpl; ring.
Qed.

Lemma num_over_den : forall q : QPos,
  QPos_from_pos (QPos_num q) / QPos_from_pos (QPos_den q) == q.
Proof.
  intro q. destruct q.
  unfold QPos.eq, QPos.div, QPos_num, QPos_den. simpl.
  rewrite QPos_num_positive; [ | easy].
  apply Q_as_fraction.
Qed.

Instance QPos_Setoid : Equivalence QPos.eq.
Proof.
  split; unfold QPos.eq; intro; [reflexivity | now symmetry |
    intros y z; now transitivity (proj1_sig y)].
Qed.

Add Morphism QPos.lt : QPos_lt_morphism.
Proof.
  unfold QPos.lt, QPos.eq.
  destruct x, y. simpl. intro.
  destruct x1, y0. simpl. intro.
  rewrite H. rewrite H0. reflexivity.
Qed.

Add Morphism QPos.le : QPos_le_morphism.
Proof.
  unfold QPos.le, QPos.eq.
  destruct x, y. simpl. intro.
  destruct x1, y0. simpl. intro.
  rewrite H. rewrite H0. reflexivity.
Qed.

Add Morphism QPos.mul : QPos_mul_morphism.
  unfold QPos.eq; simpl; intros; rewrite H; now rewrite H0.
Qed.

Add Morphism QPos.div : QPos_div_morphism.
  unfold QPos.eq; simpl; intros; rewrite H; now rewrite H0.
Qed.

Lemma QPos_from_pos_lt : forall p q, (p < q)%positive  -> QPos_from_pos p < QPos_from_pos q.
Proof.
  intros; unfold QPos.lt; simpl; rewrite <- Zlt_Qlt; unfold Zlt;
  now apply Pos.compare_lt_iff.
Qed.

Lemma QPos_from_pos_le : forall p q, (p <= q)%positive ->
  QPos_from_pos p <= QPos_from_pos q.
Proof.
  intros. unfold QPos.le. simpl. rewrite <- Zle_Qle. unfold Zle.
  now apply Pos.compare_le_iff.
Qed.

Lemma QPos_mul_inv_l p : /p * p == 1.
Proof.
  rewrite QPos.mul_comm. apply QPos.mul_inv_r.
Qed.

Lemma QPos_div_mul b c : b / c * c == b.
Proof.
  unfold QPos.div.
  rewrite <- QPos.mul_assoc. rewrite QPos_mul_inv_l.
  apply QPos.mul_1_r.
Qed.

Lemma QPos_mul_div b c : b * c / c == b.
Proof.
  unfold QPos.div.
  rewrite <- QPos.mul_assoc.
  rewrite QPos.mul_inv_r.
  apply QPos.mul_1_r.
Qed.

Lemma QPos_div_mul_r a b c : a == b / c  <->  a * c == b.
  split; intro; [rewrite H | rewrite <- H].
  apply QPos_div_mul. symmetry.  apply QPos_mul_div.
Qed.

Lemma QPos_div_mul_le_r a b c : b / c <= a  <->  b <= a * c.
Proof.
  rewrite QPos.mul_le_mono_r with (p := c).
  setoid_replace (b / c * c) with b. easy.
  apply QPos_div_mul.
Qed.

Lemma QPos_div_mul_le_l a b c : a <= b / c  <->  a * c <= b.
Proof.
  rewrite QPos.mul_le_mono_r with (p := c).
  setoid_replace (b / c * c) with b. easy.
  apply QPos_div_mul.
Qed.

Lemma QPos_div_mul_lt_l a b c : a < b / c  <->  a * c < b.
Proof.
  rewrite QPos.mul_lt_mono_r with (p := c).
  setoid_replace (b / c * c) with b. easy.
  apply QPos_div_mul.
Qed.

Lemma QPos_div_mul_lt_r a b c : b / c < a  <->  b < a * c.
Proof.
  rewrite QPos.mul_lt_mono_r with (p := c).
  setoid_replace (b / c * c) with b. easy.
  apply QPos_div_mul.
Qed.

Lemma QPos_from_pos_one : QPos_from_pos 1 == 1.
Proof.
  easy.
Qed.

Lemma QPos_from_pos_two : QPos_from_pos 2 == 2.
Proof.
  easy.
Qed.

Lemma QPos_from_pos_mul: forall p q, QPos_from_pos (p * q) == QPos_from_pos p * QPos_from_pos q.
Proof.
  unfold QPos.eq. intros. simpl. easy.
Qed.

Lemma QPos_lt_le_weak : forall p q, p < q  -> p <= q.
Proof.
  unfold QPos.le, QPos.lt; intros p q; destruct p, q; auto with qarith.
Qed.

Lemma QPos_le_lt_trans a b c : a <= b -> b < c -> a < c.
Proof.
  unfold QPos.le, QPos.lt. destruct a, b, c. simpl.
  apply Qle_lt_trans.
Qed.

Lemma QPos_mul_le_lt a b c d : a <= c -> d < b  ->  a * d < c * b.
Proof.
  intros; apply QPos_le_lt_trans with (b := c * d);
  [now apply QPos.mul_le_mono_r | now apply QPos.mul_lt_mono_l].
Qed.

Lemma QPos_div_le_lt a b c d : a <= c -> d < b  ->  a / b < c / d.
Proof.
  intros.
  apply QPos.mul_lt_mono_r with (p := b * d).
  setoid_replace (a / b * (b * d)) with (a * d).
  setoid_replace (c / d * (b * d)) with (c * b).
  now apply QPos_mul_le_lt.

  (* Left with two equality goals. Cheat by mapping to Q and using the big
  guns. *)
  unfold QPos.eq; destruct a, b, c, d; simpl; field; apply Qnot_eq_sym;
  now apply Qlt_not_eq.

  unfold QPos.eq; destruct a, b, c, d; simpl; field. apply Qnot_eq_sym;
  now apply Qlt_not_eq.
Qed.

Lemma QPos_div_lt_le a b c d : a < c -> d <= b -> a / b < c / d.
Proof.
  intros.
  apply QPos.mul_lt_mono_r with (p := b * d).
  setoid_replace (a / b * (b * d)) with (d * a).
  setoid_replace (c / d * (b * d)) with (b * c).
  now apply QPos_mul_le_lt.

  unfold QPos.eq; destruct a, b, c, d; simpl; field; apply Qnot_eq_sym;
  now apply Qlt_not_eq.

  unfold QPos.eq; destruct a, b, c, d; simpl; field; apply Qnot_eq_sym;
  now apply Qlt_not_eq.
Qed.

Lemma QPos_le_trans a b c : a <= b -> b <= c -> a <= c.
Proof.
  destruct a, b, c; unfold QPos.le; QOrder.order.
Qed.

Lemma QPos_lt_le_trans a b c : a < b -> b <= c -> a < c.
Proof.
  destruct a, b, c; unfold QPos.le, QPos.lt; apply Qlt_le_trans.
Qed.

Lemma QPos_lt_trans a b c : a < b -> b < c -> a < c.
Proof.
  destruct a, b, c; unfold QPos.lt; apply Qlt_trans.
Qed.

Lemma QPos_le_ngt : forall q r, q <= r  <->  ~ (r < q).
Proof.
  intros q r; destruct q, r; unfold QPos.le, QPos.lt; split; QOrder.order.
Qed.

Lemma QPos_lt_nge : forall q r, q < r  <->  ~ (r <= q).
Proof.
  intros q r; destruct q, r; unfold QPos.le, QPos.lt; split; QOrder.order.
Qed.

Lemma QPos_ltb_le : forall q r, (q <? r) = false  <->  r <= q.
Proof.
  unfold QPos.le, QPos.ltb, QPos.compare. intros q r. destruct q, r. simpl.
  case_eq (x ?= x0)%Q.
  rewrite <- Qeq_alt. intuition.
  rewrite H. auto with qarith.
  rewrite <- Qlt_alt. intuition. exfalso. assert (x < x)%Q.
  eapply Qlt_le_trans; eauto. revert H1. unfold Qlt. auto with zarith.
  rewrite <- Qgt_alt. intuition.
Qed.


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

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

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


Require Export Basics.

Inductive natprod : Type :=
  pair : nat -> nat -> natprod.

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

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

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

Definition sndd (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_pairingg : forall (n m : nat),
  (n,m) = (fst (n,m), snd (n,m)).
Proof.
  reflexivity.
Qed.

Theorem surjective_pairing_stuck : forall (p : natprod),
  p = (fst p, snd p).
Proof.
  destruct p.
  reflexivity.
Qed.

Theorem surjective_pairing : 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.
  destruct p. reflexivity.
Qed.

Theorem fst_swap_is_and : forall (p : natprod),
  fst (swap_pair p) = snd p.
Proof.
  intros.
  destruct p.
  reflexivity.
Qed.

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

Definition l_123 := 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 l_123' := 1 :: (2 :: (3 :: nil)).
Definition l_123'' := 1 :: 2 :: 3 :: nil.
Definition l_123''' := [1,2,3].

Notation "x + y" := (plus x y)
                    (at level 50, left associativity).

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

Eval simpl in (repeat 15).

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 tail (l:natlist) : natlist :=
  match l with
  | nil => nil
  | h :: t => t
  end.

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

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

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

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

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

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

Example test_countoddmembers1: countoddmembers [1,0,3,1,4,5] = 4.
Proof. reflexivity. Qed.
Example testcountoddmembers2: countoddmembers [0,2,4] = 0.
Proof. reflexivity. Qed.

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

Fixpoint alternate (l1 l2 : natlist) : natlist :=
  match l1, l2 with
  | nil, x2 => x2
  | x1, nil => x1
  | 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. reflexivity. Qed.
Example test_alternate2: alternate [1] [4,5,6] = [1,4,5,6].
Proof. reflexivity. Qed.
Example test_alternate3: alternate [1,2,3] [4] = [1,4,2,3].
Proof. reflexivity. Qed.
Example test_alternate4: alternate [] [20,30] = [20,30].
Proof. reflexivity. Qed.

Definition bag := natlist.

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

Example test_count1: count 1 [1,2,3,1,4,1] = 3.
Proof. reflexivity. Qed.
Example test_count2: count 6 [1,2,3,1,4,1] = 0.
Proof. 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 :=
  [v] ++ s.

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

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

Definition member (v:nat) (s:bag) : bool :=
  match count v s with
  | O => false
  | S _ => true
  end.

Example test_member1: member 1 [1,4,1] = true.
Proof. 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 => match beq_nat v h with
              | true => t
              | false => h :: (remove_one v t)
              end
  end.

Example test_remove_one1: count 5 (remove_one 5 [2,1,5,4,1]) = 0.
Proof. 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 => match beq_nat v h with
              | true => remove_all v t
              | false => h :: (remove_all v t)
              end
  end.

Example test_remove_all1: count 5 (remove_all 5 [2,1,5,4,1]) = 0.
Proof. 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, s2 with
  | nil, _ => true
  | h :: t, s22 => match member h s22 with
                   | true => subset t (remove_one h s22)
                   | false => false
                   end
  end.

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

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

Theorem tl_length_pred : forall (l : natlist),
  pred (length l) = length (tail l).
Proof.
  intros.
  destruct l as [ | ll].
  reflexivity. reflexivity.
Qed.

Theorem app_ass : forall (l1 l2 l3 : natlist),
  (l1 ++ l2) ++ l3 = l1 ++ (l2 ++ l3).
Proof.
  intros.
  induction l1.
  Case "l1 = nil".
    reflexivity.
  Case "l1 = cons n l1".
    simpl. rewrite IHl1.
    reflexivity.
Qed.

Theorem app_length : forall (l1 l2 : natlist),
  length (l1 ++ l2) = (length l1) + (length l2).
Proof.
  intros.
  induction l1. reflexivity.
  simpl. rewrite IHl1. reflexivity.
Qed.

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

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

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

Theorem length_snoc : forall (n:nat) (l:natlist),
  length (snoc l n) = S (length l).
Proof.
  intros. induction l. reflexivity.
  simpl. rewrite IHl. reflexivity.
Qed.

Theorem rev_length : forall (l : natlist),
  length (rev l) = length l.
Proof.
  intros.
  induction l. reflexivity.
  simpl. rewrite length_snoc.
  rewrite IHl. reflexivity.
Qed.

(* Usar SearchAbout blablabla *)

Theorem app_nil_end : forall (l : natlist),
  l ++ [] = l.
Proof.
  intros.
  induction l. reflexivity.
  simpl. rewrite IHl. reflexivity.
Qed.

Lemma snoc_simpl : forall (n:nat) (l:natlist),
  snoc l n   = l ++ [n].
Proof.
  intros.
  induction l. reflexivity.
  simpl. rewrite IHl. reflexivity.
Qed.

Theorem distr_rev : forall (l1 l2 : natlist),
  rev (l1 ++ l2) = (rev l2) ++ (rev l1).
Proof.
  intros.
  induction l1. simpl. rewrite app_nil_end. reflexivity.
  simpl. rewrite snoc_simpl.  rewrite snoc_simpl. rewrite IHl1. rewrite app_ass.
  reflexivity.
Qed.

Theorem rev_involutive : forall (l:natlist),
  rev (rev l) = l.
Proof.
  intros.
  induction l. reflexivity.
  simpl. rewrite snoc_simpl.
  rewrite distr_rev. rewrite IHl.
  reflexivity.
Qed.

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

Theorem snoc_append : forall (l:natlist) (n:nat),
  snoc l n = l ++ [n].
Proof.
  intros.
  induction l. reflexivity.
  simpl. rewrite IHl. reflexivity.
Qed.

Lemma nonzeros_length : forall (l1 l2 : natlist),
  nonzeros (l1 ++ l2) = (nonzeros l1) ++ (nonzeros l2).
Proof.
  intros.
  induction l1. reflexivity. assert (H : (n :: l1) ++ l2 = n :: (l1 ++ l2)).
  simpl.
  reflexivity.
  rewrite H.
  destruct n.
  simpl. apply IHl1.
  simpl.
  rewrite IHl1.
  reflexivity.
Qed.

Theorem count_member_nonzero : forall (s:bag),
  ble_nat 1 (count 1 (1 :: s)) = true.
Proof.
  intros.
  destruct s; reflexivity.
Qed.

Theorem ble_n_Sn : forall (n:nat),
  ble_nat n (S n) = true.
Proof.
  intros. induction n. reflexivity.
  simpl. rewrite IHn. reflexivity.
Qed.

Theorem remove_decreases_count : forall (s:bag),
  ble_nat (count 0 (remove_one 0 s)) (count 0 s) = true.
Proof.
  intros.
  induction s. reflexivity.
  destruct n.
  simpl.
  rewrite ble_n_Sn.
  reflexivity.
  simpl.
  apply IHs.
Qed.

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

Fixpoint index_bad (n:nat) (l:natlist) : nat :=
  match l with
  | nil => 42 (* arbitrary *)
  | a :: l' => match beq_nat n 0 with
               | true => a
               | false => index_bad (pred n) l'
               end
  end.

Fixpoint index (n:nat) (l:natlist) : natoption :=
  match l with
  | nil => None
  | a :: l' => match beq_nat n 0 with
               | true => Some a
               | false => index (pred n) l'
               end
  end.

Example test_index1  : index 0 [4,5,6,7] = Some 4.
Proof. reflexivity. Qed.
Example test_index2 : index 3 [4,5,6,7] = Some 7.
Proof. reflexivity. Qed.
Example test_index3 : index 10 [4,5,6,7] = None.
Proof. reflexivity. Qed.

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

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

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

Example test_hd_opt1  : hd_opt [] = None.
Proof. reflexivity. Qed.
Example test_hd_opt2 : hd_opt [1] = Some 1.
Proof. reflexivity. Qed.
Example test_hd_opt3 : hd_opt [5,6] = Some 5.
Proof. reflexivity. Qed.

Theorem option_elim_hd : forall (l:natlist) (default:nat),
  hd default l = option_elim (hd_opt l) default.
Proof.
  intros. induction l; reflexivity.
Qed.

Fixpoint beq_natlist (l1 l2 : natlist) : bool :=
  match l1, l2 with
  | [], [] => true
  | [], _ => false
  | _, [] => false
  | h1 :: t1, h2 :: t2 => if beq_nat h1 h2 then beq_natlist t1 t2 else false
  end.

Example test_beq_natlist1  : (beq_natlist nil nil = true).
Proof. reflexivity. Qed.
Example test_beq_natlist2 : beq_natlist [1,2,3] [1,2,3] = true.
Proof. reflexivity. Qed.
Example test_beq_natlist3 : beq_natlist [1,2,3] [1,2,4] = false.
Proof. reflexivity. Qed.

Theorem beq_natlist_refl : forall (l:natlist),
  true = beq_natlist l l.
Proof.
  intros. induction l. reflexivity.
  rewrite IHl. simpl.
  replace (beq_nat n n) with (true).
  reflexivity. induction n. reflexivity. simpl. rewrite IHn. reflexivity.
Qed.

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

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

(*  /\ IMPOSSÍVEL COM REWRITE?   *)

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

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

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

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

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

Theorem app_ass' : forall l1 l2 l3 : natlist,
  (l1 ++ l2) ++ l3 = l1 ++ (l2 ++ l3).
Proof.
  intros l1. induction l1 as [ | n l1'].
  reflexivity.
  assert (H : forall l2 l3, ((n::l1') ++ l2) ++ l3 = n :: (l1' ++ l2 ++ l3)).
Admitted.


Inductive list (X : Type) : Type :=
  | nil
  | cons (x : X) (l : list X).

Definition natlist := cons nat.
Definition boollist := cons bool.

Check natlist 1 (nil nat).
Check boollist true (nil bool).

Fixpoint repeat (X : Type) (x : X) (count : nat) : list X :=
  match count with
    | O => nil X
    | S count' => cons X x (repeat X x count')
  end.

Example test_repeat :
  repeat nat 4 2 = cons nat 4 (cons nat 4 (nil nat)).
Proof.
  reflexivity.
Qed.

Example test_repeat2 :
  repeat bool false 1 = cons bool false (nil bool).
Proof.
  reflexivity.
Qed.

Module MumbleGrumble.

Inductive mumble : Type :=
| a
| b (x : mumble) (y : nat)
| c.

Inductive grumble (X : Type) : Type :=
| d (m : mumble)
| e (x : X).

Fixpoint repeat' X x count : list X :=
  match count with
  | 0 => nil X
  | S count' => cons X x (repeat' X x count')
  end.

Check repeat'.

Fixpoint repeat'' X x count : list X :=
  match count with
    | 0 => nil _
    | S count' => cons _ x (repeat'' _ x count')
  end.

Arguments nil {X}.
Arguments cons {X}.
Arguments repeat {X}.

Definition list123'' := cons 1 (cons 2 (cons 3 nil)).
Check list123''.

Fixpoint repeat''' {X : Type} (x : X) (count : nat) : list X :=
  match count with
  | 0 => nil
  | S count' => cons x (repeat''' x count')
  end.

Inductive list' {X : Type} : Type :=
  | nil'
  | cons' (x : X) (l : list').

Fixpoint app {X : Type} (l1 l2 : list X) : list X :=
  match l1 with
    | nil => l2
    | cons h t => cons h (app t l2)
  end.

Fixpoint rev {X : Type} (l : list X) : list X :=
  match l with
  | nil => nil
  | cons h t => app (rev t) (cons h nil)
  end.

Eval compute in rev (cons 2 (cons 1 nil)).

Fixpoint length {X: Type} (l : list X) : nat :=
  match l with
  | nil => 0
  | cons h t => S (length t)
  end.

Eval compute in length (cons 1 (cons 2 nil)).

Check @nil.

Definition mynil' := @nil nat.

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

Theorem app_nil_r : forall (X : Type), forall l : list X,
      l ++ [] = l.
Proof.
  intros. induction l.
  - reflexivity.
  - simpl. rewrite IHl. reflexivity.
 Qed.

Theorem app_assoc : forall A (l m n : list A),
    l ++ m ++ n = (l ++ m) ++ n.
Proof.
  intros. induction l as [| x l1' IHl1'].
  - reflexivity.
  - simpl. rewrite IHl1'. reflexivity.
Qed.

Lemma app_length : forall (X : Type) (l1 l2 : list X),
    length (l1 ++ l2) = length l1 + length l2.
Proof.
  intros. induction l1 as [| n l1' IHl1'].
  - reflexivity.
  - simpl. rewrite IHl1'. reflexivity.
Qed.

Theorem rev_app_distr : forall X (l1 l2 : list X),
    rev (l1 ++ l2) = rev l2 ++ rev l1.
Proof.
  intros. induction l1 as [| n l1' IHl1'].
  - rewrite app_nil_r. simpl. reflexivity.
  - simpl. rewrite IHl1'. rewrite <- app_assoc. reflexivity.
Qed.

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

Inductive prod (X Y : Type) : Type :=
 | pair (x : X) (y : Y).

Arguments pair {X} {Y}.

Definition fst {X Y : Type} (p : X * Y) : X :=
  match p with
  | (x, y) => x
  end.

Definition scn {X Y : Type} (p: X * Y) : Y :=
  match p with
  | (x, y) => y
  end.

Fixpoint combine {X Y : Type} (lx : list X) (ly : list Y) : list (X*Y) :=
  match lx, ly with
  | [], _ => []
  | _, [] => []
  | x :: tx, y :: ty => (x,y)  :: (combine tx ty)
  end.

Compute combine [1;2;3] [true;false;false;true].

Check @combine.


(*

=================================================================
                 PERMUTATIVE GROUP OF FUNCTIONS
=================================================================

The permutative group of functions is defined as a single axiom:

                                        ∃ n : nat { f^n <=> id }

It has been proved that this axiom implies the axioms of Group Theory
for any natural number `n`:

https://github.com/advancedresearch/path_semantics/blob/master/papers-wip/permutation-group-of-functions.pdf

This makes it possible to prove formally with a proof assistant whether
a function generates a permutative group.

Here are some simple examples.

Checked with Coq IDE 8.11.0 (https://coq.inria.fr/)

*)

(* Function composition *)
Definition compose {A B C} (g : B -> C) (f : A -> B) :=
  fun x : A => g (f x).

(* Recursive composition `f^n` *)
Fixpoint compn {A : Type} (f : A -> A) (n : nat) :=
  match n with
  | 0 => fun x : A => x
  | 1 => fun x : A => f x
  | S r => fun x : A => (compn f r) (f x)
  end.

(* Identity function *)
Definition id {A : Type} := fun x: A => x.

(* Permutation group of functions *)
Definition fgroup {A : Type} (f : A -> A) :=
  exists n : nat, (compn f n) = @id A.

(* Prove that identity function of natural numbers is a group *)
Theorem id_nat_is_fgroup : fgroup (@id nat).
Proof.
  unfold id.
  unfold fgroup.
  pose (two := 2).
  refine (ex_intro _ two _).
  unfold compn.
  auto.
Qed.

(* Prove that identity function of any type is a group *)
Theorem id_is_fgroup (A : Type) : fgroup (@id A).
Proof.
  unfold id.
  unfold fgroup.
  pose (two := 2).
  refine (ex_intro _ two _).
  unfold compn.
  auto.
Qed.

(* Logical NOT *)
Definition not := fun x : bool =>
  match x with
  | true => false
  | false => true
  end.

(* Use functional extensionality *)
From Coq Require Import FunctionalExtensionality.

(* Prove logical NOT is a group *)
Theorem not_is_fgroup : fgroup not.
Proof.
  pose (two := 2).
  refine (ex_intro _ two _).
  compute.
  apply functional_extensionality.
  intro b.
  elim b.
  reflexivity.
  reflexivity.
Qed.

Inductive nat3 : Set :=
  | one : nat3
  | two : nat3
  | three : nat3.

Definition one_two_three := fun x : nat3 =>
  match x with
  | one => two
  | two => three
  | three => one
  end.

Theorem one_two_three_is_fgroup : fgroup one_two_three.
Proof.
  pose (x := 3).
  refine (ex_intro _ x _).
  compute.
  apply functional_extensionality.
  intro y.
  (* Prove case by case and apply reflexivity to each branch *)
  elim y; reflexivity.
Qed.


Require Import Coq.micromega.Lia.
Require Import Coq.ZArith.ZArith.
Require Import Coq.Lists.List.
Require Import Coq.Structures.Orders.
Require Import Crypto.Arithmetic.Core.
Require Import Crypto.Util.ListUtil.
Require Import Crypto.Util.ZUtil.EquivModulo.
Require Import Crypto.Util.ZUtil.Modulo Crypto.Util.ZUtil.Div.

Require Import Crypto.Util.Notations.
Import ListNotations Weight. Local Open Scope Z_scope.

(* extra name wrapper so partition won't be confused with List.partition *)
Module Partition.
  Definition partition (weight : nat -> Z) n x :=
    map (fun i => (x mod weight (S i)) / weight i) (seq 0 n).
End Partition.

Section PartitionProofs.
  Context weight {wprops : @weight_properties weight}.
  Local Notation partition := (Partition.partition weight).

  Lemma partition_step n x :
    partition (S n) x = partition n x ++ [(x mod weight (S n)) / weight n].
  Proof using Type.
    cbv [partition]. rewrite seq_snoc.
    autorewrite with natsimplify push_map. reflexivity.
  Qed.

  Lemma length_partition n x : length (partition n x) = n.
  Proof using Type. cbv [partition]; distr_length. Qed.
  Hint Rewrite length_partition : distr_length.

  Lemma eval_partition n x :
    Positional.eval weight n (partition n x) = x mod (weight n).
  Proof using wprops.
    induction n; intros.
    { cbn. rewrite (weight_0); auto with zarith. }
    { rewrite (Z.div_mod (x mod weight (S n)) (weight n)) by auto with zarith.
      rewrite <-Znumtheory.Zmod_div_mod by (try apply Z.mod_divide; auto with zarith).
      rewrite partition_step, Positional.eval_snoc with (n:=n) by distr_length.
      lia. }
  Qed.

  Lemma partition_Proper n :
    Proper (Z.equiv_modulo (weight n) ==> eq) (partition n).
  Proof using wprops.
    cbv [Proper Z.equiv_modulo respectful].
    intros x y Hxy; induction n; intros.
    { reflexivity. }
    { assert (Hxyn : x mod weight n = y mod weight n).
      { erewrite (Znumtheory.Zmod_div_mod _ (weight (S n)) x), (Znumtheory.Zmod_div_mod _ (weight (S n)) y), Hxy
          by (try apply Z.mod_divide; auto with zarith);
          reflexivity. }
      rewrite !partition_step, IHn by eauto.
      rewrite (Z.div_mod (x mod weight (S n)) (weight n)), (Z.div_mod (y mod weight (S n)) (weight n)) by auto with zarith.
      rewrite <-!Znumtheory.Zmod_div_mod by (try apply Z.mod_divide; auto with zarith).
      rewrite Hxy, Hxyn; reflexivity. }
  Qed.

  (* This is basically a shortcut for:
       apply partition_Proper; [ | cbv [Z.equiv_modulo] *)
  Lemma partition_eq_mod x y n :
    x mod weight n = y mod weight n ->
    partition n x = partition n y.
  Proof using wprops. apply partition_Proper. Qed.

  Lemma nth_default_partition d n x i :
    (i < n)%nat ->
    nth_default d (partition n x) i = x mod weight (S i) / weight i.
  Proof using Type.
    cbv [partition]; intros.
    rewrite map_nth_default with (x:=0%nat) by distr_length.
    autorewrite with push_nth_default natsimplify. reflexivity.
  Qed.

  Lemma nth_default_partition_full d n x i :
    nth_default d (partition n x) i = if lt_dec i n then x mod weight (S i) / weight i else d.
  Proof using Type.
    break_innermost_match;
      try now rewrite nth_default_out_of_bounds by distr_length.
    now rewrite nth_default_partition by lia.
  Qed.

  Fixpoint recursive_partition n i x :=
    match n with
    | O => []
    | S n' => x mod (weight (S i) / weight i) :: recursive_partition n' (S i) (x / (weight (S i) / weight i))
    end.

  Lemma recursive_partition_equiv' n : forall x j,
      map (fun i => x mod weight (S i) / weight i) (seq j n) = recursive_partition n j (x / weight j).
  Proof using wprops.
    induction n; [reflexivity|].
    intros; cbn. rewrite IHn.
    pose proof (@weight_positive _ wprops j).
    pose proof (@weight_divides _ wprops j).
    f_equal;
      repeat match goal with
             | _ => rewrite Z.mod_pull_div by auto with zarith
             | _ => rewrite weight_multiples by auto with zarith
             | _ => progress autorewrite with zsimplify_fast zdiv_to_mod pull_Zdiv
             | _ => reflexivity
             end.
  Qed.

  Lemma recursive_partition_equiv n x :
    partition n x = recursive_partition n 0%nat x.
  Proof using wprops.
    cbv [partition]. rewrite recursive_partition_equiv'.
    rewrite weight_0 by auto; autorewrite with zsimplify_fast.
    reflexivity.
  Qed.

  Lemma length_recursive_partition n : forall i x,
      length (recursive_partition n i x) = n.
  Proof using Type.
    induction n; cbn [recursive_partition]; [reflexivity | ].
    intros; distr_length; auto.
  Qed.

  Lemma drop_high_to_length_partition n m x :
    (n <= m)%nat ->
    Positional.drop_high_to_length n (partition m x) = partition n x.
  Proof using Type.
    cbv [Positional.drop_high_to_length partition]; intros.
    autorewrite with push_firstn.
    rewrite Nat.min_l by lia.
    reflexivity.
  Qed.

  Lemma partition_0 n : partition n 0 = Positional.zeros n.
  Proof.
    cbv [partition].
    erewrite Positional.zeros_ext_map with (p:=seq 0 n) by distr_length.
    apply map_ext; intros.
    autorewrite with zsimplify; reflexivity.
  Qed.

End PartitionProofs.
#[global]
Hint Rewrite length_partition length_recursive_partition : distr_length.
#[global]
Hint Rewrite eval_partition using (solve [auto; distr_length]) : push_eval.
#[global]
Hint Rewrite nth_default_partition_full : push_nth_default.


(* A category is very much like a graph. It has vertices
   named objects and vertices named arrows. Each arrow goes
   from an object to an object (possibly the same!). *)
Record Cat (obj: Type) (arr: obj -> obj -> Type) : Type :=
  MkCat {
    (* For each object, there is an arrow called `id` which
       goes from the object to itself. *)
    id: forall {o: obj}, arr o o;

    (* Given an arrow `f` from object `a` to `b` and an arrow
       `g` from `b` to `c`. We can compose these arrow. The
       result is an arrow from `a` to `c`. *)
    compose: forall {a b c: obj}, arr a b -> arr b c -> arr a c;

    (* Here comes some properties of `id` and `compose` *)

    (* For any arrow `f`, compose id f = f *)
    neutralLeft:   forall {a b: obj} (f: arr a b), compose id f = f;

    (* For any arrow `f`, compose f id = f  *)
    neutralRight:  forall {a b: obj} (f: arr a b), compose f id = f;

    (* For any arrows `f`, `g` and `h`,
        composing f with g, and then the result with h
       gives exatctly the same result as
        composing f with the result of the composition of g and h

       Which means, like string concatenation than we can commpose
       the way we preserve the order of each element in the sequence. *)
    associativity: forall {a b c d: obj} (f: arr a b) (g: arr b c) (h: arr c d),
                     compose (compose f g) h = compose f (compose g h);
  }.

Arguments MkCat {_} {_}.

(* `LE n m` encode the property that `n ≤ m`
    i.e. `n` is less or equal to `m` *)
Inductive LE : nat -> nat -> Prop :=
    LERefl: forall {o: nat}, LE o o
  | LENext: forall {a b: nat}, LE a b -> LE a (S b)
.

(* Taking naturals as objects and `LE` as arrows,
   this actually forms a category! *)
Definition natPoset: Cat nat LE := ???
.


Require Export Coq.Lists.List.
Require Export Permutation.
From sorting Require Export Utils.

Inductive sorted: list nat -> Prop :=
  | sorted_nil : sorted nil
  | sorted_1 : forall (x : nat), sorted (x :: nil)
  | sorted_cons : forall (x y : nat) (l : list nat),
      x <= y -> sorted (y :: l) -> sorted (x :: y :: l).

Definition is_a_sorting_algorithm (f: list nat -> list nat) :=
  forall (al : list nat), Permutation al (f al) /\ sorted (f al).


Require Import Matrix.
From Coq Require Import Lia.
(*
  The following constant definitions correspond to Hamming Code being proven.
  Providing other values should allow this .v file to prove codes beyond the
  Hamming(7,4)
*)
(* Hamming(7,4) values *)
Definition H74_WS : nat := 4. (* Word Size *)
Definition H74_CS : nat := 7. (* Code Size *)
Definition H74_CGM : Matrix 4 7 := (* Code Generator Matrix *)
  list2D_to_matrix
  ([
    [1;1;1;0;0;0;0];
    [1;0;0;1;1;0;0];
    [0;1;0;1;0;1;0];
    [1;1;0;1;0;0;1]
  ]).
Definition H74_PCM : Matrix 7 3 := (* Parity Check Matrix *)
  list2D_to_matrix
  ([
    [1;0;0];
    [0;1;0];
    [1;1;0];
    [0;0;1];
    [1;0;1];
    [0;1;1];
    [1;1;1]
  ]).
Definition H74_DCM : Matrix 7 4 := (* Decoder Matrix *)
  list2D_to_matrix
  ([
    [0;0;0;0];
    [0;0;0;0];
    [1;0;0;0];
    [0;0;0;0];
    [0;1;0;0];
    [0;0;1;0];
    [0;0;0;1]
  ]).
(* End Hamming(7,4) Values *)

(* Constant assignment (here to Hamming(7,4)) *)
Definition WS : nat := H74_WS.
Definition CS : nat := H74_CS.
Definition SS : nat := CS - WS. (* Syndrome (parity bit vector) Size *)
Definition Max_Word : nat := 2 ^ WS.
Definition Code_Generator_Matrix : Matrix WS CS := H74_CGM.
Definition Parity_Check_Matrix : Matrix CS SS := H74_PCM.
Definition Decoder_Matrix : Matrix CS WS := H74_DCM.
Check Code_Generator_Matrix.
Check Parity_Check_Matrix.
Check Decoder_Matrix.

Notation Word := (Matrix 1 WS).
Definition WF_Word (W : Word) : Prop :=
  WF_Matrix W /\ forall y, W 1 y = 0 \/ W 1 y = 1.

Notation Code := (Matrix 1 CS).
Definition WF_Code (C : Code) : Prop :=
  WF_Matrix C /\ forall y, C 1 y = 0 \/ C 1 y = 1.

Notation Synd := (Matrix 1 SS).
Definition WF_Synd (S : Synd) : Prop :=
  WF_Matrix S /\ forall y, S 1 y = 0 \/ S 1 y = 1.

Ltac mat_solve x y :=
  do 8 (try destruct x; try destruct y; simpl; trivial; try lia).

Lemma CGM_WF : WF_Matrix Code_Generator_Matrix.
Proof. unfold WF_Matrix. intros x y [H|H]; compute in H; mat_solve x y. Qed.

Lemma PCM_WF : WF_Matrix Parity_Check_Matrix.
Proof. unfold WF_Matrix. intros x y [H|H]; compute in H; mat_solve x y. Qed.

Lemma DCM_WF : WF_Matrix Decoder_Matrix.
Proof. unfold WF_Matrix. intros x y [H|H]; compute in H; mat_solve x y. Qed.

(* Basic Binary definitions and operators (from Basics.v and Induction.v) *)

Inductive bin : Type :=
  | Z
  | B0 (n : bin)
  | B1 (n : bin).

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

Fixpoint bin_to_nat (m:bin) : nat :=
  match m with
  | Z     => 0
  | B0 m' => 2 * (bin_to_nat m')
  | B1 m' => 1 + 2 * (bin_to_nat m')
  end.

Fixpoint nat_to_bin (n:nat) : bin :=
  match n with
  | O      => Z
  | S (n') => incr(nat_to_bin n')
  end.

(* digify inputs a binary number and nat and outputs an n bit binary number
   truncates most significant bits or adds trailing zeroes *)
Fixpoint digify (b : bin) (n : nat) : bin :=
  match n with
  | O      => Z
  | S (n') => match b with
              | Z     => B0 (digify (B0 Z) n')
              | B0 b' => B0 (digify b' n')
              | B1 b' => B1 (digify b' n')
              end
  end.

Example dig_test1 :
  (digify Z 4) = B0 (B0 (B0 (B0 Z))).
Proof. reflexivity. Qed.

Example dig_test2 :
  (digify (B1 Z) 4) = B1 (B0 (B0 (B0 Z))).
Proof. reflexivity. Qed.

Example dig_test3 :
  (digify (B1 Z) 0) =  Z.
Proof. reflexivity. Qed.

Example dig_test4 :
  (digify (B0 (B1 (B0 (B1 Z)))) 3) =  B0 (B1 (B0 Z)).
Proof. reflexivity. Qed.

Example dig_test5 :
  (digify (B1 (B1 (B0 (B1 Z)))) 4) =  B1 (B1 (B0 (B1 Z))).
Proof. reflexivity. Qed.

(* takes a binary number and outputs a nat list with its digits *)
Fixpoint bin_to_list (b : bin) : list(nat) :=
  match b with
  | Z     => []
  | B0 b' => 0 :: (bin_to_list b')
  | B1 b' => 1 :: (bin_to_list b')
  end.

Example btl_test1 :
  bin_to_list (B0 (B1 Z)) = [0 ; 1].
Proof. reflexivity. Qed.

Example btl_test2 :
  bin_to_list Z = [].
Proof. reflexivity. Qed.

Example btl_test3 :
  bin_to_list (B1 (B1 (B0 (B1 Z)))) = [1 ; 1 ; 0 ; 1].
Proof. reflexivity. Qed.

(* transforms a nat into a WS-digit binary word vector *)
Definition nat_to_word (n : nat) : Word :=
  list2D_to_matrix [(bin_to_list (digify (nat_to_bin n) WS))].

(* All WS-bit binary nats make well-formed words *)
Lemma nat_to_word_WF : forall n,
  n < Max_Word -> WF_Word (nat_to_word n).
Proof. intros n Hn. compute in Hn. unfold WF_Word. split.
  - unfold WF_Matrix. intros x y [H|H]; compute in H;
    do 16 (try destruct n; mat_solve x y).
  - intros x. left. mat_solve x y.
Qed.

Definition W1 : Word :=
  fun x y =>
  match (x, y) with
  | (0, 0) => 0
  | (0, 1) => 1
  | (0, 2) => 1
  | (0, 3) => 0
  | _ => 0
  end.

Definition W1' : Word :=
  nat_to_word 6.

Lemma ntw_test1 : W1 = W1'.
Proof.
  unfold W1'. prep_matrix_equality. mat_solve x y.
Qed.

Definition W2 : Word :=
  fun x y =>
  match (x, y) with
  | (0, 0) => 1
  | (0, 1) => 1
  | (0, 2) => 1
  | (0, 3) => 1
  | _ => 0
  end.

Definition W2' : Word :=
  nat_to_word 15.

Lemma ntw_test2 : W2 = W2'.
Proof.
  unfold W2'. prep_matrix_equality. mat_solve x y.
Qed.

(* Generates a code from an input word *)
Definition word_to_code (W : Word) : Code :=
  parity (Mmult W Code_Generator_Matrix).

(* Codes generated from well-formed Words are well-formed
   NOTE: This proof depends on an admitted proof in Matrix.v
    This lemma turned out to be unneeded for formally proving the
    Hamming(7,4) code, but because it was part of what I explored I
    am leaving it in as an extra informally proven fact. *)
Lemma word_to_code_WF : forall W,
  WF_Word W ->
  WF_Code (word_to_code W).
Proof.
  intros W [H1 H2]. unfold WF_Code. split.
  - unfold word_to_code. apply WF_parity. apply WF_mult. apply H1. apply CGM_WF.
  - intros y. unfold word_to_code.
    assert (H: forall {m n} (A : Matrix m n), parity A m n = 0 \/ parity A m n = 1).
    { intros m n A. apply bin_parity. }
    apply H with (n := y).
Qed. (* DoAP m2_01 *)

(* combines above functions to form a code directly from an input nat n *)
Definition nat_to_code (n : nat) : Code :=
  word_to_code (nat_to_word n).

Definition Code_0 : Code :=
  list2D_to_matrix
  ([[0;0;0;0;0;0;0]]).

Definition Code_0' : Code :=
  nat_to_code 0.

Lemma ntc_test0 :
  Code_0 = Code_0'.
Proof.
  unfold Code_0'. prep_matrix_equality. mat_solve x y.
Qed.

Definition Code_12 : Code :=
  list2D_to_matrix
  ([[1;0;0;0;0;1;1]]).

Definition Code_12' : Code :=
  nat_to_code 12.

Lemma ntc_test12 :
  Code_12 = Code_12'.
Proof.
  unfold Code_12'. prep_matrix_equality. mat_solve x y.
Qed.

(* Generates a Syndrome vector from a given Code.
   This will be used to error-check the Code.*)
Definition code_to_synd (C : Code) : Synd :=
  parity (Mmult C Parity_Check_Matrix).
(* Synds generated from well-formed Codes are well-formed
   NOTE: Dependent on Admitted Proof. See word_to_code_WF above *)
Lemma code_to_synd_WF : forall C,
  WF_Code C -> WF_Synd (code_to_synd C).
Proof.
  intros C [H1 H2]. unfold WF_Synd. split.
  - unfold code_to_synd. apply WF_parity. apply WF_mult. apply H1. apply PCM_WF.
  - intros y.
    assert (H: forall {m n} (A : Matrix m n), parity A m n = 0 \/ parity A m n = 1).
    { intros m n A. apply bin_parity. }
    apply H with (n := y).
Qed. (* DoAP m2_01 *)

(* converts Vector of length n to binary (requires an input bin Z to start) *)
Fixpoint vect_to_bin (n : nat) (V : Vector n) (b : bin) : bin :=
  match n with
  | O      => b
  | S (n') => match (V 0 n') with
              | 1 => (vect_to_bin n' V (B1 b))
              | _ => (vect_to_bin n' V (B0 b))
              end
  end.

(* Determines the erroneous bit if there is a one-bit error
   + returns 0 if there are no errors
   + returns n if the nth bit is erroneous (matrix index n-1) *)
Definition bit_err (S : Synd) : nat :=
  bin_to_nat (vect_to_bin SS S Z).

Example be0 : bit_err Zero = 0.
Proof. reflexivity. Qed.

Example be5 : bit_err (list2D_to_matrix([[1;0;1]])) = 5.
Proof. reflexivity. Qed.

Example be6 : bit_err (list2D_to_matrix([[0;1;1]])) = 6.
Proof. reflexivity. Qed.

(* Flips the nth bit of input code C
   + returns C unchanged if bit 0 is to be flipped
   + returns C with nth bit (index n-1) flipped otherwise
   NOTE: used to simulate errors AND correct them *)
Definition flip_bit_at_n (C : Code) (n : nat) :=
  match n with
  | O      => C
  | S (n') =>
    fun x y => if (y =? n') && (x =? 0) then if (C x y) =? 1 then 0 else 1
      else if (C x y) =? 1 then 1 else 0
  end.

Definition t_flip_0s_4 : Code :=
  list2D_to_matrix
  ([
    [0;0;0;1;0;0;0]
  ]).

Example test_flip_null_4 :
  t_flip_0s_4 = flip_bit_at_n Zero 4.
Proof. prep_matrix_equality. mat_solve x y. Qed.

Definition t_flip_1s : Code :=
  list2D_to_matrix
  ([
    [1;1;1;1;1;1;1]
  ]).

Definition t_flip_1s_6 : Code :=
  list2D_to_matrix
  ([
    [1;1;1;1;1;0;1]
  ]).

Example test_flip_1s_6 :
  t_flip_1s_6 = flip_bit_at_n t_flip_1s 6.
Proof. unfold t_flip_1s_6. simpl. prep_matrix_equality. mat_solve x y. Qed.

(* flipping none of the bits yields the input code *)
Lemma flip_0_refl : forall C,
  C = flip_bit_at_n C 0.
Proof. reflexivity. Qed.

(* takes a code, corrects one-bit error by flipping the nth bit
   + nth bit found by generating syndrome vector of C
   + returns C unchanged if no error is detected *)
Definition bit_err_fix (C : Code) : Code :=
  flip_bit_at_n C (bit_err (code_to_synd C)).

(* decodes a word from a code *)
Definition code_to_word (C : Code) : Word :=
  (Mmult C Decoder_Matrix).

Example nat_code_word1 :
  code_to_word (nat_to_code 1) = list2D_to_matrix ([[1;0;0;0]]).
Proof. prep_matrix_equality. mat_solve x y. Qed.

(* Generating a code from a nat and decoding it to a word yields the
   same code as the one generated directly from the nat *)
Lemma nat_code_word : forall n,
  n < Max_Word ->
  code_to_word (nat_to_code n) = nat_to_word n.
Proof.
  intros n H. compute in H.
  do 16 (destruct n; try prep_matrix_equality; mat_solve x y; try lia).
Qed.

(* converts a word back to a nat *)
Definition word_to_nat (W : Word) : nat :=
  bin_to_nat (vect_to_bin WS W Z).

(* This Lemma shows that all 16 nats in our word size
   can be encoded and decoded accurately *)
Lemma nat_code_nat : forall n,
   n < Max_Word ->
   word_to_nat (code_to_word (nat_to_code n)) = n.
Proof.
   intros n H. compute in H. do 16 (destruct n; auto; try lia).
Qed.

(* 1-bit errors in codes can be simulated by the flip_bit_at_n function.
   A Code is 1-bit error safe (bit_err_safe) if the code can recover from
   any one of its bits being flipped via bit_err_fix *)
Definition bit_err_safe (C : Code) : Prop :=
  forall (i : nat),
  i < 8 -> bit_err_fix (flip_bit_at_n C i) = C.

(* tactic to check all possible one-bit errors for showing bit_err_safe holds *)
Ltac check_code_safe i x y :=
  do 8 (destruct i; only 1: mat_solve x y; try lia).

(* Example case showing the code generated from 0 is 1-bit error safe *)
Lemma code0_safe : bit_err_safe (nat_to_code 0).
Proof.
  unfold bit_err_safe. intros i H. prep_matrix_equality.
  check_code_safe i x y.
Qed.

(*
  -- Big Bad Proof --
  The following proof takes about 75 seconds on my machine. It verifies,
  for nat n < 16, that the code generated by nat_to_code n is 1-bit error
  safe. bit_err_safe is the Prop that holds iff a code can be returned to
  its original state via bit_err_fix for any 1-bit error. The proof shows
  the Hamming(7,4) code holds for all cases in its scope. It can detect
  and correct any 1-bit error on any 4-bit unsigned integer.
*)
Lemma Hamming74_Formal_Proof : forall n,
  n < 16 ->
  bit_err_safe (nat_to_code n).
Proof.
  unfold bit_err_safe. intros n Hn i Hi.
  prep_matrix_equality.
  do 16 (destruct n; only 1: check_code_safe i x y; try lia).
Qed.

(*
  Given the lemmas dependent on the admitted proof are NOT used in any
  of the components of this last proof, it is safe to say that the
  Hamming(7,4) code has hereby been formally proven in the coq proof assistant.

  This was the primary goal of my project, and I am very glad to have been
  able to show this. I attempted to design my functions in a way that would
  scale to other Hamming codes. Were I to revisit this project I would continue
  by proving the Hamming(7,4) can detect (but not correct) any 2 bit error with
  an extra 8th parity bit, before examining differently sized Hamming codes.
*)


Set Implicit Arguments.
Require Import TLC.LibTactics.
Require Import TLC.LibInt.
Require Import ZArith.
Open Scope Z_scope.
Require Import Psatz.

(************************************************************)
(* A preorder on Z*Z *)

Definition ZZle : Z * Z -> Z * Z -> Prop :=
  fun '(m,n) '(m', n') => m <= m' /\ n <= n'.

(************************************************************)
(* * max *)

Hint Resolve Z.le_max_l : zarith.
Hint Resolve Z.le_max_r : zarith.

Lemma Zmax_ub_l : forall a b c,
  c <= a ->
  c <= Z.max a b.
Proof. intros. lia. Qed.

Lemma Zmax_ub_r : forall a b c,
  c <= b ->
  c <= Z.max a b.
Proof. intros. lia. Qed.

Hint Resolve Zmax_ub_l Zmax_ub_r : zarith.

Lemma Zmax_0_l :
  forall x, 0 <= x -> Z.max 0 x = x.
Proof. intros. lia. Qed.

Lemma Zmax_0_r :
  forall x, 0 <= x -> Z.max x 0 = x.
Proof. intros. lia. Qed.

(************************************************************)
(* * quotient *)

Lemma Zquot_mul_2 : forall x,
  0 <= x ->
  x - 1 <= 2 * (x ÷ 2) <= x.
Proof.
  intros x Hx. rewrite <-Zquot2_quot. set (half := Z.quot2 x).
  destruct (Zeven_odd_dec x) as [H|H].
  - rewrite (Zeven_quot2 x); subst half; auto with zarith.
  - rewrite (Zodd_quot2 x); subst half; auto with zarith.
Qed.

(************************************************************)
(* * Pow function *)

Lemma pow_ge_1 : forall k n,
  0 < k ->
  0 <= n ->
  1 <= k ^ n.
Proof.
  intros a b A B.
  rewrite <-(Z.pow_0_r a).
  apply Z.pow_le_mono_r; auto.
Qed.

Hint Resolve pow_ge_1 : zarith.

Lemma pow2_ge_1 : forall n,
  0 <= n ->
  1 <= 2 ^ n.
Proof using.
  auto with zarith.
Qed.

Hint Resolve pow2_ge_1 : zarith.

Lemma pow_succ : forall k n,
  0 < k ->
  0 <= n ->
  k ^ (n + 1) = k * k ^ n.
Proof using.
  intros.
  math_rewrite (n+1 = Z.succ n).
  rewrite Z.pow_succ_r; auto.
Qed.

Lemma pow2_succ : forall n,
  0 <= n ->
  2 ^ (n+1) = 2 * 2^n.
Proof using.
  intros.
  rewrite pow_succ; auto with zarith.
Qed.

Lemma pow_succ_quot : forall k n,
  0 < k ->
  0 <= n ->
  k ^ (n+1) ÷ k = k ^ n.
Proof using.
  intros. rewrite pow_succ, Z.mul_comm, Z.quot_mul; auto with zarith.
Qed.

(* A tactic that helps dealing with goals containing "b^m" for multiple m *)
Require Import TLC.LibList.

Ltac subst_eq_boxer_list l rewrite_tac :=
  match l with
  | nil => idtac
  | (@boxer _ ?p) :: ?Hs =>
    match p with
      (?tm, ?Htm) =>
      rewrite_tac Htm; clear Htm; clear tm;
      subst_eq_boxer_list Hs rewrite_tac
    end
  end.

(* Develop occurences of (b ^ m) in H into (b ^ (m - min_e) * b ^ min_e).
   (and try to simplify/compute b^(m - min_e)).
 *)
Ltac rew_pow_develop b m min_e H :=
  let m_eq_plusminus := fresh in
  assert (m = min_e + (m - min_e)) as m_eq_plusminus
      by (rewrite Zplus_minus; reflexivity);
  rewrite m_eq_plusminus in H; clear m_eq_plusminus;
  rewrite (Z.pow_add_r b min_e (m - min_e)) in H; [
    rewrite Z.mul_comm in H;
    let tm' := fresh "tm'" in
    let H' := fresh "H'" in
    remember (b ^ (m - min_e)) as tm' eqn:H' in H;
    let e := fresh "e" in
    evar (e: int);
    let Heqe := fresh in
    assert (e = m - min_e) as Heqe
        by (ring_simplify; subst e; reflexivity);
    rewrite <-Heqe in H'; clear Heqe; unfold e in H'; ring_simplify in H';
    rewrite H' in H; clear H'; clear tm'; clear e;
    try rewrite Z.mul_1_l in H
  | ring_simplify; auto with zarith ..].

Ltac rew_pow_aux_goal b min_e normalized_acc :=
  match goal with
  | |- context [ b ^ ?m ] =>
    let tm := fresh "tm" in
    let Heqtm := fresh "Heqtm" in
    remember (b ^ m) as tm eqn:Heqtm in |- *;
    rew_pow_develop b m min_e Heqtm; [
      rew_pow_aux_goal b min_e ((boxer (tm, Heqtm)) :: normalized_acc)
    | ..]
  | _ => subst_eq_boxer_list normalized_acc ltac:(fun E => rewrite E)
  end.

Ltac rew_pow_aux_in b min_e H normalized_acc :=
  match type of H with
  | context [ b ^ ?m ] =>
    let tm := fresh "tm" in
    let Heqtm := fresh "Heqtm" in
    remember (b ^ m) as tm eqn:Heqtm in H;
    rew_pow_develop b m min_e Heqtm; [
      rew_pow_aux_in b min_e H ((boxer (tm, Heqtm)) :: normalized_acc)
    | ..]
  | _ => subst_eq_boxer_list normalized_acc ltac:(fun E => rewrite E in H)
  end.

Tactic Notation "rew_pow" constr(b) constr(min_e) :=
  rew_pow_aux_goal b min_e (@nil Boxer).
Tactic Notation "rew_pow" "~" constr(b) constr(min_e) :=
  rew_pow_aux_goal b min_e (@nil Boxer); auto_tilde.
Tactic Notation "rew_pow" "*" constr(b) constr(min_e) :=
  rew_pow_aux_goal b min_e (@nil Boxer); auto_star.
Tactic Notation "rew_pow" constr(b) constr(min_e) "in" hyp(H) :=
  rew_pow_aux_in b min_e H (@nil Boxer).
Tactic Notation "rew_pow" "~" constr(b) constr(min_e) "in" hyp(H) :=
  rew_pow_aux_in b min_e H (@nil Boxer); auto_tilde.
Tactic Notation "rew_pow" "*" constr(b) constr(min_e) "in" hyp(H) :=
  rew_pow_aux_in b min_e H (@nil Boxer); auto_star.

(* Test *)
Axiom P : int -> Prop.
Goal forall n, P (1 + 2 ^ (n + 3) + 2 ^ n + 2 ^ (n+1)).
Proof.
  intros.
  skip_asserts H: (3 = 2 ^ (n+3)). rew_pow 2 n in H.
  rew_pow 2 n.
Admitted.

(* ---------------------------------------------------------------------------- *)

(* Base 2 logarithm. *)

Lemma Zlog2_step : forall x,
  2 <= x ->
  1 + Z.log2 (x÷2) = Z.log2 x.
Proof.
  admit. (* TODO: prove from the log2_step in LibNatExtra? *)
Qed.


Require Import List Cpdt.CpdtTactics.

Set Implicit Arguments.
Set Asymmetric Patterns.

Print unit.
Print True.

Section Propositional.
  Variables P Q R : Prop.

  Theorem obvious : True.
    apply I.
  Qed.

  Theorem obvious' : True.
    constructor.
  Qed.

  Print False.

  Theorem False_imp : False -> 2 + 2 = 5.
    destruct 1.
  Qed.

  Theorem arith_neq : 2 + 2 = 5 -> 9 + 9 = 835.
    intro.
    elimtype False.
    crush.
  Qed.

  Print not.

  Theorem arith_neq' : ~ (2 + 2 = 5).
    unfold not.
    crush.
  Qed.

  Print and.
  Print prod.

  Theorem and_comm : P /\ Q -> Q /\ P.
    destruct 1.
    split; assumption.
  Qed.

  Print or.
  Print sum.

  Theorem or_comm : P \/ Q -> Q \/ P.
    destruct 1.
    right; assumption.
    left; assumption.
  Qed.

  Theorem or_comm' : P \/ Q -> Q \/ P.
    tauto.
  Qed.

  Theorem arith_comm : forall ls1 ls2 : list nat,
      length ls1 = length ls2 \/ length ls1 + length ls2 = 6
      -> length (ls1 ++ ls2) = 6 \/ length ls1 = length ls2.
    intuition.
    rewrite app_length.
    tauto.
  Qed.

  Theorem arith_comm' : forall ls1 ls2 : list nat,
      length ls1 = length ls2 \/ length ls1 + length ls2 = 6
      -> length (ls1 ++ ls2) = 6 \/ length ls1 = length ls2.
    Hint Rewrite app_length.
    crush.
  Qed.
End Propositional.

Print ex.

Theorem exist1 : exists x : nat, x + 1 = 2.
  exists 1.
  reflexivity.
Qed.

Theorem exist2 : forall n m : nat, (exists x : nat, n + x = m) -> n <= m.
  destruct 1.
  crush.
Qed.

Inductive isZero : nat -> Prop :=
| IsZero : isZero 0.

Theorem isZero_zero : isZero 0.
  constructor.
Qed.

Print eq.

Theorem isZero_plus : forall n m : nat, isZero m -> n + m = n.
  destruct 1.
  crush.
Qed.

Theorem isZero_contra : isZero 1 -> False.
  destruct 1.
  Undo.
  inversion 1.
Qed.

Theorem isZero_contra' : isZero 1 -> 2 + 2 = 5.
  destruct 1.
Abort.

Check isZero_ind.

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

Theorem even_0 : even 0.
  constructor.
Qed.

Theorem even_4 : even 4.
  repeat constructor.
Qed.

Hint Constructors even.

Theorem even_4' : even 4.
  auto.
Qed.

Theorem even_plus : forall n m, even n -> even m -> even (n + m).
  induction n; crush.
  inversion H. simpl.
  constructor.
  Restart.
  induction 1. crush.
  intros. simpl. constructor. crush.
  Restart.
  induction 1; crush.
Qed.

Theorem even_contra : forall n, even (S (n + n)) -> False.
  induction 1.
Abort.

Lemma even_contra' : forall n', even n' -> forall n, n' = S (n + n) -> False.
  induction 1; crush.
  destruct n; destruct n0; crush.
  SearchRewrite (_ + S _).
  rewrite <- plus_n_Sm in H0.
  apply IHeven with n0. assumption.
  Restart.
  Hint Rewrite <- plus_n_Sm.
  induction 1; crush;
    match goal with
    | [H : S ?N = ?N0 + ?N0 |- _ ] => destruct N; destruct N0
    end;
    crush.
Qed.

Theorem even_contra : forall n, even (S (n + n)) -> False.
  intros; eapply even_contra'; eauto.
Qed.