Require Import Znumtheory Zdiv ZArith.
Local Open Scope Z_scope.

Import N2Z.

(* Lemmas I needed over what the Coq library supplies *)

Lemma div_swap_l: forall a b c, a <> 0 -> (a | b) -> b = a * c <-> b / a = c.
Proof.
  intros a b c a_neq_0 a_div_b.
  split.
  - destruct a_div_b as [x def_a].
    intros def_b.
    rewrite def_a.
    rewrite Z_div_mult_full; auto.
    rewrite def_a, Z.mul_comm in def_b.
    rewrite Z.mul_cancel_l in def_b; auto.
  - intros def_b.
    rewrite <- def_b.
    rewrite <- Z.divide_div_mul_exact; auto.
    rewrite Z.mul_comm.
    symmetry.
    apply Z_div_mult_full; auto.
Qed.

Lemma div_positive: forall a b, a > 0 -> b > 0 -> (a | b) -> b / a > 0.
Proof.
  intros a b a_gt_0 b_gt_0.
  intros a_div_b.
  destruct a_div_b as [x def_of_x].
  cut (x > 0). intro Cut.
  rewrite def_of_x, Z_div_mult_full; omega.
  rewrite def_of_x in b_gt_0.
  apply (Zmult_gt_reg_r x 0 a); auto.
Qed.

Lemma square_le_lemma: forall m, m > 0 -> (m / 2) * (m / 2) <=  (m * m) / 4.
Proof.
  intros m m_gt_0.
  replace 4 with (2 * 2) by auto.
  apply Zdiv_le_lower_bound; [omega | auto].
  replace ((m / 2) * (m / 2) * (2 * 2)) with ((2 * (m / 2)) * (2 * (m / 2))) by ring.
  apply Z.square_le_mono_nonneg; [auto | apply Z.mul_div_le; omega].
  replace 0 with (2 * 0) by ring.
  apply Zmult_le_compat_l; [apply Zdiv_le_lower_bound | auto]; omega.
Qed.

Lemma square_gt_0: forall n, n <> 0 -> n * n > 0.
Proof.
  intros n n_not_zero.
  destruct n;
    [contradict n_not_zero; reflexivity |
     auto |
     rewrite <- Pos2Z.opp_pos, Z.mul_opp_opp];
    rewrite <- Pos2Z.inj_mul; apply Zgt_pos_0.
Qed.

Lemma Zgt_ge_incl: forall n m: Z, m > n -> m >= n.
  intros n m n_lt_m.
  apply Z.gt_lt in n_lt_m.
  apply Z.lt_le_incl in n_lt_m.
  rewrite Z.ge_le_iff.
  assumption.
Qed.

Lemma square_ge_0: forall n, n * n >= 0.
Proof.
  intros n.
  destruct n;
    [omega |
     auto |
     rewrite <- Pos2Z.opp_pos, Z.mul_opp_opp];
    rewrite <- Pos2Z.inj_mul; apply Zgt_ge_incl; apply Zgt_pos_0.
Qed.

Lemma sum_of_squares_eq_0: forall a b, a * a + b * b = 0 -> a = 0 /\ b = 0.
Proof.
  intros a b.
  intros eq_0.
  remember (square_ge_0 a).
  remember (square_ge_0 b).
  assert (b * b = 0) by omega.
  rewrite H, Z.add_0_r in eq_0.
  rewrite Z.eq_square_0 in H.
  rewrite Z.eq_square_0 in eq_0.
  split; assumption.
Qed.

Lemma sum_of_squares_gt_0: forall a b, a * a + b * b > 0 -> a * a > 0 \/ b * b > 0.
Proof.
  intros a b gt_0.
  omega.
Qed.

(* Begin descent apparatus *)

Definition descent_modulus a m :=
  let m' := a mod m in
  if Z_le_dec (2 * m') m then
    m'
  else
    (a mod m) - m.

Lemma descent_modulus_le_m_div_2 : forall a m,
    m > 0 -> Z.abs (descent_modulus a m) <= m / 2.
Proof.
  intros a m m_gt_1.
  unfold descent_modulus.
  assert (m > 0) as m_gt_0 by omega.
  remember (Z_mod_lt a _ m_gt_0) as m'_bound.
  destruct Heqm'_bound.
  remember (a mod m) as m'.
  destruct (Z_le_dec (2 * m') m).
  - assert (0 <= m') by omega.
    apply Z.abs_eq_iff in H.
    rewrite H.
    apply Zdiv_le_lower_bound; omega.
  - assert (a mod m - m <= 0) as HQuantityNegative by omega.
    rewrite <- Heqm' in HQuantityNegative.
    apply Z.abs_neq_iff in HQuantityNegative.
    rewrite HQuantityNegative.
    apply Zdiv_le_lower_bound; omega.
Qed.

Lemma descent_modulus_equiv_a_mod_m : forall a m,
    m > 0 -> (descent_modulus a m) mod m = a mod m.
Proof.
  intros a m m_gt_0.
  unfold descent_modulus.
  destruct (Z_le_dec (2 * (a mod m)) m).
  - apply (Z_mod_lt a m) in m_gt_0.
    rewrite Zmod_mod; reflexivity.
  - apply (Z_mod_lt a m) in m_gt_0.
    rewrite Zminus_mod, Z_mod_same_full, Z.sub_0_r.
    repeat rewrite Zmod_mod.
    reflexivity.
Qed.

Lemma descent_modulus_eq_0: forall a m, m > 0 -> descent_modulus a m = 0 -> (m | a).
Proof.
  intros a m m_not_0.
  unfold descent_modulus.
  destruct (Z_le_dec (2 * (a mod m)) m).
  - intros eq_0; apply Zmod_divide; omega.
  - intros eq_0. apply Zmod_divide; [omega | ].
    rewrite Z.sub_move_r in eq_0.
    simpl in eq_0.
    remember (Z_mod_lt a m).
    omega.
Qed.

(* N = a^2 + b^2 = m * q, return (c^2 + d^2)k*q, k < m *)
Definition descent a b q :=
  let N := a * a + b * b in
  let m := N / q in
  if Z.eq_dec m 1 then
    (1, a, b)
  else
    let (u, v) := (descent_modulus a m, descent_modulus b m) in
    ((u * u + v * v) / m, (a * u + b * v)/m, (b * u - a * v)/m).

(* 3^2 + 2^2 = 13 *)
(* 5^2 + 1 = 2 * 13 *)

(* Examples of the descent step *)
Compute (descent 5 1 13).
Compute (descent 12 1 29).
Compute (descent (-7) 3 29).
Compute (descent 442 1 953).
Compute (descent 69 2 953).
Compute (descent (-15) (-41) 953).

Lemma descent_inequality: forall m,
    m > 0 -> (m / 2) * (m / 2) + (m / 2) * (m / 2) < m * m.
Proof.
  intros m m_gt_0.
  cut (((m * m) / 4) + (m * m) / 4 < m * m).
  intros Cut.
  remember (square_le_lemma m m_gt_0).
  omega.
  cut ((m * m / 4 + m * m / 4) <= (m * m / 2)).
  intros Cut.
  apply (Z.le_lt_trans _ (m * m / 2) _ Cut).
  apply Z_div_lt; [omega | apply Zmult_gt_0_compat; auto].
  replace ((m * m / 4) + (m * m / 4)) with (2 * (m * m / 4)) by ring.
  apply Zdiv_le_lower_bound; [omega | auto].
  replace (2 * (m * m / 4) * 2) with (4 * (m * m / 4)) by ring.
  apply Z_mult_div_ge; omega.
Qed.

Lemma descent_nonzero_inequality: forall u v, ~ (u * u + v * v) = 0 -> u * u + v * v > 0.
Proof.
  intros u v c.
  remember (square_ge_0 u).
  remember (square_ge_0 v).
  omega.
Qed.

Lemma descent_nonzero: forall a b q N m,
  prime q ->
  q > 0 -> N > 0 ->
  N = (a * a + b * b) ->
  (q | N) ->
  m = N / q ->
  1 < m < q ->
  descent_modulus a m * descent_modulus a m + descent_modulus b m * descent_modulus b m > 0.
Proof.
  intros a b q N m q_prime q_gt_0 N_gt_0 def_N q_divides_N def_m mt_gt_1.
  remember (descent_modulus a m) as u.
  remember (descent_modulus b m) as v.
  apply descent_nonzero_inequality.
  assert (u * u + v * v = 0 -> (m | a) /\ (m | b)) as zero_means_m_divides_a_and_b.
  intros eq_0.
  rewrite Hequ, Heqv in eq_0.
  apply sum_of_squares_eq_0 in eq_0.
  destruct eq_0 as [H I]; apply descent_modulus_eq_0 in H; apply descent_modulus_eq_0 in I;
    [| omega | omega | omega ]; auto.
  assert ((m | a) /\ (m | b) -> (m * m | a * a + b * b)) as divide_one_divide_all.
  intros [m_div_a m_div_b].
  destruct m_div_a as [k def_k].
  destruct m_div_b as [j def_j].
  exists (k * k + j * j).
  rewrite def_k, def_j; ring.
  assert ((m * m | a * a + b * b) -> (m | q)) as divide_all_implies_divide_prime.
  (* we know q * m = N *)
  (* we know m * m divides N *)
  (* so m divides q *)
  rewrite <- def_N.
  symmetry in def_m.
  rewrite <- (div_swap_l q N) in def_m; [|omega|]; auto.
  rewrite def_m.
  rewrite Z.mul_divide_cancel_r; [|omega]; auto.
  unfold not.
  intros eq_0.
  apply zero_means_m_divides_a_and_b in eq_0.
  apply divide_one_divide_all in eq_0.
  apply divide_all_implies_divide_prime in eq_0.
  apply (prime_divisors q q_prime m) in eq_0.
  omega.
Qed.

Lemma div_swap_lt_l: forall a b c, a > 0 -> (a | c) -> a * b < c <-> b < c / a.
Proof.
  intros a b c a_gt_0 a_div_c.
  destruct a_div_c as [x def_c].
  rewrite def_c.
  rewrite (Z.mul_comm a b).
  rewrite Z_div_mult_full; [|omega]; auto.
  rewrite <- Z.mul_lt_mono_pos_r; omega.
Qed.

Lemma div_swap_lt_r: forall a b c, a > 0 -> (a | b) -> b < a * c <-> b / a < c.
Proof.
  intros a b c a_gt_0 a_div_c.
  destruct a_div_c as [x def_c].
  rewrite def_c.
  rewrite Z_div_mult_full; [|omega]; auto.
  rewrite (Z.mul_comm x a).
  rewrite <- Z.mul_lt_mono_pos_l; omega.
Qed.

(* Prove that the descent step either terminates or produces a smaller integer *)
Theorem descent_smaller: forall a b q N m,
  prime q ->
  q > 0 -> N > 0 ->
  N = (a * a + b * b) ->
  (q | N) ->
  m = N / q ->
  m < q ->
  forall k t1 t2,  (k, t1, t2) = descent a b q ->
  k = 1 \/ (0 < k < m).
Proof.
  intros a b q N m q_prime q_gt_0 N_gt_0 def_N q_div_N def_m m_lt_q k u v.
  assert (m > 0) as m_gt_0.
  rewrite def_m; apply div_positive; auto.
  unfold descent.
  rewrite <- def_N, <- def_m.
  destruct (Z.eq_dec m 1); intros descent_def; inversion descent_def.
  - left; reflexivity.
  - right.
    split.
    rewrite <- div_swap_lt_l; [ | omega | ]; auto.
    remember (descent_nonzero a b q N m q_prime q_gt_0 N_gt_0 def_N q_div_N def_m); omega.
    rewrite <- Z.mod_divide; [|omega].
    rewrite Zplus_mod.
    rewrite (Zmult_mod (descent_modulus a m)).
    rewrite (Zmult_mod (descent_modulus b m)).
    repeat rewrite descent_modulus_equiv_a_mod_m; auto.
    repeat rewrite <- Zmult_mod.
    repeat rewrite <- Zplus_mod.
    rewrite <- def_N, Z.mod_divide; [|omega].
    exists q.
    rewrite div_swap_l; [auto | omega |assumption].
    rewrite <- (Z.abs_square (descent_modulus a m)).
    rewrite <- (Z.abs_square (descent_modulus b m)).
    apply Z.div_lt_upper_bound; [apply Z.gt_lt; apply m_gt_0; auto | auto].
    remember (descent_modulus_le_m_div_2 a m m_gt_0).
    remember (descent_modulus_le_m_div_2 b m m_gt_0).
    assert ((Z.abs (descent_modulus a m)) *
            (Z.abs (descent_modulus a m)) <= (m / 2) * (m / 2)).
    apply Z.square_le_mono_nonneg; [apply Z.abs_nonneg | auto].
    assert ((Z.abs (descent_modulus b m)) *
            (Z.abs (descent_modulus b m)) <= (m / 2) * (m / 2)).
    apply Z.square_le_mono_nonneg; [apply Z.abs_nonneg | auto].
    assert (Z.abs (descent_modulus a m) *
            Z.abs (descent_modulus a m) +
            Z.abs (descent_modulus b m) *
            Z.abs (descent_modulus b m) <= (m / 2) * (m / 2) + (m / 2) * (m / 2)) by omega.
    apply (Z.le_lt_trans _ _ _ H4).
    apply descent_inequality; auto.
Qed.

Lemma diophantine_identity:
  forall a b c d, (a * a + b * b) * (c * c + d * d) = (a * c + b * d) * (a * c + b * d) + (b * c - a * d) * (b * c - a * d).
Proof.
  intros; ring.
Qed.

Lemma descent_div_sum: forall a b q N m,
  q > 0 -> N > 0 ->
  N = (a * a + b * b) ->
  m = N / q ->
  (q | N) ->
  (m | (descent_modulus a m * descent_modulus a m + descent_modulus b m * descent_modulus b m)).
Proof.
  intros a b q N m q_gt_0 N_gt_0 def_N def_m q_div_N.
  assert (m > 0) as m_gt_0.
  rewrite def_m; apply div_positive; auto.
  rewrite <- Z.mod_divide; [|omega].
  rewrite Zplus_mod.
  repeat rewrite (Zmult_mod (descent_modulus a m) (descent_modulus a m) m), descent_modulus_equiv_a_mod_m; [|omega].
  repeat rewrite (Zmult_mod (descent_modulus b m) (descent_modulus b m) m), descent_modulus_equiv_a_mod_m; [|omega].
  repeat rewrite <- Zmult_mod.
  rewrite <- Zplus_mod.
  rewrite Z.mod_divide; [auto | omega].
  exists q.
  rewrite def_m, def_N.
  apply Zdivide_Zdiv_eq; [omega | auto].
  rewrite <- def_N; auto.
Qed.

Lemma descent_div_N: forall a b q N m,
  q > 0 -> N > 0 ->
  N = (a * a + b * b) ->
  m = N / q ->
  (q | N) -> (m | N).
Proof.
  intros a b q N m q_gt_0 N_gt_0 def_N def_m q_div_N.
  exists q.
  rewrite def_m.
  apply Zdivide_Zdiv_eq; [omega| auto].
Qed.

(*
  (u * u + v * v) / m * q =
  (a * u + b * v) / m * ((a * u + b * v) / m) + (a * v - b * u) / m * ((a * v - b * u) / m)
 *)

Lemma descent_div_term1: forall a b q N m,
  q > 0 -> N > 0 ->
  N = (a * a + b * b) ->
  m = N / q ->
  (q | N) ->
  (m | (a * descent_modulus a m + b * descent_modulus b m)).
Proof.
  intros a b q N m q_gt_0 N_gt_0 def_N def_m q_div_N.
  (* must show m > 0 as ever *)
  assert (m > 0).
  rewrite def_m; apply div_positive; auto.
  rewrite <- Z.mod_divide; [| omega].
  rewrite Zplus_mod, (Zmult_mod a _ _), (Zmult_mod b _ _).
  repeat rewrite descent_modulus_equiv_a_mod_m; auto.
  repeat rewrite <- Zmult_mod.
  repeat rewrite <- Zplus_mod.
  rewrite Z.mod_divide; [| omega].
  exists q.
  rewrite <- def_N.
  rewrite div_swap_l; [auto| omega | auto].
Qed.

Lemma descent_div_term2: forall a b q N m,
  q > 0 -> N > 0 ->
  N = (a * a + b * b) ->
  m = N / q ->
  (q | N) ->
  (m | (b * descent_modulus a m - a * descent_modulus b m)).
Proof.
  intros a b q N m q_gt_0 N_gt_0 def_N def_m q_div_N.
  (* must show m > 0 as ever *)
  assert (m > 0).
  rewrite def_m; apply div_positive; auto.
  rewrite <- Z.mod_divide; [| omega].
  rewrite Zminus_mod, (Zmult_mod a _ _), (Zmult_mod b _ _).
  repeat rewrite descent_modulus_equiv_a_mod_m; auto.
  repeat rewrite <- Zmult_mod.
  repeat rewrite <- Zminus_mod.
  rewrite Z.mul_comm.
  rewrite Z.sub_diag.
  rewrite Zmod_0_l; reflexivity.
Qed.

Lemma add_div_distr: forall a b c,
    a <> 0 -> (a | b) -> (a | c) -> (b + c) / a = b / a + c / a.
Proof.
  intros a b c a_not_0 a_div_b a_div_c.
  destruct a_div_b as [k def_k].
  destruct a_div_c as [j def_j].
  rewrite def_k, def_j.
  replace (k * a + j * a) with ((k + j) * a) by ring.
  repeat rewrite Z_div_mult_full; auto.
Qed.

Lemma descent_mult_key_lemma_sublemma: forall t0 t1 m a,
    m <> 0 ->
    (m | t0) ->
    (m | t1) ->
    (t0 + t1 = m * a) -> (t0 / m + (t1 / m) = a).
Proof.
  intros t0 t1 m a m_not_0 m_div_t0 m_div_t1.
  rewrite (div_swap_l m (t0 + t1) a); auto.
  rewrite add_div_distr; auto.
  apply Z.divide_add_r; auto.
Qed.

Lemma square_div_rearrange: forall a b, b <> 0 -> (b | a) -> a * a / (b * b) = (a / b) * (a / b).
Proof.
  intros a b b_not_0 b_div_a.
  destruct b_div_a.
  rewrite H.
  replace (x * b * (x * b)) with (x * x * (b * b)) by ring.
  repeat rewrite Z_div_mult_full; auto.
  apply Z.neq_mul_0; auto.
Qed.

Lemma descent_mult_key_lemma: forall t0 t1 m a,
    m <> 0 ->
    (m | t0) ->
    (m | t1) ->
    (t0 * t0 + t1 * t1 = m * m * a) -> (t0 / m * (t0 / m) + t1 / m * (t1 / m) = a).
Proof.
  intros t0 t1 m a m_not_0 m_div_t0 m_div_t1.
  assert (m * m <> 0).
  apply Z.neq_mul_0; auto.
  rewrite (div_swap_l (m * m) (t0 * t0 + t1 * t1) a); auto.
  rewrite add_div_distr; auto.
  repeat rewrite square_div_rearrange; auto.
  - destruct m_div_t0 as [k def_k]; exists (k * k); rewrite def_k; ring.
  - destruct m_div_t1 as [j def_j]; exists (j * j); rewrite def_j; ring.
  - destruct m_div_t0 as [k def_k].
    destruct m_div_t1 as [j def_j].
    rewrite def_k, def_j.
    exists (k * k + j * j).
    ring.
Qed.

Theorem descent_mult: forall a b q N,
    q > 0 -> N > 0 -> N = (a * a + b * b) -> (q | N) ->
    forall k r s,
      (k, r, s) = descent a b q ->
      k * q = r * r + s * s.
Proof.
  intros a b q N.
  intros q_gt_0 N_gt_0 def_N q_div_N.
  intros k r s descent_def.
  unfold descent in descent_def.
  rewrite <- def_N in descent_def.
  remember (N / q) as m.
  assert (m > 0) as m_gt_0.
  rewrite Heqm; apply div_positive; auto.
  destruct (Z.eq_dec m 1); inversion descent_def.
  - destruct q_div_N as [x def_N_with_q].
    rewrite Z.mul_1_l, <- def_N, def_N_with_q.
    rewrite e, def_N_with_q in Heqm.
    rewrite Z_div_mult_full in Heqm; [auto | omega].
    symmetry in Heqm.
    rewrite Heqm, Z.mul_1_l; reflexivity.
  - remember (descent_modulus a m) as u.
    remember (descent_modulus b m) as v.
    remember (descent_div_sum a b q N m q_gt_0 N_gt_0 def_N Heqm q_div_N) as m_div_u_v.
    destruct m_div_u_v as [x m_div_u_v].
    assert ((u * u + v * v)*(a * a + b * b) = m * m * x * q) as H.
    destruct Heqm_div_u_v.
    rewrite <- Hequ, <- Heqv in m_div_u_v.
    rewrite Z.gt_lt_iff in q_gt_0.
    destruct q_div_N as [y def_N_with_q].
    rewrite def_N_with_q, Z_div_mult_full in Heqm; [auto | omega].
    rewrite <- Heqm in def_N_with_q.
    rewrite <- def_N, m_div_u_v, def_N_with_q.
    ring.
    rewrite Z.mul_comm in H at 1.
    rewrite diophantine_identity in H.
    remember (a * u + b * v) as t0.
    remember (b * u - a * v) as t1.
    remember (descent_div_term1 a b q N m q_gt_0 N_gt_0 def_N Heqm q_div_N) as div_t0.
    remember (descent_div_term2 a b q N m q_gt_0 N_gt_0 def_N Heqm q_div_N) as div_t1.
    destruct Heqdiv_t0.
    destruct Heqdiv_t1.
    rewrite <- Hequ, <- Heqv, <- Heqt0 in div_t0.
    rewrite <- Hequ, <- Heqv, <- Heqt1 in div_t1.
    replace (m * m * x * q) with (m * m * (x * q)) in H by ring.
    apply descent_mult_key_lemma in H; [ | omega | |]; auto.
    rewrite H.
    destruct Heqm_div_u_v.
    rewrite <- Hequ, <- Heqv in m_div_u_v.
    rewrite (Z.mul_comm x m) in m_div_u_v.
    apply div_swap_l in m_div_u_v; [ | omega | rewrite Hequ, Heqv; apply (descent_div_sum a b q N m)]; auto.
    rewrite m_div_u_v; reflexivity.
Qed.

Compute (descent 557 55 12049).
Compute (descent 242 41 12049).

Fixpoint prime_sum_of_squares_helper a b p (n: nat) :=
  match n with
  | S m => match descent a b p with
             (k, u, v) => if Z.eq_dec k 1 then
                            (u, v)
                          else
                            prime_sum_of_squares_helper u v p m
           end
  | zero => (0, 0)
  end.

Definition prime_sum_of_squares a b p :=
  match prime_sum_of_squares_helper a b p (Z.to_nat (a * a + b * b + 1))
  with (u, v) => (Z.abs u, Z.abs v)
  end.

Lemma prime_sum_of_squares_helper_works: forall n a b p u v,
    prime p ->
    p > 0 ->
    a * a + b * b > 0 ->
    a * a + b * b < p * p ->
    (p | a*a + b*b) ->
    Nat.lt (Z.to_nat (a * a + b * b)) n ->
    (u, v) = prime_sum_of_squares_helper a b p n ->
    u * u + v * v = p.
Proof.
  induction n;
    intros a b p u v p_prime p_gt_0 args_gt_0 args_lt_p_sq p_div_a_square_plus_b_square n_bound;
     unfold prime_sum_of_squares_helper; intros def_u_v.
  contradict n_bound; unfold Nat.lt; omega.
  fold prime_sum_of_squares_helper in def_u_v.
  remember (descent a b p) as c'.
  destruct c' as [[k u'] v'].
  assert ((k, u', v') = descent a b p) as Heqd' by assumption.
  apply (descent_mult a b p (a * a + b * b)) in Heqc'; auto.
  apply (descent_smaller a b p (a * a + b * b) ((a * a + b * b) / p)) in Heqd'; auto.
  destruct (Z.eq_dec k 1); inversion def_u_v.
  - rewrite <- Heqc', e, Z.mul_1_l; reflexivity.
  - assert (u' * u' + v' * v' > 0) as result_gt_0.
    destruct Heqd' as [k_eq_1 | k_bounded];
      [|rewrite <- Heqc'; rewrite Z.gt_lt_iff; apply Z.mul_pos_pos]; omega.
    assert (u' * u' + v' * v' < a * a + b * b) as recursion_bounded.
    destruct Heqd'; [contradict H |]; auto.
    rewrite <- Heqc'.
    rewrite <- div_swap_lt_l in H; auto.
    rewrite Z.mul_comm; destruct H; assumption.
    apply IHn in def_u_v; [ | | | |omega | exists k; symmetry; assumption | ]; auto.
    rewrite Z2Nat.inj_lt in recursion_bounded; [| omega | omega].
    apply lt_n_Sm_le in n_bound.
    apply (lt_le_trans _ (Z.to_nat (a * a + b * b)) _); [assumption | omega].
  - rewrite <- div_swap_lt_r; auto.
Qed.

Theorem prime_sum_of_squares_works: forall a b p u v,
    prime p ->
    p > 0 ->
    a * a + b * b > 0 ->
    a * a + b * b < p * p ->
    (p | a*a + b*b) ->
    (u, v) = prime_sum_of_squares a b p ->
    u * u + v * v = p.
Proof.
  intros a b p u v p_prime p_gt_0 args_gt_0 args_lt_p_sq p_div_a_square_plus_b_square.
  unfold prime_sum_of_squares.
  intros def_u_v.
  remember (prime_sum_of_squares_helper a b p (Z.to_nat (a * a + b * b + 1))) as Q.
  destruct Q as [u' v'].
  apply (prime_sum_of_squares_helper_works (Z.to_nat (a * a + b * b + 1)) a b) in HeqQ;
    [ | | | | | | apply Z2Nat.inj_lt; omega ];
    auto.
  inversion def_u_v.
  repeat rewrite Z.abs_square; assumption.
Qed.


Require Import Ensembles.
Require Import Coq.Lists.List.
Require Import ListExt.
Require Import folProof.
Require Import folProp.
Require Vector.
Require Import Peano_dec.
Require Import misc.
Require Import Arith.

Section Model_Theory.

Variable L : Language.

Fixpoint naryFunc (A : Set) (n : nat) {struct n} : Set :=
  match n with
  | O => A
  | S m => A -> naryFunc A m
  end.

Fixpoint naryRel (A : Set) (n : nat) {struct n} : Type :=
  match n with
  | O => Prop
  | S m => A -> naryRel A m
  end.

Record Model : Type := model
  {U : Set;
   func : forall f : Functions L, naryFunc U (arityF L f);
   rel : forall r : Relations L, naryRel U (arityR L r)}.

Variable M : Model.

Fixpoint interpTerm (value : nat -> U M) (t : Term L) {struct t} :
 U M :=
  match t with
  | var v => value v
  | apply f ts => interpTerms _ (func M f) value ts
  end

 with interpTerms (m : nat) (f : naryFunc (U M) m)
 (value : nat -> U M) (ts : Terms L m) {struct ts} :
 U M :=
  match ts in (Terms _ n) return (naryFunc (U M) n -> U M) with
  | Tnil => fun f => f
  | Tcons m t ts => fun f => interpTerms m (f (interpTerm value t)) value ts
  end f.

Fixpoint interpRels (m : nat) (r : naryRel (U M) m)
 (value : nat -> U M) (ts : Terms L m) {struct ts} : Prop :=
  match ts in (Terms _ n) return (naryRel (U M) n -> Prop) with
  | Tnil => fun r => r
  | Tcons m t ts => fun r => interpRels m (r (interpTerm value t)) value ts
  end r.

Definition updateValue (value : nat -> U M) (n : nat)
  (v : U M) (x : nat) : U M :=
  match eq_nat_dec n x with
  | left _ => v
  | right _ => value x
  end.

Fixpoint interpFormula (value : nat -> U M) (f : Formula L) {struct f} :
 Prop :=
  match f with
  | equal t s => interpTerm value t = interpTerm value s
  | atomic r ts => interpRels _ (rel M r) value ts
  | impH A B => interpFormula value A -> interpFormula value B
  | notH A => interpFormula value A -> False
  | forallH v A => forall x : U M, interpFormula (updateValue value v x) A
  end.

Lemma freeVarInterpTerm (v1 v2 : nat -> U M) (t : Term L):
 (forall x : nat, In x (freeVarTerm L t) -> v1 x = v2 x) ->
 interpTerm v1 t = interpTerm v2 t.
Proof.
  elim t using  Term_Terms_ind with
    (P0 := fun (n : nat) (ts : Terms L n) =>
             forall f : naryFunc (U M) n,
               (forall x : nat, In x (freeVarTerms L n ts) -> v1 x = v2 x) ->
               interpTerms n f v1 ts = interpTerms n f v2 ts);
    simpl.
  - intros n H; apply H; left; auto.
  - intros f t0 H H0; apply H.
    intros x H1; apply H0, H1.
  - reflexivity.
  - intros n t0 H t1 H0 f H1.
    rewrite H.
    apply H0.
    intros x H2; apply H1.
    + unfold freeVarTerms; apply in_or_app.
      right; apply H2.
    + intros x H2; apply H1.
      unfold freeVarTerms; apply in_or_app; left.
      apply H2.
Qed.

Lemma freeVarInterpRel (v1 v2 : nat -> U M) (n : nat)
  (ts : Terms L n) (r : naryRel (U M) n):
  (forall x : nat, In x (freeVarTerms L n ts) -> v1 x = v2 x) ->
  interpRels n r v1 ts -> interpRels n r v2 ts.
Proof.
  intros H; induction ts as [| n t ts Hrects]; simpl in |- *.
  - auto.
  - rewrite (freeVarInterpTerm v1 v2).
    + apply Hrects.
      intros x H0; apply H.
      unfold freeVarTerms; apply in_or_app; right; apply H0.
    + intros x H0; apply H.
      unfold freeVarTerms; apply in_or_app; left; apply H0.
Qed.

Lemma freeVarInterpFormula (v1 v2 : nat -> U M) (g : Formula L):
 (forall x : nat, In x (freeVarFormula L g) -> v1 x = v2 x) ->
 interpFormula v1 g -> interpFormula v2 g.
Proof.
  revert v1 v2.
  induction g as [t t0| r t| g1 Hrecg1 g0 Hrecg0| g Hrecg| n g Hrecg];
    simpl in |- *; intros v1 v2 H.
  - repeat rewrite (freeVarInterpTerm v1 v2).
    + auto.
    + intros x H0; apply H.
      simpl; auto with datatypes.
    + intros x H0; apply H.
      simpl; auto with datatypes.
  - intros H0; apply (freeVarInterpRel v1 v2).
    + apply H.
    + apply H0.
  - assert (H0: interpFormula v2 g1 -> interpFormula v1 g1).
    { apply Hrecg1.
      intros x H0; symmetry; apply H.
      simpl; auto with datatypes.
    }
    assert (H1: interpFormula v1 g0 -> interpFormula v2 g0).
    { apply Hrecg0.
      intros x H1; apply H; simpl; auto with datatypes.
    }
    tauto.
  - intros H0 H1; apply H0.
    apply Hrecg with v2.
    intros x H2; symmetry; auto.
    assumption.
  - intros H0 x; apply Hrecg with (updateValue v1 n x).
    + intros x0 H1; unfold updateValue; induction (eq_nat_dec n x0).
      * reflexivity.
      * apply H.
        apply in_in_remove; auto.
    + auto.
Qed.

Lemma subInterpTerm (value : nat -> U M) (t : Term L) (v : nat) (s : Term L):
 interpTerm (updateValue value v (interpTerm value s)) t =
 interpTerm value (substituteTerm L t v s).
Proof.
  elim t using  Term_Terms_ind  with
    (P0 := fun (n : nat) (ts : Terms L n) =>
             forall f : naryFunc (U M) n,
               interpTerms n f (updateValue value v (interpTerm value s)) ts =
                 interpTerms n f value (substituteTerms L n ts v s));
    simpl.
  - intro n; unfold updateValue; induction (eq_nat_dec v n); reflexivity.
  - intros f t0 H; rewrite H.
    + reflexivity.
  - reflexivity.
  - intros n t0 H t1 H0 f; rewrite H; apply H0.
Qed.

Lemma subInterpRel (value : nat -> U M) (n : nat) (ts : Terms L n)
  (v : nat) (s : Term L) (r : naryRel (U M) n):
  interpRels n r (updateValue value v (interpTerm value s)) ts <->
    interpRels n r value (substituteTerms L n ts v s).
Proof.
  induction ts as [| n t ts Hrects].
  - simpl; tauto.
  - simpl; rewrite <- subInterpTerm; apply Hrects.
Qed.

Lemma subInterpFormula :
 forall (value : nat -> U M) (f : Formula L) (v : nat) (s : Term L),
 interpFormula (updateValue value v (interpTerm value s)) f <->
 interpFormula value (substituteFormula L f v s).
Proof.
  intros value f; revert value.
  elim f using Formula_depth_ind2; simpl.
  - intros t t0 value v s; repeat rewrite subInterpTerm.
    tauto.
  - intros r t value v s; apply subInterpRel.
  - intros f0 H f1 H0 value v s; rewrite (subFormulaImp L).
    simpl;
    assert
      (H1: interpFormula (updateValue value v (interpTerm value s)) f1 <->
         interpFormula value (substituteFormula L f1 v s)) by auto.
    assert
      (H2: interpFormula (updateValue value v (interpTerm value s)) f0 <->
         interpFormula value (substituteFormula L f0 v s)) by auto.
    tauto.
  - intros f0 H value v s; rewrite (subFormulaNot L).
    simpl in |- *.
    assert
      (interpFormula (updateValue value v (interpTerm value s)) f0 <->
         interpFormula value (substituteFormula L f0 v s)).
    auto.
    tauto.
  - intros v a H value v0 s; rewrite (subFormulaForall L).
    induction (eq_nat_dec v v0) as [a0 | b].
    + rewrite a0.
    simpl in |- *.
    unfold updateValue in |- *.
    split.
      *  intros H0 x;  apply freeVarInterpFormula with
           (fun x0 : nat =>
              match eq_nat_dec v0 x0 with
              | left _ => x
              | right _ =>
                  match eq_nat_dec v0 x0 with
                  | left _ => interpTerm value s
                  | right _ => value x0
                  end
              end).
         -- intros x0 H1; induction (eq_nat_dec v0 x0); reflexivity.
         -- auto.
      * intros H0 x; apply
          freeVarInterpFormula
          with
          (fun x0 : nat =>
             match eq_nat_dec v0 x0 with
             | left _ => x
             | right _ => value x0
             end).
        -- intros x0 H1; induction (eq_nat_dec v0 x0); reflexivity.
        --  auto.
    + induction (In_dec eq_nat_dec v (freeVarTerm L s)) as [a0 | b0].
      * simpl;
        set (nv := newVar (v0 :: freeVarTerm L s ++ freeVarFormula L a)) in *.
        assert (~ In nv (v0 :: freeVarTerm L s ++ freeVarFormula L a)).
        { unfold nv in |- *.
          apply newVar1. }
        assert
              (forall (x : U M) (x0 : nat),
                  In x0 (freeVarFormula L a) ->
                  updateValue (updateValue value v0 (interpTerm value s)) v x x0 =
                    updateValue
                      (updateValue (updateValue value nv x) v0
                         (interpTerm (updateValue value nv x) s)) v
                      (interpTerm
                         (updateValue (updateValue value nv x) v0
                            (interpTerm (updateValue value nv x) s))
                         (var nv)) x0).
    { intros x x0 H1; unfold updateValue in |- *; simpl in |- *.
      induction (eq_nat_dec v x0) as [a1 | ?].
      - induction (eq_nat_dec v0 nv) as [a2 | b0].
        + elim H0.
          rewrite a2.
          simpl in |- *.
          auto.
        + induction (eq_nat_dec nv nv) as [a2 | b1].
          * reflexivity.
          * elim b1; reflexivity.
      - induction (eq_nat_dec v0 x0) as [a1 | b1].
        + apply freeVarInterpTerm.
          intros x1 H2; induction (eq_nat_dec nv x1).
          * elim H0.
            rewrite a2.
            simpl in |- *.
            auto with datatypes.
          * reflexivity.
        + induction (eq_nat_dec nv x0) as [a1 | ?].
          * elim H0.
            rewrite a1.
            auto with datatypes.
          * reflexivity.
    }
    assert
      (H2: (forall x : U M,
           interpFormula
             (updateValue
                (updateValue (updateValue value nv x) v0
                   (interpTerm (updateValue value nv x) s)) v
                (interpTerm
                   (updateValue (updateValue value nv x) v0
                      (interpTerm (updateValue value nv x) s))
                   (var nv))) a) <->
         (forall x : U M,
             interpFormula (updateValue value nv x)
               (substituteFormula L (substituteFormula L a v (var nv)) v0 s))).
    { split.
      - assert
          (H2: forall b : Formula L,
              lt_depth L b (forallH v a) ->
              forall (value : nat -> U M) (v : nat) (s : Term L),
                interpFormula (updateValue value v (interpTerm value s)) b ->
                interpFormula value (substituteFormula L b v s)).
        { intros b0 H2 value0 v1 s0 H3;
          induction (H b0 H2 value0 v1 s0); auto.
        }
        intros H3 x; apply H2.
        + eapply eqDepth.
          * symmetry; apply subFormulaDepth.
          * apply depthForall.
        + apply H2.
          * apply depthForall.
          * apply H3.
      - intros H2 x.
        assert
          (H3: forall b : Formula L,
              lt_depth L b (allH v, a)%fol ->
              forall (value : nat -> U M) (v : nat) (s : Term L),
                interpFormula value (substituteFormula L b v s) ->
                interpFormula (updateValue value v (interpTerm value s)) b)
          by (intros; induction (H b0 H3 value0 v1 s0); auto).
        clear H; apply H3.
        + apply depthForall.
        + apply H3.
          * eapply eqDepth.
            -- symmetry; apply subFormulaDepth.
            -- apply depthForall.
          * auto.
    }
    assert
      (H3: (forall x : U M,
           interpFormula
             (updateValue (updateValue value v0 (interpTerm value s)) v x) a) <->
         (forall x : U M,
             interpFormula
               (updateValue
                  (updateValue (updateValue value nv x) v0
                     (interpTerm (updateValue value nv x) s)) v
                  (interpTerm
                     (updateValue (updateValue value nv x) v0
                        (interpTerm (updateValue value nv x) s))
                     (var nv))) a)).
    { split.
      - intros H3 x;
        apply
          freeVarInterpFormula
          with (updateValue (updateValue value v0 (interpTerm value s)) v x).
        auto.
        auto.
      - intros H3 x.
        apply
          freeVarInterpFormula
          with
          (updateValue
             (updateValue (updateValue value nv x) v0
                (interpTerm (updateValue value nv x) s)) v
             (interpTerm
                (updateValue (updateValue value nv x) v0
                   (interpTerm (updateValue value nv x) s))
                (var nv))).
        + intros x0 H4;
          symmetry  in |- *.
          auto.
        + auto.
    }
    tauto.
      * simpl in |- *.
        assert
          (forall (x : U M) (x0 : nat),
              In x0 (freeVarFormula L a) ->
              updateValue (updateValue value v0 (interpTerm value s)) v x x0 =
                updateValue (updateValue value v x) v0
                  (interpTerm (updateValue value v x) s) x0).
        { intros x x0 H0; unfold updateValue;
          induction (eq_nat_dec v x0) as [a0 | b1].
          - induction (eq_nat_dec v0 x0) as [a1 | ?].
            + elim b.
              transitivity x0; auto.
            +  reflexivity.
          - induction (eq_nat_dec v0 x0) as [a0 | ?].
            + apply freeVarInterpTerm.
              intros x1 H1; induction (eq_nat_dec v x1).
              * elim b0.
                rewrite a1.
                auto.
              * reflexivity.
            + reflexivity.
        }
        split.
        --  intros H1 x;
        assert
          (H2: forall b : Formula L,
              lt_depth L b (forallH v a) ->
              forall (value : nat -> U M) (v : nat) (s : Term L),
                interpFormula (updateValue value v (interpTerm value s)) b ->
                interpFormula value (substituteFormula L b v s)).
        { intros b1 H2 value0 v1 s0 H3; induction (H b1 H2 value0 v1 s0); auto. }
        apply H2.
        ++ apply depthForall.
        ++ apply freeVarInterpFormula with
             (updateValue (updateValue value v0 (interpTerm value s)) v x).
           ** apply (H0 x).
           ** apply H1.
    -- assert
        (forall b : Formula L,
            lt_depth L b (forallH v a) ->
            forall (value : nat -> U M) (v : nat) (s : Term L),
              interpFormula value (substituteFormula L b v s) ->
              interpFormula (updateValue value v (interpTerm value s)) b).
       { intros b1 H1 value0 v1 s0 H2; induction (H b1 H1 value0 v1 s0); auto. }
       intros H2 x;
       apply
         freeVarInterpFormula
         with
         (updateValue (updateValue value v x) v0
            (interpTerm (updateValue value v x) s)).
       ++ intros; symmetry  in |- *; auto.
       ++ apply H1.
          ** apply depthForall.
          ** auto.
Qed.

Lemma subInterpFormula1 (value : nat -> U M) (f : Formula L) (v : nat) (s : Term L):
 interpFormula (updateValue value v (interpTerm value s)) f ->
 interpFormula value (substituteFormula L f v s).
Proof.
  induction (subInterpFormula value f v s); auto.
Qed.

Lemma subInterpFormula2 (value : nat -> U M) (f : Formula L) (v : nat) (s : Term L):
  interpFormula value (substituteFormula L f v s) ->
  interpFormula (updateValue value v (interpTerm value s)) f.
Proof.
  induction (subInterpFormula value f v s); auto.
Qed.

Fixpoint nnHelp (f : Formula L) : Formula L :=
  match f with
  | equal t s => equal t s
  | atomic r ts => atomic r ts
  | impH A B => impH (nnHelp A) (nnHelp B)
  | notH A => notH (nnHelp A)
  | forallH v A => (allH v, ~ ~ nnHelp A)%fol
  end.

Definition nnTranslate (f : Formula L) : Formula L :=
  notH (notH (nnHelp f)).

Lemma freeVarNNHelp (f : Formula L):  freeVarFormula L f = freeVarFormula L (nnHelp f).
Proof.
  induction f as [t t0| r t| f1 Hrecf1 f0 Hrecf0| f Hrecf| n f Hrecf];
    try reflexivity.
  - simpl; now rewrite Hrecf1, Hrecf0.
  - simpl; assumption.
  - simpl; now rewrite Hrecf.
Qed.

Lemma subNNHelp :
 forall (f : Formula L) (v : nat) (s : Term L),
 substituteFormula L (nnHelp f) v s = nnHelp (substituteFormula L f v s).
Proof.
  intro f; elim f using Formula_depth_ind2; intros; try reflexivity.
  - simpl; rewrite subFormulaImp, H, H0.
    now rewrite subFormulaImp.
  - simpl; rewrite subFormulaNot, H, subFormulaNot; easy.
  - simpl; do 2 rewrite subFormulaForall.
    simpl; induction (eq_nat_dec v v0).
    + simpl; reflexivity.
    + induction (In_dec eq_nat_dec v (freeVarTerm L s)) as [? | ?].
      * simpl; repeat rewrite subFormulaNot; repeat rewrite H.
        -- now rewrite <- freeVarNNHelp.
        -- eapply eqDepth.
           ++ symmetry; apply subFormulaDepth.
           ++ apply depthForall.
        -- apply depthForall.
      * repeat rewrite subFormulaNot.
        rewrite H; simpl.
        -- reflexivity.
        -- apply depthForall.
Qed.

Section Consistent_Theory.

  Variable T : System L.

  Fixpoint interpTermsVector (value : nat -> U M) (n : nat)
    (ts : Terms L n) {struct ts} : Vector.t (U M) n :=
    match ts in (Terms _ n) return (Vector.t (U M) n) with
    | Tnil => Vector.nil (U M)
    | Tcons m t ts =>
        Vector.cons (U M) (interpTerm value t) m (interpTermsVector value m ts)
    end.

Lemma preserveValue (value : nat -> U M):
 (forall f : Formula L,
  mem _ T f -> interpFormula value (nnTranslate f)) ->
 forall g : Formula L, SysPrf L T g -> interpFormula value (nnTranslate g).
Proof.
  intros H g H0.
  induction H0 as (x, H0).
  induction H0 as (x0, H0).
  cut (forall g : Formula L, In g x -> interpFormula value (nnTranslate g)).
  - clear H H0; revert value.
    induction x0
      as
      [A|
        Axm1 Axm2 A B x0_1 Hrecx0_1 x0_0 Hrecx0_0|
        Axm A v n x0 Hrecx0|
        A B|
        A B C|
        A B|
        A v t|
        A v n|
        A B v|
      |
      |
      |
        R|
        f]; intros; try (simpl in |- *; tauto).
    + apply H.
      auto with datatypes.
    + assert (H0: interpFormula value (nnTranslate A))
      by auto with datatypes.
      assert (H1: interpFormula value (nnTranslate (A -> B)%fol))
        by auto with datatypes.
      clear Hrecx0_1 Hrecx0_0.
      simpl in H0, H1.
      simpl in |- *.
      tauto.
    + simpl in |- *.
      intros.
      apply H0.
      clear H0.
      intros.
      simpl in Hrecx0.
      apply (Hrecx0 (updateValue value v x)).
      * intros.
        simpl in H.
        eapply H.
        -- apply H1.
        -- intros.
           apply H2.
           apply freeVarInterpFormula with value.
           ++ intros.
              rewrite <- freeVarNNHelp in H4.
              unfold updateValue in |- *.
              induction (eq_nat_dec v x1).
              ** elim n.
                 rewrite a.
                 clear n x0 Hrecx0 H.
                 induction Axm as [| a0 Axm HrecAxm].
                 apply H1.
                 simpl in |- *.
                 simpl in H1.
                 induction H1 as [H| H].
                 rewrite H.
                 auto with datatypes.
                 auto with datatypes.
              ** reflexivity.
           ++ assumption.
      * assumption.
    + simpl in |- *.
      intros.
      apply H0.
      intros.
      elim H1 with (interpTerm value t).
      intros.
      apply H0.
      intros.
      rewrite <- subNNHelp.
      apply subInterpFormula1.
      auto.
    + simpl in |- *.
      intros.
      apply H0.
      intros.
      apply H2.
      apply freeVarInterpFormula with value.
      * intros.
        unfold updateValue in |- *.
        induction (eq_nat_dec v x0).
        -- elim n.
           rewrite a.
           rewrite freeVarNNHelp.
           assumption.
        -- reflexivity.
      * assumption.
    + simpl in |- *.
      intros.
      apply H0.
      clear H0.
      intros.
      apply H0 with x.
      intros.
      apply H1 with x.
      auto.
    + simpl in |- *.
      auto.
    + simpl in |- *.
      intros.
      apply H0.
      intros.
      transitivity (value 1); auto.
    + simpl in |- *.
      intros.
      apply H0.
      clear H H0.
      unfold AxmEq4 in |- *.
      cut
        (forall a b : Terms L (arityR L R),
            interpTermsVector value _ a =
              interpTermsVector value _ b ->
            interpFormula value
              (nnHelp (iffH (atomic R a) (atomic R b)))).
      * assert
          (H: forall A,
              (forall a b : Terms L (arityR L R),
                  interpTermsVector value (arityR L R) a =
                    interpTermsVector value (arityR L R) b ->
                  interpFormula value (nnHelp (A a b))) ->
              interpFormula value
                (nnHelp
                   (nat_rec (fun _ : nat => Formula L)
                      (prod_rec
                         (fun
                             _ : Terms L (arityR L  R) *
                                   Terms L (arityR L R) =>
                             Formula L)
                         (fun a b : Terms L (arityR L R) => A a b)
                         (nVars L (arityR L R)))
                      (fun (n : nat) (Hrecn : Formula L) =>
                         (v_ (n + n)%nat = v_ (S (n+n))%nat -> Hrecn)%fol)

                      (arityR L R)))).
        { generalize (arityR L R).
          simple induction n.
          - simpl; intros A H; now apply H.
          - intros n0 H A H0; simpl; induction (nVars L n0).
            simpl in H |- *.
            intro H1; apply
                        (H
                           (fun x y : Terms L n0 =>
                              A (Tcons (var (n0 + n0)) x)
                                (Tcons (var (S (n0 + n0))) y))).
            intros a0 b0 H2; apply H0.
            simpl; rewrite H1.
            now rewrite H2.
        }
        apply (H (fun a b => iffH (atomic R a) (atomic R b))).
      * simpl; generalize (rel M R).
        generalize (arityR L R).
        intros n n0 a b H H0.
        induction a as [| n t a Hreca].
        -- assert (H1: b = Tnil) by (symmetry; apply nilTerms).
           rewrite H1 in H0; auto.
        -- induction (consTerms L n b) as [x p].
           induction x as (a0, b0).
           simpl in p.
           rewrite <- p in H0.
           rewrite <- p in H.
           simpl in H.
           inversion H.
           simpl in H0.
           rewrite H2 in H0.
           apply (Hreca (n0 (interpTerm value a0)) b0).
           ++ apply (inj_right_pair2 _ eq_nat_dec _ _ _ _ H3).
           ++ auto.
    + simpl in |- *.
      intros H0; apply H0.
      clear H H0.
      unfold AxmEq5 in |- *.
      cut
        (forall a b : Terms L (arityF L f),
            interpTermsVector value _ a = interpTermsVector value _ b ->
            interpFormula value (nnHelp (apply f a = apply f b)%fol)).
      * assert
          (H: forall A,
              (forall a b : Terms L (arityF L f),
                  interpTermsVector value (arityF L f) a =
                    interpTermsVector value (arityF L f) b ->
                  interpFormula value (nnHelp (A a b))) ->
              interpFormula value
                (nnHelp
                   (nat_rec (fun _ : nat => Formula L)
                      (prod_rec
                         (fun _ : Terms L (arityF L f) * Terms L (arityF L f)  => Formula L)
                         (fun a b : Terms L (arityF L f) => A a b)
                         (nVars L (arityF L f)))
                      (fun (n : nat) (Hrecn : Formula L) =>
                         (v_ (n + n)%nat = v_ (S (n + n))%nat -> Hrecn)%fol)
                           (arityF L f)))).
        { generalize (arityF L f).
          simple induction n.
          - simpl; intros A H; auto.
          - intros n0 H A H0; simpl.
            induction (nVars L n0).
            simpl in H |- *.
            intros H1;
              apply  (H
                        (fun x y : Terms L n0 =>
                           A (Tcons (var (n0 + n0)) x)
                             (Tcons (var (S (n0 + n0))) y))).
            intros a0 b0 H2; apply H0.
            simpl; rewrite H1.
            now rewrite H2.
        }
        apply (H (fun a b => equal (apply f a) (apply f b))).
      * simpl; generalize (func M f).
        generalize (arityF L f).
        intros n n0 a b H.
        induction a as [| n t a Hreca].
        -- assert (H0: b = Tnil) by ( symmetry; apply nilTerms).
           now rewrite H0.
        -- induction (consTerms L n b) as [x p];
           induction x as (a0, b0).
           simpl in p; rewrite <- p; rewrite <- p in H.
           simpl in H.
           inversion H.
           simpl; rewrite H1.
           apply Hreca.
           apply (inj_right_pair2 _ eq_nat_dec _ _ _ _ H2).
  - auto.
Qed.

Lemma ModelConsistent (value : nat -> U M):
  (forall f : Formula L,
      mem _ T f -> interpFormula value (nnTranslate f)) ->
  Consistent L T.
Proof.
  intros H; unfold Consistent; exists (v_ O <> v_ 0)%fol.
  intros H0; assert (H1: interpFormula value (nnTranslate (v_ O <> v_ 0)%fol)).
  { apply preserveValue.
    assumption.
    auto.
  }
  apply H1; simpl; auto.
Qed.

End Consistent_Theory.

End Model_Theory.


(** This file generates unsatisfiable formulas for problems
   commonly used to benchmark SAT solving procedures. *)

Require Import List.
Fixpoint introduce_vars
  (P : list Prop -> Prop) (acc : list Prop) (n : nat) :=
  match n with
    | 0 => P (rev acc)
    | S m => forall (x : Prop), introduce_vars P (x::acc) m
  end.
Eval vm_compute in introduce_vars (fun l => l = l) nil 12.

(** * Pigeon hole formulas

   The pigeon hole formula with [n] holes, [hole(n)], states that
   there is no way to put [n+1] pigeons in [n] different holes such
   that no two pigeons occupy the same hole. In its valid version,
   it states that if [n+1] pigeons are in [n] different holes, at
   least one hole contains two of them pigeons.
*)

Section HoleWithListVars.
  Variable vars : list Prop.
  Variable N : nat.

  (** We define a propositional predicate [occ i j] which denotes
     the fact that the pigeon [i] occupies the hole [j].
     *)
  Definition occ (i j : nat) : Prop :=
    nth (i * N + j) vars True.

  (** The next definition, [is_home p n] builds a formula expressing
     that the pigeon [p] is at least in one of the holes 0 to [n].
     *)
  Fixpoint is_home (p n : nat) : Prop :=
    match n with
      | O => occ p O
      | S n0 => occ p n \/ is_home p n0
    end.

  (** We can now build a conjunction expressing that all pigeons
     number 0 to [n+1] have safely found home in the holes 0 to [n].
     *)
  Fixpoint everyone_home_aux (n : nat) (p : nat) : Prop :=
    match p with
      | O => is_home O n
      | S p0 => is_home p n /\ everyone_home_aux n p0
    end.
  Definition everyone_home (n : nat) : Prop :=
    everyone_home_aux n (S n).

  (** This wraps up the first part of the pigeon hole formula. For the
     second part, we need to express that for every hole [h], there
     mustn't be two different pigeons [i] and [j] such that
     [occ i h] and [occ j h] both stand.
     We start by a quick definition for this very last part, two pigeons
     are said to be "safe" with respect to a hole if at least one of them
     is not in the hole.
     *)
  Definition safe (h : nat) (i j : nat) :=
    ~occ i h \/ ~occ j h.

  (** Given a hole [h], we need a formula that says that all possible
     pairs of pigeons are safe wrt that hole. Such a hole is called
     "sane", and for efficiency reasons, we try to express every
     pair of pigeon only once, by only adding a clause [safe h i j]
     when [i < j].
     *)
  Fixpoint sane_aux_2 (h : nat) (p p' : nat) : Prop :=
    match p' with
      | O => safe h p O
      | S p'0 => safe h p p' /\ sane_aux_2 h p p'0
    end.
  Fixpoint sane_aux (h : nat) (p : nat) : Prop :=
    match p with
      | O => True (* unused, but correct nonetheless *)
      | 1 => safe h 1 0
      | S p0 => sane_aux_2 h p p0 /\ sane_aux h p0
    end.
  Definition sane (h : nat) (n : nat) : Prop :=
    sane_aux h (S n).

  (** Finally, everyone is a happy pigeon when all holes are sane,
     because it is well known that pigeons hate living in crowded areas.
     *)
  Fixpoint everyone_happy_aux (n : nat) (h : nat) : Prop :=
    match h with
      | O => sane O n
      | S h0 => sane h n /\ everyone_happy_aux n h0
    end.
  Definition everyone_happy (n : nat) : Prop :=
    everyone_happy_aux n n.
End HoleWithListVars.
(** Now, we have everything we need to express the pigeon hole
   formulas [hole n], which is true if and only if [n+1] pigeons
   can live happily in [n] holes.
   Note that up to this point, for practical reasons, we have
   indexed pigeons and holes starting with 0. This means, for instance,
   that the formula [everyone_happy n] actually ensures the sanity
   property for [n+2] pigeons and [n+1] holes.
   [hole] compensates for that by treating 0 as a special case (which
   is of course [False] since there's no way a single pigeon will be
   happy without at least one hole to live in).
   *)
Definition hole (n : nat) : Prop :=
  match n with
    | O => False
    | S n0 =>
      introduce_vars (fun l =>
        (everyone_home l n n0 /\ everyone_happy l n n0) -> False)
      nil (S n * n)
  end.

(** A couple of examples of pigeon hole formulas for small values of [n].
   Note that the size of the formula increases in [n] squared.
*)
Section Example.
  Definition hole1 := hole 1.
  Time Eval cbv -[not] in hole1.

  Definition hole2 := hole 2.
  Time Eval cbv -[not] in hole2.

  Definition hole6 := hole 6.
  Time Eval cbv -[not] in hole6.

  Definition hole10 := hole 10.
  Time Eval cbv -[not] in hole10.
End Example.

(* (** * Pigeon hole formulas (revisited) *)

(*    We now turn to another possible definition of the pigeon hole  *)
(*    formulas, expressed in their valid flavour. The real difference *)
(*    with the previous version is that the unsatisfiable version *)
(*    was naturally expressed in CNF, whereas this one will not be *)
(*    a CNF formula. Therefore it will stress the CNF conversion  *)
(*    mechanism a little more. *)

(*    We use the same family of variables [occ i j] of course. *)
(* *) *)

(* (** The first part of the formula expresses once again the fact *)
(*    that every pigeon is in a hole, so we will reuse the [everyone_home] *)
(*    function that we defined above. *)
(*    The second part expresses that there is at least one hole with *)
(*    two pigeons in it. We start by defining this last notion, ie. the *)
(*    fact that two pigeons live in the same hole. *)
(*    *) *)
(* Definition room_mate (h : nat) (i j : nat) := *)
(*   occ i h /\ occ j h. *)

(* (** Given a particular hole [h], the next formula expresses how *)
(*    at least one pair of pigeon are room mates in this hole. *)
(*    Such a hole is said to be "crowded". *)
(*    As before, we make sure we only add each pair of pigeon once. *)
(* *) *)
(* Fixpoint crowded_aux_2 (h : nat) (p p' : nat) : Prop := *)
(*   match p' with *)
(*     | O => room_mate h p O *)
(*     | S p'0 => room_mate h p p' \/ crowded_aux_2 h p p'0 *)
(*   end. *)
(* Fixpoint crowded_aux (h : nat) (p : nat) : Prop := *)
(*   match p with *)
(*     | O => False (* unused, but correct nonetheless *) *)
(*     | 1 => room_mate h 1 0 *)
(*     | S p0 => crowded_aux_2 h p p0 \/ crowded_aux h p0 *)
(*   end. *)
(* Definition crowded (h : nat) (n : nat) : Prop := *)
(*   crowded_aux h (S n). *)

(* (** Now, we are left to define a formula stating that at least *)
(*    one hole must be crowded, which is a simple disjunction over *)
(*    all possible holes.  *)
(* *) *)
(* Fixpoint one_is_crowded_aux (n : nat) (h : nat) : Prop := *)
(*   match h with *)
(*     | O => crowded O n *)
(*     | S h0 => crowded h n \/ one_is_crowded_aux n h0 *)
(*   end. *)
(* Definition one_is_crowded (n : nat) : Prop := *)
(*   one_is_crowded_aux n n. *)

(* (** Finally, a valid formula expressing the pigeon hole problem *)
(*    is just the following implication : *)
(* *) *)
(* Definition vhole (n : nat) : Prop := *)
(*   match n with *)
(*     | O => True *)
(*     | S n0 =>  *)
(*       everyone_home n0 -> one_is_crowded n0 *)
(*   end. *)

(* (** Again, a couple of examples. *) *)
(* Section VExample. *)
(*   Definition vhole1 := vhole 1. *)
(*   Time Eval cbv -[not] in vhole1. *)

(*   Definition vhole2 := vhole 2. *)
(*   Time Eval cbv -[not] in vhole2. *)

(*   Definition vhole6 := vhole 6. *)
(*   Time Eval cbv -[not] in vhole6. *)

(*   Definition vhole10 := vhole 10. *)
(*   Time Eval cbv -[not] in vhole10. *)
(* End VExample. *)

(** * De Bruijn formula

   The De Bruijn formula with parameter [n] states that among [2n+1] boolean
   variables set in a circular list, at least two adjacent variables are
   equal.
*)
Require Import Arith.
Section WithListVars.
  Variable variables : list Prop.

  Definition x i := nth i variables True.

  (** When the parameter of the problem is [n], variables should be indexed *)
(*      modulo [2n+1], starting at 0. For that reason, we define what it means  *)
(*      for two adjacent variables to be equal and we include a special case *)
(*      for the first and last variables. *)
  Definition equals (n : nat) (i : nat) : Prop :=
    match i with
      | O => x O <-> x (n+n)
      | S i0 => x i <-> x i0
    end.

  (** Now, the formula we want is simply a big disjunction expressing that *)
(*      there must be an equivalence between [var n i] and [var n (S i)] for *)
(*      at least one [i] between 0 and [2*n].  *)
(*      *)
  Fixpoint some_are_equal (n : nat) (i : nat) :=
    match i with
      | O => equals n O
      | S i0 => equals n i \/ some_are_equal n i0
    end.
End WithListVars.
Definition de_bruijn (n : nat) : Prop :=
  introduce_vars (fun l => ~(some_are_equal l n (n+n)) -> False)
  nil (S (n+n)).

(** A couple of examples for De Bruijn formulas.  *)
(*    Unlike pigeon hole formulas, these De Bruijn formulas grow *)
(*    linearly with the parameter [n]. *)
(*    *)
Section DBExample.
  Definition deb1 := de_bruijn 1.
  Time Eval cbv -[not iff] in deb1.

  Definition deb2 := de_bruijn 2.
  Time Eval cbv -[not iff] in deb2.

  Definition deb6 := de_bruijn 6.
  Time Eval cbv -[not iff] in deb6.

  Definition deb10 := de_bruijn 10.
  Time Eval cbv -[not iff] in deb10.

  Definition deb50 := de_bruijn 50.
  Time Eval cbv -[not iff] in deb50.
End DBExample.

(* (** * De Bruijn formula (in 2-SAT CNF) *)

(*    We redefine the De Bruijn formula, this time such that the resulting *)
(*    formula in not only in CNF, but also in the 2-SAT fragment. It will *)
(*    be unsatisfiable, whereas the above formula was valid. *)
(* *) *)
(* Check x. *)
(* Inductive x (i : nat) : Prop := *)
(* | mk_x : x i. *)

(* (** Conversely to what we did above, we define what it means for two *)
(*    adjacent variables to be different. We again deal with the special  *)
(*    case for the first and last variables. *) *)
(* Definition differs (n : nat) (i : nat) : Prop := *)
(*   match i with  *)
(*     | O =>  *)
(*       let n2 := n+n in (x O \/ x n2) /\ (~x 0 \/ ~x n2) *)
(*     | S i0 => (x i \/ x i0) /\ (~x i \/ ~x i0) *)
(*   end. *)

(* (** Now, the formula we want is simply a big conjunction expressing that *)
(*    all adjacent variables must differ.  *)
(*    *) *)
(* Fixpoint all_variables_differ (n : nat) (i : nat) := *)
(*   match i with *)
(*     | O => differs n O *)
(*     | S i0 => differs n i /\ all_variables_differ n i0 *)
(*   end. *)
(* Definition ude_bruijn (n : nat) : Prop := *)
(*   all_variables_differ n (n+n). *)

(* (** The same examples for the unsatisfiable 2-SAT version *)
(*    of the De Bruijn formulas.  *)
(*    *) *)
(* Section DBExample2. *)
(*   Definition udeb1 := ude_bruijn 1. *)
(*   Time Eval cbv -[not iff] in udeb1. *)

(*   Definition udeb2 := ude_bruijn 2. *)
(*   Time Eval cbv -[not iff] in udeb2. *)

(*   Definition udeb6 := ude_bruijn 6. *)
(*   Time Eval cbv -[not iff] in udeb6. *)

(*   Definition udeb10 := ude_bruijn 10. *)
(*   Time Eval cbv -[not iff] in udeb10. *)

(*   Definition udeb50 := ude_bruijn 50. *)
(*   Time Eval cbv -[not iff] in udeb50. *)
(* End DBExample2. *)

(* (** * Associativity of equivalences  *)

(*    The formula [equivn n] has the form : *)
(*    [(a1 <-> (a2 <-> (.... an))) <-> (((a1 <-> a2) <-> ...) <-> an)] *)
(*    and is valid. *)
(* *) *)
(* Inductive a : nat -> Prop := *)
(* | mk_a : forall i, a i. *)

(* Fixpoint Ln (n : nat) := *)
(*   match n with *)
(*     | O => a 0 *)
(*     | S n0 => Ln n0 <-> a n *)
(*   end. *)
(* Fixpoint Rn (n : nat) := *)
(*   match n with *)
(*     | O => a 0 *)
(*     | S n0 => a n <-> Rn n0 *)
(*   end. *)
(* Definition equivn (n : nat) := *)
(*   Ln n <-> Rn n. *)

(* Section EquivExample. *)
(*   Definition equiv1 := equivn 1. *)
(*   Time Eval cbv -[not iff] in equiv1. *)

(*   Definition equiv2 := equivn 2. *)
(*   Time Eval cbv -[not iff] in equiv2. *)

(*   Definition equiv10 := equivn 10. *)
(*   Time Eval cbv -[not iff] in equiv10. *)

(*   Definition equiv30 := equivn 30. *)
(*   Time Eval cbv -[not iff] in equiv30. *)
(* End EquivExample. *)

(* (** * Franzen formulas  *)

(*    The Franzen formula with parameter [n] has the following form : *)
(*    [(~a0 \/ ~a1 .... \/ ~an) \/ (a0 /\ a1 /\ ... /\ an)]. *)
(*    It is valid since it means that at least one variable is false, *)
(*    or they are all true. *)
(* *) *)
(* Fixpoint one_is_false (n : nat) := *)
(*   match n with *)
(*     | O => ~a O *)
(*     | S n0 => one_is_false n0 \/ ~a n *)
(*   end. *)

(* Fixpoint all_are_true (n : nat) := *)
(*   match n with *)
(*     | O => a O *)
(*     | S n0 => all_are_true n0 /\ a n *)
(*   end. *)

(* Definition Fn (n : nat) :=  *)
(*   one_is_false n \/ all_are_true n. *)

(* Section FExample. *)
(*   Definition f1 := Fn 1. *)
(*   Time Eval cbv -[not iff] in f1. *)

(*   Definition f2 := Fn 2. *)
(*   Time Eval cbv -[not iff] in f2. *)

(*   Definition f10 := Fn 10. *)
(*   Time Eval cbv -[not iff] in f10. *)

(*   Definition f30 := Fn 30. *)
(*   Time Eval cbv -[not iff] in f30. *)
(* End FExample. *)

(* (** * Schwichtenberg formulas *) *)
(* Fixpoint ant (n : nat) := *)
(*   match n with  *)
(*     | O => True *)
(*     | S n0 => (a n -> a n -> a n0) /\ ant n0 *)
(*   end. *)
(* Definition schwicht (n : nat) : Prop := *)
(*   (a n /\ ant n) -> a 0. *)

(* Section SExample. *)
(*   Definition s1 := schwicht 1. *)
(*   Time Eval cbv -[not iff] in s1. *)

(*   Definition s2 := schwicht 2. *)
(*   Time Eval cbv -[not iff] in s2. *)

(*   Definition s10 := schwicht 10. *)
(*   Time Eval cbv -[not iff] in s10. *)

(*   Definition s30 := schwicht 30. *)
(*   Time Eval cbv -[not iff] in s30. *)
(* End SExample. *)

(* (** * Two formulas to test the sharing of subformulas *) *)
(* Definition partage := hole 3 /\ ~(hole 3). *)
(* Definition partage2 :=  *)
(*   (hole 3 <-> hole 2) \/ (hole 2 <-> hole 1) \/ (hole 1 <-> hole 3). *)


Coq < Section Resolution.

Coq < Variables P Q R : Prop.
P is assumed
Q is assumed
R is assumed

Coq < Goal ((~P \/ R) /\ (P \/ Q)) -> (Q \/ R).
1 subgoal

  P : Prop
  Q : Prop
  R : Prop
  ============================
   (~ P \/ R) /\ (P \/ Q) -> Q \/ R

Unnamed_thm < intro.
1 subgoal

  P : Prop
  Q : Prop
  R : Prop
  H : (~ P \/ R) /\ (P \/ Q)
  ============================
   Q \/ R

Unnamed_thm < elim H.
1 subgoal

  P : Prop
  Q : Prop
  R : Prop
  H : (~ P \/ R) /\ (P \/ Q)
  ============================
   ~ P \/ R -> P \/ Q -> Q \/ R

Unnamed_thm < intro.
1 subgoal

  P : Prop
  Q : Prop
  R : Prop
  H : (~ P \/ R) /\ (P \/ Q)
  H0 : ~ P \/ R
  ============================
   P \/ Q -> Q \/ R

Unnamed_thm < intro.
1 subgoal

  P : Prop
  Q : Prop
  R : Prop
  H : (~ P \/ R) /\ (P \/ Q)
  H0 : ~ P \/ R
  H1 : P \/ Q
  ============================
   Q \/ R

Unnamed_thm < destruct H1.
2 subgoals

  P : Prop
  Q : Prop
  R : Prop
  H : (~ P \/ R) /\ (P \/ Q)
  H0 : ~ P \/ R
  H1 : P
  ============================
   Q \/ R

subgoal 2 is:
 Q \/ R

Unnamed_thm < right.
2 subgoals

  P : Prop
  Q : Prop
  R : Prop
  H : (~ P \/ R) /\ (P \/ Q)
  H0 : ~ P \/ R
  H1 : P
  ============================
   R

subgoal 2 is:
 Q \/ R

Unnamed_thm < auto.
2 subgoals

  P : Prop
  Q : Prop
  R : Prop
  H : (~ P \/ R) /\ (P \/ Q)
  H0 : ~ P \/ R
  H1 : P
  ============================
   R

subgoal 2 is:
 Q \/ R

Unnamed_thm < destruct H.
2 subgoals

  P : Prop
  Q : Prop
  R : Prop
  H : ~ P \/ R
  H2 : P \/ Q
  H0 : ~ P \/ R
  H1 : P
  ============================
   R

subgoal 2 is:
 Q \/ R

Unnamed_thm < destruct H as [H3|H4].
3 subgoals

  P : Prop
  Q : Prop
  R : Prop
  H3 : ~ P
  H2 : P \/ Q
  H0 : ~ P \/ R
  H1 : P
  ============================
   R

subgoal 2 is:
 R
subgoal 3 is:
 Q \/ R

Unnamed_thm < auto.
3 subgoals

  P : Prop
  Q : Prop
  R : Prop
  H3 : ~ P
  H2 : P \/ Q
  H0 : ~ P \/ R
  H1 : P
  ============================
   R

subgoal 2 is:
 R
subgoal 3 is:
 Q \/ R

Unnamed_thm < tauto.
2 subgoals

  P : Prop
  Q : Prop
  R : Prop
  H4 : R
  H2 : P \/ Q
  H0 : ~ P \/ R
  H1 : P
  ============================
   R

subgoal 2 is:
 Q \/ R

Unnamed_thm < exact H4.
1 subgoal

  P : Prop
  Q : Prop
  R : Prop
  H : (~ P \/ R) /\ (P \/ Q)
  H0 : ~ P \/ R
  H1 : Q
  ============================
   Q \/ R

Unnamed_thm < left.
1 subgoal

  P : Prop
  Q : Prop
  R : Prop
  H : (~ P \/ R) /\ (P \/ Q)
  H0 : ~ P \/ R
  H1 : Q
  ============================
   Q

Unnamed_thm < exact H1.
Proof completed.

Unnamed_thm < Qed.
intro.
elim H.
intro.
intro.
destruct H1.
 right.
 auto.
 destruct H.
 destruct H as [H3| H4].
  auto.
  tauto.

  exact H4.

 left.
 exact H1.

Unnamed_thm is defined