Require Import Init.Init.
Require Import Relation.Relation.
Require Import Nat.Nat.
Require Import Structure.Structure.
Require Import Ordinal.Ordinal.
Require Import Cardinal.Equinumerous.

Require dpdgraph.dpdgraph.

(* Hartog's Lemma *)
Lemma ex_ordinal_not_dominal: ∀ A, ∃ B, Ord B ∧ ~(B ≼ A).
Proof.
  intros A.
  pose ({x: 𝒫(A ⨉ A) ⨉ 𝒫(A)| ∃ R, ∃ S, x = ⟨R, S⟩ ∧ wo R S}) as W.
  pose (λ x, λ y, ∃ R, ∃ S, x = ⟨R, S⟩ ∧ y = EI(R, S)) as P.
  assert (∀ x, ∀ y1, ∀ y2, x ∈ W → P x y1 → P x y2 → y1 = y2) as P1.
  { intros x y1 y2 P1 P2 P3.
    destruct P2 as [R1 [S1 [Q11 Q12]]].
    destruct P3 as [R2 [S2 [Q21 Q22]]].
    pose (eq_t (eq_s Q11) Q21) as Q1.
    apply (eq_cr (λ x, x = y2) Q12).
    apply (eq_cr (λ x, EI(x, S1) = y2) (opair_eq_el _ _ _ _ Q1)).
    apply (eq_cr (λ x, EI(R2, x) = y2) (opair_eq_er _ _ _ _ Q1)).
    apply (eq_cr (λ x, EI(R2, S2) = x) Q22).
    apply eq_r. }
  destruct (ax_replace _ _ P1) as [B P2].
  assert (∀ b, b ∈ B → ∃ R, ∃ S, S ⊆ A ∧ wo R S ∧ b = EI(R, S)) as P3.
  { intros b Q1.
    destruct (P2 b) as [Q2 _].
    destruct (Q2 Q1) as [x [Q3 [R [S [Q4 Q5]]]]].
    destruct (sub_e _ _ _ Q3) as [Q8 [R' [S' [Q6 Q7]]]].
    pose (eq_t (eq_s Q4) Q6) as Q9.
    exists R.
    exists S.
    split.
    + destruct (cp_e2 _ _ _ _ (eq_cl (λ x, x ∈ (𝒫(A ⨉ A) ⨉ 𝒫(A))) Q4 Q8))
        as [_ Q10].
      apply power_e.
      apply Q10.
    + split.
      - apply (eq_cr (λ x, wo x S) (opair_eq_el _ _ _ _ Q9)).
        apply (eq_cr (λ x, wo R' x) (opair_eq_er _ _ _ _ Q9)).
        apply Q7.
      - apply Q5. }
  assert (∀ b, b ∈ B → Ord b) as P4.
  { intros b Q1.
    destruct (P3 _ Q1) as [R [S [_ [Q2 Q3]]]].
    exists R.
    exists S.
    split.
    + apply Q2.
    + apply Q3. }
  assert (∀ b, b ∈ B → b ≼ A) as P5.
  { intros b Q1.
    destruct (P3 _ Q1) as [R [S [Q2 [Q3 Q4]]]].
    pose (id_inj_exten _ _ Q2) as Q5.
    pose (eps_bij).
    pose (comp_inj).
    exists ((id S) ∘ (inv (E(R, S)))).
    apply (comp_inj _ _ _ S).
    + apply bij_e.
      apply inv_bij.
      apply (eq_cr (λ x, (E(R, S)) ∈ S ↦ᵇ x) Q4).
      apply (eps_bij _ _ Q3).
    + apply (id_inj_exten _ _ Q2). }
  assert (∀ b, Ord b → b ≼ A → b ∈ B) as P6.
  { intros b Q1 [f Q2].
    apply P2.
    destruct (isom_bij_ex_rel (ER(b)) _ _ _ (inj_bij _ _ _ Q2)) as [S [Q3 Q4]].
    pose (isom_wo _ _ _ _ (ord_wo _ Q1) Q4) as Q5.
    exists (⟨S, ran(f)⟩).
    split.
    + apply sub_i.
      - apply cp_i.
        * apply power_i.
          apply (sub_t _ _ _ Q3
            (cp_sub _ _ _ _ (inj_ran _ _ _ Q2) (inj_ran _ _ _ Q2))).
        * apply power_i.
          apply (inj_ran _ _ _ Q2).
      - exists S.
        exists (ran(f)).
        split.
        * apply eq_r.
        * apply Q5.
    + exists S.
      exists (ran(f)).
      split.
      - apply eq_r.
      - apply (eq_cl (λ x, b = x) (wo_isom_eps_eq _ _ _ _ (ord_wo _ Q1) Q5 Q4)).
        apply (ord_e2 _ Q1). }
  apply nn_e.
  intros P7.
  pose (not_ex_all_not _ P7) as P8.
  apply no_ord_set.
  exists B.
  intros b.
  split.
  + intros P9.
    apply (P6 _ P9).
    apply nn_e.
    apply ((imp_i (not_and_or (P8 b))) P9).
  + intros P9.
    apply (P4 _ P9).
Qed.

Theorem well_ord_thm: ∀ A, ∃ R, wo R A.
Proof.
  intros A.
  destruct (ex_ordinal_not_dominal A) as [Alpha [P1 P2]].
  destruct (ex_extra A) as [e P3].
  destruct (choice_fn_ex A) as [G [P4 [P5 P6]]].
  pose (λ x, λ y,
    ((A \ ran(x)) = ∅ ∧ y = e) ∨ ((A \ ran(x)) ≠ ∅ ∧ y = G[A \ ran(x)])) as P.
  assert (_G_unique P) as P7.
  { split.
    + intros x.
      destruct (LEM ((A \ ran(x)) = ∅)) as [Q1 | Q1].
      - exists e.
        left.
        apply (and_i Q1 (eq_r _)).
      - exists (G[A \ ran(x)]).
        right.
        apply (and_i Q1 (eq_r _)).
    + intros x y1 y2 [[Q1 Q2] | [Q1 Q2]] [[Q3 Q4] | [Q3 Q4]].
      - apply (eq_t Q2 (eq_s Q4)).
      - apply (bot_e _ (Q3 Q1)).
      - apply (bot_e _ (Q1 Q3)).
      - apply (eq_t Q2 (eq_s Q4)). }
  destruct (transfinite_recursion _ _ _ (ord_wo _ P1) P7) as [F [P8 [P9 P10]]].
  assert (∀ a1, ∀ a2, a1 ∈ a2 → a2 ∈ Alpha → F[a2] ≠ e → F[a1] ≠ e) as R1.
  { intros a1 a2 Q1 Q2 Q3 Q4.
    pose (ord_trans _ P1 _ _ Q1 Q2) as Q5.
    destruct (P10 _ Q5) as [[Q6 _] | [Q6 Q7]].
    + destruct (P10 _ Q2) as [[_ Q7] | [Q7 _]].
      - apply (Q3 Q7).
      - apply Q7.
        apply sub_empty_empty.
        apply (eq_cl (λ x, _ ⊆ x) Q6).
        apply compl_sub_reverse.
        apply image_sub.
        apply (seg_less_sub _ _ _ _ (wo_trans _ _ (ord_wo _ P1)) Q5 Q2
          (eps_rel_i _ _ _ Q5 Q2 Q1)).
    + destruct (compl_e _ _ _ (P6 _ Q6 (compl_sub _ _))) as [Q8 _].
      apply P3.
      apply (eq_cr (λ x, x ∈ A) (eq_t (eq_s Q4) Q7) Q8). }
  assert (∀ a1, ∀ a2, a1 ∈ a2 → a2 ∈ Alpha → F[a2] ≠ e → F[a1] ≠ F[a2]) as R2.
  { intros a1 a2 Q1 Q2 Q3 Q4.
    pose (ord_trans _ P1 _ _ Q1 Q2) as Q5.
    destruct (P10 _ Q2) as [[_ Q6] | [Q6 Q7]].
    + apply (Q3 Q6).
    + destruct (P10 _ Q5) as [[_ Q8] | [Q8 Q9]].
      - apply (R1 _ _ Q1 Q2 Q3 Q8).
      - pose P6.
        assert (F[a1] ∈ F⟦a2⟧) as Q10.
        { apply image_i.
          exists a1.
          split.
          + apply (fval_i2 _ _ P8 (eq_cr (λ x, a1 ∈ x) P9 Q5)).
          + apply Q1. }
        assert (F[a2] ∉ F⟦a2⟧) as Q11.
        { intros S1.
          destruct (image_e _ _ _ S1) as [a' [S2 S3]].
          pose (fval_i _ _ _ P8 S2) as S4.
          pose (eq_cr (λ x, x ∈ _) Q7 (P6 _ Q6 (compl_sub _ _))) as S5.
          destruct (compl_e _ _ _ S5) as [_ S7].
          pose (ord_trans _ P1 _ _ S3 Q2) as S8.
          apply S7.
          apply (eq_cl (λ x, x ∈ _) S4).
          apply (ran_i _ a').
          apply restr_i.
          + apply (fval_i2 _ _ P8 (eq_cr (λ x, a' ∈ x) P9 S8)).
          + apply seg_i.
            - apply S8.
            - apply (eps_rel_i _ _ _ S8 Q2 S3). }
        apply Q11.
        apply (eq_cl (λ x, x ∈ _) Q4 Q10). }
  assert (e ∈ ran(F)) as R3.
  { apply nn_e.
    intros Q1.
    apply P2.
    exists F.
    apply (inj_i).
    + apply P8.
    + apply P9.
    + intros y Q2.
      destruct (ran_e _ _ Q2) as [x Q3].
      pose (fval_i _ _ _ P8 Q3) as Q4.
      destruct (P10 _ (eq_cl (λ y, x ∈ y) P9 (dom_i _ _ _ Q3)))
        as [[_ Q5] | [Q5 Q6]].
      - apply bot_e.
        apply Q1.
        destruct (fval_e _ _ _ Q5 P8 (dom_i _ _ _ Q3)) as [Q6 _].
        apply (ran_i _ _ _ Q6).
      - apply (eq_cl (λ x, x ∈ A) Q4).
        apply (eq_cr (λ x, x ∈ A) Q6).
        apply (compl_sub _ _ _ (P6 _ Q5 (compl_sub _ _))).
    + intros x1 x2 y Q2 Q3.
      pose (eq_cl (λ x, _ ∈ x) P9 (dom_i _ _ _ Q2)) as Q4.
      pose (eq_cl (λ x, _ ∈ x) P9 (dom_i _ _ _ Q3)) as Q5.
      destruct (ord_tricho_weak _ _ (in_ord_ord _ _ P1 Q4)
        (in_ord_ord _ _ P1 Q5)) as [Q6 | [Q6 | Q6]].
      - apply bot_e.
        apply (R2 _ _ Q6 Q5).
        * intros Q7.
          apply Q1.
          destruct (fval_e _ _ _ Q7 P8 (dom_i _ _ _ Q3)) as [Q8 _].
          apply (ran_i _ _ _ Q8).
        * apply (eq_t (fval_i _ _ _ P8 Q2) (eq_s (fval_i _ _ _ P8 Q3))).
      - apply Q6.
      - apply bot_e.
        apply (R2 _ _ Q6 Q4).
        * intros Q7.
          apply Q1.
          destruct (fval_e _ _ _ Q7 P8 (dom_i _ _ _ Q2)) as [Q8 _].
          apply (ran_i _ _ _ Q8).
        * apply (eq_t (fval_i _ _ _ P8 Q3) (eq_s (fval_i _ _ _ P8 Q2))). }
  destruct (ran_e _ _ R3) as [xx R4].
  pose (eq_s (fval_i _ _ _ P8 R4)) as R5.
  destruct (wo_prop_seg (λ x, F[x] = e) _ _ _ (ord_wo _ P1)
    (eq_cl (λ x, xx ∈ x) P9 (dom_i _ _ _ R4)) (eq_s R5)) as [x0 [R6 [R7 R8]]].
  assert ((F↾(seg (ER(Alpha)) Alpha x0)) ∈ (seg (ER(Alpha)) Alpha x0) ↦ᵇ A) as R9.
  { apply bij_i.
    + apply (restr_fn _ _ P8).
    + apply (eq_cr (λ x, x = _) (restr_dom _ _)).
      apply (eq_cr (λ x, x ∩ _ = _) P9).
      apply inter2_absorb_r.
      apply (seg_sub _ _ _ R6).
    + apply sub_a.
      split.
      - intros y Q1.
        destruct (ran_e _ _ Q1) as [x Q2].
        destruct (restr_e _ _ _ _ Q2) as [Q3 Q4].
        pose (seg_e1 _ _ _ _ R6 Q4) as Q5.
        destruct (P10 _ Q5) as [[_ Q6] | [Q6 Q7]].
        * apply bot_e.
          apply (R8 _ Q4 Q6).
        * destruct (compl_e _ _ _ (P6 _ Q6 (compl_sub _ _))) as [Q8 _].
          apply (eq_cl (λ y, y ∈ A) (fval_i _ _ _ P8 Q3)).
          apply (eq_cr (λ y, y ∈ A) Q7).
          apply Q8.
      - intros y Q1.
        destruct (P10 _ R6) as [[Q2 _] | [Q2 Q3]].
        * apply ((compl_empty _ _ Q2) _ Q1).
        * destruct (compl_e _ _ _ (P6 _ Q2 (compl_sub _ _))) as [Q4 _].
          apply bot_e.
          apply P3.
          apply (eq_cr (λ x, x ∈ A) (eq_t (eq_s R7) Q3)).
          apply Q4.
    + intros x1 x2 y Q1 Q2.
      destruct (restr_e _ _ _ _ Q1) as [Q3 Q4].
      destruct (restr_e _ _ _ _ Q2) as [Q5 Q6].
      pose (eq_cl (λ x, _ ∈ x) P9 (dom_i _ _ _ Q3)) as Q7.
      pose (eq_cl (λ x, _ ∈ x) P9 (dom_i _ _ _ Q5)) as Q8.
      destruct (ord_tricho_weak _ _ (in_ord_ord _ _ P1 Q7)
        (in_ord_ord _ _ P1 Q8)) as [Q9 | [Q9 | Q9]].
      - apply bot_e.
        apply (R2 _ _ Q9 Q8 (R8 _ Q6)).
        apply (eq_t (fval_i _ _ _ P8 Q3) (eq_s (fval_i _ _ _ P8 Q5))).
      - apply Q9.
      - apply bot_e.
        apply (R2 _ _ Q9 Q7 (R8 _ Q4)).
        apply (eq_t (fval_i _ _ _ P8 Q5) (eq_s (fval_i _ _ _ P8 Q3))). }
  destruct (isom_bij_ex_rel (ER(seg (ER(Alpha)) Alpha x0)) _ _ _ R9)
    as [R [R10 R11]].
  exists R.
  pose (wo_seg _ _ _ (ord_wo _ P1) R6) as R12.
  pose (eps_rel_eq _ _ (seg_sub (ER(Alpha)) _ _ R6)) as R13.
  pose (wo_rel_exten _ _ _ R13 R12) as R14.
  apply (isom_wo _ _ _ _ R14 R11).
Qed.

Lemma numeration: ∀ A, ∃ O, Ord O ∧ A ≈ O.
Proof.
  intros A.
  destruct (well_ord_thm A) as [R P1].
  exists (EI(R, A)).
  split.
  + exists R.
    exists A.
    split.
    - apply P1.
    - apply eq_r.
  + apply (eqnum_eps_image _ _ P1).
Qed.

Lemma cardinality_ex: ∀ A, ∃ O, Ord O ∧ A ≈ O ∧
  ∀ O', Ord O' → O' ≈ A → O = O' ∨ O ∈ O'.
Proof.
  intros A.
  destruct (numeration A) as [O0 [P1 P2]].
  destruct (LEM (∀ O, O ∈ O0 → ~(O ≈ A))) as [P3 | P3].
  + exists O0.
    repeat split.
    - apply P1.
    - apply P2.
    - intros O' P4 P5.
      destruct (ord_tricho_weak _ _ P1 P4) as [P6 | [P6 | P6]].
      * right.
        apply P6.
      * left.
        apply P6.
      * apply bot_e.
        apply ((P3 _ P6) P5).
  + destruct (not_all_ex_not _ P3) as [O1 P4].
    destruct (nimp_e P4) as [P5 P6].
    pose (nn_e P6) as P7.
    destruct (wo_prop_least (λ x, x ≈ A) _ _ _ (ord_wo _ P1) P5 P7)
      as [O2 [P8 [P9 P10]]].
    exists O2.
    repeat split.
    - apply (in_ord_ord _ _ P1 P8).
    - apply (eqnum_s _ _ P9).
    - intros O' Q1 Q2.
      pose (in_ord_ord _ _ P1 P8) as Q3.
      destruct (ord_tricho_weak _ _ Q3 Q1)
        as [Q4 | [Q4 | Q4]].
      * right.
        apply Q4.
      * left.
        apply Q4.
      * pose (ord_t _ _ _ Q1 Q3 P1 Q4 P8) as Q5.
        destruct (P10 _ Q5 Q2) as [Q6 | Q6].
        ++apply bot_e.
          apply (no_mutual_in O' O2).
          split.
          -- apply Q4.
          -- apply (eps_rel_e _ _ _ Q6).
        ++left.
          apply Q6.
Qed.

Definition cardinality (A: J) := (ex_outl (cardinality_ex A)).
Notation   "| A |"            := (cardinality A).
Definition Card        (A: J) := (∃ B, A = |B|).

Lemma cardinality_ord: ∀ A, Ord (|A|).
Proof.
  intros A.
  apply (ex_outr (cardinality_ex A)).
Qed.

Lemma cardinality_eqnum: ∀ A, A ≈ |A|.
Proof.
  intros A.
  apply (ex_outr (cardinality_ex A)).
Qed.

Lemma cardinality_least: ∀ A, ∀ O', Ord O' → O' ≈ A → |A| = O' ∨ |A| ∈ O'.
Proof.
  intros A.
  apply (ex_outr (cardinality_ex A)).
Qed.

Lemma cardinality_eq_eqnum: ∀ A, ∀ B, |A| = |B| → A ≈ B.
Proof.
  intros A B P1.
  pose (cardinality_eqnum A) as P2.
  pose (eq_cr (λ x, B ≈ x) P1 (cardinality_eqnum B)) as P3.
  apply (eqnum_t _ _ _ P2 (eqnum_s _ _ P3)).
Qed.

Lemma eqnum_cardinality_eq: ∀ A, ∀ B, A ≈ B → |A| = |B|.
Proof.
  intros A B P1.
  pose (cardinality_eqnum A) as P2.
  pose (eqnum_t _ _ _ (eqnum_s _ _ P1) P2) as P3.
  destruct (cardinality_least _ _ (cardinality_ord A) (eqnum_s _ _ P3))
    as [P4 | P4].
  + apply (eq_s P4).
  + pose (cardinality_eqnum B) as P5.
    pose (eqnum_t _ _ _ P1 P5) as P6.
    destruct (cardinality_least _ _ (cardinality_ord B) (eqnum_s _ _ P6))
      as [P7 | P7].
    - apply P7.
    - apply bot_e.
      apply (no_mutual_in _ _ (and_i P4 P7)).
Qed.

Lemma cardinality_self: ∀ A, |A| = |(|A|)|.
Proof.
  intros A.
  apply (eqnum_cardinality_eq _ _ (cardinality_eqnum A)).
Qed.

Lemma cardinality_card: ∀ A, Card (|A|).
Proof.
  intros A.
  exists A.
  apply eq_r.
Qed.

Lemma card_cardinality_self: ∀ A, Card A → |A| = A.
Proof.
  intros A [A' P1].
  apply (eq_cr (λ x, |x| = x) P1).
  apply eq_s.
  apply cardinality_self.
Qed.

Definition aleph_null := (|ω|).
Notation   "'ℵ₀'"     := aleph_null.
Definition card_add (A B: J) := |(A ⨉ `{𝟢}) ∪ (B ⨉ `{𝟣})|.
Notation   "A +c B"          := (card_add A B).
Definition card_mul (A B: J) := |A ⨉ B|.
Notation   "A ×c B"          := (card_mul A B).
Definition card_exp (A B: J) := |A ↦ B|.
Notation   "A ^c B"          := (card_exp A B).


(** * Maps: Total and Partial Maps *)

(** _Maps_ (or _dictionaries_) are ubiquitous data structures both in
    ordinary programming and in the theory of programming languages;
    we're going to need them in many places in the coming chapters.

    They also make a nice case study using ideas we've seen in
    previous chapters, including building data structures out of
    higher-order functions (from [Basics] and [Poly]) and the use of
    reflection to streamline proofs (from [IndProp]).

    We'll define two flavors of maps: _total_ maps, which include a
    "default" element to be returned when a key being looked up
    doesn't exist, and _partial_ maps, which instead return an
    [option] to indicate success or failure.  The latter is defined in
    terms of the former, using [None] as the default element. *)

(* ################################################################# *)
(** * The Coq Standard Library *)

(** One small digression before we begin...

    Unlike the chapters we have seen so far, this one does not
    [Require Import] the chapter before it (nor, transitively, all the
    earlier chapters).  Instead, in this chapter and from now, on
    we're going to import the definitions and theorems we need
    directly from Coq's standard library stuff.  You should not notice
    much difference, though, because we've been careful to name our
    own definitions and theorems the same as their counterparts in the
    standard library, wherever they overlap. *)

From Coq Require Import Arith.Arith.
From Coq Require Import Bool.Bool.
Require Export Coq.Strings.String.
From Coq Require Import Logic.FunctionalExtensionality.
From Coq Require Import Lists.List.
Import ListNotations.

(** Documentation for the standard library can be found at
    https://coq.inria.fr/library/.

    The [Search] command is a good way to look for theorems involving
    objects of specific types. See [Lists] for a reminder of how
    to use it. *)

(** If you want to find out how or where a notation is defined, the
    [Locate] command is useful.  For example, where is the natural
    addition operation defined in the standard library? *)

Locate "+".

(** (There are several uses of the [+] notation, but only one for
    naturals.) *)

Print Init.Nat.add.

(** We'll see some more uses of [Locate] in the [Imp] chapter. *)

(* ################################################################# *)
(** * Identifiers *)

(** First, we need a type for the keys that we will use to index into
    our maps.  In [Lists.v] we introduced a fresh type [id] for a
    similar purpose; here and for the rest of _Software Foundations_
    we will use the [string] type from Coq's standard library. *)

(** To compare strings, we use the function [eqb] from the [String]
    module in the standard library. *)

Check String.eqb_refl :
  forall x : string, (x =? x)%string = true.

(** We will often use a few basic properties of string equality... *)
Check String.eqb_eq :
  forall n m : string, (n =? m)%string = true <-> n = m.
Check String.eqb_neq :
  forall n m : string, (n =? m)%string = false <-> n <> m.
Check String.eqb_spec :
  forall x y : string, reflect (x = y) (String.eqb x y).

(* ################################################################# *)
(** * Total Maps *)

(** Our main job in this chapter will be to build a definition of
    partial maps that is similar in behavior to the one we saw in the
    [Lists] chapter, plus accompanying lemmas about its behavior.

    This time around, though, we're going to use _functions_, rather
    than lists of key-value pairs, to build maps.  The advantage of
    this representation is that it offers a more "extensional" view of
    maps: two maps that respond to queries in the same way will be
    represented as exactly the same function, rather than just as
    "equivalent" list structures.  This, in turn, simplifies proofs
    that use maps. *)

(** We build up to partial maps in two steps.  First, we define a type
    of _total maps_ that return a default value when we look up a key
    that is not present in the map. *)

Definition total_map (A : Type) := string -> A.

(** Intuitively, a total map over an element type [A] is just a
    function that can be used to look up [string]s, yielding [A]s. *)

(** The function [t_empty] yields an empty total map, given a default
    element; this map always returns the default element when applied
    to any string. *)

Definition t_empty {A : Type} (v : A) : total_map A :=
  (fun _ => v).

(** More interesting is the map-updating function, which (as always)
    takes a map [m], a key [x], and a value [v] and returns a new map
    that takes [x] to [v] and takes every other key to whatever [m]
    does.  The novelty here is that we achieve this effect by wrapping
    a new function around the old one. *)

Definition t_update {A : Type} (m : total_map A)
                    (x : string) (v : A) :=
  fun x' => if String.eqb x x' then v else m x'.

(** This definition is a nice example of higher-order programming:
    [t_update] takes a _function_ [m] and yields a new function
    [fun x' => ...] that behaves like the desired map. *)

(** For example, we can build a map taking [string]s to [bool]s, where
    ["foo"] and ["bar"] are mapped to [true] and every other key is
    mapped to [false], like this: *)

Definition examplemap :=
  t_update (t_update (t_empty false) "foo" true)
           "bar" true.

(** Next, let's introduce some notations to facilitate working with
    maps. *)

(** First, we use the following notation to represent an empty total
    map with a default value. *)
Notation "'_' '!->' v" := (t_empty v)
  (at level 100, right associativity).

Example example_empty := (_ !-> false).

(** We next introduce a convenient notation for extending an existing
    map with a new binding. *)
Notation "x '!->' v ';' m" := (t_update m x v)
                              (at level 100, v at next level, right associativity).

(** The [examplemap] above can now be defined as follows: *)

Definition examplemap' :=
  ( "bar" !-> true;
    "foo" !-> true;
    _     !-> false
  ).

(** This completes the definition of total maps.  Note that we
    don't need to define a [find] operation on this representation of
    maps because it is just function application! *)

Example update_example1 : examplemap' "baz" = false.
Proof. reflexivity. Qed.

Example update_example2 : examplemap' "foo" = true.
Proof. reflexivity. Qed.

Example update_example3 : examplemap' "quux" = false.
Proof. reflexivity. Qed.

Example update_example4 : examplemap' "bar" = true.
Proof. reflexivity. Qed.

(** When we use maps in later chapters, we'll need several fundamental
    facts about how they behave. *)

(** Even if you don't bother to work the following exercises,
    make sure you thoroughly understand the statements of the
    lemmas! *)

(** (Some of the proofs require the functional extensionality axiom,
    which was discussed in the [Logic] chapter.) *)

(** **** Exercise: 1 star, standard, optional (t_apply_empty)

    First, the empty map returns its default element for all keys: *)

Lemma t_apply_empty : forall (A : Type) (x : string) (v : A),
  (_ !-> v) x = v.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 2 stars, standard, optional (t_update_eq)

    Next, if we update a map [m] at a key [x] with a new value [v]
    and then look up [x] in the map resulting from the [update], we
    get back [v]: *)

Lemma t_update_eq : forall (A : Type) (m : total_map A) x v,
  (x !-> v ; m) x = v.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 2 stars, standard, optional (t_update_neq)

    On the other hand, if we update a map [m] at a key [x1] and then
    look up a _different_ key [x2] in the resulting map, we get the
    same result that [m] would have given: *)

Theorem t_update_neq : forall (A : Type) (m : total_map A) x1 x2 v,
  x1 <> x2 ->
  (x1 !-> v ; m) x2 = m x2.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 2 stars, standard, optional (t_update_shadow)

    If we update a map [m] at a key [x] with a value [v1] and then
    update again with the same key [x] and another value [v2], the
    resulting map behaves the same (gives the same result when applied
    to any key) as the simpler map obtained by performing just
    the second [update] on [m]: *)

Lemma t_update_shadow : forall (A : Type) (m : total_map A) x v1 v2,
  (x !-> v2 ; x !-> v1 ; m) = (x !-> v2 ; m).
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 2 stars, standard (t_update_same)

    Given [string]s [x1] and [x2], we can use the tactic
    [destruct (eqb_spec x1 x2)] to simultaneously perform case
    analysis on the result of [String.eqb x1 x2] and generate
    hypotheses about the equality (in the sense of [=]) of [x1] and
    [x2].  With the example in chapter [IndProp] as a template,
    use [String.eqb_spec] to prove the following theorem, which states
    that if we update a map to assign key [x] the same value as it
    already has in [m], then the result is equal to [m]: *)

Theorem t_update_same : forall (A : Type) (m : total_map A) x,
  (x !-> m x ; m) = m.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 3 stars, standard, especially useful (t_update_permute)

    Similarly, use [String.eqb_spec] to prove one final property of
    the [update] function: If we update a map [m] at two distinct
    keys, it doesn't matter in which order we do the updates. *)

Theorem t_update_permute : forall (A : Type) (m : total_map A)
                                  v1 v2 x1 x2,
  x2 <> x1 ->
  (x1 !-> v1 ; x2 !-> v2 ; m)
  =
  (x2 !-> v2 ; x1 !-> v1 ; m).
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(* ################################################################# *)
(** * Partial maps *)

(** Lastly, we define _partial maps_ on top of total maps.  A partial
    map with elements of type [A] is simply a total map with elements
    of type [option A] and default element [None]. *)

Definition partial_map (A : Type) := total_map (option A).

Definition empty {A : Type} : partial_map A :=
  t_empty None.

Definition update {A : Type} (m : partial_map A)
           (x : string) (v : A) :=
  (x !-> Some v ; m).

(** We introduce a similar notation for partial maps: *)
Notation "x '|->' v ';' m" := (update m x v)
  (at level 100, v at next level, right associativity).

(** We can also hide the last case when it is empty. *)
Notation "x '|->' v" := (update empty x v)
  (at level 100).

Definition examplepmap :=
  ("Church" |-> true ; "Turing" |-> false).

(** We now straightforwardly lift all of the basic lemmas about total
    maps to partial maps.  *)

Lemma apply_empty : forall (A : Type) (x : string),
  @empty A x = None.
Proof.
  intros. unfold empty. rewrite t_apply_empty.
  reflexivity.
Qed.

Lemma update_eq : forall (A : Type) (m : partial_map A) x v,
  (x |-> v ; m) x = Some v.
Proof.
  intros. unfold update. rewrite t_update_eq.
  reflexivity.
Qed.

Theorem update_neq : forall (A : Type) (m : partial_map A) x1 x2 v,
  x2 <> x1 ->
  (x2 |-> v ; m) x1 = m x1.
Proof.
  intros A m x1 x2 v H.
  unfold update. rewrite t_update_neq. reflexivity.
  apply H. Qed.

Lemma update_shadow : forall (A : Type) (m : partial_map A) x v1 v2,
  (x |-> v2 ; x |-> v1 ; m) = (x |-> v2 ; m).
Proof.
  intros A m x v1 v2. unfold update. rewrite t_update_shadow.
  reflexivity.
Qed.

Theorem update_same : forall (A : Type) (m : partial_map A) x v,
  m x = Some v ->
  (x |-> v ; m) = m.
Proof.
  intros A m x v H. unfold update. rewrite <- H.
  apply t_update_same.
Qed.

Theorem update_permute : forall (A : Type) (m : partial_map A)
                                x1 x2 v1 v2,
  x2 <> x1 ->
  (x1 |-> v1 ; x2 |-> v2 ; m) = (x2 |-> v2 ; x1 |-> v1 ; m).
Proof.
  intros A m x1 x2 v1 v2. unfold update.
  apply t_update_permute.
Qed.

(** One last thing: For partial maps, it's convenient to introduce a
    notion of map inclusion, stating that all the entries in one map
    are also present in another: *)

Definition includedin {A : Type} (m m' : partial_map A) :=
  forall x v, m x = Some v -> m' x = Some v.

(** We can then show that map update preserves map inclusion -- that is: *)

Lemma includedin_update : forall (A : Type) (m m' : partial_map A)
                                 (x : string) (vx : A),
  includedin m m' ->
  includedin (x |-> vx ; m) (x |-> vx ; m').
Proof.
  unfold includedin.
  intros A m m' x vx H.
  intros y vy.
  destruct (eqb_spec x y) as [Hxy | Hxy].
  - rewrite Hxy.
    rewrite update_eq. rewrite update_eq. intro H1. apply H1.
  - rewrite update_neq. rewrite update_neq.
    + apply H.
    + apply Hxy.
    + apply Hxy.
Qed.

(** This property is quite useful for reasoning about languages with
    variable binding -- e.g., the Simply Typed Lambda Calculus, which
    we will see in _Programming Language Foundations_, where maps are
    used to keep track of which program variables are defined in a
    given scope. *)

(* 2022-07-21 10:18 *)


Require Import rt.util.all.
Require Import rt.model.basic.arrival_sequence rt.model.basic.job
               rt.model.basic.task rt.model.basic.task_arrival.
Require Import rt.implementation.basic.task rt.implementation.basic.job.
From mathcomp Require Import ssreflect ssrbool ssrfun ssrnat eqtype seq div.

Module ConcreteArrivalSequence.

  Import Job ArrivalSequence ConcreteTask ConcreteJob SporadicTaskset SporadicTaskArrival.

  Section PeriodicArrivals.

    Variable ts: concrete_taskset.

    (* At any time t, we release Some job of tsk if t is a multiple of the period,
       otherwise we release None. *)
    Definition add_job (t: time) (tsk: concrete_task) :=
      if task_period tsk %| t  then
        Some (Build_concrete_job (t %/ task_period tsk) (task_cost tsk) (task_deadline tsk) tsk)
      else
        None.

    (* The arrival sequence at any time t is simply the partial map of add_job. *)
    Definition periodic_arrival_sequence (t: time) := pmap (add_job t) ts.

  End PeriodicArrivals.

  Section Proofs.

    (* Let ts be any concrete task set with valid parameters. *)
    Variable ts: concrete_taskset.
    Hypothesis H_valid_task_parameters:
      valid_sporadic_taskset task_cost task_period task_deadline ts.

    (* Regarding the periodic arrival sequence built from ts, we prove that...*)
    Let arr_seq := periodic_arrival_sequence ts.

    (* ... every job comes from the task set, ... *)
    Theorem periodic_arrivals_all_jobs_from_taskset:
      forall (j: JobIn arr_seq),
        job_task (_job_in arr_seq j) \in ts. (* TODO: fix coercion. *)
    Proof.
      intros j.
      destruct j as [j arr ARRj]; simpl.
      unfold arr_seq, arrives_at, periodic_arrival_sequence in *.
      rewrite mem_pmap in ARRj.
      move: ARRj => /mapP ARRj; destruct ARRj as [tsk IN SOME].
      by unfold add_job in *; desf.
    Qed.

    (* ..., jobs have valid parameters, ... *)
    Theorem periodic_arrivals_valid_job_parameters:
      forall (j: JobIn arr_seq),
        valid_sporadic_job task_cost task_deadline job_cost job_deadline job_task j.
    Proof.
      rename H_valid_task_parameters into PARAMS.
      unfold valid_sporadic_taskset, is_valid_sporadic_task in *.
      intros j; destruct j as [j arr ARRj]; simpl.
      unfold arrives_at, arr_seq, periodic_arrival_sequence in ARRj.
      rewrite mem_pmap in ARRj; move: ARRj => /mapP [tsk IN SOME].
      unfold add_job in SOME; desf.
      specialize (PARAMS tsk IN); des.
      unfold valid_sporadic_job, valid_realtime_job, job_cost_positive.
      by repeat split; try (by done); apply leqnn.
    Qed.

    (* ... job arrivals satisfy the sporadic task model, ... *)
    Theorem periodic_arrivals_are_sporadic:
      sporadic_task_model task_period arr_seq job_task.
    Proof.
      unfold sporadic_task_model; move => j j' /eqP DIFF SAMEtsk LE.
      destruct j as [j arr ARR], j' as [j' arr' ARR']; simpl in *.
      rewrite eqE /= /jobin_eqdef negb_and /= in DIFF.
      unfold arrives_at, arr_seq, periodic_arrival_sequence in *.
      rewrite 2!mem_pmap in ARR ARR'.
      move: ARR ARR' => /mapP [tsk_j INj SOMEj] /mapP [tsk_j' INj' SOMEj'].
      unfold add_job in SOMEj, SOMEj'; desf; simpl in *;
      move: Heq0 Heq => /dvdnP [k DIV] /dvdnP [k' DIV'].
      {
        rewrite DIV DIV' -mulSnr.
        rewrite leq_eqVlt in LE; move: LE => /orP [/eqP EQ | LESS].
        {
          exfalso; move: DIFF => /negP DIFF; apply DIFF.
          by subst; rewrite EQ.
        }
        subst; rewrite leq_mul2r; apply/orP; right.
        by rewrite ltn_mul2r in LESS; move: LESS => /andP [_ LT].
      }
      {
        assert (LT: arr < arr'). by rewrite ltn_neqAle; apply/andP.
        clear LE DIFF; subst tsk_j' arr arr'.
        rewrite ltn_mul2r in LT; move: LT => /andP [_ LT].
        by apply leq_trans with (n := k.+1 * task_period tsk_j);
          [by rewrite mulSnr | by rewrite leq_mul2r; apply/orP; right].
      }
    Qed.

    (* ... and if the task set has no duplicates, the same applies to
       the arrival sequence. *)
    Theorem periodic_arrivals_is_a_set:
      uniq ts -> arrival_sequence_is_a_set arr_seq.
    Proof.
      intros UNIQ t.
      unfold arr_seq, periodic_arrival_sequence.
      apply (pmap_uniq) with (g := job_task); last by done.
      by unfold add_job, ocancel; intro tsk; desf.
    Qed.

  End Proofs.

End ConcreteArrivalSequence.


Require Export CoRN.reals.fast.CRtrans.
(* Require Export CoRN.reals.faster.ARbigD. *)
(* Require Export CoRN.ftc.IntegrationRules. *)

Require Export Coq.Program.Tactics.
Require Export MathClasses.interfaces.canonical_names.
Require Export MathClasses.misc.decision.
Require Export IRLemmasAsCR.

Definition QSignHalf (q: Q) : Q :=
  QSign q ½ .

Require Export Vector.
Local Notation yes := left.
Local Notation no := right.

Definition polarTheta (cart :Cart2D Q) : CR :=
  if (decide ((X cart) = 0))
    then
      CRpi * ' QSignHalf (Y cart)
    else
      let angle := (rational_arctan (Y cart / (X cart))) in
      if decide (X cart < 0) then angle + (QSign (Y cart) π) else angle.

Definition polarθSign (target : Cart2D Q) : Q := QSign (Y target) 1.

Definition Cart2Polar (cart :Cart2D Q) : Polar2D CR :=
  {|rad := ( |cart| )
  ; θ := polarTheta cart |}.

Definition Polar2Cart (pol : Polar2D CR) : Cart2D CR :=
  {|X := (rad pol) * (cos (θ pol))
  ; Y := (rad pol) * (sin (θ pol)) |}.

Require Import Coq.QArith.Qfield.
Require Import Coq.QArith.Qring.
Require Import Psatz.

Lemma Cart2Polar2CartID : forall (c :Cart2D Q),
  ' c = Polar2Cart (Cart2Polar c).
Proof.
  intros c.
  unfold Cart2Polar, Polar2Cart.
  simpl. destruct c as [cx cy].
  unfold polarTheta. simpl.
  destruct (decide (cx = 0)) as [Hcx0 | Hcx0];
  unfold equiv,EquivCart,CanonicalNotations.norm, NormSpace_instance_Cart2D ; simpl;[|].
- rewrite Hcx0. prepareForCRRing.
  unfold stdlib_rationals.Q_mult, stdlib_rationals.Q_plus. QRing_simplify.
  simpl. rewrite CRrational_sqrt_ofsqr.
  unfold QSignHalf, QSign.
  destruct (decide (cy < 0)) as [Hlt | Hlt];
    autorewrite with CRSimpl;
  prepareForCRRing; try rewrite (morph_opp QCRM);
  split; CRRing.
- destruct (decide (cx < 0)) as [HcxNeg | HcxNeg].
  + rewrite  CRCos_PlusMinus_Pi,  CRSin_PlusMinus_Pi. split;
    [apply cos_o_arctan_west| apply sin_o_arctan_west]; assumption.
  + apply orders.full_pseudo_srorder_le_iff_not_lt_flip in HcxNeg.
    apply CRle_Qle in HcxNeg.
    split; [apply cos_o_arctan_east |  apply sin_o_arctan_east];
       apply CRle_Qle in HcxNeg; revert Hcx0 HcxNeg;
        unfoldMC; intros; lra.
Qed.

Require Export MathClasses.interfaces.orders.

Hint Resolve CRweakenLt CRLtAddLHS CRLtAddRHS : CRBasics.

(*
Lemma polarθSignCorr : ∀ targetPos,
 0 < polarTheta targetPos ↔  0 < (Y targetPos).
Proof.
  intros. unfold polarθSign, polarTheta.
  destruct (decide (X targetPos = 0)); auto.
- unfold QSignHalf.
-
*)

Lemma CRabsCRpi : CRabs CRpi = CRpi.
  rewrite CRabs_pos;[reflexivity|].
  apply CRweakenLt.
  apply CR_lt_ltT.
  apply CRpi_pos.
Qed.

Instance NormSpace_instance_Q : NormSpace Q Q := Qabs.Qabs.

Lemma QAbsQSign :
  ∀ a c,  (|QSign a c|) = |c|.
Proof.
  intros.
  unfold QSign, CanonicalNotations.norm,
  NormSpace_instance_Q.
  destruct (decide (a < 0)) as [Hd | Hd]; auto.
  apply Qabs.Qabs_opp.
Qed.

Lemma multMiddle: ∀ (a b c : CR),
  a*b*c = a*c*b.
Proof.
  intros.
  prepareForCRRing.
  ring.
Qed.

Open Scope Q_scope.
Lemma  Qle_shift_div_r_neg:
   ∀ a b, 0 <= a  → b < 0 → (Qdiv a  b <= 0).
Proof.
  intros.
  unfold Qle, Qinv.
  simpl. ring_simplify.
  destruct a, b.
  unfold Qlt in H0.
  unfold Qle in H.
  simpl in H, H0.
  simpl.
  ring_simplify in H.
  ring_simplify in H0.
  unfold Qinv. simpl.
  destruct Qnum0; simpl; try omega.
  nia.
  nia.
Qed.

Lemma  Qle_shift_div_l_neg:
   ∀ a b, a <= 0  → b < 0 → (0 <= Qdiv a  b).
Proof.
  intros.
  unfold Qle, Qinv.
  simpl. ring_simplify.
  destruct a, b.
  unfold Qlt in H0.
  unfold Qle in H.
  simpl in H, H0.
  simpl.
  ring_simplify in H.
  ring_simplify in H0.
  unfold Qinv. simpl.
  destruct Qnum0; simpl; try omega.
  nia.
  nia.
Qed.

Close Scope Q_scope.

Lemma CRLtAddRHSConv
     : ∀ c a b : CR,  a + c < b + c -> a < b.
Proof.
  intros ? ? ? H.
  apply (CRLtAddRHS (-c)) in H.
  revert H. prepareForCRRing.
  intro H. ring_simplify in H.
  assumption.
Qed.

Lemma CRLtTrans : ∀ a b c:CR,
  a < b
  -> b < c
  -> a < c.
Proof.
  intros ? ? ? ? ? .  eapply ( orders.strict_po_trans _ _ _ );
  eauto.
Qed.

Lemma AddCancel : ∀ a b:CR,
  a +b -b =a.
Proof.
  intros.
  prepareForCRRing. ring.
Qed.

Hint Rewrite  <- CRopp_Qopp : MoveInjQCRIn.
Lemma polarθSignCorr1 : ∀ targetPos,
(|polarTheta targetPos|)* '(polarθSign targetPos) =polarTheta targetPos.
Proof.
  intros. unfold polarθSign, polarTheta.
  destruct (decide (X targetPos = 0)); auto.
- rewrite (mult_comm CRpi).
  unfold CanonicalNotations.norm, NormSpace_instance_0.
  rewrite CRabs_CRmult_Q.
  rewrite CRabsCRpi.
  unfold QSignHalf.
  rewrite QAbsQSign.
  unfold CanonicalNotations.norm, NormSpace_instance_Q.
  simpl Qabs.Qabs. rewrite multMiddle.
  apply CRmult_wd;[| reflexivity].
  rewrite CRmult_Qmult.
  apply inject_Q_CR_wd.
  unfold QSign.
  destruct (decide (Y targetPos < 0)); reflexivity.
- destruct (decide (X targetPos < 0)) as [Hd | Hd].
  + unfold lt, stdlib_rationals.Q_lt, zero,
    stdlib_rationals.Q_0 in Hd, n.
    unfold QSign, CanonicalNotations.norm,
    NormSpace_instance_0.
    destruct (decide (Y targetPos < 0)) as [Hdy | Hdy].
    * rewrite CRabs_neg;[ prepareForCRRing;
      unfold stdlib_rationals.Q_1; ring|].
      apply CRweakenLt.
      apply (CRLtAddRHSConv CRpi).
      unfold π, CRpi_RealNumberPi_instance.
      prepareForCRRing.
      ring_simplify.
      rewrite <- arctan_Qarctan.
      eapply CRLtTrans;[apply CRarctan_range|].
      exists 1%nat.
      vm_compute. reflexivity.

    * rewrite CRabs_pos;[ prepareForCRRing;
      unfold stdlib_rationals.Q_1; ring|].
      apply CRweakenLt.
      apply (CRLtAddRHSConv (- CRpi)).
      unfold π, CRpi_RealNumberPi_instance.
      rewrite AddCancel.
      rewrite <- arctan_Qarctan.
      eapply CRLtTrans; [|apply (proj1 (CRarctan_range _))].
      exists 1%nat.
      vm_compute. reflexivity.

  + unfold lt, stdlib_rationals.Q_lt, zero,
    stdlib_rationals.Q_0 in Hd, n.
    unfold QSign, CanonicalNotations.norm,
    NormSpace_instance_0.
    destruct (decide (Y targetPos < 0)) as [Hdy | Hdy].
    * unfold lt, stdlib_rationals.Q_lt, zero,
      stdlib_rationals.Q_0 in Hdy.
      unfold cast. autorewrite with MoveInjQCRIn.
      rewrite CRabs_neg;[ prepareForCRRing;
        unfold stdlib_rationals.Q_1; ring|].
      apply rational_arctan_nonpos.
      prepareForLra. prepareForCRRing.
      unfold equiv, stdlib_rationals.Q_eq in n.
      apply Qle_shift_div_r; try lra.

    * unfold lt, stdlib_rationals.Q_lt, zero,
      stdlib_rationals.Q_0 in Hdy.
      rewrite CRabs_pos;[ prepareForCRRing;
        unfold stdlib_rationals.Q_1; ring|].
      apply rational_arctan_nonneg.
      prepareForLra. prepareForCRRing.
      unfold equiv, stdlib_rationals.Q_eq in n.
      apply Qle_shift_div_l; try lra.
Qed.

Lemma Cart2PolarRadRange : forall (c :Cart2D Q),
  0  ≤ rad (Cart2Polar c).
Proof.
  intros c.
  unfold Cart2Polar. unfold CanonicalNotations.norm, NormSpace_instance_Cart2D.
  simpl. rewrite <- CRsqrt_Qsqrt. apply CRsqrt_nonneg.
  destruct c.
  simpl.
  apply CRle_Qle. unfoldMC. apply Q.Qplus_nonneg;apply Qpower.Qsqr_nonneg.
Qed.

Lemma Cart2PolarAngleRange : forall (c :Cart2D Q),
  -π  ≤ θ (Cart2Polar c) ≤ π.
Proof.
  intro c.
  destruct c. simpl.
  unfold polarTheta.
  simpl. destruct (decide (X = 0)).
- clear. unfold QSignHalf, QSign.
  destruct (decide (Y < 0));
  [split;[|apply CRweakenLt]|apply CRweakenRange; split];
    try(exists (1%nat); vm_compute; reflexivity).
  rewrite <- CRopp_Qopp.
  rewrite  multNegShiftOut.
  rewrite <- CRle_opp.
  apply CRweakenLt.
  exists 1%nat.
  vm_compute.
  reflexivity.

- destruct (CRarctan_range ('(Y/X)%Q)) as [Hl Hr].
  rewrite arctan_Qarctan in Hl.
  rewrite arctan_Qarctan in Hr.
  destruct (decide (X < 0)) as [l|l].
  + apply addRangeLe.
    autounfold with QMC in l.
    unfold QSign, CanonicalNotations.norm,
      NormSpace_instance_0.
    destruct (decide (Y < 0)) as [Hdy | Hdy];
      autounfold with QMC in Hdy.
    * split; [
        | apply CRweakenLt;
          eapply (orders.strict_po_trans); eauto;
          exists 1%nat; vm_compute; reflexivity].
      prepareForCRRing.
      rewrite CRplus_opp.
      apply rational_arctan_nonneg.
      autounfold  with QMC.
      apply Qle_shift_div_l_neg; try lra.

    * split; [
          apply CRweakenLt;
          eapply (orders.strict_po_trans); eauto;
          exists 1%nat; vm_compute; reflexivity| ].
      prepareForCRRing.
      rewrite CRplus_opp.
      apply rational_arctan_nonpos.
      autounfold  with QMC.
      apply Qle_shift_div_r_neg; try lra.

  + apply CRweakenRange. split;
    eapply (orders.strict_po_trans); eauto;
    exists 1%nat; vm_compute; reflexivity.
Qed.

Lemma polarFirstQuad : forall (c: Cart2D Q),
  0 ≤ c -> 0 ≤ polarTheta c ≤ ('½)*π.
Proof.
  intros ?. unfold polarTheta, QSignHalf, QSign,
  Zero_instance_Cart2D, Cart2D_instance_le.
  autounfold with QMC.
  simpl.
  intro Hh. destruct Hh.
  destruct (decide (X c == 0)%Q).
  - simpl. destruct (decide (Y c < 0)%Q);[lra|].
    rewrite commutativity.
    split;[| reflexivity].
    apply CRweakenLt.
    exists (1%nat); vm_compute; reflexivity.
  - destruct (decide (X c < 0)%Q);[lra|].
    assert ((0 < X c)%Q) by lra.
    clear n n0.
    split.
    + apply rational_arctan_nonneg.
      autounfold  with QMC.
      apply Q.Qle_shift_div_l; lra.
    + destruct (CRarctan_range ('(Y c/X c)%Q)) as [Hl Hr].
      clear Hl.
      rewrite arctan_Qarctan in Hr.
      apply CRweakenLt.
      exact Hr.
Qed.

(** Move *)
Global Instance LtCart2D `{Lt A} : Lt (Cart2D A) :=
fun a b => (X a < X b) /\  (Y a < Y b).

Lemma polarFirstQuadStrict : forall (c: Cart2D Q),
  0 < X c → 0 ≤  Y c   → polarTheta c < ('½)*π.
Proof.
  intros ?. unfold polarTheta, QSignHalf, QSign,
  Zero_instance_Cart2D, Cart2D_instance_le.
  autounfold with QMC.
  simpl.
  intros Hx Hy.
  destruct (decide (X c == 0)%Q);[lra|].
  destruct (decide (X c < 0)%Q);[lra|].
  clear n n0.
  destruct (CRarctan_range ('(Y c/X c)%Q)) as [Hl Hr].
  clear Hl.
  rewrite arctan_Qarctan in Hr.
  exact Hr.
Qed.

Lemma polarFirstQuadIncreasing : forall (a b: Cart2D Q),
  0 < X a (* if 0, LHS is arbitrarily chosen to be Pi*)
  → 0 < X b
  → (Y a / X a ≤ Y b / X b)%Q
  → polarTheta a ≤ polarTheta b.
Proof.
  intros ? ?. unfold polarTheta, QSignHalf,
    QSign,
  Zero_instance_Cart2D, Cart2D_instance_le.
  autounfold with QMC.
  simpl.
  intros ? Hlt Hrle.
  destruct (decide (X a == 0)%Q);[lra|].
  destruct (decide (X a < 0)%Q);[lra|].
  assert ((0 < X a)%Q) by lra.
  destruct (decide (X b == 0)%Q);[lra|].
  assert ((0 < X b)%Q) by lra.
  destruct (decide (X b < 0)%Q);[lra|].
  apply rational_arctan_increasing.
  exact Hrle.
Qed.

Lemma polarFirstQuadIncreasingStrict : forall (a b: Cart2D Q),
  0 < X a (* if 0, LHS is arbitrarily chosen to be Pi*)
  → 0 < X b
  → (Y a / X a < Y b / X b)%Q
  → polarTheta a < polarTheta b.
Proof using.
  intros ? ?. unfold polarTheta, QSignHalf,
    QSign,
  Zero_instance_Cart2D, Cart2D_instance_le.
  autounfold with QMC.
  simpl.
  intros ? Hlt Hrle.
  destruct (decide (X a == 0)%Q);[lra|].
  destruct (decide (X a < 0)%Q);[lra|].
  assert ((0 < X a)%Q) by lra.
  destruct (decide (X b == 0)%Q);[lra|].
  assert ((0 < X b)%Q) by lra.
  destruct (decide (X b < 0)%Q);[lra|].
  apply CR_lt_ltT.
  apply rational_arctan_increasing_strict.
  exact Hrle.
Qed.


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

Module Z.
  Lemma mod_r_distr_if (b : bool) x y z : z mod (if b then x else y) = if b then z mod x else z mod y.
  Proof. destruct b; reflexivity. Qed.
  Hint Rewrite mod_r_distr_if : push_Zmod.
  Hint Rewrite <- mod_r_distr_if : pull_Zmod.

  Lemma mod_l_distr_if (b : bool) x y z : (if b then x else y) mod z = if b then x mod z else y mod z.
  Proof. destruct b; reflexivity. Qed.
  Hint Rewrite mod_l_distr_if : push_Zmod.
  Hint Rewrite <- mod_l_distr_if : pull_Zmod.

  (** Version without the [n <> 0] assumption *)
  Lemma mul_mod_full a b n : (a * b) mod n = ((a mod n) * (b mod n)) mod n.
  Proof. auto using Zmult_mod. Qed.
  Hint Rewrite <- mul_mod_full : pull_Zmod.
  Hint Resolve mul_mod_full : zarith.

  Lemma mul_mod_l a b n : (a * b) mod n = ((a mod n) * b) mod n.
  Proof.
    intros; rewrite (mul_mod_full a b), (mul_mod_full (a mod n) b).
    autorewrite with zsimplify; reflexivity.
  Qed.
  Hint Rewrite <- mul_mod_l : pull_Zmod.
  Hint Resolve mul_mod_l : zarith.

  Lemma mul_mod_r a b n : (a * b) mod n = (a * (b mod n)) mod n.
  Proof.
    intros; rewrite (mul_mod_full a b), (mul_mod_full a (b mod n)).
    autorewrite with zsimplify; reflexivity.
  Qed.
  Hint Rewrite <- mul_mod_r : pull_Zmod.
  Hint Resolve mul_mod_r : zarith.

  Lemma add_mod_full a b n : (a + b) mod n = ((a mod n) + (b mod n)) mod n.
  Proof. auto using Zplus_mod. Qed.
  Hint Rewrite <- add_mod_full : pull_Zmod.
  Hint Resolve add_mod_full : zarith.

  Lemma add_mod_l a b n : (a + b) mod n = ((a mod n) + b) mod n.
  Proof.
    intros; rewrite (add_mod_full a b), (add_mod_full (a mod n) b).
    autorewrite with zsimplify; reflexivity.
  Qed.
  Hint Rewrite <- add_mod_l : pull_Zmod.
  Hint Resolve add_mod_l : zarith.

  Lemma add_mod_r a b n : (a + b) mod n = (a + (b mod n)) mod n.
  Proof.
    intros; rewrite (add_mod_full a b), (add_mod_full a (b mod n)).
    autorewrite with zsimplify; reflexivity.
  Qed.
  Hint Rewrite <- add_mod_r : pull_Zmod.
  Hint Resolve add_mod_r : zarith.

  Lemma opp_mod_mod a n : (-a) mod n = (-(a mod n)) mod n.
  Proof.
    intros; destruct (Z_zerop (a mod n)) as [H'|H']; [ rewrite H' | ];
      [ | rewrite !Z_mod_nz_opp_full ];
      autorewrite with zsimplify; lia.
  Qed.
  Hint Rewrite <- opp_mod_mod : pull_Zmod.
  Hint Resolve opp_mod_mod : zarith.

  (** Give alternate names for the next three lemmas, for consistency *)
  Lemma sub_mod_full a b n : (a - b) mod n = ((a mod n) - (b mod n)) mod n.
  Proof. auto using Zminus_mod. Qed.
  Hint Rewrite <- sub_mod_full : pull_Zmod.
  Hint Resolve sub_mod_full : zarith.

  Lemma sub_mod_l a b n : (a - b) mod n = ((a mod n) - b) mod n.
  Proof. auto using Zminus_mod_idemp_l. Qed.
  Hint Rewrite <- sub_mod_l : pull_Zmod.
  Hint Resolve sub_mod_l : zarith.

  Lemma sub_mod_r a b n : (a - b) mod n = (a - (b mod n)) mod n.
  Proof. auto using Zminus_mod_idemp_r. Qed.
  Hint Rewrite <- sub_mod_r : pull_Zmod.
  Hint Resolve sub_mod_r : zarith.

  Definition NoZMod (x : Z) := True.
  Ltac NoZMod :=
    lazymatch goal with
    | [ |- NoZMod (?x mod ?y) ] => fail 0 "Goal has" x "mod" y
    | [ |- NoZMod _ ] => constructor
    end.

  Lemma mul_mod_push a b n : NoZMod a -> NoZMod b -> (a * b) mod n = ((a mod n) * (b mod n)) mod n.
  Proof. intros; apply mul_mod_full; assumption. Qed.
  Hint Rewrite mul_mod_push using solve [ NoZMod ] : push_Zmod.

  Lemma add_mod_push a b n : NoZMod a -> NoZMod b -> (a + b) mod n = ((a mod n) + (b mod n)) mod n.
  Proof. intros; apply add_mod_full; assumption. Qed.
  Hint Rewrite add_mod_push using solve [ NoZMod ] : push_Zmod.

  Lemma mul_mod_l_push a b n : NoZMod a -> (a * b) mod n = ((a mod n) * b) mod n.
  Proof. intros; apply mul_mod_l; assumption. Qed.
  Hint Rewrite mul_mod_l_push using solve [ NoZMod ] : push_Zmod.

  Lemma mul_mod_r_push a b n : NoZMod b -> (a * b) mod n = (a * (b mod n)) mod n.
  Proof. intros; apply mul_mod_r; assumption. Qed.
  Hint Rewrite mul_mod_r_push using solve [ NoZMod ] : push_Zmod.

  Lemma add_mod_l_push a b n : NoZMod a -> (a + b) mod n = ((a mod n) + b) mod n.
  Proof. intros; apply add_mod_l; assumption. Qed.
  Hint Rewrite add_mod_l_push using solve [ NoZMod ] : push_Zmod.

  Lemma add_mod_r_push a b n : NoZMod b -> (a + b) mod n = (a + (b mod n)) mod n.
  Proof. intros; apply add_mod_r; assumption. Qed.
  Hint Rewrite add_mod_r_push using solve [ NoZMod ] : push_Zmod.

  Lemma sub_mod_push a b n : NoZMod a -> NoZMod b -> (a - b) mod n = ((a mod n) - (b mod n)) mod n.
  Proof. intros; apply Zminus_mod; assumption. Qed.
  Hint Rewrite sub_mod_push using solve [ NoZMod ] : push_Zmod.

  Lemma sub_mod_l_push a b n : NoZMod a -> (a - b) mod n = ((a mod n) - b) mod n.
  Proof. intros; symmetry; apply Zminus_mod_idemp_l; assumption. Qed.
  Hint Rewrite sub_mod_l_push using solve [ NoZMod ] : push_Zmod.

  Lemma sub_mod_r_push a b n : NoZMod b -> (a - b) mod n = (a - (b mod n)) mod n.
  Proof. intros; symmetry; apply Zminus_mod_idemp_r; assumption. Qed.
  Hint Rewrite sub_mod_r_push using solve [ NoZMod ] : push_Zmod.

  Lemma opp_mod_mod_push a n : NoZMod a -> (-a) mod n = (-(a mod n)) mod n.
  Proof. intros; apply opp_mod_mod; assumption. Qed.
  Hint Rewrite opp_mod_mod_push using solve [ NoZMod ] : push_Zmod.
End Z.


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

(* Certified Undecidability of Intuitionistic Linear Logic via Binary Stack Machines and Minsky Machines. Yannick Forster and Dominique Larchey-Wendling. CPP '19. http://uds-psl.github.io/ill-undecidability/ *)

(* * Halting problem for two counter Minsky machines MM2_HALTING  *)

Require Import List Arith Relations.

Set Implicit Arguments.

Section self_contained_mm2.

  (* Two counters Minsky machines. Counters are named A and B

      For instructions: INC{A,B} | DEC{A,B} j

      j is a conditional jump PC index which occurs
      when the counter has non-zero value
  *)

  Inductive mm2_instr : Set :=
    | mm2_inc_a : mm2_instr
    | mm2_inc_b : mm2_instr
    | mm2_dec_a : nat -> mm2_instr
    | mm2_dec_b : nat -> mm2_instr.

  Reserved Notation "i '//' r '⇢' s" (at level 70, no associativity).
  Reserved Notation "P '//' r '→' s" (at level 70, no associativity).
  Reserved Notation "P '//' r '↠' s" (at level 70, no associativity).
  Reserved Notation "P '//' r ↓" (at level 70, no associativity).

  Notation mm2_state := (nat*(nat*nat))%type.

  (* Instruction step semantics:

      ρ // x ⇢ y : instruction ρ transforms state x into state y

      Notice that the jump occurs on the non-zero case when DEC

   *)

  Inductive mm2_atom : mm2_instr -> mm2_state -> mm2_state -> Prop :=
    | in_mm2s_inc_a  : forall i   a b, mm2_inc_a   // (i,(  a,  b)) ⇢ (1+i,(S a,  b))
    | in_mm2s_inc_b  : forall i   a b, mm2_inc_b   // (i,(  a,  b)) ⇢ (1+i,(  a,S b))
    | in_mm2s_dec_aS : forall i j a b, mm2_dec_a j // (i,(S a,  b)) ⇢ (  j,(  a,  b))
    | in_mm2s_dec_bS : forall i j a b, mm2_dec_b j // (i,(  a,S b)) ⇢ (  j,(  a,  b))
    | in_mm2s_dec_a0 : forall i j   b, mm2_dec_a j // (i,(  0,  b)) ⇢ (1+i,(  0,  b))
    | in_mm2s_dec_b0 : forall i j a,   mm2_dec_b j // (i,(  a,  0)) ⇢ (1+i,(  a,  0))
  where "ρ // x ⇢ y" := (mm2_atom ρ x y).

  (* instruction ρ occurs at PC index i in the program (1,P) *)

  Definition mm2_instr_at (ρ : mm2_instr) i P := exists l r, P = l++ρ::r /\ 1+length l = i.

  (* Program step semantics:

      program P with first instruction at PC index 1 transforms
      state x into state y in one step, using instruction a PC index (fst x) *)

  Definition mm2_step P x y := exists ρ, mm2_instr_at ρ (fst x) P /\ ρ // x ⇢ y.

  Notation "P // x → y" := (mm2_step P x y).

  (* Halting condition: program P cannot progress anymore *)

  Definition mm2_stop P s := forall s', ~ P // s → s'.

  (* reflexive and transitive closure of program step semantics *)

  Notation "P // x ↠ y" := (clos_refl_trans _ (mm2_step P) x y).

  Definition mm2_terminates P s := exists s', P // s ↠ s' /\ mm2_stop P s'.

  Notation "P // s ↓" := (mm2_terminates P s).

  Definition MM2_PROBLEM := (list mm2_instr * nat * nat)%type.

  Definition MM2_HALTING (P : MM2_PROBLEM) :=
    match P with (P,a,b) => P // (1,(a,b)) ↓ end.

  Definition MM2_HALTS_ON_ZERO (P : MM2_PROBLEM) :=
    match P with (P,a,b) => P // (1,(a,b)) ↠ (0,(0,0)) end.

End self_contained_mm2.


Require Import List.
Require Import util.
Require concrete.
Require abstract.
Require respect.
Set Implicit Arguments.

Section contents.

  (* Suppose we wish to abstract a concrete system.. *)

  Variable concrete_system: concrete.System.

  Let Location := concrete.Location concrete_system.
  Let Point := concrete.Point concrete_system.
    (* convenience *)

  (* We will need decideable equality on the system's locations, as
   well as a set of regions (which can contain Points), and
   exhaustive lists of locations and regions. *)

  Variables
    (Location_eq_dec: forall l l': Location, decision (l=l'))
    (Region: Set) (Region_eq_dec: forall i i': Region, decision (i=i'))
    (in_region: concrete.Point concrete_system -> Region -> Prop)
    (select_region: Point -> Region)
    (locations: list Location) (locations_complete: forall l, List.In l locations)
    (regions: list Region) (regions_complete: forall i, List.In i regions).

  (* We can now define the abstract states: *)

  Let State: Set := prod Location Region.

  Definition State_eq_dec (s s': State): decision (s=s').
    unfold State.
    apply (pair_eq_dec Location_eq_dec Region_eq_dec).
  Defined.

  Definition states: list State :=
    flat_map (fun l => map (pair l) regions) locations.

  Lemma states_complete: forall s, List.In s states.
  Proof with auto.
    destruct s.
    unfold states.
    destruct (in_flat_map (fun l => map (pair l) regions) locations (l, r)).
    apply H0.
    exists l.
    split...
    apply in_map...
  Qed.

  (* Next, we define the "ideal" criteria for when there should be
   transitions between abstract states, as well as for when
   an abstract state should be initial. *)

  Definition initial_condition (l: State): Prop :=
    exists p, in_region p (snd l) /\
    concrete.initial (fst l, p).

  Definition continuous_transition_condition
    (l: prod Location (prod Region Region)): Prop :=
    exists p, exists q,
      in_region p (fst (snd l)) /\ in_region q (snd (snd l)) /\
      concrete.cont_trans (fst l, p) (fst l, q).

  Definition discrete_transition_condition
    (l: prod State State): Prop :=
    exists p, exists q,
      in_region p (snd (fst l)) /\ in_region q (snd (snd l)) /\
      concrete.disc_trans (fst (fst l), p) (fst (snd l), q).

  (* These are not decideable, however, so we'll let users specify
   weak deciders for these conditions. *)

  Variables
    (cont_decider: decideable_overestimator continuous_transition_condition)
    (disc_decider: decideable_overestimator discrete_transition_condition)
    (initial_decider: decideable_overestimator initial_condition).

  (* Using these, we can define the abstract transitions.. *)

  Definition canContTrans (l: Location) (s s': Region): bool :=
    unsumbool (doe_dec cont_decider (l, (s, s'))).
  Definition canDiscTrans (s s': State): bool :=
    unsumbool (doe_dec disc_decider (s, s')).

  Definition contTrans (s: State): list State :=
    map (pair (fst s)) (filter (canContTrans (fst s) (snd s)) regions).
  Definition discreteTrans (s: State): list State :=
    filter (canDiscTrans s) states.
      (* a more efficient implementation would grow the graph *)

  Definition initial (s: State): bool :=
    unsumbool (doe_dec initial_decider s).

  (* .. and the abstract system itself: *)

  Definition abstract_system: abstract.System :=
    abstract.Build_System State_eq_dec states states_complete initial contTrans discreteTrans.

  (* Next, we will show that this abstract system respects the concrete
   system by the following abstraction function: *)

  Definition absFunc (s: concrete.State concrete_system):
     abstract.State abstract_system :=
    match s with
    | pair l p => pair l (select_region p)
    end.

  Lemma fst_absFunc s: fst (absFunc s) = fst s.
  Proof. destruct s. reflexivity. Qed.

  Hypothesis regions_cover_invariants: forall l p,
    concrete.invariant (l, p) -> in_region p (select_region p).

  Lemma respectsInit
    (s: concrete.Location concrete_system * concrete.Point concrete_system):
    concrete.initial s -> abstract.initial (absFunc s) = true.
  Proof with auto.
    intros.
    destruct s.
    unfold absFunc.
    simpl.
    unfold initial.
    destruct (doe_dec initial_decider (l, select_region p))...
    elimtype False. apply n. clear n.
    apply doe_correct.
    unfold initial_condition.
    exists p.
    split...
    simpl snd.
    apply regions_cover_invariants with l.
    apply concrete.invariant_initial...
  Qed.

  Lemma respectsDisc (s1 s2: concrete.State concrete_system):
    concrete.disc_trans s1 s2 ->
    In (absFunc s2) (abstract.disc_trans (absFunc s1)).
  Proof with auto.
    intros.
    unfold abstract.disc_trans, abstract_system, discreteTrans.
    destruct (filter_In (canDiscTrans (absFunc s1)) (absFunc s2) states).
    apply H1.
    split.
      apply states_complete.
    unfold canDiscTrans.
    destruct (@doe_dec (prod State State) discrete_transition_condition disc_decider
        (@pair State State (absFunc s1) (absFunc s2)))...
    elimtype False.
    apply n.
    clear n H0 H1.
    apply doe_correct.
    unfold discrete_transition_condition.
    simpl fst. simpl snd.
    destruct H.
    destruct H0.
    destruct H1.
    exists (snd s1).
    exists (snd s2).
    simpl snd.
    repeat rewrite fst_absFunc.
    simpl in H0.
    simpl concrete.Location. simpl concrete.Point.
    split.
      destruct s1. simpl.
      apply regions_cover_invariants with l...
    split.
      destruct s2. simpl.
      apply regions_cover_invariants with l...
    unfold concrete.disc_trans.
    simpl fst. simpl snd.
    destruct s1.
    split...
    split...
    split...
    destruct s2...
  Qed.

  Lemma respectsCont s1 s2: (concrete.cont_trans s1 s2) ->
    In (absFunc s2) (abstract.cont_trans (absFunc s1)).
  Proof with auto with real.
    intros.
    unfold abstract_system.
    simpl abstract.cont_trans.
    destruct s1. destruct s2.
    unfold concrete.cont_trans in H.
    unfold contTrans.
    destruct H. destruct H0. destruct H0. simpl in * |-. subst.
    rewrite fst_absFunc.
    simpl fst.
    rename l0 into l.
    simpl absFunc.
    apply in_map.
    simpl fst. simpl snd.
    destruct (filter_In
      (canContTrans l (select_region p)) (select_region (concrete.flow concrete_system l p (proj1_sig x))) regions).
    clear H. apply H1. clear H1.
    split.
      apply regions_complete.
    unfold canContTrans.
    destruct (@doe_dec (prod Location (prod Region Region))
        continuous_transition_condition cont_decider
        (@pair Location (prod Region Region) l
           (@pair Region Region (select_region p)
              (select_region (concrete.flow concrete_system l p (proj1_sig x))))))...
    elimtype False. apply n. clear n.
    apply doe_correct.
    unfold continuous_transition_condition.
    simpl fst. simpl snd.
    exists p. exists (concrete.flow concrete_system l p (proj1_sig x)).
    split.
      apply regions_cover_invariants with l.
      rewrite <- (flow.flow_zero (concrete.flow concrete_system l)) with p.
      destruct x...
    split.
      apply regions_cover_invariants with l.
      destruct x...
    unfold concrete.cont_trans.
    simpl fst. simpl snd.
    split...
    exists x...
  Qed.

  (* Et voila: *)

  Theorem respect: respect.Respects abstract_system absFunc.
  Proof respect.Build_Respects abstract_system absFunc respectsInit respectsDisc respectsCont.

  Lemma result:
    { abstract_system: abstract.System &
    { f: concrete.State concrete_system -> abstract.State abstract_system
    | respect.Respects abstract_system f } }.
  Proof.
    exists abstract_system.
    exists absFunc.
    apply respect.
  Defined.

End contents.


Require Import Coq.Numbers.Natural.Peano.NPeano.
Require Import Coq.Arith.Plus.
Require Import Coq.Arith.Mult.
Require Import Coq.Arith.Wf_nat.

Lemma plus_red_l : forall a b p, a = b -> p + a = p + b.
auto.
Qed.

Lemma plus_red_r : forall a b p, a = b -> a + p = b + p.
auto.
Qed.

Lemma mult_red_l : forall a b p, a = b -> p * a = p * b.
auto.
Qed.

Lemma mult_red_r : forall a b p, a = b -> a * p = b * p.
auto.
Qed.

Proposition div_n0 : forall n, n / 0 = 0.
Proof.
  auto.
Qed.

Lemma div_0 : forall n, 0 / n = 0.
Proof.
destruct n; auto.
Qed.

Proposition div_S : forall n m, m <> 0 -> (n + m) / m = S (n / m).
Proof.
  intros n m.
  case m.
  now tauto.
  intros m' NeqH.
  unfold div.
  assert (lem : forall x y z, divmod (x + (S z)) y 0 z = divmod (S x) y 0 0).
  {
    intros x y.
    induction z.
    + rewrite plus_comm. now auto.
    +
      transitivity (divmod (S (x + S z)) y 0 (S z)).
      assert(EqS : (x + S (S z)) = S (x + S z)).
      {
        transitivity (S (S z) + x).
        now apply plus_comm.
        transitivity (S (S z + x)).
        now auto.
        rewrite plus_comm.
        now auto.
      }
      rewrite EqS.
      now reflexivity.
      transitivity (divmod (x + S z) y 0 z).
      now auto.
      rewrite IHz.
      now auto.
  }
  rewrite lem.
  simpl.
  assert(lem2 : forall a b c d, fst (divmod a b (S c) d) = S (fst (divmod a b c d))).
  {
    induction a.
    now auto.
    intros b c.
    destruct d.
    +
      simpl.
      apply IHa.
    +
      simpl.
      apply IHa.
  }
  apply lem2.
Qed.

Proposition div_le : forall n m, n < m -> n / m = 0.
Proof.
assert(forall a b c, a < c -> fst (divmod a b 0 c) = 0).
{
  induction a.
  now auto.
  intros b c leac.
  destruct c.
  +
    apply lt_n_0 in leac.
    destruct leac.
  +
    simpl.
    apply IHa.
    apply lt_S_n.
    auto.
}
intros n m lenm.
unfold div.
destruct m.
now auto.
unfold lt in lenm.
apply le_S_n in lenm.
apply le_lt_or_eq in lenm.
destruct lenm as [lenm | eqnm].
+
  apply H.
  apply lenm.
+
  rewrite eqnm.
  cut (forall a b, fst (divmod a b 0 a) = 0).
  now auto.
  induction a.
  now auto.
  simpl.
  apply IHa.
Qed.

Proposition mod_plus : forall a b, b <> 0 -> modulo (a + b) b = modulo a b.
Proof.
intros a b neb0.
generalize (div_mod (a + b) b neb0); intro divapb.
rewrite (div_S _ _ neb0) in divapb.
rewrite mult_comm in divapb.
simpl in divapb.
rewrite <- plus_assoc in divapb.
rewrite (plus_comm a b) in divapb.
apply plus_reg_l in divapb.
rewrite (div_mod a _ neb0) in divapb at 1.
rewrite mult_comm in divapb.
apply plus_reg_l in divapb.
symmetry.
rewrite (plus_comm a b).
auto.
Qed.

Lemma mult_div_mod : forall a b r, b <> 0 -> r < b -> (a * b + r) / b = a.
Proof.
induction a.
+
  simpl.
  intros b r neb0 lerb.
  apply div_le.
  apply lerb.
+
  intros b r neqb lerb.
  simpl.
  rewrite plus_assoc_reverse.
  rewrite plus_comm.
  rewrite (div_S _ _ neqb).
  rewrite (IHa _ _ neqb lerb).
  auto.
Qed.

Lemma mult_div : forall a b, b <> 0 -> a * b / b = a.
Proof.
intros a b neb0.
transitivity ((a*b+0) / b).
{
  rewrite plus_comm.
  simpl.
  auto.
}
apply (mult_div_mod _ _ _ neb0).
unfold lt.
destruct b.
elimtype False.
apply neb0.
reflexivity.
apply le_n_S.
apply le_0_n.
Qed.

Lemma mult_div' : forall a b, b <> 0 -> b * a / b = a.
Proof.
intros a b neb.
rewrite mult_comm.
apply mult_div.
auto.
Qed.

Lemma mult_rem_div : forall a b r q, b <> 0 -> (a = q*b + r /\ r < b) -> q = a / b.
Proof.
  intros a b r.
  induction q.
  +
    intros neqb0 [Eqa lerb].
    simpl in Eqa.
    rewrite Eqa.
    rewrite (div_le _ _ lerb).
    auto.
  +
    intros neqb0 [Eqa lerb].
    simpl in Eqa.
    rewrite Eqa.
    rewrite plus_assoc_reverse.
    rewrite plus_comm.
    rewrite (div_S _ _ neqb0).
    rewrite (mult_div_mod _ _ _ neqb0 lerb).
    auto.
Qed.

Lemma mult_rem_mod : forall a b r q, b <> 0 -> (a = q*b + r /\ r < b) -> modulo a b = r.
Proof.
intros a b r q neb0 [Eqa lerb].
assert(Eqq : q = a / b).
{
  apply (mult_rem_div a b r q neb0).
  split; assumption.
}
rewrite Eqq in Eqa.
generalize (div_mod a _ neb0); intro Eqa'.
rewrite mult_comm in Eqa'.
rewrite Eqa' in Eqa at 1.
apply plus_reg_l in Eqa.
apply Eqa.
Qed.

Proposition mod_le : forall a b, a < b -> modulo a b = a.
Proof.
intros a b leab.
destruct b.
now auto.
assert(neb : S b <> 0).
 intro eqb0.
 inversion eqb0.
symmetry.
rewrite (div_mod a _ neb) at 1.
rewrite (div_le _ _ leab).
cut (S b * 0 = 0).
 intros EqH.
 rewrite EqH.
 now auto.
auto.
Qed.

Lemma mod_bound : forall a b, b <> 0 -> modulo a b < b.
Proof.
intros a b neb0.
apply mod_bound_pos.
apply le_0_n.
apply neq_0_lt.
intro eq0b.
apply neb0.
rewrite eq0b.
auto.
Qed.

Lemma mod_exists : forall a b c, b <> 0 -> modulo a b = c -> exists n, a = n * b + c.
Proof.
intros a b c beq Eqc.
generalize (div_mod a _ beq); intro eqa.
rewrite Eqc in eqa.
exists (a / b).
rewrite mult_comm.
apply eqa.
Qed.

Section pow3.

  Definition pow2 m := m * m.
  Definition mod3 n := modulo n 3.

  Lemma ne03 : 3 <> 0.
  Proof.
  auto.
  Qed.

  Lemma mod3_le : forall n, mod3 n <= 2.
  Proof.
    intro n.
    unfold mod3.
    apply lt_n_Sm_le.
    apply mod_bound.
    apply ne03.
  Qed.

  Lemma mod3_dest : forall n, mod3 n = 0 \/ mod3 n = 1 \/ mod3 n = 2.
  Proof.
    intro n.
    set (mod3 n) as m.
    assert(lem3 : m <= 2).
     apply mod3_le.
    destruct m.
    now auto.
    destruct m.
    now auto.
    destruct m.
    now auto.
    repeat apply le_S_n in lem3.
    apply le_Sn_0 in lem3.
    destruct lem3.
  Qed.

  Lemma mod3_0 : forall n, mod3 n = 0 -> exists p, n = 3*p.
  Proof.
    intros n modH.
    generalize (mod_exists _ _ _ ne03 modH); intro HH.
    destruct HH as [p Eqn].
    exists p.
    rewrite Eqn.
    transitivity (p*3).
    now rewrite plus_comm; auto.
    apply mult_comm.
  Qed.

  Lemma mod3_1 : forall n, mod3 n = 1 -> exists p, n = 3*p + 1.
  Proof.
    intros n modH.
    generalize (mod_exists _ _ _ ne03 modH); intro HH.
    destruct HH as [p Eqn].
    exists p.
    rewrite Eqn.
    rewrite mult_comm.
    auto.
  Qed.

  Lemma mod3_2 : forall n, mod3 n = 2 -> exists p, n = 3*p + 2.
  Proof.
    intros n modH.
    generalize (mod_exists _ _ _ ne03 modH); intro HH.
    destruct HH as [p Eqn].
    exists p.
    rewrite Eqn.
    rewrite mult_comm.
    auto.
  Qed.

  Lemma To_mod3_0 : forall n, mod3 (3 * n) = 0.
  Proof.
    intro n.
    apply (mult_rem_mod _ _ _ n).
    apply ne03.
    split.
    transitivity (n*3).
    now apply mult_comm.
    rewrite plus_comm.
    auto.
    unfold lt.
    apply le_n_S.
    apply le_0_n.
  Qed.

  Lemma To_mod3_1 : forall n, mod3 (3 * n + 1) = 1.
  Proof.
    intro n.
    apply (mult_rem_mod _ _ _ n).
    apply ne03.
    split.
    rewrite mult_comm.
    auto.
    unfold lt.
    apply le_n_S.
    apply le_n_S.
    apply le_0_n.
  Qed.

  Lemma To_mod3_2 : forall n, mod3 (3 * n + 2) = 2.
  Proof.
    intro n.
    apply (mult_rem_mod _ _ _ n).
    apply ne03.
    split.
    rewrite mult_comm.
    auto.
    unfold lt.
    apply le_n_S.
    apply le_n_S.
    apply le_n_S.
    apply le_0_n.
  Qed.

  Lemma plus_reg_r : forall n m p : nat, n + p = m + p -> n = m.
  Proof.
    intros n m p eq.
    rewrite (plus_comm n p) in eq.
    rewrite (plus_comm m p) in eq.
    apply plus_reg_l in eq.
    auto.
  Qed.

  Lemma mult_plus_distr : forall a b c d, (a + b) * (c + d) = a * c + b * c + a * d + b * d.
  Proof.
    intros a b c d.
    transitivity ((a+b) * c + (a+b) * d).
    now apply mult_plus_distr_l.
    transitivity ((a*c + b*c) + ((a+b) * d)).
    {
      apply plus_red_r.
      apply mult_plus_distr_r.
    }
    transitivity ((a*c + b*c) + (a*d + b*d)).
    {
      apply plus_red_l.
      apply mult_plus_distr_r.
    }
    rewrite plus_assoc.
    auto.
  Qed.

  Lemma pow2_distr : forall a b, pow2 (a + b) = pow2 a + 2 * (a*b) + pow2 b.
  Proof.
    intros a b.
    unfold pow2 at 1.
    rewrite mult_plus_distr.
    transitivity (pow2 a + b * a + a * b + pow2 b).
    {
      unfold pow2.
      auto.
    }
    apply plus_red_r.
    rewrite plus_assoc_reverse.
    apply plus_red_l.
    transitivity (a * b + a * b).
    {
      rewrite (mult_comm b a).
      auto.
    }
    simpl.
    apply plus_red_l.
    rewrite plus_comm.
    auto.
  Qed.

  Lemma pow23p0 : forall p, pow2 (3 * p) = 3 * (3 * pow2 p).
  Proof.
    intro p.
    unfold pow2.
    transitivity (3 * (p * (3 * p))).
    now apply mult_assoc_reverse.
    apply mult_red_l.
    transitivity (p * 3 * p).
    now apply mult_assoc.
    transitivity (3 * p * p).
    {
      apply mult_red_r.
      apply mult_comm.
    }
    apply mult_assoc_reverse.
  Qed.

  Lemma pow23p1 : forall p, pow2 (3*p+1) = 3 * (3 * pow2 p + 2 * p) + 1.
  Proof.
    intro p.
    rewrite pow2_distr.
    transitivity (pow2 (3 * p) + (2 * (3* p * 1)) + 1).
    {
      cut (pow2 1 = 1).
      intro relH.
      rewrite relH.
      auto.
      reflexivity.
    }
    apply plus_red_r.
    transitivity (pow2 (3 * p) + 3 * (2 * p)).
    {
      apply plus_red_l.
      rewrite mult_1_r.
      transitivity (2 * 3 * p).
      now apply mult_assoc.
      transitivity (3 * 2 * p).
      {
        apply mult_red_r.
        apply mult_comm.
      }
      apply mult_assoc_reverse.
    }
    rewrite pow23p0.
    symmetry.
    apply mult_plus_distr_l.
  Qed.

  Lemma pow23p2 : forall p, pow2 (3*p+2) = 3 * (3 * pow2 p + 4 * p + 1) + 1.
  Proof.
    intro p.
    rewrite pow2_distr.
    transitivity (pow2 (3 * p) + 2 * (3 * p * 2) + 3 * 1 + 1).
    {
      transitivity (pow2 (3 * p) + (2 * (3 * p * 2) + pow2 2)).
      now apply plus_assoc_reverse.
      transitivity (pow2 (3 * p) + (2 * (3 * p * 2) + (3 * 1 + 1))).
      {
        apply plus_red_l.
        apply plus_red_l.
        reflexivity.
      }
      rewrite (plus_assoc _ _ 1).
      rewrite plus_assoc.
      apply plus_red_r.
      apply plus_assoc.
    }
    apply plus_red_r.
    transitivity (pow2 (3 * p) + 3 * (4 * p) + 3 * 1).
    {
      apply plus_red_r.
      apply plus_red_l.
      transitivity (2 * (3 * 2 * p)).
      {
        apply mult_red_l.
        transitivity (3 * (p * 2)).
        now apply mult_assoc_reverse.
        rewrite (mult_comm p 2).
        apply mult_assoc.
      }
      transitivity (2 * (6 * p)).
      {
        apply mult_red_l.
        apply mult_red_r.
        reflexivity.
      }
      transitivity (2 * 6 * p).
      now apply mult_assoc.
      transitivity (12 * p).
      {
        apply mult_red_r.
        reflexivity.
      }
      transitivity (3 * 4 * p).
      {
        apply mult_red_r.
        reflexivity.
      }
      apply mult_assoc_reverse.
    }
    rewrite pow23p0.
    rewrite <- (mult_plus_distr_l 3).
    rewrite <- (mult_plus_distr_l 3).
    reflexivity.
  Qed.

  Theorem Problem1 : forall n, mod3 (pow2 n) = 0 \/ mod3 (pow2 n) = 1.
  Proof.
    intro n.
    destruct (mod3_dest n) as [case1 | [case2 | case3]].
    +
      left.
      apply mod3_0 in case1.
      destruct case1 as [p eqn].
      rewrite eqn.
      rewrite pow23p0.
      apply To_mod3_0.
    +
      right.
      apply mod3_1 in case2.
      destruct case2 as [p eqn].
      rewrite eqn.
      rewrite pow23p1.
      apply To_mod3_1.
    +
      right.
      apply mod3_2 in case3.
      destruct case3 as [p eqn].
      rewrite eqn.
      rewrite pow23p2.
      apply To_mod3_1.
  Qed.

  Lemma mod3pow20_mod30 : forall a, mod3 (pow2 a) = 0 -> mod3 a = 0.
  Proof.
    intros a modH.
    destruct (mod3_dest a) as [case1 | [case2 | case3]].
    + auto.
    +
      apply mod3_1 in case2.
      destruct case2 as [p eqa].
      rewrite eqa in modH.
      rewrite pow23p1 in modH.
      rewrite To_mod3_1 in modH.
      discriminate.
    +
      apply mod3_2 in case3.
      destruct case3 as [p eqa].
      rewrite eqa in modH.
      rewrite pow23p2 in modH.
      rewrite To_mod3_1 in modH.
      discriminate.
  Qed.

  Theorem Problem2 : forall a b c, pow2 a + pow2 b = 3 * pow2 c -> mod3 a = 0 /\ mod3 b = 0 /\ mod3 c = 0.
  Proof.
    intros a b c eq.
    assert(Lemma1 : mod3 a = 0 /\ mod3 b = 0).
    {
      assert(pow2_lem : mod3 (pow2 a) = 0 /\ mod3 (pow2 b) = 0).
      {
        destruct (Problem1 a) as [eq00 | eq01] ; destruct (Problem1 b) as [eq10 | eq11].
        +
          split; auto.
        +
          apply mod3_0 in eq00.
          destruct eq00 as [a' eqa].
          apply mod3_1 in eq11.
          destruct eq11 as [b' eqb].
          rewrite eqa in eq.
          rewrite eqb in eq.
          rewrite plus_assoc in eq.
          rewrite <- (mult_plus_distr_l 3) in eq.
          assert(P1 : mod3 (3 * pow2 c) = 1).
          {
            rewrite <- eq.
            apply To_mod3_1.
          }
          rewrite To_mod3_0 in P1.
          discriminate P1.
        +
          apply mod3_1 in eq01.
          destruct eq01 as [a' eqa].
          apply mod3_0 in eq10.
          destruct eq10 as [b' eqb].
          rewrite eqa in eq.
          rewrite eqb in eq.
          rewrite plus_assoc_reverse in eq.
          rewrite (plus_comm 1 (3 * b')) in eq.
          rewrite (plus_assoc) in eq.
          rewrite <- (mult_plus_distr_l 3) in eq.
          assert(P1 : mod3 (3 * pow2 c) = 1).
          {
            rewrite <- eq.
            apply To_mod3_1.
          }
          rewrite To_mod3_0 in P1.
          discriminate P1.
        +
          apply mod3_1 in eq01.
          destruct eq01 as [a' eqa].
          apply mod3_1 in eq11.
          destruct eq11 as [b' eqb].
          rewrite eqa in eq.
          rewrite eqb in eq.
          assert(P1 : mod3 (3 * pow2 c) = 2).
          {
            rewrite <- eq.
            cut (3 * a' + 1 + (3 * b' + 1) = 3 * (a' + b') + 2).
            {
              intro relH.
              rewrite relH.
              apply To_mod3_2.
            }
            rewrite plus_assoc.
            transitivity (3 * a' + 3 * b' + 1 + 1).
            {
              apply plus_red_r.
              transitivity (3 * a' + (1 + 3 * b')).
              now apply plus_assoc_reverse.
              rewrite (plus_comm 1 (3*b')).
              apply plus_assoc.
            }
            rewrite <- (mult_plus_distr_l 3).
            rewrite plus_assoc_reverse.
            apply plus_red_l.
            reflexivity.
          }
          rewrite To_mod3_0 in P1.
          discriminate.
      }
      destruct pow2_lem as [mpa0 mpb0].
      split; apply mod3pow20_mod30; assumption.
    }
    destruct Lemma1 as [mda0 mdb0].
    assert(mdc0 : mod3 c = 0).
    {
      apply mod3_0 in mda0.
      destruct mda0 as [a' eqa].
      apply mod3_0 in mdb0.
      destruct mdb0 as [b' eqb].
      apply mod3pow20_mod30.
      cut (pow2 c = 3 * (pow2 a' + pow2 b')).
      {
        intro relH.
        rewrite relH.
        apply To_mod3_0.
      }
      cut (3 * pow2 c = 3 * (3 * (pow2 a' + pow2 b'))).
      {
        intro relH.
        transitivity (3 * pow2 c / 3).
        {
          symmetry.
          apply mult_div'.
          intro reH.
          discriminate.
        }
        rewrite relH.
        apply mult_div'.
        intro neq.
        discriminate.
      }
      rewrite <- eq.
      rewrite eqa.
      rewrite eqb.
      rewrite pow23p0.
      rewrite pow23p0.
      rewrite <- mult_plus_distr_l.
      apply mult_red_l.
      symmetry.
      apply mult_plus_distr_l.
    }
    split.
    assumption.
    split.
    assumption.
    assumption.
  Qed.

(*
  Lemma mod3_0_dest : forall n, mod3 n = 0 -> (n = 0 \/ (exists p r, n = 3 ^ p * r /\ mod3 r <> 0)).
  Proof.
*)
  Lemma mod3_0_dest : forall n, n = 0 \/ (exists p r, 3 * n = 3 ^ p * r /\ (mod3 r = 1 \/ mod3 r = 2)).
  Proof.
    apply (well_founded_induction lt_wf (fun n => n = 0 \/ (exists p r, 3 * n = 3^p*r /\ (mod3 r = 1 \/ mod3 r = 2)))).
    intros n IndH.
    destruct n.
    now auto.
    destruct (IndH _ (lt_n_Sn n)) as [Eqy0 | [p [r [Eqn [Eqr1 | Eqr2]]]]].
    {
      rewrite Eqy0.
      right.
      exists 1.
      exists 1.
      split.
      now reflexivity.
      left.
      now reflexivity.
    } {
      right.
      destruct p.
      -
        rewrite pow_0_r in Eqn.
        rewrite mult_1_l in Eqn.
        rewrite <- Eqn in Eqr1.
        rewrite To_mod3_0 in Eqr1.
        discriminate.
      -
        exists 1.
        exists (3^p*r+1).
        split.
        +
          rewrite mult_succ_r.
          rewrite Eqn.
          transitivity(3*(3^p*r)+3).
          {
            apply plus_red_r.
            rewrite mult_assoc.
            apply mult_red_r.
            reflexivity.
          }
          transitivity(3*(3^p*r) + 3*1).
          {
            apply plus_red_l.
            reflexivity.
          }
          rewrite <- mult_plus_distr_l.
          apply mult_red_r.
          reflexivity.
        +
          destruct p.
          *
            right.
            rewrite pow_0_r.
            rewrite mult_1_l.
            apply mod3_1 in Eqr1.
            destruct Eqr1 as [q Eqr].
            rewrite Eqr.
            rewrite plus_assoc_reverse.
            assert(H112 : 1+1=2).
            now reflexivity.
            rewrite H112.
            apply To_mod3_2.
          *
            cut(3^(S p) * r + 1 = 3*(3^p*r)+1).
            {
              intro relH.
              rewrite relH.
              left.
              apply To_mod3_1.
            }
            apply plus_red_r.
            rewrite mult_assoc.
            apply mult_red_r.
            reflexivity.
    } {
      right.
      destruct p.
      -
        rewrite pow_0_r in Eqn.
        rewrite mult_1_l in Eqn.
        rewrite <- Eqn in Eqr2.
        rewrite To_mod3_0 in Eqr2.
        discriminate.
      -
        destruct p.
        {
          assert(Eqnr : n = r).
          {
            cut(3*n = 3*r).
            {
              intro Eq3n.
              transitivity (3*n / 3).
              {
                rewrite (mult_div' _ _ ne03).
                reflexivity.
              }
              rewrite Eq3n.
              apply (mult_div' _ _ ne03).
            }
            rewrite Eqn.
            apply mult_red_r.
            reflexivity.
          }
          rewrite <- Eqnr in Eqr2.
          clear Eqn.
          clear Eqnr.
          clear r.
          assert(mod3nS : mod3 (S n) = 0).
          {
            apply mod3_2 in Eqr2.
            destruct Eqr2 as [p Eqr2].
            rewrite Eqr2.
            cut(S(3*p+2) = 3*(p+1)).
            {
              intro relH.
              rewrite relH.
              apply To_mod3_0.
            }
            transitivity(3*p+2+1).
            {
              rewrite (plus_comm _ 1).
              reflexivity.
            }
            rewrite mult_plus_distr_l.
            rewrite plus_assoc_reverse.
            reflexivity.
          }
          apply mod3_0 in mod3nS.
          destruct mod3nS as [p EqSn].
          assert(lepSn : p < S n).
          {
            rewrite EqSn.
            rewrite <- mult_1_l at 1.
            apply mult_lt_compat_r.
            unfold lt.
            apply le_n_S.
            apply le_n_S.
            now apply le_0_n.
            cut (p <> 0).
            {
              intro nep0.
              destruct p.
              now discriminate.
              unfold lt.
              apply le_n_S.
              apply le_0_n.
            }
            intro Eqp0.
            rewrite Eqp0 in EqSn.
            simpl in EqSn.
            discriminate EqSn.
          }
          rewrite EqSn.
          destruct (IndH _ lepSn) as [Eqp0 | [t [u [Eq3p [Equ1 | Equ2]]]]].
          {
            rewrite Eqp0 in EqSn.
            simpl in EqSn.
            discriminate EqSn.
          } {
            rewrite Eq3p.
            exists (S t).
            exists u.
            split.
            -
              rewrite mult_assoc.
              reflexivity.
            -
              auto.
          } {
            rewrite Eq3p.
            exists (S t).
            exists u.
            split.
            -
              rewrite mult_assoc.
              reflexivity.
            -
              auto.
          }
        }
        {
          exists 1.
          exists (3^(S p) * r + 1).
          split.
          -
            transitivity (3 * (n+1)).
            {
              apply mult_red_l.
              rewrite plus_comm.
              reflexivity.
            }
            rewrite mult_plus_distr_l.
            rewrite Eqn.
            transitivity(3*3^(S p) * r + 3*1).
            {
              apply plus_red_r.
              apply mult_red_r.
              reflexivity.
            }
            transitivity(3*(3^(S p)*r + 1)).
            {
              rewrite mult_plus_distr_l.
              apply plus_red_r.
              apply mult_assoc_reverse.
            }
            apply mult_red_r.
            reflexivity.
          -
            left.
            cut(3^(S p) * r + 1 = 3*(3^p*r)+1).
            {
              intro relH.
              rewrite relH.
              apply To_mod3_1.
            }
            apply plus_red_r.
            rewrite mult_assoc.
            apply mult_red_r.
            reflexivity.
        }
      }
  Qed.

  Lemma IndLemma : forall (P : nat -> Prop), (forall n, P n -> exists n', n = 3 * n' /\ P n') -> forall n, P n -> n = 0.
  Proof.
    intros P IndH n Pn.
    assert(eq3n : exists n', n = 3*n').
    {
      destruct(IndH _ Pn) as [n' [Eqn Pn']].
      exists n'.
      auto.
    }
    destruct eq3n as [n' Eqn].
    destruct (mod3_0_dest n') as [Eqn0 | HH].
    {
      rewrite Eqn0 in Eqn.
      simpl in Eqn.
      auto.
    }
    destruct HH as [p [r [Eq3n' modr]]].
    assert(PInd : forall b t, P(3^t*b) -> P b).
    {
      intro b.
      induction t.
      {
        assert(relH : 3^0*b=b).
        {
          rewrite pow_0_r.
          rewrite mult_1_l.
          auto.
        }
        rewrite relH.
        tauto.
      } {
        intro PH'.
        apply IHt.
        destruct (IndH _ PH') as [t' [Eqt' Pt']].
        cut(t' = 3^t*b).
        {
          intro relH.
          rewrite <- relH.
          auto.
        }
        transitivity(3*t'/3).
        {
          rewrite mult_div'.
          auto.
          apply ne03.
        }
        rewrite <- Eqt'.
        assert(Eq3t : 3^(S t) * b = 3*(3^t * b)).
        {
          rewrite mult_assoc.
          apply mult_red_r.
          reflexivity.
        }
        rewrite Eq3t.
        apply mult_div'.
        apply ne03.
      }
    }
    rewrite Eqn in Pn.
    rewrite Eq3n' in Pn.
    apply PInd in Pn.
    assert(modr0 : mod3 r = 0).
    {
      apply IndH in Pn.
      destruct Pn as [r' [Eqr' Pr']].
      rewrite Eqr'.
      apply To_mod3_0.
    }
    rewrite modr0 in modr.
    destruct modr; discriminate.
  Qed.

  Theorem Problem3 : forall a b c, pow2 a + pow2 b = 3 * pow2 c -> a = 0 /\ b = 0 /\ c = 0.
  Proof.
    set (fun a b c => pow2 a + pow2 b = 3 * pow2 c) as P.
    cut(forall a b c, P a b c -> a=0 /\ b=0 /\ c=0).
    {
      tauto.
    }
    assert(Lem : forall x y z, P x y z -> exists x' y' z', (x = 3 * x' /\ y = 3 * y' /\ z = 3 * z') /\ P x' y' z').
(*    assert(Lemma : forall x y z, pow2 x + pow2 y = 3 * pow2 z -> exists x' y' z', (x = 3 * x' /\ y= 3 * y' /\ z = 3 * z') /\ pow2 x' + pow2 y' = 3 * pow2 z').*)
    {
      unfold P.
      intros x y z eq.
      generalize (Problem2 _ _ _ eq); intro eq'.
      destruct eq' as [mx [my mz]].
      apply mod3_0 in mx.
      apply mod3_0 in my.
      apply mod3_0 in mz.
      destruct mx as [x' eqx].
      destruct my as [y' eqy].
      destruct mz as [z' eqz].
      exists x'.
      exists y'.
      exists z'.
      split.
      {
        split.
        assumption.
        split.
        assumption.
        assumption.
      }
      rewrite eqx in eq.
      rewrite eqy in eq.
      rewrite eqz in eq.
      rewrite pow23p0 in eq.
      rewrite pow23p0 in eq.
      rewrite pow23p0 in eq.
      symmetry.
      transitivity ((9 * (3 * pow2 z')) / 9).
      {
        symmetry.
        apply mult_div'.
        intro dis.
        discriminate.
      }
      transitivity ((3 * (3 * (3 * pow2 z'))) / 9).
      {
        cut (9 * (3 * pow2 z') = 3 * (3 * (3 * pow2 z'))).
        intro relH; rewrite relH; auto.
        transitivity ((3 * 3) * (3 * pow2 z')).
        {
          apply mult_red_r.
          reflexivity.
        }
        apply mult_assoc_reverse.
      }
      rewrite <- eq.
      rewrite <- mult_plus_distr_l.
      rewrite <- mult_plus_distr_l.
      rewrite mult_assoc.
      transitivity ((9 * (pow2 x' + pow2 y')) / 9).
      {
        cut (3*3=9).
        intro relH; rewrite relH; auto.
        reflexivity.
      }
      apply mult_div'.
      intro dis.
      discriminate.
    }
    set (fun a => exists b c, P a b c) as P1.
    set (fun b => exists a c, P a b c) as P2.
    set (fun c => exists a b, P a b c) as P3.
    intros a b c Pabc.
    assert(P1H : P1 a).
    {
      unfold P1.
      exists b.
      exists c.
      now assumption.
    }
    assert(P2H : P2 b).
    {
      unfold P2.
      exists a.
      exists c.
      now assumption.
    }
    assert(P3H : P3 c).
    {
      unfold P3.
      exists a.
      exists b.
      now assumption.
    }
    split; try split.
    +
      generalize P1H.
      apply IndLemma.
      intros x P1x.
      unfold P1 in P1x.
      destruct P1x as [y [z Pxyz]].
      apply Lem in Pxyz.
      destruct Pxyz as [x' [y' [z' [[Eqx [Eqy Eqz]] Pxyz']]]].
      exists x'.
      split.
      now apply Eqx.
      exists y'.
      exists z'.
      now assumption.
    +
      generalize P2H.
      apply IndLemma.
      intros y P2y.
      unfold P2 in P2y.
      destruct P2y as [x [z Pxyz]].
      apply Lem in Pxyz.
      destruct Pxyz as [x' [y' [z' [[Eqx [Eqy Eqz]] Pxyz']]]].
      exists y'.
      split.
      now apply Eqy.
      exists x'.
      exists z'.
      now assumption.
    +
      generalize P3H.
      apply IndLemma.
      intros z P3z.
      unfold P3 in P3z.
      destruct P3z as [x [y Pxyz]].
      apply Lem in Pxyz.
      destruct Pxyz as [x' [y' [z' [[Eqx [Eqy Eqz]] Pxyz']]]].
      exists z'.
      split.
      now apply Eqz.
      exists x'.
      exists y'.
      now assumption.
  Qed.

End pow3.


From Hammer Require Import Hammer.

Require Import Le Lt Gt Decidable PeanoNat.

Local Open Scope nat_scope.

Implicit Types m n x y : nat.

Definition zerop n : {n = 0} + {0 < n}.
Proof. hammer_hook "Compare_dec" "Compare_dec.zerop".
destruct n; auto with arith.
Defined.

Definition lt_eq_lt_dec n m : {n < m} + {n = m} + {m < n}.
Proof. hammer_hook "Compare_dec" "Compare_dec.lt_eq_lt_dec".
induction n in m |- *; destruct m; auto with arith.
destruct (IHn m) as [H|H]; auto with arith.
destruct H; auto with arith.
Defined.

Definition gt_eq_gt_dec n m : {m > n} + {n = m} + {n > m}.
Proof. hammer_hook "Compare_dec" "Compare_dec.gt_eq_gt_dec".
now apply lt_eq_lt_dec.
Defined.

Definition le_lt_dec n m : {n <= m} + {m < n}.
Proof. hammer_hook "Compare_dec" "Compare_dec.le_lt_dec".
induction n in m |- *.
- left; auto with arith.
- destruct m.
+ right; auto with arith.
+ elim (IHn m); [left|right]; auto with arith.
Defined.

Definition le_le_S_dec n m : {n <= m} + {S m <= n}.
Proof. hammer_hook "Compare_dec" "Compare_dec.le_le_S_dec".
exact (le_lt_dec n m).
Defined.

Definition le_ge_dec n m : {n <= m} + {n >= m}.
Proof. hammer_hook "Compare_dec" "Compare_dec.le_ge_dec".
elim (le_lt_dec n m); auto with arith.
Defined.

Definition le_gt_dec n m : {n <= m} + {n > m}.
Proof. hammer_hook "Compare_dec" "Compare_dec.le_gt_dec".
exact (le_lt_dec n m).
Defined.

Definition le_lt_eq_dec n m : n <= m -> {n < m} + {n = m}.
Proof. hammer_hook "Compare_dec" "Compare_dec.le_lt_eq_dec".
intros; destruct (lt_eq_lt_dec n m); auto with arith.
intros; absurd (m < n); auto with arith.
Defined.

Theorem le_dec n m : {n <= m} + {~ n <= m}.
Proof. hammer_hook "Compare_dec" "Compare_dec.le_dec".
destruct (le_gt_dec n m).
- now left.
- right. now apply gt_not_le.
Defined.

Theorem lt_dec n m : {n < m} + {~ n < m}.
Proof. hammer_hook "Compare_dec" "Compare_dec.lt_dec".
apply le_dec.
Defined.

Theorem gt_dec n m : {n > m} + {~ n > m}.
Proof. hammer_hook "Compare_dec" "Compare_dec.gt_dec".
apply lt_dec.
Defined.

Theorem ge_dec n m : {n >= m} + {~ n >= m}.
Proof. hammer_hook "Compare_dec" "Compare_dec.ge_dec".
apply le_dec.
Defined.

Theorem dec_le n m : decidable (n <= m).
Proof. hammer_hook "Compare_dec" "Compare_dec.dec_le".
apply Nat.le_decidable.
Qed.

Theorem dec_lt n m : decidable (n < m).
Proof. hammer_hook "Compare_dec" "Compare_dec.dec_lt".
apply Nat.lt_decidable.
Qed.

Theorem dec_gt n m : decidable (n > m).
Proof. hammer_hook "Compare_dec" "Compare_dec.dec_gt".
apply Nat.lt_decidable.
Qed.

Theorem dec_ge n m : decidable (n >= m).
Proof. hammer_hook "Compare_dec" "Compare_dec.dec_ge".
apply Nat.le_decidable.
Qed.

Theorem not_eq n m : n <> m -> n < m \/ m < n.
Proof. hammer_hook "Compare_dec" "Compare_dec.not_eq".
apply Nat.lt_gt_cases.
Qed.

Theorem not_le n m : ~ n <= m -> n > m.
Proof. hammer_hook "Compare_dec" "Compare_dec.not_le".
apply Nat.nle_gt.
Qed.

Theorem not_gt n m : ~ n > m -> n <= m.
Proof. hammer_hook "Compare_dec" "Compare_dec.not_gt".
apply Nat.nlt_ge.
Qed.

Theorem not_ge n m : ~ n >= m -> n < m.
Proof. hammer_hook "Compare_dec" "Compare_dec.not_ge".
apply Nat.nle_gt.
Qed.

Theorem not_lt n m : ~ n < m -> n >= m.
Proof. hammer_hook "Compare_dec" "Compare_dec.not_lt".
apply Nat.nlt_ge.
Qed.

Notation nat_compare := Nat.compare (compat "8.4").

Notation nat_compare_spec := Nat.compare_spec (compat "8.4").
Notation nat_compare_eq_iff := Nat.compare_eq_iff (compat "8.4").
Notation nat_compare_S := Nat.compare_succ (compat "8.4").

Lemma nat_compare_lt n m : n<m <-> (n ?= m) = Lt.
Proof. hammer_hook "Compare_dec" "Compare_dec.nat_compare_lt".
symmetry. apply Nat.compare_lt_iff.
Qed.

Lemma nat_compare_gt n m : n>m <-> (n ?= m) = Gt.
Proof. hammer_hook "Compare_dec" "Compare_dec.nat_compare_gt".
symmetry. apply Nat.compare_gt_iff.
Qed.

Lemma nat_compare_le n m : n<=m <-> (n ?= m) <> Gt.
Proof. hammer_hook "Compare_dec" "Compare_dec.nat_compare_le".
symmetry. apply Nat.compare_le_iff.
Qed.

Lemma nat_compare_ge n m : n>=m <-> (n ?= m) <> Lt.
Proof. hammer_hook "Compare_dec" "Compare_dec.nat_compare_ge".
symmetry. apply Nat.compare_ge_iff.
Qed.

Lemma nat_compare_eq n m : (n ?= m) = Eq -> n = m.
Proof. hammer_hook "Compare_dec" "Compare_dec.nat_compare_eq".
apply Nat.compare_eq_iff.
Qed.

Lemma nat_compare_Lt_lt n m : (n ?= m) = Lt -> n<m.
Proof. hammer_hook "Compare_dec" "Compare_dec.nat_compare_Lt_lt".
apply Nat.compare_lt_iff.
Qed.

Lemma nat_compare_Gt_gt n m : (n ?= m) = Gt -> n>m.
Proof. hammer_hook "Compare_dec" "Compare_dec.nat_compare_Gt_gt".
apply Nat.compare_gt_iff.
Qed.

Definition nat_compare_alt (n m:nat) :=
match lt_eq_lt_dec n m with
| inleft (left _) => Lt
| inleft (right _) => Eq
| inright _ => Gt
end.

Lemma nat_compare_equiv n m : (n ?= m) = nat_compare_alt n m.
Proof. hammer_hook "Compare_dec" "Compare_dec.nat_compare_equiv".
unfold nat_compare_alt; destruct lt_eq_lt_dec as [[|]|].
- now apply Nat.compare_lt_iff.
- now apply Nat.compare_eq_iff.
- now apply Nat.compare_gt_iff.
Qed.

Notation leb := Nat.leb (compat "8.4").

Notation leb_iff := Nat.leb_le (compat "8.4").

Lemma leb_iff_conv m n : (n <=? m) = false <-> m < n.
Proof. hammer_hook "Compare_dec" "Compare_dec.leb_iff_conv".
rewrite Nat.leb_nle. apply Nat.nle_gt.
Qed.

Lemma leb_correct m n : m <= n -> (m <=? n) = true.
Proof. hammer_hook "Compare_dec" "Compare_dec.leb_correct".
apply Nat.leb_le.
Qed.

Lemma leb_complete m n : (m <=? n) = true -> m <= n.
Proof. hammer_hook "Compare_dec" "Compare_dec.leb_complete".
apply Nat.leb_le.
Qed.

Lemma leb_correct_conv m n : m < n -> (n <=? m) = false.
Proof. hammer_hook "Compare_dec" "Compare_dec.leb_correct_conv".
apply leb_iff_conv.
Qed.

Lemma leb_complete_conv m n : (n <=? m) = false -> m < n.
Proof. hammer_hook "Compare_dec" "Compare_dec.leb_complete_conv".
apply leb_iff_conv.
Qed.

Lemma leb_compare n m : (n <=? m) = true <-> (n ?= m) <> Gt.
Proof. hammer_hook "Compare_dec" "Compare_dec.leb_compare".
rewrite Nat.compare_le_iff. apply Nat.leb_le.
Qed.