(**************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(**************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(**************************************************************)

(* * Arithmetic libraries for Matiyasevich's theorems *)
(* ** Modular arithmetic *)

Require Import Arith Lia ZArith List Permutation Eqdep_dec.

From Undecidability.Shared.Libs.DLW.Utils
  Require Import utils_tac utils_list gcd prime binomial sums php.

From Undecidability.H10.ArithLibs
  Require Import matrix.

Set Implicit Arguments.

Section le_pirr.

  (* a dependent induction principle for le *)

  Scheme le_indd := Induction for le Sort Prop.

  Fact le_pirr : forall x y (H1 H2 : x <= y), H1 = H2.
  Proof.
    simpl; intros n ? H1.
    induction H1 as [ | m H1 IH ] using le_indd; intro H2.

    change (le_n n) with (eq_rect _ (fun n0 => n <= n0) (le_n n) _ eq_refl).
    generalize (eq_refl n).
    pattern n at 2 4 6 10, H2.
    case H2; [intro E | intros m l E].
    rewrite UIP_dec with (p1 := E) (p2 := eq_refl); auto.
    apply eq_nat_dec.
    contradiction (Nat.nle_succ_diag_l m); subst; auto.

    change (le_S n m H1) with (eq_rect _ (fun n0 => n <= n0) (le_S n m H1) _ eq_refl).
    generalize (eq_refl (S m)).
    pattern (S m) at 1 3 4 6, H2.
    case H2; [intro E | intros p H3 E].
    contradiction (Nat.nle_succ_diag_l m); subst; auto.
    injection E; intro; subst.
    rewrite (IH H3).
    rewrite UIP_dec with (p1 := E) (p2 := eq_refl); auto.
    apply eq_nat_dec.
  Qed.

End le_pirr.

Fact lt_pirr x y (H1 H2 : x < y) : H1 = H2.
Proof. apply le_pirr. Qed.

Fact Zring : ring_theory 0%Z 1%Z Zplus Zmult Zminus Z.opp eq.
Proof. exists; intros; ring. Qed.

#[export] Hint Resolve Zring Zplus_monoid Zmult_monoid : core.

Section Z_coprime.

  Open Scope Z_scope.

  Definition Z_pos_or_neg u : { 0 <= u } + { u < 0 }.
  Proof.
    destruct (Ztrichotomy_inf u 0) as [ [|] | ]; try (left; lia); tauto.
  Qed.

  Fact Z_coprime u v : (exists a b, a * Z.of_nat u + b*Z.of_nat v = 1) -> is_gcd u v 1%nat.
  Proof.
    intros (a & b & H).
    destruct (Z_pos_or_neg a) as [ Ha | Ha ];
    destruct (Z_pos_or_neg b) as [ Hb | Hb ].
    + apply bezout_sc with (a:= Z.to_nat a) (b := Z.to_nat b) (m := 0%nat).
      2: left; apply divides_0.
      apply Nat2Z.inj.
      rewrite Nat2Z.inj_add.
      repeat rewrite Nat2Z.inj_mul.
      repeat rewrite Z2Nat.id; auto.
    + apply bezout_sc with (a:= Z.to_nat a) (b := 0%nat) (m := (Z.to_nat (-b)*v)%nat).
      2: right; apply divides_mult, divides_refl.
      apply Nat2Z.inj.
      repeat rewrite Nat2Z.inj_add.
      repeat rewrite Nat2Z.inj_mul.
      repeat rewrite Z2Nat.id; auto; lia.
    + apply bezout_sc with (b:= Z.to_nat b) (a := 0%nat) (m := (Z.to_nat (-a)*u)%nat).
      2: left; apply divides_mult, divides_refl.
      apply Nat2Z.inj.
      repeat rewrite Nat2Z.inj_add.
      repeat rewrite Nat2Z.inj_mul.
      repeat rewrite Z2Nat.id; auto; lia.
    + apply Z.lt_le_incl in Ha.
      apply Z.lt_le_incl in Hb.
      exfalso; revert H.
      generalize (Z.mul_nonpos_nonneg _ _ Ha (Nat2Z.is_nonneg u)).
      generalize (Z.mul_nonpos_nonneg _ _ Hb (Nat2Z.is_nonneg v)).
      intros; lia.
  Qed.

End Z_coprime.

Section Zp.

  Variable (p : nat) (Hp : p <> 0).

  Definition Z_Zp := { x | x < p }.

  Implicit Type x y : Z_Zp.

  Fact Zp_inj : forall x y, proj1_sig x = proj1_sig y -> x = y.
  Proof. intros (x & H1) (y & H2); simpl; intros; subst; f_equal; apply lt_pirr. Qed.

  Definition Zp_plus : Z_Zp -> Z_Zp -> Z_Zp.
  Proof using Hp.
    intros (x & Hx) (y & Hy).
    exists (rem (x+y) p).
    apply div_rem_spec2; trivial.
  Defined.

  (* ⊕  ⊗  ∸    ⊞ ⊠ ⊟ *)

  Infix "⊕" := Zp_plus (at level 50, left associativity).

  Definition Zp_zero : Z_Zp.
  Proof using Hp.
    exists 0; lia.
  Defined.

  Definition Zp_opp : Z_Zp -> Z_Zp.
  Proof using Hp.
    intros (x & Hx).
    exists (rem (p - x) p).
    apply div_rem_spec2; trivial.
  Defined.

  Notation "∸" := Zp_opp.

  Definition Zp_mult : Z_Zp -> Z_Zp -> Z_Zp.
  Proof using Hp.
    intros (x & Hx) (y & Hy).
    exists (rem (x*y) p).
    apply div_rem_spec2; trivial.
  Defined.

  Infix "⊗" := Zp_mult (at level 40, left associativity).

  Definition Zp_one : Z_Zp.
  Proof using Hp.
    exists (rem 1 p); apply div_rem_spec2; trivial.
  Defined.

(*

  Infix "+p" := Zp_plus (at level 50, left associativity).
  Infix "*p" := Zp_mult (at level 40, left associativity).
  Notation "-p" := Zp_opp.

*)

  Notation Zp := Zp_zero.
  Notation Op := Zp_one.

  Fact Zp_plus_zero : forall x, Zp ⊕ x = x.
  Proof.
    intros (x & Hx); apply Zp_inj; simpl.
    apply rem_prop with 0; simpl; auto.
  Qed.

  Fact Zp_add_comm : forall x y,  x ⊕ y = y ⊕ x.
  Proof.
    intros (x & ?) (y & ?); apply Zp_inj; simpl.
    f_equal; lia.
  Qed.

  Fact Zp_add_assoc : forall x y z, x ⊕ (y ⊕ z) = x ⊕ y ⊕ z.
  Proof.
    intros (x & ?) (y & ?) (z & ?); apply Zp_inj; simpl.
    rewrite (Nat.add_comm (rem _ _) z), rem_plus_rem, rem_plus_rem.
    f_equal; ring.
  Qed.

  Fact Zp_minus : forall x, x ⊕ ∸ x = Zp.
  Proof.
    intros ([ | x ] & Hx); apply Zp_inj; simpl.
    + rewrite Nat.sub_0_r, rem_diag, rem_lt; auto.
    + rewrite rem_lt with (a := _ - _); try lia.
      replace (S (x+(p - S x))) with p by lia.
      apply rem_diag; auto.
  Qed.

  Fact Zp_mult_one : forall x, Op ⊗ x = x.
  Proof.
    intros (x & ?); apply Zp_inj; simpl proj1_sig.
    destruct p as [ | [ | q ] ].
    + destruct Hp; auto.
    + rewrite rem_diag; simpl; auto.
      rewrite rem_lt; lia.
    + rewrite rem_lt with (a := 1); try lia.
      rewrite Nat.mul_1_l, rem_lt; lia.
  Qed.

  Fact Zp_mul_comm : forall x y, x ⊗ y = y ⊗ x.
  Proof.
    intros (x & ?) (y & ?); apply Zp_inj; simpl.
    f_equal; ring.
  Qed.

  Fact Zp_mult_one_r x : x ⊗ Op = x.
  Proof. rewrite Zp_mul_comm, Zp_mult_one; auto. Qed.

  Fact Zp_mul_assoc : forall x y z, x ⊗ (y ⊗ z) = x ⊗ y ⊗ z.
  Proof.
    intros (x & ?) (y & ?) (z & ?); apply Zp_inj; simpl.
    rewrite (Nat.mul_comm (rem _ _) z), rem_mult_rem, rem_mult_rem.
    f_equal; ring.
  Qed.

  Fact Zp_mult_plus_distr_l : forall x y z, x ⊗ (y ⊕ z) = x ⊗ y ⊕ x ⊗ z.
  Proof.
    intros (x & ?) (y & ?) (z & ?); apply Zp_inj; simpl.
    rewrite <- rem_plus, <- rem_scal; f_equal; ring.
  Qed.

  Fact Zp_mult_plus_distr_r x y z : (y ⊕ z) ⊗ x = y ⊗ x ⊕ z ⊗ x.
  Proof. do 3 rewrite (Zp_mul_comm _ x); apply Zp_mult_plus_distr_l. Qed.

  (* Define a ring structureon Zp *)

  Definition Zp_is_ring : @ring_theory _ Zp Op Zp_plus Zp_mult (fun x y => x ⊕ ∸ y) Zp_opp eq.
  Proof.
    exists.
    + apply Zp_plus_zero.
    + apply Zp_add_comm.
    + apply Zp_add_assoc.
    + apply Zp_mult_one.
    + apply Zp_mul_comm.
    + apply Zp_mul_assoc.
    + intros; apply Zp_mult_plus_distr_r.
    + auto.
    + apply Zp_minus.
  Qed.

  (* Invertible elements are some which are relatively prime to x *)

  Fact Zp_mult_invert : forall x, is_gcd p (proj1_sig x) 1 -> { i | i ⊗ x = Op }.
  Proof.
    intros  (x & Hx); simpl; intros H.
    destruct (bezout_generalized p x) as (u & v & g & l & H1 & H2 & H3 & _).
    generalize (is_gcd_fun H H2); intro; subst g.
    exists (exist _ (rem v p) (@div_rem_spec2 v p Hp)).
    apply Zp_inj; simpl.
    rewrite Nat.mul_comm, <- rem_scal.
    destruct H3 as (k & H3).
    rewrite Nat.mul_comm.
    rewrite <- rem_erase with (n := u) (1 := eq_refl).
    rewrite <- rem_erase with (n := k) (r := 1) (1 := eq_refl).
    f_equal.
    rewrite H1,H3; ring.
  Qed.

  Fact Zp_mult_revert : forall x i, i ⊗ x = Op -> is_gcd p (proj1_sig x) 1.
  Proof.
    intros (x & Hx) (i & Hi) H; simpl.
    apply f_equal with (f := @proj1_sig _ _) in H; simpl in H.
    destruct (le_lt_dec p 1) as [ H' | H'].
    + replace p with 1 by lia.
      apply is_gcd_1l.
    + rewrite rem_lt with (a := 1) in H; try lia.
      generalize (div_rem_spec1 (i*x) p).
      rewrite H.
      generalize (div (i*x) p); clear H Hi; intros u Hu.
      apply bezout_sc with 1 i ((1+u)* p).
      * rewrite Hu; ring.
      * left; apply divides_mult, divides_refl.
  Qed.

  Definition Zp_invertible x := exists i, i ⊗ x = Op.

  Fact Zp_invertible_spec x : Zp_invertible x <-> is_gcd p (proj1_sig x) 1.
  Proof.
    split.
    + intros (i & Hi); revert Hi; apply Zp_mult_revert.
    + intros H; destruct (Zp_mult_invert _ H) as (i & ?); exists i; auto.
  Qed.

  Fact Zp_prime_invert : prime p -> forall x, x <> Zp -> { i | i ⊗ x = Op }.
  Proof.
    intros Hp' x Hx.
    apply Zp_mult_invert.
    destruct x; simpl in *.
    destruct (prime_gcd x Hp') as [ | H ]; auto.
    exfalso; apply Hx, Zp_inj; simpl.
    destruct H as ([ | k ] & Hk); simpl in Hk; auto.
    revert Hk; generalize (k* p); intros; lia.
  Qed.

  (* So we have the commutative ring structure and the field structure for p prime

     These follow form (non-commutative) ring axioms

   *)

  Add Ring Zp_ring : Zp_is_ring.

  Fact Zp_plus_monoid : monoid_theory Zp_plus Zp_zero.
  Proof. exists; intros; ring. Qed.

  Fact Zp_mult_monoid : monoid_theory Zp_mult Zp_one.
  Proof. exists; intros; ring. Qed.

  Fact Zp_one_invertible : Zp_invertible Op.
  Proof. exists Op; ring. Qed.

  Fact Zp_opp_invertible x : Zp_invertible x <-> Zp_invertible (∸ x).
  Proof. split; intros (i & Hi); exists (∸ i); rewrite <- Hi; ring. Qed.

  Fact Zp_mult_invertible x y : Zp_invertible x -> Zp_invertible y -> Zp_invertible (x ⊗ y).
  Proof.
    intros (u & H1) (v & H2); exists (u⊗v); rewrite <- (Zp_mult_one Op).
    rewrite <- H1 at 1.
    rewrite <- H2; ring.
  Qed.

  Hint Resolve Zp_one_invertible Zp_opp_invertible Zp_mult_invertible : core.

  Fact Zp_expo_invertible n x : Zp_invertible x -> Zp_invertible (mscal Zp_mult Op n x).
  Proof. intros; induction n; [ rewrite mscal_0 | rewrite mscal_S ]; auto. Qed.

  Fact Zp_invertible_cancel_l x y z : Zp_invertible x -> x⊗y = x⊗z -> y = z.
  Proof.
    intros (i & Hi) H.
    rewrite <- (Zp_mult_one y), <- Hi, <- Zp_mul_assoc,
            H, Zp_mul_assoc, Hi, Zp_mult_one; auto.
  Qed.

  (* ⊕  ⊗  ∸ *)

  Fact Zp_opp_zero : ∸ Zp = Zp.
  Proof. ring. Qed.

  Fact Zp_plus_inj_l x y z : x ⊕ y = x ⊕ z -> y = z.
  Proof.
    intros H.
    apply f_equal with (f := fun a => ∸ x ⊕ a) in H.
    do 2 rewrite Zp_add_assoc in H.
    rewrite (Zp_add_comm _ x), Zp_minus in H.
    do 2 rewrite Zp_plus_zero in H; auto.
  Qed.

  Fact Zp_plus_zero_r x : x ⊕ Zp = x.
  Proof. ring. Qed.

  Fact Zp_opp_inv x : ∸ (∸ x) = x.
  Proof. ring. Qed.

  Fact Zp_opp_inj x y : ∸ x = ∸ y -> x = y.
  Proof. intros H; rewrite <- (Zp_opp_inv x), H; ring. Qed.

  Fact Zp_opp_plus x y : ∸ (x ⊕ y) = ∸ x ⊕ ∸ y.
  Proof. ring. Qed.

  Fact Zp_opp_plus_eq x y z : x ⊕ y = z <-> x = z ⊕ ∸ y.
  Proof. split; intros; subst; ring. Qed.

  Fact Zp_mult_zero x : Zp ⊗ x = Zp.
  Proof. ring. Qed.

  Fact Zp_mult_minus_one x : (∸ Op) ⊗ x = ∸ x.
  Proof. ring. Qed.

  Fact Zp_opp_mult x y : (∸ x) ⊗ y = ∸ (x ⊗ y).
  Proof. ring. Qed.

  Fact Zp_invertible_eq_zero x y : Zp_invertible x -> x ⊗ y = Zp -> y = Zp.
  Proof.
    intros (i & Hi) H1.
    rewrite <- (Zp_mult_one y), <- Hi at 1.
    rewrite <- Zp_mul_assoc, H1; ring.
  Qed.

  Fact Zp_zero_is_one : Zp = Op <-> p = 1.
  Proof.
    split.
    + intros H; apply f_equal with (f := @proj1_sig _ _) in H; simpl in H.
      symmetry in H.
      apply divides_rem_eq, divides_1_inv in H; auto.
    + intros; apply Zp_inj; simpl; subst; rewrite rem_diag; auto.
  Qed.

  Fact Zp_eq_dec : forall x y : Z_Zp, { x = y } + { x <> y }.
  Proof.
    intros (x & Hx) (y & Hy).
    destruct (eq_nat_dec x y) as [ | H ].
    + left; apply Zp_inj; auto.
    + right; contradict H.
      apply f_equal with (f := @proj1_sig _ _) in H; auto.
  Qed.

  (* We define a morphism for nat to Z_Zp *)

  Section nat2Zp.

    Definition nat2Zp (u : nat) : Z_Zp.
    Proof using Hp.
      exists (rem u p); apply div_rem_spec2; trivial.
    Defined.

    Arguments nat2Zp u /.

    Notation "〚 x 〛" := (nat2Zp x).

    Fact nat2Zp_zero : 〚0〛= Zp.
    Proof.
      apply Zp_inj; simpl.
      apply rem_prop with 0; lia.
    Qed.

    Fact nat2Zp_one : 〚1〛= Op.
    Proof.
      apply Zp_inj; simpl; auto.
    Qed.

    Fact nat2Zp_invertible n : Zp_invertible 〚n〛 <-> is_gcd p n 1.
    Proof.
      rewrite Zp_invertible_spec.
      symmetry; apply is_gcd_rem.
    Qed.

    Fact nat2Zp_p :〚p〛= Zp.
    Proof.
      apply Zp_inj; simpl.
      apply rem_diag; lia.
    Qed.

    Fact nat2Zp_inj u v : 〚u〛=〚v〛 <-> rem u p = rem v p.
    Proof.
      split; intros H.
      + apply f_equal with (f := @proj1_sig _ _) in H; auto.
      + apply Zp_inj; auto.
    Qed.

    Fact nat2Zp_surj u : { x | x < p /\ u = 〚x〛 }.
    Proof.
      destruct u as (u & Hu); exists u; split; auto.
      apply Zp_inj; simpl.
      rewrite rem_prop with (n := 0) (2 := Hu); auto.
    Qed.

    Fact nat2Zp_plus u v : 〚u+v〛=〚u〛⊕〚v〛.
    Proof.
      apply Zp_inj; simpl.
      rewrite rem_plus_rem, (Nat.add_comm (rem _ _)), rem_plus_rem.
      f_equal; ring.
    Qed.

    Fact nat2Zp_minus u v : v <= u -> 〚u-v〛=〚u〛⊕ ∸〚v〛.
    Proof.
      intros; apply Zp_inj; simpl.
      rewrite rem_plus_rem, (Nat.add_comm (rem _ _)), Nat.add_comm.
      generalize (div u p) (div v p) (div_rem_spec1 u p) (div_rem_spec1 v p).
      intros a b H1 H2.
      assert (b <= a) as Hab.
      { destruct (le_lt_dec b a); auto.
        replace b with ((1+a) + (b-a-1)) in H2 by lia.
        generalize (div_rem_spec2 u Hp) (div_rem_spec2 v Hp); intros H3 H4.
        do 2 rewrite Nat.mul_add_distr_r in H2.
        contradict H; rewrite H1, H2, Nat.mul_1_l.
        generalize (a* p) ((b-a-1)* p); intros; lia. }
      destruct (eq_nat_dec a b) as [ | Ha ]; try subst b.
      + assert (rem v p <= rem u p) as H3.
        { rewrite H1, H2 in H; revert H; intros; lia. }
        symmetry; apply rem_erase with 1.
        rewrite H1 at 2.
        rewrite H2 at 2.
        generalize (a* p) (div_rem_spec2 v Hp); intros; lia.
      + apply rem_erase with (a-b-1).
        rewrite H2 at 1; rewrite H1 at 1.
        do 2 rewrite Nat.mul_sub_distr_r.
        rewrite Nat.mul_1_l.
        assert (b* p + p <= a* p) as E.
        { replace a with (1+b+(a-b-1)) by lia.
          do 2 rewrite Nat.mul_add_distr_r.
          generalize (b* p) ((a-b-1)* p); intros; lia. }
        revert E.
        generalize (a* p) (b* p) (div_rem_spec2 u Hp) (div_rem_spec2 v Hp); intros.
        lia.
    Qed.

    Fact nat2Zp_minus_one : 〚p-1〛= ∸Op.
    Proof.
      rewrite nat2Zp_minus; try lia.
      rewrite nat2Zp_p, nat2Zp_one; ring.
    Qed.

    Fact nat2Zp_mult u v :〚u*v〛=〚u〛⊗〚v〛.
    Proof.
      apply Zp_inj; simpl.
      rewrite rem_mult_rem, (Nat.mul_comm (rem _ _)), rem_mult_rem.
      f_equal; ring.
    Qed.

    Fact nat2Zp_expo n u : 〚mscal mult 1%nat n u〛 = mscal Zp_mult Zp_one n 〚u〛.
    Proof.
      induction n as [ | n IHn ].
      + do 2 rewrite mscal_0; auto.
      + do 2 rewrite mscal_S.
        rewrite nat2Zp_mult, IHn; auto.
    Qed.

    Fact nat2Zp_divides u v :〚u〛=〚v〛-> divides p u -> divides p v.
    Proof.
      intros H.
      apply f_equal with (f := @proj1_sig _ _) in H; simpl in H.
      do 2 (rewrite divides_rem_eq; auto); lia.
    Qed.

    Fact divides_nat2Zp u : divides p u <-> 〚u〛= Zp.
    Proof.
      split.
      + intros (q & Hq); apply Zp_inj; simpl.
        apply rem_prop with q; lia.
      + intros H.
        apply f_equal with (f := @proj1_sig _ _) in H; simpl in H.
        exists (div u p).
        rewrite (div_rem_spec1 u p) at 1; lia.
    Qed.

  End nat2Zp.

  Arguments nat2Zp u /.

  Definition Zp_list := map nat2Zp (list_an 0 p).

  Fact Zp_list_spec x : In x Zp_list.
  Proof.
    destruct (nat2Zp_surj x) as (n & H1 & H2); subst.
    apply in_map_iff; exists n; split; auto.
    apply list_an_spec; lia.
  Qed.

  Fact Zp_list_length : length Zp_list = p.
  Proof. unfold Zp_list; rewrite map_length, list_an_length; auto. Qed.

  Fact Zp_invertible_prime x : prime p -> Zp_invertible x <-> x <> Zp.
  Proof.
    intros H.
    split.
    + intros (i & Hi) E.
      subst.
      rewrite Zp_mul_comm, Zp_mult_zero, Zp_zero_is_one in Hi.
      apply prime_ge_2 in H; lia.
    + intros Hx.
      destruct (nat2Zp_surj x) as (u & _ & Hu).
      rewrite Hu; apply nat2Zp_invertible.
      destruct (prime_gcd u H) as [ H1 | H1 ]; auto.
      destruct Hx.
      rewrite Hu; apply divides_nat2Zp; auto.
  Qed.

  Fact Zp_prime_integral x y : prime p -> x ⊗ y = Zp -> x = Zp \/ y = Zp.
  Proof.
    intros H1 H2.
    destruct (Zp_eq_dec x Zp) as [ | H ]; auto; right.
    revert H2; apply Zp_invertible_eq_zero, Zp_invertible_prime; auto.
  Qed.

  Fact Zp_prime_square_eq_square x y : prime p -> x⊗x = y⊗y <-> x = y \/ x = ∸y.
  Proof.
    intros H1; split.
    + intros H2.
      assert ((x⊕∸y)⊗(x⊕y) = Zp) as H3.
      { rewrite Zp_mult_plus_distr_l, Zp_mult_plus_distr_r, H2; ring. }
      apply Zp_prime_integral in H3; auto.
      destruct H3 as [ H3 | H3 ]; [ left | right ];
        rewrite Zp_opp_plus_eq in H3; rewrite H3; ring.
    + intros [ | ]; subst x; ring.
  Qed.

  Fact Zp_prime_square_one x : prime p -> x⊗x = Op <-> x = Op \/ x = ∸Op.
  Proof.
    rewrite <- (Zp_mult_one Op) at 1.
    apply Zp_prime_square_eq_square.
  Qed.

  (* We define a morphism for Z to Z_Zp *)

  Section Z2Zp.

    Open Scope Z_scope.

    Implicit Types u v w : Z.

    Definition Z2Zp u : Z_Zp.
    Proof using Hp.
      destruct (Z_pos_or_neg u) as [ H | H ].
      + apply nat2Zp, Z.to_nat; exact u.
      + apply Zp_opp, nat2Zp, Z.to_nat; exact (-u).
    Defined.

    Arguments Z2Zp u /.

    Notation "〘 x 〙" := (Z2Zp x).
    Notation "〚 x 〛" := (nat2Zp x).

    Fact Z2Zp_pos u : 0 <= u -> 〘u〙= 〚Z.to_nat u〛.
    Proof.
      intros H.
      unfold Z2Zp.
      destruct (Z_pos_or_neg u); try lia; auto.
    Qed.

    Fact Z2Zp_of_nat n : 〘Z.of_nat n〙 = 〚n〛.
    Proof.
      rewrite Z2Zp_pos, Nat2Z.id; auto.
      apply Zle_0_nat.
    Qed.

    Fact Z2Zp_zero : 〘0〙= Zp.
    Proof.
      rewrite Z2Zp_pos; try lia.
      rewrite Z2Nat.inj_0, nat2Zp_zero; auto.
    Qed.

    Fact Z2Zp_neg u : u <= 0 -> 〘u〙 = ∸〘-u〙.
    Proof.
      intros H.
      unfold Z2Zp at 1.
      destruct (Z_pos_or_neg u) as [ H' | H' ]; try lia; auto.
      replace u with 0 by lia.
      rewrite Z.opp_0, Z2Nat.inj_0, nat2Zp_zero, Z2Zp_zero; auto.
      symmetry; apply Zp_opp_zero.
      unfold Z2Zp.
      destruct (Z_pos_or_neg (-u)) as [ H'' | H'' ]; try lia; auto.
    Qed.

    (* ⊕  ⊗  ∸ *)

    Section Z2Zp_plus.

      Let Z2Zp_plus_loc u v : u <= 0 -> 0 <= v -> -u <= v -> 〘u+v〙=〘u〙⊕〘v〙.
      Proof.
        intros H1 H2 H3.
        rewrite Z2Zp_pos; try lia.
        rewrite Z2Zp_neg; try lia.
        do 2 (rewrite Z2Zp_pos; try lia).
        replace (u+v) with (v-(-u)) by lia.
        rewrite Z2Nat.inj_sub; try lia.
        rewrite nat2Zp_minus.
        + apply Zp_add_comm.
        + rewrite <- Z2Nat.inj_le; lia.
      Qed.

      Let Z2Zp_plus_loc' u v : u <= 0 -> 0 <= v -> v <= -u -> 〘u+v〙=〘u〙⊕〘v〙.
      Proof.
        intros H1 H2 H3.
        rewrite Z2Zp_neg; try lia.
        rewrite Z2Zp_pos; try lia.
        rewrite Z2Zp_neg; try lia.
        do 2 (rewrite Z2Zp_pos; try lia).
        replace (-(u+v)) with (-u-v) by lia.
        rewrite Z2Nat.inj_sub; try lia.
        rewrite nat2Zp_minus; auto.
        + rewrite Zp_opp_plus, Zp_opp_inv; auto.
        + rewrite <- Z2Nat.inj_le; lia.
      Qed.

      Fact Z2Zp_plus u v : 〘u+v〙=〘u〙⊕〘v〙.
      Proof.
        destruct (Z_pos_or_neg u) as [ H1 | H1 ];
        destruct (Z_pos_or_neg v) as [ H2 | H2 ].
        + do 3 (rewrite Z2Zp_pos; try lia).
          rewrite Z2Nat.inj_add; auto.
          apply nat2Zp_plus.
        + rewrite Z.add_comm, Zp_add_comm.
          destruct (Z_pos_or_neg (u+v)).
          - apply Z2Zp_plus_loc; lia.
          - apply Z2Zp_plus_loc'; lia.
        + destruct (Z_pos_or_neg (u+v)).
          - apply Z2Zp_plus_loc; lia.
          - apply Z2Zp_plus_loc'; lia.
        + do 3 (rewrite Z2Zp_neg, Z2Zp_pos; try lia).
          rewrite <- Zp_opp_plus; f_equal.
          replace (-(u+v)) with ((-u)+(-v)) by lia.
          rewrite Z2Nat.inj_add; try lia.
          apply nat2Zp_plus.
      Qed.

    End Z2Zp_plus.

    Fact Z2Zp_opp u :〘-u〙= ∸〘u〙.
    Proof.
      apply Zp_plus_inj_l with (Z2Zp u).
      rewrite Zp_minus, <- Z2Zp_plus, <- Z2Zp_zero.
      f_equal; lia.
    Qed.

    Fact Z2Zp_minus u v : 〘u-v〙 = 〘u〙⊕ ∸〘v〙.
    Proof.
      replace (u-v) with (u+(-v)) by lia.
      rewrite Z2Zp_plus; f_equal.
      apply Z2Zp_opp.
    Qed.

    Section Z2Zp_canon.

      (* Find a representative in the A interval [0,Z.of_nat p[ *)

      Let Z2Zp_canon_pos u : 0 <= u -> { v | 〘u〙=〘v〙 /\ 0 <= v < Z.of_nat p }.
      Proof.
        intros H1.
        rewrite Z2Zp_pos; auto.
        exists (Z.of_nat (rem (Z.to_nat u) p)); split.
        rewrite Z2Zp_of_nat.
        apply nat2Zp_inj.
        rewrite rem_rem; auto.
        split.
        * apply Zle_0_nat.
        * apply inj_lt, div_rem_spec2; auto.
      Qed.

      Let Z2Zp_canon_neg u : u <= 0 -> { v | 〘u〙=〘v〙 /\ 0 <= v < Z.of_nat p }.
      Proof.
        intros H1.
        rewrite Z2Zp_neg; try lia.
        rewrite Z2Zp_opp, Zp_opp_inv.
        destruct (Zp_eq_dec (Z2Zp u) Zp_zero) as [ E | D ].
        + exists 0; split.
          * rewrite E, Z2Zp_zero; auto.
          * split; lia.
        + destruct Z2Zp_canon_pos with (u := -u)
          as (v & H2 & H3); try lia.
          exists (Z.of_nat p - v); split.
          * rewrite Z2Zp_minus, Z2Zp_of_nat, nat2Zp_p, <- H2, Z2Zp_opp; ring.
          * split; try lia.
            destruct (Z.eq_dec v 0) as [ E | ]; try lia.
            subst; destruct D.
            rewrite Z2Zp_opp in H2.
            rewrite <- (Zp_opp_inv 〘 _ 〙), H2, Z2Zp_zero; ring.
      Qed.

      Fact Z2Zp_repr_canon u : { v |〘u〙=〘v〙 /\ 0 <= v < Z.of_nat p }.
      Proof.
        destruct (Z_pos_or_neg u); auto.
        apply Z2Zp_canon_neg; lia.
      Qed.

    End Z2Zp_canon.

    Fact Zp_repr_interval a b u :
            Z.of_nat p <= b-a -> { v |〘u〙=〘v〙/\ a <= v < b }.
    Proof.
      intros Hab.
      destruct (Z2Zp_repr_canon (u-a)) as (v & H1 & H2).
      exists (a+v)%Z; split; try lia.
      rewrite Z2Zp_plus, <- H1, Z2Zp_minus; ring.
    Qed.

    Section Z2Zp_mult.

      Let Z2Zp_mult_loc u v : 0 <= u -> 0 <= v -> 〘u*v〙=〘u〙⊗〘v〙.
      Proof.
        intros H1 H2.
        rewrite Z2Zp_pos; try lia.
        do 2 (rewrite Z2Zp_pos; try lia).
        rewrite Z2Nat.inj_mul; auto.
        apply nat2Zp_mult.
      Qed.

      Fact Z2Zp_mult u v : 〘u*v〙=〘u〙⊗〘v〙.
      Proof.
        destruct (Z_pos_or_neg u) as [ H1 | H1 ];
        destruct (Z_pos_or_neg v) as [ H2 | H2 ].
        + apply Z2Zp_mult_loc; auto.
        + replace (u*v) with (-(u*-v)); try ring.
          rewrite Z2Zp_opp, Z2Zp_mult_loc; try lia.
          rewrite Z2Zp_opp, Zp_mul_comm, Zp_opp_mult, Zp_opp_inv.
          apply Zp_mul_comm.
        + replace (u*v) with (- ((-u)*v)); try ring.
          rewrite Z2Zp_opp, Z2Zp_mult_loc; try lia.
          rewrite Z2Zp_opp, Zp_opp_mult, Zp_opp_inv; auto.
        + replace (u*v) with ((-u)*(-v)); try ring.
          rewrite Z2Zp_mult_loc; try lia.
          do 2 rewrite Z2Zp_opp.
          do 2 rewrite Zp_opp_mult, Zp_mul_comm.
          apply Zp_opp_inv.
      Qed.

    End Z2Zp_mult.

    Fact Z2Zp_one : 〘1〙 = Op.
    Proof.
      rewrite Z2Zp_pos; try lia.
      apply Zp_inj; simpl; f_equal; auto.
    Qed.

    Section Z2Zp_inj.

      Let Z2Zp_inj_loc u v : v <= u ->〘u〙=〘v〙-> exists i, u-v = i*Z.of_nat p.
      Proof.
        intros H2 H.
        assert (〘u-v〙= Zp) as H1.
        { rewrite Z2Zp_minus, H; ring. }
        rewrite Z2Zp_pos in H1; auto; try lia.
        rewrite <- nat2Zp_zero in H1.
        apply nat2Zp_inj in H1.
        rewrite rem_of_0 in H1.
        generalize (@div_rem_spec1 (Z.to_nat (u-v)) p); intros H3.
        rewrite H1 in H3.
        apply f_equal with (f := Z.of_nat) in H3.
        rewrite Z2Nat.id in H3; auto; try lia.
        rewrite H3.
        exists (Z.of_nat (div (Z.to_nat (u-v)) p)).
        rewrite Nat2Z.inj_add, Nat2Z.inj_mul; simpl; ring.
      Qed.

      Fact Z2Zp_inj u v :〘u〙=〘v〙<-> exists i, u-v = i*Z.of_nat p.
      Proof.
        split.
        + destruct (Z_pos_or_neg (u-v)) as [ H | H ].
          * apply Z2Zp_inj_loc; lia.
          * intros H'; symmetry in H'.
            apply Z2Zp_inj_loc in H'; try lia.
            destruct H' as (i & Hi).
            exists (-i).
            apply f_equal with (f := Z.opp) in Hi.
            ring_simplify in Hi.
            rewrite <- Hi; ring.
        + intros (i & Hi).
          replace u with (v+(u-v)) by lia.
          rewrite Hi, Z2Zp_plus, Z2Zp_mult, Z2Zp_of_nat, nat2Zp_p; ring.
      Qed.

    End Z2Zp_inj.

    Fact Z2Zp_zero_inv u :
          〘u〙= Zp_zero
        -> exists v, (u = Z.of_nat p * v)%Z.
    Proof.
      intros H.
      rewrite <- Z2Zp_zero in H.
      apply Z2Zp_inj in H.
      destruct H as (y & Hy); exists y.
      rewrite Z.mul_comm, <- Hy; ring.
    Qed.

    Fact nat2Zp_choose : forall x, x = Zp \/ x = Op \/ x = ∸ Op \/ exists m,  (1 < m < p-1)%nat /\〚m〛= x.
    Proof.
      intros (x & Hx).
      destruct x as [ | [ | x ] ].
      + left; apply Zp_inj; simpl; auto.
      + right; left; apply Zp_inj; simpl; rewrite rem_lt; auto.
      + destruct (eq_nat_dec (S (S x)) (p-1)) as [ H | H ].
        * do 2 right; left.
          rewrite <- nat2Zp_minus_one.
          apply Zp_inj; simpl; rewrite rem_lt; lia.
        * do 3 right; exists (S (S x)); split; try lia.
          apply Zp_inj; simpl; rewrite rem_lt; lia.
    Qed.

    Section prime.

      Hypothesis Hp' : prime p.

      Fact nat2Zp_invertible_prime n : (0 < n < p)%nat -> Zp_invertible 〚n〛.
      Proof using Hp'.
        intros Hn.
        apply Zp_invertible_prime; auto.
        intros H.
        apply divides_nat2Zp in H.
        destruct H as ([ | k ] & Hk).
        + simpl in Hk; lia.
        + revert Hn; rewrite Hk; simpl.
          generalize (k*p)%nat; intros; lia.
      Qed.

      Let Hp'' : (2 <= p)%nat.
      Proof. apply prime_ge_2; trivial. Qed.

      Let Hzero_one : Zp <> Op.
      Proof.
        intros H.
        apply Zp_zero_is_one in H.
        lia.
      Qed.

      Fact Zp_invertible_factorial n : (n < p)%nat -> Zp_invertible 〚fact n〛.
      Proof using Hp'.
        induction n as [ | n IHn ]; intros Hn.
        + rewrite fact_0; apply nat2Zp_invertible_prime; lia.
        + rewrite fact_S, nat2Zp_mult; apply Zp_mult_invertible.
          * apply nat2Zp_invertible_prime; lia.
          * apply IHn; lia.
      Qed.

      Section inv.

        Let Zp_invert_full x : { i | (x = Zp -> i = Zp) /\ (x <> Zp -> i ⊗ x = Op) }.
        Proof.
          destruct (Zp_eq_dec x Zp) as [ Hx | Hx ].
          + exists Zp; split; auto; intros []; auto.
          + destruct Zp_prime_invert with (2 := Hx) as (i & Hi); trivial.
            exists i; split; auto; intros; destruct Hx; auto.
        Qed.

        Definition Zp_invert x := proj1_sig (Zp_invert_full x).

        Fact Zp_invert_spec1 : Zp_invert Zp = Zp.
        Proof. apply (proj2_sig (Zp_invert_full Zp)); trivial. Qed.

        Fact Zp_invert_spec2 x : x <> Zp -> Zp_invert x ⊗ x = Op.
        Proof. apply (proj2_sig (Zp_invert_full x)). Qed.

      End inv.

      Notation inv := Zp_invert.

      Fact Zp_invert_eq_not_zero x y : x <> Zp -> inv x = y <-> y ⊗ x = Op.
      Proof.
        intros H1.
        split.
        + intros H2; rewrite <- H2; apply Zp_invert_spec2; auto.
        + intros H2.
          apply Zp_invert_spec2 in H1.
          rewrite <- (Zp_mult_one (inv x)) , <- H2, <- Zp_mul_assoc,
                    (Zp_mul_comm x), H1, Zp_mul_comm, Zp_mult_one.
          trivial.
      Qed.

      Fact Zp_invert_opp x : inv (∸x) = ∸(inv x).
      Proof.
        destruct (Zp_eq_dec x Zp) as [ Hx | Hx ].
        + subst; rewrite Zp_opp_zero, Zp_invert_spec1, Zp_opp_zero; auto.
        + apply Zp_invert_eq_not_zero.
          * contradict Hx.
            rewrite <- (Zp_opp_inv x), Hx, Zp_opp_zero; trivial.
          * do 2 rewrite Zp_opp_mult, Zp_mul_comm.
            rewrite Zp_opp_inv, Zp_invert_spec2; auto.
      Qed.

      Fact Zp_invert_one : inv Op = Op.
      Proof.
        rewrite Zp_invert_eq_not_zero; auto.
        rewrite Zp_mult_one; auto.
      Qed.

      Fact Zp_invert_minus_one : inv (∸ Op) = ∸ Op.
      Proof. rewrite Zp_invert_opp, Zp_invert_one; auto. Qed.

      Fact Zp_invert_fix x : inv x = x <-> x = Zp \/ x = Op \/ x = ∸ Op.
      Proof.
        split.
        + intros H.
          destruct (Zp_eq_dec x Zp) as [ Hx | Hx ]; auto.
          apply Zp_invert_spec2 in Hx.
          rewrite H in Hx.
          apply Zp_prime_square_one in Hx; auto.
        + intros [ | [|]]; subst.
          * apply Zp_invert_spec1.
          * apply Zp_invert_eq_not_zero; try ring.
            intros H; symmetry in H; revert H; rewrite Zp_zero_is_one; lia.
          * apply Zp_invert_eq_not_zero; try ring.
            intros H.
            rewrite <- Zp_opp_zero in H.
            symmetry in H; apply Zp_opp_inj in H.
            revert H; rewrite Zp_zero_is_one; lia.
      Qed.

      Fact Zp_invert_involutive x : inv (inv x) = x.
      Proof.
        destruct (Zp_eq_dec x Zp) as [ Hx | Hx ]; subst.
        + do 2 rewrite Zp_invert_spec1; auto.
        + apply Zp_invert_eq_not_zero.
          * intros H.
            apply Zp_invert_spec2 in Hx.
            rewrite H, Zp_mult_zero in Hx.
            apply Zp_zero_is_one in Hx; lia.
          * rewrite Zp_mul_comm; apply Zp_invert_spec2; auto.
      Qed.

      Fact Zp_invert_not_fix n : (1 < n < p-1)%nat -> inv〚n〛<>〚n〛.
      Proof.
        intros H1 H2.
        apply Zp_invert_fix in H2.
        destruct H2 as [ H2 | [ H2 | H2 ] ].
        + rewrite <- nat2Zp_zero in H2.
          apply nat2Zp_inj in H2.
          rewrite rem_lt, rem_lt in H2; lia.
        + rewrite <- nat2Zp_one in H2.
          apply nat2Zp_inj in H2.
          rewrite rem_lt, rem_lt in H2; lia.
        + rewrite <- nat2Zp_minus_one in H2.
          apply nat2Zp_inj in H2.
          rewrite rem_lt, rem_lt in H2; lia.
      Qed.

      Fact Zp_invert_stable n : (1 < n < p-1)%nat -> exists m, (1 < m < p-1)%nat /\〚m〛= inv〚n〛.
      Proof.
        intros Hn.
        destruct (nat2Zp_choose (inv 〚n〛)) as [ H | [ H | [ H | H ] ] ]; auto;
          exfalso; apply f_equal with (f := inv) in H;
          rewrite Zp_invert_involutive in H; symmetry in H.
        + rewrite Zp_invert_spec1 in H.
          rewrite <- nat2Zp_zero, nat2Zp_inj in H.
          rewrite rem_lt, rem_lt in H; lia.
        + rewrite Zp_invert_one, <- nat2Zp_one in H.
          rewrite nat2Zp_inj, rem_lt, rem_lt in H; lia.
        + rewrite Zp_invert_minus_one, <- nat2Zp_minus_one in H.
          rewrite nat2Zp_inj, rem_lt, rem_lt in H; lia.
      Qed.

      Definition Zp_lprod := fold_right Zp_mult Zp_one.

      Fact Zp_lprod_nil : Zp_lprod nil = Op.
      Proof. trivial. Qed.

      Fact Zp_lprod_cons x l : Zp_lprod (x::l) = x ⊗ Zp_lprod l.
      Proof. trivial. Qed.

      Fact Zp_lprod_app l m : Zp_lprod (l++m) = Zp_lprod l ⊗  Zp_lprod m.
      Proof.
        induction l as [ | x l IHl ].
        + rewrite Zp_lprod_nil, Zp_mult_one; auto.
        + simpl app; do 2 rewrite Zp_lprod_cons.
          rewrite IHl; ring.
      Qed.

      Theorem Zp_mult_autoinv l : ~ list_has_dup l -> (forall x, In x l -> x <> Zp /\ inv x <> x /\ In (inv x) l) -> Zp_lprod l = Op.
      Proof.
        induction on l as IHl with measure (length l); intros H0 Hl.
        destruct l as [ | x l ].
        + rewrite Zp_lprod_nil; auto.
        + destruct (Hl x) as (H1 & H2 & [H3 | H3]); try (simpl; auto; fail).
          1: destruct H2; auto.
          destruct in_split with (1 := H3) as (u & v & ?); subst.
          rewrite Zp_lprod_cons, Zp_lprod_app, Zp_lprod_cons.
          rewrite (Zp_mul_assoc _ (inv x)), (Zp_mul_comm _ (inv x)).
          repeat rewrite Zp_mul_assoc.
          rewrite (Zp_mul_comm _ (inv x)), Zp_invert_spec2; auto.
          rewrite Zp_mult_one, <- Zp_lprod_app.
          apply IHl.
          * simpl; do 2 rewrite app_length; simpl; lia.
          * contradict H0.
            constructor 2.
            apply perm_list_has_dup with (inv x::u++v).
            - apply Permutation_cons_app; auto.
            - constructor 2; auto.
          * intros y Hy.
            destruct (Hl y) as (G1 & G2 & G3).
            - apply in_app_or in Hy; right; apply in_or_app; simpl; tauto.
            - repeat (split; auto).
              destruct G3 as [ G3 | G3 ].
              ++ destruct H0; rewrite G3 at 2.
                 rewrite Zp_invert_involutive.
                 constructor 2.
                 apply perm_list_has_dup with (y::u++v).
                 ** apply Permutation_cons_app; auto.
                 ** constructor 1; auto.
              ++ apply in_or_app.
                 apply in_app_or in G3.
                 destruct G3 as [ | [ G3 | ] ]; try tauto.
                 exfalso.
                 apply f_equal with (f := inv) in G3.
                 do 2 rewrite Zp_invert_involutive in G3.
                 destruct H0.
                 apply perm_list_has_dup with (inv x::(x::u)++v).
                 ** apply Permutation_cons_app with (l1 := x::u); auto.
                 ** simpl; constructor 2; constructor 1; subst; auto.
      Qed.

      Fact Zp_lprod_fact n : 〚fact (S n)〛= Zp_lprod (map nat2Zp (list_an 2 n)).
      Proof using Hp'.
        induction n as [ | n IHn ].
        + apply Zp_inj; simpl; auto.
        + rewrite fact_S, nat2Zp_mult.
          replace (S n)%nat with (n+1)%nat by lia.
          rewrite list_an_plus, map_app, Zp_lprod_app, <- IHn, Zp_mul_comm.
          f_equal.
          * do 2 f_equal; lia.
          * simpl list_an; unfold map.
            rewrite Zp_lprod_cons, Zp_mul_comm, Zp_mult_one.
            f_equal; lia.
      Qed.

      Theorem Wilson_thm_1 :〚fact (p-1)〛= ∸Op.
      Proof using Hp'.
        replace (p-1)%nat with (S (p-2))%nat by lia.
        rewrite Zp_lprod_fact.
        destruct (eq_nat_dec p 2) as [ H1 | H1 ].
        + rewrite H1; simpl map; rewrite Zp_lprod_nil.
          rewrite <- nat2Zp_minus_one; apply nat2Zp_inj.
          rewrite H1; auto.
        + replace (p-2)%nat with (p-3+1)%nat by lia.
          rewrite list_an_plus, map_app, Zp_lprod_app.
          replace (p-3+2)%nat with (p-1)%nat by lia.
          simpl list_an at 2; unfold map at 2.
          rewrite Zp_lprod_cons, Zp_lprod_nil.
          rewrite Zp_mult_autoinv.
          * rewrite nat2Zp_minus_one; ring.
          * intros H.
            apply list_has_dup_map_inv in H.
            - revert H; apply not_list_an_has_dup.
            - intros x y; do 2 rewrite list_an_spec.
              intros Hx Hy.
              rewrite nat2Zp_inj, rem_lt, rem_lt; auto; lia.
          * intros x; rewrite in_map_iff.
            intros (n & ? & Hn); subst.
            rewrite list_an_spec in Hn.
            split; [ | split ].
            - intros H.
              rewrite <- nat2Zp_zero in H.
              apply nat2Zp_inj in H.
              rewrite rem_of_0, rem_lt in H; lia.
            - apply Zp_invert_not_fix; lia.
            - destruct Zp_invert_stable with n as (m & G1 & G2); try lia.
              apply in_map_iff.
              exists m; split; auto.
              apply list_an_spec; lia.
      Qed.

    End prime.

    Fact Zp_divides_and_invertible d k n i : (d * k = n)%nat ->〚i〛⊗〚d〛= Op ->〚k〛=〚i〛⊗〚n〛.
    Proof.
      intros H1 H2.
      rewrite <- H1, nat2Zp_mult, Zp_mul_assoc, H2; ring.
    Qed.

  End Z2Zp.

End Zp.

Fact divides_not_0_interval p q : q <> 0 -> divides p q -> 1 <= p <= q.
Proof.
  intros Hq ([ | k ] & Hk); try lia.
Qed.

Fact divides_fact_lt q n : 1 <= q <= n -> divides q (fact n).
Proof.
  revert q; induction n as [ | n IHn ].
  + intros; rewrite fact_0; lia.
  + intros q Hq; rewrite fact_S.
    destruct (eq_nat_dec q (S n)).
    - subst; exists (fact n); ring.
    - apply divides_mult, IHn; lia.
Qed.

Theorem Wilson_theorem p : 2 <= p -> prime p <-> divides p (fact (p-1)+1).
Proof.
  intros H1; split.
  + intros H2.
    assert (Hp : p <> 0) by lia.
    rewrite divides_nat2Zp with (Hp := Hp).
    rewrite nat2Zp_plus, Wilson_thm_1; auto.
    rewrite nat2Zp_one, Zp_add_comm, Zp_minus; auto.
  + intros H2; split; try lia.
    intros q Hq.
    destruct (eq_nat_dec q p) as [ Hp | Hp ]; auto.
    generalize (divides_trans Hq H2); intros H3.
    apply divides_plus_inv in H3.
    - apply divides_1_inv in H3; auto.
    - apply divides_fact_lt.
      apply divides_not_0_interval in Hq; lia.
Qed.

Section Z2Zp_morphishm.

  Variable (p : nat) (Hp : p <> 0).

  Fact Z2Zp_morphishm : ring_morphism 0%Z 1%Z Zplus Zmult Z.opp
                                      (Zp_zero Hp) (Zp_one Hp) (Zp_plus Hp) (Zp_mult Hp) (Zp_opp Hp) (Z2Zp Hp).
  Proof.
    exists.
    + apply Z2Zp_zero.
    + apply Z2Zp_one.
    + apply Z2Zp_plus.
    + apply Z2Zp_mult.
    + apply Z2Zp_opp.
  Qed.

End Z2Zp_morphishm.


(*
 * a - wife of -> b -> father of -> c
 * a - mother of -> c
 *)

Local Unset Elimination Schemes.

(* We start by inhabiting our type of person with the subjects involved.
 * Dependent type [W] depend on the value of [P] given to it, [W b] is
 * the wife type of person [b]. Ideally, we would like [a] to be an
 * inhabitant of [W b], however, [b] has been predefined as type [P].

 * Note: [F] and [M] denote father and mother respectively.
 *)
Inductive P : Set := a | b | c.

Inductive W : P -> Type :=.

Inductive F : P -> Type :=.

Inductive M : P -> Type :=.

(* Thus we inhabit [W b] with [a'] with it being a proof of existence
 * of a wife of [b], without any information on the identity of the wife.
 * Thus we create a product type [P * W b], when inhabited consists of
 * the proof of the existence of the wife and the identity of the wife.
 *)

Definition a' : W b. Admitted.

Definition a_wife : prod P (W b) := (a, a').

Definition b' : F c. Admitted.

Definition b_father : prod P (F c) := (b, b').

Definition a'' : M c. Admitted.

Definition a_mother: prod P (M c) := (a, a'').

(* The reason for this construction is because we there are many
 * interpretations of a type in coq... type after lunch
 *)
Definition g := fun (x:P) (y' : prod P (F x)) (z' : prod P (W (fst y')))
              => fst z'.

Check g.
(* g : forall (x : P) (y' : P * F x), P * W (fst y') -> P *)

Eval compute in (g c b_father a_wife).


(*
  Autor(s):
    Andrej Dudenhefner (1)
  Affiliation(s):
    (1) TU Dortmund University, Dortmund, Germany
*)

(*
  Decision Procedure(s):
    Two-counter Minsky Machine Halting (MM_2_HALTING)
*)

Require Import PeanoNat Lia List.
Import ListNotations.

Require Import Undecidability.MinskyMachines.MM.
Require Undecidability.MinskyMachines.Deciders.MPM2_HALT_dec.
Module MPM2 := MPM2_HALT_dec.

From Undecidability.Shared.Libs.DLW
  Require Import Vec.pos Vec.vec Code.sss.

Require Import Undecidability.CounterMachines.Util.Facts.

Require Import ssreflect ssrbool ssrfun.

Set Default Goal Selector "!".
Set Default Proof Using "Type".

#[local] Notation "P // s ↓" := (sss_terminates (@mm_sss _) P s).
#[local] Notation "P // r ->> s" := (sss_compute (@mm_sss _) P r s).

Section Construction.
Context (P : list (mm_instr (pos 2))).

Lemma decompose_vec2 {X : Type} (v : vec X 2) : v = vec_head v ## vec_head (vec_tail v) ## vec_nil.
Proof.
  by rewrite [LHS](vec_head_tail v) [in LHS](vec_head_tail (vec_tail v)) [in LHS](vec_0_nil (vec_tail (vec_tail v))).
Qed.

Lemma case_pos2 (v : pos 2) : (v = Fin.F1) + (v = Fin.FS Fin.F1).
Proof.
  have [?|] := pos_S_inv v; first by left.
  move=> [w] ->. right.
  have [->|] := pos_S_inv w; first done.
  move=> [?]. exfalso. by apply: pos_O_inv.
Qed.

Definition to_Instruction (i : mm_instr (pos 2)) : MPM2.Instruction :=
  match i with
  | INC d => MPM2.inc (if case_pos2 d then false else true)
  | DEC d p => MPM2.dec (if case_pos2 d then false else true) (if p is S q then q else length P)
  end.

Definition to_Config (s : mm_state 2) : MPM2.Config :=
  match s with
  | (S p, Vector.cons _ a _ (Vector.cons _ b _ _)) => (p, (a, b))
  | (0, Vector.cons _ a _ (Vector.cons _ b _ _)) => (length P, (a, b))
  | _ => (0, (0, 0))
  end.

(* corresponding Mpm 2 *)
Definition M := map to_Instruction P.

Lemma P_to_M_step s t : sss_step (@mm_sss _) (1, P) s t -> MPM2.step M (to_Config s) = Some (to_Config t).
Proof.
  rewrite /sss_step.
  move=> [k] [P1] [i] [P2] [v] [[<- HP]] [->].
  rewrite /MPM2.step.
  have -> : nth_error M (MPM2.state (to_Config (1 + length P1, v))) = Some (to_Instruction i).
  { rewrite /M HP map_app (decompose_vec2 v) nth_error_app2.
    { by rewrite /= map_length. }
    by rewrite /= map_length Nat.sub_diag. }
  move Hc: (1 + length P1, v) => c H.
  case: H Hc.
  - move=> ? d w [<- <-]. rewrite [to_Instruction _]/= (decompose_vec2 v).
    by case: (case_pos2 d) => /= ->.
  - move=> ? d q w + [<- ?]. subst w. rewrite (decompose_vec2 v) /=.
    case: (case_pos2 d).
    + move=> /= -> ->. by case: q.
    + move=> /= -> ->. by case: q.
  - move=> ? d q w u + [<- ?]. subst w. rewrite (decompose_vec2 v) /=.
    case: (case_pos2 d).
    + by move=> /= -> ->.
    + by move=> /= -> ->.
Qed.

Lemma P_to_M s t : ((1, P) // s ->> t) ->
  exists n, Nat.iter n (obind (MPM2.step M)) (Some (to_Config s)) = Some (to_Config t).
Proof.
  move=> [n Hn]. exists n.
  elim: n s Hn. { by move=> s /sss_steps_0_inv <-. }
  move=> n IH s /sss_steps_S_inv' [u] [/P_to_M_step Hsu] /IH {}IH.
  by rewrite /= obind_oiter Hsu.
Qed.

Lemma M_to_P_step s y : MPM2.step M (to_Config s) = Some y ->
  exists t, y = to_Config t /\ sss_step (@mm_sss _) (1, P) s t.
Proof.
  rewrite /MPM2.step. case Hi: (nth_error M (MPM2.state (to_Config s))) => [i|]; last done.
  case: i Hi.
  - done.
  - rewrite /M. move=> ? /(@nth_error_In MPM2.Instruction) /in_map_iff.
    by move=> [[]] /= => [?|??] [].
  - move=> c. rewrite /M nth_error_map.
    case Hi: (nth_error P (MPM2.state (to_Config s))) => [i|]; last done.
    move: Hi => /(@nth_error_split (mm_instr _)) [P1] [P2] [HP HP1] [Hi] [<-].
    move: s HP1 => [p v] HP1.
    have Hp : p = S (p - 1).
    { move: p HP1 => [|p].
      { rewrite (decompose_vec2 v) /= HP app_length /=. lia. }
      move=> ? /=. lia. }
    exists (S (S (MPM2.state (to_Config (p, v)))),
      ((if c then 0 else 1) + MPM2.value1 (to_Config (p, v))) ##
      ((if c then 1 else 0) + MPM2.value2 (to_Config (p, v))) ##
      vec_nil).
    split; first done.
    exists 1, P1, i, P2, v.
    split; first by congr pair.
    split.
    { move: HP1. by rewrite (decompose_vec2 v) Hp /= => <-. }
    have -> : i = INC (if c then pos1 else pos0).
    { move: i Hi {HP} => []; last done. move=> d /=.
      by case: (case_pos2 d) => /= -> [<-]. }
    have := @in_mm_sss_inc 2 p (if c then pos1 else pos0) v.
    congr mm_sss. congr pair. { by rewrite (decompose_vec2 v) Hp. }
    case: c {Hi}.
    + by rewrite (decompose_vec2 v) Hp /=.
    + by rewrite (decompose_vec2 v) Hp /=.
  - move=> c q.
    rewrite /M nth_error_map.
    case Hi: (nth_error P (MPM2.state (to_Config s))) => [i|]; last done.
    move: Hi => /(@nth_error_split (mm_instr _)) [P1] [P2] [HP HP1] [Hi] [<-].
    move: s HP1 => [p v] HP1.
    have Hp : p = S (p - 1).
    { move: p HP1 => [|p].
      { rewrite (decompose_vec2 v) /= HP app_length /=. lia. }
      move=> ? /=. lia. }
    move: HP1. rewrite (decompose_vec2 v) Hp /= => HP1.
    move: i HP Hi => [] /=; first done.
    move=> d r.
    move: (case_pos2 d) => [|] /= -> HP [] <- <-.
    + exists (if (vec_head v) is S a then
        (S p, a ## vec_head (vec_tail v) ## vec_nil) else
        (r, 0 ## vec_head (vec_tail v) ## vec_nil)).
      split.
      { case: (vec_head v).
        - by case: (r).
        - move=> ?. by rewrite [in to_Config _]Hp /to_Config. }
      case Hv: (vec_head v) => [|a].
      * exists 1, P1, (DEC pos0 r), P2, v.
        split; first by congr pair.
        split.
        { by rewrite [in (_, v)](decompose_vec2 v) /= HP1 Hv. }
        have := @in_mm_sss_dec_0 2 p pos0 r v.
        rewrite [in vec_pos v](decompose_vec2 v) /=.
        move=> /(_ Hv).
        by congr mm_sss; rewrite -?Hp [in (_, v)](decompose_vec2 v) Hv.
      * exists 1, P1, (DEC pos0 r), P2, v.
        split; first by congr pair.
        split.
        { by rewrite [in (_, v)](decompose_vec2 v) /= HP1 Hv. }
        have := @in_mm_sss_dec_1 2 p pos0 r v.
        rewrite [in vec_pos v](decompose_vec2 v) /=.
        move=> /(_ a Hv).
        congr mm_sss; rewrite -?Hp.
        ** by rewrite -Hv -(decompose_vec2 v).
        ** by rewrite [in vec_change v](decompose_vec2 v).
    + exists (if (vec_head (vec_tail v)) is S b then
        (S p, vec_head v ## b ## vec_nil) else
        (r, vec_head v ## 0 ## vec_nil)).
      split.
      { case: (vec_head (vec_tail v)).
        - by case: (r).
        - move=> ?. by rewrite [in to_Config _]Hp /to_Config. }
      case Hv: (vec_head (vec_tail v)) => [|b].
      * exists 1, P1, (DEC pos1 r), P2, v.
        split; first by congr pair.
        split.
        { by rewrite [in (_, v)](decompose_vec2 v) /= HP1 Hv. }
        have := @in_mm_sss_dec_0 2 p pos1 r v.
        rewrite [in vec_pos v](decompose_vec2 v) /=.
        move=> /(_ Hv).
        by congr mm_sss; rewrite -?Hp [in (_, v)](decompose_vec2 v) Hv.
      * exists 1, P1, (DEC pos1 r), P2, v.
        split; first by congr pair.
        split.
        { by rewrite [in (_, v)](decompose_vec2 v) /= HP1 Hv. }
        have := @in_mm_sss_dec_1 2 p pos1 r v.
        rewrite [in vec_pos v](decompose_vec2 v) /=.
        move=> /(_ b Hv).
        congr mm_sss; rewrite -?Hp.
        ** by rewrite -Hv -(decompose_vec2 v).
        ** by rewrite [in vec_change v](decompose_vec2 v).
Qed.

Lemma M_to_P n s y : Nat.iter n (obind (MPM2.step M)) (Some (to_Config s)) = Some y ->
  exists t, y = to_Config t /\ ((1, P) // s ->> t).
Proof.
  move=> Hn.
  suff : exists t : mm_state 2, y = to_Config t /\ sss_steps (@mm_sss _) (1, P) n s t.
  { move=> [t] [? ?]. exists t. split; [done|by exists n]. }
  elim: n s Hn.
  { move=> s [<-]. exists s. split; first done. by apply: sss_steps_0. }
  move=> n IH s /=. rewrite obind_oiter.
  case Hz: (MPM2.step M (to_Config s)) => [z|]; last by rewrite oiter_None.
  move: Hz => /M_to_P_step [u] [->] Hsu.
  move=> /IH [t] [? ?]. exists t.
  split; first done. have ->: S n = 1 + n by done.
  apply: sss_steps_trans; last by eassumption.
  by apply: sss_steps_1.
Qed.

#[local] Arguments to_Config : simpl never.

(* informative decision statement for halting for Mm2 *)
Lemma decision (v: vec nat 2) : ((1, P) // (1, v) ↓) + (not ((1, P) // (1, v) ↓)).
Proof.
  have [H|H] := MPM2.decision M (to_Config (1, v)).
  - left. move: H => [n]. elim: n; first done.
    move=> n IH /=.
    case Hy: (MPM2.steps M n (to_Config (1, v))) => [y|].
    + move: Hy => /M_to_P [t] [->] Ht H't.
      exists t. split; first done.
      move: t {Ht} H't => [[|p] w] /=; first by lia.
      rewrite (decompose_vec2 w) /to_Config /= /MPM2.step /=.
      case Hi: (nth_error M p) => [i|]; first last.
      { move: Hi => /nth_error_None. rewrite /M map_length. lia. }
      case: i Hi; [|done..].
      move=> /(@nth_error_In MPM2.Instruction) /in_map_iff.
      by move=> [[]] => [?|??] [].
    + by move: (IH Hy).
  - right. move=> [t] [/=] /P_to_M [n] Hn Ht.
    apply: (H (S n)).
    rewrite /= /MPM2.steps Hn.
    move: t Ht {Hn} => [[|p] w].
    + rewrite /= /MPM2.step /to_Config (decompose_vec2 w) /=.
      suff ->: nth_error M (length P) = None by done.
      apply /nth_error_None. by rewrite /M map_length.
    + move=> /= [|?]; first by lia.
      rewrite /= /MPM2.step /to_Config (decompose_vec2 w) /=.
      suff ->: nth_error M p = None by done.
      apply /nth_error_None. rewrite /M map_length. lia.
Qed.

End Construction.

Require Import Undecidability.Synthetic.Definitions.

(* decision procedure for the halting problem for MM with two counters *)
Definition decide : { P : list (mm_instr (pos 2)) & vec nat 2 } -> bool :=
  fun '(existT _ P v) =>
    match decision P v with
    | inl _ => true
    | inr _ => false
    end.

(* decision procedure correctness *)
Lemma decide_spec : decider decide MM_2_HALTING.
Proof.
  rewrite /decider /reflects /decide => - [P v].
  case: (decision P v).
  - tauto.
  - move=> H. split; [by move=> /H | done].
Qed.


From Coq Require Import Lists.List.
Import ListNotations.

Inductive sublist {T : Type} : list T -> nat -> nat -> list T -> Prop :=
| SHeadIncluded head tail j subtail : sublist subtail 0 j tail ->
                                        sublist (head::subtail) 0 (S j) (head::tail)
| SHeadExcluded head tail i j sub :   sublist sub i j tail ->
                                        sublist sub (S i) (S j) (head::tail)
| SNil i lst :                        sublist [] i i lst.

Lemma nil_sublist {X : Type} (i j : nat) {xs : list X} :
  sublist [] i j xs -> i = j.
Proof. Admitted.

Lemma sublist_trans {X : Type} {xs ys zs : list X} {i j k l : nat} :
    sublist xs i j ys ->
    sublist ys k l zs ->
  sublist xs k (k + length xs) zs.
Proof. Admitted.

Lemma sublist_app {X : Type} {xs ys : list X} :
  sublist xs 0 (length xs) (xs ++ ys).
Proof. Admitted.

Lemma sublist_of_app_sublist_left {X : Type} {xs ys zs : list X} {i j : nat} :
    sublist (xs ++ ys) i j zs ->
  sublist xs i (i + length xs) zs.
Proof. Admitted.

Lemma sublist_of_app_sublist_right {X : Type} {xs ys zs : list X} {i j : nat} :
    sublist (xs ++ ys) i j zs ->
  sublist ys (i + length xs) j zs.
Proof. Admitted.


From mathcomp Require Import all_ssreflect.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Section DFSearch.

Variable T : finType.

Lemma closureP (g : rel T) (s : pred T) x :
  reflect (exists2 v, v \in s & connect g x v) (x \in closure g s).
Proof.
apply: (iffP idP).
- move/existsP => [y Hy].
  move/andP: Hy => [Hc Hy].
  by exists y.
- move => [v Hv] Hc.
  apply/existsP.
  exists v.
  by apply/andP.
Qed.

Definition rclosed (g : rel T) (a : seq T) :=
  forall x y, g x y -> x \in a -> y \in a.

Lemma rclosed_connect : forall (g : rel T) (s : seq T),
 rclosed g s -> forall x y, connect g x y -> x \in s -> y \in s.
Proof.
move => g s Hr x y.
move/connectP => [p Hp] Hl.
elim: p x Hp Hl => //=; first by move => Hp Hx; move =>->.
move => z p IH x.
move/andP => [Hz Hp] Hl Hx.
have Hzg := Hr _ _ Hz Hx.
move: Hzg.
exact: IH.
Qed.

Definition rclosure (g : T -> seq T) :=
 foldr (fun x s => dfs g #|T| s x) [::].

Definition rclosure' (g : T -> seq T) :=
 foldl (dfs g #|T|) [::].

Lemma rclosure_exist : forall g s x,
  x \in rclosure (rgraph g) s ->
  exists2 v : T, v \in s & connect g v x.
Proof.
move => g.
elim => //=.
move => x s IH y Hyd.
case Hy: (y \in rclosure (rgraph g) s).
  move/idP: Hy.
  move/IH => [v Hv] Hc.
  exists v => //.
  rewrite in_cons.
  apply/orP.
  by right.
move/negP/negP: Hy => Hy.
move/dfs_pathP: Hyd => Hd.
have Ht: #|T| <= #|rclosure (rgraph g) s| + #|T| by exact: leq_addl.
have Hd' := Hd Ht Hy.
destruct Hd'.
exists x; first by rewrite in_cons; apply/orP; left.
apply/connectP.
exists p => //.
move: H.
rewrite /grel /rgraph /=.
elim: p x {H0 H1 Hd} => //=.
move => z p IH' x.
rewrite mem_enum.
move/andP => [He Hp].
apply/andP.
split => //.
exact: IH'.
Qed.

Lemma dfs_in : forall (g : T -> seq T) n s x y,
 x \in s ->
 x \in dfs g n s y.
Proof.
move => g.
case => /=; first by move => s x Hs; case: ifP.
move => n s x y Hx.
case: ifP => //.
move/negP/negP => Hs.
move/subsetP: (subset_dfs g n (y :: s) (g y)) => Hsb.
apply: Hsb.
rewrite in_cons.
by apply/orP; right.
Qed.

Lemma dfs_subset : forall (g : T -> seq T) n s x,
  s \subset dfs g n s x.
Proof.
move => g.
case => //=.
- move => s x.
  by case: ifP => Hx; apply/subsetP.
- move => n s x.
  case: ifP => Hx; first by apply/subsetP.
  move/negP/negP: Hx => Hx.
  move/subsetP: (subset_dfs g n (x :: s) (g x)) => Hs.
  apply/subsetP.
  move => y Hy.
  apply Hs.
  rewrite in_cons.
  by apply/orP; right.
Qed.

Lemma rclosed_rclosure : forall g s,
  rclosed g (rclosure (rgraph g) s).
Proof.
move => g.
elim => //=.
move => x s IH.
move => y z Hg.
case Hy: (y \in rclosure (rgraph g) s).
  move/idP: Hy.
  move/(IH _ z Hg) => Hz Hy.
  exact: dfs_in.
move/negP/negP: Hy => Hcx.
move => Hcy.
have Ht: #|T| <= #|rclosure (rgraph g) s| + #|T| by exact: leq_addl.
case Hz: (z \in rclosure (rgraph g) s); first by apply: dfs_in.
move/negP/negP: Hz => Hz.
apply/dfs_pathP => //.
move/dfs_pathP: Hcy => Hcy.
case (Hcy Ht Hcx) => [p Hp] Hl Hd.
rewrite disjoint_cons in Hd.
move/andP: Hd => [Hx Hd].
exists (rcons p z).
- rewrite /grel /rgraph /=.
  rewrite rcons_path /=.
  rewrite -Hl.
  apply/andP.
  split => //.
  by rewrite mem_enum.
- by rewrite last_rcons.
- rewrite disjoint_cons.
  apply/andP.
  split => //.
  rewrite disjoint_has.
  elim: p Hd {Hp Hl} => //=.
  * move => Hd.
    apply/negP.
    move/orP.
    case => //.
    move => Hz'.
    by move/negP: Hz; case.
  * move => z0 p IH'.
    rewrite disjoint_cons.
    move/andP => [Hz0 Hd].
    apply/norP.
    split => //.
    exact: IH'.
Qed.

Lemma dfs_in_in : forall (g : T -> seq T) s x,
  x \in dfs g #|T| s x.
Proof.
move => g s x.
case Hx: (x \in s); first by apply dfs_in.
move/negP/negP: Hx => Hx.
apply/dfs_pathP => //.
- exact: leq_addl.
- exists [::] => //.
  rewrite disjoint_has.
  rewrite /=.
  apply/norP.
  by split.
Qed.

Lemma subset_closure : forall g s,
 s \subset rclosure (rgraph g) s.
Proof.
move => g.
elim => //= x s IH.
move/subsetP: IH => IH.
apply/subsetP.
move => y.
rewrite in_cons.
move/orP; case.
- move/eqP =>-> {y}.
  exact: dfs_in_in.
- move => Hy.
  apply IH in Hy.
  exact: dfs_in.
Qed.

Lemma rclosureP g (modified : seq T) x :
  reflect
    (exists2 v, v \in modified & connect g v x)
    (x \in rclosure (rgraph g) modified).
Proof.
apply: (iffP idP); first by move => Hx; apply: rclosure_exist.
move => [v Hm] Hc.
have Hcl := @rclosed_rclosure g modified.
move: Hcl.
move/rclosed_connect => Hcl.
move/Hcl: Hc.
apply.
move/subsetP: (subset_closure g modified) => Hp.
exact: Hp.
Qed.

Lemma dfs_eq_in : forall (g1 g2 : T -> seq T) n s x,
 x \in s ->
 dfs g1 n s x =i dfs g2 n s x.
Proof.
move => g1 g2.
elim => //=.
move => n IH s x Hg Hs.
case: ifP => //.
move/negP.
by case.
Qed.

Lemma dfs_mem : forall (g1 g2 : T -> seq T) s x,
    g1 =1 g2 ->
    dfs g1 #|T| s x =i dfs g2 #|T| s x.
Proof.
move => g1 g2 s x Hg y.
case Hy: (y \in s).
  move/idP: Hy => Hy.
  have Hd1 := dfs_in g1 #|T| x Hy.
  have Hd2 := dfs_in g2 #|T| x Hy.
  move: Hd1 Hd2.
  by case (y \in dfs g1 #|T| s x).
move/negP/negP: Hy => Hy.
have Hn: #|T| <= #|s| + #|T| by apply: leq_addl.
apply/dfs_pathP/idP => //.
- case => p Hp Hl Hd.
  apply/dfs_pathP => //.
  exists p => //.
  elim: p x Hp {Hl Hd} => //=.
  move => z p IH x.
  move/andP => [Hg1 Hp].
  apply/andP.
  split; last by apply: IH.
  by rewrite -Hg.
- move/dfs_pathP => Hd.
  move/Hd: Hn => Hd'.
  move/Hd': Hy.
  case => p Hp Hl Hds.
  exists p => //.
  elim: p x Hp {Hl Hd Hd' Hds} => //=.
  move => z p IH x.
  move/andP => [Hg1 Hp].
  apply/andP.
  split; last by apply: IH.
  by rewrite Hg.
Qed.

Lemma dfs_mem' : forall (g1 g2 : T -> seq T) s x,
    (forall x, g1 x =i g2 x) ->
    dfs g1 #|T| s x =i dfs g2 #|T| s x.
Proof.
move => g1 g2 s x Hg y.
case Hy: (y \in s).
  move/idP: Hy => Hy.
  have Hd1 := dfs_in g1 #|T| x Hy.
  have Hd2 := dfs_in g2 #|T| x Hy.
  move: Hd1 Hd2.
  by case (y \in dfs g1 #|T| s x).
move/negP/negP: Hy => Hy.
have Hn: #|T| <= #|s| + #|T| by apply: leq_addl.
apply/dfs_pathP/idP => //.
- case => p Hp Hl Hd.
  apply/dfs_pathP => //.
  exists p => //.
  elim: p x Hp {Hl Hd} => //=.
  move => z p IH x.
  move/andP => [Hg1 Hp].
  apply/andP.
  split; last by apply: IH.
  by rewrite -Hg.
- move/dfs_pathP => Hd.
  move/Hd: Hn => Hd'.
  move/Hd': Hy.
  case => p Hp Hl Hds.
  exists p => //.
  elim: p x Hp {Hl Hd Hd' Hds} => //=.
  move => z p IH x.
  move/andP => [Hg1 Hp].
  apply/andP.
  split; last by apply: IH.
  by rewrite Hg.
Qed.

Lemma subset_rclose : forall (g : T -> seq T) s s0,
 s \subset foldr (fun x s => dfs g #|T| s x) s s0.
Proof.
move => g s s0.
elim: s0 s => //=.
move => x s IH s0.
apply/subsetP => y Hy.
apply: dfs_in.
move/subsetP: (IH s0) => Hs.
exact: Hs.
Qed.

Lemma rclose_subset : forall (g : T -> seq T) s s0,
 s \subset foldr (fun x s => dfs g #|T| s x) s0 s.
Proof.
move => g.
elim => //=; first by move => s0; apply/subsetP.
move => x s IH s0.
apply/subsetP.
move => y.
rewrite in_cons.
move/orP; case.
- move/eqP =>->.
  exact: dfs_in_in.
- move => Hy.
  apply: dfs_in.
  move/subsetP: (IH s0) => Hs.
  exact: Hs.
Qed.

Lemma dfs_mems : forall (g : T -> seq T) s1 s2 x,
    s1 =i s2 ->
    dfs g #|T| s1 x =i dfs g #|T| s2 x.
Proof.
move => g s1 s2 x Hs y.
case Hy: (y \in s1).
  move/idP: Hy => Hy.
  have Hd1 := dfs_in g #|T| x Hy.
  rewrite Hs in Hy.
  have Hd2 := dfs_in g #|T| x Hy.
  move: Hd1 Hd2.
  by case (y \in dfs _ #|T| _ x).
move/negP: Hy => Hy.
have Hy' : ~ y \in s2.
  move => Hy'.
  rewrite -Hs in Hy'.
  by case: Hy.
move/negP: Hy => Hy.
move/negP: Hy' => Hy'.
have Hn: #|T| <= #|s1| + #|T| by apply: leq_addl.
have Hn': #|T| <= #|s2| + #|T| by apply: leq_addl.
apply/dfs_pathP/idP => //.
- case => p Hp Hl Hd.
  apply/dfs_pathP => //.
  exists p => //.
  move: Hd.
  rewrite 2!disjoint_cons.
  move/andP => [Hx Hd].
  apply/andP.
  split; first by rewrite -Hs.
  elim: p Hd {Hp Hl} => //=.
  move => z p Hd.
  rewrite 2!disjoint_cons.
  rewrite Hs.
  move/andP => [Hz Hd'].
  apply/andP.
  split => //.
  exact: Hd.
- move/dfs_pathP => Hd.
  move/Hd: Hn' => Hd'.
  move/Hd': Hy'.
  case => p Hp Hl Hds.
  exists p => //.
  move: Hds.
  rewrite 2!disjoint_cons.
  move/andP => [Hx Hd0].
  apply/andP.
  split; first by rewrite Hs.
  elim: p Hd0 {Hp Hl} => //=.
  move => z p Hd0.
  rewrite 2!disjoint_cons.
  rewrite Hs.
  move/andP => [Hz Hd1].
  apply/andP.
  split => //.
  exact: Hd0.
Qed.

Lemma closure_g : forall g1 g2 s,
  (forall x, g1 x =i g2 x) ->
  rclosure g1 s =i rclosure g2 s.
Proof.
move => g1 g2 s Hg.
move: s.
elim => //=.
move => x s IH y.
by rewrite (dfs_mems _ _ IH) (@dfs_mem' g1 g2).
Qed.

Lemma rclosurePg g (modified : seq T) x :
  reflect
    (exists2 v, v \in modified & connect (grel g) v x)
    (x \in rclosure g modified).
Proof.
apply: (iffP idP).
- move => Hx.
  apply: rclosure_exist.
  have Hg := @closure_g g (rgraph (grel g)).
  rewrite -Hg //.
  move => y s.
  by rewrite /rgraph /grel mem_enum.
- move/rclosureP.
  have Hg := @closure_g g (rgraph (grel g)).
  rewrite -Hg //.
  move => y s.
  by rewrite /rgraph /grel mem_enum.
Qed.

Lemma closure_eqi : forall (g : T -> seq T) s1 s2,
  s1 =i s2 ->
  rclosure g s1 =i rclosure g s2.
Proof.
move => g s1 s2 Hs x.
apply/rclosurePg/idP.
- move => [v Hv] Hc.
  apply/rclosurePg.
  exists v => //.
  by rewrite -Hs.
- move/rclosurePg.
  move => [v Hv] Hc.
  exists v => //.
  by rewrite Hs.
Qed.

Lemma rclosure_in_lr : forall (g : T -> seq T) s x,
  x \in foldl (dfs g #|T|) [::] s ->
  x \in foldr (fun x s => dfs g #|T| s x) [::] s.
Proof.
move => g s x.
have {1} ->: s = rev (rev s) by rewrite revK.
rewrite foldl_rev.
rewrite (@closure_eqi _ s (rev s)) //.
move => y.
have Hs := has_rev (pred1 y) s.
by rewrite 2!has_pred1 in Hs.
Qed.

Lemma rclosure_in_rl : forall (g : T -> seq T) s x,
  x \in foldr (fun x s => dfs g #|T| s x) [::] s ->
  x \in foldl (dfs g #|T|) [::] s.
Proof.
move => g s x.
have {2} ->: s = rev (rev s) by rewrite revK.
rewrite foldl_rev.
rewrite (@closure_eqi _ s (rev s)) //.
move => y.
have Hs := has_rev (pred1 y) s.
by rewrite 2!has_pred1 in Hs.
Qed.

Lemma rclosure_rclosure'_i : forall g s,
  rclosure g s =i rclosure' g s.
Proof.
move => g s x.
case Hx: (x \in _); case Hx': (x \in _) => //.
- move/negP: Hx'.
  case.
  exact: rclosure_in_rl.
- move/negP: Hx.
  case.
  exact: rclosure_in_lr.
Qed.

Lemma rclosure'P g (modified : seq T) x :
  reflect
    (exists2 v, v \in modified & connect g v x)
    (x \in rclosure' (rgraph g) modified).
Proof.
apply: (iffP idP).
- rewrite -rclosure_rclosure'_i.
  by move/rclosureP.
- move => Hx.
  rewrite -rclosure_rclosure'_i.
  by apply/rclosureP.
Qed.

Lemma rclosed_rclosure' : forall g s,
  rclosed g (rclosure' (rgraph g) s).
Proof.
move => g s x y Hg.
rewrite -2!rclosure_rclosure'_i.
exact: rclosed_rclosure.
Qed.

Lemma rclosure'Pg g (modified : seq T) x :
  reflect
    (exists2 v, v \in modified & connect (grel g) v x)
    (x \in rclosure' g modified).
Proof.
apply: (iffP idP).
- rewrite -rclosure_rclosure'_i.
  by move/rclosurePg.
- move/rclosurePg.
  by rewrite rclosure_rclosure'_i.
Qed.

Lemma dfs_uniq : forall (g : T -> seq T) n s v,
 uniq s ->
 uniq (dfs g n s v).
Proof.
move => g.
elim => //=; first by move => s v; case: ifP.
move => n IH s v Hs.
have ->: g v = rev (rev (g v)) by rewrite revK.
case: ifP => //.
move/negP/negP => Hv.
rewrite foldl_rev.
generalize (rev (g v)).
elim => //=; first by apply/andP; split.
move => y s' Hu.
exact: IH.
Qed.

Lemma rclosure_uniq : forall (g : T -> seq T) s,
  uniq s ->
  uniq (rclosure g s).
Proof.
move => g.
elim => //=.
move => x s IH.
move/andP => [Hx Hs].
apply: dfs_uniq.
exact: IH.
Qed.

Lemma rclosure'_uniq : forall (g : T -> seq T) s,
  uniq s ->
  uniq (rclosure' g s).
Proof.
move => g s.
rewrite /rclosure'.
have {2} ->: s = rev (rev s) by rewrite revK.
rewrite foldl_rev.
move => Hs.
apply: rclosure_uniq.
by rewrite rev_uniq.
Qed.

Definition rclosures g (s : {set T}) : {set T} :=
  finset (mem (rclosure (rgraph g) (enum s))).

Lemma rclosuresP (g : rel T) (modified : {set T}) x  :
  reflect
    (exists2 v, v \in modified & connect g v x)
    (x \in rclosures g modified).
Proof.
apply: (iffP idP).
- rewrite /rclosures 2!inE.
  move/rclosureP.
  move => [v Hv] Hc.
  rewrite mem_enum in Hv.
  by exists v.
- move => [v Hv] Hc.
  have Hv': v \in enum modified by rewrite mem_enum.
  have Hex: exists2 v, v \in enum modified & connect g v x by exists v.
  move/rclosureP: Hex => Hcl.
  by rewrite /rclosures 2!inE.
Qed.

Lemma rclosures_connect : forall g s,
 forall x y, connect g x y -> x \in (rclosures g s) -> y \in (rclosures g s).
Proof.
move => g s x y Hc.
have Hc' := rclosed_connect (@rclosed_rclosure g (enum s)) Hc.
move => Hx.
rewrite /rclosures inE /=.
apply: Hc'.
move: Hx.
by rewrite inE.
Qed.

Definition rclosures' g (s : {set T}) : {set T} :=
  finset (mem (rclosure' (rgraph g) (enum s))).

Lemma rclosures'P (g : rel T) (modified : {set T}) x  :
  reflect
    (exists2 v, v \in modified & connect g v x)
    (x \in rclosures' g modified).
Proof.
apply: (iffP idP).
- rewrite /rclosures' 2!inE.
  move/rclosure'P.
  move => [v Hv] Hc.
  rewrite mem_enum in Hv.
  by exists v.
- move => [v Hv] Hc.
  have Hv': v \in enum modified by rewrite mem_enum.
  have Hex: exists2 v, v \in enum modified & connect g v x by exists v.
  move/rclosure'P: Hex => Hcl.
  by rewrite /rclosures 2!inE.
Qed.

Lemma rclosures'_connect : forall g s,
 forall x y, connect g x y -> x \in (rclosures' g s) -> y \in (rclosures' g s).
Proof.
move => g s x y Hc.
have Hc' := rclosed_connect (@rclosed_rclosure' g (enum s)) Hc.
move => Hx.
rewrite /rclosures' inE /=.
apply: Hc'.
move: Hx.
by rewrite inE.
Qed.

End DFSearch.


Set Implicit Arguments.
Require Import Eqdep Eqdep_dec  EqdepFacts.

Section s.
Variable (A:Type).

Hypothesis A_eq_dec : forall a b:A, {a=b}+{a<>b}.

CoInductive LList :=
 | LNil: LList
 | LCons : A -> LList -> LList.

Inductive Finite : LList -> Prop :=
 |Finite_LNil: Finite LNil
 |Finite_LCons   : forall a l, Finite l -> Finite (LCons a l).

(* An equivalent (one contructor) definition of Finite *)

Inductive Finite_alt (x:LList) :Prop :=
  |finite_alt_intro: (forall a y , x = LCons a y -> Finite_alt y)->
       Finite_alt x.

Lemma Finite_Finite_alt : forall x, Finite x -> Finite_alt x.
Proof.
  intros x H;induction H.
  -  constructor; intros a y H;inversion H.
  -  constructor;intros b y;injection 1. intros;subst y;assumption.
Qed.

Lemma Finite_alt_Finite : forall x, Finite_alt x -> Finite x.
Proof.
 intros x H; induction H as [x H H0]; destruct x;constructor.
 eapply H0;eauto.
Qed.

Definition Finite_rect_0 (P:LList->Type) :
    (forall x : LList,
        (forall(h:A) (y  : LList),  Finite y -> x = LCons h y -> P y) -> P x) ->
    forall x : LList, Finite x -> P x.
Proof.
 intros H x Hx;apply Finite_Finite_alt in Hx.
 induction Hx.
 -  apply H; auto.
    intros; eapply X;eauto.
Defined.

Definition Finite_rect (P:LList->Type) :
  P LNil ->
  (forall x (l:LList), Finite l -> P l -> (P (LCons  x l))) ->
  forall l, Finite l -> P l.
Proof.
  intros H0 Hcons l H.
  generalize H;  elim H using Finite_rect_0.
  destruct x; auto.
  intros X H1; apply Hcons.
  - now inversion H1.
  -  apply X with a.
   +  inversion H1;auto.
   +  reflexivity.
   +  inversion H1;auto.
Defined.

Notation "H == K" := (eq_dep _ Finite _ H _ K) (at level 80).

Fixpoint dep h (H: Finite h): forall k (K: Finite k), h = k -> H == K.
  destruct H; destruct K.
 -  reflexivity.
 -  discriminate.
 -  discriminate.
 -  injection 1; intros; subst a0 l0.
    now  rewrite (dep _ H _ K ).
Defined.

Goal forall l (H K:Finite l), H == K.
Proof.
  intros; now apply dep.
Qed.

Lemma  LList_dec: forall h :LList,
                    Finite h ->
                    forall k, Finite k -> {h=k}+{h<>k}.
Proof.
 intros h H;elim H using Finite_rect.
 -  intros k K ; elim K using Finite_rect.
   +  left;auto.
   +  right;discriminate.
 -  intros x l H0 H1 k K ; elim K using Finite_rect.
   +   right;discriminate.
   + intros x0 l0 H2 H3.
     destruct (H1 _ H2).
   *  destruct (A_eq_dec x x0).
      subst x0 l; now left.
      right;intro H4;injection H4.
      intros;now destruct n.
   *  right;intro H4;injection H4; intros;destruct n;auto.
Qed.

Goal forall l, Finite l -> forall (H K:Finite l), H=K.
Proof.
  intros l Hl H K;  apply eq_dep_eq. (* uses an axiom ! *)
  now  apply dep.
Qed.

End s.


Require Import FinTypes Vector.

Instance eq_dec_vector (X : Type) `{eq_dec X} n : eq_dec (Vector.t X n).
Proof.
  eapply Vector.eq_dec with (A_beq := fun x y => Decb (x = y)). firstorder. now decide (x = y).
Defined.

Fixpoint all_vectors (X : Type) (A : list X) n : list (Vector.t X n) :=
  match n with
    0 => [Vector.nil X]
  | S n' => concat (List.map (fun a => (List.map (fun v => cons _ a _ v) (all_vectors A n'))) A)
  end.

Lemma vectors_enum_ok (X : finType) n (v : Vector.t X n):
  count (undup (all_vectors (elem X) n)) v = 1.
Proof.
  apply dupfreeCount.
  -apply dupfree_undup.
  -rewrite undup_id_equi. induction v;cbn. tauto.
   rewrite in_concat_iff. eexists; split; rewrite in_map_iff; eauto.
Qed.

Instance fintype_vector (X : finType) n : finTypeC (EqType (Vector.t X n)).
Proof.
  econstructor. apply vectors_enum_ok.
Qed.

Hint Extern 4 (finTypeC (EqType (Vector.t _ _))) => eapply fintype_vector : typeclass_instances.


(*
Taller 5 Logita digital
Guido Ernesto Salazar Muñoz
24/10/2020
*)

Section LPPO_1.

Variable D: Set.
Variable c d e :D.
Variable P Q T: D-> Prop.

(*1*)
Theorem pred_008 : ~(forall x, P x) -> ~ forall x, P x /\ Q x.
Proof.
intro.
intro.
destruct H.
intro.
apply H0.
Qed.

(*2*)
Theorem pred_013 : (exists x, P x \/ Q x) -> (forall x, ~Q x) -> exists x, P x.
Proof.
intro.
destruct H.
intro.
exists x.
destruct H.
assumption.
apply H0 in H.
contradiction.
Qed.

(*3*)
Theorem pred_025 : ~(forall x, P x /\ Q x) /\ (forall x, P x) -> ~forall x, Q x.
Proof.
intro.
intro.
destruct H.
destruct H.
intro.
split.
apply H1.
apply H0.
Qed.

(*4*)
Theorem pred_035 : (forall y, Q y -> ~exists x, P x) /\ (forall x, P x) -> forall y, ~Q y.
Proof.
intro.
destruct H.
intro x.
intro.
apply H in H1.
destruct H1.
exists x.
apply H0.
Qed.

(*5*)
Theorem pred_067 : (forall x, ~P x) -> ~exists x, P x.
Proof.
intro.
intro.
destruct H0.
apply H in H0.
contradiction.
Qed.

End LPPO_1.

Section LPPO_2.

Variable A : Set.
Variables (P Q : A -> Prop)
          (R : A -> A -> Prop).

(*6*)
Lemma forall_imp_dist : (forall x:A, P x -> Q x) ->
                        (forall x:A, P x) ->
                        forall x: A, Q x.
Proof.
intro.
intro.
intro.
apply H.
apply H0.
Qed.

(*7*)
Lemma forall_perm : (forall x y:A, R x y) -> forall y x, R x y.
Proof.
intro.
intro.
intro.
apply H.
Qed.

(*8*)
Lemma forall_delta : (forall x y:A, R x y) -> forall x, R x x.
Proof.
intro.
intro y.
apply H.
Qed.

(*9*)
Lemma exists_or_dist : (exists x: A, P x \/ Q x) <->
                       (exists x, P x) \/ (exists x , Q x).
Proof.
split.
intro.
destruct H.
destruct H.
left.
exists x.
assumption.
right.
exists x.
assumption.
intro.
destruct H.
destruct H.
exists x.
left.
assumption.
destruct H.
exists x.
right.
assumption.
Qed.

(*10*)
Lemma exists_imp_dist : (exists x: A, P x -> Q x) ->
                        (forall x:A, P x) ->
                        exists x:A, Q x.
Proof.
intro.
intro.
destruct H.
exists x.
apply H.
apply H0.
Qed.

(*11*)
Lemma not_empty_forall_exists : forall a:A,
                                (forall x:A, P x) ->
                                exists x:A, P x.
Proof.
intro.
intro.
exists a.
apply H.
Qed.

(*12*)
Lemma not_ex_forall_not : ~(exists x:A, P x) <-> forall x:A, ~P x.
Proof.
split.
intro.
unfold not in H.
intro.
intro.
apply H.
exists x.
assumption.
intro.
intro.
destruct H0.
apply H in H0.
contradiction.
Qed.

End LPPO_2.

(* 14
Todo ni˜no ve alguna bruja. Ninguna bruja tiene tanto un gato negro como un
sombrero puntiagudo. Toda bruja es buena o mala. Todo ni˜no que ve una bruja
buena recibe dulces. Las brujas malvéolas siempre tienen un gato negro.
Entonces, si toda bruja que es vista por cualquier ni˜no posee un sombrero puntiagudo,
todo ni˜no recibe un dulce.

Nino x: x es niño
Bruja x: x es bruja
Ver x y. x ve a y
Gato x: x tiene un gato negro
Sombre x: x tiene un sombrero
Bueno x: x es bueno
Dulces x: x recibe dulces
*)

Section s14.

Variable D: Set.
Variable Nino Bruja Gato Sombre Bueno Dulces: D -> Prop.
Variable Ver: D -> D -> Prop.

Hypothesis H: forall x, Nino x -> (exists y, Bruja y -> Ver x y).
Hypothesis H0: forall x, Bruja x -> ~(Gato x <-> Sombre x). (*O esclusivo*)
Hypothesis H1: forall x, Bruja x -> (Bueno x \/ ~Bueno x).
Hypothesis H2: forall x, Nino x -> (forall y, (Bruja y /\ Bueno y) -> (Ver x y -> Dulces x)).
Hypothesis H3: forall x, (Bruja x /\ ~Bueno x) -> Gato x.
Lemma lemma1: forall x y, Bruja x /\ Nino y -> ((Ver y x /\ Sombre x) -> Dulces y).
Proof.
intros.
destruct H4.
destruct H5.
apply H2 in H5.
assumption.
assumption.
split.
assumption.
apply H in H6.
destruct H6.
firstorder.
Admitted.

End s14.
(* 15
Todo muchacho ama a Santa. Todo aquel que ama a Santa ama a cualquier
reno. Rudolph es un reno y tiene la nariz roja. Todo lo que tiene una nariz roja
es raro o es un payaso. Ningún reno es un payaso. Scrooge no ama nada que sea
raro. Entonces, Scrooge no es un muchacho.

Much x: x es un muchacho
Ama x y: x ama a y
Reno x: x es un reno
Nar x: x tiene una nariz roja
Raro x: x es raro
Paya x: x es un payaso

s : Santa, r : Rudolph, sc : Scrooge

*)

Section s15.

Variable U : Set.
Variable s r sc : U.
Variable Much Reno Nar Raro Paya : U -> Prop.
Variable Ama : U -> U -> Prop.

Hypothesis H: forall x, (Much x -> Ama x s).
Hypothesis H0: forall x, (Ama x s -> (forall y, Reno y -> Ama x y)).
Hypothesis H1: Reno r /\ Nar r.
Hypothesis H2: forall x, Nar x -> (Raro x \/ Paya x).
Hypothesis H3: forall x, Reno x -> ~Paya x.
Hypothesis H4: forall x, Raro x -> ~Ama sc x.
Lemma lema2: ~Much sc.
Proof.
intro.
destruct H1.
apply H2 in H7.
apply H3 in H6.
destruct H7.
apply H4 in H7.
destruct H7.
apply H0.
apply H.
assumption.
destruct H1.
assumption.
contradiction.
Qed.

End s15.


(** * Lógica em Coq *)

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

(* ############################################### *)
(** * Lógica em Coq *)

(** Em Coq, toda expressão possui um tipo.
    Afirmações lógicas são odo tipo [Prop]. *)

Check 3 = 3.
(* ===> Prop *)

Check forall n m : nat, n + m = m + n.
(* ===> Prop *)

(** Ser uma proposição, não quer dizer que
    a afirmação pode ser provada verdadeira. *)

Check 2 = 2.
(* ===> Prop *)

Check forall n : nat, n = 2.
(* ===> Prop *)

Check 3 = 4.
(* ===> Prop *)

(** Proposições são _first-class objects_; logo,
    podem ser manipuladas como outras entidades
    de Coq. *)

Definition plus_fact : Prop := 2 + 2 = 4.
Check plus_fact.
(* ===> plus_fact : Prop *)

Theorem plus_fact_is_true :
  plus_fact.
Proof. reflexivity.  Qed.

(** É possível definir proposições parametrizadas. *)

Definition is_three (n : nat) : Prop :=
  n = 3.
Check is_three.
(* ===> nat -> Prop *)

(** Em Coq, funções que retornam proposições
    são tidas como definições de propriedades
    sobre seus argumentos. *)

Definition injective {A B} (f : A -> B) :=
  forall x y : A, f x = f y -> x = y.

Lemma succ_inj : injective S.
Proof.
  intros n m H. inversion H. reflexivity.
Qed.

(** O operador [=] é uma função que retorna [Prop].
    Escrever [n = m] é um açúcar sintático para
    [eq n m]. *)

Check @eq.
(* ===> forall A : Type, A -> A -> Prop *)

(* ############################################### *)
(** * Conectivos lógicos: conjunção *)

(** Se escreve [A /\ B] para representar que [A] e
    [B] são afirmações verdadeiras. Na prova de
    tais afirmações, usa-se a tática split. *)

Example and_example : 3 + 4 = 7 /\ 2 * 2 = 4.
Proof.
  split.
  - (* 3 + 4 = 7 *) reflexivity.
  - (* 2 + 2 = 4 *) reflexivity.
Qed.

Lemma and_intro : forall A B : Prop, A -> B -> A /\ B.
Proof.
  intros A B HA HB. split.
  - apply HA.
  - apply HB.
Qed.

(** Observe que [apply and_intro] tem o mesmo efeito
    de [split]. *)

Example and_example' : 3 + 4 = 7 /\ 2 * 2 = 4.
Proof.
  apply and_intro.
  - (* 3 + 4 = 7 *) reflexivity.
  - (* 2 + 2 = 4 *) reflexivity.
Qed.

(** **** Exercise: (and_exercise)  *)
Example and_exercise :
  forall n m : nat,
    n + m = 0 -> n = 0 /\ m = 0.
Proof.
  intros n m. intros eq. split.
  - destruct n.
    + reflexivity.
    + inversion eq.
  - destruct m.
    + reflexivity.
    + Search "plus_n_Sm". rewrite <- plus_n_Sm in eq.
      inversion eq.
Qed.

(** Se no contexto temos [A /\ B], escrever
    [destruct H as [HA HB]] irá remover H e adicionar
    duas novas hipóteses HA e HB. *)

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

(** É comum em algumas situações se saber que [A /\ B],
    mas precisarmos somente de [A] (ou [B]) para concluir
    a prova. *)

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

(** **** Exercise: (proj2)  *)
Lemma proj2 : forall P Q : Prop,
  P /\ Q -> Q.
Proof.
  intros P Q [HP HQ].
  apply HQ.
Qed.

(** Os próximos teoremas provam a comutatividade
    e associatividade da conjunção. *)

Theorem and_commut : forall P Q : Prop,
  P /\ Q -> Q /\ P.
Proof.
  intros P Q [HP HQ].
  split.
    - (* left *) apply HQ.
    - (* right *) apply HP.
Qed.

(** **** Exercise: (and_assoc)  *)
(** Dica: É possível usar um padrão de destruct
    _aninhado_; ou seja, [destruct H as [HP [HQ HR]]]. *)

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

(* ############################################### *)
(** * Conectivos lógicos: disjunção *)

(** Em Coq, escrevemos [A \/ B], e podemos usar as
    táticas [destruct] ou [intros]. *)

Lemma or_example :
  forall n m : nat,
    n = 0 \/ m = 0 -> n * m = 0.
Proof.
  (* Análise de casos em n = 0 \/ m = 0] *)
  intros n m [Hn | Hm].
  - (* [n = 0] *)
    rewrite Hn. reflexivity.
  - (* [m = 0] *)
    rewrite Hm. rewrite <- mult_n_O.
    reflexivity.
Qed.

(** Quando a disjunção está no objetivo,
    podemos usar as táticas [left] e [right]. *)

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

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

(** **** Exercise: (mult_eq_0)  *)
Lemma mult_eq_0 :
  forall n m,
    n * m = 0 -> n = 0 \/ m = 0.
Proof.
  intros n m H0. destruct n as [|n'].
  - left. reflexivity.
  - right. simpl in H0. Search "and_exercise".
    apply and_exercise in H0. apply proj1 in H0. apply H0.
Qed.

(** **** Exercise: (or_commut)  *)
Theorem or_commut : forall P Q : Prop,
  P \/ Q  -> Q \/ P.
Proof.
  intros P Q [HP | HQ].
  - right. apply HP.
  - left. apply HQ.
Qed.

(* ############################################### *)
(** * Conectivos lógicos: negação *)

(** Sintaxe em Coq: [~]. Em Coq, [~ P] é definido
    como [P -> False]; onde [False] é uma proposição
    básica contraditória. *)

Module MyNot.

Definition not (P:Prop) := P -> False.

Notation "~ x" := (not x) : type_scope.

Check not.
(* ===> Prop -> Prop *)

End MyNot.

(** Como [False] é uma contradição, se ele aparecer
    no contexto, também podemos usar [inversion]
    para concluir a prova. *)

Theorem ex_falso_quodlibet : forall (P:Prop),
  False -> P.
Proof.
  intros P contra.
  inversion contra.
Qed.

(** Em Latim, ex falso quodlibet significa,
    literalmente, "from falsehood follows
    whatever you like"; outro nome para o
    princípio da explosão. *)

(** **** Exercise: (not_implies_our_not)  *)
Fact not_implies_our_not : forall (P:Prop),
  ~ P -> (forall (Q:Prop), P -> Q).
Proof.
  intros P. intros NP. intros Q. intros HP. apply NP in HP.
  apply ex_falso_quodlibet. apply HP.
Qed.

(** Usamos a seguinte notação para representar
    o fato que dois naturais são diferentes. *)

Theorem zero_not_one : ~(0 = 1).
Proof.
  intros contra. inversion contra.
Qed.

(** Sintaxe alternativa. *)

Check (0 <> 1).
(* ===> Prop *)

Theorem zero_not_one' : 0 <> 1.
Proof.
  unfold not. intros H. inversion H.
Qed.

(** É necessário um pouco de prática para
    se acostumar com o uso da negação em Coq. *)

Theorem not_False :
  ~ False.
Proof.
  unfold not. intros H. destruct H.
Qed.

Theorem contradiction_implies_anything :
  forall P Q : Prop,
    (P /\ ~P) -> Q.
Proof.
  intros P Q [HP HNA]. unfold not in HNA.
  apply HNA in HP. destruct HP.
Qed.

Theorem double_neg : forall P : Prop,
  P -> ~~P.
Proof.
  intros P H. unfold not. intros G.
  apply G. apply H.
Qed.

(** **** Exercise: (contrapositive)  *)
Theorem contrapositive : forall (P Q : Prop),
  (P -> Q) -> (~Q -> ~P).
Proof.
  intros P Q PQ. unfold not. intros QF. intros HP.
  apply QF. apply PQ. apply HP.
Qed.

(** **** Exercise: (not_both_true_and_false)  *)
Theorem not_both_true_and_false : forall P : Prop,
  ~ (P /\ ~P).
Proof.
  intros P. unfold not. intros [HP PF]. apply PF. apply HP.
Qed.

(** Como desigualdades usam negação, é preciso prática
    para se acostumar com o seu uso em Coq. Ao tentar
    provar algo claramente absurdo (e.g., [false = true]),
    aplique [ex_falso_quodlibet] para mudar o objetivo
    da prova para [False]. *)

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

(** Como uso de [ex_falso_quodlibet] é comum,
    há uma tática específica em Coq chamada
    [exfalso]. *)

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

(** Em Coq, [True] define uma proposição básica
    que é trivialmente verdadeira. Para prová-la,
    usamos a constante predefinida [I : True]. *)

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

(* ############################################### *)
(** * Equivalência lógica *)

(** Em Coq, o "se e somente se" é representado
    como a conjunção de duas implicações. *)

Module MyIff.

Definition iff (P Q : Prop) := (P -> Q) /\ (Q -> P).

Notation "P <-> Q" := (iff P Q)
                      (at level 95, no associativity)
                      : type_scope.

End MyIff.

Theorem iff_sym : forall P Q : Prop,
  (P <-> Q) -> (Q <-> P).
Proof.
  intros P Q [HAB HBA].
  unfold iff. split.
  - (* -> *) apply HBA.
  - (* <- *) apply HAB.  Qed.

Lemma not_true_iff_false : forall b,
  b <> true <-> b = false.
Proof.
  intros b. split.
  - (* -> *)
    apply not_true_is_false.
  - (* <- *)
    intros H. rewrite H. intros H'.
    inversion H'.
Qed.

(** **** Exercise: (iff_properties)  *)
Theorem iff_refl : forall P : Prop,
  P <-> P.
Proof.
  intros P. split.
  - intros HP. apply HP.
  - auto.
Qed.

Theorem iff_trans : forall P Q R : Prop,
  (P <-> Q) -> (Q <-> R) -> (P <-> R).
Proof.
  intros P Q R iffPQ iffQR.
  split.
  - Search (?E /\ _ -> ?E). apply proj1 in iffPQ. apply proj1 in iffQR.
    intros HP. apply iffQR. apply iffPQ. apply HP.
  - apply proj2 in iffPQ. apply proj2 in iffQR.
    intros HR. apply iffPQ. apply iffQR. apply HR.
Qed.

(** **** Exercise: (or_distributes_over_and)  *)
Theorem or_distributes_over_and : forall P Q R : Prop,
  P \/ (Q /\ R) <-> (P \/ Q) /\ (P \/ R).
Proof.
  intros P Q R. split.
  {
    intros [HP | [HQ HR]].
    {
      split.
      - left. apply HP.
      - auto.
    }
    {
      split.
      - right. apply HQ.
      - auto.
    }
  }
  {
    intros [[HP | HQ] [HP' | HR]].
    - left. apply HP.
    - auto.
    - auto.
    - auto.
  }
Qed.

(** As táticas [rewrite] e [reflexivity] podem
    ser usadas com afirmações se e somente se,
    não somente com igualdades. Isto é suportado
    pela biblioteca Setoid. *)

Require Import Coq.Setoids.Setoid.

(** Primeiro, provando algumas equivalências. *)

Lemma mult_0 : forall n m,
  n * m = 0 <-> n = 0 \/ m = 0.
Proof.
  split.
  - apply mult_eq_0.
  - apply or_example.
Qed.

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

(** Agora, podemos usar [rewrite] e [reflexivity]
    com as equivalências antes provadas. *)

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

(** A tática [apply] também pode ser usada com [<->].
    Nesses casos, a tática tenta advinhar qual
    lado da equivalência usar. *)

Lemma apply_iff_example :
  forall n m : nat,
    n * m = 0 -> n = 0 \/ m = 0.
Proof.
  intros n m H. apply mult_0. apply H.
Qed.

(* ############################################### *)
(** ** Quantificação existencial *)

(** Em Coq, escrevemos [exists x : T, P]. Assim como
    o [forall], a anotação [: T] pode ser omitida
    se Coq tiver como inferir o tipo de [x].

    Para provar uma afirmação usando [exists x], primeiro
    precisamos explicitamente dizer a Coq qual
    testemunha (witness) [t] deve ser usada para [x].
    Para tanto, usamos a tática [exists t].

    Em seguida, devemos provar que a afirmação é verdadeira
    com toda ocorrência de [x] substituída por [t]. *)

Lemma four_is_even :
  exists n : nat, 4 = n + n.
Proof.
  exists 2. reflexivity.
Qed.

(** Se o [exists x] estiver no contexto, podemos
    destruir para obter uma testemunha [x] e
    uma hipótese afirmando que [P] é verdade. *)

Theorem exists_example_2 : forall n,
  (exists m, n = 4 + m) ->
  (exists o, n = 2 + o).
Proof.
  intro n. intro H. destruct H as [m Hm].
  exists (2 + m).
  apply Hm.
Qed.

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

(** **** Exercise: (dist_exists_or)  *)
Theorem dist_exists_or : forall (X:Type) (P Q : X -> Prop),
  (exists x, P x \/ Q x) <->
  (exists x, P x) \/ (exists x, Q x).
Proof.
  intros X P Q. split.
  - intros [x [HP | HQ]].
    + left. exists x. apply HP.
    + right. exists x. apply HQ.
  - intros [HP | HQ].
    + destruct HP as [x HP].
      exists x. left. apply HP.
    + destruct HQ as [x HQ].
      exists x. right. apply HQ.
Qed.

(* ############################################### *)
(** ** Programando com proposições *)

(** Podemos definir proposições complexas a partir
    de outras proposições simples. *)

Fixpoint In {A : Type} (x : A) (l : list A) : Prop :=
  match l with
  | [] => False
  | x' :: l' => x' = x \/ In x l'
  end.

(** Quando [In] é aplicado a uma lista concreta,
    sua aplicação expande para uma sequência de
    disjunções aninhadas. *)

Example In_example_1 : In 4 [1; 2; 3; 4; 5].
Proof.
  simpl. right. right. right. left. reflexivity.
Qed.

(** No exemplo a seguir, observe o uso do
    padrão vazio: []. *)

Example In_example_2 :
  forall n, In n [2; 4] ->
  exists n', n = 2 * n'.
Proof.
  simpl.
  intros n [H | [H | []]].
  - exists 1. rewrite <- H. reflexivity.
  - exists 2. rewrite <- H. reflexivity.
Qed.

(** Podemos definir e provar afirmações mais gerais.
    Observe que, inicialmente, [In] é aplicado a uma
    variável e só é expandido ao fazer análise
    de casos sobre esta variável. *)

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

(** Esta maneira de definir proposições recursivamente,
    apesar de conveniente, está sujeita à limitação
    de definição de funções recursivas em Coq. *)

(** **** Exercise: (In_map_iff)  *)
Lemma In_map_iff :
  forall (A B : Type) (f : A -> B) (l : list A) (y : B),
    In y (map f l) <->
    exists x, f x = y /\ In x l.
Proof.
  intros A B f l. induction l as [|x l' IHl'].
  - simpl. intros y. split.
    + intros F. inversion F.
    + intros [x H]. apply proj2 in H. apply H.
  - intros y. split.
    + intros [H | H].
      * exists x. split. apply H. left. reflexivity.
      * simpl. apply IHl' in H. destruct H as [x' H].
        exists x'. split.
          { apply proj1 in H. apply H. }
          { destruct H as [H1 H2]. right. apply H2. }
    + intros He. simpl.
      destruct He as [x' H]. destruct H as [H1 H2]. simpl in H2.
        destruct H2 as [H2 | H2].
      * left. rewrite H2. apply H1.
      * right. apply IHl'. exists x'. split.
        { apply H1. }
        { apply H2. }
Qed.

(** **** Exercise: (In_app_iff)  *)
Lemma In_app_iff : forall A l l' (a:A),
  In a (l++l') <-> In a l \/ In a l'.
Proof.
  intros A l l'. induction l as [| a' l1 IHl1].
  - split.
    + simpl. intros H. right. apply H.
    + simpl. intros [contra | H].
      * inversion contra.
      * apply H.
  - split.
    + simpl. intros [H | H].
      * left. left. apply H.
      * apply IHl1 in H. destruct H as [H | H].
        { left. right. apply H. }
        { right. apply H. }
    + intros [H | H].
      * simpl in H. simpl. destruct H as [H | H].
        { left. apply H. }
        { right. apply IHl1. left. apply H. }
      * simpl. right. apply IHl1. right. apply H.
Qed.

(** **** Exercise: (All)  *)
(** Defina uma função recursiva [All] que retorna uma
    proposição afirmando que uma propriedade [P] é
    satisfeita por todos os elementos da lista. Em seguida,
    para provar que sua definição é correta, prove o
    lemma [All_In]. *)

Fixpoint All {T : Type} (P : T -> Prop) (l : list T) : Prop :=
  match l with
  | [] => True
  | (x :: l') => P x /\ All P l'
  end.

Lemma All_In :
  forall T (P : T -> Prop) (l : list T),
    (forall x, In x l -> P x) <-> All P l.
Proof.
  intros T P l. induction l as [| t l' IHl'].
  - split.
    + simpl. intros H. apply I.
    + simpl. intros H. intros x. intros false. inversion false.
  - split.
    + simpl. intros H. split.
      * apply H. left. reflexivity.
      * apply IHl'. intros x. intros Hin.
        apply H. right. apply Hin.
    + simpl. intros [H1 H2]. intros x.
      intros H.
      rewrite <- IHl' in H2.
      destruct H as [H | H].
      * rewrite <- H. apply H1.
      * apply H2. apply H.
Qed.

(* ############################################### *)
(** * Aplicando teoremas a argumentos *)

(** Em Coq, _provas_ são também "first-class objects".
    Mais informações em:
    https://softwarefoundations.cis.upenn.edu/lf-current/IndProp.html
    https://softwarefoundations.cis.upenn.edu/lf-current/ProofObjects.html

    Veja o exemplo a seguir. *)

Lemma plus_comm3 :
  forall x y z, x + (y + z) = (z + y) + x.
Proof.
  intros x y z.
  rewrite plus_comm.
  rewrite plus_comm.
  (* voltamos ao ponto inicial *)
Abort.

(** Uma alternativa é criar uma versão
    especializada de [plus_comm] usando [assert]. *)

Lemma plus_comm3_take2 :
  forall x y z, x + (y + z) = (z + y) + x.
Proof.
  intros x y z.
  rewrite plus_comm.
  assert (H : y + z = z + y).
  { rewrite plus_comm. reflexivity. }
  rewrite H.
  reflexivity.
Qed.

(** Ou, de forma mais elegante, aplicar [plus_comm]
    diretamente aos argumentos para os quais
    desejamos instanciar a prova [plus_comm]. *)

Lemma plus_comm3_take3 :
  forall x y z, x + (y + z) = (z + y) + x.
Proof.
  intros x y z.
  rewrite plus_comm.
  rewrite (plus_comm y z).
  reflexivity.
Qed.

(** Logo, é possível usar teoremas como funções! *)

Example lemma_application_ex :
  forall {n : nat} {ns : list nat},
    In n (map (fun m => m * 0) ns) ->
    n = 0.
Proof.
  intros n ns H.
  Print proj1.
  Print In_map_iff.
  Search "In_map_iff".
  Compute (proj1 _ _).
  destruct (proj1 _ _ (In_map_iff _ _ _ _ _) H)
           as [m [Hm _]].
  rewrite mult_0_r in Hm.
  rewrite <- Hm. reflexivity.
Qed.

(**
In_map_iff:
  forall (A B : Type) (f : A -> B) (l : list A) (y : B), In y (map f l) <-> (exists x : A, f x = y /\ In x l)

In_map_iff:
  f = fun m => m * 0
  y = n
  l = ns
result:
  In n (map (fun m => m * 0) ns) <-> (exists x: nat, x * 0 = n /\ In x ns)
result rewriten:
  In n (map (fun m => m * 0) ns) -> (exists x: nat, x * 0 = n /\ In x ns)
  /\ In n (map (fun m => m * 0) ns) <-> (exists x: nat, x * 0 = n /\ In x ns)

proj1 _ _ result:
  In n (map (fun m => m * 0) ns) -> (exists x: nat, x * 0 = n /\ In x ns)
applied to H:
  (exists x: nat, x * 0 = n /\ In x ns)
**)

(* ############################################### *)
(** * Coq vs. Teoria dos conjuntos *)

(** O core lógico de Coq é baseado no _Calculus of
    Inductive Constructions_, que, por sua vez,
    difere de outros sistemas formais como
    a teoria de conjuntos de Zermelo-Fraenkel (ZFC).

    Por exemplo, em ZFC, um elemento pode ser membro
    de vários conjuntos. Em Coq, um termo é membro
    de no máximo um tipo. Logo, no lugar de dizer
    que um número natural [n] pertence ao conjunto
    dos números pares, em Coq, dizemos que a
    afirmação [ev n] é verdadeira, onde
    [ev : nat -> Prop].

    Contudo, há casos em que expressar uma certa
    afirmação em Coq não é algo direto, às vezes,
    nem possível, exceto se enriquecermos a lógica
    suportada por Coq com axiomas adicionais. *)

(** ** Functional Extensionality *)

(** Duas funções [f] e [g] são consideradas iguais
    se elas produzem a mesma saída para toda
    entrada possível.

    (forall x, f x = g x) -> f = g

    Esta definição é conhecida como o princípio
    da _functional extensionality_, e ela não faz
    parte dos axiomas básicos definidos em Coq.
    Logo, proposições envolvendo este conceito
    não podem ser provadas. *)

Example function_equality_ex2 :
  (fun x => plus x 1) = (fun x => plus 1 x).
Proof.
   (* Stuck *)
Abort.

(** Contudo, podemos axiomatizar esta definição
    usando o comando [Axiom]. *)

Axiom functional_extensionality :
  forall {X Y: Type} {f g : X -> Y},
    (forall (x:X), f x = g x) -> f = g.

(** O efeito de [Axiom] é o mesmo de definir um
    Teorema e não prová-lo, através do uso
    de [Admitted]. Contudo, aqui, não existe
    a intenção de provar posteriormente a afirmação. *)

Example function_equality_ex2 :
  (fun x => plus x 1) = (fun x => plus 1 x).
Proof.
  apply functional_extensionality. intros x.
  apply plus_comm.
Qed.

(** É preciso ter cuidado ao adicionar novos
    axiomas para não introduzir inconsistências.
    Não é simples, em linhas gerais, provar
    a consistência lógica de um conjunto de axiomas.

    No caso particular do functional extensionality,
    este é consistente com o core lógico de Coq.

    O comando [Print Assumptions] imprime que
    axiomas adicionais foram utilizados em uma
    certa prova. *)

Print Assumptions function_equality_ex2.
(* ===>
     Axioms:
     functional_extensionality :
         forall (X Y : Type) (f g : X -> Y),
                (forall x : X, f x = g x) -> f = g *)

(** ** Proposições e Booleanos *)

(** Podemos definir fatos lógicos usando _booleanos_
    ou _proposições_. Por exemplo, dizer que [n] é
    par, pode ser representado dizendo que

    (1) [evenb n] retorna [true] ou
    (2) que existe um [k] tal que [n = double k]

    Estas duas definições são equivalentes. *)

(** Definindo lemmas auxiliares. *)

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

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

(** **** Exercise: (evenb_double_conv)  *)
Theorem evenb_double_conv : forall n,
  exists k, n = if evenb n then double k
                else S (double k).
Proof.
  intros n. induction n as [| n'].
  - simpl. exists 0. reflexivity.
  - destruct IHn' as [k H].
    rewrite -> evenb_S. unfold negb.
    destruct (evenb n') eqn: H1.
    + exists k. rewrite H. reflexivity.
    + exists (S k). simpl. rewrite H. reflexivity.
Qed.

Theorem even_bool_prop : forall n,
  evenb n = true <-> exists k, n = double k.
Proof.
  induction n as [| n'].
  - simpl. split.
    + intros eq. exists 0. reflexivity.
    + intros ex. reflexivity.
  - split.
    + intros H. Compute (evenb_double_conv _).
      destruct (evenb_double_conv (S n')) as [k H0].
      rewrite H in H0. exists k. apply H0.
    + intros [k H0]. rewrite H0. apply evenb_double.
Qed.

(** Dizemos, portanto, que a computação de
    [evenb n] _reflete_ a proposição lógica
    [exists k, n = double k]. Veja outro exemplo
    a seguir. *)

Theorem beq_nat_refl : forall n : nat,
  true = beq_nat n n.
Proof.
  intro n. induction n as [| n'].
  - reflexivity.
  - simpl. rewrite IHn'.
    reflexivity.
Qed.

Theorem beq_nat_true_iff : forall n1 n2 : nat,
  beq_nat n1 n2 = true <-> n1 = n2.
Proof.
  intros n1 n2. split.
  - apply beq_nat_true.
  - intros H. rewrite H.
    rewrite <- beq_nat_refl.
    reflexivity.
Qed.

(** Em algumas situações, a definição proposicional
    é mais útil do que a booleana. Por exemplo,
    saber que [beqnat n m = true] pode não ser tão
    útil quanto saber que [n = m]; uma vez que,
    a segunda opção permite realizar reescrita.

    Contudo, em outras situações, a definição
    booleana é mais útil. Por exemplo, Coq
    não permite testar se uma proposição
    qualquer é verdadeira ou falsa na definição
    de uma função. Veja que o código abaixo
    não é aceito. *)

Fail Definition is_even_prime n :=
  if n = 2 then true
  else false.

(** Coq reclama que [n = 2] tem tipo [Prop],
    quando ele espera outro tipo indutivo com
    dois elementos (construtores). Isto está
    associado com o fato que em Coq toda função
    é total e precisa ser computável (em particular,
    para permitir a extração de código executável.

    Se fosse permitir usar [Prop] em uma análise
    de casos, seria possível escrever funções
    não computáveis.

    Em alguns casos, mesmo tendo uma propriedade
    computável, é mais fácil defini-la usando
    [Prop], uma vez que funções em Coq possuem
    restrições significativas na sua definição.

    Por outro lado, um ponto positivo em definir
    fatos de forma computável é permitir certa
    automação através da computação de termos em
    Coq. Esta é uma técnica conhecida como _proof
    by reflection_. Veja o exemplo a seguir. *)

Example even_1000 : exists k, 1000 = double k.
Proof. exists 500. reflexivity. Qed.

Example even_1000' : evenb 1000 = true.
Proof. simpl. reflexivity. Qed.

Example even_1000'' : exists k, 1000 = double k.
Proof.
  Print even_bool_prop.
  apply even_bool_prop.
  reflexivity.
Qed.

(** **** Exercise: (logical_connectives)  *)
(** Os próximos lemmas relacionam conectivos lógicos
    com as respectivas operações booleanas. *)

Lemma andb_true_iff : forall b1 b2:bool,
  b1 && b2 = true <-> b1 = true /\ b2 = true.
Proof.
  intros b1 b2.
  split.
  - simpl. intros H. destruct b1.
    + destruct b2.
      * auto.
      * auto.
    + simpl in H. rewrite H. destruct b2.
      * auto.
      * auto.
  - intros [H1 H2]. rewrite H1. rewrite H2. simpl. reflexivity.
Qed.

Lemma orb_true_iff : forall b1 b2,
  b1 || b2 = true <-> b1 = true \/ b2 = true.
Proof.
  intros b1 b2. split.
  - intros H. destruct b1.
    + left. reflexivity.
    + destruct b2.
      * right. reflexivity.
      * simpl in H. rewrite H. left. reflexivity.
  - intros [H | H].
    + rewrite H. simpl. reflexivity.
    + rewrite H. destruct b1.
      * reflexivity.
      * reflexivity.
Qed.

(** ** Lógica clássica vs. construtivas *)

(** Anteriormente, vimos que não é possível
    verificar se uma proposição [P] é verdadeira
    ou não dentro da definição de uma função
    em Coq. O mesmo se aplica para provas.
    O seguinte princípio não é possível derivar
    a partir dos axiomas definidos em Coq. *)

Definition excluded_middle :=
  forall P : Prop, P \/ ~ P.

(** Ao provar objetivos na prova [_ \/ _],
    usamos [left] ou [right] que, implicitamente,
    requer saber qual lado da disjunção é
    verdadeiro. Contudo, neste caso, nada se
    sabe sobre [P]. No entanto, se [P] for
    refletido em algum termo booleano [b],
    é possível realizar a prova; basta checar
    o valor de [b]. *)

Theorem restricted_excluded_middle : forall P b,
  (P <-> b = true) -> P \/ ~ P.
Proof.
  intros P b H. destruct b.
  - left. rewrite H. reflexivity.
  - right. rewrite H. unfold not.
    intros contra. inversion contra.
Qed.

(** Em particular, a propriedade de _excluded middle_
    é válida para equações [n = m] entre números
    naturais [n] e [m]. *)

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

(** Como consequência de não assumir o _excluded middle_,
    se existe uma prova para [exists x, P x], então é
    possível explicitar um valor para [x] tal que
    [P x] é verdade; em outras palavras, toda prova
    de existência é _construtiva_. Lógicas como ZFC
    são tidas como lógicas clássicas. *)

(* ############################################### *)
(** * Leitura sugerida *)

(** Software Foundations: volume 1
  - Logic in Coq
  https://softwarefoundations.cis.upenn.edu/lf-current/Logic.html
*)