Require Import Coq.ZArith.ZArith Coq.micromega.Lia Coq.ZArith.Znumtheory Coq.ZArith.Zpow_facts.
Require Import Crypto.Util.ZUtil.Hints.Core.
Require Import Crypto.Util.ZUtil.ZSimplify.Core.
Require Import Crypto.Util.ZUtil.Tactics.DivModToQuotRem.
Require Import Crypto.Util.ZUtil.Tactics.LtbToLt.
Require Import Crypto.Util.ZUtil.Tactics.ReplaceNegWithPos.
Require Import Crypto.Util.Tactics.BreakMatch.
Require Import Crypto.Util.Tactics.DestructHead.
Local Open Scope Z_scope.

Module Z.
  Lemma elim_mod : forall a b m, a = b -> a mod m = b mod m.
  Proof. intros; subst; auto. Qed.
  Hint Resolve elim_mod : zarith.

  Lemma mod_add_full : forall a b c, (a + b * c) mod c = a mod c.
  Proof. intros a b c; destruct (Z_zerop c); try subst; autorewrite with zsimplify; reflexivity. Qed.
  Hint Rewrite mod_add_full : zsimplify.

  Lemma mod_add_l_full : forall a b c, (a * b + c) mod b = c mod b.
  Proof. intros a b c; rewrite (Z.add_comm _ c); autorewrite with zsimplify; reflexivity. Qed.
  Hint Rewrite mod_add_l_full : zsimplify.

  Lemma mod_add'_full : forall a b c, (a + b * c) mod b = a mod b.
  Proof. intros a b c; rewrite (Z.mul_comm _ c); autorewrite with zsimplify; reflexivity. Qed.
  Lemma mod_add_l'_full : forall a b c, (a * b + c) mod a = c mod a.
  Proof. intros a b c; rewrite (Z.mul_comm _ b); autorewrite with zsimplify; reflexivity. Qed.
  Hint Rewrite mod_add'_full mod_add_l'_full : zsimplify.

  Lemma mod_add_l : forall a b c, b <> 0 -> (a * b + c) mod b = c mod b.
  Proof. intros a b c H; rewrite (Z.add_comm _ c); autorewrite with zsimplify; reflexivity. Qed.

  Lemma mod_add' : forall a b c, b <> 0 -> (a + b * c) mod b = a mod b.
  Proof. intros a b c H; rewrite (Z.mul_comm _ c); autorewrite with zsimplify; reflexivity. Qed.
  Lemma mod_add_l' : forall a b c, a <> 0 -> (a * b + c) mod a = c mod a.
  Proof. intros a b c H; rewrite (Z.mul_comm _ b); autorewrite with zsimplify; reflexivity. Qed.

  Lemma add_pow_mod_l : forall a b c, a <> 0 -> 0 < b ->
                                      ((a ^ b) + c) mod a = c mod a.
  Proof.
    intros a b c H H0; replace b with (b - 1 + 1) by ring;
      rewrite Z.pow_add_r, Z.pow_1_r by omega; auto using Z.mod_add_l.
  Qed.

  Lemma mod_exp_0 : forall a x m, x > 0 -> m > 1 -> a mod m = 0 ->
    a ^ x mod m = 0.
  Proof.
    intros a x m H H0 H1.
    replace x with (Z.of_nat (Z.to_nat x)) in * by (apply Z2Nat.id; omega).
    induction (Z.to_nat x). {
      simpl in *; omega.
    } {
      rewrite Nat2Z.inj_succ in *.
      rewrite Z.pow_succ_r by omega.
      rewrite Z.mul_mod by omega.
      case_eq n; intros. {
        subst. simpl.
        rewrite Zmod_1_l by omega.
        rewrite H1.
        apply Zmod_0_l.
      } {
        subst.
        rewrite IHn by (rewrite Nat2Z.inj_succ in *; omega).
        rewrite H1.
        auto.
      }
    }
  Qed.

  Lemma mod_pow : forall (a m b : Z), (0 <= b) -> (m <> 0) ->
      a ^ b mod m = (a mod m) ^ b mod m.
  Proof.
    intros a m b H H0; rewrite <- (Z2Nat.id b) by auto.
    induction (Z.to_nat b) as [|n IHn]; auto.
    rewrite Nat2Z.inj_succ.
    do 2 rewrite Z.pow_succ_r by apply Nat2Z.is_nonneg.
    rewrite Z.mul_mod by auto.
    rewrite (Z.mul_mod (a mod m) ((a mod m) ^ Z.of_nat n) m) by auto.
    rewrite <- IHn by auto.
    rewrite Z.mod_mod by auto.
    reflexivity.
  Qed.

  Lemma mod_to_nat x m (Hm:(0 < m)%Z) (Hx:(0 <= x)%Z) : (Z.to_nat x mod Z.to_nat m = Z.to_nat (x mod m))%nat.
    pose proof Zdiv.mod_Zmod (Z.to_nat x) (Z.to_nat m) as H;
      rewrite !Z2Nat.id in H by omega.
    rewrite <-H by (change 0%nat with (Z.to_nat 0); rewrite Z2Nat.inj_iff; omega).
    rewrite !Nat2Z.id; reflexivity.
  Qed.

  Lemma mul_div_eq_full : forall a m, m <> 0 -> m * (a / m) = (a - a mod m).
  Proof.
    intros a m H. rewrite (Z_div_mod_eq_full a m) at 2 by auto. ring.
  Qed.

  Hint Rewrite mul_div_eq_full using zutil_arith : zdiv_to_mod.
  Hint Rewrite <-mul_div_eq_full using zutil_arith : zmod_to_div.

  Lemma f_equal_mul_mod x y x' y' m : x mod m = x' mod m -> y mod m = y' mod m -> (x * y) mod m = (x' * y') mod m.
  Proof.
    intros H0 H1; rewrite Zmult_mod, H0, H1, <- Zmult_mod; reflexivity.
  Qed.
  Hint Resolve f_equal_mul_mod : zarith.

  Lemma f_equal_add_mod x y x' y' m : x mod m = x' mod m -> y mod m = y' mod m -> (x + y) mod m = (x' + y') mod m.
  Proof.
    intros H0 H1; rewrite Zplus_mod, H0, H1, <- Zplus_mod; reflexivity.
  Qed.
  Hint Resolve f_equal_add_mod : zarith.

  Lemma f_equal_opp_mod x x' m : x mod m = x' mod m -> (-x) mod m = (-x') mod m.
  Proof.
    intro H.
    destruct (Z_zerop (x mod m)) as [H'|H'], (Z_zerop (x' mod m)) as [H''|H''];
      try congruence.
    { rewrite !Z_mod_zero_opp_full by assumption; reflexivity. }
    { rewrite Z_mod_nz_opp_full, H, <- Z_mod_nz_opp_full by assumption; reflexivity. }
  Qed.
  Hint Resolve f_equal_opp_mod : zarith.

  Lemma f_equal_sub_mod x y x' y' m : x mod m = x' mod m -> y mod m = y' mod m -> (x - y) mod m = (x' - y') mod m.
  Proof.
    rewrite <- !Z.add_opp_r; auto with zarith.
  Qed.
  Hint Resolve f_equal_sub_mod : zarith.

  Lemma mul_div_eq : forall a m, m > 0 -> m * (a / m) = (a - a mod m).
  Proof.
    intros a m H.
    rewrite (Z_div_mod_eq a m) at 2 by auto.
    ring.
  Qed.

  Lemma mul_div_eq' : (forall a m, m > 0 -> (a / m) * m = (a - a mod m))%Z.
  Proof.
    intros a m H.
    rewrite (Z_div_mod_eq a m) at 2 by auto.
    ring.
  Qed.

  Hint Rewrite mul_div_eq mul_div_eq' using zutil_arith : zdiv_to_mod.
  Hint Rewrite <- mul_div_eq' using zutil_arith : zmod_to_div.

  Lemma mod_div_eq0 : forall a b, 0 < b -> (a mod b) / b = 0.
  Proof.
    intros.
    apply Z.div_small.
    auto using Z.mod_pos_bound.
  Qed.
  Hint Rewrite mod_div_eq0 using zutil_arith : zsimplify.

  Local Lemma mod_pull_div_helper a b c X
        (HX : forall a b c d e f g,
            X a b c d e f g = if a =? 0 then c else 0)
    : 0 <> b
      -> 0 <> c
      -> (a / b) mod c
         = (a mod (c * b)) / b
           + if c <? 0 then - X ((a / b) mod c) (a mod (c * b)) ((a mod (c * b)) / b) a b c (a / b) else 0.
  Proof.
    intros; break_match; Z.ltb_to_lt; rewrite ?Z.sub_0_r, ?Z.add_0_r;
      assert (0 <> c * b) by nia; Z.div_mod_to_quot_rem; subst;
        destruct_head'_or; destruct_head'_and;
          try assert (b < 0) by omega;
          try assert (c < 0) by omega;
          Z.replace_all_neg_with_pos;
          try match goal with
              | [ H : ?c * ?b * ?q1 + ?r1 = ?b * (?c * ?q2 + _) + _ |- _ ]
                => assert (q1 = q2) by nia; progress subst
              end;
          rewrite ?HX; clear HX X;
          try nia;
          repeat match goal with
                 | [ |- - ?x = ?y ] => is_var y; assert (y <= 0) by nia; Z.replace_all_neg_with_pos
                 | [ |- - ?x = ?y + -_ ] => is_var y; assert (y <= 0) by nia; Z.replace_all_neg_with_pos
                 | [ H : -?x + (-?y + ?z) = -?w + ?v |- _ ]
                   => assert (x + (y + -z) = w + -v) by omega; clear H
                 | [ H : ?c * ?b * ?q1 + (?b * ?q2 + ?r) = ?b * (?c * ?q1' + ?q2') + ?r' |- _ ]
                   => assert (c * q1 + q2 = c * q1' + q2') by nia;
                        assert (r = r') by nia;
                        clear H
                 | [ H : -?x < -?y + ?z |- _ ] => assert (y + -z < x) by omega; clear H
                 | [ H : -?x + ?y <= 0 |- _ ] => assert (0 <= x + -y) by omega; clear H
                 | _ => progress Z.clean_neg
                 | _ => progress subst
                 end.
    all:match goal with
        | [ H : ?c * ?q + ?r = ?c * ?q' + ?r' |- _ ]
          => first [ constr_eq q q'; assert (r = r') by nia; clear H
                   | assert (q = q') by nia; assert (r = r') by nia; clear H
                   | lazymatch goal with
                     | [ H' : r' < c |- _ ]
                       => destruct (Z_dec' r c) as [[?|?]|?]
                     | [ H' : r < c |- _ ]
                       => destruct (Z_dec' r' c) as [[?|?]|?]
                     end;
                     subst;
                     [ assert (q = q') by nia; assert (r = r') by nia; clear H
                     | nia
                     | first [ assert (1 + q = q') by nia | assert (q = 1 + q') by nia ];
                       first [ assert (r' = 0) by nia | assert (r = 0) by nia ] ] ]
        end.
    all:try omega.
    all:break_match; Z.ltb_to_lt; omega.
  Qed.

  Lemma mod_pull_div_full a b c
    : (a / b) mod c
      = if ((c <? 0) && ((a / b) mod c =? 0))%bool
        then 0
        else (a mod (c * b)) / b.
  Proof.
    destruct (Z_zerop b), (Z_zerop c); subst;
      autorewrite with zsimplify; try reflexivity.
    { break_match; Z.ltb_to_lt; omega. }
    { erewrite mod_pull_div_helper at 1 by (omega || reflexivity); cbv beta.
      destruct (c <? 0) eqn:?; simpl; [ | omega ].
      break_innermost_match; omega. }
  Qed.

  Lemma mod_pull_div a b c
    : 0 <= c -> (a / b) mod c = a mod (c * b) / b.
  Proof. rewrite mod_pull_div_full; destruct (c <? 0) eqn:?; Z.ltb_to_lt; simpl; omega. Qed.

  Lemma small_mod_eq a b n: a mod n = b mod n -> 0 <= a < n -> a = b mod n.
  Proof. intros; rewrite <-(Z.mod_small a n); auto. Qed.

  Lemma mod_pow_full p q n : (p^q) mod n = ((p mod n)^q) mod n.
  Proof.
    destruct (Z_dec' n 0) as [ [H|H] | H]; subst;
      [
      | apply Zpower_mod; assumption
      | rewrite !Zmod_0_r; reflexivity ].
    { revert H.
      rewrite <- (Z.opp_involutive (p^q)),
      <- (Z.opp_involutive ((p mod n)^q)),
      <- (Z.opp_involutive p),
      <- (Z.opp_involutive n).
      generalize (-n); clear n; intros n H.
      rewrite !Zmod_opp_opp.
      rewrite !Z.opp_involutive.
      apply f_equal.
      destruct (Z.Even_or_Odd q).
      { rewrite !Z.pow_opp_even by (assumption || omega).
        destruct (Z.eq_dec (p^q mod n) 0) as [H'|H'], (Z.eq_dec ((-p mod n)^q mod n) 0) as [H''|H''];
          repeat first [ rewrite Z_mod_zero_opp_full by assumption
                       | rewrite Z_mod_nz_opp_full by assumption
                       | reflexivity
                       | rewrite <- Zpower_mod, Z.pow_opp_even in H'' by (assumption || omega); omega
                       | rewrite <- Zpower_mod, Z.pow_opp_even in H'' |- * by (assumption || omega); omega ]. }
      { rewrite Z.pow_opp_odd, !Z.opp_involutive, <- Zpower_mod, Z.pow_opp_odd, ?Z.opp_involutive by (assumption || omega).
        reflexivity. } }
  Qed.

  Lemma mod_bound_min_max l x u d (H : l <= x <= u)
    : (if l / d =? u / d then Z.min (l mod d) (u mod d) else Z.min 0 (d + 1))
      <= x mod d
      <= if l / d =? u / d then Z.max (l mod d) (u mod d) else Z.max 0 (d - 1).
  Proof.
    destruct (Z_dec d 0) as [ [?|?] | ? ];
      try solve [ subst; autorewrite with zsimplify; simpl; split; reflexivity
                | repeat first [ progress Z.div_mod_to_quot_rem
                               | progress subst
                               | progress break_innermost_match
                               | progress Z.ltb_to_lt
                               | progress destruct_head'_or
                               | progress destruct_head'_and
                               | progress apply Z.min_case_strong
                               | progress apply Z.max_case_strong
                               | progress intros
                               | omega
                               | match goal with
                                 | [ H : ?x <= ?y, H' : ?y <= ?x |- _ ] => assert (x = y) by omega; clear H H'
                                 | _ => progress subst
                                 | [ H : ?d * ?q0 + ?r0 = ?d * ?q1 + ?r1 |- _ ]
                                   => assert (q0 = q1) by nia; subst q0
                                 | [ H : ?d * ?q0 + ?r0 <= ?d * ?q1 + ?r1 |- _ ]
                                   => assert (q0 = q1) by nia; subst q0
                                 end ] ].
  Qed.
End Z.


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

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

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

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) {struct plus_arg0}
  : natural :=
  match plus_arg0 with
  | Zero => plus_arg1
  | Succ n => Succ (plus n plus_arg1)
  end.

Fixpoint mult (mult_arg0 : natural) (mult_arg1 : natural) {struct mult_arg0}
  : natural :=
  match mult_arg0 with
  | Zero => Zero
  | Succ n => plus (mult n mult_arg1) mult_arg1
  end.

Definition synth (lf2 : natural) (y : natural) (x : natural) (lf1 : natural)
  : natural := mult (Succ y) x.


Require Import List.
Import ListNotations.

Inductive Forall3 {A B C : Type} (R : A -> B -> C -> Prop) : list A -> list B -> list C -> Prop :=
| Forall3_nil : Forall3 R [] [] []
| Forall3_cons : forall x y z xs ys zs,
        R x y z ->
        Forall3 R xs ys zs ->
        Forall3 R (x :: xs) (y :: ys) (z :: zs).


Require Import Coq.ZArith.ZArith Coq.micromega.Lia.
Require Import Crypto.Util.ZUtil.Hints.Core.
Require Import Crypto.Util.ZUtil.Hints.ZArith.
Require Import Crypto.Util.ZUtil.Tactics.DivModToQuotRem.
Local Open Scope Z_scope.

Module Z.
  Lemma mod_mod_small a n m
        (Hnm : (m mod n = 0)%Z)
        (Hnm_le : (0 < n <= m)%Z)
        (H : (a mod m < n)%Z)
    : ((a mod n) mod m = a mod m)%Z.
  Proof.
    assert ((a mod n) < m)%Z
      by (eapply Z.lt_le_trans; [ apply Z.mod_pos_bound | ]; lia).
    rewrite (Z.mod_small _ m) by auto with zarith.
    apply Z.mod_divide in Hnm; [ | lia ].
    destruct Hnm as [x ?]; subst.
    repeat match goal with
           | [ H : context[(_ mod _)%Z] |- _ ]
             => revert H
           end.
    Z.div_mod_to_quot_rem_in_goal.
    lazymatch goal with
    | [ H : a = (?x * ?n * ?q) + _, H' : a = (?n * ?q') + _ |- _ ]
      => assert (q' = x * q) by nia; subst q'; nia
    end.
  Qed.

  (** [rewrite_mod_small] is a better version of [rewrite Z.mod_small
      by rewrite_mod_small_solver]; it backtracks across occurences
      that the solver fails to solve the side-conditions on. *)
  Ltac rewrite_mod_small_solver :=
    zutil_arith_more_inequalities.
  Ltac rewrite_mod_small :=
    repeat match goal with
           | [ |- context[?x mod ?y] ]
             => rewrite (Z.mod_small x y) by rewrite_mod_small_solver
           end.
  Ltac rewrite_mod_mod_small :=
    repeat match goal with
           | [ |- context[(?a mod ?n) mod ?m] ]
             => rewrite (mod_mod_small a n m) by rewrite_mod_small_solver
           end.
  Ltac rewrite_mod_small_more :=
    repeat (rewrite_mod_small || rewrite_mod_mod_small).
  Ltac rewrite_mod_small_in_hyps :=
    repeat match goal with
           | [ H : context[?x mod ?y] |- _ ]
             => rewrite (Z.mod_small x y) in H by rewrite_mod_small_solver
           end.
  Ltac rewrite_mod_mod_small_in_hyps :=
    repeat match goal with
           | [ H : context[(?a mod ?n) mod ?m] |- _ ]
             => rewrite (mod_mod_small a n m) in H by rewrite_mod_small_solver
           end.
  Ltac rewrite_mod_small_more_in_hyps :=
    repeat (rewrite_mod_small_in_hyps || rewrite_mod_mod_small_in_hyps).
  Ltac rewrite_mod_small_in_all := repeat (rewrite_mod_small || rewrite_mod_small_in_hyps).
  Ltac rewrite_mod_mod_small_in_all := repeat (rewrite_mod_mod_small || rewrite_mod_mod_small_in_hyps).
  Ltac rewrite_mod_small_more_in_all := repeat (rewrite_mod_small_more || rewrite_mod_small_more_in_hyps).
End Z.


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

Definition prod_uncurry {X Y Z : Type}
  (f : X -> Y -> Z) (p : X * Y) : Z :=
  f (fst p) (snd p).

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

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


Require Export D.

(** **** Problem #4 : 2 stars (filter_even_gt7) *)

(** Use [filter] (instead of [Fixpoint]) to write a Coq function
    [filter_even_gt7] that takes a list of natural numbers as input
    and returns a list of just those that are even and greater than
    7. *)

Fixpoint greater_than (a b:nat) : bool :=
match a with
| O => false
| S n => match b with
        | O => true
        | S m => greater_than n m
        end
end.

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

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

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


Require Import ssreflect Nat PeanoNat Le Logic Lia.

Open Scope nat_scope.

Theorem nat_strong_ind : forall P : nat -> Prop,
P 0 -> (forall n, (forall k, k <= n -> P k) -> P (S n)) -> forall n, P n.
Proof.
  move=> P P0 SI n.
  assert (exists k, n <= k); first by exists n.
  case: H => k.
  move: n.
  induction k.
  - move=> n Le.
    destruct n.
    + exact P0.
    + lia.
  - move=> n H.
    apply Nat.lt_eq_cases in H.
    case: H => H.
    + apply IHk.
      lia.
    + rewrite H.
      apply SI => x.
      apply IHk.
Qed.

Theorem nat_strong2_ind : forall P : nat -> Prop,
(forall n, (forall k, k < n -> P k) -> P n) -> forall n, P n.
Proof.
  move=> P SI n.
  refine (nat_strong_ind P _ _ n).
  - apply: SI.
    move=> k Lt.
    inversion Lt.
  - move=> m OSI.
    apply: SI.
    move=> k Lt.
    apply: OSI.
    lia.
Qed.

Theorem nat_even_odd_ind : forall P : nat -> Prop,
P 0 -> P 1 -> (forall n , P n -> P (2 + n)) -> forall n, P n.
Proof.
  move=> P P0 P1 IH.
  fix H 1.
  case=> [|[|n]]; [exact: P0|exact: P1| ].
  apply: IH.
  apply: H.
  Show Proof.
Qed.

Theorem nat_my_ind : forall P : nat -> Prop,
P 0 -> (forall n , P n -> P (S n)) -> forall n, P n.
Proof.
  move=> P P0 IH.
  fix H 1.
  case=> [|n]; [exact: P0| ].
  apply: IH.
  apply: H.
Qed.

Fixpoint nat_my_def_ind (P : nat -> Prop)
    (p0 : P 0) (ih : (forall n, P n -> P (S n))) (n : nat) : P n :=
  match n with
    | 0 => p0
    | (S m) => ih m (nat_my_def_ind P p0 ih m)
  end.

Theorem even_odd_dec n: exists m, n = m * 2 \/ n = 1 + m * 2.
Proof.
  elim/nat_even_odd_ind: n => [ | | n H]; try exists 0; lia.
  case: H => [m [-> | ->]]; by exists (m + 1); lia.
Qed.

Theorem name : forall A B C : Prop, ((A -> B) /\ (A -> C)) <-> (A -> B /\ C).
Proof.
  move=> A B C.
  split.
  - move=> [ab ac] a.
    split.
    + exact (ab a).
    + exact (ac a).
  - move=> abc.
    split.
    + move=> a.
      move: (abc a) => [b c].
      exact b.
    + move=> a.
      move: (abc a) => [b c].
      exact c.
Qed.

Theorem nat_doubling_ind : forall P : nat -> Prop,
  P 0 -> (forall a : nat, P a -> (P (a * 2) /\ P (1 + a * 2))) -> forall n, P n .
Proof.
  move=> P P0 IH n.
  move: (IH 0 P0) => [_ P1] /=.
  simpl in P1.
  elim/nat_strong_ind: n => [| n SIH] //.
  case: (even_odd_dec n) => [m [E | E]];
  rewrite E.
  - case/name: (IH m) => m2m m2sm.
    apply: m2sm.
    apply: SIH.
    lia.
  - case/name: (IH (S m)) => m2m m2sm.
    apply: m2m.
    apply: SIH.
    lia.
Qed.

Theorem nat_doube_ind : forall R : nat -> nat -> Prop,
  (forall n, R 0 n) -> (forall n, R (S n) 0) ->
  (forall n m, R n m -> R (S n) (S m)) ->
  forall n m, R n m.
Proof.
  move=> R R0n Rn0 RS.
  fix IH 1 => n m.
  case: n => [| n0]; first exact: R0n.
  case: m => [| m0]; first exact: Rn0.
  apply: RS.
  exact: IH.
Qed.


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

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

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

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) {struct plus_arg0}
  : natural :=
  match plus_arg0 with
  | Zero => plus_arg1
  | Succ n => Succ (plus n plus_arg1)
  end.

Fixpoint mult (mult_arg0 : natural) (mult_arg1 : natural) {struct mult_arg0}
  : natural :=
  match mult_arg0 with
  | Zero => Zero
  | Succ n => plus (mult n mult_arg1) mult_arg1
  end.

Definition synth (lf2 : natural) (x : natural) (lf1 : natural) : natural :=
  mult lf2 (Succ x).


Definition pred_partial: forall (n : nat), n <> 0 ->  nat.
Proof.
 refine (fun n:nat => match n return n <> 0 -> nat
                      with 0 => fun h  => False_rec _ _
                         | S p => fun h => p
                      end).
 -  now destruct h.
Defined.

Scheme
le_ind_max := Induction for le Sort Prop.

Theorem le_2_n_not_zero: forall (n : nat), 2 <= n ->  n <> 0.
Proof.
intros n Hle; elim Hle; intros; discriminate.
Qed.

Theorem le_2_n_pred:
 forall (n : nat) (h : 2 <= n),  pred_partial n (le_2_n_not_zero n h) <> 0.
Proof.
 intros n h; induction h  using le_ind_max.
 - discriminate.
 - cbn; inversion h; auto.
Qed.

(**

Extraction pred_partial.

**)


Require Import group.
Require Import Basics.

Open Scope program_scope.

Structure action {M : Type} (G : group M) (X : Type) := {
  phi :> M -> X -> X;
  phi_low1 : forall x, phi (id G) x = x;
  phi_low2 : forall g h x, phi g (phi h x) = phi (bin G g h) x;
}.

Example action_has_inverse {M : Type} (G : group M) (X : Type) (φ : action G X) : forall g, g \in G -> exists φ',
  (forall x, ((φ g) ∘ (φ' g)) x = x) /\ (forall x, ((φ' g) ∘ (φ g)) x = x).
Proof.
  intros.
  exists (fun g => fun x => (φ (inverse G g)) x).
  unfold compose.
  split.
  - (* left *)
    intros.
    rewrite phi_low2.
    rewrite invR.
    rewrite phi_low1.
    reflexivity.
  - (* right *)
    intros.
    rewrite phi_low2.
    rewrite invL.
    rewrite phi_low1.
    reflexivity.
Qed.


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

(** ** Single Diophantine equations *)

Require Import List Arith Omega Nat.

Require Import utils_tac utils_list sums pos vec.
Require Import dio_logic dio_elem.

Set Implicit Arguments.

Local Notation "∑" := (msum plus 0).

Section convexity.

  Let convex_1 x p : 2*(x*(x+p)) <= x*x+(x+p)*(x+p).
  Proof.
    rewrite mult_assoc.
    repeat rewrite Nat.mul_add_distr_r.
    repeat rewrite Nat.mul_add_distr_l.
    rewrite (mult_comm p x).
    repeat rewrite <- mult_assoc.
    generalize (x*x) (x*p) (p*p); intros; omega.
  Qed.

  Let convex_2 x p : 2*(x*(x+p)) = x*x+(x+p)*(x+p) -> p = 0.
  Proof.
    rewrite mult_assoc.
    intros H.
    cut (p*p = 0).
    { destruct p; simpl; auto; discriminate. }
    revert H.
    repeat rewrite Nat.mul_add_distr_r.
    repeat rewrite Nat.mul_add_distr_l.
    rewrite (mult_comm p x).
    repeat rewrite <- mult_assoc.
    generalize (x*x) (x*p) (p*p); intros; omega.
  Qed.

  Fact convex_le x y : 2*(x*y) <= x*x+y*y.
  Proof.
    destruct (le_lt_dec x y).
    + replace y with (x+(y-x)) by omega.
      apply convex_1.
    + rewrite (mult_comm x y), plus_comm.
      replace x with (y+(x-y)) by omega.
      apply convex_1.
  Qed.

  Fact convex_eq x y : 2*(x*y) = x*x+y*y -> x = y.
  Proof.
    destruct (le_lt_dec x y).
    + replace y with (x+(y-x)) by omega.
      intros H; apply convex_2 in H; omega.
    + rewrite (mult_comm x y), plus_comm.
      replace x with (y+(x-y)) by omega.
      intros H; apply convex_2 in H; omega.
  Qed.

  Let convex_3 a t x y : 0 < t -> a*x+(a+t)*y = a*y+(a+t)*x -> x = y.
  Proof.
    intros H.
    repeat rewrite Nat.mul_add_distr_r.
    intros H1.
    apply Nat.mul_cancel_l with t; omega.
  Qed.

  Fact convex_neq a b x y : a < b -> a*x+b*y = a*y+b*x -> x = y.
  Proof.
    intros H.
    replace b with (a+(b-a)) by omega.
    apply convex_3; omega.
  Qed.

  Hint Resolve convex_le.

  Fact convex_n_le n (f g : nat -> nat) :  ∑ n (fun i => 2*(f i*g i))
                                        <= ∑ n (fun i => f i*f i + g i*g i).
  Proof.
    revert f g; induction n as [ | n IHn ]; intros f g.
    + rewrite msum_0; auto.
    + do 2 rewrite msum_S.
      apply plus_le_compat; auto.
  Qed.

  Hint Resolve convex_n_le.

  Let nat_le_sum a b c d : a <= b -> c <= d -> a+c = b+d -> a = b /\ c = d.
  Proof. intros; omega. Qed.

  (* This one can be used to encode a list of equations
     x1 = y1 ... xn = yn into a single equation of size
     linear in n if all the xi, yi have a bounded size

     Hence one can transform a system elementary diophantine
     equations into a single polynomial equation of linear
     size !! *)

  Fact convex_n_eq n (f g : nat -> nat) : ∑ n (fun i => 2*(f i*g i))
                                        = ∑ n (fun i => f i*f i + g i*g i)
                                    <-> forall i, i < n -> f i = g i.
  Proof.
    split.
    + revert f g; induction n as [ | n IHn ]; intros f g.
      * intros; omega.
      * do 2 rewrite msum_S; intros H.
        apply nat_le_sum in H; auto.
        destruct H as (H1 & H2).
        apply convex_eq in H1.
        specialize (IHn _ _ H2).
        intros [ | ] ?; auto; apply IHn; omega.
    + intros Hfg.
      apply msum_ext.
      intros i Hi; rewrite Hfg; auto; ring.
  Qed.

End convexity.

Section diophantine_polynomial.

  Variable (V P : Set).

  Inductive dio_polynomial : Set :=
    | dp_nat : nat -> dio_polynomial                  (* natural number constant *)
    | dp_var : V   -> dio_polynomial                  (* existentially quantified variable *)
    | dp_par : P   -> dio_polynomial                  (* parameter *)
    | dp_comp : dio_op -> dio_polynomial -> dio_polynomial -> dio_polynomial.

  Notation dp_add := (dp_comp do_add).
  Notation dp_mul := (dp_comp do_mul).

  Fixpoint dp_var_list p :=
    match p with
      | dp_nat _      => nil
      | dp_var v      => v::nil
      | dp_par _      => nil
      | dp_comp _ p q => dp_var_list p ++ dp_var_list q
    end.

  Fixpoint dp_par_list p :=
    match p with
      | dp_nat _      => nil
      | dp_var _      => nil
      | dp_par x      => x::nil
      | dp_comp _ p q => dp_par_list p ++ dp_par_list q
    end.

  (* ρ σ ν φ *)

  Fixpoint dp_eval φ ν p :=
    match p with
      | dp_nat n => n
      | dp_var v => φ v
      | dp_par i => ν i
      | dp_comp do_add p q => dp_eval φ ν p + dp_eval φ ν q
      | dp_comp do_mul p q => dp_eval φ ν p * dp_eval φ ν q
    end.

  Fact dp_eval_ext φ ν φ' ν' p :
        (forall v, In v (dp_var_list p) -> φ v = φ' v)
     -> (forall i, In i (dp_par_list p) -> ν i = ν' i)
     -> dp_eval φ ν p = dp_eval φ' ν' p.
  Proof.
    induction p as [ | | | [] p Hp q Hq ]; simpl; intros H1 H2; f_equal; auto;
      ((apply Hp || apply Hq); intros; [ apply H1 | apply H2 ]; apply in_or_app; auto).
  Qed.

  Fact dp_eval_fix_add φ ν p q : dp_eval φ ν (dp_add p q) = dp_eval φ ν p + dp_eval φ ν q.
  Proof. trivial. Qed.

  Fact dp_eval_fix_mul φ ν p q : dp_eval φ ν (dp_mul p q) = dp_eval φ ν p * dp_eval φ ν q.
  Proof. trivial. Qed.

  Fixpoint dp_size p :=
    match p with
      | dp_nat n => 1
      | dp_var v => 1
      | dp_par i => 1
      | dp_comp _ p q => 1 + dp_size p + dp_size q
    end.

  Fact dp_size_fix_comp o p q : dp_size (dp_comp o p q) = 1 + dp_size p + dp_size q.
  Proof. auto. Qed.

  Definition dio_single := (dio_polynomial * dio_polynomial)%type.
  Definition dio_single_size (e : dio_single) := dp_size (fst e) + dp_size (snd e).

  Definition dio_single_pred e ν := exists φ, dp_eval φ ν (fst e) = dp_eval φ ν (snd e).

End diophantine_polynomial.

Arguments dp_nat {V P}.
Arguments dp_var {V P}.
Arguments dp_par {V P}.
Arguments dp_comp {V P}.

Notation dp_add := (dp_comp do_add).
Notation dp_mul := (dp_comp do_mul).

Section dio_elem_dio_poly.

  Let dp_2xy u v : dio_polynomial nat nat := dp_mul (dp_nat 2) (dp_mul u v).
  Let dp_x2y2 u v : dio_polynomial nat nat := dp_add (dp_mul u u) (dp_mul v v).

  Let dp_2xy_size u v : dp_size (dp_2xy u v) = 3+dp_size u+dp_size v.
  Proof. auto. Qed.

  Let dp_x2y2_size u v : dp_size (dp_x2y2 u v) = 3+2*dp_size u+2*dp_size v.
  Proof. simpl; omega. Qed.

  Let dp_common e : dio_polynomial nat nat :=
    match e with
      | dee_nat c      => dp_nat c
      | dee_var v      => dp_var v
      | dee_par p      => dp_par p
      | dee_comp o v w => dp_comp o (dp_var v) (dp_var w)
    end.

  Let dp_common_size e : dp_size (dp_common e) <= 3.
  Proof. destruct e as [ | | | [] ]; simpl; auto. Qed.

  Let dp_eval_common φ ν e : dp_eval φ ν (dp_common e) = dee_eval φ ν e.
  Proof. destruct e as [ | | | [] ]; auto. Qed.

  Let dp_left (c : dio_constraint) := dp_2xy (dp_var (fst c)) (dp_common (snd c)).
  Let dp_right (c : dio_constraint) := dp_x2y2 (dp_var (fst c)) (dp_common (snd c)).

  Let dee2dp_1 l := fold_right dp_add (dp_nat 0) (map dp_left l).
  Let dee2dp_2 l := fold_right dp_add (dp_nat 0) (map dp_right l).

  Let dee2dp_1_size l : dp_size (dee2dp_1 l) <= 1+8*length l.
  Proof.
    induction l as [ | (x,e) l IHl ].
    + simpl; auto.
    + unfold dee2dp_1; simpl fold_right; fold (dee2dp_1 l).
      rewrite dp_size_fix_comp.
      unfold dp_left; rewrite dp_2xy_size.
      unfold fst, snd.
      generalize (dp_common_size e); intros.
      simpl dp_size at 1; simpl length.
      rewrite Nat.mul_succ_r; omega.
  Qed.

  Let dee2dp_2_size l : dp_size (dee2dp_2 l) <= 1+12*length l.
  Proof.
    induction l as [ | (x,e) l IHl ].
    + simpl; auto.
    + unfold dee2dp_2; simpl fold_right; fold (dee2dp_2 l).
      rewrite dp_size_fix_comp.
      unfold dp_right; rewrite dp_x2y2_size.
      unfold fst, snd.
      generalize (dp_common_size e); intros.
      simpl dp_size at 1; simpl length.
      rewrite Nat.mul_succ_r; omega.
  Qed.

  Let dc_value_1 φ ν (c : dio_constraint) := 2*(φ (fst c)*dee_eval φ ν (snd c)).
  Let dc_value_2 φ ν (c : dio_constraint) := (φ (fst c)*φ (fst c)) + (dee_eval φ ν (snd c)*dee_eval φ ν (snd c)).

  Let dee2dp_1_eval φ ν l : dp_eval φ ν (dee2dp_1 l) = fold_right plus 0 (map (dc_value_1 φ ν) l).
  Proof.
    induction l as [ | (u,e) l IHl ].
    + simpl; auto.
    + simpl fold_right; rewrite <- IHl.
      unfold dee2dp_1; simpl fold_right.
      rewrite dp_eval_fix_add; f_equal; auto.
      unfold dc_value_1, dp_left, dp_2xy.
      repeat rewrite dp_eval_fix_mul.
      unfold fst, snd; do 2 f_equal.
      apply dp_eval_common.
  Qed.

  Let dee2dp_2_eval φ ν l : dp_eval φ ν (dee2dp_2 l) = fold_right plus 0 (map (dc_value_2 φ ν) l).
  Proof.
    induction l as [ | (u,e) l IHl ].
    + simpl; auto.
    + simpl fold_right; rewrite <- IHl.
      unfold dee2dp_2; simpl fold_right.
      rewrite dp_eval_fix_add; f_equal; auto.
      unfold dc_value_2, dp_right, dp_x2y2.
      rewrite dp_eval_fix_add.
      repeat rewrite dp_eval_fix_mul.
      unfold fst, snd; do 2 f_equal;
      apply dp_eval_common.
  Qed.

  Let dee2dp_spec φ ν l : dp_eval φ ν (dee2dp_1 l) = dp_eval φ ν (dee2dp_2 l)
                      <-> Forall (dc_eval φ ν) l.
  Proof.
    rewrite dee2dp_1_eval, dee2dp_2_eval.
    destruct (list_fun_inv l (0,dee_nat 0)) as (f & Hf).
    rewrite Hf at 1 2.
    do 2 rewrite map_map.
    do 2 rewrite <- sum_fold_map.
    unfold dc_value_1, dc_value_2.
    rewrite convex_n_eq.
    unfold dc_eval.
    apply Forall_forall_map with (P := fun i =>  φ (fst i) = dee_eval φ ν (snd i)); auto.
  Qed.

  Theorem dio_elem_single l : { E : dio_single nat nat | dio_single_size E <= 2+20*length l
              /\ forall ν φ, dp_eval φ ν (fst E) = dp_eval φ ν (snd E) <-> Forall (dc_eval φ ν) l }.
  Proof.
    exists (dee2dp_1 l,dee2dp_2 l); split.
    + unfold dio_single_size, fst, snd.
      generalize (dee2dp_1_size l) (dee2dp_2_size l); intros; omega.
    + unfold dio_single_pred, fst, snd; split; apply dee2dp_spec.
  Defined.

  Theorem dio_elem_equation l : { E : dio_single nat nat | dio_single_size E <= 2+20*length l
                                            /\ forall ν, dio_single_pred E ν <-> exists φ, Forall (dc_eval φ ν) l }.
  Proof.
    destruct (dio_elem_single l) as (p & H1 & H2); exists p; split; auto.
    split; intros (phi & H); exists phi; revert H; apply H2.
  Defined.

End dio_elem_dio_poly.

Corollary dio_rel_single R :
      𝔻R R -> { E : dio_single nat nat | forall ν, R ν <-> dio_single_pred E ν}.
Proof.
  intros (A & HA).
  destruct dio_formula_elem with (f := A) as (l & _ & _ & Hl).
  destruct dio_elem_equation with (l := l) as (E & _ & HE).
  exists E; intro; rewrite HE, <- Hl, HA; tauto.
Qed.

Section dio_poly_pos.

  Variable P : Set.

  Implicit Type (p : dio_polynomial nat P).

  Definition dio_poly_pos m p : (forall x, In x (dp_var_list p) -> x < m) -> { q | forall φ ν, dp_eval φ ν p = dp_eval (vec_pos (fun2vec 0 m φ)) ν q }.
  Proof.
    induction p as [ n | v | i | o p Hp q Hq ]; intros H.
    + exists (dp_nat n); auto.
    + specialize (H v); spec in H; simpl; auto.
      exists (dp_var (nat2pos H)); intros phi psi; simpl.
      rewrite vec_pos_fun2vec, pos2nat_nat2pos; auto.
    + exists (dp_par i); auto.
    + simpl in H.
      destruct Hp as (p1 & H1). { intros; apply H, in_or_app; auto. }
      destruct Hq as (q1 & H2). { intros; apply H, in_or_app; auto. }
      exists (dp_comp o p1 q1); intros phi psi; simpl.
      destruct o; f_equal; auto.
  Qed.

  Theorem dio_poly_eq_pos (e : dio_single nat P) : { m : nat
                                                 & { p' : dio_polynomial (pos m) P
                                                 & { q' | forall ν, dio_single_pred e ν <-> dio_single_pred (p',q') ν } } }.
  Proof.
    destruct e as (p,q).
    destruct (list_upper_bound (dp_var_list p++dp_var_list q)) as (m & Hm).
    destruct (@dio_poly_pos m p) as (p1 & H1). { intros; apply Hm, in_or_app; auto. }
    destruct (@dio_poly_pos m q) as (q1 & H2). { intros; apply Hm, in_or_app; auto. }
    exists m, p1, q1; intros psi; unfold dio_single_pred.
    split; intros (phi & Hphi).
    + exists (vec_pos (fun2vec 0 m phi)); simpl.
      rewrite <- H1, <- H2; auto.
    + exists (vec2fun (vec_set_pos phi) 0).
      rewrite H1, H2.
      rewrite fun2vec_vec2fun.
      eq goal Hphi; f_equal;
      apply dp_eval_ext; auto; intros j _; rewrite vec_pos_set; auto.
  Qed.

  Fact dio_poly_eq_pos_equiv n (p q : dio_polynomial (pos n) P) ν : dio_single_pred (p,q) ν <-> exists w, dp_eval (vec_pos w) ν p = dp_eval (vec_pos w) ν q.
  Proof.
    split.
    + intros (w & Hw); exists (vec_set_pos w); eq goal Hw; f_equal; simpl; apply dp_eval_ext; auto;
        intros; rewrite vec_pos_set; auto.
    + intros (w & Hw); exists (vec_pos w); auto.
  Qed.

End dio_poly_pos.

Check dio_poly_eq_pos.

Section dio_poly_inst_par.

  Variable (V P : Set) (σ : P -> nat).

  Fixpoint dp_inst_par (p : dio_polynomial V P) : dio_polynomial V Empty_set :=
    match p with
      | dp_nat c       => dp_nat c
      | dp_var v       => dp_var v
      | dp_par p       => dp_nat (σ p)
      | dp_comp o p q  => dp_comp o (dp_inst_par p) (dp_inst_par q)
    end.

  Fact dp_inst_par_eval φ ν p :
    dp_eval φ ν (dp_inst_par p) = dp_eval φ σ p.
  Proof. induction p as [ | | | [] ]; simpl; f_equal; auto. Qed.

End dio_poly_inst_par.

Section dio_poly_ren_par.

  Variable (V P Q : Set) (f : P -> Q).

  Fixpoint dp_ren_par p : dio_polynomial V Q :=
    match p with
      | dp_nat c       => dp_nat c
      | dp_var v       => dp_var v
      | dp_par p       => dp_par (f p)
      | dp_comp o p q  => dp_comp o (dp_ren_par p) (dp_ren_par q)
    end.

  Fact dp_ren_par_eval φ ν p :
    dp_eval φ ν (dp_ren_par p) = dp_eval φ (fun i => ν (f i)) p.
  Proof. induction p as [ | | | [] ]; simpl; f_equal; auto. Qed.

End dio_poly_ren_par.

Section dio_poly_proj_par.

  Variable (V : Set) (n : nat).

  Fixpoint dp_proj_par p : dio_polynomial V (pos n) :=
    match p with
      | dp_nat c       => dp_nat c
      | dp_var v       => dp_var v
      | dp_par p       => match le_lt_dec n p with left _ => dp_nat 0 | right H => dp_par (nat2pos H) end
      | dp_comp o p q  => dp_comp o (dp_proj_par p) (dp_proj_par q)
    end.

  Fact dp_proj_par_eval φ ν p :
    dp_eval φ ν (dp_proj_par p) = dp_eval φ (fun i => match le_lt_dec n i with left _ => 0 | right H => ν (nat2pos H) end) p.
  Proof.
    induction p as [ | | p | [] ]; simpl; f_equal; auto.
    destruct (le_lt_dec n p); auto.
  Qed.

End dio_poly_proj_par.


(* Copyright 2012-2015 by Adam Petcher.				*
 * Use of this source code is governed by the license described	*
 * in the LICENSE file at the root of the source tree.		*)

(* This file contains the definition of the base 2 logarithm function (rounded down) over natural numbers. *)

(* Some of the definitions and theory in this file were added to Coq 8.4, so we should refactor this at some point. *)

Set Implicit Arguments.

Require Import ZArith.

(* log2 is like log_inf except it returns nat, so I don't have to reason about an unnecessary conversion. This function is only used to implement lognat below.*)
Fixpoint log2(n : positive) : nat :=
  match n with
    | xH => 0
    | xO n' | xI n' => (S (log2 n'))
  end.

Lemma log2_prod_sum : forall(a : positive),
  (S (log2 a)) = (log2 (Pmult 2 a)).

  intros. auto.
Qed.

Lemma le_s : forall a b,
  (a <= b) -> S a <= S b.

  intros. omega.
Qed.

Lemma log2_monotonic_b : forall(a : positive),
  (log2 a) <= (log2 (Psucc a)).

  induction a;
  simpl in *; try apply le_s; auto.
Qed.

Lemma log2_ge_monotonic : forall(a : positive),
  (log2 (Psucc a)) >= (log2 a).

  induction a;
  simpl in *; try apply le_s; auto.
Qed.

Definition nat_to_pos (n : nat) : (n <> 0) -> positive :=
  fun _ => (P_of_succ_nat (pred n)).

Lemma double_nat_nz : forall(a : nat)(pf : a <> 0),
  ((2 * a) <> 0).
  intros. omega.
Qed.
Lemma s_nat_nz : forall(a : nat)(pf : a <> 0),
  ((S a) <> 0).
  intros. omega.
Qed.

Lemma factor_s_conv : forall(a : nat)(pf1 : (a <> 0))(pf2 : (S a) <> 0),
  (nat_to_pos (pf2)) = (Psucc (nat_to_pos pf1)).

  intros.
  destruct a.
  congruence.

  unfold nat_to_pos in *.
  simpl in *.
  intros. auto.
Qed.

Lemma add_s_r : forall a b,
  a + (S b) = S (a + b).
  intros. omega.
Qed.

Lemma factor_double_s : forall a,
  (2 * (S a)) = (S (S (2 * a))).

  intros. omega.
Qed.

Lemma factor_double_conv : forall(a : nat)(pf1 : (a <> 0))(pf2 : (2 * a) <> 0),
  (nat_to_pos pf2) = (Pmult 2 (nat_to_pos pf1)).

  induction a; intros; simpl in *.
  congruence.

  destruct (eq_nat_dec a 0).
  subst.
  unfold nat_to_pos.
  auto.

  assert (a + S (a + 0) <> 0) by omega.
  specialize (factor_s_conv H). intros.
  unfold nat_to_pos in *.

  rewrite (H0 pf2). clear H0.  clear pf2.
  assert (a + S (a + 0) = S (a + (a + 0))) by omega.
  rewrite H0.
  assert (a + (a + 0) <> 0) by omega.
  specialize (factor_s_conv H1). intros.

  unfold nat_to_pos in H2.
  rewrite <- H0 in H2.
  rewrite <- H0.
  rewrite (H2 H). clear H. clear H2.

  rewrite (IHa n). clear IHa.
  simpl.
  destruct a. intros. destruct n. auto.

  auto.
  omega.
Qed.

Definition lognat(n : nat) : (n <> 0) -> nat :=
  fun pf => (log2 (nat_to_pos pf)).

Theorem lognat_prod_sum : forall(a : nat)(pf1 : (a <> 0))(pf2: (2 * a) <> 0),
  (S (lognat pf1)) = (lognat pf2).

  intros.
  unfold lognat in *.
  rewrite (factor_double_conv pf1 pf2).
  eapply log2_prod_sum.
Qed.

Theorem lognat_monotonic_b : forall(a : nat)(pf1 : (a <> 0))(pf2: (S a) <> 0),
  (lognat pf1) <= (lognat pf2).

  induction a.
  intros.
  destruct pf1. auto.

  intros.
  unfold lognat in *.
  rewrite (factor_s_conv pf1).
  apply log2_monotonic_b.
Qed.

(* for good measure, we will define exponentiation for nat and prove that lognat is correct *)
Fixpoint expnat(a e : nat) : nat :=
  match e with
    | 0 => 1
    | (S e') => a * (expnat a e')
  end.

Lemma mult_ne : forall a b,
  a <> 0 -> b <> 0 -> a * b <> 0.

  intros.
  destruct a. omega.
  destruct b. omega.
  simpl.
  remember (b + a * (S b)) as c.
  omega.
Qed.

Theorem expnat_nz : forall a e,
  (a <> 0) -> (expnat a e) <> 0.

  induction e.
  simpl. auto.

  simpl.
  intros.
  eapply mult_ne; eauto.
Qed.

Lemma nz_2 : 2 <> 0.
  omega.
Qed.

Theorem expnat_2_nz: forall e,
  (expnat 2 e) <> 0.

  intros.
  apply (expnat_nz e nz_2).
Qed.

Theorem expnat_2_monotonic : forall e1 e2,
  e1 <= e2 ->
  (expnat 2 e1 <= expnat 2 e2).

  induction e1.
  intros.
  simpl.
  specialize (expnat_2_nz e2). intros.
  omega.

  induction e2;
  intros.
  omega.

  simpl.
  specialize (IHe1 e2).
  omega.
Qed.

Theorem lognat_correct_eq : forall(b : nat)(pf : (expnat 2 b) <> 0),
  (lognat pf) = b.

  induction b.
  intros. simpl in *. auto.

  intros.
  specialize (lognat_prod_sum (expnat_2_nz b)). intros.
  specialize (IHb (expnat_2_nz b)).
  rewrite IHb in H.
  symmetry in H.
  simpl in *.
  apply H.
Qed.

Lemma fold_add : forall a,
  a + (a + 0) = 2*a.
  intros. omega.
Qed.

Theorem lognat_ge_monotonic_b : forall(a : nat)(pf1 : (a <> 0))(pf2: (S a) <> 0),
  (lognat pf2) >= (lognat pf1).

  induction a.
  intros.
  destruct pf1. auto.

  intros.
  unfold lognat in *.
  rewrite (factor_s_conv pf1).
  apply log2_monotonic_b.
Qed.

Lemma ge_trans : forall a b c,
  a >= b -> b >= c -> a >= c.
  intuition.
Qed.

Lemma lognat_ge_monotonic_h : forall (c a b : nat)(pfa : a <> 0)(pfb : b <> 0),
    a >= b -> c = (a - b) -> (lognat pfa) >= (lognat pfb).

  induction c.
  intros.
  assert (a = b) by intuition.
  subst. auto.

  intros.
  assert (a >= (S b)) by omega.
  assert (c = a - (S b)) by omega.
  eapply ge_trans.
  apply (IHc a (S b) pfa (s_nat_nz pfb)).
  apply H1.
  apply H2.
  apply lognat_ge_monotonic_b.
Qed.

Lemma lognat_ge_monotonic : forall (a b : nat)(pfa : a <> 0)(pfb : b <> 0),
    a >= b -> (lognat pfa) >= (lognat pfb).

  intros.
  remember (a - b) as c.
  apply (@lognat_ge_monotonic_h c); auto.
Qed.

Lemma lognat_monotonic : forall (a b : nat)(pfa : a <> 0)(pfb : b <> 0),
    a <= b -> (lognat pfa) <= (lognat pfb).

  intros.
  remember (b - a) as c.
  apply (@lognat_ge_monotonic_h c); auto.
Qed.

Theorem mt : forall P Q: Prop, (P -> Q) -> (~Q -> ~P).
  unfold not in *.
  intros.
  apply H0.
  apply H.
  apply H1.
Qed.

Lemma ge_not : forall a b,
  ~(a >= b) -> a < b.
  intuition.
Qed.

Lemma lognat_ge_monotonic_mt : forall (a b : nat)(pfa : a <> 0)(pfb : b <> 0),
    (lognat pfa) < (lognat pfb) -> a < b.

  intros.
  specialize (lognat_ge_monotonic pfa pfb).
  intros.
  specialize (mt H0).
  intros.
  apply ge_not. omega.
Qed.

Lemma lognat_correct2 : forall(a : nat)(pf : a <> 0),
  a < (expnat 2 (S (lognat pf))).

  intros.

  simpl.
  rewrite fold_add.
  assert (expnat 2 (lognat pf) <> 0). apply expnat_nz. auto.
  assert (2 * (expnat 2 (lognat pf)) <> 0). omega.
  eapply (lognat_ge_monotonic_mt pf H0).
  rewrite <- (lognat_prod_sum H).
  rewrite lognat_correct_eq.
  omega.
Qed.

Lemma lognat_odd : forall(a : nat)(pf1 : (2 * a) <> 0)(pf2 : (S (2 * a)) <> 0),
  ((lognat pf2) = (lognat pf1)).

  intros.
  unfold lognat in *.
  rewrite (factor_s_conv pf1 pf2).
  assert (a <> 0). omega.
  rewrite (factor_double_conv H pf1).
  simpl.
  auto.
Qed.

Lemma double_s : forall a, (S (S (2 * a))) = 2 * (S a).
  intros. omega.
Qed.

Lemma lognat_double_eq : forall a b (pf1: 2 * a <> 0)(pf2: 2 * b <> 0)(pf3 : a <> 0) (pf4: b <> 0),
  lognat pf3 = lognat pf4 ->
  lognat pf1 = lognat pf2.

  intros.
  rewrite <- (lognat_prod_sum pf3).
  rewrite <- (lognat_prod_sum pf4).
  omega.
Qed.

Lemma nat_comp : forall(a : nat),
  exists x : nat,
  (a = (2 * x) \/ a = (S (2 * x))).

  induction a.
  exists 0. simpl.  auto.

  elim IHa. clear IHa.
  intros.
  destruct H.
  subst. simpl.
  exists x.
  right. auto.

  subst. simpl.
  exists (S x).
  left.
  simpl.
  omega.
Qed.

Lemma lognat_correct1 : forall(b a : nat)(pf : a <> 0),
  (lognat pf) = b ->
  (expnat 2 b) <= a.

  induction b.

  intros. simpl in *. omega.

  intros.
  elim (nat_comp a). intros.
  destruct H0.
  subst.
  destruct (eq_nat_dec x 0).
  subst. omega.
  rewrite <- (lognat_prod_sum n pf) in H.
  inversion H. clear H.
  rewrite H1.
  apply IHb in H1.
  simpl in *. omega.

  subst.
  destruct (eq_nat_dec x 0).
  subst. unfold lognat in H. simpl in *. omega.
  assert ((2 * x) <> 0). omega.
  rewrite (lognat_odd x H0 pf) in H.

  rewrite <- (lognat_prod_sum n H0) in H.
  inversion H.
  rewrite H2.
  apply IHb in H2.
  simpl.
  omega.
Qed.

Theorem lognat_correct : forall(a : nat)(pf : a <> 0),
  (expnat 2 (lognat pf)) <= a < (expnat 2 (S (lognat pf))).

  intros.
  split.
  remember (lognat pf) as b.
  apply (lognat_correct1 pf). auto.
  apply lognat_correct2.
Qed.

Lemma lognat_prod_sum_gen_h : forall (a' a b: nat)(pf1 : (a <> 0))(pf2 : (b <> 0))(pf3 : a * b <> 0),
  lognat pf1 = a' ->
  a' + lognat pf2 <= lognat pf3.

  induction a'; intros.
  simpl.
  eapply lognat_monotonic.
  induction a.
  congruence.
  simpl.
  intuition.

  destruct (nat_comp a).
  destruct H0.
  subst.
  assert (x <> 0). omega.
  assert (x * b <> 0). destruct x; destruct b; simpl; congruence.
  rewrite <- (lognat_prod_sum H0) in H.
  assert (lognat pf3 = S (lognat H1)).
  generalize pf3.
  rewrite mult_assoc_reverse.
  intros.
  rewrite (lognat_prod_sum _ pf0).
  trivial.

  rewrite H2.
  inversion H.
  specialize (IHa' x b H0 pf2 H1 H4).
  subst.
  omega.

  destruct (eq_nat_dec x 0).
  subst.
  unfold lognat in *.
  simpl in *.
  discriminate.

  assert (2 * x <> 0). omega.
  assert (x * b <> 0). destruct x; destruct b; simpl; congruence.
  assert (2 * x * b <> 0). rewrite mult_assoc_reverse. omega.
  subst.
  rewrite (lognat_odd _ H1) in H.
  rewrite <- (lognat_prod_sum n) in H.
  inversion H.
  subst.
  assert (lognat n = lognat n). trivial.
  specialize (IHa' x b n pf2 H2 H0).

  generalize pf3.
  assert (S (2 * x) * b = b + 2 * x * b). intuition.
  rewrite H4.
  intros.
  eapply le_trans.
  Focus 2.
  eapply (lognat_monotonic H3). intuition.
  generalize H3.
  rewrite mult_assoc_reverse.
  intros.
  rewrite <- (lognat_prod_sum H2).
  omega.
Qed.

Theorem lognat_prod_sum_gen : forall (a b: nat)(pf1 : (a <> 0))(pf2 : (b <> 0))(pf3 : a * b <> 0),
  lognat pf1 + lognat pf2 <= lognat pf3.

  intros.
  eapply lognat_prod_sum_gen_h.
  eauto.
Qed.

Lemma lognat_0_1 : forall n (pf : n <> 0),
  lognat pf = 0 -> n = 1.

  intros.
  destruct n.
  omega.

  destruct n.
  trivial.

  assert (2 <> 0). omega.
  assert (lognat pf >= lognat H0).
  eapply lognat_ge_monotonic.
  omega.

  unfold lognat in *.
  simpl in *.
  omega.
Qed.

Lemma lognat_succ_h : forall a n (pf1 : n <> 0)(pf2: (S n) <> 0),
  a = lognat pf1 ->
    lognat pf2 = a \/
    lognat pf2 = S (a).

  induction a; intros.
  assert (n = 1).
  apply (lognat_0_1 pf1).
  auto.
  subst.
  unfold lognat.
  simpl.
  auto.

  destruct (nat_comp n).
  destruct H0.
  subst.
  assert (x <> 0). omega.
  rewrite <- (lognat_prod_sum H0) in H.
  inversion H.
  subst.
  rewrite (lognat_odd _ pf1).
  rewrite <- (lognat_prod_sum H0).
  auto.

  subst.
  destruct (eq_nat_dec x 0).
  subst.
  unfold lognat in *.
  simpl in *.
  omega.

  generalize pf2.
  assert (S (S (2 * x)) = 2 * (S x)). omega.
  rewrite H0.
  intros.
  assert (S x <> 0). omega.
  assert (2 * x <> 0). omega.
  rewrite (lognat_odd _ H2) in H.
  rewrite <- (lognat_prod_sum n) in H.
  inversion H.
  rewrite <- (lognat_prod_sum H1).
  specialize (IHa x n H1 H4).
  destruct IHa.
  subst.
  rewrite H4.
  auto.
  subst.
  right.
  rewrite H3.
  auto.

Qed.

Lemma lognat_succ : forall n (pf1 : n <> 0)(pf2: (S n) <> 0),
  lognat pf2 = lognat pf1 \/
  lognat pf2 = S (lognat pf1).

  intros.
  eapply lognat_succ_h.
  eauto.
Qed.

Lemma logn_ge_1 : forall n (pf : n <> 0),
  n > 1 -> lognat pf >= 1.

  intros.
  destruct n.
  congruence.

  destruct n.
  omega.

  assert (2 <> 0).
  omega.

  assert (forall n (pf1 : S (S n) <> 0)(pf2 : 2 <> 0), lognat pf1 >= lognat pf2).
  intros.
  eapply lognat_ge_monotonic.
  omega.

  assert (forall (pf : 2 <> 0), 1 = lognat pf).
  intros.
  unfold lognat.
  auto.

  rewrite (H2 H0).
  eauto.

Qed.


Section ExistsUnique.

  Variables (A : Type) (P : A -> Prop).

  (*
Example 3.6.1

1. ∃x(P(x) ∧ ∀y(P(y) → y = x))                (= ∃!x P(x))
2. ∃x∀y(P(y) ↔ y = x).
3. ∃x P(x) ∧ ∀y∀z((P(y) ∧ P(z)) → y = z).
   *)

  (* 1 -> 2 *)
  Goal (exists ! x, P x) -> (exists x, forall y, P y <-> x = y).
  Proof.
    unfold unique.
    intros.
    destruct H as [x0].
    destruct H as [H1 H2].
    (* Givens and Goal p.147 *)
    exists x0.
    intros.
    split.
    - now apply H2.
    - intros Hx0y.
      now rewrite <- Hx0y.
  Qed.

  (* 2 -> 3 *)
  Goal (exists x, forall y, P y <-> x = y) ->
  (exists x, P x /\ (forall y z, P y /\ P z -> y = z)).
  Proof.
    intros.
    destruct H as [x0].
    exists x0.
    split.
    - destruct (H x0).
      now apply H1.
    - intros y z [H1 H2].
      (* Givens and Goal p.148 *)
      destruct (H y) as [H3 H4].
      destruct (H z) as [H5 H6].
      now rewrite <- H3, <- H5.
  Qed.

  (* 3 -> 1 *)
  Goal (exists x, P x /\ (forall y z, P y /\ P z -> y = z)) ->
  (exists ! x, P x).
  Proof.
    unfold unique.
    intros H.
    destruct H as [x0].
    destruct H as [H1 H2].
    exists x0.
    (* Givens and Goal p.148 *)
    split.
    - easy.
    - intros y H3.
      now apply (H2 x0 y).
  Qed.

End ExistsUnique.


Require Import ZArith.

Definition INC : Z := 2.

Module hddivsteps.

Record State : Set :=
 { delta : Z
 ; f : Z
 ; g : Z
 ; d : Z
 ; e : Z
 ; modulus : Z
 }.

Definition init f g :=
{| delta := 1
 ; f := f
 ; g := g
 ; d := 0
 ; e := 1
 ; modulus := f
 |}.

Section Step.

Let div2M (M x : Z) : Z :=
 (if Z.odd x then x + M else x) / 2.

Definition step (st : State) : State :=
if Z.even (g st)
  then {| delta := INC + delta st
        ; f := f st
        ; g := g st / 2
        ; d := d st
        ; e := div2M (modulus st) (e st)
        ; modulus := modulus st
        |}
  else if (0 <? delta st)%Z
         then {| delta := INC - delta st
               ; f := g st
               ; g := (g st - f st) / 2
               ; d := e st
               ; e := div2M (modulus st) (e st - d st)
               ; modulus := modulus st
               |}
         else {| delta := INC + delta st
               ; f := f st
               ; g := (g st + f st) / 2
               ; d := d st
               ; e := div2M (modulus st) (e st + d st)
               ; modulus := modulus st
               |}.

Lemma modulus_step : forall st, modulus (step st) = modulus st.
Proof.
intros [delta f g d e modulus].
unfold step.
cbn -[Z.ltb Z.add Z.sub] in *.
case (Z.even g) eqn:Hg;[|case (0 <? delta)%Z];auto.
Qed.

Lemma odd_step : forall st, Z.Odd (f st) ->
   Z.Odd (f (step st)).
Proof.
intros [delta f g] Hf.
unfold step.
cbn -[Z.ltb Z.add Z.sub] in *.
case (Z.even g) eqn:Hg;[|case (0 <? delta)%Z];auto.
simpl.
rewrite <- Z.odd_spec, Zodd_even_bool, Hg.
reflexivity.
Qed.

Lemma zero_step : forall st, g st = 0%Z ->
   g (step st) = 0%Z.
Proof.
intros [delta f g]; simpl.
intros ->.
reflexivity.
Qed.

Lemma d_zero_spec : forall (n:nat) st,
  g st = 0%Z ->
  d (Nat.iter n step st) = d st.
Proof.
intros n [delta f g d e M]; simpl.
set (st := Build_State _ _ _ _ _ _).
intros ->.
cut (hddivsteps.g (Nat.iter n step st) = 0%Z /\ hddivsteps.d (Nat.iter n step st) = d).
 tauto.
induction n; auto.
simpl.
destruct IHn as [IHn1 IHn2].
split;auto using zero_step.
unfold step at 1.
rewrite IHn1.
assumption.
Qed.

Definition gcd (st : State) : Z :=
  Z.gcd (f st) (g st).

Lemma gcd_step : forall st, Z.Odd (f st) ->
  gcd (step st) = gcd st.
Proof.
assert (Hgcd : forall f g, Z.Odd f -> Z.Even g -> Z.gcd f (g / 2) = Z.gcd f g).
  intros f g Hf Hg.
  rewrite <- Zdiv2_div.
  replace g with (2 * Z.div2 g)%Z at 2 by
   (symmetry;
    apply Zeven_div2;
    rewrite Zeven_equiv;
    assumption).
  generalize (Z.div2 g); intros g'.
  symmetry.
  apply Znumtheory.Zis_gcd_gcd;[apply Z.gcd_nonneg|].
  constructor;[apply Z.gcd_divide_l|apply Z.divide_mul_r; apply Z.gcd_divide_r|].
  intros x Hxf Hxg'.
  apply Z.gcd_greatest; auto.
  apply Znumtheory.Gauss with 2%Z; auto.
  apply Znumtheory.rel_prime_sym.
  apply Znumtheory.prime_rel_prime;[apply Znumtheory.prime_2|].
  intros H2x.
  apply Z.Even_Odd_False with f; auto.
  rewrite <-Zeven_equiv, Zeven_ex_iff.
  exists (f / 2)%Z.
  apply Znumtheory.Zdivide_Zdiv_eq; auto with *.
  apply Z.divide_transitive with x; auto.
intros [delta f g] Hf.
unfold step, gcd.
cbn -[Z.ltb Z.add Z.sub] in *.
case (Z.even g) eqn:Hg;[|case (0 <? delta)%Z];cbn -[Z.add Z.sub].
* rewrite Z.even_spec in Hg.
  apply Hgcd; auto.
* rewrite (Z.gcd_comm f g), <- (Z.gcd_sub_diag_r g f).
  replace (f - g)%Z with (-(g - f))%Z by ring.
  rewrite Z.gcd_opp_r.
  apply Hgcd;
  [ rewrite <- Z.odd_spec, <- Z.negb_even, Hg; reflexivity
  | rewrite <- Z.odd_spec in Hf;
    rewrite <- Z.even_spec, Z.even_sub, Hg, Zeven.Zeven_odd_bool, Hf
  ]; reflexivity.
* rewrite <- (Z.gcd_add_diag_r f g).
  apply Hgcd; auto.
  rewrite <- Z.odd_spec in Hf.
  rewrite <- Z.even_spec, Z.even_add, Hg, Zeven.Zeven_odd_bool, Hf.
  reflexivity.
Qed.

Lemma gcd_spec : forall (n:nat) st,
  Z.Odd (f st) ->
  g (Nat.iter n step st) = 0%Z ->
  Znumtheory.Zis_gcd (f st) (g st) (f (Nat.iter n step st)).
Proof.
intros n [delta f g] Hf Hg; simpl in *.
set (d := hddivsteps.f _).
cut (Znumtheory.Zis_gcd f g (Z.abs d) /\ Z.Odd d).
  destruct (Z.abs_eq_or_opp d) as [-> | ->];intros [H _];[auto|].
  replace d with (- - d)%Z by ring.
  auto using Znumtheory.Zis_gcd_sym, Znumtheory.Zis_gcd_opp.
rewrite <- Z.gcd_0_r, <- Hg.
clear Hg.
induction n;[auto using Znumtheory.Zgcd_is_gcd|].
destruct IHn as [IHn1 IHn2].
split;[|apply odd_step; auto].
unfold d; simpl.
set (st' := (Nat.iter n _ _ )) in *.
fold (gcd (step st')).
rewrite (gcd_step st'); auto.
Qed.

Let modulo_invariant (x : Z) (st : State) :=
 eqm (modulus st) (f st) (d st * x) /\
 eqm (modulus st) (g st) (e st * x).

Definition inv2M (M : Z) : Z :=
 let 'Znumtheory.Euclid_intro _ _ u _ d _ _ := Znumtheory.euclid 2 M in (d*u).

Lemma mul_inv2M : forall M, Z.Odd M -> eqm M (inv2M M * 2) 1.
Proof.
intros M HM.
unfold inv2M.
destruct (Znumtheory.euclid 2 M) as [u v d Hd Hgcd].
assert (H : Znumtheory.rel_prime 2 M).
 apply Znumtheory.prime_rel_prime.
  apply Znumtheory.prime_2.
 intros Heven.
 apply (Zeven_not_Zodd M).
 rewrite Znumtheory.Zdivide_Zdiv_eq with 2%Z M; auto with *.
  apply Zeven_2p.
 apply Zodd_equiv; auto.
destruct (Znumtheory.Zis_gcd_uniqueness_apart_sign _ _ _ _ Hgcd H) as [Heq|Heq];
 rewrite Heq in *;
[|apply (f_equal Z.opp) in Hd;rewrite Z.opp_involutive in Hd;
  replace (- (u * 2 + v * M))%Z with (- u*2 + (-v) * M)%Z in Hd by ring];
 rewrite <- Hd at 2;
 unfold eqm;
 rewrite <- Zplus_mod_idemp_r, <- (Zmult_mod_idemp_r M), Z_mod_same_full,
         Z.mul_0_r, Z.add_0_r;
 f_equal.
ring.
Qed.

Lemma mul_inv2M_even : forall M x, Z.Odd M -> Z.Even x ->
 eqm M (x / 2) (inv2M M * x).
Proof.
intros M x HM Hx.
rewrite <- Z.div2_div.
rewrite (Zeven_div2 x) at 2; [|apply Zeven_equiv;auto].
rewrite Zmult_assoc.
replace (Z.div2 x) with (1*Z.div2 x)%Z at 1 by ring.
apply Zmult_eqm;try reflexivity.
auto using eqm_sym, mul_inv2M.
Qed.

Lemma eqm_div2M : forall M x, Z.Odd M -> eqm M (div2M M x) (inv2M M * x).
Proof.
intros M x HM.
rewrite <- (Z.mul_1_l (div2M M x)).
apply eqm_trans with ((inv2M M * 2) * div2M M x)%Z.
 apply Zmult_eqm; try reflexivity.
 apply eqm_sym.
 apply mul_inv2M; auto.
rewrite <- Zmult_assoc.
apply Zmult_eqm; try reflexivity.
unfold div2M.
case (Z.odd x) eqn:Hx.
* apply Zodd_bool_iff in Hx.
  apply Zodd_equiv in HM.
  rewrite <- Zdiv2_div, <- Zeven_div2; auto using Zodd_plus_Zodd.
  unfold eqm; rewrite Zplus_mod.
  rewrite <- (Zmod_eqm M M), Z_mod_same_full, Z.add_0_r.
  apply Zmod_mod.
* apply (f_equal negb) in Hx.
  rewrite Z.negb_odd in Hx.
  apply Zeven_bool_iff in Hx.
  rewrite <- Zdiv2_div, <- Zeven_div2; auto.
  reflexivity.
Qed.

Lemma eqm_div2M' : forall M x y, Z.Odd M ->
 eqm M (inv2M M * (x * y)) (div2M M x * y).
Proof.
intros M x y HM.
rewrite Zmult_assoc.
apply Zmult_eqm;try reflexivity.
auto using eqm_div2M, eqm_sym.
Qed.

Lemma modulo_step : forall x st, Z.Odd (modulus st) -> Z.Odd (f st) ->
  modulo_invariant x st ->
  modulo_invariant x (step st).
Proof.
intros x [delta f g d e M] HM Hf [Heqf Heqg].
unfold modulo_invariant.
rewrite modulus_step.
simpl in *.
destruct (Z.eq_dec M 1%Z) as [->|HM1].
 unfold eqm.
 rewrite !Z.mod_1_r; auto with *.
destruct (Z.eq_dec M (-1)%Z) as [->|HM1'].
 unfold eqm.
 rewrite !(Z_mod_zero_opp_r _ _ (Z.mod_1_r _)); auto with *.
assert (HM0 : M <> 0%Z).
 rewrite <- Z.odd_spec in HM.
 intros HM0.
 rewrite HM0 in HM.
 discriminate.
assert (HM2 : (2 mod M)%Z <> 0%Z).
 rewrite <- Z.odd_spec in HM.
 intros H.
 apply Znumtheory.Zmod_divide in H; auto with *.
 apply Znumtheory.prime_divisors in H; auto using Znumtheory.prime_2.
 destruct H as [H|[H|[H|H]]]; try contradiction; rewrite H in HM; discriminate.
unfold step.
cbn -[Z.ltb Z.add Z.sub] in *.
case (Z.even g) eqn:Hg;[|case (0 <? delta)%Z];simpl;split;auto.
* apply Zeven_bool_iff in Hg.
  apply Zeven_equiv in Hg.
  eapply eqm_trans;[apply mul_inv2M_even;auto|].
  eapply eqm_trans;[|apply eqm_div2M';auto].
  apply Zmult_eqm;try reflexivity.
  assumption.
* apply (f_equal negb) in Hg.
  rewrite Z.negb_even in Hg.
  rewrite Zodd_bool_iff in Hg.
  apply Zodd_equiv in Hg.
  eapply eqm_trans;[apply mul_inv2M_even;auto|].
   apply Zeven_equiv.
   apply Zodd_plus_Zodd; apply Zodd_equiv; auto.
   apply Z.odd_spec.
   rewrite Z.odd_opp.
   apply Z.odd_spec.
   assumption.
  eapply eqm_trans;[|apply eqm_div2M';auto].
  apply Zmult_eqm;try reflexivity.
  replace ((e - d)*x)%Z with (e * x - d * x)%Z by ring.
  apply Zminus_eqm; auto.
* apply (f_equal negb) in Hg.
  rewrite Z.negb_even in Hg.
  rewrite Zodd_bool_iff in Hg.
  apply Zodd_equiv in Hg.
  eapply eqm_trans;[apply mul_inv2M_even;auto|].
   apply Zeven_equiv.
   apply Zodd_plus_Zodd; apply Zodd_equiv; auto.
  eapply eqm_trans;[|apply eqm_div2M';auto].
  apply Zmult_eqm;try reflexivity.
  replace ((e + d)*x)%Z with (e * x + d * x)%Z by ring.
  apply Zplus_eqm; auto.
Qed.

Lemma modulo_spec : forall (n:nat) st x,
  Z.Odd (modulus st) ->
  Z.Odd (f st) ->
  modulo_invariant x st ->
  Znumtheory.rel_prime (f st) (g st) ->
  let st' := (Nat.iter n step st) in
  g st' = 0%Z ->
  Z.abs (f st') = 1%Z /\
  eqm (modulus st) ((d st' * f st') * x) 1.
Proof.
intros n st x HM Hf Hinv Hprime st' Hg.
assert (HMeq : modulus st = modulus st').
 clear.
 induction n;try reflexivity.
 unfold st'.
 rewrite IHn.
 simpl.
 rewrite modulus_step.
 reflexivity.
assert (Hinv' : modulo_invariant x st').
 clear -HM Hf Hinv.
 cut (Z.Odd (modulus st') /\ (Z.Odd (f st') /\ modulo_invariant x st'));[tauto|].
 induction n; auto.
 destruct IHn as [IHn1 [IHn2 IHn3]].
 unfold st'.
 simpl.
 split;[rewrite modulus_step;auto|].
 split;[apply odd_step;auto|].
 apply modulo_step; auto.
destruct Hinv' as [Hinv' _].
rewrite (Zmult_comm (d st') _), <- Zmult_assoc.
rewrite <- HMeq in Hinv'.
assert (Hgcd := gcd_spec n st Hf Hg).
fold st' in Hgcd.
assert (H1 : Z.abs (f st') = 1%Z).
destruct (Znumtheory.Zis_gcd_uniqueness_apart_sign _ _ _ _ Hgcd Hprime) as [->| ->];
 auto.
split; auto.
change 1%Z with (1 * 1)%Z.
rewrite <- H1.
rewrite Z.abs_square.
apply eqm_sym.
apply Zmult_eqm; auto; reflexivity.
Qed.

Lemma modulo_init : forall f g, modulo_invariant g (init f g).
Proof.
intros f g.
split; unfold init; cbn -[Zmult]; unfold eqm.
* rewrite Z_mod_same_full, Z.mul_0_l, Zmod_0_l; reflexivity.
* rewrite Z.mul_1_l; reflexivity.
Qed.

End Step.
End hddivsteps.


Inductive mynat : Set := Zero : mynat | Succ : mynat -> mynat.

Fixpoint myplus n m : mynat :=
match n with
  | Zero => m
  | Succ p => Succ (myplus p m)
end.

Lemma plus_n_0 : forall n : mynat, myplus n Zero = n.
Proof.
induction n.
(*simpl.*)
reflexivity.

simpl.
rewrite -> IHn.
reflexivity.
Qed.


Definition nandb (b1:bool) (b2:bool) : bool :=
  match b1 with
  | true => negb b2
  | false => true
  end.
Example test_nandb1: (nandb true false) = true.
Proof. simpl. reflexivity. Qed.
Example test_nandb2: (nandb false false) = true.
Proof. simpl. reflexivity. Qed.
Example test_nandb3: (nandb false true) = true.
Proof. simpl. reflexivity. Qed.
Example test_nandb4: (nandb true true) = false.
Proof. simpl. reflexivity. Qed.

Definition andb3 (b1:bool) (b2:bool) (b3:bool) : bool :=
  andb (andb b1 b2) b3.
Example test_andb31: (andb3 true true true) = true.
Proof. simpl. reflexivity. Qed.
Example test_andb32: (andb3 false true true) = false.
Proof. simpl. reflexivity. Qed.
Example test_andb33: (andb3 true false true) = false.
Proof. simpl. reflexivity. Qed.
Example test_andb34: (andb3 true true false) = false.
Proof. simpl. reflexivity. Qed.

Fixpoint factorial (n:nat) : nat :=
  match n with
  | O => 1
  | S n => S n * factorial n
  end.
Example test_factorial1: (factorial 3) = 6.
Proof. simpl. reflexivity. Qed.
Example test_factorial2: (factorial 5) = (mult 10 12).
Proof. simpl. reflexivity. Qed.

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

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

Notation "x =? y" := (eqb x y) (at level 70) : nat_scope.
Notation "x <=? y" := (leb x y) (at level 70) : nat_scope.

Definition ltb (n m : nat) : bool :=
  negb (leb m n).
Notation "x <? y" := (ltb x y) (at level 70) : nat_scope.
Example test_ltb1: (ltb 2 2) = false.
Proof. simpl. reflexivity. Qed.
Example test_ltb2: (ltb 2 4) = true.
Proof. simpl. reflexivity. Qed.
Example test_ltb3: (ltb 4 2) = false.
Proof. simpl. reflexivity. Qed.

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

Theorem mult_S_1 : forall n m : nat,
  m = S n ->
  m * (1 + n) = m * m.
Proof.
  intros n m.
  intros H.
  rewrite -> H.
  reflexivity.
  Qed.

Theorem andb_true_elim2 : forall b c : bool,
  andb b c = true -> c = true.
Proof.
  intros [] [].
  reflexivity.
  simpl.
  intros H.
  rewrite -> H.
  reflexivity.
  simpl.
  reflexivity.
  simpl.
  intros H.
  rewrite -> H.
  reflexivity.
  Qed.

Theorem zero_nbeq_plus_1 : forall n : nat,
  0 =? (n + 1) = false.
Proof.
  intros [].
  - reflexivity.
  - reflexivity.
  Qed.

Theorem identity_fn_applied_twice :
  forall (f : bool -> bool),
  (forall (x : bool), f x = x) ->
  forall (b : bool), f (f b) = b.
Proof.
  intros.
  rewrite -> H.
  rewrite -> H.
  reflexivity.
  Qed.

Theorem negation_fn_applied_twice :
  forall (f : bool -> bool),
  (forall (x : bool), f x = negb x) ->
  forall (b : bool), f (f b) = b.
Proof.
  intros.
  rewrite -> H.
  rewrite -> H.
  destruct b.
  reflexivity.
  reflexivity.
  Qed.

Theorem andb_eq_orb :
  forall (b c : bool),
  (andb b c = orb b c) ->
  b = c.
Proof.
  intros [] [].
  reflexivity.
  simpl.
  intros H.
  rewrite -> H.
  reflexivity.
  simpl.
  intros H.
  rewrite -> H.
  reflexivity.
  reflexivity.
  Qed.

Inductive bin : Type :=
  | Z
  | A (n : bin)
  | B (n : bin).

Fixpoint incr (m:bin) : bin :=
  match m with
  | Z => B Z
  | A n => B n
  | B n => A (incr n)
  end.

Fixpoint decr (m:bin) : bin :=
  match m with
  | Z => Z
  | A n => B (decr n)
  | B n => match n with
           | Z => Z
           | _ => A n
           end
  end.

Fixpoint bin_to_nat (m:bin) : nat :=
  match m with
  | Z => O
  | A n => 2 * bin_to_nat n
  | B n => 1 + 2 * bin_to_nat n
  end.


Require Import A1_Plan A2_Orientation .
Require Import C1_Distance .
Require Import D1_IntersectionCirclesProp .
Require Import F5_Tactics .
Require Import G1_Angles.

Section ANGLE_PROPERTIES.

Lemma  EqAngleUniquePointSide1 : forall A B C D : Point,
	CongruentAngle C A B D A B ->
	Distance A C = Distance A D ->
	~Clockwise A C B ->
	~Clockwise A D B ->
	C = D.
Proof.
	intros.
	apply (EqThirdPoint A B).
	 apply (CongruentAngleDistinctBC C A B D A B H) .
	 immediate5.
	 apply (CongruentSAS A B C A B D).
	  immediate5.
	  immediate5.
	  apply CongruentAngleRev; immediate5.
	 immediate5.
	 immediate5.
Qed.

Lemma  EqAngleUniquePointSide2 : forall A B C D : Point,
	CongruentAngle B A C B A D  ->
	Distance A C = Distance A D ->
	~Clockwise A B C ->
	~Clockwise A B D ->
	C = D.
Proof.
	intros.
	apply (EqThirdPoint B A).
	 apply sym_not_eq; apply (CongruentAngleDistinctBA B A C B A D H).
	 apply (CongruentSAS A B C A B D); immediate5.
	 immediate5.
	 immediate5.
	 immediate5.
Qed.

Lemma  EqAngleOpenRay1 : forall A B C D : Point,
	CongruentAngle C A B D A B ->
	~Clockwise A C B ->
	~Clockwise A D B ->
	OpenRay A C D.
Proof.
	intros.
	setMarkSegmentPoint5 A D A C ipattern:(E).
	 apply (CongruentAngleDistinctED C A B D A B H).
	 since5 (C = E).
	  apply (EqAngleUniquePointSide1 A B C E).
	   apply (CongruentAngleTrans C A B D A B E A B).
	    immediate5.
	    apply CongruentAngleSide1.
	     immediate5.
	     apply (CongruentAngleDistinctBC C A B D A B H).
	     step5 H4.
	       step5 H3.
	       apply (CongruentAngleDistinctBA C A B D A B H).
	   immediate5.
	   immediate5.
	   intro; elim H1; step5 H4.
	  rewrite H5; immediate5.
Qed.

Lemma  EqAngleOpenRay2 : forall A B C D : Point,
	CongruentAngle B A C B A D ->
	~Clockwise A B C ->
	~Clockwise A B D ->
	OpenRay A C D.
Proof.
	intros.
	setMarkSegmentPoint5 A D A C ipattern:(E).
	 apply (CongruentAngleDistinctEF B A C B A D H).
	 since5 (C = E).
	  apply (EqAngleUniquePointSide2 A B C E).
	   apply (CongruentAngleTrans B A C B A D B A E).
	    immediate5.
	    apply CongruentAngleSide2.
	     apply (CongruentAngleDistinctBA B A C B A D H).
	     immediate5.
	     step5 H4.
	       step5 H3.
	       apply (CongruentAngleDistinctBC B A C B A D H).
	   immediate5.
	   immediate5.
	   intro; elim H1; step5 H4.
	  rewrite H5; immediate5.
Qed.

End ANGLE_PROPERTIES.


(* Software Foundations *)
(* Exercice 3 stars, partition *)

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

Arguments nil {X}.
Arguments cons {X} _ _.

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

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

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

Arguments pair {X} {Y} _ _.

Notation "( x , y )" := (pair x y).
Notation "X * Y" := (prod X Y): type_scope.

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

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

Definition partition{X: Type}(test: X -> bool)(l: list X): list X * list X :=
    (filter test l, filter (fun x => notb (test x)) l).

Example test_partition1: partition Nat.odd [1;2;3;4;5] = ([1;3;5], [2;4]).
Proof. reflexivity. Qed.

Example test_partition2: partition (fun x => false) [5;9;0] = ([], [5;9;0]).
Proof. reflexivity. Qed.


(*
Z_3 háromelemű (véges) típus, Z_3={0, 1, 2} ill. {n, a, b}
*)

Inductive Z_3 : Set :=
  | n : Z_3
  | a : Z_3
  | b : Z_3.

(*
Legyen belőle csoport, ami egy olyan algebrai struktúra, ahol van

op: G->G->G művelet,

ahol op asszociatív,

van z neutrális elem: op z x = x = op x z

van inv: inverz : op x (inv) x = z = op (inv x) x

Z_3-ban ez az összeadás:

*)

Definition ope (x:Z_3) (y:Z_3) :=
  match x , y with
  | n , y => y
  | x , n => x
  | a , b => n
  | b , a => n
  | a , a => b
  | b , b => a
  end.

Definition inve (x:Z_3) :=
  match x with
  | n => n
  | a => b
  | b => a
  end.

(*Absztrakt csoport definíciója Structure vagy Record környezettel: *)

Structure Group : Type := const_kozos
{
  A :> Set;

  op : A -> A -> A ;
  inv : A -> A ;
  z : A ;

  op_assoc : forall a b c, op a (op b c) = op (op a b) c;
  op_z : forall a, op a z = a /\ op z a = a ;
  op_inverse : forall a, op a (inv a) = z /\ op (inv a) a = z
}.

(*Z_3 a műveletekkel valóban csoport, amit
 a Group típus Z_3_group jelölésű eleme mutat, aminek a definíciója: *)

Theorem Z_3_group : Group.
Proof.
  apply (const_kozos Z_3 ope inve n).
  induction a0, b0, c; compute; auto.
  induction a0; auto.
  induction a0; auto.
Defined.

(*Minden véges típus algoritmikusan eldönthető, így Z_3 is: *)

Theorem Z_3_eq_dec : forall (x y: Z_3), x = y \/ x <> y.
Proof.
  induction x, y; auto; right; discriminate.
  Show Proof.
Defined.

(*A morfizmusok őshonos állatfajok a típuselméletben,
így a csoportok közötti G->H művelettartó leképezések is *)

Definition GroupMorphism (G:Group) (H:Group) (f:G->H) : Prop :=
    f(z G)=z H /\
    forall a:G, f(inv G a)=inv H (f(a)) /\
    forall a b : G, f(op G a b) = op H (f(a)) (f(b)).

(*Pl. a Z_1->Z_3, e|--->n leképezés is egy csoportmorfizmus *)

Inductive Z_1 : Set :=
  | e : Z_1.

Definition ope_1 (x:Z_1) (y:Z_1) :=
  match x , y with
  | e , e => e
  end.

Definition inve_1 x:Z_1 :=
  match x with
  | e => e
  end.

Theorem Z_1_group : Group.
Proof.
  apply (const_kozos Z_1 ope_1 inve_1 e).
  induction a0, b0, c; compute; auto.
  induction a0; auto.
  induction a0; auto.
Defined.

Definition f_Z_1_Z_3 : Z_1->Z_3 := fun (x:Z_1) => match x with e => n end.

Theorem f_Z_1_Z_3_csoportmorfizmus : GroupMorphism (Z_1_group) (Z_3_group) f_Z_1_Z_3.
Proof.
  unfold GroupMorphism.
  split.
  compute; auto.
  split.
  induction a0.
  compute; auto.
  induction a0, b0.
  induction a0.
  compute; auto.
Qed.


(*
Guido Salazar
Taller 3 Logica Computacional
*)

Section LP1.
Variables P Q R S T : Prop.

(* 1 *)
Lemma weak_peirce : ((((P -> Q) -> P) -> P) -> Q) -> Q.
Proof.
intro.
apply H.
intro.
apply H0.
intro.
apply H.
intro.
assumption.
Qed.

(* 2 *)
Lemma then_bsc : (P -> Q) -> (Q -> R) -> P -> R.
Proof.
intros.
apply H0.
apply H.
assumption.
Qed.

(* 3 *)
Lemma contraposition : ((P -> Q) -> (~Q -> ~P)).
Proof.
intros.
intro.
destruct H0.
apply H.
assumption.
Qed.

(* 4 *)
Lemma contraposition' : (~P -> ~Q) <-> (~~Q -> ~~P).
Proof.
split.
intros.
intro.
apply H.
assumption.
destruct H0.
apply H.
assumption.
intros.
intro.
apply H.
intro.
destruct H2.
assumption.
assumption.
Qed.

(* 5 *)
Lemma impl_cmpl : (P <-> Q) -> (Q <-> R) -> (P <-> R).
Proof.
intros.
destruct H.
destruct H0.
split.
intro.
apply H0.
apply H.
assumption.
intro.
apply H1.
apply H2.
assumption.
Qed.

(* 6 *)
Lemma then_ext : (P -> Q) -> (P -> R) -> (Q -> R -> S) -> P -> S.
Proof.
intros.
apply H1.
apply H.
assumption.
apply H0.
assumption.
Qed.

End LP1.

Section LP2.
Variables P Q R S T : Prop.

(* 7 *)
Lemma and_assoc : P /\ (Q /\ R) -> (P /\ Q) /\ R.
Proof.
intro.
destruct H.
destruct H0.
split.
split.
assumption.
assumption.
assumption.
Qed.

(* 8 *)
Lemma and_imp_dist : (P -> Q) /\ (R -> S) -> P /\ R -> Q /\ S.
Proof.
intro.
destruct H.
intro.
destruct H1.
split.
apply H.
assumption.
apply H0.
assumption.
Qed.

(* 9 - Resolver usando Contradicction *)
Lemma not_contrad : ~(P /\ ~P).
Proof.
intro.
destruct H.
contradiction.
Qed.

(* 10 *)
Lemma or_and_not : (P \/ Q) /\ ~P -> Q.
Proof.
intro.
destruct H.
destruct H.
contradiction.
assumption.
Qed.

(* 11 *)
Lemma de_morgan_1 : ~(P \/ Q) -> ~P /\ ~Q.
Proof.
intro.
split.
intro.
destruct H.
left.
assumption.
intro.
destruct H.
right.
assumption.
Qed.

(* 12 *)
Lemma de_morgan_2 : ~P /\ ~Q -> ~(P \/ Q).
intro.
destruct H.
intro.
destruct H1.
contradiction.
contradiction.
Qed.

(* 13 *)
Lemma de_morgan_3 : ~P \/ ~Q -> ~(P /\ Q).
Proof.
intro.
intro.
destruct H0.
destruct H.
contradiction.
destruct H.
assumption.
Qed.

(* 14 *)
Lemma b_mx : P \/ (Q /\ R) <-> (P \/ Q) /\ (P \/ R).
Proof.
split.
intro.
destruct H.
split.
left.
assumption.
left.
assumption.
destruct H.
split.
right.
assumption.
right.
assumption.
intro.
destruct H.
destruct H.
left.
assumption.
destruct H0.
left.
assumption.
right.
split.
assumption.
assumption.
Qed.

End LP2.

(* 15 *)
Section S0.
Variables P Q : Prop.
Hypothesis H0 : P -> Q.
Hypothesis H1 : ~P -> Q.
Lemma weak_exm : ~~Q.
Proof.
unfold not.
intro.
apply H.
apply H1.
intro.
apply H.
apply H0.
assumption.
Qed.

End S0.

(* 16 *)
(*
P : Aprobare Lógica
Q : Dios Quiere/ Dios quiere que apruebe.
R : Estudie
S : Hice todo los ejercicios
*)

(* Sección con Q : Dios quiere que apruebe*)
Section S1.
Variables P Q R S: Prop.
Hypothesis H : Q -> P.
Hypothesis H0 : P <-> (R /\ S).
Lemma weak_exm2 : ~S -> (~Q->~P).
Proof.
intros.
destruct H0.
intro.
destruct H1.
apply H3.
assumption.
Qed.

End S1.

(* Sección con Q : Dios quiere*)
Section S2.

Variables P Q R S: Prop.
Hypothesis H : Q -> P.
Hypothesis H0 : P <-> (R /\ S).
Lemma weak_exm1 : ~S -> ~Q.
Proof.
intro.
destruct H0.
intro.
destruct H1.
apply H2.
apply H.
assumption.
Qed.

End S2.


Require Import Omega.
Require Import Nat.
Require Export Arith_base.
Require Import Arith.Even.
Require Import BinPos BinInt BinNat Pnat Nnat.
Require Import PeanoNat.
Require Import ZArith_base.
Require Import ZArithRing.
Require Import Zcomplements.
Require Import Zdiv.
Require Import Wf_nat.

Lemma even_exists : forall x : nat,
Nat.even x = true -> exists k, 2*k = x.
Proof.
intros.
apply Nat.even_spec in H.
unfold Nat.Even in H.
destruct H.
exists x0.
auto.
Qed.

Lemma even_minus_even_is_even : forall x a : nat,
    Nat.even(x + 2*a) = true -> Nat.even(x) = true.
Proof.
intros.
apply Nat.even_spec in H.
unfold Nat.Even in H.
apply Nat.even_spec.
unfold Nat.Even.
destruct H.
apply f_equal with (f := fun t => t- 2*a) in H.
replace (x + 2*a - 2*a) with (x) in H.
replace (2*x0 - 2*a) with (2*(x0-a)) in H.
exists (x0-a).
assumption.
omega.
omega.
Qed.

Theorem two_times_x_even : forall x : nat, Nat.even(2 * x) = true.
Proof.
  simpl.
  induction x.
  auto.
  rewrite Nat.add_0_r.
  rewrite Nat.add_0_r in IHx.
  replace (S x + S x) with (S (S (x + x))).
  simpl.
  apply IHx.
  simpl.
  auto.
Qed.

Axiom trivial : forall x : nat, 2*(x-1) +1 = 2*x - 1.

  Lemma even_plus_one_is_odd : forall x : nat, Nat.even(x+1) = true -> Nat.odd(x) = true.
Proof.
intros.
apply Nat.even_spec in H.
apply Nat.odd_spec.
unfold Nat.Odd.
unfold Nat.Even in H.
destruct H.
apply f_equal with (f := fun t => t-1) in H.
replace (x +1-1) with (x) in H.
replace (2*x0 -1) with (2*(x0-1) + 1) in H.
exists (x0-1).
assumption.
apply trivial.
omega.
Qed.

  Theorem easy : forall p q : Prop, (p->q) -> (~q->~p).
Proof.
intros.
intro.
apply H0.
apply H.
assumption.
Qed.

Lemma not_even_not_odd : forall n, even n -> odd n -> False.
Proof.
induction n.
intros even_0 odd_0.
inversion odd_0.
intros even_Sn odd_Sn.
inversion even_Sn.
inversion  odd_Sn.
auto with arith.
Qed.

Axiom not_even_implies_odd: forall x : nat, Nat.even(x) <> true -> Nat.odd(x) = true.
Theorem square_even_is_even : forall x : nat, Nat.even(x * x) = true <->  Nat.even(x) = true.
Proof.
intros.
induction x.
simpl.
split.
auto.
auto.
split.
intros.
replace (S x  * S x) with ((x*x + 1) + 2*x) in H.
assert (forall p q : nat, Nat.even(p+2*q) = true -> Nat.even(p) = true).
apply even_minus_even_is_even.
assert (Nat.even(x*x+1) = true).
destruct (H0 (x*x+1) (x)).
assumption.
auto.
assert (Nat.odd(x*x) = true).
apply even_plus_one_is_odd.
assumption.
destruct IHx.
assert (Nat.odd x = true).
assert (~Nat.even(x*x) = true -> ~Nat.even(x) = true).
apply easy.
assumption.
assert (Nat.even(x*x) <> true).
unfold not.
intros.
assert (forall n : nat, (Nat.Even(n) -> Nat.Odd(n) -> False)).
intros.
apply even_equiv in H7.
apply odd_equiv in H8.
cut (odd n).
cut (even n).
apply not_even_not_odd.
assumption.
assumption.
destruct (H7 (x*x)).
cut (Nat.even(x*x) = true).
apply Nat.even_spec.
assumption.
cut (Nat.odd(x*x) = true).
apply Nat.odd_spec.
assumption.
assert (Nat.even x <> true).
apply H5.
assumption.
cut (Nat.even x <> true).
apply not_even_implies_odd.
assumption.
replace (S x) with (x+1).
cut (Nat.odd(1)= true).
cut (Nat.odd(x) = true).
rewrite Nat.even_spec.
repeat rewrite Nat.odd_spec.
rewrite <-  even_equiv.
repeat rewrite <- odd_equiv.
apply odd_even_plus.
assumption.
auto.
omega.
simpl.
replace (S x) with (x+1).
rewrite Nat.mul_add_distr_l.
repeat omega.
omega.
intros.
rewrite Nat.even_spec in H.
rewrite Nat.even_spec.
unfold Nat.Even in H.
unfold Nat.Even.
destruct H.
replace (S x) with (2*x0).
exists (2*x0*x0).
rewrite <- Nat.mul_assoc.
apply f_equal.
rewrite Nat.mul_assoc.
replace (x0*2) with (2*x0).
auto.
omega.
Qed.

Theorem root_2_irr : forall p q : nat,p * p <> 2 * q * q.
  Proof.
  intros.
  unfold not.
  intros eq.
  assert (Nat.even(p*p) = true).
  rewrite eq.
  replace (2*q*q) with (2*(q*q)).
  apply two_times_x_even.
  symmetry.
  apply mult_assoc_reverse.
  assert (Nat.even(p)= true).
  apply square_even_is_even.
  assumption.

  (* The proof is incomplete, still need a way to define relatively prime numbers (that's readily available from coq) and a few lemmas need to be proved which are listed as axioms *)


Require Import GraphBasics.Graphs.
Require Import GraphBasics.Connected.
Require Import Coq.Logic.Classical_Prop.

(* Require FunInd. *)

Section Help.

(* Our terminology for members of a network (graph). *)
Definition Component := Vertex.

(* Unequalness is symmetric. *)
Lemma neq_symm: forall (X : Type) {p q: X}, p <> q -> q <> p.
Proof.
  intros X p q pq.
  unfold not.
  intros.
  apply pq.
  symmetry.
  apply H.
Qed.

(* A natural number can't be even and odd at the same time. *)
Lemma not_even_and_odd: forall (n : nat),
  Nat.even n = Nat.odd n -> False.
Proof.
  intros n H.
  induction n.
  simpl in H.
  rewrite Nat.odd_0 in H.
  inversion H.
  apply IHn.
  rewrite Nat.even_succ in H.
  rewrite Nat.odd_succ in H.
  symmetry.
  apply H.
Qed.

(* A natural number is either odd or even. *)
Lemma even_or_odd: forall(n : nat),
  Nat.even n = true \/ Nat.odd n = true.
Proof.
  intros n.
  induction n.
  left.
  reflexivity.
  destruct IHn.
  right.
  rewrite Nat.odd_succ.
  apply H.
  left.
  rewrite Nat.even_succ.
  apply H.
Qed.

(* The definition of Connected doesn't allow loops (edges from some vertex to itself). *)
Lemma Connected_no_loops: forall (v: V_set) (a: A_set) (c : Connected v a) (x y : Vertex),
  a (A_ends x y) -> x <> y.
Proof.
  intros v a c x y arc.
  assert (g:= c).
  apply Connected_Isa_Graph in g.
  assert (v x).
  apply (G_ina_inv1 v a g) in arc.
  apply arc.
  rename H into vx.
  assert (v y).
  apply (G_ina_inv2 v a g) in arc.
  apply arc.
  rename H into vy.
  induction c.

  inversion arc.

  assert (x0 <> y0).
  unfold not. intros.
  rewrite H in v0. intuition.

  inversion arc.
  inversion H0.
  rewrite H3 in H. rewrite H4 in H. apply H.
  rewrite H3 in H. rewrite H4 in H. intuition.
  apply IHc.
  apply H0.
  apply Connected_Isa_Graph in c. apply c.
  destruct vx.
  inversion H2.
  rewrite <- H3 in H0.
  apply (G_ina_inv1 v a) in H0.
  intuition.
  apply Connected_Isa_Graph in c. apply c.
  apply H2.
  destruct vy.
  inversion H2.
  rewrite <- H3 in H0.
  apply (G_ina_inv2 v a) in H0.
  intuition.
  apply Connected_Isa_Graph in c. apply c.
  apply H2.

  inversion arc.
  inversion H.
  rewrite H2 in n. rewrite H3 in n. apply n.
  rewrite H2 in n. rewrite H3 in n. intuition.
  apply (IHc H).
  apply Connected_Isa_Graph in c. apply c.
  apply vx. apply vy.

  apply IHc.
  rewrite <- e0 in arc.
  apply arc.
  rewrite <- e0 in g. rewrite <- e in g.
  apply g.
  rewrite <- e in vx.
  apply vx.
  rewrite <- e in vy.
  apply vy.
Qed.

(* the starting vertex of a walk is in the graph itself *)
Lemma W_endx_inv :
 forall (v: V_set) (a: A_set) (x y : Component) (vl : V_list) (el : E_list), Walk v a x y vl el -> v x.
Proof.
        intros. inversion H. apply H0. apply H1.
Qed.

(* the ending vertex of a walk is in the graph itself *)
Lemma W_endy_inv :
 forall (v: V_set) (a: A_set) (x y : Component) (vl : V_list) (el : E_list), Walk v a x y vl el -> v y.
Proof.
        intros. elim H. intros. apply v0. intros. apply H0.
Qed.

(* Lenghts of lists don't change by reversing. *)
Lemma E_rev_len: forall(el:E_list),
  length (E_reverse el) = length el.
Proof.
  intros el.
  induction el.
  reflexivity.
  destruct a.
  simpl.
  rewrite app_length.
  simpl.
  rewrite IHel.
  apply plus_comm.
Qed.

(* All Connected have at least one component (therefore root exists). *)
Lemma v_not_empty : forall (v:V_set) (a:A_set) (c:Connected v a),
  exists (x:Component), v x.
Proof.
  intros v a c.
  assert (c':=c).
  induction c.
  exists x.
  unfold V_single.
  intuition.

  exists x.
  apply V_in_right.
  apply v0.

  exists x.
  apply v0.

  rewrite <- e.
  apply IHc.
  apply c.
Qed.

End Help.


Require Import Arith.
Import Nat.

Load hoare.

(*
power(x, n):
  a := 1;
  while n > 0 do    { x0 ^ n0 = a * x ^ n }
    y := n mod 2;
    n := n div 2;

    if y then a := a * x else skip;
    if n then x := x * x else skip
 *)

Definition gt01 n m := if gt_dec n m then 1 else 0.

Notation "[ e1 `*` e2 ]" := (expr_op e1 mul e2).
Notation "[ e1 `/` e2 ]" := (expr_op e1 div e2).
Notation "[ e1 `%` e2 ]" := (expr_op e1 modulo e2).
Notation "[ e1 `>` e2 ]" := (expr_op e1 gt01 e2).

Definition power_cmd :=
  seq (assign a (expr_num 1))
      (while [expr_var n `>` expr_num 0]
             (seq (assign y [expr_var n `%` expr_num 2])
                  (seq (assign n [expr_var n `/` expr_num 2])
                       (seq (if_then_else (expr_var y)
                                          (assign a [expr_var a `*` expr_var x])
                                          skip)
                            (if_then_else (expr_var n)
                                          (assign x [expr_var x `*` expr_var x])
                                          skip)
                       )
                  )
             )
      ).

Module MainProof.

  Definition c :=
    (seq (assign y [expr_var n `%` expr_num 2])
         (seq (assign n [expr_var n `/` expr_num 2])
              (seq (if_then_else (expr_var y)
                                 (assign a [expr_var a `*` expr_var x])
                                 skip)
                   (if_then_else (expr_var n)
                                 (assign x [expr_var x `*` expr_var x])
                                 skip)
              )
         )
    ).

  Definition linv x0 n0 := fun s => x0 ^ n0 = s a * (s x ^ s n).

  (* Control the behavior of `simpl` to allow more unfoldings. *)
  Arguments subst P v e /.
  Arguments set s v / z.
  Arguments var_eq_dec !v1 !v2.
  Arguments div !x !y.
  Arguments modulo !x !y.
  Arguments gt01 n m / : simpl nomatch.

  Lemma div_mod_n n k : k > 0 -> n = (n / k) * k + (n mod k).
  Admitted.

  Definition c1 :=
    (seq (assign y [expr_var n `%` expr_num 2])
         (assign n [expr_var n `/` expr_num 2])).

  Definition c2 :=
    (seq (if_then_else (expr_var y)
                       (assign a [expr_var a `*` expr_var x])
                       skip)
         (if_then_else (expr_var n)
                       (assign x [expr_var x `*` expr_var x])
                       skip)
    ).

  Lemma linv_advance x0 n0 : hoare (fun s => linv x0 n0 s /\ s n > 0)
                                   c1
                                   (fun s => x0 ^ n0 = s a * (s x * s x) ^ s n * s x ^ s y
                                          /\ s y <= 1).
  Proof.
    econstructor.
    2: constructor.
    eapply hoare_weaken_l.
    2: constructor.
    unfold linv; simpl.
    intros s [H1 H2].
    split.
    - rewrite H1.
      rewrite div_mod with (x:=s n) (y:=2) at 1; [|firstorder].
      rewrite pow_add_r.
      rewrite pow_mul_r. simpl. rewrite mul_assoc. firstorder.
    - apply lt_n_Sm_le. apply mod_upper_bound. firstorder.
  Qed.

  Inductive hoare_two : assertion -> cmd -> cmd -> assertion -> Prop :=
    hoare_two_seq : forall c1 c2 P M Q,
      hoare P c1 M -> hoare M c2 Q -> hoare_two P c1 c2 Q
  | hoare_two_weaken : forall (P' P : assertion) c1 c2 (Q Q' : assertion),
      (forall s, P' s -> P s) ->
      hoare_two P c1 c2 Q ->
      (forall s, Q s -> Q' s) ->
      hoare_two P' c1 c2 Q'.

  Lemma hss' P c1 c2 Q c12 : c12 = seq c1 c2 ->
                             hoare P c12 Q -> hoare_two P c1 c2 Q.
  Proof.
    intros.
    induction H0; inversion H.
    - eapply hoare_two_seq. subst. eassumption. subst. eassumption.
    - eapply hoare_two_weaken. eassumption. subst; firstorder. eassumption.
  Qed.

  Lemma hss P c1 c2 Q : hoare P (seq c1 c2) Q -> hoare_two P c1 c2 Q.
  Proof.
    apply hss'. reflexivity.
  Qed.

  Lemma hoare_middle_ground' P c1 c2 Q : hoare_two P c1 c2 Q ->
                                         exists M, hoare P c1 M /\ hoare M c2 Q.
  Proof.
    induction 1.
    - exists M; firstorder.
    - destruct IHhoare_two as [M].
      exists M. firstorder.
      + eapply hoare_weaken_l; eassumption.
      + eapply hoare_weaken_r; eassumption.
  Qed.

  Lemma hoare_middle_ground P c1 c2 Q : hoare P (seq c1 c2) Q ->
                                        exists M, hoare P c1 M /\ hoare M c2 Q.
  Proof.
    intro; apply hoare_middle_ground'. apply hss. assumption.
  Qed.

  Lemma hoare_seq_assoc P Q c1 c2 c3 :
    hoare P (seq c1 (seq c2 c3)) Q <-> hoare P (seq (seq c1 c2) c3) Q.
  Proof.
    split.
    - intro H. apply hoare_middle_ground in H.
      destruct H as [M1 [H1 H23]].
      apply hoare_middle_ground in H23.
      destruct H23 as [M2 [H2 H3]].
      econstructor.
      + econstructor; eassumption.
      + assumption.
    - intro H. apply hoare_middle_ground in H.
      destruct H as [M2 [H12 H3]].
      apply hoare_middle_ground in H12.
      destruct H12 as [M1 [H1 H2]].
      econstructor.
      + eassumption.
      + econstructor; eassumption.
  Qed.
    (* -- this went terribly bad --
    split.
    intro H. apply hss in H. inversion H.
    - apply hss in H1. subst. induction H1.
      + econstructor.
        econstructor.
        eassumption. eassumption. eassumption.
      + eapply hoare_weaken_r.
        2: apply IHhoare_seq_seq.
        * firstorder.
        * eapply hoare_seq_weaken.
          2: eassumption.
       *)

  Require Omega.

  Lemma linv_inv x0 n0 : hoare (fun s => linv x0 n0 s /\ s n > 0)
                               c
                               (linv x0 n0).
  Proof.
    apply hoare_seq_assoc.
    econstructor.
    - apply linv_advance.
    - econstructor.
      Focus 2.
      {
        econstructor.
        - eapply hoare_weaken_l.
          2: constructor.
          unfold linv; simpl.
          intros. destruct H.
          exact H.
        - eapply hoare_weaken_l.
          2: constructor.
          unfold linv; simpl.
          intros s [H1 H2].
          rewrite H1, H2. reflexivity.
      }
      Unfocus.
      econstructor.
      + eapply hoare_weaken_l. 2: constructor.
        simpl.
        intros s [[H1 H2] H3].
        assert (s y = 1) by firstorder.
        rewrite H1, H, pow_1_r.
        rewrite <- mul_assoc.
        rewrite mul_comm with (n:=_ ^ s n).
        rewrite mul_assoc.
        reflexivity.
      + eapply hoare_weaken_l. 2: constructor.
        simpl.
        intros s [[H1 H2] H3].
        rewrite H1, H3. firstorder.
  Qed.

End MainProof.