(* Write the function that corresponsd to the polynomial 2 * x^2 + 3 * x + 3 on
   relative integers, using lambda abstraction and the functions Zplus and
   Zmult provided in the ZArith library of Coq. Compute the value of this
   function on integers 2, 3, 4.*)

Require Import ZArith.

Open Scope Z_scope.

Definition Z_poly (x:Z) : Z :=
  (Zplus (Zplus (Zmult 2 (Zmult x x)) (Zmult 3 x)) 3).

Eval compute in Z_poly.
Eval compute in (Z_poly 2).
Eval compute in (Z_poly 3).
Eval compute in (Z_poly 4).


(** 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 (y : natural) (z : natural) (x : natural) : natural :=
  mult z (plus y (Succ x)).


Set Warnings "-notation-overridden-parsing".
Add LoadPath "/Users/lubis/Documents/study/software_foundations".
Require Export Poly.
Require Export Lists.

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

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

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

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

(* Page 93 Exercise *)

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

(* Exercise ends *)

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

(* Page 94 Exercise *)

Theorem rev_exercise: forall l1 l2: list nat,
  l1 = rev l2 -> l2 = rev l1.
Proof.
  intros l1 l2 eq1. rewrite -> eq1.
  symmetry. apply rev_involutive.
Qed.

(* Exercise ends *)

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

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

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

(* Page 95 Exercise *)

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

(* Exercise Ends *)

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

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

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

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

(* Page 97 Exercise *)

Example injection_ex3: forall (X: Type) (x y z: X) (l j: list X),
  x :: y :: l = z :: j ->
  y :: l = x :: j ->
  x = y.
Proof.
  intros X x y z l j H1 H2. injection H2.
  intros H2a. intros H2b.
  symmetry. apply H2b.
Qed.

(* Exercise Ends *)

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

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

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

(* Page 98 Exercise *)

Example discriminate_ex3:
  forall (X: Type) (x y z: X) (l j: list X),
  x :: y :: l = [] -> x = z.
Proof.
  intros X x y z l j contra. discriminate contra.
Qed.

(* Exercise ends *)

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

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

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

Theorem plus_n_n_injective:
  forall n m: nat, n + n = m + m -> n = m.
Proof.
  intros n. induction n as [| n'].
  - simpl. intros m. destruct m as [| m'].
    + reflexivity.
    + discriminate.
  - intros m. destruct m as [| m'].
    + discriminate.
    + intros eq.
      rewrite <- plus_n_Sm in eq. rewrite <- plus_n_Sm in eq.
      apply S_injective in eq.
      simpl in eq. apply S_injective in eq.
      apply IHn' in eq.
      rewrite eq. reflexivity.
Qed.

Theorem double_injective_FAILED:
  forall n m: nat, double n = double m -> n = m.
Proof.
  intros n m. induction n as [| n'].
  - simpl. intros eq. destruct m as [| m'] eqn:E.
    + reflexivity.
    + discriminate eq.
  - intros eq. destruct m as [| m'] eqn:E.
    + discriminate eq.
    + apply f_equal. Abort.

Theorem double_injective:
  forall n m: nat, double n = double m -> n = m.
Proof.
  intros n. induction n as [| n'].
  - simpl. intros m. destruct m as [| m'] eqn:E.
    + reflexivity.
    + discriminate.
  - simpl.
    intros m eq.
    destruct m as [| m'] eqn:E.
    + simpl. discriminate.
    + apply f_equal. apply IHn'. simpl in eq. injection eq.
      intros H. apply H.
Qed.

(* Page 102 Exercise *)

Theorem eqb_true: forall n m: nat,
  n =? m = true -> n = m.
Proof.
  intros n. induction n as [| n' IHn'].
  - intros m. destruct m as [| m'].
    + reflexivity.
    + discriminate.
  - intros m. simpl. destruct m as [| m'].
    + discriminate.
    + intros eq. apply IHn' in eq. apply f_equal, eq.
Qed.

(* Exercise Ends *)

Theorem double_injective_take2_FAILED:
  forall n m: nat, double n = double m -> n = m.
Proof.
  intros n m. induction m as [| m'].
  - simpl. intros eq. destruct n as [| n'] eqn:E.
    + reflexivity.
    + discriminate eq.
  - intros eq. destruct n as [| n'] eqn:E.
    + discriminate.
    + apply f_equal.
Abort.

Theorem double_injective_take2:
  forall n m: nat, double n = double m -> n = m.
Proof.
  intros n m.
  generalize dependent n.
  induction m as [| m' IHm'].
  - simpl. intros n eq. destruct n as [| n'] eqn:E.
    + reflexivity.
    + discriminate.
  - simpl. intros n eq. destruct n as [| n'] eqn:E.
    + discriminate.
    + apply f_equal, IHm'.
      simpl in eq. injection eq.
      intros H. apply H.
Qed.

(* Page 104 Exercise *)

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

(* Exercise Ends *)

Definition square n := n * n.

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

Definition foo (x: nat) := 5.

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

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

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

(* Page 107 Exercise *)

Lemma combine_split_lemma:
  forall (X Y: Type) (p: X*Y) (l1 l2: list (X*Y)),
  l1 = l2 -> p :: l1 = p :: l2.
Proof.
  intros X Y p l1 l2 eq.
  inversion eq. reflexivity.
Qed.

Theorem combine_split:
  forall (X Y: Type) (l: list (X*Y)) l1 l2,
  split l = (l1,l2) -> combine l1 l2 = l.
Proof.
  intros X Y. induction l as [| p l' IHl'].
  - intros l1 l2. simpl. intros eq. inversion eq. reflexivity.
  - intros l1 l2. simpl. destruct p. destruct (split l').
    destruct l1 as [| x1 l1'] eqn:E1.
    + intros eq1. inversion eq1.
    + destruct l2 as [| x2 l2'] eqn:E2.
        intros eq1. inversion eq1.
        intros eq1. inversion eq1. simpl.
        apply combine_split_lemma. apply IHl'.
        rewrite H1. rewrite H3. reflexivity.
Qed.

(* Exercise Ends *)

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

Theorem sillyfun1_odd_FAILED:
  forall n: nat, sillyfun1 n = true -> oddb n = true.
Proof.
  intros n eq. unfold sillyfun1 in eq.
  destruct (n =? 3).
Abort.

Theorem sillyfun1_odd: forall n: nat,
  sillyfun1 n = true -> oddb n = true.
Proof.
  intros n eq. unfold sillyfun1 in eq.
  destruct (n =? 3) eqn:Heqe3.
  - apply eqb_true in Heqe3. rewrite -> Heqe3. reflexivity.
  - destruct (n =? 5) eqn:Heqe5.
    + apply eqb_true in Heqe5. rewrite -> Heqe5. reflexivity.
    + discriminate.
Qed.

(* Page 109 Exercise *)

Theorem bool_fn_applied_thrice:
  forall (f: bool -> bool) (b: bool),
  f (f (f b)) = f b.
Proof.
  intros f b. destruct b eqn:eb.
  - destruct (f true) eqn:ftrue.
    + rewrite -> ftrue. rewrite -> ftrue. reflexivity.
    + destruct (f false) eqn:ffalse.
      * rewrite -> ftrue. reflexivity.
      * rewrite -> ffalse. reflexivity.
  - destruct (f false) eqn:ffalse.
    + destruct (f true) eqn:ftrue.
      * rewrite -> ftrue. reflexivity.
      * rewrite -> ffalse. reflexivity.
    + rewrite -> ffalse. rewrite -> ffalse.
      reflexivity.
Qed.

(* Exercise Ends *)

(* Page 110 Exercise *)

Theorem eqb_sym:
  forall n m: nat, (n =? m) = (m =? n).
Proof.
  intros n. induction n as [| n' IHn'].
  - intros m. destruct m as [| m'].
    + reflexivity.
    + reflexivity.
  - intros m. destruct m as [| m'].
    + reflexivity.
    + simpl. apply IHn'.
Qed.

Theorem eqb_trans:
  forall n m p,
  n =? m = true -> m =? p = true -> n =? p = true.
Proof.
  intros n m p eq1 eq2.
  apply eqb_true in eq1. apply eqb_true in eq2.
  rewrite -> eq1. rewrite -> eq2. rewrite <- eqb_refl.
  reflexivity.
Qed.

Theorem split_combine:
  forall (X Y: Type) (l1: list X) (l2: list Y),
  length l1 = length l2 ->
  split (combine l1 l2) = (l1, l2).
Proof.
  intros X Y. intros l1.
  induction l1 as [| x1 l1' IHl1'].
  - intros l2. destruct l2 as [| x2 l2].
    + reflexivity.
    + discriminate.
  - intros l2. destruct l2 as [| x2 l2].
    + discriminate.
    + simpl.
      intros eq. inversion eq. apply IHl1' in H0.
      rewrite -> H0. reflexivity.
Qed.

Theorem filter_exercise:
  forall (X: Type) (test: X -> bool) (x: X) (l lf: list X),
  filter test l = x :: lf -> test x = true.
Proof.
  intros X test x.
  induction l as [| n l' IHl'].
  - intros lf. discriminate.
  - intros lf. destruct (test n) eqn:En.
    + simpl. rewrite -> En.
      intros eq. inversion eq.
      rewrite -> H0 in En. apply En.
    + simpl. rewrite -> En.
      intros eq. apply IHl' in eq.
      apply eq.
Qed.

Fixpoint forallb {X: Type} (test: X -> bool) (l: list X) : bool :=
  match l with
  | [] => true
  | x :: t => if (test x) then (forallb test t) else false
  end.

Fixpoint existsb {X: Type} (test: X -> bool) (l: list X) : bool :=
  match l with
  | [] => false
  | x :: t => if (test x) then true else (existsb test t)
  end.

Example test_forallb_1 : forallb oddb [1;3;5;7;9] = true.
Proof. reflexivity. Qed.

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

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

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

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

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

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

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

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

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

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

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

Example test_existsb'_4 : existsb' evenb [] = false.
Proof. reflexivity. Qed.

Theorem existsb_existsb':
  forall (X: Type) (test: X -> bool) (l: list X),
  existsb test l = existsb' test l.
Proof.
  intros X test l.
  induction l as [| n l' IHl'].
  - simpl. unfold existsb'. reflexivity.
  - simpl. destruct (test n) eqn:En.
    + unfold existsb'. simpl. rewrite -> En.
      simpl. reflexivity.
    + rewrite -> IHl'. unfold existsb'.
      simpl. rewrite -> En. simpl. reflexivity.
Qed.

(* Exercise Ends *)


Require Import NArith.
Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq.
Require Import ssrlib.

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

Open Scope N_scope.

(** Some [N]versions of standard ssreflect operations. *)
Definition iotaN (m n:N) : seq N :=
 N.peano_rect _ (fun _=>[::]) (fun n r m=> [:: m & r (N.succ m)]) n m.

Lemma iotaN_succ x n:
 iotaN x (N.succ n) = x :: iotaN (N.succ x) n.
Proof. by rewrite /iotaN N.peano_rect_succ. Qed.

Lemma iotaN_iota x n:
 iotaN x n = map n2N (iota (N2n x) (N2n n)).
Proof.
elim/N.peano_ind: n x => //= n IH x.
rewrite N2Nat.inj_succ /= iotaN_succ N2n2N; f_equal.
by rewrite (IH (N.succ x)) N2Nat.inj_succ.
Qed.

Lemma mem_iotaN m n x:
  (x \in iotaN m n) <-> (m <= x < m+n).
Proof.
rewrite iotaN_iota; split.
 move/mapP => [y []]; rewrite mem_iota; move => [/andP[]].
 rewrite -{1 2}[y]n2N2n N2n_le -plusE -N2Nat.inj_add N2n_lt.
 by move=> H1 H2 ->; split.
move=> [H1 H2]. apply/mapP.
exists (N2n x); last by rewrite N2n2N.
rewrite mem_iota; apply/andP; split.
 by rewrite -N2n_le.
by rewrite -plusE -N2Nat.inj_add -N2n_lt.
Qed.

Definition nseqN {A} : N -> A -> seq A :=
 N.peano_rect _ (fun _=>[::]) (fun n r x=> x::r x).

Lemma nseqN_nseq {A} n (x:A) : nseqN n x = nseq (N2n n) x.
Proof.
elim/N.peano_ind: n => //= n.
by rewrite /nseqN /= N.peano_rect_succ N2Nat.inj_succ /= => ->.
Qed.

Lemma map_nseqN {A B} (f:A -> B) (x:A) n:
  [seq f i | i <- nseqN n x] = nseqN n (f x).
Proof. by rewrite nseqN_nseq map_nseq nseqN_nseq. Qed.

Fixpoint sizeN {A} (s: seq A) : N :=
 if s is x::xs then N.succ (sizeN xs) else 0.

Lemma size_sizeN {A}: forall (s: seq A),
 size s = N.to_nat (sizeN s).
Proof.
elim => //= x xs IH.
by rewrite N2Nat.inj_succ; f_equal.
Qed.

Lemma sizeN_size {A}: forall (s: seq A),
 sizeN s = N.of_nat (size s).
Proof. by move=> s; rewrite size_sizeN N2Nat.id. Qed.

Corollary sizeN_map {A B} (f: A -> B) (m: list A) :
  sizeN (map f m) = sizeN m.
Proof. by rewrite !sizeN_size size_map. Qed.

Corollary sizeN_rev {A} (m: list A) :
  sizeN (rev m) = sizeN m.
Proof. by rewrite !sizeN_size size_rev. Qed.

Corollary sizeN_app {A} (m m': list A) :
  sizeN (m ++ m') = sizeN m + sizeN m'.
Proof. by rewrite !sizeN_size size_cat Nat2N.inj_add. Qed.

Corollary sizeN_rcons {A} (m: list A) a :
  sizeN (rcons m a) = sizeN m + 1.
Proof.
rewrite !sizeN_size size_rcons -[1]/(n2N 1) -Nat2N.inj_add.
by rewrite plusE addn1.
Qed.

Lemma sizeN_iotaN m n :
  sizeN (iotaN m n) = n.
Proof. by rewrite sizeN_size iotaN_iota size_map size_iota N2n2N. Qed.

Fixpoint nthN {A} (dfl: A) (s: seq A) (n: N) : A :=
 if s is x::xs
 then if n is N0 then x else nthN dfl xs (N.pred n)
 else dfl.

Lemma nth_nthN: forall A (dfl:A) n xs,
 nth dfl xs n = nthN dfl xs (N.of_nat n).
Proof.
move=> A d; elim => [|n IH] [|x xs] //=.
by rewrite IH pospred_ofsuccnat; f_equal.
Qed.

Lemma nthN_nth: forall A (dfl:A) xs n,
 nthN dfl xs n = nth dfl xs (N.to_nat n).
Proof. by move=> A d xs n; rewrite nth_nthN N2Nat.id. Qed.

Corollary nth_rcons_last {A} (d: A) m a :
  nthN d (rcons m a) (sizeN m) = a.
Proof.
rewrite nthN_nth -size_sizeN nth_rcons.
case: (ifP _).
 move=> /ltP H; omega.
by rewrite eq_refl.
Qed.

Lemma nthN_cat {A} (d: A) m m' n :
  nthN d (m ++ m') n
  = (if n <? sizeN m then nthN d m n else nthN d m' (n - sizeN m)).
Proof.
rewrite !nthN_nth nth_cat !sizeN_size N2Nat.inj_sub /= n2N2n.
have ->: (N2n n < size m)%N = (n <? n2N (size m)).
 rewrite -{1}[size m]n2N2n.
 by apply/idP/idP; rewrite -N2n_lt -N.ltb_lt.
by rewrite minusE.
Qed.

Definition takeN {A} (n:N) : seq A -> seq A :=
 N.peano_rect _ (fun _=>[::]) (fun n r s=> if s is x::xs
                                           then x::r xs
                                           else [::]) n.

Lemma takeN_nil A: forall pos,
 takeN pos [::] = @nil A.
Proof.
elim/N.peano_ind => //=.
by move=> n IH; rewrite /takeN N.peano_rect_succ.
Qed.

Lemma takeN_0 A: forall (s: seq A),
 takeN 0 s = [::].
Proof. by move=> s; rewrite /takeN. Qed.

Lemma takeN_cons A: forall p x (xs: seq A),
 takeN (Npos p) (x::xs) = x::takeN (Npred (Npos p)) xs.
Proof.
move => p x xs.
by rewrite /takeN -N.succ_pos_pred N.peano_rect_succ N.pred_succ.
Qed.

Lemma take_takeN: forall {A} (xs: seq A) n,
 take n xs = takeN (N.of_nat n) xs.
Proof.
move=> A; elim => //.
 by move=> n; rewrite /= takeN_nil.
move=> x xs IH [|n] //.
rewrite takeN_cons /= IH; f_equal; f_equal.
by rewrite pospred_ofsuccnat.
Qed.

Lemma takeN_take: forall {A} n (xs: seq A),
 takeN n xs = take (N.to_nat n) xs.
Proof. by move=> A n xs; rewrite take_takeN N2Nat.id. Qed.

Lemma takeN_all {A} (m: list A) n :
  sizeN m <= n -> takeN n m = m.
Proof.
  revert m; elim n using N.peano_ind; clear.
  intros [ | a m ]. reflexivity. simpl. Psatz.lia.
  intros n IH m LE.
  unfold takeN. rewrite N.peano_rect_succ. fold (@takeN A n).
  destruct m as [ | a m ]. reflexivity.
  f_equal. apply IH. simpl in LE. Psatz.lia.
Qed.

Lemma takeN_map_nthN {A} x (s: seq A) n:
(n <= sizeN s) -> takeN n s = map (nthN x s) (iotaN 0 n).
Proof.
rewrite sizeN_size takeN_take iotaN_iota -map_comp.
have E: nthN x s \o n2N =1 nth x s by move=> y /=; rewrite nth_nthN.
move=> H; rewrite (eq_map E) (take_map_nth x) //=.
by rewrite size_sizeN -N2n_le sizeN_size.
Qed.

Definition dropN {A} (n:N) : seq A -> seq A :=
 N.peano_rect _ id (fun n r s=> if s is x::xs
                                then r xs
                                else [::]) n.

Lemma dropN_nil A: forall pos,
 dropN pos [::] = @nil A.
Proof.
elim/N.peano_ind => //=.
by move=> n IH; rewrite /dropN N.peano_rect_succ.
Qed.

Lemma dropN_0 A: forall (s: seq A),
 dropN 0 s = s.
Proof. by move=> s; rewrite /dropN. Qed.

Lemma dropN_succ_cons A: forall n x (xs: seq A),
 dropN (N.succ n) (x::xs) = dropN n xs.
Proof. by move=> n x xs; rewrite /dropN N.peano_rect_succ. Qed.

Lemma dropN_pos_cons A: forall p x (xs: seq A),
 dropN (Npos p) (x::xs) = dropN (Npred (Npos p)) xs.
Proof.
move=> p x xs.
by rewrite /dropN -N.succ_pos_pred N.peano_rect_succ N.pred_succ.
Qed.

Lemma drop_dropN: forall A (xs: seq A) n,
 drop n xs = dropN (N.of_nat n) xs.
Proof.
move=> A; elim => //.
 by move=> n; rewrite dropN_nil.
move=> x xs IH [|n] //.
by rewrite [drop _ _]/= IH Nat2N.inj_succ dropN_succ_cons.
Qed.

Lemma dropN_drop: forall A (xs: seq A) n,
 dropN n xs = drop (N.to_nat n) xs.
Proof. by move=> A n xs; rewrite drop_dropN N2Nat.id. Qed.

Lemma dropN_sizeN_cat: forall T n (s1 s2: seq T),
    sizeN s1 = n -> dropN n (s1++s2) = s2.
Proof.
move=> T n s1 s2.
rewrite sizeN_size => H.
move/(f_equal N.to_nat): H; rewrite Nat2N.id => H.
by rewrite dropN_drop drop_size_cat.
Qed.

Lemma dropN_add {A} (m: list A) n n' :
  dropN (n + n') m = dropN n (dropN n' m).
Proof. by rewrite !dropN_drop N2Nat.inj_add drop_add. Qed.

Lemma dropN_is_nil {A} (m: list A) n :
  dropN n m = nil -> sizeN m <= n.
Proof. by rewrite dropN_drop => /drop_is_nil; rewrite size_sizeN -N2n_le. Qed.

Definition takeN_dflt {A} (dflt: A) (n:N) : seq A -> seq A :=
 N.peano_rect _ (fun _=>[::]) (fun n r s=> if s is x::xs
                                           then x::r xs
                                           else dflt:: r [::]) n.

Lemma take_takeN_dflt: forall A (dfl:A) n s,
 take_dflt dfl n s = takeN_dflt dfl (N.of_nat n) s.
Proof.
by move=> A d; elim => // n IH [|x xs];
rewrite Nat2N.inj_succ /takeN_dflt N.peano_rect_succ /= IH.
Qed.

Lemma takeN_take_dflt: forall A (dfl:A) n s,
 takeN_dflt dfl n s = take_dflt dfl (N.to_nat n) s.
Proof. by move=> A d n s; rewrite take_takeN_dflt N2Nat.id. Qed.

Lemma takeN_dflt_catl: forall n (T : Type) (s1 : seq T),
    (n <= sizeN s1) -> forall d s2, takeN_dflt d n (s1 ++ s2) = takeN_dflt d n s1.
Proof.
move=> n T s1 H d s2.
rewrite !takeN_take_dflt take_dflt_catl //.
by apply/leP; rewrite Compare_dec.nat_compare_le size_sizeN Nat2N.inj_compare !N2Nat.id.
Qed.

Lemma takeN_dflt_eqsize: forall T d n (s : seq T),
    (sizeN s = n) -> takeN_dflt d n s = s.
Proof.
move=> T d n s; rewrite sizeN_size => H.
rewrite takeN_take_dflt take_dflt_eqsize //.
by apply Nat2N.inj; rewrite H N2Nat.id.
Qed.

Lemma size_takeN_dflt: forall A (dfl:A) n s,
 size (takeN_dflt dfl n s) = N.to_nat n.
Proof.
move=> A dfl; elim/N.peano_ind => //=.
move=> n IH [|x xs].
 rewrite /takeN_dflt N.peano_rect_succ Nnat.N2Nat.inj_succ /=.
 by f_equal; apply IH.
rewrite /takeN_dflt N.peano_rect_succ Nnat.N2Nat.inj_succ /=.
by rewrite IH.
Qed.

Lemma sizeN_takeN_dflt: forall A (dfl:A) n s,
 sizeN (takeN_dflt dfl n s) = n.
Proof.
move=> A d n s; apply N2Nat.inj.
by rewrite sizeN_size size_takeN_dflt Nat2N.id.
Qed.

Lemma takeN_dflt_all {A} d (m: list A) :
  takeN_dflt d (sizeN m) m = m.
Proof.
  elim m; clear.
  reflexivity.
  intros a m IH.
  unfold takeN_dflt. simpl.
  rewrite N.peano_rect_succ.
  f_equal. apply IH.
Qed.

Lemma takeN_dflt_split {A} (d: A) s n:
  sizeN s <= n -> takeN_dflt d n s = s ++ (nseqN (n-sizeN s) d).
Proof.
rewrite takeN_take_dflt take_dflt_split sizeN_size nseqN_nseq => Hsize.
rewrite take_oversize; last first.
 by move: Hsize; rewrite N2n_le n2N2n.
by rewrite N2Nat.inj_sub n2N2n.
Qed.

Lemma nth_takeN_dflt A (d:A) bs n x:
 nth d (takeN_dflt d n bs) x = if (x < N2n n)%N
                               then nth d bs x
                               else d.
Proof. by rewrite takeN_take_dflt nth_take_dflt. Qed.

Fixpoint onthN {A} (s: seq A) (n: N) : option A :=
 if s is x::xs
 then if n is N0 then Some x else onthN xs (N.pred n)
 else None.

Lemma onth_onthN {A}: forall (s: seq A) n,
 onth s n = onthN s (N.of_nat n).
Proof.
elim => //= x xs IH [|n] //=.
by rewrite IH pospred_ofsuccnat; f_equal.
Qed.

Lemma onthN_onth: forall A (s: seq A) n,
 onthN s n = onth s (N.to_nat n).
Proof. by move=> A s n; rewrite onth_onthN N2Nat.id. Qed.

Lemma onthN_isS {A} d (s: seq A) n v:
  onthN s n = Some v <-> (n < sizeN s) /\ nthN d s n = v.
Proof.
rewrite onthN_onth (onth_isS d) sizeN_size nthN_nth.
split; move => [H1 H2]; split => //.
 by move: H1; rewrite size_sizeN N2n_lt N2n2N.
by rewrite size_sizeN -N2n_lt sizeN_size.
Qed.

Lemma onthN_isS_cat {A} (x y: seq A) n z :
  onthN x n = Some z ->
  onthN (x ++ y) n = Some z.
Proof. by rewrite !onthN_onth => H; apply onth_isS_cat. Qed.

Lemma map_onthN_iotaN {A} (m: list A) n :
  forall x,
    (x + n <= sizeN m) ->
    map (onthN m) (iotaN x n) = map (@Some _) (take (N2n n) (drop (N2n x) m)).
Proof.
move=> x Hsize.
rewrite -map_onth_iota; last first.
 by move: Hsize; rewrite N2n_le -size_sizeN N2Nat.inj_add plusE => Hsize.
rewrite iotaN_iota.
rewrite -map_comp /=; apply eq_map.
by move=> a /=; rewrite onth_onthN.
Qed.

Definition updprefAtN {A} : N -> seq A -> seq A -> seq A :=
 (N.peano_rect _ (fun orig new => updpref orig new)
               (fun n' r orig new => if orig is x::xs
                                     then x::r xs new
                                     else [::])).

Lemma updprefAtN_updprefAt {A} n (orig new: seq A):
 updprefAtN n orig new = updprefAt (N2n n) orig new.
Proof.
elim/N.peano_ind: n orig new => //= n IH [|x xs] new.
 by rewrite /updprefAtN N.peano_rect_succ Nnat.N2Nat.inj_succ /=.
by rewrite /updprefAtN N.peano_rect_succ Nnat.N2Nat.inj_succ /= -IH.
Qed.

Lemma updprefAt_updprefAtN {A} n (orig new: seq A):
 updprefAt n orig new = updprefAtN (n2N n) orig new.
Proof.
elim: n orig new => // n IH [|x xs] new.
 by rewrite /updprefAtN Nat2N.inj_succ N.peano_rect_succ.
by rewrite /updprefAtN Nat2N.inj_succ N.peano_rect_succ /= IH.
Qed.

Lemma updprefAtN_E {A} n (orig new: seq A):
  updprefAtN n orig new = takeN n orig ++ updpref (dropN n orig) new.
Proof. by rewrite updprefAtN_updprefAt updprefAtE !takeN_take dropN_drop. Qed.

Lemma sizeN_updprefAtN {A} n (orig new: seq A):
  sizeN (updprefAtN n orig new) = sizeN orig.
Proof.
by rewrite updprefAtN_updprefAt !sizeN_size size_updprefAt.
Qed.

(** selects the nth element with a given [width] *)
Definition nthN_width {A} (width:N) (s:seq A) (n:N) : seq A :=
 (N.peano_rect _ (takeN width) (fun n r s=> r (dropN width s)) n) s.

(** selects the nth double element with a given [width] *)
Definition nthN_dwidth {A} (width:N) (s:seq A) (n:N) : seq A :=
 (N.peano_rect _ (takeN (2*width)) (fun n r s=> r (dropN width s)) n) s.

(*
(** updates the nth element with a given [width] *)
Definition updN_width {A} (width:N) (x:seq A) (s:seq A) (n:N) : seq A :=
 (N.peano_rect _ (fun l => x++dropN width l)
               (fun n r s=> takeN width s ++ r (dropN width s)) n) s.

(** upd the nth double element with a given [width] *)
Definition updN_dwidth {A} (width:N) (x:seq A) (s:seq A) (n:N) : seq A :=
 (N.peano_rect _ (fun l => x++dropN (2*width) l)
               (fun n r s=> takeN width s ++ r (dropN width s)) n) s.
*)


Require Export P07.

Theorem snoc_rev_relation : forall n : nat, forall l : natlist,
      rev (snoc l n) = n :: rev l.
Proof.
  intros n l. induction l.
  - simpl. reflexivity.
  - simpl. rewrite -> IHl. reflexivity.
Qed.

(** Hint: You may need to first state and prove some lemma about snoc and rev. *)
Theorem rev_involutive : forall l : natlist,
  rev (rev l) = l.
Proof.
  intros l. induction l.
  - reflexivity.
  - simpl. rewrite -> snoc_rev_relation. rewrite -> IHl. reflexivity.
Qed.


(***************************** LIFLF - TPX ************************************)
(************* Evaluation pratique en temps limité : 30' **********************)
(******************************************************************************)

Require Import List.
Import ListNotations.

(***************************** fonction mystère *******************************)

(* On donne le corps suivant d'une fonction

  match ls with
   | []     => None
   | x::xs  => Some x
  end.
*)

(* EXERCICE : Définir la fonction "mystere" avec le corps donné ci-dessus. *)
(*            Donner son type *)
(*            Expliquer simplement ce que fait cette fonction. *)

Definition mystere (ls : list nat) : option nat :=
match ls with
   | []     => None
   | x::xs  => Some x
  end.

(***************************** "take" *****************************************)

(* EXERCICE : définir "take n ls" qui renvoie le préfixe de ls de longueur n
   EXEMPLE  : voir les tests unitaires ci-dessous
*)

(* nombre element liste list nb elem concat list ++ :: n-1*)

Fixpoint take (n: nat) (ls: list nat) : list nat :=
  match ls with
  | [] => []
  | n'::l' => if (Nat.eqb n 0) then [] else n'::[] ++ (take (n-1) l')
  end.

Goal  take 0 [1;2;3;4;5] = [].
simpl.
reflexivity.
Qed.

Goal  take 6 [1;2;3;4;5] = [1;2;3;4;5].
simpl.
reflexivity.
Qed.

Goal  take 3 [1;2;3;4;5] = [1;2;3].
simpl.
reflexivity.
Qed.

Print app.

(***************************** "drop" *****************************************)

(* EXERCICE : définir "drop n ls" qui renvoie le suffixe de ls privée de ses n
              premiers éléments
   EXEMPLE  : voir les tests unitaires ci-dessous
*)

(* enlever element liste list drop elements number list*)

Fixpoint drop (n: nat) (l: list nat) : list nat :=
  match l with
  | [] => []
  | n'::l' => if (Nat.eqb n 0) then l else drop (n-1) l'
  end.

Goal  drop 0 [1;2;3;4;5] = [1;2;3;4;5].
simpl.
reflexivity.
Qed.

Goal  drop 6 [1;2;3;4;5] = [].
simpl.
reflexivity.
Qed.

Goal  drop 3 [1;2;3;4;5] = [4;5].
simpl.
reflexivity.
Qed.

(*********************** explication d'énoncé *********************************)

(* EXERCICE : On donne l'énoncé suivant "a_expliquer".
              Expliquer en français cette propriété
*)
Lemma a_expliquer : forall n la, (fun p => app (fst p) (snd p) ) (take n la, drop n la) = la.
Admitted.

(* c'est le theoreme qui verifie que pour tout entier n et tout liste la si on applique
take et drop en parallele sur la meme liste, le resultat de leurs deux liste concatenes
revient a la liste de depart la*)

Compute (take 3 [1;2;3;4;5;6]).
Compute (drop 3 [1;2;3;4;5;6]).
Compute (take 3 [1;2;3;4;5;6]) ++ (drop 3 [1;2;3;4;5;6]).
Compute (a_expliquer 3 [1;2;3;4;5;6]).


(* begin hide *)
From mathcomp
  Require Import ssreflect ssrfun ssrbool ssrnat eqtype seq bigop path.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.
(* end hide *)
(** One important aspect of Coq's logic is the special status given to
_computation_: while some systems require one to apply explicit
deductive steps to show that two given terms are equal, Coq's logic
considers any two terms that _evaluate_ to the same result to be equal
automatically, without the need for additional reasoning.

Without getting into too much detail, we can illustrate this idea with
some simple examples. Russell and Whitehead's seminal _Principia
Mathematica_ had to develop #hundreds
of pages# of foundational mathematics before being able to prove
that [1 + 1 = 2]. In contrast, here's what this proof looks like in
Coq: *)

Definition one_plus_one : 1 + 1 = 2 := erefl.

(** [erefl] is the only constructor of the [eq] type; its type,
[forall A (a : A), a = a], tells us that we can use it to prove that
given term [a] is equal to itself. Coq accepts [one_plus_one] as a
valid proof because, even though the two sides of the equation are not
syntactically the same, it is able to use the definition of [+] to
compute the left-hand side and check that the result is the same as
the right-hand side. This also works for some statements with
variables in them, for instance *)

Definition zero_plus_n n : 0 + n = n := erefl.

(** The same principle applies here: [+] is defined by case analysis
on its first argument, and doesn't even need to inspect the second
one. Since the first argument on the left-hand side is a constructor
([0]), Coq can reduce the expression and conclude that both sides are
equal.

Unfortunately, not every equality is a direct consequence of
computation. For example, this proof attempt is rejected: *)

Fail Definition n_plus_zero n : n + 0 = n := erefl.

(** What happened here? As mentioned before, [+] is defined by case
analysis on the first argument; since the first argument of the
left-hand side doesn't start with a constructor, Coq doesn't know how
to compute there. As it turns out, one actually needs an inductive
argument to prove this result, which might end up looking like this,
if we were to check the proof term that Coq produces: *)

Fixpoint n_plus_zero n : n + 0 = n :=
  match n with
  | 0 => erefl
  | n.+1 => let: erefl := n_plus_zero n in erefl
  end.

(** It seems that, although interesting, computation inside Coq isn't
of much use when proving something. Or is it?

In this post, I will show how computation in Coq can be used to write
certified automation tactics with a technique known as _proof by
reflection_. Reflection is extensively used in Coq and in other proof
assistants as well; it is at the core of powerful automation tactics
such as [ring], and played an important role in the formalization of
the #Four-color
theorem#. As a matter of fact, the name #Ssreflect# stands for
_small-scale reflection_, due to the library's pervasive use of
reflection and computation.

Let's see how reflection works by means of a basic example: a tactic
for checking equalities between simple expressions involving natural
numbers.

** Arithmetic with reflection

Imagine that we were in the middle of a proof and needed to show that
two natural numbers are equal: *)

Lemma lem n m p : (n + m) * p = p * m + p * n.

(** [ring] is powerful enough to solve this goal by itself, but just
for the sake of the example, suppose that we had to prove it by
hand. We could write something like *)

Proof. by rewrite mulnDl (mulnC n) (mulnC m) addnC. Qed.

(** This was not terribly complicated, but there's certainly room for
improvement. In a paper proof, a mathematician would probably assume
that the reader is capable of verifying this result on their own,
without any additional detail. But how exactly would the reader
proceed?

In the case of the simple arithmetic expression above, it suffices to
apply the distributivity law as long as possible, until both
expressions become a sum of monomials. Then, thanks to associativity
and commutativity, we just have to reorder the factors and terms and
check that both sides of the equation match.

The idea of proof by reflection is to reduce a the validity of a
logical statement to a _symbolic computation_, usually by proving a
theorem of the form [thm : b = true -> P] with [b : bool]. If [b] can
be computed explicitly and reduces to [true], then Coq recognizes
[erefl] as a proof of [b = true], which means that [thm erefl] becomes
a proof of [P].

To make things concrete, let's go back to our example. The idea that
we described above for checking whether two numbers are equal can be
used whenever we have expressions involving addition, multiplication,
and variables. We will define a Coq data type for representing such
expressions, as we will need to compute with them: *)

Inductive expr :=
| Var of nat
| Add of expr & expr
| Mul of expr & expr.

(** Variables are represented by natural numbers using the [Var]
constructor, and [Add] and [Mul] can be used to combine
expressions. The following term, for instance, represents the
expression [n * (m + n)]: *)

Example expr_ex :=
  Mul (Var 0) (Add (Var 1) (Var 0)).

(** where [Var 0] and [Var 1] denote [n] and [m], respectively.

If we are given a function [vals] assigning variables to numbers, we
can compute the value of an expression with a simple recursive
function: *)

Fixpoint nat_of_expr vals e :=
  match e with
  | Var v => vals v
  | Add e1 e2 => nat_of_expr vals e1 + nat_of_expr vals e2
  | Mul e1 e2 => nat_of_expr vals e1 * nat_of_expr vals e2
  end.

(** Now, since every expression of that form can be written as a sum
of monomials, we can define a function for converting an [expr] to
that form: *)

Fixpoint monoms e :=
  match e with
  | Var v => [:: [:: v] ]
  | Add e1 e2 => monoms e1 ++ monoms e2
  | Mul e1 e2 => [seq m1 ++ m2 | m1 <- monoms e1, m2 <- monoms e2]
  end.

(** Here, each monomial is represented by a list enumerating all
variables that occur in it, counting their multiplicities. Hence, a
sum of monomials is represented as a list of lists. For example,
here's the result of normalizing [expr_ex]: *)

Example monoms_expr_ex :
  monoms expr_ex = [:: [:: 0; 1]; [:: 0; 0]].
Proof. by []. Qed.

(** To prove that [monoms] has the intended behavior, we show that the
value of an expression is preserved by it. By using the big operations
[\sum] and [\prod] from the MathComp library, we can compute the value
of a sum of monomials very easily: *)

Lemma monomsE vals e :
  nat_of_expr vals e = \sum_(m <- monoms e) \prod_(v <- m) vals v.
Proof.
elim: e=> [v|e1 IH1 e2 IH2|e1 IH1 e2 IH2] /=.
- by rewrite 2!big_seq1.
- by rewrite big_cat IH1 IH2.
rewrite {}IH1 {}IH2 big_distrlr /=.
elim: (monoms e1) (monoms e2)=> [|v m1 IH] m2 /=; first by rewrite 2!big_nil.
rewrite big_cons big_cat /= IH; congr addn.
by rewrite big_map; apply/eq_big=> //= m3 _; rewrite big_cat.
Qed.

(** Hence, to check that two expressions are equivalent, it suffices
to compare the results of [monoms], modulo the ordering. We can do
this by sorting the variable names on each monomial and then testing
whether one list of monomials is a permutation of the other: *)

Definition normalize := map (sort leq) \o monoms.

Lemma normalizeE vals e :
  nat_of_expr vals e = \sum_(m <- normalize e) \prod_(v <- m) vals v.
Proof.
rewrite monomsE /normalize /=; elim: (monoms e)=> [|m ms IH] /=.
  by rewrite big_nil.
rewrite 2!big_cons IH; congr addn.
by apply/perm_big; rewrite perm_sym perm_sort.
Qed.

Definition expr_eq e1 e2 := perm_eq (normalize e1) (normalize e2).

Lemma expr_eqP vals e1 e2 :
  expr_eq e1 e2 ->
  nat_of_expr vals e1 = nat_of_expr vals e2.
Proof. rewrite 2!normalizeE; exact/perm_big. Qed.

(** To see how this lemma works, let's revisit our original
example. Here's a new proof that uses [expr_eqP]: *)

Lemma lem' n m p : (n + m) * p = p * m + p * n.
Proof.
exact: (@expr_eqP (nth 0 [:: n; m; p])
                  (Mul (Add (Var 0) (Var 1)) (Var 2))
                  (Add (Mul (Var 2) (Var 1)) (Mul (Var 2) (Var 0)))
                  erefl).
Qed.

(** The first argument to our lemma assigns "real" variables to
variable numbers: [0] corresponds to [n] (the first element of the
list), [1] to [m], and [2] to [p]. The second and third argument are
symbolic representations of the left and right-hand sides of our
equation. The fourth argument is the most interesting one: the
[expr_eq] was defined as a _boolean_ function that returns [true] when
its two arguments are equivalent expressions. As we've seen above,
this means that whenever [expr_eq e1 e2] computes to [true], [erefl]
is a valid proof of it. Finally, when Coq tries to check whether the
conclusion of [expr_eqP] can be used on our goal, it computes
[nat_of_expr] on both sides, realizing that the conclusion and the
goal are exactly the same. For instance: *)

Lemma expr_eval n m p :
  nat_of_expr (nth 0 [:: n; m; p]) (Mul (Add (Var 0) (Var 1)) (Var 2))
  = (n + m) * p.
Proof. reflexivity. Qed.

(** Of course, [expr_eqP] doesn't force its first argument to always
return actual Coq variables, so it can be applied even in some cases
where the expressions contain other operators besides [+] and [*]: *)

Lemma lem'' n m : 2 ^ n * m = m * 2 ^ n.
Proof.
exact: (@expr_eqP (nth 0 [:: 2 ^ n; m])
                  (Mul (Var 0) (Var 1)) (Mul (Var 1) (Var 0))
                  erefl).
Qed.

(** At this point, it may seem that we haven't gained much from using
[expr_eqP], since the second proof of our example was much bigger than
the first one. This is just an illusion, however, as the proof term
produced on the first case is actually quite big:

[[
lem =
fun n m p : nat =>
(fun _evar_0_ : n * p + m * p = p * m + p * n =>
 eq_ind_r (eq^~ (p * m + p * n)) _evar_0_ (mulnDl n m p))
  ((fun _evar_0_ : p * n + m * p = p * m + p * n =>
    eq_ind_r
      (fun _pattern_value_ : nat => _pattern_value_ + m * p = p * m + p * n)
      _evar_0_ (mulnC n p))
     ((fun _evar_0_ : p * n + p * m = p * m + p * n =>
       eq_ind_r
         (fun _pattern_value_ : nat =>
          p * n + _pattern_value_ = p * m + p * n) _evar_0_
         (mulnC m p))
        ((fun _evar_0_ : p * m + p * n = p * m + p * n =>
          eq_ind_r (eq^~ (p * m + p * n)) _evar_0_ (addnC (p * n) (p * m)))
           (erefl (p * m + p * n)))))
     : forall n m p : nat, (n + m) * p = p * m + p * n
]]

By using reflection, we were able to transform the explicit reasoning
steps of the first proof into implicit computation that is carried out
by the proof assistant. And since proof terms have to be stored in
memory or included into the compiled [vo] file, it is good to make
them smaller if we can.

Nevertheless, even with a smaller proof term, having to manually type
in that proof term is not very convenient. The problem is that Coq's
unification engine is not smart enough to infer the symbolic form of
an expression, forcing us to provide it ourselves. Fortunately, we can
use some code to fill in the missing bits.

** Reification

To _reify_ something means to produce a representation of that object
that can be directly manipulated in computation. In our case, that
object is a Gallina expression of type [nat], and the representation
we are producing is a term of type [expr].

Reification is ubiquitous in proofs by reflection. The Coq standard
library comes with a #plugin#
for reifying formulas, but it is not general enough to accommodate our
use case. Therefore, we will program our own reification tactic in
ltac.

We will begin by writing a function that looks for a variable on a
list and returns its position. If the variable is not present, we add
it to the end of the list and return the updated list as well: *)

Ltac intern vars e :=
  let rec loop n vars' :=
    match vars' with
    | [::] =>
      let vars'' := eval simpl in (rcons vars e) in
      constr:((n, vars''))
    | e :: ?vars'' => constr:((n, vars))
    | _ :: ?vars'' => loop (S n) vars''
    end in
  loop 0 vars.

(** Notice the call to [eval simpl] on the first branch of
[loop]. Remember that in ltac everything is matched almost purely
syntactically, so we have to explicitly evaluate a term when we are
just interested on its value, and not on how it is written.

We can now write a tactic for reifying an expression. [reify_expr]
takes two arguments: a list [vars] to be used with [intern] for
reifying variables, plus the expression [e] to be reified. It returns
a pair [(e',vars')] contained the reified expression [e'] and an
updated variable list [vars']. *)

Ltac reify_expr vars e :=
  match e with
  | ?e1 + ?e2 =>
    let r1 := reify_expr vars e1 in
    match r1 with
    | (?qe1, ?vars') =>
      let r2 := reify_expr vars' e2 in
      match r2 with
      | (?qe2, ?vars'') => constr:((Add qe1 qe2, vars''))
      end
    end
  | ?e1 * ?e2 =>
    let r1 := reify_expr vars e1 in
    match r1 with
    | (?qe1, ?vars') =>
      let r2 := reify_expr vars' e2 in
      match r2 with
      | (?qe2, ?vars'') => constr:((Mul qe1 qe2, vars''))
      end
    end
  | _ =>
    let r := intern vars e in
    match r with
    | (?n, ?vars') => constr:((Var n, vars'))
    end
  end.

(** Again, because this is an ltac function, we can traverse our
Gallina expression syntactically, as if it were a data
structure. Notice how we thread though the updated variable lists
after each call; this is done to ensure that variables are named
consistently.

Finally, using [reify_expr], we can write [solve_nat_eq], which
reifies both sides of the equation on the goal and applies [expr_eqP]
with the appropriate arguments. *)

Ltac solve_nat_eq :=
  match goal with
  | |- ?e1 = ?e2 =>
    let r1 := reify_expr (Nil nat) e1 in
    match r1 with
    | (?qe1, ?vm') =>
      let r2 := reify_expr vm' e2 in
      match r2 with
      | (?qe2, ?vm'') => exact: (@expr_eqP (nth 0 vm'') qe1 qe2 erefl)
      end
    end
  end.

(** We can check that our tactic works on our original example: *)

Lemma lem''' n m p : (n + m) * p = p * m + p * n.
Proof. solve_nat_eq. Qed.

(** With [solve_nat_eq], every equation of that form becomes very easy
to solve, including cases where a human prover might have trouble at
first sight! *)

Lemma complicated n m p r t :
  (n + 2 ^ r * m) * (p + t) * (n + p)
  = n * n * p + m * 2 ^ r * (p * n + p * t + t * n + p * p)
  + n * (p * p + t * p + t * n).
Proof. solve_nat_eq. Qed.

(** ** Summary

We have seen how we can use internal computation in Coq to write
powerful tactics. Besides generating small proof terms, tactics that
use reflection have another important benefit: they are mostly written
in Gallina, a typed language, and come with correctness proofs. This
contrasts with most custom tactics written in ltac, which tend to
break quite often due to the lack of static guarantees (and to how
unstructure the tactic language is). For [solve_nat_eq], we only had
to write the reification engine in ltac, which results in a more
manageable code base.

If you want to learn more about reflection, Adam Chlipala's #CPDT# book has #an entire
chapter# devoted to the subject, which I highly recommend. *)


(* week-09_exercises.v *)
(* FPP 2020 - YSC3236 2020-2011, Sem1 *)

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

(*
Your name:
Bernard Boey
Tristan Koh

Your e-mail address:
bernard@u.yale-nus.edu.sg
tristan.koh@u.yale-nus.edu.sg

Your student number:
A0191234L
A0191222R

*)

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

(* Paraphernalia: *)

Ltac fold_unfold_tactic name := intros; unfold name; fold name; reflexivity.

Require Import Arith Bool.

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

(* Exercise 1 *)

Inductive m22 : Type :=
| M22 : nat -> nat -> nat -> nat -> m22.

Definition m22_add (x y : m22) : m22 :=
  match x with
  | M22 x11 x12
        x21 x22 =>
    match y with
    | M22 y11 y12
          y21 y22 =>
      M22 (x11 + y11) (x12 + y12)
          (x21 + y21) (x22 + y22)
    end
  end.

Definition m22_zero :=
  M22 0 0
      0 0.

Definition m22_one :=
  M22 1 0
      0 1.

(* Part a: Definition 9 - Multiplication *)

Definition m22_mul (x y : m22) : m22 :=
  match x with
  | M22 x11 x12
        x21 x22 =>
    match y with
    | M22 y11 y12
          y21 y22 =>
      M22 ((x11 * y11) + (x12 * y21)) ((x11 * y12) + (x12 * y22))
          ((x21 * y11) + (x22 * y21)) ((x21 * y12) + (x22 * y22))
    end
  end.

(* Part b: Proposition 10 - Associativity of matrix multiplication *)

Proposition proposition_10 :
  forall (x y z : m22),
    m22_mul x (m22_mul y z) = m22_mul (m22_mul x y) z.
Proof.
  intros [x11 x12 x21 x22] [y11 y12 y21 y22] [z11 z12 z21 z22].
  unfold m22_mul.
  Search (_ * (_ + _)).
  rewrite -> 8 Nat.mul_add_distr_l.
  Search ((_ + _) * _).
  rewrite -> 8 Nat.mul_add_distr_r.
  Search (_ * (_ * _)).
  rewrite -> 16 Nat.mul_assoc.
  Search (_ + (_ + _ )).
  rewrite -> (Nat.add_shuffle1 (x11 * y11 * z11)).
  rewrite -> (Nat.add_shuffle1 (x11 * y11 * z12)).
  rewrite -> (Nat.add_shuffle1 (x21 * y11 * z11)).
  rewrite -> (Nat.add_shuffle1 (x21 * y11 * z12)).
  reflexivity.
Qed.

(* Part c: Proposition 12 - Identity matrix is left and right neutral *)

Proposition proposition_12_left_neutral :
  forall x : m22,
    m22_mul m22_one x = x.
Proof.
  intros [x11 x12 x21 x22].
  unfold m22_one, m22_mul.
  Search (1 * _).
  rewrite -> 4 Nat.mul_1_l.
  Search (0 * _).
  rewrite -> 4 Nat.mul_0_l.
  Search (_ + 0).
  rewrite -> 2 Nat.add_0_r.
  rewrite -> 2 Nat.add_0_l.
  reflexivity.
Qed.

Proposition proposition_12_right_neutral :
  forall x : m22,
    m22_mul x m22_one = x.
Proof.
  intros [x11 x12 x21 x22].
  unfold m22_one, m22_mul.
  rewrite -> 4 Nat.mul_1_r.
  rewrite -> 4 Nat.mul_0_r.
  rewrite -> 2 Nat.add_0_l.
  rewrite -> 2 Nat.add_0_r.
  reflexivity.
Qed.

(* Part d: Definition 13 - Matrix exponentiation function *)

Fixpoint m22_exp (x : m22) (n : nat) : m22 :=
  match n with
  | 0 =>
    m22_one
  | S n' =>
    m22_mul (m22_exp x n') x
  end.

Lemma fold_unfold_m22_exp_O :
  forall x : m22,
    m22_exp x 0 =
    m22_one.
Proof.
  fold_unfold_tactic m22_exp.
Qed.

Lemma fold_unfold_m22_exp_S :
  forall (x : m22)
         (n' : nat),
    m22_exp x (S n') =
    m22_mul (m22_exp x n') x.
Proof.
  fold_unfold_tactic m22_exp.
Qed.

(* Part e - Proposition 14 *)

Proposition proposition_14 :
  forall n : nat,
    m22_exp (M22 1 1
                 0 1) n =
    M22 1 n
        0 1.
Proof.
  intro n.
  induction n as [ | n' IHn'].
  - rewrite -> (fold_unfold_m22_exp_O (M22 1 1 0 1)).
    unfold m22_one.
    reflexivity.
  - rewrite -> (fold_unfold_m22_exp_S (M22 1 1 0 1) n').
    rewrite -> IHn'.
    unfold m22_mul.
    rewrite -> Nat.mul_0_l.
    rewrite ->2 Nat.mul_0_r.
    Search (_ + 0).
    rewrite ->2 Nat.add_0_r.
    rewrite -> Nat.add_0_l.
    rewrite -> (Nat.mul_1_l 1).
    rewrite -> Nat.mul_1_r.
    Search (1 + _).
    rewrite -> (Nat.add_1_l n').
    reflexivity.
Qed.

(* Part g - Exercise 25 *)

Compute (m22_exp (M22 1 1
                      1 0) 0).

Compute (m22_exp (M22 1 1
                      1 0) 1).

Compute (m22_exp (M22 1 1
                      1 0) 2).

Compute (m22_exp (M22 1 1
                      1 0) 3).

Compute (m22_exp (M22 1 1
                      1 0) 4).

Compute (m22_exp (M22 1 1
                      1 0) 5).

Compute (m22_exp (M22 1 1
                      1 0) 6).

Compute (m22_exp (M22 1 1
                      1 0) 7).

Notation "A =n= B" :=
  (beq_nat A B) (at level 70, right associativity).

Definition test_fib (candidate : nat -> nat) :=
  (candidate 0 =n= 0)
  &&
  (candidate 1 =n= 1)
  &&
  (candidate 2 =n= 1)
  &&
  (candidate 3 =n= 2)
  &&
  (candidate 4 =n= 3)
  &&
  (candidate 5 =n= 5)
  &&
  (candidate 6 =n= 8).

Fixpoint fib_aux (n : nat) : nat :=
  match n with
  | 0 =>
    0
  | S n' =>
    match n' with
    | 0 =>
      1
    | S n'' =>
      fib_aux n' + fib_aux n''
  end
end.

Definition fib (n : nat) : nat :=
  fib_aux n.

Compute (test_fib fib).

Lemma fold_unfold_fib_aux_O :
  fib_aux 0 =
  0.
Proof.
  fold_unfold_tactic fib_aux.
Qed.

Lemma fold_unfold_fib_aux_1 :
  fib_aux 1 =
  1.
Proof.
  fold_unfold_tactic fib_aux.
Qed.

Lemma fold_unfold_fib_aux_S :
  forall n' : nat,
    fib_aux (S (S n')) =
    fib_aux (S n') + fib_aux n'.
Proof.
  fold_unfold_tactic fib_aux.
Qed.

Proposition exercise_25 :
  forall n : nat,
    m22_exp (M22 1 1
                 1 0) (S n) =
    M22 (fib (S (S n))) (fib (S n))
        (fib (S n)) (fib n).
Proof.
  intro n.
  unfold fib.
  induction n as [ | n' IHn'].
  - rewrite -> fold_unfold_fib_aux_O.
    rewrite -> fold_unfold_fib_aux_1.
    rewrite -> (fold_unfold_fib_aux_S 0).
    rewrite -> fold_unfold_fib_aux_O.
    rewrite -> fold_unfold_fib_aux_1.
    rewrite -> (Nat.add_0_r 1).
    unfold m22_exp.
    Check proposition_12_left_neutral.
    rewrite -> (proposition_12_left_neutral (M22 1 1 1 0)).
    reflexivity.
  - Check (fold_unfold_m22_exp_S).
    rewrite -> (fold_unfold_m22_exp_S (M22 1 1 1 0) (S n')).
    rewrite -> IHn'.
    unfold m22_mul.
    rewrite -> 3 Nat.mul_1_r.
    rewrite -> 2 Nat.mul_0_r.
    rewrite -> 2 Nat.add_0_r.
    Check (fold_unfold_fib_aux_S).
    rewrite <- (fold_unfold_fib_aux_S (S n')).
    rewrite <- (fold_unfold_fib_aux_S n').
    reflexivity.
Qed.

(* Part h - Definition 27 *)

Fixpoint m22_exp' (x : m22) (n : nat) : m22 :=
  match n with
  | 0 =>
    m22_one
  | S n' =>
    m22_mul x (m22_exp' x n')
  end.

Lemma fold_unfold_m22_exp'_O :
  forall x : m22,
  m22_exp' x 0 =
  m22_one.
Proof.
  fold_unfold_tactic m22_exp'.
Qed.

Lemma fold_unfold_m22_exp'_S :
  forall (x : m22)
         (n' : nat),
    m22_exp' x (S n') =
    m22_mul x (m22_exp' x n').
Proof.
  fold_unfold_tactic m22_exp'.
Qed.

(* Part i - Equivalence of m22_exp and m22_exp' *)

Proposition proposition_29 :
  forall (x : m22)
         (n : nat),
    m22_mul x (m22_exp x n) = m22_mul (m22_exp x n) x.
Proof.
  intros x n.
  induction n as [ | n' IHn'].
  - rewrite -> (fold_unfold_m22_exp_O x).
    rewrite -> (proposition_12_left_neutral x).
    exact (proposition_12_right_neutral x).
  - rewrite -> (fold_unfold_m22_exp_S x n').
    rewrite -> (proposition_10 x (m22_exp x n') x).
    rewrite -> IHn'.
    reflexivity.
Qed.

Corollary definition_13_and_27_are_equivalent :
  forall (x : m22)
         (n : nat),
    m22_exp x n = m22_exp' x n.
Proof.
  intros x n.
  induction n as [ | n' IHn'].
  - rewrite -> (fold_unfold_m22_exp_O x).
    rewrite -> (fold_unfold_m22_exp'_O x).
    reflexivity.
  - rewrite -> (fold_unfold_m22_exp_S x n').
    rewrite -> (fold_unfold_m22_exp'_S x n').
    rewrite <- IHn'.
    rewrite -> (proposition_29 x n').
    reflexivity.
Qed.

(* Part j - Definition 35, Transposition of matrix *)

Definition m22_transpose (x : m22) : m22 :=
  match x with
  | M22 x11 x12
        x21 x22 =>
    M22 x11 x21
        x12 x22
  end.

(* Part k - Property 36, Transposition is involutive *)

Proposition property_36 :
  forall x : m22,
    m22_transpose (m22_transpose x) = x.
Proof.
  intros [x11 x12 x21 x22].
  unfold m22_transpose.
  reflexivity.
Qed.

(* Part l - Proposition 38, Transposition and exponentiation commute with each other *)

Lemma lemma_37 :
  forall x y : m22,
    m22_transpose (m22_mul x y) = m22_mul (m22_transpose y) (m22_transpose x).
Proof.
  intros [x11 x12 x21 x22]
         [y11 y12 y21 y22].
  unfold m22_transpose.
  unfold m22_mul.
  rewrite -> (Nat.mul_comm x11 y11).
  rewrite -> (Nat.mul_comm x12 y21).
  rewrite -> (Nat.mul_comm x21 y11).
  rewrite -> (Nat.mul_comm x22 y21).
  rewrite -> (Nat.mul_comm x11 y12).
  rewrite -> (Nat.mul_comm x12 y22).
  rewrite -> (Nat.mul_comm x21 y12).
  rewrite -> (Nat.mul_comm x22 y22).
  reflexivity.
Qed.

Proposition proposition_38 :
  forall (x : m22)
         (n : nat),
    m22_transpose (m22_exp x n) = m22_exp (m22_transpose x) n.
Proof.
  intros [x11 x12 x21 x22] n.
  induction n as [ | n' IHn'].
  - Check (fold_unfold_m22_exp_O).
    rewrite -> (fold_unfold_m22_exp_O (M22 x11 x12 x21 x22)).
    rewrite -> (fold_unfold_m22_exp_O (m22_transpose (M22 x11 x12 x21 x22))).
    unfold m22_transpose.
    unfold m22_one.
    reflexivity.
  - Check (fold_unfold_m22_exp_S).
    rewrite -> (fold_unfold_m22_exp_S (M22 x11 x12 x21 x22)).
    Check (lemma_37).
    rewrite -> (lemma_37 (m22_exp (M22 x11 x12 x21 x22) n') (M22 x11 x12 x21 x22)).
    rewrite -> IHn'.
    Check (proposition_29).
    rewrite -> (proposition_29 (m22_transpose (M22 x11 x12 x21 x22)) n').
    rewrite -> (fold_unfold_m22_exp_S (m22_transpose (M22 x11 x12 x21 x22))).
    reflexivity.
Qed.

(* Part m - Exericse 40*)

Proposition proposition_33 :
  forall (n : nat),
    m22_exp (M22 1 0
                 1 1) n =
    (M22 1 0
         n 1).
Proof.
  intro n.
  rewrite <- (property_36 (M22 1 0 1 1)).
  unfold m22_transpose at 2.
  rewrite <- (proposition_38 (M22 1 1 0 1) n).
  rewrite -> (proposition_14 n).
  unfold m22_transpose.
  reflexivity.
Qed.

(* Week 7 Exercise 2 *)

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

Definition is_a_sound_and_complete_equality_predicate (V : Type) (V_eqb : V -> V -> bool) :=
  forall v1 v2 : V,
    V_eqb v1 v2 = true <-> v1 = v2.

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

Check Bool.eqb.
(* eqb : bool -> bool -> bool *)

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

Lemma bool_eqb_is_reflexive :
  forall b : bool,
    bool_eqb b b = true.
Proof.
  intros [ | ]; unfold bool_eqb; reflexivity.
Qed.

Search (eqb _ _ = _ -> _ = _).
(* eqb_prop: forall a b : bool, eqb a b = true -> a = b *)

Proposition soundness_and_completeness_of_bool_eqb :
  is_a_sound_and_complete_equality_predicate bool bool_eqb.
Proof.
  unfold is_a_sound_and_complete_equality_predicate.
  intros [ | ] [ | ].
  - split.
    * intro H_bool_eqb.
      reflexivity.
    * intro H_obvious.
      exact (bool_eqb_is_reflexive true).
  - split.
    * intro H_absurd.
      unfold bool_eqb in H_absurd.
      discriminate H_absurd.
    * intro H_absurd.
      discriminate H_absurd.
  - split.
    * intro H_absurd.
      unfold bool_eqb in H_absurd.
      discriminate H_absurd.
    * intro H_absurd.
      discriminate H_absurd.
  - split.
    * intro H_bool_eqb.
      reflexivity.
    * intro H_obvious.
      exact (bool_eqb_is_reflexive false).
Qed.

(* ***** *)

Proposition soundness_and_completeness_of_Bool_eqb :
  is_a_sound_and_complete_equality_predicate bool eqb.
Proof.
  unfold is_a_sound_and_complete_equality_predicate.
  intros v1 v2.
  Search (eqb _ _ = _ <-> _ = _).
  exact (eqb_true_iff v1 v2).
Qed.

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

Check Nat.eqb.
(* Nat.eqb : nat -> nat -> bool *)

Fixpoint nat_eqb (n1 n2 : nat) : bool :=
  match n1 with
  | O =>
    match n2 with
    | O =>
      true
    | S n2' =>
      false
    end
  | S n1' =>
    match n2 with
    | O =>
      false
    | S n2' =>
      nat_eqb n1' n2'
    end
  end.

Lemma fold_unfold_nat_eqb_O :
  forall n2 : nat,
    nat_eqb 0 n2 =
    match n2 with
    | O =>
      true
    | S _ =>
      false
    end.
Proof.
  fold_unfold_tactic nat_eqb.
Qed.

Lemma fold_unfold_nat_eqb_S :
  forall n1' n2 : nat,
    nat_eqb (S n1') n2 =
    match n2 with
    | O =>
      false
    | S n2' =>
      nat_eqb n1' n2'
    end.
Proof.
  fold_unfold_tactic nat_eqb.
Qed.

Search (Nat.eqb _ _ = true -> _ = _).
(* beq_nat_true: forall n m : nat, (n =? m) = true -> n = m *)

Proposition soundness_and_completeness_of_nat_eqb :
  is_a_sound_and_complete_equality_predicate nat nat_eqb.
Proof.
  unfold is_a_sound_and_complete_equality_predicate.
  intros v1.
  induction v1 as [ | v1' IHv1'].
  - intros [ | v2'].
    * split.
      + intros _.
        reflexivity.
      + intros _.
        exact (fold_unfold_nat_eqb_O 0).
    * rewrite -> (fold_unfold_nat_eqb_O (S v2')).
      split; intro H_absurd; discriminate H_absurd.
  - intros [ | v2'].
    * rewrite -> (fold_unfold_nat_eqb_S v1' 0).
      split; intro H_absurd; discriminate H_absurd.
    * rewrite -> (fold_unfold_nat_eqb_S v1' (S v2')).
      assert (IHv1' := IHv1' v2').
      destruct IHv1' as [H_nat_eqb_implies_equality H_v1_equals_v2_implies_nat_eqb].
      split.
      + intro H_nat_eqb.
        rewrite -> (H_nat_eqb_implies_equality H_nat_eqb).
        reflexivity.
      + intro H_S_v1_equals_S_v2.
        Search (S _ = S _ -> _ = _).
        assert (H_v1_equals_v2 := eq_add_S v1' v2' H_S_v1_equals_S_v2).
        rewrite -> (H_v1_equals_v2_implies_nat_eqb H_v1_equals_v2).
        reflexivity.
Qed.

(* ***** *)

Lemma fold_unfold_Nat_eqb_O :
  forall n2 : nat,
    0 =? n2 =
    match n2 with
    | O =>
      true
    | S _ =>
      false
    end.
Proof.
  fold_unfold_tactic Nat.eqb.
Qed.

Lemma fold_unfold_Nat_eqb_S :
  forall n1' n2 : nat,
    S n1' =? n2 =
    match n2 with
    | O =>
      false
    | S n2' =>
      n1' =? n2'
    end.
Proof.
  fold_unfold_tactic Nat.eqb.
Qed.

Proposition soundness_and_completeness_of_Nat_eqb :
  is_a_sound_and_complete_equality_predicate nat Nat.eqb.
Proof.
  unfold is_a_sound_and_complete_equality_predicate.
  intros v1 v2.
  Search (Nat.eqb _ _ = true <-> _ = _).
  exact (Nat.eqb_eq v1 v2).
Qed.

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

Definition pair_eqb (V W : Type) (V_eqb : V -> V -> bool) (W_eqb : W -> W -> bool) (p1 p2 : V * W) : bool :=
  match p1 with
  | (v1, w1) =>
    match p2 with
    | (v2, w2) =>
      V_eqb v1 v2 && W_eqb w1 w2
    end
  end.

Proposition soundness_and_completeness_of_pair_eqb :
  forall (V W : Type)
         (V_eqb : V -> V -> bool)
         (W_eqb : W -> W -> bool),
    is_a_sound_and_complete_equality_predicate V V_eqb ->
    is_a_sound_and_complete_equality_predicate W W_eqb ->
    forall p1 p2 : V * W,
      pair_eqb V W V_eqb W_eqb p1 p2 = true <-> p1 = p2.
Proof.
  intros V W V_eqb W_eqb.
  unfold is_a_sound_and_complete_equality_predicate.
  intros H_soundness_and_completeness_of_V_eqb H_soundness_and_completeness_of_W_eqb.
  intros [v1 w1] [v2 w2].
  unfold pair_eqb.
  assert (H_soundness_and_completeness_of_V_eqb' := H_soundness_and_completeness_of_V_eqb v1 v2).
  assert (H_soundness_and_completeness_of_W_eqb' := H_soundness_and_completeness_of_W_eqb w1 w2).
  destruct H_soundness_and_completeness_of_V_eqb' as [H_V_eqb_implies_equality H_v1_equals_v2_implies_eqb].
  destruct H_soundness_and_completeness_of_W_eqb' as [H_W_eqb_implies_equality H_w1_equals_w2_implies_eqb].
  split.
  - Search (_ && _ = true).
    intros H_V_eqb_and_W_eqb.
    assert (H_V_eqb_and_W_eqb' := andb_prop (V_eqb v1 v2) (W_eqb w1 w2)  H_V_eqb_and_W_eqb).
    destruct H_V_eqb_and_W_eqb' as [H_V_eqb H_W_eqb].
    assert (H_v1_equals_v2 := H_V_eqb_implies_equality H_V_eqb).
    assert (H_w1_equals_w2 := H_W_eqb_implies_equality H_W_eqb).
    rewrite -> H_v1_equals_v2.
    rewrite -> H_w1_equals_w2.
    reflexivity.
  - intro H_equality_of_pair.
    injection H_equality_of_pair as H_v1_equals_v2 H_w1_equals_w2.
    assert (H_V_eqb := H_v1_equals_v2_implies_eqb H_v1_equals_v2).
    assert (H_W_eqb := H_w1_equals_w2_implies_eqb H_w1_equals_w2).
    Search (_ && _ = true).
    assert (H_V_eqb_and_W_eqb := conj H_V_eqb H_W_eqb).
    exact (andb_true_intro H_V_eqb_and_W_eqb).
Qed.

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

Definition pair_nat_bool_eqb (p1 p2: nat * bool) : bool :=
  pair_eqb nat bool nat_eqb bool_eqb p1 p2.

Proposition soundness_and_completeness_of_pair_nat_bool_eqb :
  is_a_sound_and_complete_equality_predicate (nat * bool) pair_nat_bool_eqb.
Proof.
  unfold is_a_sound_and_complete_equality_predicate.
  Check (soundness_and_completeness_of_pair_eqb nat bool nat_eqb bool_eqb soundness_and_completeness_of_nat_eqb soundness_and_completeness_of_bool_eqb).
  exact (soundness_and_completeness_of_pair_eqb nat bool nat_eqb bool_eqb soundness_and_completeness_of_nat_eqb soundness_and_completeness_of_bool_eqb).
Qed.

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

(* Week 9 Exercise 2 *)

Inductive mm22 : Type :=
| MM22 : m22 -> m22 -> m22 -> m22 -> mm22.

(* Part a *)

Definition mm22_add (x y : mm22) : mm22 :=
  match x with
  | MM22 m22_x11 m22_x21
         m22_x12 m22_x22 =>
    match y with
    | MM22 m22_y11 m22_y21
           m22_y12 m22_y22 =>
      MM22 (m22_add m22_x11 m22_y11) (m22_add m22_x21 m22_y21)
           (m22_add m22_x12 m22_y12) (m22_add m22_x22 m22_y22)
    end
  end.

Definition mm22_mul (x y : mm22) : mm22 :=
  match x with
  | MM22 m22_x11 m22_x21
         m22_x12 m22_x22 =>
    match y with
    | MM22 m22_y11 m22_y21
           m22_y12 m22_y22 =>
      MM22 (m22_add (m22_mul m22_x11 m22_y11) (m22_mul m22_x12 m22_y21)) (m22_add (m22_mul m22_x11 m22_y12) (m22_mul m22_x12 m22_y22))
           (m22_add (m22_mul m22_x21 m22_y11) (m22_mul m22_x22 m22_y21)) (m22_add (m22_mul m22_x21 m22_y12) (m22_mul m22_x22 m22_y22))
    end
  end.

Definition mm22_one :=
  MM22 m22_one m22_one
       m22_one m22_one.

Fixpoint mm22_exp (x : mm22) (n : nat) : mm22 :=
  match n with
  | 0 =>
    mm22_one
  | S n' =>
    mm22_mul (mm22_exp x n') x
  end.

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

(* end of week-09_exercises.v *)


(* This code is copyrighted by its authors; it is distributed under  *)
(* the terms of the LGPL license (see LICENSE and description files) *)

(* Contribution to the Coq Library   V6.3 (July 1999)                    *)
(****************************************************************************)
(*                                                                          *)
(*                                                                          *)
(*                   Solange Coupet-Grimal & Line Jakubiec                  *)
(*                                                                          *)
(*                                                                          *)
(*              Laboratoire d'Informatique de Marseille                     *)
(*               CMI-Technopole de Chateau-Gombert                          *)
(*                   39, Rue F. Joliot Curie                                *)
(*                   13453 MARSEILLE Cedex 13                               *)
(*           e-mail:{Solange.Coupet,Line.Jakubiec}@lim.univ-mrs.fr          *)
(*                                                                          *)
(*                                                                          *)
(*                                Coq V5.10                                 *)
(*                              May 30th 1996                               *)
(*                                                                          *)
(****************************************************************************)
(*                                Lib_Fact.v                                *)
(****************************************************************************)

Require Export Arith.

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

Lemma fact_pred :
 forall n : nat, 0 < n -> factorial n = n * factorial (pred n).
simple induction n; auto with arith.
Qed.
Hint Resolve fact_pred.

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


Load LFindLoad.
From lfind Require Import LFind.
Unset Printing Notations.
Set Printing Implicit.

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

Inductive lst : Type :=  Nil : lst | Cons : natural -> lst -> 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 mult (mult_arg0 : natural) (mult_arg1 : natural) : natural
           := match mult_arg0, mult_arg1 with
              | Zero, n => Zero
              | Succ n, m => plus (mult n m) m
              end.

Fixpoint qmult (qmult_arg0 : natural) (qmult_arg1 : natural) (qmult_arg2 : natural) : natural
           := match qmult_arg0, qmult_arg1, qmult_arg2 with
              | Zero, n, m => m
              | Succ n, m, p => qmult n m (plus p m)
              end.

Lemma plus_succ : forall (x y : natural), plus x (Succ y) = Succ (plus x y).
Proof.
   intros.
   induction x.
   - reflexivity.
   - simpl. rewrite IHx. reflexivity.
Qed.

Lemma plus_assoc : forall (x y z : natural), plus (plus x y) z = plus x (plus y z).
Proof.
   intros.
   induction x.
   - reflexivity.
   - simpl. rewrite IHx. reflexivity.
Qed.

Lemma plus_zero : forall (x : natural), plus x Zero = x.
Proof.
   intros.
   induction x.
   - reflexivity.
   - simpl. rewrite IHx. reflexivity.
Qed.

Lemma plus_commut : forall (x y : natural), plus x y = plus y x.
Proof.
   intros.
   induction x.
   - rewrite plus_zero. reflexivity.
   - simpl. lfind.  rewrite IHx.  reflexivity.
Admitted.

Lemma plus_qmult : forall (x y z a : natural), plus (qmult x y z) a = qmult x y (plus z a).
Proof.
   intro.
   induction x.
   - reflexivity.
   - intros. simpl. rewrite IHx. rewrite plus_assoc. rewrite (plus_commut y a).
     rewrite <- plus_assoc. reflexivity.
Qed.

Theorem mult_eq_qmult : forall (x : natural) (y : natural), eq (mult x y) (qmult x y Zero).
Proof.
   intros.
   induction x.
   - reflexivity.
   - simpl. rewrite IHx. rewrite plus_qmult. reflexivity.
Qed.


Require Import List.
Require Import Arith.
Require Import Sorted.
Require Import Recdef.

Function bubble (l : list nat) {measure length} : list nat :=
  match l with
  | nil => nil
  | n :: nil => n :: nil
  | n1 :: n2 :: l' => if leb n1 n2
                      then n1 :: (bubble (n2 :: l'))
                      else n2 :: (bubble (n1 :: l'))
  end.
Proof.
  auto. auto.
Qed.

Function bubble_sort (l : list nat) : list nat :=
  match l with
  | nil => nil
  | n :: l' => bubble (n :: (bubble_sort l'))
  end.

Check Sorted.

Check (Sorted le).

Print Sorted.

Print HdRel.

(*
Sorted_cons:
  forall (a : A) (l : list A),
  Sorted R l -> HdRel R a l -> Sorted R (a :: l)

HdRel_nil : HdRel R a nil
HdRel_cons : forall (b : A) (l : list A), R a b -> HdRel R a (b :: l)
*)

Check bubble_terminate.
Check iter.

Theorem bubble_sort_correct : forall l, Sorted le (bubble_sort l).
Proof.
  intros.
  induction l.
    simpl. apply Sorted_nil.
    simpl. destruct l.
      simpl. unfold bubble.
      unfold bubble_terminate.

Eval compute in bubble      (1 :: 2 :: 0 :: 3 :: 1 :: nil).
Eval compute in bubble_sort (1 :: 2 :: 0 :: 3 :: 1 :: nil).
Eval compute in bubble_sort (1 :: 2 :: 10 :: 3 :: 6 :: nil).


(*
        #####################################################
        ###  PLEASE DO NOT DISTRIBUTE SOLUTIONS PUBLICLY  ###
        #####################################################
*)
Require Import Coq.Strings.Ascii.
Require Import Coq.Lists.List.

From Turing Require Import Lang.
From Turing Require Import Util.
From Turing Require Import Regex.

Import Lang.Examples.
Import LangNotations.
Import ListNotations.
Import RegexNotations.

Open Scope lang_scope.
Open Scope char_scope.

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

(**

Show that 'aba' is accepted the the following regular expression.

 *)
Theorem ex1:
  ["a"; "b"; "a"] \in (r_star "a" ;; ("b" || "c") ;; r_star "a").
Proof.
  apply accept_app with (s1:=["a";"b"]) (s2:=["a"]).
  apply accept_app with (s1:=["a"]) (s2:=["b"]).
  - apply accept_star_eq, accept_char.
  - apply accept_union_l, accept_char.
  - simpl. reflexivity.
  - apply accept_star_eq, accept_char.
  - simpl. reflexivity.
Qed.

(**

Show that 'bb' is rejected by the following regular expression.

 *)
Theorem ex2:
  ~ (["b"; "b"] \in (r_star "a" ;; ("b" || "c") ;; r_star "a")).
Proof.
  unfold not; intros.
  inversion H; subst; clear H.
  destruct s1.
  - inversion H3; subst; clear H3.
    * inversion H5.
    * inversion H0; subst; clear H0.
      inversion H5.
  - inversion H2; subst; clear H2.
    rewrite H7 in H5.
    inversion H1; subst; clear H1.
    * inversion H4; subst; clear H4.
       + inversion H2; subst; clear H2.
         inversion H3; subst; clear H3.
         -- inversion H5.
         -- inversion H0; subst; clear H0.
            inversion H5.
       + inversion H2; subst; clear H2.
         inversion H5.
    * inversion H0; subst; clear H0. inversion H5.

Qed.

(**

Function size counts how many operators were used in a regular
expression. Show that (c ;; {})* can be written using a single
regular expression constructor.

 *)
Theorem ex3:
  exists r, size r = 1 /\ (r_star ( "c" ;; r_void ) <==> r).
Proof.
  exists r_nil.
  split.
  - reflexivity.
  - rewrite r_app_r_void_rw.
    apply r_star_void_rw.

Qed.

(**

Given that the following regular expression uses 530 constructors
(because size r_all = 514).
Show that you can find an equivalent regular expression that uses
at most 6 constructors.

 *)
(* Using lecture 11*)
Theorem ex4:
  exists r, size r <= 6 /\  ((r_star ( (r_all || r_star "c" ) ;; r_void) ;; r_star ("a" || "b")) ;; r_star r_nil;; "c" <==> r).
Proof.
  exists (r_star ("a" || "b") ;; "c").
  split.
  - reflexivity.
  - Search (r_void).
    rewrite r_app_r_void_rw.
    rewrite r_star_void_rw.
    rewrite r_star_nil_rw.
    rewrite r_app_l_nil_rw.
    rewrite r_app_r_nil_rw.
    reflexivity.
Qed.
(**

The following code implements a function that given a string
it returns a regular expression that only accepts that string.

    Fixpoint r_word' l :=
    match l with
    | nil => r_nil
    | x :: l => (r_char x) ;; r_word' l
    end.

Prove that function `r_word'` is correct.
Note that you must copy/paste the function to outside of the comment
and in your proof state: exists r_word'.

The proof must proceed by induction.

 *)
 Fixpoint r_word' l :=
    match l with
    | nil => r_nil
    | x :: l => (r_char x) ;; r_word' l
    end.

Theorem ex5:
  forall l, exists (r_word:list ascii -> regex), Accept (r_word l) == fun w => w = l.
Proof.
  exists r_word'.
  induction l.
  - simpl.
    unfold Equiv.
    split; intros.
    + inversion H.
      apply nil_in.
    + inversion H.
      subst.
      rewrite r_nil_rw.
      apply H.
  - unfold Equiv.
    split; intros.
    + inversion H; subst; clear H.
      inversion H2; subst; clear H2.
      destruct IHl with (w:=s2).
      intuition.
      rewrite H1.
      reflexivity.
    + unfold In in *.
      rewrite H.
      apply accept_app with (s1:=[a]) (s2:=l).
      * apply accept_char.
      * apply IHl.
        unfold In.
        reflexivity.
      * reflexivity.
Qed.

(**

Show that there exists a regular expression with 5 constructs that
recognizes the following language. The idea is to find the smallest
regular expression that recognizes the language.

 *)
Theorem ex6:
  exists r, (Accept r == fun w => w = ["a"; "c"] \/ w = ["b"; "c"]) /\ size r = 5.
Proof.
  exists (("a" || "b");;"c").
  split.
  - split; intros.
    + apply r_app_union_distr_l in H.
      inversion H; subst; clear H.
      * left.
        inversion H3; subst; clear H3.
        inversion H1; subst; clear H1.
        inversion H2; subst; clear H2.
        reflexivity.
      * right.
        inversion H3; subst; clear H3.
        inversion H1; subst; clear H1.
        inversion H2; subst; clear H2.
        reflexivity.
    + inversion H.
      * apply r_app_union_distr_l.
        unfold In.
        apply accept_union_l.
        apply accept_app with (s1:=["a"]) (s2:=["c"]).
         -- apply accept_char.
         -- apply accept_char.
         -- rewrite H0.
           reflexivity.
      * apply r_app_union_distr_l.
         unfold In.
         apply accept_union_r.
         apply accept_app with (s1:=["b"]) (s2:=["c"]).
         -- apply accept_char.
         -- apply accept_char.
         -- rewrite H0.
            reflexivity.
  - reflexivity.
Qed.


From GameTheory Require Import In ImpartialGame Boolgroup SumGames Equiv Nim.
Require Import Lia.
Require Import BinNat.

Definition mx_N_list (l : list N) : N := fold_right N.max 0 l.
Check list_max_le.
Lemma max_lt : forall (l : list N) (n : N),
    mx_N_list l < n ->
    Forall (fun k => k < n) l.
Proof.
  induction l; auto.
  intros n H.
  simpl in H.
  constructor.
  lia.
  apply IHl.
  lia.
Qed.

Section Mex.
  Variable l : list N.
  Definition is_mex (m : N) :=
    (forall n, n < m -> In n l) /\ ~ In m l.

  (* We do not use this lemma, but this gives us some confidence that mex is in fact *)
  (* a well-defined function, rather than just a relation between lists and Ns. *)
  Lemma mex_unique : forall m m',
      is_mex m -> is_mex m' -> m = m'.
  Proof using l.
    intros.
    repeat (match goal with
            | H : is_mex ?x |- _ => destruct H as [? ?]
            end).
    destruct (N.lt_trichotomy m m') as [? | [? | ?]];
    repeat (match goal with
    | E : ?x < ?y, H1 : forall n, n < ?y -> In n l, H2 : ~ In ?x l |- _ =>
      specialize H1 with x; apply H2 in H1; auto; contradiction
    | |- _ => auto
    end).
  Qed.

  Lemma not_in_dec : forall x, {In x l} + {~ In x l}.
  Proof.
    intros x.
    destruct (in_dec N.eq_dec x l); auto.
  Defined.

  Lemma mex_bound : { m | ~ In m l}.
    constructor 1 with (mx_N_list l + 1).
    pose proof (max_lt l (mx_N_list l + 1)).
    rewrite Forall_forall in H.
    unfold not; intros.
    apply H in H0; lia.
  Defined.

  Definition mex_defn : { m | is_mex m }.
  Proof.
    destruct mex_bound as [b H].
    enough (forall k, (forall x, x <= k -> In x l) + { m | m <= k /\ is_mex m }) as IH.
    {
    destruct (IH b) as [? | ?].
    - specialize i with b.
        apply H in i. contradiction. lia.
    - destruct s as [m [? Hm]].
      constructor 1 with m. assumption.
    }
    refine (N.peano_rect _ _ _); intros.
    - destruct (not_in_dec 0).
      + left. intros. assert (x = 0). lia. rewrite H1. auto.
      + right. constructor 1 with 0; unfold is_mex; intuition; lia.
    - destruct H0 as [? | ?].
      + destruct (not_in_dec (N.succ n)).
        * left; intros. assert (x <= n \/ x = N.succ n). lia.
          destruct H1; auto.
          rewrite H1. auto.
        * right. constructor 1 with (N.succ n); unfold is_mex; intuition.
          assert (n1 <= n). lia. apply i; auto.
      + destruct s as [m [? ?]].
        right. constructor 1 with m; intuition; lia.
  Defined.

  Definition mex : N := let (m, _) := mex_defn in m.
  Lemma mex_lt : (forall n, n < mex -> In n l).
    unfold mex.
    destruct mex_defn as [? [? ?]].
    auto.
  Qed.

  Lemma mex_neq :  ~ In (mex) l.
    unfold mex.
    destruct mex_defn as [? [? ?]].
    auto.
  Qed.
End Mex.

Compute (mex [0; 1; 2; 3; 4; 6]).

Section Grundy.
  Variable g : impartial_game.

  Definition grundy : position g -> N :=
    Fix (finite_game g)
      (fun _ => N)
      (fun x F => mex (map_In (moves g x) (fun y P => F y P))).

  Lemma grundy_unfold : forall s,
      grundy s = mex (map grundy (moves g s)).
    intros.
    unfold grundy.
    rewrite Fix_eq.
    apply f_equal.
    rewrite map_In_map with (g := Fix (finite_game g) (fun _ : position g => N)
       (fun (x : position g) (F : forall y : position g, valid_move g y x -> N) =>
          mex (map_In (moves g x) (fun (y : position g) (P : In y (moves g x)) => F y P)))).
    reflexivity.
    reflexivity.
    intros. apply f_equal. apply map_In_ext; auto.
  Qed.

  Lemma grundy_moves_valid : forall s s', valid_move g s' s -> In (grundy s') (map grundy (moves g s)).
    intros.
    unfold valid_move in H.
    apply (in_map grundy) in H.
    assumption.
  Qed.

  Lemma grundy_moves : forall s s',
      valid_move g s' s ->
      grundy s' < grundy s \/ grundy s < grundy s'.
    intros.
    destruct (N.lt_trichotomy (grundy s') (grundy s)) as [? | [? | ?]]; auto.
    apply grundy_moves_valid in H.
    rewrite H0 in H.
    rewrite grundy_unfold in H.
    apply mex_neq in H.
    contradiction.
  Qed.

  Lemma grundy_moves_lt : forall n s,
      n < grundy s ->
      exists s', valid_move g s' s /\ grundy s' = n.
    intros.
    rewrite grundy_unfold in H.
    apply mex_lt in H.
    apply in_map_iff in H as [s' [? ?]].
    exists s'; auto.
  Qed.

  Definition grundy_game : N := grundy (start g).

  Theorem sg_theorem : g == Nim (grundy_game).
    enough (forall s, forall n, losing_state (g ~+~ (Nim n)) (s, grundy s)).
    - unfold equiv. apply H.
    - refine (well_founded_induction (wf_trans _ _ (finite_game g)) _ _).
      intros.
      constructor; intros.
      apply moves_in_game_sum in H0 as [[? ?] | [? ?]].
      + destruct s'; simpl in *; subst.
        pose proof H0 as ?.
        apply grundy_moves in H0 as [H0 | H0].
        (* If our move is to a state with lower grundy number, *)
        (* make corresponding move on right side. *)
        * apply trans_to_losing with (p, grundy p).
          apply moves_in_game_sum; right; simpl; intuition.
          apply nim_moves_spec; assumption.
          apply H; constructor; assumption.
        (* If our move is to a state with higher grundy number, *)
        (* move back to state with original grundy value on left side *)
        * destruct (grundy_moves_lt _ _ H0) as [p' [? ?]].
          apply trans_to_losing with (p', grundy x).
          apply moves_in_game_sum; left; simpl; intuition.
          rewrite <- H3.
          apply H. constructor 2 with p; assumption.
      + destruct s'; simpl in *; subst.
        apply nim_moves_spec in H0.
        destruct (grundy_moves_lt _ _ H0) as [p' [? ?]].
        apply trans_to_losing with (p', p0).
        apply moves_in_game_sum; left; simpl; intuition.
        rewrite <- H2.
        apply H; constructor; assumption.
  Qed.
End Grundy.

Theorem sg_sum : forall g h, g ~+~ h == Nim (N.lxor (grundy_game g) (grundy_game h)).
  intros.
  rewrite (sg_theorem g) at 1.
  rewrite (sg_theorem h) at 1.
  apply nim_sum_equiv.
Qed.

Print Assumptions sg_sum.


Require Import init.

Require Export plus_group.

#[universes(template)]
Class Mult U := {
    mult : U → U → U;
}.
Infix "*" := mult : algebra_scope.

Class Ldist U `{Plus U} `{Mult U} := {
    ldist : ∀ a b c, a * (b + c) = a * b + a * c;
}.
Class Rdist U `{Plus U} `{Mult U} := {
    rdist : ∀ a b c, (a + b) * c = a * c + b * c;
}.

Class MultAssoc U `{Mult U} := {
    mult_assoc : ∀ a b c, a * (b * c) = (a * b) * c;
}.
Class MultComm U `{Mult U} := {
    mult_comm : ∀ a b, a * b = b * a;
}.

Class MultLanni U `{Zero U, Mult U} := {
    mult_lanni : ∀ a, 0 * a = 0;
}.
Class MultRanni U `{Zero U, Mult U} := {
    mult_ranni : ∀ a, a * 0 = 0;
}.

#[universes(template)]
Class One U := {
    one : U;
}.
Notation "1" := one : algebra_scope.
Notation "- 1" := (-(1)) : algebra_scope.
Class MultLid U `{Mult U, One U} := {
    mult_lid : ∀ a, 1 * a = a;
}.
Class MultRid U `{Mult U, One U} := {
    mult_rid : ∀ a, a * 1 = a;
}.

Class MultLcancel U `{Zero U, Mult U} := {
    mult_lcancel : ∀ {a b} c, 0 ≠ c → c * a = c * b → a = b;
}.
Class MultRcancel U `{Zero U, Mult U} := {
    mult_rcancel : ∀ {a b} c, 0 ≠ c → a * c = b * c → a = b;
}.

Class Rng U `{
    RP : AllPlus U,
    UM : Mult U,
    UL : @Ldist U UP UM,
    UR : @Rdist U UP UM,
    UMA : @MultAssoc U UM
}.

Class Ring U `{
    RR : Rng U,
    UE : @One U,
    UME : @MultLid U UM UE,
    UMER : @MultRid U UM UE
}.

Class CRing U `{
    CRR : Ring U,
    UMC : @MultComm U UM
}.

Class IntegralDomain U `{
    IDR : CRing U,
    UML : @MultLcancel U UZ UM,
    UMR : @MultRcancel U UZ UM
}.

Class AllMult U `{
    AMI : IntegralDomain U,
    UZL : @MultLanni U UZ UM,
    UZR : @MultRanni U UZ UM
}.

Class HomomorphismMult {U V} `{Mult U, Mult V} (f : U → V) := {
    homo_mult : ∀ a b, f (a * b) = f a * f b
}.

Class HomomorphismOne {U V} `{One U, One V} (f : U → V) := {
    homo_one : f 1 = 1
}.

Arguments mult : simpl never.
Arguments one : simpl never.

Notation "2" := (one + 1) : algebra_scope.
Notation "3" := (one + 2) : algebra_scope.
Notation "4" := (one + 3) : algebra_scope.
Notation "5" := (one + 4) : algebra_scope.
Notation "6" := (one + 5) : algebra_scope.
Notation "7" := (one + 6) : algebra_scope.
Notation "8" := (one + 7) : algebra_scope.
Notation "9" := (one + 8) : algebra_scope.
Notation "- 2" := (-(2)) : algebra_scope.
Notation "- 3" := (-(3)) : algebra_scope.
Notation "- 4" := (-(4)) : algebra_scope.
Notation "- 5" := (-(5)) : algebra_scope.
Notation "- 6" := (-(6)) : algebra_scope.
Notation "- 7" := (-(7)) : algebra_scope.
Notation "- 8" := (-(8)) : algebra_scope.
Notation "- 9" := (-(9)) : algebra_scope.

(* begin hide *)
Section MultRingImply.

Context {U} `{AllMult U}.

Global Instance mult_lid_rid : MultRid U.
Proof.
    split.
    intros a.
    rewrite mult_comm.
    apply mult_lid.
Qed.

Global Instance mult_lcancel_rcancel : MultRcancel U.
Proof.
    split.
    intros a b c neq eq.
    do 2 rewrite (mult_comm _ c) in eq.
    apply mult_lcancel with c; [>exact neq|].
    exact eq.
Qed.

Global Instance mult_lanni_ranni : MultRanni U.
Proof.
    split.
    intros a.
    rewrite mult_comm.
    apply mult_lanni.
Qed.

Global Instance ldist_rdist : Rdist U.
Proof.
    split.
    intros a b c.
    do 3 rewrite (mult_comm _ c).
    apply ldist.
Qed.

End MultRingImply.

Section MultRing.

Context {U} `{AllMult U, NotTrivial U}.

(* end hide *)
Theorem lmult : ∀ {a b} c, a = b → c * a = c * b.
Proof.
    intros a b c ab.
    apply f_equal.
    exact ab.
Qed.
Theorem rmult : ∀ {a b} c, a = b → a * c = b * c.
Proof.
    intros a b c ab.
    rewrite ab.
    reflexivity.
Qed.
Theorem lrmult : ∀ {a b c d}, a = b → c = d → a * c = b * d.
Proof.
    intros a b c d ab cd.
    rewrite ab, cd.
    reflexivity.
Qed.

Theorem not_trivial_one : 0 ≠ 1.
Proof.
    intros contr.
    pose proof not_trivial_zero as [a a_nz].
    apply rmult with a in contr.
    rewrite mult_lanni in contr.
    rewrite mult_lid in contr.
    contradiction.
Qed.

Global Instance ring_mult_lanni : MultLanni U.
Proof.
    split.
    intros a.
    apply plus_rcancel with (0 * a).
    rewrite <- rdist.
    do 2 rewrite plus_lid.
    reflexivity.
Qed.
Global Instance ring_mult_ranni : MultRanni U.
Proof.
    split.
    intros a.
    apply plus_lcancel with (a * 0).
    rewrite <- ldist.
    do 2 rewrite plus_rid.
    reflexivity.
Qed.

Theorem mult_lneg : ∀ a b, -a * b = -(a * b).
Proof.
    intros a b.
    apply plus_lcancel with (a * b).
    rewrite <- rdist.
    do 2 rewrite plus_rinv.
    apply mult_lanni.
Qed.
Theorem mult_rneg : ∀ a b, a * -b = -(a * b).
Proof.
    intros a b.
    apply plus_lcancel with (a * b).
    rewrite <- ldist.
    do 2 rewrite plus_rinv.
    apply mult_ranni.
Qed.
Theorem mult_lrneg : ∀ a b, -a * b = a * -b.
Proof.
    intros a b.
    rewrite mult_lneg, mult_rneg.
    reflexivity.
Qed.

Theorem mult_neg_one : ∀ a, -1 * a = -a.
Proof.
    intros a.
    rewrite mult_lneg.
    rewrite mult_lid.
    reflexivity.
Qed.

Theorem neg_nz : ∀ a, 0 ≠ a ↔ 0 ≠ -a.
Proof.
    intros a.
    split; intros neq eq.
    -   apply (f_equal neg) in eq.
        rewrite neg_neg, neg_zero in eq.
        contradiction.
    -   rewrite <- eq in neq.
        rewrite neg_zero in neq.
        contradiction.
Qed.

Theorem plus_two : ∀ a, a + a = 2*a.
Proof.
    intros a.
    rewrite <- (mult_lid a) at 1 2.
    rewrite <- rdist.
    reflexivity.
Qed.

Theorem two_plus_two : 2 + 2 = 4.
Proof.
    rewrite <- plus_assoc.
    reflexivity.
Qed.

Theorem two_times_two : 2 * 2 = 4.
Proof.
    rewrite ldist.
    rewrite mult_rid.
    exact two_plus_two.
Qed.

Theorem dif_squares : ∀ a b, a*a - b*b = (a + b) * (a - b).
Proof.
    intros a b.
    rewrite rdist.
    do 2 rewrite ldist.
    do 2 rewrite mult_rneg.
    rewrite (mult_comm b a).
    rewrite <- plus_assoc.
    rewrite plus_llinv.
    reflexivity.
Qed.

Theorem mult_zero : ∀ a b, 0 = a * b → 0 = a ∨ 0 = b.
Proof.
    intros a b eq.
    classic_case (0 = a) as [a_z|a_nz].
    -   left.
        exact a_z.
    -   right.
        apply mult_lcancel with a; [>exact a_nz|].
        rewrite mult_ranni.
        exact eq.
Qed.

Theorem mult_nz : ∀ a b, 0 ≠ a → 0 ≠ b → 0 ≠ a * b.
Proof.
    intros a b neq1 neq2 contr.
    apply mult_zero in contr.
    destruct contr; contradiction.
Qed.

(* begin hide *)
End MultRing.

Section MultHomo.

Context {U V} `{AllMult U, AllMult V}.
(* end hide *)
Context (f : U → V) `{
    @Injective U V f,
    @HomomorphismPlus U V UP UP0 f,
    @HomomorphismZero U V UZ UZ0 f,
    @HomomorphismNeg U V UN UN0 f,
    @HomomorphismMult U V UM UM0 f,
    @HomomorphismOne U V UE UE0 f
}.

Theorem homo_two : f 2 = 2.
Proof.
    setoid_rewrite homo_plus.
    rewrite homo_one.
    reflexivity.
Qed.

Theorem homo_three : f 3 = 3.
Proof.
    setoid_rewrite homo_plus.
    rewrite homo_one, homo_two.
    reflexivity.
Qed.

Theorem homo_four : f 4 = 4.
Proof.
    setoid_rewrite homo_plus.
    rewrite homo_one, homo_three.
    reflexivity.
Qed.

(* begin hide *)
End MultHomo.
(* end hide *)
Tactic Notation "mult_bring_left" constr(x) :=
    repeat rewrite mult_assoc;
    repeat rewrite (mult_comm _ x);
    repeat rewrite <- mult_assoc.
Tactic Notation "mult_bring_left" constr(x) "in" ident(H) :=
    repeat rewrite mult_assoc in H;
    repeat rewrite (mult_comm _ x) in H;
    repeat rewrite <- mult_assoc in H.
Tactic Notation "mult_bring_right" constr(x) :=
    repeat rewrite <- mult_assoc;
    repeat rewrite (mult_comm x _);
    repeat rewrite mult_assoc.
Tactic Notation "mult_bring_right" constr(x) "in" ident(H) :=
    repeat rewrite <- mult_assoc in H;
    repeat rewrite (mult_comm x _) in H;
    repeat rewrite mult_assoc in H.


Require Export GeoCoq.Elements.OriginalProofs.lemma_ABCequalsCBA.
Require Export GeoCoq.Elements.OriginalProofs.lemma_equalanglestransitive.

Section Euclid.

Context `{Ax:euclidean_neutral_ruler_compass}.

Lemma lemma_equalanglesreflexive :
   forall A B C,
   nCol A B C ->
   CongA A B C A B C.
Proof.
intros.
assert (CongA A B C C B A) by (conclude lemma_ABCequalsCBA).
assert (nCol C B A) by (conclude lemma_equalanglesNC).
assert (CongA C B A A B C) by (conclude lemma_ABCequalsCBA).
assert (CongA A B C A B C) by (conclude lemma_equalanglestransitive).
close.
Qed.

End Euclid.


Require Import Arith.

Theorem nat_ind_le : forall P : nat -> Prop,
    P 0 -> (forall n, (forall m, m <= n -> P m) -> P (S n))
    -> forall n, P n.
Proof.
  intros P HP0 HPi.
  set (Q n := forall m, m <= n -> P m).
  assert (forall n : nat, Q n).
    intros.
    induction n.
      unfold Q.
      intros.
      inversion H. exact HP0.

      unfold Q.
      intros.
      apply le_lt_eq_dec in H.
      destruct H as [Hl | Heq].
        unfold lt in Hl. apply le_S_n in Hl.
        apply IHn. exact Hl.

        rewrite Heq.
        apply HPi.
        exact IHn.

  intro.
  apply (H n).
  apply le_n.
Qed.

Ltac induction_le_nat n := let IHn := fresh "IH" n in
  try intros until n; pattern n; apply nat_ind_le; clear n; [ | intros n IHn ].

Theorem nat_ind_lt : forall P : nat -> Prop,
    (forall n, (forall m, m < n -> P m) -> P n)
    -> forall n, P n.
Proof.
  intros P HPi.
  set (Q n := forall m, m <= n -> P m).
  assert (forall n : nat, Q n).
    intros.
    induction n.
      unfold Q.
      intros.
      inversion H.
      apply HPi.
      intros.
      contradict H1.
      apply lt_n_0.

      unfold Q.
      intros.
      apply le_lt_eq_dec in H.
      destruct H as [Hl | Heq].
        unfold lt in Hl. apply le_S_n in Hl.
        apply IHn. exact Hl.

        rewrite Heq.
        apply HPi.
        intros.
        apply le_S_n in H.
        apply IHn. exact H.

  intro.
  apply (H n).
  apply le_n.
Qed.

Ltac induction_lt_nat n := let IHn := fresh "IH" n in
  try intros until n; pattern n; apply nat_ind_lt; clear n; intros n IHn.

Theorem nat_pred_interval_dec : forall P : nat -> Prop, (forall n, {P n} + {~ P n})
    -> forall n m, {exists k, n <= k < m /\ P k} + {forall k, n <= k < m -> ~ P k}.
Proof.
  intros.
  induction m.
    right.
    intros.
    destruct H0.
    inversion H1.

    destruct (le_lt_dec n m) as [Hnm | Hmn].
    (* Case where n <= m *)
    destruct IHm as [Heg | Hnall].
      left.
      destruct Heg as [k [Hnkm HPk]].
      exists k.
      split. destruct Hnkm as [Hnk Hkm]. split. assumption.
      apply le_S. apply Hkm. assumption.

      destruct (H m) as [HPm | HnPm].
      left. exists m.
      split. split. assumption. apply le_n. assumption.

      right.
      intros.
      destruct H0 as [Hnk Hkm].
      apply le_lt_eq_dec in Hkm.
      destruct Hkm as [Hkm | Hkm].
        apply Hnall. split. assumption.
        apply lt_S_n; assumption.

        inversion Hkm. assumption.

    (* Case where m < n *)
    right. clear H. clear IHm.
    intros. exfalso.
    assert (n <= m). destruct H as [Hnk Hkm].
    apply le_S_n in Hkm.
    apply le_trans with (m := k); assumption.
    (* SearchAbout (_<=_ -> ~_<_). *)
    revert Hmn. apply le_not_lt. assumption.
Qed.

Theorem exists__not_forall_not : forall (S : Set) (P Q : S -> Prop),
    (exists x : S, Q x /\ P x) -> ~ forall x : S, Q x -> ~ P x.
Proof.
  intros.
  intro.
  destruct H as [x [Qx Px]].
  unfold not in H0. apply H0 with (x := x) ; assumption.
Qed.