(** * Define Group with Setoid *)

Require Import Relation_Definitions Setoid Morphisms.
Require Import Arith Omega.

(** ** Example : define Z with two nat-s *)
Inductive Z' : Set :=
| mkZ' : nat -> nat -> Z'.

Definition eq'(z1 z2:Z') : Prop :=
  match z1,z2 with
  | (mkZ' p1 n1),(mkZ' p2 n2) => (p1+n2 = p2+n1)
  end.

Definition minus'(z:Z') :=
  match z with
  | mkZ' a b => mkZ' b a
  end.

Definition plus'(z1 z2:Z') :=
  match z1,z2 with
  | (mkZ' a1 b1),(mkZ' a2 b2) => (mkZ' (a1+a2) (b1+b2))
  end.

(** eq' is equivalence *)
Lemma refl_eq' : reflexive _ eq'.
Proof.
unfold reflexive. intro z. destruct z as [a b].
unfold eq'. omega.
Qed.
Lemma sym_eq' : symmetric _ eq'.
Proof.
unfold symmetric. intros z1 z2 H.
destruct z1 as [a1 b1]. destruct z2 as [a2 b2].
unfold eq' in *. omega.
Qed.
Lemma trans_eq' : transitive _ eq'.
Proof.
unfold transitive. intros z1 z2 z3 H12 H23.
destruct z1 as [a1 b1].
destruct z2 as [a2 b2]. destruct z3 as [a3 b3].
unfold eq' in *. omega.
Qed.

(** Z' with eq' is setoid *)
Add Parametric Relation : Z' eq'
  reflexivity proved by refl_eq'
  symmetry proved by sym_eq'
  transitivity proved by trans_eq' as Z'_setoid.

(** minus' is well-defined *)
Add Parametric Morphism :
  minus' with signature (eq' ==> eq') as minus'_mor.
Proof.
intros z1 z2 H.
destruct z1 as [a1 b1]; destruct z2 as [a2 b2].
unfold minus'. unfold eq' in *. omega.
Qed.

(** plus' is well-defined *)
Add Parametric Morphism :
  plus' with signature (eq' ==> eq' ==> eq') as plus'_mor.
Proof.
intros x1 y1 H1 x2 y2 H2.
destruct x1; destruct y1; destruct x2; destruct y2.
unfold plus; unfold eq' in *. simpl. omega.
Qed.

(** Define group with decidable setoid and morphisms *)
Class Group {S:Set}(eq:S->S->Prop)
  (e:S)(inv:S->S)(op:S->S->S) := {
  equiv : Equivalence eq ;
  equiv_dec :
    forall x y:S, {eq x y} + {~(eq x y)} ;
  inv_mor :
    forall x y:S, eq x y -> eq (inv x) (inv y) ;
  op_mor :
    forall x1 y1 x2 y2:S, eq x1 y1 -> eq x2 y2 ->
    eq (op x1 x2) (op y1 y2) ;
  op_assoc :
    forall x y z:S, eq (op (op x y) z) (op x (op y z)) ;
  left_unit :
    forall x:S, eq (op e x) x ;
  right_unit :
    forall x:S, eq (op x e) x ;
  left_inv :
    forall x:S, eq (op (inv x) x) e ;
  right_inv :
    forall x:S, eq (op x (inv x)) e
}.

(** Example *)
Instance Z'_group : Group eq' (mkZ' O O) minus' plus'.
Proof.
apply Build_Group.
        (* equiv *)
        apply Z'_setoid.
       (* equiv_dec *)
       intros x y; destruct x; destruct y.
       unfold eq'. eapply eq_nat_dec.
      (* inv_mor *)
      apply minus'_mor.
     (* op_mor *)
     intros; eapply plus'_mor; assumption.
    (* op_assoc *)
    intros; destruct x; destruct y; destruct z;
    unfold plus'; unfold eq'; omega.
   (* left_unit *)
   intros; destruct x; unfold plus'; unfold eq'; omega.
  (* right_unit *)
  intros; destruct x; unfold plus'; unfold eq'; omega.
 (* left_inv *)
 intros; destruct x; unfold minus'; unfold plus';
 unfold eq'; omega.
(* right_inv *)
intros; destruct x; unfold minus'; unfold plus';
unfold eq'; omega.
Defined.


Require Import AB.Imp9.
Require Import Coq.ZArith.ZArith.
Require Import Coq.Lists.List.

Open Scope Z.

Module Polynomial.
Import Assertion_D.

(** Definitions of poly *)
Definition poly := list Z. (* The power increases as the index goes up *)

Definition ZERO : poly := nil.
Definition CONSTANT : poly := 1::nil.
Definition LINEAR : poly := 0::1::nil.
Definition QUADRATIC : poly := 0::0::1::nil.
Definition CUBIC : poly := 0::0::0::1::nil.
(** [] *)

(** Evaluations of polynomial *)
Fixpoint poly_eval (p : poly) : Z -> Z :=
  fun z =>
    match p with
    | nil => 0
    | h :: t => h + z * (poly_eval t z)
    end.

Open Scope term_scope.
Print aexp'.

Fixpoint TPower (v : logical_var) (n : nat) : term :=
  match n with
  | O => 1
  | S n' => v * (TPower v n')
  end.

Fixpoint poly_eval_lv (p : poly) : logical_var -> term :=
  fun v =>
    match p with
    | nil => 0
    | h :: t => h + v * (poly_eval_lv t v)
    end.

Close Scope term_scope.
(** [] *)

(** Operations of polynomial *)
Fixpoint poly_add (p1 p2 : poly) : poly :=
  match p1, p2 with
  | nil, nil => nil
  | h::t, nil => h::t
  | nil, h::t => h::t
  | h::t, h'::t' => (h+h')::(poly_add t t')
  end.

Fixpoint trim_0 (p : poly) : poly :=
  match p with
  | nil => nil
  | h :: t => match trim_0 t with
              | nil => if Z.eq_dec h 0 then nil else h :: nil
              | _ => h :: trim_0 t
              end
  end.

Fixpoint poly_scalar_mult (k : Z) (p : poly) : poly :=
  match p with
  | nil => nil
  | h :: t => k * h :: poly_scalar_mult k t
  end.

Fixpoint poly_mult (p1 p2 : poly) : poly :=
  match p1, p2 with
  | nil, _ => nil
  | _, nil => nil
  | h :: t, _ => poly_add (poly_scalar_mult h p2) (0 :: (poly_mult t p2))
  end.

Notation "p '+++' q" := (poly_add p q) (at level 60).
Notation "k ** p" := (poly_scalar_mult k p) (at level 60).
Notation "p '***' q" := (poly_mult p q) (at level 60).

Section Examples.

Example poly_add_eg : poly_eval ((CONSTANT +++ LINEAR) +++ (CONSTANT +++ QUADRATIC)) 2 = 8.
Proof.
  simpl. reflexivity.
Qed.

Example poly_mult_eg : poly_eval ((CONSTANT +++ LINEAR) *** (CONSTANT +++ QUADRATIC)) 2 = 15.
Proof.
  simpl. reflexivity.
Qed.

End Examples.
(** [] *)

(** Properties of Shorthand Notations *)
Fact CONSTANT_spec : forall z, poly_eval CONSTANT z = 1.
Proof.
  intros.
  simpl.
  rewrite Z.mul_0_r.
  reflexivity.
Qed.

Fact LINEAR_spec : forall z, poly_eval LINEAR z = z.
Proof.
  intros.
  simpl.
  rewrite Z.mul_0_r.
  omega.
Qed.

Fact QUADRATIC_spec : forall z, poly_eval QUADRATIC z = z*z.
Proof.
  intros.
  simpl.
  rewrite Z.mul_0_r.
  ring.
Qed.

Fact CUBIC_spec : forall z, poly_eval CUBIC z = z*z*z.
Proof.
  intros.
  simpl.
  rewrite Z.mul_0_r.
  ring.
Qed.
(** [] *)

(** Properties of Polynomial Operations *)
Lemma poly_add_nil_l : forall p, poly_add nil p = p.
Proof.
  intros.
  destruct p.
  - auto.
  - simpl. reflexivity.
Qed.

Lemma poly_add_nil_r : forall p, poly_add p nil = p.
Proof.
  intros.
  destruct p.
  - auto.
  - simpl. reflexivity.
Qed.

Lemma poly_mult_nil_l : forall p, poly_mult nil p = nil.
Proof.
  intros.
  simpl.
  reflexivity.
Qed.

Lemma poly_mult_nil_r : forall p, poly_mult p nil = nil.
Proof.
  intros.
  destruct p; auto.
Qed.

Lemma poly_eval_zero: forall n z,
  poly_eval (repeat 0 n) z = 0.
Proof.
  intros.
  induction n.
  - simpl. reflexivity.
  - simpl. rewrite IHn. omega.
Qed.

Theorem poly_add_spec : forall (p1 p2 : poly) (z : Z),
  poly_eval (poly_add p1 p2) z = poly_eval p1 z + poly_eval p2 z.
Proof.
  intro.
  induction p1; intros.
  - rewrite poly_add_nil_l. simpl. reflexivity.
  - destruct p2.
    + simpl. omega.
    + simpl. rewrite IHp1.
      rewrite Z.mul_add_distr_l. omega.
Qed.

Theorem poly_scalar_mult_spec : forall (k : Z) (p : poly) (z : Z),
  poly_eval (poly_scalar_mult k p) z = k * poly_eval p z.
Proof.
  intros.
  induction p.
  - simpl. rewrite Z.mul_0_r. reflexivity.
  - simpl. rewrite IHp. ring.
Qed.

Theorem poly_mult_spec : forall (p1 p2 : poly) (z : Z),
  poly_eval (poly_mult p1 p2) z = poly_eval p1 z * poly_eval p2 z.
Proof.
  intro.
  induction p1; intros.
  - auto.
  - destruct p2.
    + simpl. rewrite Z.mul_0_r. reflexivity.
    + simpl.
      rewrite poly_add_spec. rewrite IHp1.
      rewrite poly_scalar_mult_spec. simpl.
      ring.
Qed.

Theorem trim_invar:
  forall p z,
  poly_eval (trim_0 p) z = poly_eval p z.
Proof.
  intro.
  induction p; intros.
  - auto.
  - simpl.
    destruct (trim_0 p) eqn:eqp.
    + destruct (Z.eq_dec a 0) eqn:eqa; rewrite <- IHp; simpl; omega.
    + rewrite <- eqp in *.
      simpl. rewrite IHp. reflexivity.
Qed.

Lemma poly_eval_cons : forall (p: poly) (a z : Z),
  poly_eval (a :: p) z = a + z * (poly_eval p z).
Proof.
  simpl.
  reflexivity.
Qed.

Lemma poly_eval_nil : forall (z : Z),
  poly_eval nil z = 0.
Proof.
  intros.
  simpl.
  reflexivity.
Qed.

Lemma poly_eval_app : forall (p1 p2 : poly) (z : Z),
  poly_eval (p1 ++ p2) z = poly_eval p1 z + (z^(Z.of_nat (length p1))) * (poly_eval p2 z).
Proof.
  intros. induction p1.
  - assert (Z.of_nat (Datatypes.length (nil:poly)) = 0). auto.
    rewrite app_nil_l.
    rewrite H. rewrite Z.pow_0_r.
    pose proof poly_eval_nil z. rewrite H0.
    omega.
  - rewrite <- app_comm_cons.
    pose proof poly_eval_cons (p1 ++ p2) a z.
    rewrite H. clear H. rewrite IHp1.
    rewrite Z.mul_add_distr_l.
    assert (z * (z ^ Z.of_nat (Datatypes.length p1)) = z ^ Z.of_nat (Datatypes.length (a :: p1))).
    {
      pose proof Z.pow_1_r z. rewrite <- H at 1.
      pose proof Z.pow_add_r z 1 (Z.of_nat (Datatypes.length p1)).
      assert (0 <= 1). omega.
      assert (0 <= Z.of_nat (Datatypes.length p1)).
      {
        clear IHp1 H H0 H1.
        induction p1.
        - simpl. omega.
        - simpl. apply Zle_0_pos.
      }
      pose proof H0 H1 H2.
      rewrite <- H3.
      assert (1 + Z.of_nat (Datatypes.length p1) = Z.of_nat (Datatypes.length (a :: p1))).
      {
        clear IHp1 H H0 H1 H2 H3.
        pose proof Nat2Z.inj_add 1 (length p1).
        assert (Z.of_nat 1 = 1). auto.
        rewrite <- H0.
        rewrite <- H.
        pose proof inj_eq (1 + (length p1)) (length (a::p1)).
        assert ((1 + Datatypes.length p1)%nat = Datatypes.length (a :: p1)). auto.
        omega.
      }
      rewrite H4.
      omega.
    }
    rewrite <- H.
    pose proof poly_eval_cons p1 a z.
    rewrite H0.
    rewrite Z.mul_assoc.
    omega.
Qed.

Lemma poly_eval_add_zero_l: forall (p : poly) n z,
  poly_eval (poly_add (repeat 0 n) p) z = poly_eval p z.
Proof.
  intros.
  rewrite poly_add_spec.
  rewrite poly_eval_zero.
  omega.
Qed.

Lemma poly_eval_add_zero_r: forall (p : poly) n z,
  poly_eval (poly_add p (repeat 0 n)) z = poly_eval p z.
Proof.
  intros.
  rewrite poly_add_spec.
  rewrite poly_eval_zero.
  omega.
Qed.

Lemma poly_add_comm: forall p1 p2,
  poly_add p1 p2 = poly_add p2 p1.
Proof.
  intro.
  induction p1; intros.
  - rewrite poly_add_nil_l, poly_add_nil_r. reflexivity.
  - destruct p2.
    + auto.
    + simpl.
      rewrite IHp1.
      rewrite Z.add_comm.
      reflexivity.
Qed.
(** [] *)

(* Dealing with the coef *)
Fixpoint poly_coef_sum (p : poly) : Z :=
  match p with
  | nil => 0
  | h::t => h + (poly_coef_sum t)
  end.

End Polynomial.

Module Polynomial'.
Export Polynomial.
Import Assertion_D.

Definition poly' := list Z. (* The power decreases as the index goes up *)

(** Evaluations of polynomial' *)
Fixpoint poly'_eval (p : poly') : Z -> Z :=
  fun z =>
    match p with
    | nil => 0
    | h :: t => h * (Z.pow z (Z.of_nat (length t))) + (poly'_eval t z)
    end.

(** Operations of polynomial *)
Fixpoint poly'_add_body (l1 l2 : list Z) : list Z :=
  match l1, l2 with
  | nil, nil => l2
  | h::t, nil => h::t
  | nil, h::t => h::t
  | h::t, h'::t' => (h+h')::(poly'_add_body t t')
  end.

Definition poly'_add (p1 p2 : poly') : poly' := rev (poly'_add_body (rev p1) (rev p2)).

(** Properties of Polynomial Operations *)
Lemma poly'_add_body_empty_r : forall l, poly'_add_body l nil = l.
Proof.
  intros.
  destruct l.
  - auto.
  - simpl. reflexivity.
Qed.

Lemma poly'_add_empty_r : forall p, poly'_add p nil = p.
Proof.
  intros.
  destruct p.
  - auto.
  - unfold poly'_add.
    rewrite poly'_add_body_empty_r.
    apply rev_involutive.
Qed.

Lemma poly'_add_body_empty_l : forall l, poly'_add_body nil l = l.
Proof.
  intros.
  destruct l.
  - auto.
  - simpl. reflexivity.
Qed.

Lemma poly'_add_empty_l : forall p, poly'_add nil p = p.
Proof.
  intros.
  destruct p.
  - auto.
  - unfold poly'_add.
    rewrite poly'_add_body_empty_l.
    apply rev_involutive.
Qed.

Lemma poly'_eval_0s: forall times n,
  poly'_eval (repeat 0 times) n = 0.
Proof.
  intros.
  induction times.
  - simpl. reflexivity.
  - simpl. omega.
Qed.

Lemma poly'_cons_eval_comm : forall p z n,
  poly'_eval (cons z p) n = poly'_eval (cons z (repeat 0 (length p))) n + poly'_eval p n.
Proof.
  intros.
  simpl.
  assert (Datatypes.length (repeat 0 (Datatypes.length p)) = Datatypes.length p).
  { induction p.
    - simpl. reflexivity.
    - simpl. rewrite IHp. reflexivity.
  }
  rewrite H.
  pose proof poly'_eval_0s (Datatypes.length p) n.
  rewrite H0.
  omega.
Qed.

Lemma poly'_app_eval_comm: forall p1 p2 n,
  poly'_eval (p1 ++ p2) n = poly'_eval (p1 ++ (repeat 0 (length p2))) n + poly'_eval p2 n.
Proof.
  intros.
  induction p1.
  - simpl.
    pose proof app_nil_l p2.
    rewrite <- H. simpl.
    pose proof poly'_eval_0s (Datatypes.length p2) n.
    rewrite H0.
    omega.
  - pose proof poly'_cons_eval_comm.
    simpl.
    assert (Datatypes.length (p1 ++ repeat 0 (Datatypes.length p2)) = Datatypes.length (p1 ++ p2)).
    { clear IHp1 H.
      Search (length (_ ++ _)).
      assert (Datatypes.length (repeat 0%Z (Datatypes.length p2)) = Datatypes.length p2).
      { induction p2.
        - simpl. reflexivity.
        - simpl. rewrite IHp2. reflexivity.
      }
      pose proof app_length p1 p2.
      rewrite H0.
      pose proof app_length p1 (repeat 0 (Datatypes.length p2)).
      rewrite H1.
      rewrite H.
      omega.
    }
    rewrite H0.
    rewrite IHp1.
    omega.
Qed.

Lemma poly'_eval_repeat_length_p: forall a (p : poly') z,
  poly'_eval (a :: repeat 0 (length p)) z = a * z ^ (Z.of_nat (length p)).
Proof.
  intros.
  simpl.
  pose proof poly'_eval_0s (length p) z.
  rewrite H.
  pose proof repeat_length 0 (length p).
  rewrite H0.
  omega.
Qed.

Theorem poly'_eval_poly_eval: forall (p : poly') n,
  poly'_eval p n = poly_eval (rev p) n.
Proof.
  intros.
  induction p.
  - simpl. reflexivity.
  - simpl.
    pose proof poly_eval_app (rev p) (a::nil) n.
    rewrite H. simpl. clear H.
    rewrite IHp.
    pose proof rev_length p.
    rewrite H.
    assert (a + n * 0 = a). { omega. }
    rewrite H0.
    rewrite Z.mul_comm.
    omega.
Qed.

Theorem poly_eval_poly'_eval: forall (p : poly) n,
  poly_eval p n = poly'_eval (rev p) n.
Proof.
  intros.
  pose proof poly'_eval_poly_eval (rev p) n.
  rewrite rev_involutive in H.
  omega.
Qed.

End Polynomial'.

Module WZY_Poly_Enhance.
Export Polynomial.

Inductive list_le : poly -> poly -> Prop :=
  | nil_le : list_le nil nil
  | cons_le : forall p1 p2 a1 a2,
              length p1 = length p2 ->
              a1 <= a2 ->
              list_le p1 p2 ->
              list_le (a1 :: p1) (a2 :: p2).

End WZY_Poly_Enhance.

Module Monomial.
Export Polynomial.
Export Polynomial'.
Export WZY_Poly_Enhance.

Fixpoint poly_get_last (p : poly) : Z :=
  match p with
  | nil => 0
  | a::nil => a
  | h::t => poly_get_last t
  end.

Fact poly_app_nonnil: forall (p : poly) a, (p ++ a::nil) <> nil.
Proof.
  intros. unfold not. intros.
  induction p.
  - inversion H; subst.
  - inversion H; subst.
Qed.

Fact poly_get_last_app: forall (p : poly) a,
  poly_get_last (p ++ a::nil) = a.
Proof.
  intros.
  induction p.
  - simpl. reflexivity.
  - pose proof poly_app_nonnil p a.
    simpl.
    destruct (p ++ a ::nil).
    + unfold not in H. assert ((nil:poly) = (nil:poly)). { reflexivity. }
      pose proof H H0. destruct H1.
    + tauto.
Qed.

Fact poly_get_last_cons: forall (a h: Z) (t : poly),
  poly_get_last (a::h::t) = poly_get_last (h::t).
Proof.
  intros.
  simpl. reflexivity.
Qed.

Fixpoint poly'_get_first (p : poly) : Z :=
  match p with
  | nil => 0
  | h::t => h
  end.

Definition poly_monomialize (p : poly) : poly :=
  match p with
  | nil => nil
  | _ :: _ => (repeat 0 ((length p) - 1)) ++ (poly_get_last p)::nil
  end.

Definition poly'_monomialize (p : poly') : poly' :=
  match p with
  | nil => nil
  | h :: _ => h::nil ++ (repeat 0 ((length p) - 1))
  end.

Example poly_mono_1: poly_monomialize (3::2::1::nil) = 0::0::1::nil.
Proof.
  simpl. reflexivity.
Qed.

Example poly'_mono_1: poly'_monomialize (1::2::3::nil) = 1::0::0::nil.
Proof.
  simpl. reflexivity.
Qed.

Lemma poly'_eval_mono: forall (p : poly') (n : Z),
  poly'_eval (poly'_monomialize p) n = (poly'_get_first p) * n^(Z.of_nat (length p) - 1).
Proof.
  intros.
  induction p.
  - simpl. reflexivity.
  - assert (Datatypes.length p - 0 = Datatypes.length p)%nat.
    { omega. }
    assert (poly'_eval (poly'_monomialize (a :: p)) n = a * n ^ Z.of_nat (Datatypes.length (repeat 0 (Datatypes.length p - 0))) + poly'_eval (repeat 0 (Datatypes.length p - 0)) n).
    { simpl. reflexivity. }
    rewrite H0. clear H0.
    rewrite H.
    assert (Datatypes.length (repeat 0 (Datatypes.length p)) = Datatypes.length p).
    { clear IHp H.
      induction p.
      - simpl. reflexivity.
      - simpl. rewrite IHp. reflexivity.
    }
    rewrite H0.
    pose proof poly'_eval_0s (Datatypes.length p) n.
    rewrite H1.
    assert (poly'_get_first (a :: p) = a).
    { simpl. reflexivity. }
    rewrite H2.
    assert (Z.of_nat (Datatypes.length (a :: p)) - 1 = Z.of_nat (Datatypes.length p)).
    { assert (Datatypes.length (a :: p) = Datatypes.length p + 1)%nat.
      { simpl. omega. }
      rewrite H3.
      rewrite Nat2Z.inj_add.
      simpl. omega.
    }
    rewrite H3.
    omega.
Qed.

Lemma poly_mono_app_1 : forall (p : poly) a,
  poly_monomialize (p ++ a::nil) = (repeat 0 (length p)) ++ a::nil.
Proof.
  intros.
  pose proof poly_app_nonnil p a.
  pose proof poly_get_last_app p a.
  assert (length (p ++ a::nil) = length p + 1)%nat.
  { clear H H0.
    induction p.
    - simpl. reflexivity.
    - simpl. rewrite IHp. reflexivity.
  }
  unfold poly_monomialize. destruct (p ++ a::nil).
  { unfold not in H. assert ((nil:poly) = (nil:poly)). { reflexivity. }
    pose proof H H2. destruct H3.
  }
  { rewrite H0. rewrite H1.
    assert (Datatypes.length p + 1 - 1 = Datatypes.length p)%nat.
    { omega. }
    rewrite H2.
    reflexivity.
  }
Qed.

Lemma poly'_mono_poly_mono : forall (p : poly') n,
  poly_eval (poly_monomialize (rev p)) n = poly'_eval (poly'_monomialize p) n.
Proof.
  intros.
  induction p.
  - simpl. reflexivity.
  - simpl.
    assert (Datatypes.length p - 0 = Datatypes.length p)%nat.
    { omega. }
    rewrite H.
    assert (Datatypes.length (repeat 0 (Datatypes.length p)) = Datatypes.length p).
    { clear IHp H.
      induction p.
      - simpl. reflexivity.
      - simpl. rewrite IHp. reflexivity.
    }
    rewrite H0.
    pose proof poly'_eval_0s (Datatypes.length p) n.
    rewrite H1.
    pose proof poly_mono_app_1 (rev p) a.
    rewrite H2.
    rewrite rev_length.
    { clear IHp H H0 H1 H2.
      induction p.
      - simpl. omega.
      - simpl. rewrite IHp.
        assert (n * (a * n ^ Z.of_nat (Datatypes.length p) + 0) = a * n * n ^ Z.of_nat (Datatypes.length p)).
        { simpl. ring. }
        rewrite H.
        pose proof Z.pow_1_r n. rewrite <- H0 at 1. clear H0.
        pose proof Z.pow_add_r n 1 (Z.of_nat (Datatypes.length p)).
        assert (0 <= 1). { omega. }
        assert ( 0 <= Z.of_nat (Datatypes.length p)). { omega. }
        pose proof H0 H1 H2.
        assert (a * n ^ 1 * n ^ Z.of_nat (Datatypes.length p) = a * n ^ (1 + Z.of_nat (Datatypes.length p))).
        { rewrite H3. rewrite Z.mul_assoc. reflexivity. }
        rewrite H4. clear H4.
        pose proof Zpos_P_of_succ_nat (Datatypes.length p).
        rewrite Z.pow_pos_fold.
        rewrite H4.
        assert (1 + Z.of_nat (Datatypes.length p) = Z.succ (Z.of_nat (Datatypes.length p))).
        { rewrite <- Z.add_1_r.
          rewrite Z.add_comm.
          reflexivity.
        }
        rewrite H5.
        omega.
    }
Qed.

Lemma poly_mono_poly'_mono : forall (p : poly) n,
  poly_eval (poly_monomialize p) n = poly'_eval (poly'_monomialize (rev p)) n.
Proof.
  intros.
  pose proof poly'_mono_poly_mono (rev p) n.
  rewrite rev_involutive in H.
  tauto.
Qed.

Lemma poly'_last_poly_first: forall (p : poly'),
  poly_get_last (rev p) = poly'_get_first p.
Proof.
  intros. induction p.
  - simpl. reflexivity.
  - simpl. pose proof poly_get_last_app (rev p) a.
    tauto.
Qed.

Lemma poly_last_poly'_first: forall (p : poly),
  poly_get_last p = poly'_get_first (rev p).
Proof.
  intros. pose proof poly'_last_poly_first (rev p).
  rewrite rev_involutive in H.
  tauto.
Qed.

Lemma poly_eval_mono: forall (p : poly) (n : Z),
  poly_eval (poly_monomialize p) n = (poly_get_last p) * n^(Z.of_nat (length p) - 1).
Proof.
  intros.
  pose proof poly_mono_poly'_mono p n.
  rewrite H.
  pose proof poly_last_poly'_first p.
  rewrite H0.
  rewrite <- rev_length.
  pose proof poly'_eval_mono (rev p) n.
  tauto.
Qed.

Fixpoint poly_get_max (p : poly) (d : Z) : Z :=
  match p with
    | nil => d
    | b::t => poly_get_max t (Z.max b d)
  end.

Lemma poly_get_max1: forall (p : poly),
  forall z, z <= poly_get_max p z.
Proof.
  induction p; intros.
  - simpl. reflexivity.
  - simpl.
    specialize (IHp (Z.max a z)).
    assert (z <= Z.max a z).
    { apply Z.le_max_r. }
    pose proof Z.le_trans _ _ _ H IHp.
    tauto.
Qed.

Lemma poly_get_max2: forall (p : poly) z1 z2,
  z1 <= z2 ->
  poly_get_max p z1 <= poly_get_max p z2.
Proof.
  induction p; intros.
  - simpl. tauto.
  - simpl.
    assert ( a <= z1 \/ z1 < a).
    { omega. }
    destruct H0.
    + pose proof Z.max_l _ _ H0.
      rewrite Z.max_comm in H1.
      rewrite H1.
      pose proof Z.le_trans _ _ _ H0 H.
      pose proof Z.max_l _ _ H2.
      rewrite Z.max_comm in H3.
      rewrite H3.
      specialize (IHp z1 z2).
      tauto.
    + apply Z.lt_le_incl in H0.
      pose proof Z.max_l _ _ H0.
      rewrite H1.
      assert ( a <= z2 \/ z2 < a).
      { omega. }
      destruct H2.
      * pose proof Z.max_l _ _ H2.
        rewrite Z.max_comm in H3.
        rewrite H3.
        pose proof IHp a z2 H2.
        tauto.
      * apply Z.lt_le_incl in H2.
        pose proof Z.max_l _ _ H2.
        rewrite H3.
        pose proof IHp a a.
        pose proof Z.le_refl a.
        tauto.
Qed.

Lemma poly_get_max3: forall (p : poly),
  forall z, In z p -> z <= poly_get_max p 0.
Proof.
  induction p; intros.
  - simpl. inversion H.
  - simpl.
    assert (z <= 0 \/ z > 0).
    { omega. }
    destruct H0.
    + pose proof poly_get_max1 p 0.
      pose proof poly_get_max2 p 0 (Z.max a 0).
      pose proof Z.le_max_r a 0.
      pose proof H2 H3.
      pose proof Z.le_trans _ _ _ H0 H1.
      pose proof Z.le_trans _ _ _ H5 H4.
      tauto.
    + inversion H; subst.
      * pose proof poly_get_max1 p z.
        pose proof poly_get_max2 p z (Z.max z 0).
        pose proof Z.le_max_l z 0.
        pose proof H2 H3.
        pose proof Z.le_trans _ _ _ H1 H4.
        tauto.
      * specialize (IHp z).
        pose proof IHp H1.
        pose proof poly_get_max2 p 0 (Z.max a 0).
        pose proof Z.le_max_r a 0.
        pose proof H3 H4.
        pose proof Z.le_trans _ _ _ H2 H5.
        tauto.
Qed.

Lemma rev_nil : forall (l : list Z), nil = rev l -> l = nil.
Proof.
  intros.
  destruct l.
  - auto.
  - assert (length (rev (z :: l)) = length (rev (z :: l))). auto.
    rewrite <- H in H0 at 1.
    simpl in H0. rewrite app_length in H0.
    simpl in H0. rewrite Nat.add_1_r in H0.
    inversion H0.
Qed.

Lemma non_empty_list : forall (l : list Z),
  l <> nil -> exists l' a, l = l' ++ a :: nil.
Proof.
  intros.
  remember (rev l) as rl.
  destruct rl.
  - apply rev_nil in Heqrl.
    congruence.
  - assert (rev (z :: rl) = rev (rev l)).
    rewrite Heqrl. reflexivity.
    simpl in H0. rewrite rev_involutive in H0.
    exists (rev rl), z. auto.
Qed.

Lemma poly_get_last_spec : forall l a,
  poly_get_last (l ++ a :: nil) = a.
Proof.
  intros.
  induction l.
  - auto.
  - simpl.
    destruct (l ++ a :: nil) eqn:eq.
    + assert (length (l ++ a :: nil) = length (l ++ a :: nil)); auto.
      rewrite eq in H at 1.
      simpl in H. rewrite app_length in H.
      simpl in H. rewrite Nat.add_1_r in H.
      inversion H.
    + auto.
Qed.

Fact poly_get_last_in_poly: forall p,
  p <> nil -> In (poly_get_last p) p.
Proof.
  intros.
  apply non_empty_list in H as [l' [a ?]].
  rewrite H at 1.
  rewrite poly_get_last_spec, H.
  rewrite in_app_iff.
  right. simpl. left. auto.
Qed.

Lemma poly_distr_coef_compare:
  forall K (N : nat) n,
  K > 0 ->
  n > 0 ->
  poly_eval ((repeat 0 (Z.to_nat (Z.of_nat N-1))) ++ (K * Z.of_nat N)::nil) n >=
  poly_eval (repeat K N) n.
Proof.
  assert (forall N:nat, (Datatypes.length (repeat 0 N)) = N) as lem_repeat.
  { intros. simpl.
    induction N.
    - simpl. reflexivity.
    - simpl. rewrite IHN. reflexivity.
  }
  intros.
  induction N.
  - simpl. omega.
  - pose proof poly_eval_app (repeat 0 (Z.to_nat (Z.of_nat (S N) - 1))) (K * Z.of_nat (S N) :: nil) n.
    rewrite H1.
    pose proof poly_eval_zero (Z.to_nat (Z.of_nat (S N) - 1)).
    rewrite H2.
    pose proof lem_repeat (Z.to_nat (Z.of_nat (S N) - 1))%nat.
    rewrite H3.
    pose proof Z2Nat.id (Z.of_nat (S N) - 1).
    assert (0 <= Z.of_nat (S N) - 1).
    { clear IHN H1 H2 H3 H4.
      induction N. - simpl. omega.
      - pose proof Nat2Z.inj_succ (S N).
        rewrite H1.
        pose proof Z.le_succ_diag_r (Z.of_nat (S N)).
        omega.
    }
    pose proof H4 H5.
    rewrite H6.
    assert (poly_eval (K * Z.of_nat (S N) :: nil) n = K * Z.of_nat (S N)).
    { simpl. omega. }
    rewrite H7.
    rewrite Z.add_0_l.
    assert (S N = N + 1)%nat. { omega. }
    rewrite H8.
    assert (Z.of_nat (N + 1) - 1 = Z.of_nat N).
    { pose proof Nat2Z.inj_sub (N+1) 1.
      assert (1 <= N + 1)%nat. omega.
      pose proof H9 H10. simpl in H11.
      assert (N+1-1=N)%nat. omega.
      rewrite H12 in H11.
      omega.
    }
    rewrite H9.

    clear H1 H2 H3 H4 H5 H6 H7 H8 H9.
    pose proof poly_eval_app (repeat 0 (Z.to_nat (Z.of_nat N - 1))) (K * Z.of_nat N :: nil) n.
    rewrite H1 in IHN.
    pose proof poly_eval_zero (Z.to_nat (Z.of_nat N - 1)) n.
    rewrite H2 in IHN.
    pose proof lem_repeat (Z.to_nat (Z.of_nat N - 1))%nat.
    rewrite H3 in IHN.
    assert (poly_eval (K * Z.of_nat N :: nil) n = K * Z.of_nat N).
    { simpl. omega. }
    rewrite H4 in IHN.
    rewrite Z.add_0_l in IHN.
    assert (Z.to_nat (Z.of_nat N - 1) = N - 1)%nat.
    { pose proof Nat2Z.id N.
      pose proof Z2Nat.inj_sub (Z.of_nat N) 1.
      assert (0<=1). omega. pose proof H6 H7.
      rewrite H5 in H8.
      assert (Z.to_nat 1 = 1)%nat.
      { simpl. apply Pos2Nat.inj_1. }
      rewrite H9 in H8.
      exact H8.
    }
    rewrite H5 in IHN.

    clear H1 H2 H3 H4 H5.
    assert (poly_eval (repeat K (N + 1)) n = K * n ^ (Z.of_nat N) + poly_eval (repeat K N) n).
    { clear IHN.
      induction N.
      - simpl. omega.
      - assert (poly_eval (repeat K (S N + 1)) n = K + n * poly_eval (repeat K (S N)) n).
        { clear IHN. simpl. induction N.
          - simpl. omega.
          - simpl. rewrite IHN. omega.
        }
        rewrite H1.
        assert (S N = N + 1)%nat. omega.
        rewrite <- H2 in IHN.
        rewrite IHN at 1.
        rewrite Z.mul_add_distr_l.
        assert (n * (K * n ^ Z.of_nat N) = K * n ^ (Z.of_nat (S N))).
        { rewrite Z.mul_assoc.
          rewrite Z.mul_shuffle0.
          pose proof Z.pow_1_r n.
          rewrite <- H3 at 1.
          pose proof Z.pow_add_r n 1 (Z.of_nat N).
          assert (0 <= 1). { omega. }
          assert (0 <= Z.of_nat N). { omega. }
          pose proof H4 H5 H6. rewrite <- H7.
          assert (Z.of_nat (S N) = 1 + Z.of_nat N).
          { pose proof Nat2Z.inj_add 1 N.
            assert (1 + N = S N)%nat. { omega. }
            assert (1 = Z.of_nat 1). { simpl. omega. }
            rewrite H9 in H8.
            rewrite <- H10 in H8.
            tauto.
          }
          rewrite <- H8.
          rewrite Z.mul_comm.
          omega.
        }
        rewrite H3.
        rewrite Z.add_assoc.
        assert (K + K * n ^ Z.of_nat (S N) + n * poly_eval (repeat K N) n = K * n ^ Z.of_nat (S N) + (K + n * poly_eval (repeat K N) n)).
        { omega. }
        rewrite H4.
        assert (K + n * poly_eval (repeat K N) n = poly_eval (repeat K (S N)) n).
        { simpl. omega. }
        rewrite H5.
        omega.
      }
      rewrite H1.
      assert (n ^ Z.of_nat N * (K * Z.of_nat (N + 1)) >= n ^ Z.of_nat (N - 1) * (K * Z.of_nat N) + K * n ^ Z.of_nat N).
      { clear H1.
        assert (Z.of_nat (N + 1) = Z.of_nat N + 1).
        { pose proof Nat2Z.inj_add N 1. simpl in H1.
          tauto.
        }
        rewrite H1.
        rewrite Z.mul_add_distr_l.
        rewrite Z.mul_add_distr_l.
        assert (n >= 1). { omega. }
        assert (n ^ Z.of_nat N >= n ^ Z.of_nat (N - 1)).
        { clear IHN H1.
          induction N.
          - simpl. omega.
          - assert (n ^ Z.of_nat (S N) = n * n ^ Z.of_nat N).
            { assert (S N = N + 1)%nat. omega.
              rewrite H1. clear H1.
              assert (Z.of_nat (N + 1) = Z.of_nat N + 1).
              { pose proof Nat2Z.inj_add N 1. simpl in H1.
                tauto.
              }
              rewrite H1. clear H1.
              pose proof Z.pow_add_r n (Z.of_nat N) 1.
              assert (0 <= Z.of_nat N). omega.
              assert (0 <= 1). omega.
              pose proof H1 H3 H4. rewrite H5.
              rewrite Z.pow_1_r.
              rewrite Z.mul_comm.
              reflexivity.
            }
            rewrite H1.
            assert (S N - 1 = N)%nat. omega.
            rewrite H3.
            pose proof Z.le_mul_diag_r (n ^ Z.of_nat N) n.
            assert (0 < n ^ Z.of_nat N).
            { apply Z.pow_pos_nonneg. omega. omega. }
            assert (1<=n). omega.
            pose proof H4 H5.
            apply H7 in H6.
            rewrite Z.mul_comm in H6.
            omega.
        }
        assert (n ^ Z.of_nat N * (K * 1) = K * n ^ Z.of_nat N).
        { ring. }
        rewrite H4.
        apply Z.le_ge.
        pose proof Zplus_le_compat_r (n ^ Z.of_nat (N - 1) * (K * Z.of_nat N)) (n ^ Z.of_nat N * (K * Z.of_nat N)) (K * n ^ Z.of_nat N).
        assert (n ^ Z.of_nat (N - 1) * (K * Z.of_nat N) <= n ^ Z.of_nat N * (K * Z.of_nat N)).
        { clear H5.
          pose proof Z.mul_le_mono_nonneg_r (n ^ Z.of_nat (N - 1)) (n ^ Z.of_nat N) (K * Z.of_nat N).
          assert (0 <= K * Z.of_nat N ).
          pose proof Z.mul_nonneg_nonneg K (Z.of_nat N).
          assert (0<=K). omega. pose proof H6 H7.
          assert (0<=Z.of_nat N). omega. pose proof H8 H9.
          exact H10.
          pose proof H5 H6.
          assert (n ^ Z.of_nat (N - 1) <= n ^ Z.of_nat N). omega.
          tauto.
        }
     pose proof H5 H6.
     tauto.
   }
   assert (n ^ Z.of_nat (N - 1) * (K * Z.of_nat N) + K * n ^ Z.of_nat N >= K * n ^ Z.of_nat N + poly_eval (repeat K N) n).
   { apply Z.le_ge.
     pose proof Zplus_le_compat_l (poly_eval (repeat K N) n) (n ^ Z.of_nat (N - 1) * (K * Z.of_nat N)) (K * n ^ Z.of_nat N).
     apply Z.ge_le in IHN.
     pose proof H3 IHN. omega.
   }
  omega.
Qed.

Fact poly_mono_cons: forall a h t,
  poly_monomialize (a :: h :: t) = 0 :: poly_monomialize (h :: t).
Proof.
  intros.
  simpl.
  assert (Datatypes.length t - 0 = Datatypes.length t)%nat.
  omega.
  rewrite H.
  reflexivity.
Qed.

Fact poly_mono_length_invar: forall p : poly,
  length p = length (poly_monomialize p).
Proof.
  intros.
  induction p.
  - simpl. omega.
  - destruct p.
    + simpl. reflexivity.
    + pose proof poly_mono_cons a z p.
      rewrite H.
      assert (Datatypes.length (a :: z :: p) = 1 + Datatypes.length (z :: p))%nat. { simpl. omega. }
      assert (Datatypes.length (0 :: poly_monomialize (z :: p)) = plus 1 (Datatypes.length (poly_monomialize (z :: p)))).
      { simpl. reflexivity. }
      rewrite H0.
      rewrite H1.
      f_equal.
      omega.
Qed.

Definition term_by_term_le := list_le.

Lemma poly_each_coef_compare:
  forall p1 p2,
  length p1 = length p2 ->
  term_by_term_le p1 p2 ->
  forall n, 0 <= n ->
  poly_eval p1 n <= poly_eval p2 n.
Proof.
  intros.
  induction H0.
  - omega.
  - simpl.
    pose proof IHlist_le H0.
    apply Z.add_le_mono; auto.
    apply Z.mul_le_mono_nonneg_l; auto.
Qed.

End Monomial.

Module Polynomial_Asympotitic_Bound.
Export Polynomial.
Export Monomial.
Import Assertion_D.

Inductive AsymptoticBound : Type :=
  | BigO : poly -> logical_var -> AsymptoticBound
  | BigOmega : poly -> logical_var -> AsymptoticBound
  | BigTheta : poly -> logical_var -> AsymptoticBound.

(* Convert asymtotic bounds to corresponding inequalities. We do not consider input with nonpositive size *)
Definition ab_eval (La : Lassn) (T : AsymptoticBound) (a1 a2 t : Z) : Prop :=
  match T with
  | BigO p n => 0 < La n ->
                0 <= t <= a2 * (poly_eval p (La n))
  | BigOmega p n => 0 < La n ->
                    0 <= a1 * (poly_eval p (La n)) <= t
  | BigTheta p n => 0 < La n ->
                    0 <= a1 * (poly_eval p (La n)) <= t /\ t <= a2 * (poly_eval p (La n))
  end.

Reserved Notation "T1 '=<' T2" (at level 50, no associativity).

(* loosen relationship defines equivalence between bounds *)
Inductive loosen : AsymptoticBound -> AsymptoticBound -> Prop :=
  (* If time is bounded by Theta, it is bounded by O and Omega *)
  | Theta2Omega : forall p n, 0 < poly_get_last p -> BigTheta p n =< BigOmega p n
  | Theta2O : forall p n, 0 < poly_get_last p -> BigTheta p n =< BigO p n

  (* We can relax the bound to a monomial with the same highest order term *)
  | O_Poly2Mono : forall p n, 0 < poly_get_last p -> BigO p n =< BigO (poly_monomialize p) n
  (* TODO: a monomial should also be able to be relaxed to polynomial with same highest order, but we did not have time to prove its soundness, thus it is not included yet *)

  (* Multiplying positive constant to a bound can obtain another valid bound *)
  | O_const : forall p a b n, 0 < a -> 0 < b ->  0 < poly_get_last p -> BigO (a ** p) n =< BigO (b ** p) n

  (* A polynomial can have different forms, if they always evaulate to the same value, then bounds defined by them are equivalent *)
  | O_id : forall p1 p2 n, (forall z, poly_eval p1 z = poly_eval p2 z) -> BigO p1 n =< BigO p2 n
  | Theta_id : forall p1 p2 n, (forall z, poly_eval p1 z = poly_eval p2 z) -> BigTheta p1 n =< BigTheta p2 n
  | Omega_id : forall p1 p2 n, (forall z, poly_eval p1 z = poly_eval p2 z) -> BigOmega p1 n =< BigOmega p2 n

  where "T1 '=<' T2" := (loosen T1 T2).

End Polynomial_Asympotitic_Bound.


From mathcomp Require Import all_ssreflect.

Fail Fixpoint gcd (m n : nat) {struct m} : nat :=
    if m is 0 then n else gcd (n %% m) m.
(* Recursive definition of gcd is ill-formed. *)
(* Recursive call to gcd has principal argument equal to
"n %% m" instead of "n0". *)

(*
Fixpoint gcd (h m n : nat) {struct h} : nat :=
    if h is h.+1 then
        if m is 0 then n else gcd h (n %% m) m
    else 0.
*)

Require Import Wf_nat Recdef.
Check lt_wf. (* well_founded lt *)
Check lt_wf_ind. (* forall (n : nat) (P : nat -> Prop),
(forall n0 : nat, (forall m : nat, (m < n0)%coq_nat -> P m) -> P n0) ->
P n *)

Function gcd (m n : nat) {wf lt m} : nat :=
    if m is 0 then n else gcd (modn n m) m.
Proof.
    - move=> m n m0 _. apply/ltP.
      by rewrite ltn_mod.
    - exact: lt_wf.
Qed.

Check gcd_equation.
Check gcd_ind.
Print gcd_terminate.

Require Import Extraction.
Extraction gcd.
(*
let rec gcd m n =
  match m with
  | O -> n
  | S n0 -> gcd (modn n (S n0)) (S n0)
*)

Search (_ %| _) "dvdn".
Check divn_eq. (* forall m d : nat, m = m %/ d * d + m %% d *)
Check dvdn_add. (* forall d m n : nat, d %| m -> d %| n -> d %| m + n *)
Check dvdn_mull. (* forall d m n : nat, d %| n -> d %| m * n *)

Theorem gcd_divides m n : (gcd m n %| m) && (gcd m n %| n).
Proof.
    functional induction (gcd m n).
        by rewrite dvdn0 dvdnn.
        move: IHn0 => /andP [HL HR].
        apply/andP. split.
        - exact HR.
        - rewrite {2}(divn_eq n m).
          apply: dvdn_add.
          by apply: dvdn_mull.
          exact HL.
Restart.
    functional induction (gcd m n).
    by rewrite dvdn0 dvdnn.
    move: IHn0 => /andP [HL HR].
    apply/andP. split => //.
    rewrite {2}(divn_eq n m).
    apply: dvdn_add => //.
    by apply: dvdn_mull.
Restart.
    functional induction (gcd m n).
    - rewrite dvdn0. rewrite dvdnn. done.
    - apply /andP. move :IHn0. move /andP. case.
      split => //.
      rewrite {2}(divn_eq n m).
      rewrite dvdn_add => //.
      rewrite dvdn_mull => //.
Qed.

Check addKn. (* forall n : nat, cancel (addn n) (subn^~ n) *)
Theorem gcd_max g m n : g %| m -> g %| n -> g %| gcd m n.
Proof.
    functional induction (gcd m n).
        done.
        move=> Hgm Hgn.
        apply: (IHn0 _ Hgm).
        rewrite (divn_eq n m) in Hgn.
        have Hgnm: g %| n %/ m * m.
            apply/dvdn_mull/Hgm.
        rewrite <- (dvdn_addr _ Hgnm).
        exact Hgn.
Restart.
    functional induction (gcd m n) => //.
    move => Im. rewrite {1}(divn_eq n m) dvdn_addr.
    - move => In. by move: In Im.
    - by rewrite dvdn_mull.
Restart.
    functional induction (gcd m n) => //.
    move => Im. rewrite {1}(divn_eq n m) dvdn_addr.
    - move => In. by apply: IHn0.
    - by apply: dvdn_mull.
Restart.
    (* addKn 使う版 *)
    functional induction (gcd m n) => // gm gn.
    apply: IHn0 => //.
    rewrite -(addKn (n %/ m * m) (n %% m)) -divn_eq.
      by rewrite dvdn_sub // dvdn_mull.
Qed.

Check odd_mul. (* forall m n : nat, odd (m * n) = odd m && odd n *)
Check odd_double. (* forall n : nat, odd n.*2 = false *)
Check odd_double_half. (* forall n: nat, odd n + n./2.*2 = n *)
Check andbb. (* idempotent andb *)(* forall x: bool, x && x = x *)
Check negbTE. (* forall b: bool, ~~ b -> b = false *)
Check double_inj. (* injective double *)(* forall x x2: nat, x.*2 = x2.*2 -> x = x2 *)
Check divn2. (* forall m: nat, m %/ 2 = m./2 *)
Check ltn_Pdiv. (* forall m d: nat, 1 < d -> 0 < m -> m %/ d < m *)
Check muln2. (* forall m: nat, m * 2 = m.*2 *)
Check esym. (* ?x = ?y -> ?y = ?x *)(* forall (A: Type) (x y: A), x = y -> y = x *)

Lemma odd_square n : odd n = odd (n*n).
Proof. by rewrite odd_mul andbb. Qed.
Lemma even_double_half n : ~~odd n -> n./2.*2 = n.
Proof.
    move=>H.
    rewrite -{2}(odd_double_half n) -{1}(add0n (n./2).*2).
    apply/esym/eqP.
    by rewrite eqn_add2r eqb0.
Restart.
    move=>H.
    rewrite -{2}(odd_double_half n).
    by rewrite (negbTE H).
Qed.

(* 本定理 *)
Theorem main_thm (n p : nat) : n * n = (p * p).*2 -> p = 0.
Proof.
    Check posnP. (* forall n : nat, eqn0_xor_gt0 n (n == 0) (0 < n) *)
    Print eqn0_xor_gt0.
(*
    Variant eqn0_xor_gt0 (n : nat) : bool -> bool -> Set :=
	Eq0NotPos : n = 0 -> eqn0_xor_gt0 n true false
  | PosNotEq0 : 0 < n -> eqn0_xor_gt0 n false true.
*)
  elim/lt_wf_ind: n p => n. (* 整礎帰納法 *)
    case: (posnP n) => [-> _ [] // | Hn IH p Hnp].
    have Hon : ~~odd n.
        apply: negbT. rewrite odd_square Hnp. apply: odd_double.
    have Hop : ~~odd p.
        apply: negbT. rewrite odd_square. rewrite -(even_double_half _ Hon) in Hnp.
        rewrite -muln2 mulnA [n./2*2*n./2]mulnC mulnA in Hnp.
        rewrite !muln2 in Hnp.
        rewrite -(double_inj Hnp).
        apply: odd_double.
    have Hp20: p./2 = 0 -> p = 0.
        move => Hp2. by rewrite -double0 -Hp2 (even_double_half _ Hop).
    apply: Hp20. apply: (IH n./2).
    - apply/ltP. rewrite -divn2. by apply: ltn_Pdiv.
    - rewrite -(even_double_half _ Hon) -(even_double_half _ Hop) in Hnp.
      rewrite -!doubleMr -!doubleMl in Hnp. by apply/double_inj/double_inj.
Restart.
    elim/lt_wf_ind: n p => n. (* 整礎帰納法 *)
    case: (posnP n).
    - (* n = 0 *)
    move=> ->.
    move=> _.
    move=>[].
    + (* p = 0 *) done.
    + (* 0 < p *) move=>n'. cbn.
        (* 0 = ((n' + (n' * n'.+1)%Nrec)%coq_nat.*2)%Nrec.+2 -> n'.+1 = 0 *)
        (* 0 = ... .+2 なので前提が成立しない *)
        done.
    - (* 0 < n *)
    move => Hn IH p Hnp.
Restart.
    elim/lt_wf_ind: n p => n. (* 整礎帰納法 *)
    case: (posnP n) => [-> _ [] // | Hn IH p Hnp].
    have /even_double_half Hon : ~~odd n by rewrite odd_square Hnp odd_double.
    move: Hnp.
    rewrite -Hon -muln2 mulnAC mulnA !muln2 => /double_inj Hnp'.
    have /even_double_half Hop : ~~odd p
    by rewrite odd_square -Hnp' odd_double.
    rewrite -Hop.
    apply/eqP. rewrite double_eq0. apply/eqP.
    apply: (IH n./2).
    - apply/ltP. rewrite -divn2. by apply: ltn_Pdiv.
    - apply/double_inj. by rewrite Hnp' doubleMr Hop mulnC doubleMr Hop.
Restart.
    elim/lt_wf_ind: n p => n. (* 整礎帰納法 *)
    case: (posnP n) => [-> _ [] // | Hn IH p Hnp].
    have /even_double_half Hevenn : ~~odd n by rewrite odd_square Hnp odd_double.
    move: Hnp.
    rewrite -Hevenn -muln2 mulnAC mulnA !muln2 => /double_inj /esym Hnp'.
    have /even_double_half Hevenp : ~~odd p
      by rewrite odd_square Hnp' odd_double.
    move: Hnp'.
    rewrite -Hevenp -muln2 mulnAC muln2 => /double_inj.
    rewrite mulnA muln2 => /esym /IH -> //.
    rewrite -divn2.
    by apply/ltP/ltn_Pdiv.
Qed.

(* 無理数 *)
Require Import Reals Field. (* 実数とそのための field タクティク *)

Definition irrational (x : R) : Prop :=
    forall (p q : nat), q <> 0 -> x <> (INR p / INR q)%R. (* %R はringスコープ *)
Locate "/".
(* Notation "x / y" := (Rdiv x y) : R_scope *)
Print Rdiv.
(* Rdiv = fun r1 r2 : R => (r1 * / r2)%R *)
(* Notation "/ x" := (RinvImpl.Rinv x) : R_scope *)

Theorem irrational_sqrt_2: irrational (sqrt (INR 2)).
Proof.
    move=> p q Hq Hrt.
    apply /Hq /(main_thm p) /INR_eq.
    rewrite -mul2n !mult_INR -(sqrt_def (INR 2)) ?{}Hrt; last by auto with real.
    have Hqr : INR q <> 0%R by auto with real.
    by field.
Qed.


Require Import Coq.Arith.Div2.
Require Import Coq.NArith.NArith.
Require Import Coq.ZArith.ZArith.
Require Import N_Z_nat_conversions.
Require Export Lia Nlia.

Set Implicit Arguments.

Fixpoint mod2 (n : nat) : bool :=
  match n with
    | 0 => false
    | 1 => true
    | S (S n') => mod2 n'
  end.

Ltac rethink :=
  match goal with
    | [ H : ?f ?n = _ |- ?f ?m = _ ] => replace m with n; simpl; auto
  end.

Theorem mod2_S_double : forall n, mod2 (S (2 * n)) = true.
  induction n; simpl; intuition; rethink.
Qed.

Theorem mod2_double : forall n, mod2 (2 * n) = false.
  induction n; simpl; intuition; rewrite <- plus_n_Sm; rethink.
Qed.

Theorem div2_double : forall n, div2 (2 * n) = n.
  induction n; simpl; intuition; rewrite <- plus_n_Sm; f_equal; rethink.
Qed.

Theorem div2_S_double : forall n, div2 (S (2 * n)) = n.
  induction n; simpl; intuition; f_equal; rethink.
Qed.

Notation pow2 := (Nat.pow 2).

Fixpoint Npow2 (n : nat) : N :=
  match n with
    | O => 1
    | S n' => 2 * Npow2 n'
  end%N.

Theorem untimes2 : forall n, n + (n + 0) = 2 * n.
  auto.
Qed.

Section strong.
  Variable P : nat -> Prop.

  Hypothesis PH : forall n, (forall m, m < n -> P m) -> P n.

  Lemma strong' : forall n m, m <= n -> P m.
    induction n; simpl; intuition; apply PH; intuition.
    exfalso; lia.
  Qed.

  Theorem strong : forall n, P n.
    intros; eapply strong'; eauto.
  Qed.
End strong.

Theorem div2_odd : forall n,
  mod2 n = true
  -> n = S (2 * div2 n).
  induction n as [n] using strong; simpl; intuition.

  destruct n as [|n]; simpl in *.
    discriminate.
  destruct n as [|n]; simpl in *; intuition.
  do 2 f_equal.
  replace (div2 n + S (div2 n + 0)) with (S (div2 n + (div2 n + 0))); auto.
Qed.

Theorem div2_even : forall n,
  mod2 n = false
  -> n = 2 * div2 n.
  induction n as [n] using strong; simpl; intuition.

  destruct n as [|n]; simpl in *; intuition.
  destruct n as [|n]; simpl in *.
    discriminate.
  f_equal.
  replace (div2 n + S (div2 n + 0)) with (S (div2 n + (div2 n + 0))); auto.
Qed.

Theorem drop_mod2 : forall n k,
  2 * k <= n
  -> mod2 (n - 2 * k) = mod2 n.
  induction n as [n] using strong; intros.

  do 2 (destruct n; simpl in *; repeat rewrite untimes2 in *; intuition).

  destruct k; simpl in *; intuition.

  destruct k; simpl; intuition.
  rewrite <- plus_n_Sm.
  repeat rewrite untimes2 in *.
  simpl; auto.
  apply H; lia.
Qed.

Theorem div2_minus_2 : forall n k,
  2 * k <= n
  -> div2 (n - 2 * k) = div2 n - k.
  induction n as [n] using strong; intros.

  do 2 (destruct n; simpl in *; intuition; repeat rewrite untimes2 in * ).
  destruct k; simpl in *; intuition.

  destruct k; simpl in *; intuition.
  rewrite <- plus_n_Sm.
  apply H; lia.
Qed.

Theorem div2_bound : forall k n,
  2 * k <= n
  -> k <= div2 n.
  intros ? n H; case_eq (mod2 n); intro Heq.

  rewrite (div2_odd _ Heq) in H.
  lia.

  rewrite (div2_even _ Heq) in H.
  lia.
Qed.

Lemma two_times_div2_bound: forall n, 2 * Nat.div2 n <= n.
Proof.
  eapply strong. intros n IH.
  destruct n.
  - constructor.
  - destruct n.
    + simpl. constructor. constructor.
    + simpl (Nat.div2 (S (S n))).
      specialize (IH n). lia.
Qed.

Lemma div2_compat_lt_l: forall a b, b < 2 * a -> Nat.div2 b < a.
Proof.
  induction a; intros.
  - lia.
  - destruct b.
    + simpl. lia.
    + destruct b.
      * simpl. lia.
      * simpl. apply lt_n_S. apply IHa. lia.
Qed.

(* otherwise b is made implicit, while a isn't, which is weird *)
Arguments div2_compat_lt_l {_} {_} _.

Lemma pow2_add_mul: forall a b,
  pow2 (a + b) = (pow2 a) * (pow2 b).
Proof.
  induction a; destruct b; firstorder auto with arith; simpl.
  repeat rewrite Nat.add_0_r.
  rewrite Nat.mul_1_r; auto.
  repeat rewrite Nat.add_0_r.
  rewrite IHa.
  simpl.
  repeat rewrite Nat.add_0_r.
  rewrite Nat.mul_add_distr_r; auto.
Qed.

Lemma mult_pow2_bound: forall a b x y,
  x < pow2 a -> y < pow2 b -> x * y < pow2 (a + b).
Proof.
  intros.
  rewrite pow2_add_mul.
  apply Nat.mul_lt_mono_nonneg; lia.
Qed.

Lemma mult_pow2_bound_ex: forall a c x y,
  x < pow2 a -> y < pow2 (c - a) -> c >= a -> x * y < pow2 c.
Proof.
  intros.
  replace c with (a + (c - a)) by lia.
  apply mult_pow2_bound; auto.
Qed.

Lemma lt_mul_mono' : forall c a b,
  a < b -> a < b * (S c).
Proof.
  induction c; intros.
  rewrite Nat.mul_1_r; auto.
  rewrite Nat.mul_succ_r.
  apply lt_plus_trans.
  apply IHc; auto.
Qed.

Lemma lt_mul_mono : forall a b c,
  c <> 0 -> a < b -> a < b * c.
Proof.
  intros.
  replace c with (S (c - 1)) by lia.
  apply lt_mul_mono'; auto.
Qed.

Lemma zero_lt_pow2 : forall sz, 0 < pow2 sz.
Proof.
  induction sz; simpl; lia.
Qed.

Lemma one_lt_pow2:
  forall n,
    1 < pow2 (S n).
Proof.
  intros.
  induction n.
  simpl; lia.
  remember (S n); simpl.
  lia.
Qed.

Lemma one_le_pow2 : forall sz, 1 <= pow2 sz.
Proof.
  intros. pose proof (zero_lt_pow2 sz). lia.
Qed.

Lemma pow2_ne_zero: forall n, pow2 n <> 0.
Proof.
  intros.
  pose proof (zero_lt_pow2 n).
  lia.
Qed.

Lemma mul2_add : forall n, n * 2 = n + n.
Proof.
  induction n; lia.
Qed.

Lemma pow2_le_S : forall sz, (pow2 sz) + 1 <= pow2 (sz + 1).
Proof.
  induction sz; simpl; auto.
  repeat rewrite Nat.add_0_r.
  rewrite pow2_add_mul.
  repeat rewrite mul2_add.
  pose proof (zero_lt_pow2 sz).
  lia.
Qed.

Lemma pow2_bound_mono: forall a b x,
  x < pow2 a -> a <= b -> x < pow2 b.
Proof.
  intros.
  replace b with (a + (b - a)) by lia.
  rewrite pow2_add_mul.
  apply lt_mul_mono; auto.
  pose proof (zero_lt_pow2 (b - a)).
  lia.
Qed.

Lemma pow2_inc : forall n m,
  0 < n -> n < m ->
    pow2 n < pow2 m.
Proof.
  intros.
  generalize dependent n; intros.
  induction m; simpl.
  intros. inversion H0.
  unfold lt in H0.
  rewrite Nat.add_0_r.
  inversion H0.
  apply Nat.lt_add_pos_r.
  apply zero_lt_pow2.
  apply Nat.lt_trans with (pow2 m).
  apply IHm.
  exact H2.
  apply Nat.lt_add_pos_r.
  apply zero_lt_pow2.
Qed.

Lemma pow2_S: forall x, pow2 (S x) = 2 * pow2 x.
Proof. intros. reflexivity. Qed.

Lemma mod2_S_S : forall n,
  mod2 (S (S n)) = mod2 n.
Proof.
  intros.
  destruct n; auto; destruct n; auto.
Qed.

Lemma mod2_S_not : forall n,
  mod2 (S n) = if (mod2 n) then false else true.
Proof.
  intros.
  induction n; auto.
  rewrite mod2_S_S.
  destruct (mod2 n); replace (mod2 (S n)); auto.
Qed.

Lemma mod2_S_eq : forall n k,
  mod2 n = mod2 k ->
  mod2 (S n) = mod2 (S k).
Proof.
  intros.
  do 2 rewrite mod2_S_not.
  rewrite H.
  auto.
Qed.

Theorem drop_mod2_add : forall n k,
  mod2 (n + 2 * k) = mod2 n.
Proof.
  intros.
  induction n.
  simpl.
  rewrite Nat.add_0_r.
  replace (k + k) with (2 * k) by lia.
  apply mod2_double.
  replace (S n + 2 * k) with (S (n + 2 * k)) by lia.
  apply mod2_S_eq; auto.
Qed.

Lemma mod2sub: forall a b,
  b <= a ->
  mod2 (a - b) = xorb (mod2 a) (mod2 b).
Proof.
  intros. remember (a - b) as c. revert dependent b. revert a. revert c.
  change (forall c,
    (fun c => forall a b, b <= a -> c = a - b -> mod2 c = xorb (mod2 a) (mod2 b)) c).
  apply strong.
  intros c IH a b AB N.
  destruct c.
  - assert (a=b) by lia. subst. rewrite Bool.xorb_nilpotent. reflexivity.
  - destruct c.
    + assert (a = S b) by lia. subst a. simpl (mod2 1). rewrite mod2_S_not.
      destruct (mod2 b); reflexivity.
    + destruct a; [lia|].
      destruct a; [lia|].
      simpl.
      apply IH; lia.
Qed.

Theorem mod2_pow2_twice: forall n,
  mod2 (pow2 n + (pow2 n + 0)) = false.
Proof.
  intros.
  replace (pow2 n + (pow2 n + 0)) with (2 * pow2 n) by lia.
  apply mod2_double.
Qed.

Theorem div2_plus_2 : forall n k,
  div2 (n + 2 * k) = div2 n + k.
Proof.
  induction n; intros.
  simpl.
  rewrite Nat.add_0_r.
  replace (k + k) with (2 * k) by lia.
  apply div2_double.
  replace (S n + 2 * k) with (S (n + 2 * k)) by lia.
  destruct (Even.even_or_odd n).
  - rewrite <- even_div2.
    rewrite <- even_div2 by auto.
    apply IHn.
    apply Even.even_even_plus; auto.
    apply Even.even_mult_l; repeat constructor.

  - rewrite <- odd_div2.
    rewrite <- odd_div2 by auto.
    rewrite IHn.
    lia.
    apply Even.odd_plus_l; auto.
    apply Even.even_mult_l; repeat constructor.
Qed.

Lemma pred_add:
  forall n, n <> 0 -> pred n + 1 = n.
Proof.
  intros; rewrite pred_of_minus; lia.
Qed.

Lemma pow2_zero: forall sz, (pow2 sz > 0)%nat.
Proof.
  induction sz; simpl; auto; lia.
Qed.

Theorem Npow2_nat : forall n, nat_of_N (Npow2 n) = pow2 n.
  induction n as [|n IHn]; simpl; intuition.
  rewrite <- IHn; clear IHn.
  case_eq (Npow2 n); intuition.
Qed.

Theorem pow2_N : forall n, Npow2 n = N.of_nat (pow2 n).
Proof.
  intro n.
  apply nat_of_N_eq. rewrite Nat2N.id. apply Npow2_nat.
Qed.

Lemma Z_of_N_Npow2: forall n, Z.of_N (Npow2 n) = (2 ^ Z.of_nat n)%Z.
Proof.
  intros.
  rewrite pow2_N.
  rewrite nat_N_Z.
  rewrite Nat2Z.inj_pow.
  reflexivity.
Qed.

Lemma pow2_S_z:
  forall n, Z.of_nat (pow2 (S n)) = (2 * Z.of_nat (pow2 n))%Z.
Proof.
  intros.
  replace (2 * Z.of_nat (pow2 n))%Z with
      (Z.of_nat (pow2 n) + Z.of_nat (pow2 n))%Z by lia.
  simpl.
  repeat rewrite Nat2Z.inj_add.
  ring.
Qed.

Lemma pow2_le:
  forall n m, (n <= m)%nat -> (pow2 n <= pow2 m)%nat.
Proof.
  intros.
  assert (exists s, n + s = m) by (exists (m - n); lia).
  destruct H0; subst.
  rewrite pow2_add_mul.
  pose proof (pow2_zero x).
  replace (pow2 n) with (pow2 n * 1) at 1 by lia.
  apply mult_le_compat_l.
  lia.
Qed.

Lemma Zabs_of_nat:
  forall n, Z.abs (Z.of_nat n) = Z.of_nat n.
Proof.
  unfold Z.of_nat; intros.
  destruct n; auto.
Qed.

Lemma Npow2_not_zero:
  forall n, Npow2 n <> 0%N.
Proof.
  induction n; simpl; intros; [discriminate|].
  destruct (Npow2 n); auto.
  discriminate.
Qed.

Lemma Npow2_S:
  forall n, Npow2 (S n) = (Npow2 n + Npow2 n)%N.
Proof.
  simpl; intros.
  destruct (Npow2 n); auto.
  rewrite <-Pos.add_diag.
  reflexivity.
Qed.

Lemma Npow2_pos: forall a,
    (0 < Npow2 a)%N.
Proof.
  intros.
  destruct (Npow2 a) eqn: E.
  - exfalso. apply (Npow2_not_zero a). assumption.
  - constructor.
Qed.

Lemma minus_minus: forall a b c,
  c <= b <= a ->
  a - (b - c) = a - b + c.
Proof. intros. lia. Qed.

Lemma even_odd_destruct: forall n,
  (exists a, n = 2 * a) \/ (exists a, n = 2 * a + 1).
Proof.
  induction n.
  - left. exists 0. reflexivity.
  - destruct IHn as [[a E] | [a E]].
    + right. exists a. lia.
    + left. exists (S a). lia.
Qed.

Lemma mul_div_undo: forall i c,
    c <> 0 ->
    c * i / c = i.
Proof.
  intros.
  pose proof (Nat.div_mul_cancel_l i 1 c) as P.
  rewrite Nat.div_1_r in P.
  rewrite Nat.mul_1_r in P.
  apply P; auto.
Qed.

Lemma mod_add_r: forall a b,
    b <> 0 ->
    (a + b) mod b = a mod b.
Proof.
  intros. rewrite <- Nat.add_mod_idemp_r by lia.
  rewrite Nat.mod_same by lia.
  rewrite Nat.add_0_r.
  reflexivity.
Qed.

Lemma mod2_cases: forall (n: nat), n mod 2 = 0 \/ n mod 2 = 1.
Proof.
  intros.
  assert (n mod 2 < 2). {
    apply Nat.mod_upper_bound. congruence.
  }
  lia.
Qed.

Lemma div_mul_undo: forall a b,
    b <> 0 ->
    a mod b = 0 ->
    a / b * b = a.
Proof.
  intros.
  pose proof Nat.div_mul_cancel_l as A. specialize (A a 1 b).
  replace (b * 1) with b in A by lia.
  rewrite Nat.div_1_r in A.
  rewrite mult_comm.
  rewrite <- Nat.divide_div_mul_exact; try assumption.
  - apply A; congruence.
  - apply Nat.mod_divide; assumption.
Qed.

Lemma Smod2_1: forall k, S k mod 2 = 1 -> k mod 2 = 0.
Proof.
  intros k C.
  change (S k) with (1 + k) in C.
  rewrite Nat.add_mod in C by congruence.
  pose proof (Nat.mod_upper_bound k 2).
  assert (k mod 2 = 0 \/ k mod 2 = 1) as E by lia.
  destruct E as [E | E]; [assumption|].
  rewrite E in C. simpl in C. discriminate.
Qed.

Lemma mod_0_r: forall (m: nat),
    m mod 0 =
    ltac:(match eval hnf in (1 mod 0) with | 0 => exact 0 | _ => exact m end).
Proof.
  intros. reflexivity.
Qed.

Lemma sub_mod_0: forall (a b m: nat),
    a mod m = 0 ->
    b mod m = 0 ->
    (a - b) mod m = 0.
Proof.
  intros. assert (m = 0 \/ m <> 0) as C by lia. destruct C as [C | C].
  - subst. cbn in *. now subst.
  - assert (a - b = 0 \/ b < a) as D by lia. destruct D as [D | D].
    + rewrite D. apply Nat.mod_0_l. assumption.
    + apply Nat2Z.inj. simpl.
      rewrite Nat2Z.inj_mod.
      rewrite Nat2Z.inj_sub by lia.
      rewrite Zdiv.Zminus_mod.
      rewrite <-! Nat2Z.inj_mod.
      rewrite H. rewrite H0.
      apply Z.mod_0_l.
      lia.
Qed.

Lemma mul_div_exact: forall (a b: nat),
    b <> 0 ->
    a mod b = 0 ->
    b * (a / b) = a.
Proof.
  intros. edestruct Nat.div_exact as [_ P]; [eassumption|].
  specialize (P H0). symmetry. exact P.
Qed.


Require Export chapter03.

Inductive list (X:Type) : Type :=
  | nil : list X
  | cons : X -> list X -> list X.

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

Example test_length1 :
    length nat (cons nat 1 (cons nat 2 (nil nat))) = 2.
Proof. reflexivity. Qed.

Example test_length2 :
    length bool (cons bool true (nil bool)) = 1.
Proof. reflexivity. Qed.

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

Fixpoint snoc (X:Type) (l:list X) (v:X) : (list X) :=
  match l with
  | nil => cons X v (nil X)
  | cons h t => cons X h (snoc X t v)
  end.

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

Example test_rev1 :
    rev nat (cons nat 1 (cons nat 2 (nil nat)))
  = (cons nat 2 (cons nat 1 (nil nat))).
Proof. reflexivity. Qed.

Example test_rev2:
  rev bool (nil bool) = nil bool.
Proof. reflexivity. Qed.

Module MumbleBaz.

Inductive mumble : Type :=
  | a : mumble
  | b : mumble -> nat -> mumble
  | c : mumble.
Inductive grumble (X:Type) : Type :=
  | d : mumble -> grumble X
  | e : X -> grumble X.

End MumbleBaz.

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

Check app'.
(* ===> forall X : Type, list X -> list X -> list X *)
Check app.
(* ===> forall X : Type, list X -> list X -> list X *)

Arguments nil {X}.
Arguments cons {X} _ _. (* use underscore for argument position that has no name *)
Arguments length {X} l.
Arguments app {X} l1 l2.
Arguments rev {X} l.
Arguments snoc {X} l v.

(* note: no _ arguments required... *)
Definition list123'' := cons 1 (cons 2 (cons 3 nil)).
Check (length list123'').

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

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

Fixpoint repeat {X : Type} (n : X) (count : nat) : list X :=
  match count with
  | 0 => []
  | S m => n :: repeat n m
  end.

Example test_repeat1:
  repeat true 2 = cons true (cons true nil).
Proof. reflexivity. Qed.

Theorem nil_app : forall X:Type, forall l:list X,
  app [] l = l.
Proof. reflexivity. Qed.

Theorem rev_snoc : forall X : Type,
                   forall v : X,
                   forall s : list X,
  rev (snoc s v) = v :: (rev s).
Proof.
  intros. induction s as [|y ys].
  Case "[]". reflexivity.
  Case "x :: xs".  simpl. rewrite -> IHys. simpl. reflexivity.
Qed.

Theorem rev_involutive : forall X : Type, forall l : list X,
  rev (rev l) = l.
Proof.
  intros. induction l as [|x xs].
  Case "[]". reflexivity.
  Case "x :: xs". simpl. rewrite rev_snoc. rewrite IHxs. reflexivity.
Qed.

Theorem snoc_with_append : forall X : Type,
                           forall l1 l2 : list X,
                           forall v : X,
  snoc (l1 ++ l2) v = l1 ++ (snoc l2 v).
Proof.
  intros. induction l1 as [|x xs].
  Case "[]". reflexivity.
  Case "x :: xs". simpl. rewrite IHxs. reflexivity.
Qed.

Inductive prod (X Y : Type) : Type :=
  pair : X -> Y -> prod X Y.

Arguments pair {X} {Y} _ _.

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

Notation "X * Y" := (prod X Y) : type_scope.

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

Definition snd {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.

Check @combine.
Eval compute in (combine [1;2] [false;false;true;true]).

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

Example test_split:
  split [(1,false);(2,false)] = ([1;2],[false;false]).
Proof. reflexivity. Qed.

Inductive option (X:Type) : Type :=
  | Some : X -> option X
  | None : option X.

Arguments Some {X} _.
Arguments None {X}.

Fixpoint index {X : Type} (n : nat)
               (l : list X) : option X :=
  match l with
  | [] => None
  | a :: l' => if beq_nat n O then Some a else index (pred n) l'
  end.

Example test_index1 : index 0 [4;5;6;7] = Some 4.
Proof. reflexivity. Qed.
Example test_index2 : index 1 [[1];[2]] = Some [2].
Proof. reflexivity. Qed.
Example test_index3 : index 2 [true] = None.
Proof. reflexivity. Qed.

Definition hd_opt {X : Type} (l : list X) : option X :=
  match l with
  | [] => None
  | x :: xs => Some x
  end.

Check @hd_opt.

Example test_hd_opt1 : hd_opt [1;2] = Some 1.
Proof. reflexivity. Qed.
Example test_hd_opt2 : hd_opt [[1];[2]] = Some [1].
Proof. reflexivity. Qed.

Definition doit3times {X:Type} (f:X -> X) (n:X) : X :=
  f (f (f n)).

Check @doit3times.
(* ===> doit3times : forall X : Type, (X -> X) -> X -> X *)

Example test_doit3times: doit3times minustwo 9 = 3.
Proof. reflexivity. Qed.

Example test_doit3times': doit3times negb true = false.
Proof. reflexivity. Qed.

Check plus.
(* ==> nat -> nat -> nat *)

Definition plus3 := plus 3.
Check plus3.

Example test_plus3 : plus3 4 = 7.
Proof. reflexivity. Qed.
Example test_plus3' : doit3times plus3 0 = 9.
Proof. reflexivity. Qed.
Example test_plus3'' : doit3times (plus 3) 0 = 9.
Proof. reflexivity. Qed.

Definition prod_curry {X Y Z : Type}
  (f : X * Y -> Z) (x : X) (y : Y) : Z := f (x, y).

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

Check @prod_curry.
Check @prod_uncurry.

Theorem uncurry_curry : forall (X Y Z : Type) (f : X -> Y -> Z) x y,
  prod_curry (prod_uncurry f) x y = f x y.
Proof. intros. reflexivity. Qed.

Theorem curry_uncurry : forall (X Y Z : Type)
                               (f : (X * Y) -> Z) (p : X * Y),
  prod_uncurry (prod_curry f) p = f p.
Proof. intros. destruct p as [x y]. reflexivity. Qed.

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

Example test_filter1: filter evenb [1;2;3;4] = [2;4].
Proof. reflexivity. Qed.

Definition length_is_1 {X : Type} (l : list X) : bool :=
  beq_nat (length l) 1.

Example test_filter2:
    filter length_is_1
           [ [1; 2]; [3]; [4]; [5;6;7]; []; [8] ]
  = [ [3]; [4]; [8] ].
Proof. reflexivity. Qed.

Definition countoddmembers' (l:list nat) : nat :=
  length (filter oddb l).

Example test_countoddmembers'1: countoddmembers' [1;0;3;1;4;5] = 4.
Proof. reflexivity. Qed.
Example test_countoddmembers'2: countoddmembers' [0;2;4] = 0.
Proof. reflexivity. Qed.
Example test_countoddmembers'3: countoddmembers' nil = 0.
Proof. reflexivity. Qed.

Example test_anon_fun':
  doit3times (fun n => n * n) 2 = 256.
Proof. reflexivity. Qed.

Example test_filter2':
    filter (fun l => beq_nat (length l) 1)
           [ [1; 2]; [3]; [4]; [5;6;7]; []; [8] ]
  = [ [3]; [4]; [8] ].
Proof. reflexivity. Qed.

Definition filter_even_gt7 (l : list nat) : list nat :=
  filter (fun x => andb (evenb x) (blt_nat 7 x)) l.

Example test_filter_even_gt7_1 :
  filter_even_gt7 [1;2;6;9;10;3;12;8] = [10;12;8].
Proof. reflexivity. Qed.

Example test_filter_even_gt7_2 :
  filter_even_gt7 [5;2;6;19;129] = [].
Proof. reflexivity. Qed.

Fixpoint partition {X : Type} (p : X -> bool) (l : list X)
                   : list X * list X :=
  match l with
  | [] => ([],[])
  | x :: xs => let (y, n) := partition p xs
                in if p x then (x :: y, n) else (y, x :: n)
  end.

Example test_partition1: partition oddb [1;2;3;4;5] = ([1;3;5], [2;4]).
Proof. reflexivity. Qed.
Example test_partition2: partition (fun x => false) [5;9;0] = ([], [5;9;0]).
Proof. reflexivity. Qed.

Fixpoint map {X Y:Type} (f:X -> Y) (l:list X)
             : (list Y) :=
  match l with
  | [] => []
  | h :: t => (f h) :: (map f t)
  end.

Theorem snoc_map : forall (X Y : Type) (f : X -> Y) (x : X) (xs : list X),
  map f (snoc xs x) = snoc (map f xs) (f x).
Proof.
  intros. induction xs as [|p ps].
  Case "[]". reflexivity.
  Case "p :: ps". simpl. rewrite -> IHps. reflexivity.
Qed.

Theorem map_rev : forall (X Y : Type) (f : X -> Y) (l : list X),
  map f (rev l) = rev (map f l).
Proof.
  intros. induction l as [|x xs].
  Case "[]". reflexivity.
  Case "x :: xs". simpl. rewrite <- IHxs. rewrite <- snoc_map. reflexivity.
Qed.

Fixpoint flat_map {X Y:Type} (f:X -> list Y) (l:list X)
                   : (list Y) :=
  match l with
  | [] => []
  | x :: xs => (f x) ++ (flat_map f xs)
  end.

Example test_flat_map1:
  flat_map (fun n => [n;n;n]) [1;5;4]
  = [1; 1; 1; 5; 5; 5; 4; 4; 4].
Proof. reflexivity. Qed.

Definition option_map {X Y : Type} (f : X -> Y) (xo : option X)
                      : option Y :=
  match xo with
    | None => None
    | Some x => Some (f x)
  end.

Fixpoint fold {X Y:Type} (f: X -> Y -> Y) (l:list X) (b:Y) : Y :=
  match l with
  | nil => b
  | h :: t => f h (fold f t b)
  end.

Definition constfun {X: Type} (x: X) : nat -> X :=
  fun (k:nat) => x.

Definition ftrue := constfun true.

Example constfun_example1 : ftrue 0 = true.
Proof. reflexivity. Qed.

Example constfun_example2 : (constfun 5) 99 = 5.
Proof. reflexivity. Qed.

Definition override {X: Type} (f: nat -> X) (k:nat) (x:X) : nat -> X:=
  fun (k':nat) => if beq_nat k k' then x else f k'.

Theorem unfold_example : forall m n,
  3 + n = m ->
  plus3 n + 1 = m + 1.
Proof.
  intros m n H.
  unfold plus3.
  rewrite -> H.
  reflexivity.
Qed.

Theorem override_eq : forall {X:Type} x k (f:nat -> X),
  (override f k x) k = x.
Proof.
  intros X x k f.
  unfold override.
  rewrite <- beq_nat_refl.
  reflexivity. Qed.

Theorem override_neq : forall (X:Type) x1 x2 k1 k2 (f : nat -> X),
  f k1 = x1 ->
  beq_nat k2 k1 = false ->
  (override f k2 x2) k1 = x1.
Proof.
  intros.
  unfold override.
  rewrite -> H0.
  rewrite -> H.
  reflexivity.
Qed.

Definition fold_length {X : Type} (l : list X) : nat :=
  fold (fun _ n => S n) l 0.

Example test_fold_length1 : fold_length [4;7;0] = 3.
Proof. reflexivity. Qed.

Theorem fold_length_correct : forall X (l : list X),
  fold_length l = length l.
Proof.
  intros. unfold fold_length. unfold fold.
  induction l as [|x xs].
  Case "[]". reflexivity.
  Case "x :: xs". simpl. rewrite -> IHxs. reflexivity.
Qed.


(* Proyecto 2
   Reyes Granados Naomi Itzel
   Árboles Binarios *)

Require Import Nat.
Require Import List.
Require Import Arith Omega.
Require Import PeanoNat.
Require Import NZAxioms NZBase Decidable OrdersTac.
Require Import NAxioms NProperties OrdersFacts.

Section TREES.
Variable V: Type.

Parameters (A:Type).

Definition nodo := V.

(* Definicion de arboles binarios*)
Inductive tree: Type :=
  | N : nodo -> tree
  | T : tree -> tree -> tree.

(* Funcion potencia*)
Fixpoint pot n m :=
  match m with
  | 0 => 1
  | S p => (n)*(pot n p)
  end.

(* Función que nos regresa el número de hojas del árbol*)
Fixpoint size (t:tree) : nat :=
  match t with
  | N n => 1
  | T tr tl => (size tr) + (size tl)
  end.

(* Función que nos regresa el número de nodos internos del árbol*)
Fixpoint nsize (t:tree) : nat :=
  match t with
  |N n => 0
  |T t1 t2 => (nsize t1) + (nsize t2) + 1
  end.

(* Función que nos regresa la profundidad árbol*)
Fixpoint depth (t:tree) : nat :=
  match t with
  |N n => 0
  |T t1 t2 => 1 + (max (depth t1) (depth t2))
  end.

(* Función de orden superior que mapea una función f
   a los elementos de las hojas del árbol*)
Fixpoint maptree (f: V -> V) (t:tree): tree :=
  match t with
  |N n => N (f n)
  |T t1 t2 => T (maptree f t1) (maptree f t2)
  end.

(* Función de orden superior *)
Fixpoint foldbtree (f: V -> V -> V) (t:tree): V :=
  match t with
  |N n => n
  |T t1 t2 => f (foldbtree f t1) (foldbtree f t2)
  end.

(* Función que nos regresa una lista con todos los
   nodos del árbol*)
Fixpoint subtrees (t:tree) : list (tree) :=
  match t with
  |N n => (N n)::nil
  |T t1 t2 => (subtrees t1) ++ ((T t1 t2)::(subtrees t2))
  end.

(* Función que regresa la longitud de una lista*)
Fixpoint length (l:list tree) : nat :=
  match l with
  |nil => 0
  |(b::bs) => 1 + (length bs)
  end.

(* Función que nos regresa el natural más grande entre
   dos opciones*)
Fixpoint maximo (n:nat) (m:nat) : nat:=
  match n with
  |0 => m
  |S k => if (m <? (S k)) then (S k) else m
  end.

(* Función que nos dice si un árbol es una hoja*)
Fixpoint esHoja (t:tree): Prop:=
  match t with
  |N n => True
  |T t1 t2 => False
  end.

(* Función que nos dice si un árbol no es una hoja*)
Fixpoint esInductivo (t:tree): Prop :=
  match t with
  |N n => False
  |T t1 t2 => True
  end.

(* Función que nos regresa el subárbol izquierdo*)
Fixpoint sacaIzquierdo (t:tree): tree :=
  match t with
  |N n => N n
  |T t1 t2 => t1
  end.
(* Función que nos regresa el subárbol derecho*)
Fixpoint sacaDerecho (t:tree): tree :=
  match t with
  |N n => N n
  |T t1 t2 => t2
  end.

(* Demostración de que para todo árbol al menos tiene
   una hoja.*)
Lemma lema0: forall t:tree, 1 <= (size t).
Proof.
intros.
induction t.
simpl.
trivial.
simpl.
rewrite -> IHt1.
apply le_plus_l.
Qed.

(* Demostación de que para todo natural a, 2^a será
   mayor o igua a 1*)
Lemma lema01: forall a:nat, 1 <= (pot 2 a).
Proof.
intros.
induction a.
simpl.
trivial.
simpl.
apply le_plus_trans.
apply IHa.
Qed.

(*Demostracion de que 2^(s n) = (2^n) + (2^n)*)
Lemma lema04: forall n:nat, pot 2 (S n)  = (pot 2 n) + (pot 2 n).
Proof.
intros.
induction n.
simpl.
trivial.
simpl.
rewrite plus_assoc.
rewrite plus_assoc.
rewrite plus_assoc.
rewrite plus_assoc_reverse.
simpl.
trivial.
Qed.

(* Demostración de que la función length abre con la concatenación*)
Lemma lema11: forall l1 l2 : list (tree), length (l1++l2) = (length l1) + (length l2).
Proof.
intros.
induction l1.
simpl.
trivial.
simpl.
auto.
Qed.

(* Demostracion de que el sucesor es analogo a sumarle un elemento*)
Lemma lemma10: forall n : nat, S(n) = n+1.
Proof.
intros.
induction n.
auto.
simpl.
rewrite IHn.
trivial.
Qed.

(* Demostacion de untipo de asociatividad*)
Lemma asoc: forall n m k :nat, n+(m+k)=m+(n+k).
Proof.
intros.
induction n.
simpl.
trivial.
simpl.
rewrite IHn.
rewrite plus_n_Sm.
trivial.
Qed.

(* Demostracion de neutro aditivo*)
Lemma sum0: forall n:nat, n+0 = n.
Proof.
intros.
induction n.
trivial.
simpl.
rewrite IHn.
trivial.
Qed.

(* Demostración de que se cumple la propiedad size t = nsize t + 1
   para cualquier t árbol*)
Lemma lema1: forall t:tree, (size t) = (nsize t + 1).
Proof.
intro.
induction t.
simpl.
reflexivity.
simpl.
rewrite -> IHt1.
rewrite -> IHt2.
rewrite plus_assoc_reverse.
symmetry.
rewrite plus_assoc_reverse.
rewrite plus_assoc_reverse.
simpl.
symmetry.
rewrite Peano.plus_n_Sm.
reflexivity.
Qed.

(*Demostracion de que se cumple la propiedad de length (subtrees t) + 1 = 2*(size t)
  para cualquier t árbol.*)
Lemma lema2: forall t:tree, (length (subtrees t)) + 1 = 2*(size t).
Proof.
intros.
induction t.
simpl.
trivial.
simpl.
rewrite lema11.
simpl.
rewrite plus_assoc_reverse.
rewrite asoc.
rewrite IHt1.
rewrite lemma10.
rewrite IHt2.
simpl.
rewrite sum0.
rewrite asoc.
rewrite plus_assoc.
rewrite asoc.
rewrite sum0.
rewrite plus_assoc.
rewrite sum0.
rewrite plus_assoc.
rewrite asoc.
rewrite plus_assoc.
rewrite plus_assoc.
trivial.
Qed.

(* Demostración de que se cumple que para todo número que sea un sucesor
   será mayor estricto que 0*)
Lemma lema12: forall n:nat, 0 < S n.
Proof.
intros.
induction n.
auto.
auto.
Qed.

Lemma lema13: forall n m k:nat, (k < n /\ m = k) -> m<n.
Proof.
intros.
destruct H.
rewrite H0.
apply H.
Qed.

(* Demostración de que si un árbol tiene profundidad 0 entonces es una hoja*)
Lemma lemma03: forall t:tree, (depth t = 0) -> (esHoja t).
Proof.
intro.
induction t.
simpl.
trivial.
simpl.
intro.
inversion H.
Qed.

(* Demostración de que si un árbol tiene profundidad mayor a 0
  entonces es un árbol con rama derecha e izquierda.*)
Lemma lema02: forall t:tree, (0 < depth t) -> (esInductivo t).
Proof.
intro.
induction t.
simpl.
intro.
inversion H.
simpl.
intro.
auto.
Qed.

(* Demostración de que si un árbol es una hoja
  entonces su prfundidad es 1*)
Lemma lema05: forall t:tree, (esHoja t) -> (size t = 1).
Proof.
intro.
induction t.
simpl.
auto.
simpl.
intro.
absurd (False).
contradict H.
apply H.
Qed.

(* Este lema ayudaria a terminar la demostración del lema 4
Lemma lema14: forall n m k:nat, (1 <= k /\ n <= m) -> 1+n <= m+k.
intro.
intro.
intro.
induction n.
intros.
destruct H.
induction m.
simpl.
apply H.
simpl.

Casi salia :C pero ya no me dio tiempo de terminar el
lema auxiliar anterior para el caso inductivo.

Lemma lema4: forall t:tree, (depth t) +1 <= (size t).
Proof.
intros.
(*remember (depth t).*)
induction t.
simpl.
trivial.
simpl.
destruct (Nat.max_dec (depth t1) (depth t2)).
rewrite e.
rewrite lemma10.
rewrite plus_assoc_reverse.
rewrite asoc.

Lema para ver que si es un árbol t con rama derecha e izquierda entonces
  la altura de cada lado siempre es menor que la del arbol t. Sería ocupado
  para demostrar el lema 3.
Lemma lema06: forall t:tree, (esInductivo t) -> ((depth (sacaIzquierdo t) < depth t) /\ (depth (sacaDerecho t) < depth t)).
Proof.
intro.
induction t.
simpl.
intro.
inversion H.
simpl.
intro.
split.
unfold lt.
simpl.
destruct (Nat.max_dec (depth t1) (depth t2)).
rewrite e.
trivial.
rewrite e.
rewrite lemma10.
auto.

Estaba en proceso, pero necesitaba mas cosas para terminar la demostración
en lo ultimo que me quede es que necesitaba el lema anterior.
Lemma lema3: forall t: tree, size t <= pot 2 (depth t).
intros.
remember (depth t).
induction n.
simpl.
assert (esHoja t).
apply lemma03.
rewrite Heqn.
reflexivity.
assert (size t = 1).
apply lema05.
apply H.
rewrite H0.
trivial.
assert (esInductivo t).
apply lema02.
rewrite <- Heqn.
apply lema12.*)


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

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

Eval simpl in (next_weekday friday).
Eval simpl in (next_weekday (next_weekday friday)).

Example test_next_weekday:
  (next_weekday (next_weekday saturday)) = tuesday.
Proof.
  simpl.
  reflexivity.
Qed.

Inductive bool: Type :=
  | true: bool
  | false: bool.

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

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

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

Example test_orb1: (orb true false) = true.
Proof.
  simpl.
  reflexivity.
Qed.

Example test_orb2: (orb false false) = false.
Proof.
  simpl.
  reflexivity.
Qed.

Example test_orb3: (orb false true) = true.
Proof.
  simpl.
  reflexivity.
Qed.

Example test_orb4: (orb true true) = true.
Proof.
  simpl.
  reflexivity.
Qed.

Definition admit {T: Type} : T. Admitted.

Definition nandb (b1: bool) (b2: bool) :bool :=
  negb (andb b1 b2).

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

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

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

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

Definition andb3 (b1:bool) (b2:bool) (b3:bool) : bool :=
 andb (andb b1 b2) b3.

Example test_andb31: (andb3 true true true) = true.
Proof.
  reflexivity.
Qed.

Example test_andb32: (andb3 false true true) = false.
Proof.
  reflexivity.
Qed.

Example test_andb33: (andb3 true false true) = false.
Proof.

  reflexivity.
Qed.

Example test_andb34: (andb3 true true false) = false.
Proof.
  reflexivity.
Qed.

Check (negb).

Module Playground1.

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

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

End Playground1.

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

Check (S (S (S O))).
Eval simpl in (minustwo 4).

Check S.
Check prod.
Check minustwo.

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

Example test_evenb: (evenb 100) = true.
Proof.
  simpl.
  reflexivity.
Qed.

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

Example test_oddb1: (oddb (S O)) = true.
Proof.
  reflexivity.
Qed.

Example test_oddb2: (oddb (S (S (S (S O))))) = false.
Proof.
  simpl. reflexivity.
Qed.

Module Playground2.

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

  Eval simpl in (plus 5 4).

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

  Eval simpl in (mult 3 4).

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

  Eval simpl in (minus 11 5).

End Playground2.

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

Eval simpl in (exp 3 4).

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

Eval simpl in (factorial 3).

Notation "x + y" := (plus x y) (at level 50, left associativity) : nat_scope.
Notation "x - y" := (minus x y) (at level 50, left associativity) : nat_scope.
Notation "x * y" := (mult x y) (at level 40, left associativity) : nat_scope.

Check ((0 + 1) + 1).

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

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

Example test_ble_nat1: (ble_nat 2 2) = true.
Proof. simpl. reflexivity. Qed.
Example test_ble_nat2: (ble_nat 2 4) = true.
Proof. simpl. reflexivity. Qed.
Example test_ble_nat3: (ble_nat 4 2) = false.
Proof. simpl. reflexivity. Qed.

Definition blt_nat (n m : nat) : bool := andb (ble_nat n m) (negb (beq_nat n m)).

Example test_blt_nat1: (blt_nat 2 2) = false.
Proof. simpl. reflexivity. Qed.

Example test_blt_nat2: (blt_nat 2 4) = true.
Proof. simpl. reflexivity. Qed.

Example test_blt_nat3: (blt_nat 4 2) = false.
Proof. simpl. reflexivity. Qed.

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

Theorem plus_0_n': forall n: nat, 0 + n = n.
Proof.
  reflexivity.
Qed.

Theorem plus_0_n'': forall n: nat, 0 + n = n.
Proof.
  intros n.
  reflexivity.
Qed.

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

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

Theorem plus_id_example: forall n m: nat,
    n = m -> n + n = m + m.
Proof.
  intros n m H.
  rewrite <- H.
  reflexivity.
Qed.

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

Theorem mult_0_plus : forall n m : nat,
  (0 + n) * m = n * m.
Proof.
  intros n m.
  rewrite -> plus_O_n.
  reflexivity.
Qed.

Theorem mult_1_plus : forall n m : nat,
  (1 + n) * m = m + (n * m).
Proof.
  intros.
  rewrite -> plus_1_l.
  simpl.
  reflexivity.
Qed.

Theorem plus_1_neq_0_firsttry : forall n : nat,
  beq_nat (n + 1) 0 = false.
Proof.
  intros n.
  destruct n as [ | n']. (* as以下は必要ではない *)
  reflexivity.
  reflexivity.
Qed.

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

Theorem zero_nbeq_plus_1 : forall n: nat, beq_nat 0 (n+1) =false.
Proof.
  intros.
  destruct n.
  reflexivity.
  reflexivity.
Qed.

Require String. Open Scope string_scope.

Ltac move_to_top x :=
  match reverse goal with
  | H : _ |- _ => try move x after H
  end.

Tactic Notation "assert_eq" ident(x) constr(v) :=
  let H := fresh in
  assert (x = v) as H by reflexivity;
  clear H.

Tactic Notation "Case_aux" ident(x) constr(name) :=
  first [
    set (x := name); move_to_top x
  | assert_eq x name; move_to_top x
  | fail 1 "because we are working on a different case" ].

Tactic Notation "Case" constr(name) := Case_aux Case name.
Tactic Notation "SCase" constr(name) := Case_aux SCase name.
Tactic Notation "SSCase" constr(name) := Case_aux SSCase name.
Tactic Notation "SSSCase" constr(name) := Case_aux SSSCase name.
Tactic Notation "SSSSCase" constr(name) := Case_aux SSSSCase name.
Tactic Notation "SSSSSCase" constr(name) := Case_aux SSSSSCase name.
Tactic Notation "SSSSSSCase" constr(name) := Case_aux SSSSSSCase name.
Tactic Notation "SSSSSSSCase" constr(name) := Case_aux SSSSSSSCase name.

Theorem andb_true_elim1 : forall b c : bool,
  andb b c = true -> b = true.
Proof.
  intros b c H.
  destruct b.
  Case "b = true".
    reflexivity.
  Case "b = false".
    rewrite <- H. reflexivity.
Qed.

Theorem andb_true_elim2 : forall b c : bool,
  andb b c = true -> c = true.
Proof.
  intros b c H.
  destruct b.
  Case "b = true".
    rewrite <- H.
    reflexivity.
  Case "b = fasle".
    destruct c.
    SCase "c = true".
      reflexivity.
    SCase "c = false".
      rewrite <- H. reflexivity.
Qed.

Theorem plus_0_r : forall n: nat,
  n + 0 = n.
Proof.
  intros n.
  induction n as [| n'].
  Case "n = 0". reflexivity.
  Case "n = Sn'". simpl. rewrite -> IHn'. reflexivity.
Qed.

Theorem minus_diag : forall n, minus n n = 0.
Proof.
  intros n.
  induction n as [| n'].
  Case "n = 0". reflexivity.
  Case "n = S n'". simpl. trivial.
Qed.

Theorem mult_0_r : forall n:nat,
  n * 0 = 0.
Proof.
  intros n.
  induction n as [| n'].
  Case "n = 0". reflexivity.
  Case "n = S n'". simpl. trivial.
Qed.

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

Theorem plus_comm : forall n m : nat,
  n + m = m + n.
Proof.
  intros n m.
  induction n as [| n'].
  Case "n = 0".
    induction m as [| m'].
    SCase "m = 0". reflexivity.
    SCase "m = S m'". simpl. rewrite <- IHm'. reflexivity.
  Case "n = S n'".
    induction m as [| m'].
    SCase "m = 0". simpl. rewrite -> IHn'. reflexivity.
    SCase "m = S m'". simpl. rewrite -> IHn'. simpl. rewrite plus_n_Sm. reflexivity.
Qed.

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

Lemma double_plus : forall n, double n = n + n.
Proof.
  intros n.
  induction n as [| n'].
  Case "n = 0". reflexivity.
  Case "n = S n'". simpl. rewrite -> IHn'. rewrite plus_n_Sm. reflexivity.
Qed.

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

Theorem beq_nat_refl: forall n : nat,
    true = beq_nat n n.
Proof.
  intros n.
  induction n as [| n'].
    reflexivity.
    simpl. trivial.
Qed.

Theorem mult_0_plus': forall n m: nat,
    (0 + n) * m = n * m.
Proof.
  intros n m.
  assert (H: 0 + n = n).
    Case "Proof of assertion". reflexivity.
  rewrite H. reflexivity.
Qed.

Theorem plus_rearrange: forall n m p q: nat,
    (n + m) + (p + q) = (m + n) + (p + q).
Proof.
  intros n m p q.
  assert (H: n + m = m + n).
    Case "Proof of assertion".
    rewrite plus_comm. reflexivity.
  rewrite H. reflexivity.
Qed.

Theorem plus_swap: forall n m p : nat,
  n + (m + p) = m + (n + p).
Proof.
  intros n m p.
  assert (H0: n + (m + p) = (n + m) + p).
    rewrite <- plus_assoc. reflexivity.
  assert (H1: m + (n + p) = (m + n) + p).
    rewrite <- plus_assoc. reflexivity.
  rewrite H0. rewrite H1.
  assert (H2: n + m = m + n).
    rewrite plus_comm. reflexivity.
  rewrite H2. reflexivity.
Qed.

Theorem  mult_plus_distr_l: forall n m l: nat,
    m * l + m * n = m * (n + l).
Proof.
  intros n m l.
  induction m as [| m'].
    Case "m = 0". reflexivity.
    Case "m = S m'".
      simpl.
      rewrite <- IHm'.
      rewrite <- plus_swap.
      rewrite <- plus_assoc.
      rewrite <- plus_assoc.
      rewrite <- plus_assoc.
      reflexivity.
Qed.

Theorem mult_1_r: forall n: nat,
    n * 1 = n.
Proof.
  intros n.
  induction n as [| n'].
    Case "n = 0". reflexivity.
    Case "n = S n'". simpl. rewrite -> IHn'. reflexivity.
Qed.

Theorem mult_comm: forall m n: nat,
    m * n = n * m.
Proof.
  induction n as [| n'].
    Case "n = 0". rewrite -> mult_0_r. reflexivity.
    Case "n = S n'".
      assert (H0: S n' = 1 + n'). reflexivity.
      simpl.
      rewrite H0.
      rewrite <- mult_plus_distr_l.
      rewrite plus_comm.
      rewrite -> mult_1_r.
      rewrite IHn'.
      reflexivity.
Qed.

Theorem ble_nat_refl : forall n: nat,
  true = ble_nat n n.
Proof.
  intros n.
  induction n as [| n'].
    Case "n = 0". reflexivity.
    Case "n = S n'". simpl. trivial.
Qed.

Theorem zero_nbeq_S : forall n: nat,
  beq_nat 0 (S n) = false.
Proof.
  intros n.
  reflexivity.
Qed.

Theorem andb_false_r : forall b : bool,
  andb b false = false.
Proof.
  intros b.
  destruct b.
    Case "b = true". reflexivity.
    Case "b = false". reflexivity.
Qed.

Theorem plus_ble_compat_l : forall n m p : nat,
  ble_nat n m = true -> ble_nat (p + n) (p + m) = true.
Proof.
  intros n m p H.
  induction p as [| p'].
    Case "p = 0". simpl. trivial.
    Case "p = S p'". simpl. trivial.
Qed.

Theorem S_nbeq_0 : forall n: nat,
  beq_nat (S n) 0 = false.
Proof.
  intros n. reflexivity.
Qed.

Theorem mult_1_l : forall n: nat, 1 * n = n.
Proof.
  intros n. rewrite <- plus_0_r. reflexivity.
Qed.

Theorem all3_spec : forall b c : bool,
    orb (andb b c) (orb (negb b) (negb c)) = true.
Proof.
  intros b c.
  destruct b. destruct c.
  reflexivity. reflexivity. reflexivity.
Qed.

Theorem mult_plus_distr_r : forall n m p : nat,
  (n + m) * p = (n * p) + (m * p).
Proof.
  intros n m p.
  induction n as [| n'].
    Case "n = 0". reflexivity.
    Case "n = S n'". simpl. rewrite IHn'. rewrite plus_assoc. reflexivity.
Qed.

Theorem mult_assoc : forall n m p : nat,
  n * (m * p) = (n * m) * p.
Proof.
  intros n m p.
  induction n as [| n'].
    Case "n = 0". reflexivity.
    Case "n = S n'". simpl. rewrite mult_plus_distr_r. rewrite IHn'. reflexivity.
Qed.

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

Inductive bin : Type :=
| o : bin
| s : bin -> bin
| t : bin -> bin.

Fixpoint inc (b : bin) : bin :=
  match b with
  | o => t o
  | s b' => t b'
  | t b' => s (inc b')
  end.

Eval simpl in (inc (inc (inc (inc (inc o))))).

Fixpoint bin_nat (b : bin) : nat :=
  match b with
  | o => 0
  | s b' => bin_nat b' + bin_nat b'
  | t b' => S (bin_nat b' + bin_nat b')
  end.

Eval simpl in (bin_nat (s (t (s (t o))))).

Theorem inc_comm: forall b : bin,
    bin_nat (inc b) = S (bin_nat b).
Proof.
  intros b.
  induction b.
    reflexivity.
    reflexivity.
    simpl. rewrite -> IHb. simpl. rewrite <- plus_n_Sm. reflexivity.
Qed.

Fixpoint nat_bin (n : nat) : bin :=
  match n with
  | O => o
  | S n' => inc (nat_bin n')
  end.

Eval simpl in nat_bin 1.
Eval simpl in nat_bin 2.
Eval simpl in nat_bin 3.
Eval simpl in nat_bin 4.
Eval simpl in nat_bin 5.
Eval simpl in nat_bin 6.
Eval simpl in nat_bin 10.


From Undecidability.Shared.Libs.PSL Require Import BasicDefinitions.
From Undecidability.Shared.Libs.PSL Require Import FiniteTypes.FinTypes.
From Undecidability.Shared.Libs.PSL Require Import Vectors.Vectors.
Import VectorNotations2.

Open Scope vector_scope.

Fixpoint all_fins (n : nat) : list (Fin.t n) :=
  match n with
  | 0 => nil
  | S n => Fin.F1 :: map Fin.FS (all_fins n)
  end.

#[global]
Instance Fin_finTypeC n : finTypeC (EqType (Fin.t n)).
Proof.
  constructor 1 with (enum := all_fins n).
  cbn. intros x. eapply dupfreeCount.
  - clear x. induction n as [|n IH]; simpl; constructor.
    + now intros [? [? ?]]%in_map_iff.
    + apply (FinFun.Injective_map_NoDup (@Fin.FS_inj n) IH).
  - now induction x; [left|right; apply in_map].
Defined.

(* Function that produces a list of all Vectors of length n over A *)
Fixpoint Vector_pow {X: Type} (A: list X) n {struct n} : list (Vector.t X n) :=
  match n with
  | 0 => [Vector.nil _]
  | S n => concat (map (fun a => map (fun v => a:::v) (Vector_pow A n) ) A)
  end.

#[global]
Instance Vector_finTypeC (A:finType) n: finTypeC (EqType (Vector.t A n)).
Proof.
  exists (nodup (@eqType_dec _) ((Vector_pow (elem A) n))). cbn in *.
  intros v. eapply dupfreeCount.
  - eapply NoDup_nodup.
  - apply nodup_In. induction v; cbn.
    + eauto.
    + eapply in_concat. eexists; split.
      eapply in_map_iff. eexists.
      split. reflexivity.
      2:eapply in_map_iff. 2:eauto.
      eapply elem_spec.
Defined.

#[export] Hint Extern 4 (finTypeC (EqType (Vector.t _ _))) => eapply Vector_finTypeC : typeclass_instances.


From mathcomp Require Import all_ssreflect all_algebra all_field.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Import GRing.Theory Num.Theory UnityRootTheory.
Open Scope ring_scope.

Section PreliminaryLemmas.
(** -------------------------------------------- *)
(** #
#
* Preliminaries

Let's extend the library on rings and algebraic numbers
with some easy lemmas first.

** Question -2: prove that if a sum of natural numbers is 1 then one of its term is 0 and the other is 1

Note that we do not consider nat but the copy of nat which is embeded
in the algebraic numbers algC. The theorem is easy to prove for nat, so
we suggest you use a compatibility lemma numbers between nat and Cnat
*)
Lemma Cnat_add_eq1 : {in Cnat &, forall x y,
   (x + y == 1) = ((x == 1) && (y == 0)) || ((x == 0) && (y == 1))}.
Proof.
(*D*)move=> x y /CnatP [n ->] /CnatP [m ->]; rewrite -natrD !pnatr_eq1 ?pnatr_eq0.
(*D*)by move: n m => [|[|?]] [|[|?]].
(*A*)Qed.
(**
** Question -1: The real part of product
*)
Lemma algReM (x y : algC) : 'Re (x * y) = 'Re x * 'Re y - 'Im x * 'Im y.
Proof.
(*D*)rewrite {1}[x]algCrect {1}[y]algCrect mulC_rect algRe_rect //;
(*D*)by rewrite rpredD ?rpredN // rpredM // ?Creal_Re ?Creal_Im.
(*A*)Qed.
(**
** Question 0: The imaginary part of product
   (it's the same, don't do it if takes more than 5s
*)
Lemma algImM (x y : algC) : 'Im (x * y) = 'Re x * 'Im y + 'Re y * 'Im x.
Proof.
(*D*)rewrite {1}[x]algCrect {1}[y]algCrect mulC_rect algIm_rect //;
(*D*)by rewrite rpredD ?rpredN // rpredM // ?Creal_Re ?Creal_Im.
(*A*)Qed.

End PreliminaryLemmas.
(** #
# *)
(** -------------------------------------------- *)
(** #
#
* The ring of Gauss integers

 - Ref: exercices de mathematiques oraux X-ENS algebre 1
 - Exercice 3.10. ENS Lyon

*)
Section GaussIntegers.
(**
First we define a predicate for the algebraic numbers which are gauss integers.
*)
Definition gaussInteger := [qualify a x | ('Re x \in Cint) && ('Im x \in Cint)].
(**
** Question 1: Prove that integers are gauss integers
*)
Lemma Cint_GI (x : algC) : x \in Cint -> x \is a gaussInteger.
Proof.
(*D*)move=> x_int; rewrite qualifE (Creal_ReP _ _) ?(Creal_ImP _ _) ?Creal_Cint //.
(*D*)by rewrite x_int rpred0.
(*A*)Qed.
(** #
# *)
(** -------------------------------------------- *)
(** #
#
** Question 2: Prove that gauss integers form a subfield
*)
Lemma GI_subring : subring_closed gaussInteger.
Proof.
(*D*)split => [|x y /andP[??] /andP[??]|x y /andP[??] /andP[??]].
(*D*)- by rewrite Cint_GI.
(*D*)- by rewrite qualifE !raddfB /= ?rpredB.
(*D*)by rewrite qualifE algReM algImM rpredB ?rpredD // rpredM.
(*A*)Qed.
(**

There follows the boilerplate to use the proof GI_subring in order to
canonically provide a subring structure to the predicate gaussInteger.

*)
Fact GI_key : pred_key gaussInteger. Proof. by []. Qed.
Canonical GI_keyed := KeyedQualifier GI_key.
Canonical GI_opprPred := OpprPred GI_subring.
Canonical GI_addrPred := AddrPred GI_subring.
Canonical GI_mulrPred := MulrPred GI_subring.
Canonical GI_zmodPred := ZmodPred GI_subring.
Canonical GI_semiringPred := SemiringPred GI_subring.
Canonical GI_smulrPred := SmulrPred GI_subring.
Canonical GI_subringPred := SubringPred GI_subring.
(**

Finally, we define the type of Gauss Integer, as a sigma type of
algebraic numbers. We soon prove that this is in fact a sub type.

*)
Record GI := GIof {
  algGI : algC;
  algGIP : algGI \is a gaussInteger }.
(** We make the defining property of GI a Hint *)
Hint Resolve algGIP.
(**

We provide the subtype property.

- This makes it possible to use the generic operator "val" to get an
  algC from a Gauss Integer.

*)
Canonical GI_subType := [subType for algGI].
(**
We deduce that the real and imaginary parts of a GI are integers
*)
Lemma GIRe (x : GI) : 'Re (val x) \in Cint.
Proof. by have /andP [] := algGIP x. Qed.
Lemma GIIm (x : GI) : 'Im (val x) \in Cint.
Proof. by have /andP [] := algGIP x. Qed.
Hint Resolve GIRe GIIm.

Canonical ReGI x := GIof (Cint_GI (GIRe x)).
Canonical ImGI x := GIof (Cint_GI (GIIm x)).
(**

We provide a ring structure to the type GI, using the subring
canonical property for the predicate gaussInteger

*)
Definition GI_eqMixin := [eqMixin of GI by <:].
Canonical GI_eqType := EqType GI GI_eqMixin.
Definition GI_choiceMixin := [choiceMixin of GI by <:].
Canonical GI_choiceType := ChoiceType GI GI_choiceMixin.
Definition GI_countMixin := [countMixin of GI by <:].
Canonical GI_countType := CountType GI GI_countMixin.
Definition GI_zmodMixin := [zmodMixin of GI by <:].
Canonical GI_zmodType := ZmodType GI GI_zmodMixin.
Definition GI_ringMixin := [ringMixin of GI by <:].
Canonical GI_ringType := RingType GI GI_ringMixin.
Definition GI_comRingMixin := [comRingMixin of GI by <:].
Canonical GI_comRingType := ComRingType GI GI_comRingMixin.
(* Definition GI_unitRingMixin := [unitRingMixin of GI by <:]. *)
(* Canonical GI_unitRingType := UnitRingType GI GI_unitRingMixin. *)
(**

 - Now we build the unitRing and comUnitRing structure of gauss
   integers. Contrarily to the previous structures, the operator is
   not the same as on algebraics. Indeed the invertible algebraics are
   not necessarily invertible gauss integers.

 - Hence, we define the inverse of gauss integers as follow : if the
   algebraic inverse happens to be a gauss integer we recover the
   proof and package it together with the element and get a gauss
   integer, otherwise, we default to the identity.

 - A gauss integer is invertible if the algbraic inverse is a gauss
   integer.

*)
Definition invGI (x : GI) := insubd x (val x)^-1.
Definition unitGI := [pred x : GI | (x != 0) && ((val x)^-1 \is a gaussInteger)].
(** #
# *)
(** -------------------------------------------- *)
(** #
#

** Question 3: prove a few facts in order to find a comUnitRingMixin
for GI, and then instantiate the interfaces of unitRingType and
comUnitRingType.

Do only one of the following proofs.

*)
Fact mulGIr : {in unitGI, left_inverse 1 invGI *%R}.
Proof.
(*D*)move=> x /andP [x_neq0 xVGI]; rewrite /invGI.
(*D*)by apply: val_inj; rewrite /= insubdK // mulVr ?unitfE.
(*A*)Qed.

Fact unitGIP (x y : GI) : y * x = 1 -> unitGI x.
Proof.
(*D*)rewrite /unitGI => /(congr1 val) /=.
(*D*)have [-> /eqP|x_neq0] := altP (x =P 0); first by rewrite mulr0 eq_sym oner_eq0.
(*D*)by move=> /(canRL (mulfK x_neq0)); rewrite mul1r => <- /=.
(*A*)Qed.

Fact unitGI_out : {in [predC unitGI], invGI =1 id}.
Proof.
move=> x.
(*D*)rewrite !inE /= /unitGI.
(*D*)rewrite negb_and negbK => /predU1P [->|/negPf xGIF];
(*D*)by apply: val_inj; rewrite /invGI ?val_insubd /= ?xGIF // invr0 if_same.
(*A*)Qed.
(*D*)
Definition GI_comUnitRingMixin := ComUnitRingMixin mulGIr unitGIP unitGI_out.
Canonical GI_unitRingType := UnitRingType GI GI_comUnitRingMixin.
Canonical GI_comUnitRingType := [comUnitRingType of GI].
(** #
# *)
(** -------------------------------------------- *)
(** #
#

** Question 4: Show that gauss integers are stable by conjugation.

*)
Lemma conjGIE x : (x^* \is a gaussInteger) = (x \is a gaussInteger).
(*A*)Proof. by rewrite ![_ \is a _]qualifE algRe_conj algIm_conj rpredN. Qed.
(**

We use this fact to build the conjugation of a gauss Integers

*)
Fact conjGI_subproof (x : GI) : (val x)^* \is a gaussInteger.
Proof. by rewrite conjGIE. Qed.

Canonical conjGI x := GIof (conjGI_subproof x).
(**

We now define the norm (stasm) for gauss integer, we don't need to
specialize it to gauss integer so we define it over algebraic numbers
instead.

*)
Definition gaussNorm (x : algC) := x * x^*.
Lemma gaussNorm_val (x : GI) : gaussNorm (val x) = val (x * conjGI x).
Proof. by []. Qed.
(**

** Question 4: Show that the gaussNorm of x is the square of the complex modulus of x

Hint: only one rewrite with the right theorem.
*)
Lemma gaussNormE x : gaussNorm x = `|x| ^+ 2.
(*A*)Proof. by rewrite normCK. Qed.
(** #
# *)
(** -------------------------------------------- *)
(** #
#

** Question 5: Show that the gaussNorm of an gauss integer is a natural number.

*)
Lemma gaussNormCnat (x : GI) : gaussNorm (val x) \in Cnat.
(*A*)Proof. by rewrite /gaussNorm -normCK normC2_Re_Im rpredD // Cnat_exp_even. Qed.
Hint Resolve gaussNormCnat.
(** #
# *)
(** -------------------------------------------- *)
(** #
#

** Question 6: Show that gaussNorm is multiplicative (on all algC).

Hint: use morphism lemmas #rmorph1# and #rmorphM#
*)
Lemma gaussNorm1 : gaussNorm 1 = 1.
(*A*)Proof. by rewrite /gaussNorm rmorph1 mulr1. Qed.

Lemma gaussNormM : {morph gaussNorm : x y / x * y}.
(*A*)Proof. by move=> x y; rewrite /gaussNorm rmorphM mulrACA. Qed.
(** #
# *)
(** -------------------------------------------- *)
(** #
#

** Question 7 (hard): Find the invertible elements of GI

 - This is question 1 of the CPGE exercice

Do unitGI_norm1 first, and come back to side lemmas later.
*)

Lemma rev_unitrPr (R : comUnitRingType) (x y : R) : x * y = 1 -> x \is a GRing.unit.
Proof. by move=> ?; apply/unitrPr; exists y. Qed.

Lemma eq_algC  a b : (a == b :> algC) = ('Re a == 'Re b) && ('Im a == 'Im b).
Proof.
rewrite -subr_eq0 [a - b]algCrect -normr_eq0 -sqrf_eq0.
rewrite normC2_rect ?paddr_eq0 ?sqr_ge0 -?realEsqr ?Creal_Re ?Creal_Im //.
by rewrite !sqrf_eq0 !raddfB ?subr_eq0.
Qed.

Lemma primitive_root_i : 4.-primitive_root 'i.
Proof.
(*D*)have : 'i ^+ 4 = 1 by rewrite [_ ^+ (2 * 2)]exprM sqrCi -signr_odd expr0.
(*D*)move=> /prim_order_exists [] // [//|[|[|[//|[//|//]]]]] /prim_expr_order.
(*D*)  rewrite expr1 => /(congr1 (fun x => 'Im x)) /eqP.
(*D*)  by rewrite algIm_i (Creal_ImP _ _) ?oner_eq0 ?rpred1.
(*D*)by move/eqP; rewrite sqrCi eq_sym -addr_eq0 paddr_eq0 ?ler01 ?oner_eq0.
(*A*)Qed.

Lemma primitive_rootX_unity (C: fieldType) n (x : C) :
  n.-primitive_root x -> n.-unity_root =i [seq x ^+ (val k) | k <- enum 'I_n].
Proof.
(*D*)move=> x_p y; rewrite -topredE /= unity_rootE; apply/idP/idP; last first.
(*D*)  by move=> /mapP [k _ ->]; rewrite exprAC [x ^+ _]prim_expr_order // expr1n.
(*D*)by move=> /eqP/(prim_rootP x_p)[k ->]; apply/mapP; exists k; rewrite ?mem_enum.
(*A*)Qed.

Lemma unitGI_norm1 (a : GI) : (a \in GRing.unit) = (val a \in 4.-unity_root).
(*D*)Proof. (*give trace*)
transitivity (gaussNorm (val a) == 1).
  apply/idP/idP; last first.
(*a*)    by rewrite gaussNorm_val (val_eqE _ (1 : GI)) => /eqP /rev_unitrPr.
(*D*)  move=> /unitrPr [b /(congr1 (gaussNorm \o val)) /=] /eqP.
(*a*) by rewrite gaussNormM gaussNorm1 Cnat_mul_eq1 // => /andP [].
rewrite (primitive_rootX_unity primitive_root_i).
rewrite (map_comp (GRing.exp 'i) val) val_enum_ord /=.
rewrite /= expr0 expr1 sqrCi exprSr sqrCi mulN1r.
rewrite !in_cons in_nil ?orbF orbA orbAC !orbA orbAC -!orbA.
(*D*)rewrite [val a in LHS]algCrect gaussNormE normC2_rect ?Creal_Re ?Creal_Im //.
(*D*)rewrite Cnat_add_eq1 ?Cnat_exp_even // !sqrf_eq0 !sqrf_eq1.
(*D*)rewrite andb_orr andb_orl -!orbA.
(*D*)rewrite ?[val _ == _]eq_algC !raddfN /=.
(*a*)by rewrite algRe_i algIm_i ?(Creal_ReP 1 _) ?(Creal_ImP 1 _) ?oppr0.
(*A*)Qed.

End GaussIntegers.
(* End of exercices *)