import lean.incorrectness_logic

namespace IncorrectnessCompleteness

inductive IncorrectnessProof : IncLoLang.prop → IncLoLang.stmt → IncLoLang.prop → IncLoLang.LogicType → Prop
| empty_under_approx {P: IncLoLang.prop} {ty: IncLoLang.LogicType} {C: IncLoLang.stmt}:
  IncorrectnessProof P C (λ _, false) ty
| consequence (P Q P' Q': IncLoLang.prop) {ty: IncLoLang.LogicType} {C: IncLoLang.stmt} (Hp: ∀ σ, P σ → P' σ) (Hq: ∀ σ, Q' σ → Q σ) (H: IncorrectnessProof P C Q ty):
  IncorrectnessProof P' C Q' ty
| disjunction {P₁ Q₁ P₂ Q₂: IncLoLang.prop} {ty: IncLoLang.LogicType} {C: IncLoLang.stmt} (H₁: IncorrectnessProof P₁ C Q₁ ty) (H₁: IncorrectnessProof P₂ C Q₂ ty):
  IncorrectnessProof (λ σ, P₁ σ ∨ P₂ σ) C (λ σ, Q₁ σ ∨ Q₂ σ) ty
| unit_ok {P: IncLoLang.prop}:
  IncorrectnessProof P IncLoLang.stmt.skip P IncLoLang.LogicType.ok
| unit_er {P: IncLoLang.prop}:
  IncorrectnessProof P IncLoLang.stmt.skip (λ _, false) IncLoLang.LogicType.er
| sequencing_short {P Q: IncLoLang.prop} {C₁ C₂: IncLoLang.stmt} (H: IncorrectnessProof P C₁ Q IncLoLang.LogicType.er):
  IncorrectnessProof P (C₁;;C₂) Q IncLoLang.LogicType.er
| sequencing_normal {P Q R: IncLoLang.prop} {C₁ C₂: IncLoLang.stmt} {ty: IncLoLang.LogicType}
  (H₁: IncorrectnessProof P C₁ Q IncLoLang.LogicType.ok)
  (H₂: IncorrectnessProof Q C₂ R ty) :
  IncorrectnessProof P (C₁;;C₂) R ty
| iterate_zero {P: IncLoLang.prop} {C: IncLoLang.stmt} :
  IncorrectnessProof P (C**) P IncLoLang.LogicType.ok
| iterate_non_zero {P Q: IncLoLang.prop} {C: IncLoLang.stmt} {ty: IncLoLang.LogicType}
  (H: IncorrectnessProof P (C** ;; C) Q ty) :
  IncorrectnessProof P (C**) Q ty
| backwards_variant {P: ℕ → IncLoLang.prop} {C: IncLoLang.stmt}
  (H: ∀ n, IncorrectnessProof (P n) C (P (n+1)) IncLoLang.LogicType.ok) :
  IncorrectnessProof (P 0) (C**) (λ σ, ∃ N, P N σ) IncLoLang.LogicType.ok
| choice_left {P Q: IncLoLang.prop} {C₁ C₂: IncLoLang.stmt} {ty: IncLoLang.LogicType}
  (H: IncorrectnessProof P C₁ Q ty) :
  IncorrectnessProof P (C₁ <+> C₂) Q ty
| choice_right {P Q: IncLoLang.prop} {C₁ C₂: IncLoLang.stmt} {ty: IncLoLang.LogicType}
  (H: IncorrectnessProof P C₂ Q ty) :
  IncorrectnessProof P (C₁ <+> C₂) Q ty
| error_ok {P: IncLoLang.prop}:
  IncorrectnessProof P (IncLoLang.stmt.error) (λ_, false) IncLoLang.LogicType.ok
| error_er {P: IncLoLang.prop}:
  IncorrectnessProof P (IncLoLang.stmt.error) P IncLoLang.LogicType.er
| assume_ok {P B: IncLoLang.prop}:
  IncorrectnessProof P (IncLoLang.stmt.assumes B) (λ σ, P σ ∧ B σ) IncLoLang.LogicType.ok
| assume_er {P B: IncLoLang.prop}:
  IncorrectnessProof P (IncLoLang.stmt.assumes B) (λ σ, false) IncLoLang.LogicType.er
| assignment_ok {P: IncLoLang.prop} {e: IncLoLang.expression} {x: string} :
  IncorrectnessProof P ([x ↣ e]) (λ σ', (∃ x', (P{x ↣ x'} σ') ∧ σ' x = e (σ'{x ↦ x'}))) IncLoLang.LogicType.ok
| assignment_er {P: IncLoLang.prop} {e: IncLoLang.expression} {x: string} :
  IncorrectnessProof P ([x ↣ e]) (λ σ', false) IncLoLang.LogicType.er
| non_det_assignment_ok {P: IncLoLang.prop} {x: string} :
  IncorrectnessProof P (IncLoLang.stmt.non_det_assign x) (λ σ', (∃ v, (P{x ↣ v} σ'))) IncLoLang.LogicType.ok
| non_det_assignment_er {P: IncLoLang.prop} {x: string} :
  IncorrectnessProof P (IncLoLang.stmt.non_det_assign x) (λ σ', false) IncLoLang.LogicType.er
| constancy {P Q F: IncLoLang.prop} {C: IncLoLang.stmt} {ty: IncLoLang.LogicType}
  (HC: IncorrectnessProof P C Q ty)
  (Hf: C.Mod ∩ F.Free = ∅) :
  IncorrectnessProof (λ σ, P σ ∧ F σ) C (λ σ', Q σ' ∧ F σ') ty
| substitution_1 {P Q: IncLoLang.prop} {C: IncLoLang.stmt} {ty: IncLoLang.LogicType} {e: IncLoLang.expression} {x: string}
  (HC: IncorrectnessProof P C Q ty)
  (HB: (∃ B: set string, (e.FreeProp B ∧ B.finite)))
  (He: (e.Free ∪ {x}) ∩ C.Free = ∅):
  IncorrectnessProof (λ σ, P (σ{x ↦ e σ})) C (λ σ, Q (σ{x ↦ e σ})) ty
| substitution_2 {P Q: IncLoLang.prop} {C: IncLoLang.stmt} {ty: IncLoLang.LogicType} {x y: string}
  (H₁: [* P *]C[* Q *]ty)
  (H₂: y ∉ C.Free ∪ P.Free ∪ Q.Free)
  (H₃: x ≠ y):
  IncorrectnessProof (P[y//x]) (C{y // x}) (Q[y//x]) ty

/-! ## Soundness -/

lemma IncorectnessProof.soundness {P Q: IncLoLang.prop} {C: IncLoLang.stmt} {ty: IncLoLang.LogicType}:
  IncorrectnessProof P C Q ty → [* P *]C[* Q *]ty :=
begin
  intro h,
  induction h,

  case empty_under_approx { exact IncLogic.empty_under_incorrect, },
  case consequence { exact IncLogic.consequence_incorrect h_ih h_Hq h_Hp, },
  case disjunction { refine IncLogic.disjunction_incorrect h_ih_H₁ h_ih_H₁_1},
  case unit_ok { refine IncLogic.unit_incorrect_ok},
  case unit_er { refine IncLogic.unit_incorrect_err},
  case sequencing_short { refine IncLogic.seq_short_circuit_incorrect h_ih, },
  case sequencing_normal { refine IncLogic.seq_normal_incorrect h_ih_H₁ h_ih_H₂, },
  case iterate_zero { refine IncLogic.iterate_zero_incorrect, },
  case iterate_non_zero {exact IncLogic.star_seq h_ih,},
  case backwards_variant {exact IncLogic.backwards_variant h_ih,},
  case choice_right {exact IncLogic.choice_right_incorrect h_ih,},
  case choice_left {exact IncLogic.choice_left_incorrect h_ih,},
  case error_ok {exact IncLogic.error_ok_incorrect},
  case error_er {exact IncLogic.error_er_incorrect},
  case assume_ok {exact IncLogic.assume_incorrect_ok,},
  case assume_er {exact IncLogic.assume_incorrect_er,},
  case assignment_ok {exact IncLogic.assignment_correct,},
  case assignment_er {exact IncLogic.empty_under_incorrect},
  case non_det_assignment_ok {exact IncLogic.non_det_assignment_incorrect},
  case non_det_assignment_er {exact IncLogic.empty_under_incorrect},
  case constancy {exact IncLogic.constancy h_Hf h_ih,},
  case substitution_1 {exact IncLogic.substitution_1 h_HB h_ih h_He,},
  case substitution_2 {exact IncLogic.substitution_2 h_H₁ h_H₂ h_H₃,},
end

/-! ## Completeness -/

lemma IncorectnessProof.completeness.star_case_ok (C: IncLoLang.stmt)
(hC: ∀ (P Q : IncLoLang.prop) (ty : IncLoLang.LogicType), ([* P *] C [* Q *]ty) → IncorrectnessProof P C Q ty) :
∀ (P Q : IncLoLang.prop), ([* P *] C** [* Q *]IncLoLang.LogicType.ok) → IncorrectnessProof P (C**) Q IncLoLang.LogicType.ok :=
begin
  intros P Q h,
  let P' : ℕ → IncLoLang.prop := λ n, λ σ', ∃ σ, P σ ∧ IncLoLang.lang_semantics (IncLoLang.repeat C n) IncLoLang.LogicType.ok σ σ',
  have Hpq: ∀ σ, Q σ → ∃ n, P' n σ, {
    intros σ hσ,
    specialize h σ hσ,
    rcases h with ⟨ σ', ⟨ hpσ', hls ⟩ ⟩,
    cases hls,
    use hls_i,
    use σ',
    split,
    { exact hpσ', },
    { exact hls_h, }
  },
  have X: IncorrectnessProof P (C**) (λ σ, ∃ N, P' N σ) IncLoLang.LogicType.ok, {
    have H: P = P' 0, {
      ext,
      split,
      {
        intro h,
        use x,
        split,
        { exact h, },
        { rw IncLoLang.repeat, exact IncLoLang.lang_semantics.skip, },
      },
      {
        intro h,
        rcases h with ⟨ σ, ⟨ hp, hls ⟩ ⟩,
        rw IncLoLang.repeat at hls,
        cases hls,
        exact hp,
      },
    },
    rw H,

    refine IncorrectnessProof.backwards_variant (by {
      intro n,
      apply hC,
      intros σ hσ,
      rcases hσ with ⟨ σ' , ⟨ hPσ', hls ⟩ ⟩,
      rw IncLoLang.repeat at hls,
      cases hls,
      use hls_t,
      split,
      {
        use σ',
        exact ⟨hPσ', hls_H1⟩,
      },
      {
        exact hls_H2,
      }
    }),
  },

  refine IncorrectnessProof.consequence P _ P Q (by {intro _, exact id,}) Hpq X,
end

lemma IncorectnessProof.completeness.star_case (C: IncLoLang.stmt)
(hC: ∀ (P Q : IncLoLang.prop) (ty : IncLoLang.LogicType), ([* P *] C [* Q *]ty) → IncorrectnessProof P C Q ty) :
∀ (P Q : IncLoLang.prop) (ty : IncLoLang.LogicType), ([* P *] C** [* Q *]ty) → IncorrectnessProof P (C**) Q ty :=
begin
  intros P Q ty h,
  cases ty,
  case ok {
    exact IncorectnessProof.completeness.star_case_ok C hC P Q h,
  },
  case er {
    -- let P' : ℕ → IncLoLang.prop := λ n, λ σ', ∃ σ, P σ ∧ IncLoLang.lang_semantics (IncLoLang.repeat C n) IncLoLang.LogicType.ok σ σ',
    let frontier := IncLogic.post IncLoLang.LogicType.ok (C**) P,
    have H: [* P *] C** [* frontier *] IncLoLang.LogicType.ok, { intros σ hσ, exact hσ, },
    have X := IncorectnessProof.completeness.star_case_ok C hC P frontier H,

    have H₂: [* frontier *]C[* Q *]IncLoLang.LogicType.er, {
      intros σ hσ,
      specialize h σ hσ,

      rcases h with ⟨ σ', ⟨ hσ', hls ⟩ ⟩,
      cases hls,
      induction hls_i,
      case zero {
        -- seek contradiciton
        rw IncLoLang.repeat at hls_h,
        cases hls_h,
      },
      case succ {
        rw IncLoLang.repeat at hls_h,
        cases hls_h,
        {
          use hls_h_t,
          split,
          {
            use σ',
            split,
            { exact hσ', },
            { exact IncLoLang.lang_semantics.star hls_i_n hls_h_H1, },
          },
          {
            exact hls_h_H2,
          }
        },
        {
          exact hls_i_ih hls_h_H1,
        }
      },
    },
    have X₂ := hC frontier Q IncLoLang.LogicType.er H₂,

    have X₃ := IncorrectnessProof.sequencing_normal X X₂,
    exact IncorrectnessProof.iterate_non_zero X₃,
  }
end

lemma IncorectnessProof.completeness {P Q: IncLoLang.prop} {C: IncLoLang.stmt} {ty: IncLoLang.LogicType}:
  ([* P *]C[* Q *]ty) → IncorrectnessProof P C Q ty :=
begin
  revert P Q ty,
  induction C with
    x e
    x
    C₁ C₂ hC₁ hC₂
    C₁ C₂ hC₁ hC₂
    j k,
  case IncLoLang.stmt.skip {
    intros P Q ty h,
    cases ty,
    {
      -- seek that Q is (λ _, false)
      have H: Q = λ _, false, {
        by_contra hQ,
        have H₂: ∃ σ, Q σ, {
          by_contra h₂,
          push_neg at h₂,
          apply hQ,
          funext,
          specialize h₂ x,
          exact eq_false_intro h₂,
        },
        cases H₂ with σ hσ,
        specialize h σ hσ,
        rcases h with ⟨σ', ⟨ hp, hls ⟩⟩,
        cases hls,
      },
      rw H,
      exact IncorrectnessProof.unit_er,
    },
    {
      have Hpq: ∀ σ, Q σ → P σ, {
        intros σ hqσ,
        specialize h σ hqσ,
        rcases h with ⟨σ', ⟨ hp, hls ⟩⟩,
        cases hls,
        exact hp,
      },

      exact IncorrectnessProof.consequence Q Q P Q Hpq (by {intro x, exact id,}) (by {exact IncorrectnessProof.unit_ok,}),
    },
  },
  case IncLoLang.stmt.assign {
    intros P Q ty h,
    cases ty,
    {
      -- seek that Q is (λ _, false)
      have H: Q = λ _, false, {
        by_contra hQ,
        have H₂: ∃ σ, Q σ, {
          by_contra h₂,
          push_neg at h₂,
          apply hQ,
          funext y,
          specialize h₂ y,
          exact eq_false_intro h₂,
        },
        cases H₂ with σ hσ,
        specialize h σ hσ,
        rcases h with ⟨σ', ⟨ hp, hls ⟩⟩,
        cases hls,
      },
      rw H,
      exact IncorrectnessProof.assignment_er,
    },
    {
      have Hpq: ∀ σ, Q σ → (λ σ', ∃ (x' : ℕ), P{x ↣ x'} σ' ∧ σ' x = e (σ'{x ↦ x'})) σ, {
        simp,
        intros σ hqσ,
        specialize h σ hqσ,
        rcases h with ⟨σ', ⟨ hp, hls ⟩⟩,
        cases hls,
        rw ← IncLoLang.state.update,
        use σ' x,
        split,
        { unfold IncLoLang.prop.update_val, simp[hp], },
        { simp, }
      },

      refine IncorrectnessProof.consequence P _ P Q (by {intro x, exact id,}) Hpq (IncorrectnessProof.assignment_ok),
    },
  },
  case IncLoLang.stmt.non_det_assign {
    intros P Q ty h,
    cases ty,
    {
      -- seek that Q is (λ _, false)
      have H: Q = λ _, false, {
        by_contra hQ,
        have H₂: ∃ σ, Q σ, {
          by_contra h₂,
          push_neg at h₂,
          apply hQ,
          funext y,
          specialize h₂ y,
          exact eq_false_intro h₂,
        },
        cases H₂ with σ hσ,
        specialize h σ hσ,
        rcases h with ⟨σ', ⟨ hp, hls ⟩⟩,
        cases hls,
      },
      rw H,
      exact IncorrectnessProof.non_det_assignment_er,
    },
    {
      have Hpq: ∀ σ, Q σ → (λ σ', ∃ (v : ℕ), P{x ↣ v} σ') σ, {
        intros σ hqσ,
        specialize h σ hqσ,
        rcases h with ⟨σ', ⟨ hp, hls ⟩⟩,
        cases hls,
        rw ← IncLoLang.state.update,
        use σ' x,
        unfold IncLoLang.prop.update_val,
        simp[hp],
      },
      refine IncorrectnessProof.consequence P _ P Q (by {intro x, exact id,}) Hpq (IncorrectnessProof.non_det_assignment_ok),
    },
  },
  case IncLoLang.stmt.seq {
    intros P Q ty h,
    cases ty,
    case LogicType.ok {
      have H: ∀ σ, Q σ → IncLogic.post IncLoLang.LogicType.ok C₂ (λ σ', IncLogic.post IncLoLang.LogicType.ok C₁ P σ') σ,
      {
        intros σ hσ,
        specialize h σ hσ,
        rcases h with ⟨ σ', ⟨ hP, hls ⟩ ⟩,
        cases hls,
        use hls_t,
        simp,
        split,
        {
          use σ',
          exact ⟨hP, hls_H1⟩,
        },
        { exact hls_H2, },
      },

      have HC₁: [* P *] C₁ [* λ σ, IncLogic.post IncLoLang.LogicType.ok C₁ P σ *]IncLoLang.LogicType.ok, { intro _, exact id, },
      specialize hC₁ HC₁,
      have HC₂: [* λ σ, IncLogic.post IncLoLang.LogicType.ok C₁ P σ *] C₂ [* λ σ, IncLogic.post IncLoLang.LogicType.ok C₂ (λ σ', IncLogic.post IncLoLang.LogicType.ok C₁ P σ') σ *]IncLoLang.LogicType.ok, { intro _, exact id, },
      specialize hC₂ HC₂,

      have X := IncorrectnessProof.sequencing_normal hC₁ hC₂,

      refine IncorrectnessProof.consequence P _ P Q (by {intro x, exact id,}) H X,
    },
    case LogicType.er {
      have H: ∀ σ, Q σ → IncLogic.post IncLoLang.LogicType.er C₂ (λ σ', IncLogic.post IncLoLang.LogicType.ok C₁ P σ') σ ∨ IncLogic.post IncLoLang.LogicType.er C₁ P σ,
      {
        intros σ hσ,
        specialize h σ hσ,
        rcases h with ⟨ σ', ⟨ hP, hls ⟩ ⟩,
        cases hls,
        {
          left,
          use hls_t,
          simp,
          split,
          {
            use σ',
            exact ⟨hP, hls_H1⟩,
          },
          { exact hls_H2, },
        },
        {
          right,
          use σ',
          exact ⟨hP, hls_H1⟩,
        },
      },

      have X1: IncorrectnessProof P (C₁ ;; C₂) (λ (σ : IncLoLang.state), IncLogic.post IncLoLang.LogicType.er C₂ (λ (σ' : IncLoLang.state), IncLogic.post IncLoLang.LogicType.ok C₁ P σ') σ) IncLoLang.LogicType.er, {
        have HC₁: [* P *] C₁ [* λ σ, IncLogic.post IncLoLang.LogicType.ok C₁ P σ *]IncLoLang.LogicType.ok, { intro _, exact id, },
        specialize hC₁ HC₁,
        have HC₂: [* λ σ, IncLogic.post IncLoLang.LogicType.ok C₁ P σ *] C₂ [* λ σ, IncLogic.post IncLoLang.LogicType.er C₂ (λ σ', IncLogic.post IncLoLang.LogicType.ok C₁ P σ') σ *]IncLoLang.LogicType.er, { intro _, exact id, },
        specialize hC₂ HC₂,
        exact IncorrectnessProof.sequencing_normal hC₁ hC₂,
      },
      have X2: IncorrectnessProof P (C₁ ;; C₂) (λ (σ : IncLoLang.state), IncLogic.post IncLoLang.LogicType.er C₁ P σ) IncLoLang.LogicType.er, {
        have HC₁: [* P *] C₁ [* λ σ, IncLogic.post IncLoLang.LogicType.er C₁ P σ *]IncLoLang.LogicType.er, { intro _, exact id, },
        specialize hC₁ HC₁,
        exact IncorrectnessProof.sequencing_short hC₁,
      },

      have X: IncorrectnessProof P (C₁ ;; C₂) (λ (σ : IncLoLang.state), IncLogic.post IncLoLang.LogicType.er C₂ (λ (σ' : IncLoLang.state), IncLogic.post IncLoLang.LogicType.ok C₁ P σ') σ ∨ IncLogic.post IncLoLang.LogicType.er C₁ P σ) IncLoLang.LogicType.er, {
        have T := IncorrectnessProof.disjunction X1 X2,
        simp at T,
        exact T,
      },

      refine IncorrectnessProof.consequence P _ P Q (by {intro x, exact id,}) H X,
    },
  },
  case IncLoLang.stmt.choice {
    intros P Q ty h,
    have H: ∀ σ, Q σ → IncLogic.post ty (C₁ <+> C₂) P σ, { intros σ hσ, exact h σ hσ, },
    have hPost: ∀ σ, IncLogic.post ty (C₁ <+> C₂) P σ → IncLogic.post ty C₁ P σ ∨ IncLogic.post ty C₂ P σ,
    {
      intros σ hσ,
      rcases hσ with ⟨ σ', ⟨ hσ', hls ⟩⟩,
      cases hls,
      { left, use σ', exact ⟨hσ', hls_h⟩, },
      { right, use σ', exact ⟨hσ', hls_h⟩, },
    },
    have H: ∀ σ, Q σ → IncLogic.post ty C₁ P σ ∨ IncLogic.post ty C₂ P σ, {
      intros σ hσ,
      apply hPost,
      apply H,
      exact hσ,
    },

    have HC₁: [* P *] C₁ [* λ σ, IncLogic.post ty C₁ P σ *]ty, { intro _, exact id, },
    specialize hC₁ HC₁,
    have HC₂: [* P *] C₂ [* λ σ, IncLogic.post ty C₂ P σ *]ty, { intro _, exact id, },
    specialize hC₂ HC₂,

    have X := IncorrectnessProof.disjunction (IncorrectnessProof.choice_left hC₁) (IncorrectnessProof.choice_right hC₂),
    simp at X,

    refine IncorrectnessProof.consequence P _ P Q (by {intro x, exact id,}) H X,
  },
  case IncLoLang.stmt.star {
    exact IncorectnessProof.completeness.star_case j (by { intros P Q ty, exact k, }),
  },
  case IncLoLang.stmt.error {
    intros P Q ty h,
    cases ty,
    {
      have Hpq: ∀ σ, Q σ → P σ, {
        intros σ hqσ,
        specialize h σ hqσ,
        rcases h with ⟨σ', ⟨ hp, hls ⟩⟩,
        cases hls,
        exact hp,
      },

      exact IncorrectnessProof.consequence Q Q P Q Hpq (by {intro x, exact id,}) (by {exact IncorrectnessProof.error_er,}),
    },
    {
      -- seek that Q is (λ _, false)
      have H: Q = λ _, false, {
        by_contra hQ,
        have H₂: ∃ σ, Q σ, {
          by_contra h₂,
          push_neg at h₂,
          apply hQ,
          funext,
          specialize h₂ x,
          exact eq_false_intro h₂,
        },
        cases H₂ with σ hσ,
        specialize h σ hσ,
        rcases h with ⟨σ', ⟨ hp, hls ⟩⟩,
        cases hls,
      },
      rw H,
      exact IncorrectnessProof.error_ok,
    },
  },
  case IncLoLang.stmt.assumes {
    intros P Q ty h,

    cases ty,
    {
      -- seek that Q is (λ _, false)
      have H: Q = λ _, false, {
        by_contra hQ,
        have H₂: ∃ σ, Q σ, {
          by_contra h₂,
          push_neg at h₂,
          apply hQ,
          funext,
          specialize h₂ x,
          exact eq_false_intro h₂,
        },
        cases H₂ with σ hσ,
        specialize h σ hσ,
        rcases h with ⟨σ', ⟨ hp, hls ⟩⟩,
        cases hls,
      },
      rw H,
      exact IncorrectnessProof.assume_er,
    },
    {
      have Hpq: ∀ σ, Q σ → P σ ∧ C σ, {
        intros σ hqσ,
        specialize h σ hqσ,
        rcases h with ⟨σ', ⟨ hp, hls ⟩⟩,
        cases hls,
        exact ⟨hp, hls_h⟩,
      },

      exact IncorrectnessProof.consequence P (λ σ, P σ ∧ C σ) P Q (by {intro x, exact id,}) Hpq IncorrectnessProof.assume_ok,
    },
  },
end

end IncorrectnessCompleteness


/-
Copyright (c) 2021 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro
-/
import Mathlib.Tactic.Basic
import Mathlib.Data.Array.Basic

structure UFModel (n) where
  parent : Fin n → Fin n
  rank : Nat → Nat
  rank_lt : ∀ i, (parent i).1 ≠ i → rank i < rank (parent i)

namespace UFModel

def empty : UFModel 0 where
  parent i := i.elim0
  rank i := 0
  rank_lt i := i.elim0

def push {n} (m : UFModel n) (k) (le : n ≤ k) : UFModel k where
  parent i :=
    if h : i < n then
      let ⟨a, h'⟩ := m.parent ⟨i, h⟩
      ⟨a, lt_of_lt_of_le h' le⟩
    else i
  rank i := if h : i < n then m.rank i else 0
  rank_lt i := by
    simp; split <;> rename_i h
    · simp [(m.parent ⟨i, h⟩).2, h]; exact m.rank_lt _
    · intro.

def setParent {n} (m : UFModel n) (x y : Fin n) (h : m.rank x < m.rank y) : UFModel n where
  parent i := if x.1 = i then y else m.parent i
  rank := m.rank
  rank_lt i := by
    simp; split <;> rename_i h'
    · rw [← h']; exact fun _ => h
    · exact m.rank_lt i

def setParentBump {n} (m : UFModel n) (x y : Fin n)
  (ne : x.1 ≠ y) (H : m.rank x ≤ m.rank y) (hroot : (m.parent y).1 = y) : UFModel n where
  parent i := if x.1 = i then y else m.parent i
  rank i := if y.1 = i ∧ m.rank x = m.rank y then m.rank y + 1 else m.rank i
  rank_lt i := by
    simp; split <;>
      (rename_i h₁; simp [h₁]; split <;> rename_i h₂ <;>
        (intro h; simp [h] at h₂ <;> simp [h₁, h₂, h]))
    · simp [← h₁]; split <;> rename_i h₃
      · rw [h₃]; apply Nat.lt_succ_self
      · exact lt_of_le_of_ne H h₃
    · have := Fin.eq_of_val_eq h₂.1; subst this
      simp [hroot] at h
    · have := m.rank_lt i h
      split <;> rename_i h₃
      · rw [h₃.1]; exact Nat.lt_succ_of_lt this
      · exact this

end UFModel

structure UFNode (α : Type _) where
  parent : Nat
  value : α
  rank : Nat

inductive UFModel.Agrees (arr : Array α) (f : α → β) : ∀ {n}, (Fin n → β) → Prop
| mk : Agrees arr f fun i => f (arr.get i)

namespace UFModel.Agrees

theorem mk' {arr : Array α} {f : α → β} {n} {g : Fin n → β}
  (e : n = arr.size)
  (H : ∀ i h₁ h₂, f (arr.get ⟨i, h₁⟩) = g ⟨i, h₂⟩) :
  Agrees arr f g := by
    cases e
    have : (fun i => f (arr.get i)) = g := by funext ⟨i, h⟩; apply H
    cases this; constructor

theorem get_eq {arr : Array α} {n} {m : Fin n → β} (H : Agrees arr f m) :
  ∀ i h₁ h₂, f (arr.get ⟨i, h₁⟩) = m ⟨i, h₂⟩ := by
  cases H; exact fun i h _ => rfl

theorem get_eq' {arr : Array α} {m : Fin arr.size → β} (H : Agrees arr f m)
  (i) : f (arr.get i) = m i := H.get_eq ..

theorem empty {f : α → β} {g : Fin 0 → β} : Agrees #[] f g := mk' rfl λ.

theorem push {arr : Array α} {n} {m : Fin n → β} (H : Agrees arr f m)
  (k) (hk : k = n + 1) (x) (m' : Fin k → β)
  (hm₁ : ∀ (i : Fin k) (h : i < n), m' i = m ⟨i, h⟩)
  (hm₂ : ∀ (h : n < k), f x = m' ⟨n, h⟩) : Agrees (arr.push x) f m' := by
  cases H
  have : k = (arr.push x).size := by simp [hk]
  refine mk' this fun i h₁ h₂ => ?_
  simp [Array.get_push]; split <;> (rename_i h; simp at hm₁ ⊢)
  · exact (hm₁ ⟨i, h₂⟩ _).symm
  · simp at h₁
    cases le_antisymm (le_of_not_lt h) (Nat.le_of_lt_succ h₁); apply hm₂

theorem set {arr : Array α} {n} {m : Fin n → β} (H : Agrees arr f m)
  {i : Fin arr.size} {x} {m' : Fin n → β}
  (hm₁ : ∀ (j : Fin n) (h : j.1 ≠ i), m' j = m j)
  (hm₂ : ∀ (h : i < n), f x = m' ⟨i, h⟩) : Agrees (arr.set i x) f m' := by
  cases H
  refine mk' (by simp) fun j hj₁ hj₂ => ?_
  have := arr.get?_set i j x
  rw [Array.get?_eq_get _ _ hj₁, Array.get?_eq_get _ _ hj₂] at this
  revert this; split <;> (rename_i h; simp; intro h'; rw [h'])
  · cases h; apply hm₂
  · rw [hm₁]; exact Ne.symm h

end UFModel.Agrees

def UFModel.Models (arr : Array (UFNode α)) {n} (m : UFModel n) :=
  UFModel.Agrees arr (·.parent) (fun i => m.parent i) ∧
  UFModel.Agrees arr (·.rank) (fun i : Fin n => m.rank i)

namespace UFModel.Models

theorem size_eq {arr : Array (UFNode α)} {n} {m : UFModel n} (H : m.Models arr) :
  n = arr.size := H.1.size_eq

theorem parent_eq {arr : Array (UFNode α)} {n} {m : UFModel n} (H : m.Models arr)
  (i h₁ h₂) : (arr.get ⟨i, h₁⟩).parent = m.parent ⟨i, h₂⟩ := H.1.get_eq ..

theorem parent_eq' {arr : Array (UFNode α)} {m : UFModel arr.size} (H : m.Models arr)
  (i) : (arr.get i).parent = m.parent i := H.parent_eq ..

theorem rank_eq {arr : Array (UFNode α)} {n} {m : UFModel n} (H : m.Models arr)
  (i) : (arr.get i).rank = m.rank i := H.2.get_eq _ _ (by rw [H.size_eq]; exact i.2)

theorem empty : UFModel.empty.Models (α := α) #[] := ⟨Agrees.empty, Agrees.empty⟩

theorem push {arr : Array (UFNode α)} {n} {m : UFModel n} (H : m.Models arr)
  (k) (hk : k = n + 1) (x) :
  (m.push k (hk ▸ Nat.le_add_right ..)).Models (arr.push ⟨n, x, 0⟩) := by
  apply H.imp <;>
  · intro H
    refine H.push _ hk _ _ (fun i h => ?_) (fun h => ?_) <;>
    simp [UFModel.push, h, lt_irrefl]

theorem setParent {arr : Array (UFNode α)} {n} {m : UFModel n} (hm : m.Models arr)
  (i j H hi x) (hp : x.parent = j.1) (hrk : x.rank = (arr.get ⟨i.1, hi⟩).rank) :
  (m.setParent i j H).Models (arr.set ⟨i.1, hi⟩ x) :=
  ⟨hm.1.set
      (fun k h => by simp [UFModel.setParent, h.symm])
      (fun h => by simp [UFModel.setParent, hp]),
    hm.2.set (fun _ _ => rfl) (fun _ => hrk.trans $ hm.2.get_eq ..)⟩

end UFModel.Models

structure UnionFind (α) where
  arr : Array (UFNode α)
  model : ∃ (n : _) (m : UFModel n), m.Models arr

namespace UnionFind

def size (self : UnionFind α) := self.arr.size

theorem model' (self : UnionFind α) : ∃ (m : UFModel self.arr.size), m.Models self.arr := by
  let ⟨n, m, hm⟩ := self.model; cases hm.size_eq; exact ⟨m, hm⟩

def empty : UnionFind α where
  arr := #[]
  model := ⟨_, _, UFModel.Models.empty⟩

def mkEmpty (c : Nat) : UnionFind α where
  arr := Array.mkEmpty c
  model := ⟨_, _, UFModel.Models.empty⟩

def rank (self : UnionFind α) (i : Nat) : Nat :=
  if h : i < self.size then (self.arr.get ⟨i, h⟩).rank else 0

def rankMaxAux (self : UnionFind α) : ∀ (i : Nat),
  {k : Nat // ∀ j < i, ∀ h, (self.arr.get ⟨j, h⟩).rank ≤ k}
| 0 => ⟨0, λ.⟩
| i+1 => by
  let ⟨k, H⟩ := rankMaxAux self i
  refine ⟨max k (if h : _ then (self.arr.get ⟨i, h⟩).rank else 0), fun j hj h => ?_⟩
  match j, lt_or_eq_of_le (Nat.le_of_lt_succ hj) with
  | j, Or.inl hj => exact le_trans (H _ hj h) (le_max_left _ _)
  | _, Or.inr rfl => simp [h, le_max_right]

def rankMax (self : UnionFind α) := (rankMaxAux self self.size).1 + 1

theorem lt_rankMax' (self : UnionFind α) (i : Fin self.size) :
  (self.arr.get i).rank < self.rankMax :=
  Nat.lt_succ_iff.2 $ (rankMaxAux self self.size).2 _ i.2 _

theorem lt_rankMax (self : UnionFind α) (i : Nat) : self.rank i < self.rankMax := by
  simp [rank]; split; {apply lt_rankMax'}; apply Nat.succ_pos

theorem rank_eq (self : UnionFind α) {n} {m : UFModel n} (H : m.Models self.arr)
  {i} (h : i < self.size) : self.rank i = m.rank i := by
  simp [rank, h, H.rank_eq]

theorem rank_lt (self : UnionFind α) {i} : (self.arr.get i).parent ≠ i →
  self.rank i < self.rank (self.arr.get i).parent := by
  let ⟨m, hm⟩ := self.model'
  simp [hm.parent_eq', hm.rank_eq, rank, size, i.2, (m.parent i).2]
  exact m.rank_lt i

theorem parent_lt (self : UnionFind α) (i) : (self.arr.get i).parent < self.size := by
  let ⟨m, hm⟩ := self.model'
  simp [hm.parent_eq', size, (m.parent i).2]

def push (self : UnionFind α) (x : α) : UnionFind α where
  arr := self.arr.push ⟨self.arr.size, x, 0⟩
  model := let ⟨m, hm⟩ := self.model'; ⟨_, _, hm.push _ rfl _⟩

def findAux (self : UnionFind α) (x : Fin self.size) :
  (s : Array (UFNode α)) ×' (root : Fin s.size) ×'
    ∃ n, ∃ (m : UFModel n) (m' : UFModel n),
      m.Models self.arr ∧ m'.Models s ∧ m'.rank = m.rank ∧
      (∃ hr, (m'.parent ⟨root, hr⟩).1 = root) ∧
      m.rank x ≤ m.rank root := by
  let y := (self.arr.get x).parent
  refine if h : y = x then ⟨self.arr, x, ?a⟩ else
    have := Nat.sub_lt_sub_left (self.lt_rankMax x) (self.rank_lt h)
    let ⟨arr₁, root, H⟩ := self.findAux ⟨y, self.parent_lt x⟩
    have hx := ?hx
    let arr₂ := arr₁.set ⟨x, hx⟩ {arr₁.get ⟨x, hx⟩ with parent := root}
    ⟨arr₂, ⟨root, by simp [root.2]⟩, ?b⟩
  -- start proof
  case a =>
    let ⟨m, hm⟩ := self.model'
    exact ⟨_, m, m, hm, hm, rfl, ⟨x.2, by rwa [← hm.parent_eq']⟩, le_refl _⟩
  all_goals let ⟨n, m, m', hm, hm', e, ⟨_, hr⟩, le⟩ := H
  case hx => exact hm'.size_eq ▸ hm.size_eq.symm ▸ x.2
  case b =>
    let x' : Fin n := ⟨x, hm.size_eq ▸ x.2⟩
    let root : Fin n := ⟨root, hm'.size_eq.symm ▸ root.2⟩
    have hy : (UFModel.parent m x').1 = y := by rw [← hm.parent_eq x x.2 x'.2]; rfl
    have := m.rank_lt x'; rw [hy] at this
    have := lt_of_lt_of_le (this h) le
    refine ⟨n, m, _, hm,
      hm'.setParent x' root (by rw [e]; exact this) hx _ rfl rfl, e,
      ⟨root.2, ?_⟩, le_of_lt this⟩
    have := show x.1 ≠ root from mt (congrArg _) (ne_of_lt this)
    simp [UFModel.setParent, this, hr]
termination_by _ α self x => self.rankMax - self.rank x

def find (self : UnionFind α) (x : Fin self.size) :
  (s : UnionFind α) × (root : Fin s.size) ×'
    s.size = self.size ∧ (s.arr.get root).parent = root :=
  let ⟨s, root, H⟩ := self.findAux x
  have : _ ∧ s.size = self.size ∧ (s.get root).parent = root :=
    let ⟨n, _, m', hm, hm', _, ⟨_, hr⟩, _⟩ := H
    ⟨⟨n, m', hm'⟩, hm'.size_eq.symm.trans hm.size_eq, by rwa [hm'.parent_eq]⟩
  ⟨⟨s, this.1⟩, root, this.2⟩

def link (self : UnionFind α) (x y : Fin self.size)
  (yroot : (self.arr.get y).parent = y) : UnionFind α := by
  refine if ne : x.1 = y then self else
    let nx := self.arr.get x
    let ny := self.arr.get y
    if h : ny.rank < nx.rank then
      ⟨self.arr.set y {ny with parent := x}, ?a⟩
    else
      let arr₁ := self.arr.set x {nx with parent := y}
      let arr₂ := if e : nx.rank = ny.rank then
        arr₁.set ⟨y, by simp; exact y.2⟩ {ny with rank := ny.rank + 1}
      else arr₁
      ⟨arr₂, ?b⟩
  -- start proof
  case a =>
    let ⟨m, hm⟩ := self.model'
    simp [hm.rank_eq] at h
    exact ⟨_, _, hm.setParent y x h _ _ rfl rfl⟩
  case b =>
    let ⟨m, hm⟩ := self.model'; let n := self.size
    simp [hm.rank_eq] at h; simp [hm.parent_eq'] at yroot
    refine ⟨_, m.setParentBump x y ne h yroot, ?_⟩
    let parent (i : Fin n) := (if x.1 = i then y else m.parent i).1
    have : UFModel.Agrees arr₁ (·.parent) parent :=
      hm.1.set (fun i h => by simp; rw [if_neg h.symm]) (fun h => by simp)
    have H1 : UFModel.Agrees arr₂ (·.parent) parent := by
      simp; split
      · exact this.set (fun i h => by simp [h.symm]) (fun h => by simp [ne, hm.parent_eq'])
      · exact this
    have : UFModel.Agrees arr₁ (·.rank) (fun i : Fin n => m.rank i) :=
      hm.2.set (fun i h => by simp) (fun h => by simp [hm.rank_eq])
    let rank (i : Fin n) := if y.1 = i ∧ m.rank x = m.rank y then m.rank y + 1 else m.rank i
    have H2 : UFModel.Agrees arr₂ (·.rank) rank := by
      simp; split <;> (rename_i xy; simp [hm.rank_eq] at xy; simp [xy])
      · exact this.set (fun i h => by rw [if_neg h.symm]) (fun h => by simp [hm.rank_eq])
      · exact this
    exact ⟨H1, H2⟩

def union (self : UnionFind α) (x y : Fin self.size) : UnionFind α :=
  let ⟨self₁, rx, e, _⟩ := self.find x
  let ⟨self₂, ry, e, hry⟩ := self₁.find ⟨y, by rw [e]; exact y.2⟩
  self₂.link ⟨rx, by rw [e]; exact rx.2⟩ ry hry


-- Cubo de una diferencia
-- ======================

import tactic

lemma expand_mult
  (a b : ℤ)
  : (b-a)^3 = b^3-3*a*b^2+3*a^2*b-a^3 :=
by ring_exp


/-
Copyright (c) 2022 Yaël Dillies. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yaël Dillies
-/
import group_theory.group_action.defs

/-!
# Sum instances for additive and multiplicative actions

This file defines instances for additive and multiplicative actions on the binary `sum` type.

## See also

* `group_theory.group_action.pi`
* `group_theory.group_action.prod`
* `group_theory.group_action.sigma`
-/

variables {M N P α β γ : Type*}

namespace sum

section has_scalar
variables [has_scalar M α] [has_scalar M β] [has_scalar N α] [has_scalar N β] (a : M) (b : α)
  (c : β) (x : α ⊕ β)

@[to_additive sum.has_vadd] instance : has_scalar M (α ⊕ β) := ⟨λ a, sum.map ((•) a) ((•) a)⟩

@[to_additive] lemma smul_def : a • x = x.map ((•) a) ((•) a) := rfl
@[simp, to_additive] lemma smul_inl : a • (inl b : α ⊕ β) = inl (a • b) := rfl
@[simp, to_additive] lemma smul_inr : a • (inr c : α ⊕ β) = inr (a • c) := rfl
@[simp, to_additive] lemma smul_swap : (a • x).swap = a • x.swap := by cases x; refl

instance [has_scalar M N] [is_scalar_tower M N α] [is_scalar_tower M N β] :
  is_scalar_tower M N (α ⊕ β) :=
⟨λ a b x,
  by { cases x, exacts [congr_arg inl (smul_assoc _ _ _), congr_arg inr (smul_assoc _ _ _)] }⟩

@[to_additive] instance [smul_comm_class M N α] [smul_comm_class M N β] :
  smul_comm_class M N (α ⊕ β) :=
⟨λ a b x,
  by { cases x, exacts [congr_arg inl (smul_comm _ _ _), congr_arg inr (smul_comm _ _ _)] }⟩

instance [has_scalar Mᵐᵒᵖ α] [has_scalar Mᵐᵒᵖ β] [is_central_scalar M α] [is_central_scalar M β] :
  is_central_scalar M (α ⊕ β) :=
⟨λ a x,
  by { cases x, exacts [congr_arg inl (op_smul_eq_smul _ _), congr_arg inr (op_smul_eq_smul _ _)] }⟩

@[to_additive] instance has_faithful_smul_left [has_faithful_smul M α] :
  has_faithful_smul M (α ⊕ β) :=
⟨λ x y h, eq_of_smul_eq_smul $ λ a : α, by injection h (inl a)⟩

@[to_additive] instance has_faithful_smul_right [has_faithful_smul M β] :
  has_faithful_smul M (α ⊕ β) :=
⟨λ x y h, eq_of_smul_eq_smul $ λ b : β, by injection h (inr b)⟩

end has_scalar

@[to_additive] instance {m : monoid M} [mul_action M α] [mul_action M β] : mul_action M (α ⊕ β) :=
{ mul_smul := λ a b x,
    by { cases x, exacts [congr_arg inl (mul_smul _ _ _), congr_arg inr (mul_smul _ _ _)] },
  one_smul := λ x,
    by { cases x, exacts [congr_arg inl (one_smul _ _), congr_arg inr (one_smul _ _)] } }

end sum


import abelian_power_quandle

universes u v

section abelianization_pq

inductive pre_abelianization_pq (Q : Type u) [power_quandle Q] : Type u
| incl (x : Q) : pre_abelianization_pq
| add (x y : pre_abelianization_pq) : pre_abelianization_pq
| neg (x : pre_abelianization_pq) : pre_abelianization_pq
| zero : pre_abelianization_pq
| pow (x : pre_abelianization_pq) (n : ℤ) : pre_abelianization_pq

open pre_abelianization_pq

inductive pre_abelianization_pq_rel' (Q : Type u) [power_quandle Q] : pre_abelianization_pq Q → pre_abelianization_pq Q → Type u
| refl {x : pre_abelianization_pq Q} : pre_abelianization_pq_rel' x x
| symm {x y : pre_abelianization_pq Q} (hxy : pre_abelianization_pq_rel' x y) : pre_abelianization_pq_rel' y x
| trans {x y z : pre_abelianization_pq Q} (hxy : pre_abelianization_pq_rel' x y) (hyz : pre_abelianization_pq_rel' y z) : pre_abelianization_pq_rel' x z
| congr_add {x1 x2 y1 y2 : pre_abelianization_pq Q} (hx : pre_abelianization_pq_rel' x1 x2) (hy : pre_abelianization_pq_rel' y1 y2) : pre_abelianization_pq_rel' (add x1 y1) (add x2 y2)
| congr_neg {x1 x2 : pre_abelianization_pq Q} (hx : pre_abelianization_pq_rel' x1 x2) : pre_abelianization_pq_rel' (neg x1) (neg x2)
| congr_pow {x1 x2 : pre_abelianization_pq Q} {n : ℤ} (hx : pre_abelianization_pq_rel' x1 x2) : pre_abelianization_pq_rel' (pow x1 n) (pow x2 n)
| add_assoc (x y z : pre_abelianization_pq Q) : pre_abelianization_pq_rel' (add (add x y) z) (add x (add y z))
| add_comm (x y : pre_abelianization_pq Q) : pre_abelianization_pq_rel' (add x y) (add y x)
| zero_right (x : pre_abelianization_pq Q) :
pre_abelianization_pq_rel' (add x zero) (x)
| neg_add_right (x : pre_abelianization_pq Q) :
pre_abelianization_pq_rel' (add x (neg x)) (zero)
| pow_one (x : pre_abelianization_pq Q) : pre_abelianization_pq_rel' (pow x (1 : ℤ)) (x)
| pow_exp_zero (x : pre_abelianization_pq Q) : pre_abelianization_pq_rel' (pow x (0 : ℤ)) (incl 1)
| pow_comp (x : pre_abelianization_pq Q) (n m : ℤ) : pre_abelianization_pq_rel' (pow (pow x n) m) (pow x (n * m))
| pow_add (x y : pre_abelianization_pq Q) (n : ℤ) : pre_abelianization_pq_rel' (add (pow x n) (pow y n)) (pow (add x y) n)
| pow_neg (x : pre_abelianization_pq Q) (n : ℤ) : pre_abelianization_pq_rel' (neg (pow x n)) (pow (neg x) n)
| pow_zero (n : ℤ) : pre_abelianization_pq_rel' (pow zero n) (zero)
| rhd_incl (x y : Q) : pre_abelianization_pq_rel' (incl (x ▷ y)) (incl y)
| pow_incl (x : Q) (n : ℤ) : pre_abelianization_pq_rel' (incl (x ^ n)) (pow (incl x) n)

inductive pre_abelianization_pq_rel (Q : Type u) [power_quandle Q] : pre_abelianization_pq Q → pre_abelianization_pq Q → Prop
| rel {x y : pre_abelianization_pq Q} (hxy : pre_abelianization_pq_rel' Q x y) : pre_abelianization_pq_rel x y

variables {Q : Type u} [power_quandle Q]

lemma pre_abelianization_pq_rel'.rel {a b : pre_abelianization_pq Q} : pre_abelianization_pq_rel' Q a b → pre_abelianization_pq_rel Q a b := pre_abelianization_pq_rel.rel

@[refl]
lemma pre_abelianization_pq_rel.refl {a : pre_abelianization_pq Q} : pre_abelianization_pq_rel Q a a :=
pre_abelianization_pq_rel'.rel pre_abelianization_pq_rel'.refl

@[symm]
lemma pre_abelianization_pq_rel.symm {a b : pre_abelianization_pq Q} : pre_abelianization_pq_rel Q a b → pre_abelianization_pq_rel Q b a
| ⟨r⟩ := r.symm.rel

@[trans]
lemma pre_abelianization_pq_rel.trans {a b c : pre_abelianization_pq Q} :
pre_abelianization_pq_rel Q a b → pre_abelianization_pq_rel Q b c → pre_abelianization_pq_rel Q a c
| ⟨rab⟩ ⟨rbc⟩ := (rab.trans rbc).rel

instance pre_abelianization_pq.setoid (Q : Type*) [power_quandle Q] : setoid (pre_abelianization_pq Q) :=
{
    r := pre_abelianization_pq_rel Q,
    iseqv := begin
        split, apply pre_abelianization_pq_rel.refl,
        split, apply pre_abelianization_pq_rel.symm,
        apply pre_abelianization_pq_rel.trans,
    end
}

def abelianization_pq (Q : Type u) [power_quandle Q] : Type u := quotient (pre_abelianization_pq.setoid Q)

instance abelianization_pq_has_add : has_add (abelianization_pq Q) := ⟨λ a b, quotient.lift_on₂ a b (λ a b, ⟦add a b⟧) (begin
  intros a b c d hac hbd,
  cases hac with hac,
  cases hbd with hbc,
  apply quotient.sound,
  fconstructor,
  apply pre_abelianization_pq_rel'.congr_add,
  assumption,
  assumption,
end)⟩

instance abelianization_pq_has_neg : has_neg (abelianization_pq Q) := ⟨λ a, quotient.lift_on a (λ a, ⟦neg a⟧) (begin
  intros a b hab,
  cases hab with hab,
  apply quotient.sound,
  fconstructor,
  apply pre_abelianization_pq_rel'.congr_neg,
  assumption,
end)⟩

instance abelianization_pq_has_zero : has_zero (abelianization_pq Q) := ⟨⟦zero⟧⟩

instance abelianizaiton_pq_has_rhd : has_rhd (abelianization_pq Q) :=
⟨λ a b, b⟩

instance abelianization_pq_has_pow : has_pow (abelianization_pq Q) ℤ :=
⟨λ a n, quotient.lift_on a (λ a, ⟦pow a n⟧) (begin
  intros a b hab,
  cases hab with hab,
  apply quotient.sound,
  fconstructor,
  apply pre_abelianization_pq_rel'.congr_pow,
  assumption,
end)⟩

instance abelianization_pq_has_one : has_one (abelianization_pq Q) := ⟨⟦incl 1⟧⟩

lemma abelianization_pq_add_def (x y : pre_abelianization_pq Q) : (⟦x⟧ + ⟦y⟧ : abelianization_pq Q) = ⟦add x y⟧ := rfl

lemma abelianization_pq_neg_def (x : pre_abelianization_pq Q) : (-⟦x⟧ : abelianization_pq Q) = ⟦neg x⟧ := rfl

lemma abelianization_pq_zero_def : (0 : abelianization_pq Q) = ⟦zero⟧ := rfl

lemma abelianization_pq_rhd_def (x y : abelianization_pq Q) : x ▷ y = y := rfl

lemma abelianization_pq_pow_def (x : pre_abelianization_pq Q) (n : ℤ) : (⟦x⟧ ^ n : abelianization_pq Q) = ⟦pow x n⟧ := rfl

lemma abelianization_pq_one_def : (1 : abelianization_pq Q) = ⟦incl 1⟧ := rfl

lemma quot_mk_helper_abelianization (x : pre_abelianization_pq Q) : quot.mk setoid.r x = ⟦x⟧ := rfl

def apq_of : Q → abelianization_pq Q := λ q, ⟦incl q⟧

lemma apq_of_def (q : Q) : apq_of (q) = ⟦incl q⟧ := rfl

lemma apq_of_rhd (a b : Q) : apq_of (a ▷ b) = (apq_of a) ▷ (apq_of b) :=
begin
  simp only [apq_of_def],
  apply quotient.sound,
  fconstructor,
  exact pre_abelianization_pq_rel'.rhd_incl a b,
end

lemma apq_of_pow (a : Q) (n : ℤ) : apq_of (a ^ n) = (apq_of a) ^ n :=
begin
  simp only [apq_of_def],
  apply quotient.sound,
  fconstructor,
  exact pre_abelianization_pq_rel'.pow_incl a n,
end

instance abelianization_pq_is_pq : power_quandle (abelianization_pq Q) := {
  rhd_dist := begin
    intros,
    simp only [abelianization_pq_rhd_def],
  end,
  rhd_idem := begin
    intros,
    simp only [abelianization_pq_rhd_def],
  end,
  pow_one := begin
    intro a,
    induction a,
    {
      simp only [quot_mk_helper_abelianization],
      simp only [abelianization_pq_pow_def],
      apply quotient.sound,
      fconstructor,
      exact pre_abelianization_pq_rel'.pow_one a,
    },
    {refl,},
  end,
  pow_zero := begin
    intro a,
    induction a,
    {
      simp only [quot_mk_helper_abelianization],
      simp only [abelianization_pq_pow_def],
      apply quotient.sound,
      fconstructor,
      exact pre_abelianization_pq_rel'.pow_exp_zero a,
    },
    {refl,},
  end,
  pow_comp := begin
    intros a n m,
    induction a,
    {
      simp only [quot_mk_helper_abelianization],
      simp only [abelianization_pq_pow_def],
      apply quotient.sound,
      fconstructor,
      exact pre_abelianization_pq_rel'.pow_comp a n m,
    },
    {refl,},
  end,
  rhd_one := begin
    intros,
    simp only [abelianization_pq_rhd_def],
  end,
  one_rhd := begin
    intros,
    simp only [abelianization_pq_rhd_def],
  end,
  pow_rhd := begin
    intros,
    simp only [abelianization_pq_rhd_def],
  end,
  rhd_pow_add := begin
    intros,
    simp only [abelianization_pq_rhd_def],
  end }

instance abelianization_pq_is_apq : abelian_power_quandle (abelianization_pq Q) := {
  apq_unit_is_morphism := begin
    split,
    {
      intros a b,
      simp only [abelianization_pq_rhd_def],
    },
    {
      intros a n,
      symmetry,
      apply quotient.sound,
      fconstructor,
      exact pre_abelianization_pq_rel'.pow_zero n,
    }
  end,
  apq_inverse_is_morphism := begin
    split,
    {
      intros a b,
      simp only [abelianization_pq_rhd_def],
    },
    {
      intros a n,
      simp only,
      induction a,
      {
        rw quot_mk_helper_abelianization,
        apply quotient.sound,
        fconstructor,
        exact pre_abelianization_pq_rel'.pow_neg a n,
      },
      {refl,},
    },
  end,
  apq_addition_is_morphism := begin
    split,
    {
      intros a b,
      cases a with a1 a2,
      cases b with b1 b2,
      simp only [rhd_def_prod],
      simp only [abelianization_pq_rhd_def],
    },
    {
      intros a n,
      cases a with a1 a2,
      simp only [pow_def_prod],
      induction a1,
      induction a2,
      {
        simp only [quot_mk_helper_abelianization],
        apply quotient.sound,
        fconstructor,
        exact pre_abelianization_pq_rel'.pow_add a1 a2 n,
      },
      {refl,},
      {refl,},
    },
  end,
  apq_addition_assoc := begin
    intros a b c,
    induction a,
    induction b,
    induction c,
    {
      simp only [quot_mk_helper_abelianization],
      symmetry,
      apply quotient.sound,
      fconstructor,
      exact pre_abelianization_pq_rel'.add_assoc a b c,
    },
    {refl,},
    {refl,},
    {refl,},
  end,
  apq_addition_comm := begin
    intros a b,
    induction a,
    induction b,
    {
      simp only [quot_mk_helper_abelianization],
      apply quotient.sound,
      fconstructor,
      exact pre_abelianization_pq_rel'.add_comm a b,
    },
    {refl,},
    {refl,},
  end,
  apq_addition_zero_right := begin
    intros a,
    induction a,
    {
      simp only [quot_mk_helper_abelianization],
      apply quotient.sound,
      fconstructor,
      exact pre_abelianization_pq_rel'.zero_right a,
    },
    {refl,},
  end,
  apq_addition_zero_left := begin
    intros a,
    induction a,
    {
      simp only [quot_mk_helper_abelianization],
      apply quotient.sound,
      fconstructor,
      refine pre_abelianization_pq_rel'.trans _ _,
      exact a.add zero,
      apply pre_abelianization_pq_rel'.add_comm,
      exact pre_abelianization_pq_rel'.zero_right a,
    },
    {refl,},
  end,
  apq_inverse_addition_right := begin
    intros a,
    induction a,
    {
      simp only [quot_mk_helper_abelianization],
      apply quotient.sound,
      fconstructor,
      exact pre_abelianization_pq_rel'.neg_add_right a,
    },
    {refl,},
  end,
  apq_inverse_addition_left := begin
    intros a,
    induction a,
    {
      simp only [quot_mk_helper_abelianization],
      apply quotient.sound,
      fconstructor,
      refine pre_abelianization_pq_rel'.trans _ _,
      exact add (a) (neg a),
      exact pre_abelianization_pq_rel'.add_comm (neg a) a,
      exact pre_abelianization_pq_rel'.neg_add_right a,
    },
    {refl,},
  end }

lemma apq_of_is_pq_morphism : is_pq_morphism (apq_of : Q → abelianization_pq Q) :=
begin
  split,
  exact apq_of_rhd,
  exact apq_of_pow,
end

end abelianization_pq

section abelianization_pq_functor

variables {Q1 : Type u} [power_quandle Q1]
variables {Q2 : Type v} [power_quandle Q2]

open pre_abelianization_pq

def abelianization_pq_functor_pre (f : Q1 → Q2) (hf : is_pq_morphism f) : pre_abelianization_pq Q1 → pre_abelianization_pq Q2
| (incl x) := incl (f x)
| (add x y) := add (abelianization_pq_functor_pre x) (abelianization_pq_functor_pre y)
| (neg x)  := neg (abelianization_pq_functor_pre x)
| zero := zero
| (pow x n) := pow (abelianization_pq_functor_pre x) n

def abelianization_pq_functor (f : Q1 → Q2) (hf : is_pq_morphism f) : abelianization_pq Q1 → abelianization_pq Q2 := quotient.lift (λ x, ⟦abelianization_pq_functor_pre f hf x⟧) (begin
  intros a b hab,
  simp only,
  induction hab,
  induction hab_hxy,
  {
    refl,
  },
  {
    symmetry,
    assumption,
  },
  {
    transitivity,
    assumption,
    assumption,
  },
  {
    simp only [abelianization_pq_functor_pre, ←abelianization_pq_add_def],
    congr,
    assumption,
    assumption,
  },
  {
    simp only [abelianization_pq_functor_pre, ←abelianization_pq_neg_def],
    congr,
    assumption,
  },
  {
    simp only [abelianization_pq_functor_pre, ←abelianization_pq_pow_def],
    congr,
    assumption,
  },
  {
    simp only [abelianization_pq_functor_pre, ←abelianization_pq_add_def],
    rw abelian_power_quandle.apq_addition_assoc,
  },
  {
    simp only [abelianization_pq_functor_pre, ←abelianization_pq_add_def],
    rw abelian_power_quandle.apq_addition_comm,
  },
  {
    simp only [abelianization_pq_functor_pre, ←abelianization_pq_add_def, ←abelianization_pq_zero_def],
    rw abelian_power_quandle.apq_addition_zero_right,
  },
  {
    simp only [abelianization_pq_functor_pre, ←abelianization_pq_add_def, ←abelianization_pq_zero_def, ←abelianization_pq_neg_def],
    rw abelian_power_quandle.apq_inverse_addition_right,
  },
  {
    simp only [abelianization_pq_functor_pre, ←abelianization_pq_pow_def],
    rw power_quandle.pow_one,
  },
  {
    simp only [abelianization_pq_functor_pre, ←abelianization_pq_pow_def],
    rw one_preserved_by_morphism f hf,
    rw ←abelianization_pq_one_def,
    rw power_quandle.pow_zero,
  },
  {
    simp only [abelianization_pq_functor_pre, ←abelianization_pq_pow_def],
    rw power_quandle.pow_comp,
  },
  {
    simp only [abelianization_pq_functor_pre, ←abelianization_pq_pow_def, ←abelianization_pq_add_def],
    rw pow_dist_add,
  },
  {
    simp only [abelianization_pq_functor_pre, ←abelianization_pq_pow_def, ←abelianization_pq_neg_def],
    rw apq_neg_pow,

  },
  {
    simp only [abelianization_pq_functor_pre, ←abelianization_pq_pow_def, ←abelianization_pq_zero_def],
    rw apq_zero_pow,
  },
  {
    simp only [abelianization_pq_functor_pre, ←apq_of_def],
    rw hf.1,
    rw apq_of_rhd,
    rw abelianization_pq_rhd_def,
  },
  {
    simp only [abelianization_pq_functor_pre, ←abelianization_pq_pow_def, ←apq_of_def],
    rw hf.2,
    rw apq_of_pow,
  },
end)

theorem abelianization_pq_functor_is_apq_morphism (f : Q1 → Q2) (hf : is_pq_morphism f) : is_apq_morphism (abelianization_pq_functor f hf) :=
begin
  split,
  {
    intros a b,
    induction a,
    induction b,
    refl,
    refl,
    refl,
  },
  {
    intros a n,
    induction a,
    refl,
    refl,
  },
end

end abelianization_pq_functor

section abelianization_pq_adjoint

variables {Q : Type u} [power_quandle Q]
variables {A : Type v} [abelian_power_quandle A]

open pre_abelianization_pq

def apq_adjoint_lift_pre (f : Q → A) (hf : is_pq_morphism f) : pre_abelianization_pq Q → A
| (incl x) := f x
| (add x y) := (apq_adjoint_lift_pre x) + (apq_adjoint_lift_pre y)
| (neg x) := -(apq_adjoint_lift_pre x)
| (zero) := 0
| (pow x n) := (apq_adjoint_lift_pre x) ^ n

def apq_adjoint_lift (f : Q → A) (hf : is_pq_morphism f) : abelianization_pq Q → A := quotient.lift (apq_adjoint_lift_pre f hf) (begin
  intros a b hab,
  induction hab,
  induction hab_hxy,
  {
    refl,
  },
  {
    symmetry,
    assumption,
  },
  {
    transitivity,
    assumption,
    assumption,
  },
  {
    simp only [apq_adjoint_lift_pre],
    congr,
    assumption,
    assumption,
  },
  {
    simp only [apq_adjoint_lift_pre],
    congr,
    assumption,
  },
  {
    simp only [apq_adjoint_lift_pre],
    congr,
    assumption,
  },
  {
    simp only [apq_adjoint_lift_pre],
    rw abelian_power_quandle.apq_addition_assoc,
  },
  {
    simp only [apq_adjoint_lift_pre],
    rw abelian_power_quandle.apq_addition_comm,
  },
  {
    simp only [apq_adjoint_lift_pre],
    rw abelian_power_quandle.apq_addition_zero_right,
  },
  {
    simp only [apq_adjoint_lift_pre],
    rw abelian_power_quandle.apq_inverse_addition_right,
  },
  {
    simp only [apq_adjoint_lift_pre],
    rw power_quandle.pow_one,
  },
  {
    simp only [apq_adjoint_lift_pre],
    rw power_quandle.pow_zero,
    rw one_preserved_by_morphism f hf,
  },
  {
    simp only [apq_adjoint_lift_pre],
    rw power_quandle.pow_comp,
  },
  {
    simp only [apq_adjoint_lift_pre],
    rw pow_dist_add,
  },
  {
    simp only [apq_adjoint_lift_pre],
    rw apq_neg_pow,
  },
  {
    simp only [apq_adjoint_lift_pre],
    rw apq_zero_pow,
  },
  {
    simp only [apq_adjoint_lift_pre],
    rw hf.1,
    rw apq_rhd_is_right,
  },
  {
    simp only [apq_adjoint_lift_pre],
    rw hf.2,
  },
end)

def apq_adjoint_lift_is_apq_morphism (f : Q → A) (hf : is_pq_morphism f) : is_apq_morphism (apq_adjoint_lift f hf) :=
begin
  split,
  {
    intros a b,
    induction a,
    induction b,
    refl,
    refl,
    refl,
  },
  {
    intros a n,
    induction a,
    refl,
    refl,
  },
end

end abelianization_pq_adjoint


import .typing .semantics

lemma progress {e : term} {τ : type} : has_type e τ → is_value e ∨ ∃ e', e ⇝ e' :=
begin
  unfold has_type,
  generalize g : @emptyf var type = Γ,
  intro h,
  induction h,

  -- Impossible, variables cannot be typed in ∅
  case has_type_under.var _ _ _ h
  { rw ←g at h, contradiction },

  -- Unit and abstractions are trivially values
  case has_type_under.unit
  { apply or.inl, apply is_value.unit },
  case has_type_under.abs
  { apply or.inl, apply is_value.abs },

  -- Applications always evaluate
  case has_type_under.app _ e₁ e₂ _ _ te₁ _ ih₁ ih₂
  { apply or.inr,
    -- Apply the inductive hypothesis on e₁
    cases (ih₁ g).symm with e₁_steps e₁_iv,

    -- If the LHS steps, apply CONTEXT
    cases e₁_steps with e₁',
    existsi term.app e₁' e₂,
    let E := E.app_left E.hole e₂,
    rw [show term.app e₁  e₂ = E e₁,  from rfl,
        show term.app e₁' e₂ = E e₁', from rfl],
    apply step.context, assumption,

    -- Apply the inductive hypothesis on e₂
    cases (ih₂ g).symm with e₂_steps,

    -- If the RHS steps, apply CONTEXT
    cases e₂_steps with e₂',
    existsi term.app e₁ e₂',
    let E := E.app_right ⟨e₁, e₁_iv⟩ E.hole,
    rw [show term.app e₁ e₂  = E e₂,  from rfl,
        show term.app e₁ e₂' = E e₂', from rfl],
    apply step.context, assumption,

    -- If both are values, then it β-reduces
    cases e₁_iv with x _ e,
    cases subst e e₂ x with e',
    existsi e',
    apply step.beta, repeat { assumption },

    -- Discard superfluous goals
    cases te₁ }
end

lemma has_type_halts_is_value {e : term} {τ : type} : has_type e τ → halts e → is_value e :=
or.resolve_right ∘ progress

lemma ctx_invar {e : term} {τ : type} {Γ : ctx} :
  has_type e τ → ∀ Γ, has_type_under Γ e τ := sorry

-- See technical note in Programming Languages Foundations
-- for why we induct on e as opposed to x:τ' |- e:τ
lemma subst_lemma {x : var} {e e' es : term} {τ τ' : type} {Γ : ctx} :
  has_type_under (extend Γ x τ') e τ → has_type e' τ' → is_subst es e e' x → has_type_under Γ es τ :=
begin
  intros te te' is,

  induction e generalizing Γ τ es,

  case term.unit
  { cases te, cases is,
    apply has_type_under.unit },

  case term.var
  { cases te,

    case has_type_under.var h
    { cases is,

      case is_subst.same_var
      { rw extend_same at h,
        injection h with h,
        rw ←h, apply ctx_invar, assumption, assumption },

      case is_subst.diff_var neq
      { rw extend_diff Γ τ' neq at h,
        apply has_type_under.var, assumption } } },

  case term.abs y _ ih
  { cases te, cases is,

    apply has_type_under.abs,
    apply ih,
    rw extend_comm _ _ _ a_2,
    repeat { assumption } },

  case term.app
  { cases te, cases is,
    let := ih_1 a_2 a_4,
    let := ih_2 a_3 a_5,
    apply has_type_under.app,
    repeat {assumption} }
end

lemma uniqueness {e : term} {τ τ' : type} :
  has_type e τ → has_type e τ' → τ = τ' := sorry

lemma E_lemma {E : E} {e e' : term} {τ τ' : type} :
  has_type (E e) τ → has_type e τ' → has_type e' τ' → has_type (E e') τ :=
begin
  intros tEe te te',

  induction E generalizing τ,

  rw uniqueness tEe te,
  assumption,

  cases tEe,
  let := ih_1 a_2,
  apply has_type_under.app,
  repeat {assumption},

  cases a,
  cases tEe,
  let := ih_1 a_2,
  apply has_type_under.app,
  repeat {assumption},
end

lemma typing_hole {E : E} {e : term} {τ : type} :
  has_type (E e) τ → ∃ τ', has_type e τ' :=
begin
  intro t,
  induction E generalizing τ,

  case E.hole
  { existsi τ, assumption },

  case E.app_left _ _ ih
  { cases t,
    case has_type_under.app _ h
    { exact ih h } },

  case E.app_right v _ ih
  { cases v, cases t,
    case has_type_under.app _ _ h
    { exact ih h } }
end

lemma preservation {e e' : term} {τ : type} :
  has_type e τ → (e ⇝ e') → has_type e' τ :=
begin
  intros t s,
  induction s generalizing τ,

  case step.beta
  { cases t,
    case has_type_under.app _ t'
    { cases t',
      apply subst_lemma,
      repeat { assumption } } },

  case step.context _ _ _ _ ih
  { cases typing_hole t with _ t',
    let := ih t',
    apply E_lemma,
    repeat { assumption } },
end

theorem soundness {e e' : term} {τ : type} :
  has_type e τ → (e ⇝* e') → halts e' → is_value e' ∧ has_type e' τ :=
begin
  intros t s h,
  induction s,

  case rtc.refl
  { apply and.intro,
    apply has_type_halts_is_value,
    repeat { assumption } },

  case rtc.trans _ _ _ s _ ih
  { exact ih (preservation t s) h }
end


/-
Copyright (c) 2019 The Flypitch Project. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.

Authors: Jesse Han, Floris van Doorn
-/
import .regular_open_algebra

universes u v
local attribute [instance] classical.prop_decidable

/- Some facts about Cantor spaces: topological spaces of the form (set α) -/

open topological_space lattice

@[instance, priority 1000]def Prop_space : topological_space Prop := ⊥

instance discrete_Prop : discrete_topology Prop := ⟨rfl⟩

instance product_topology {α : Type*} : topological_space (set α) :=
Pi.topological_space

lemma eq_true_of_provable {p : Prop} (h : p) : (p = true) := by simp[h]

lemma eq_false_of_provable_neg {p : Prop} (h : ¬ p) : (p = false) := by finish

@[reducible, simp]noncomputable def Prop_to_bool (p : Prop) : bool :=
by {haveI := classical.prop_decidable p, by_cases p, exact true, exact false}

@[simp]lemma Prop_to_bool_true : Prop_to_bool true = tt := by simp

@[simp]lemma Prop_to_bool_false : Prop_to_bool false = ff := by simp

noncomputable def equiv_Prop_bool : equiv Prop bool :=
{ to_fun := Prop_to_bool,
  inv_fun := λ b, by {cases b, exact false, exact true},
  left_inv := λ p, by {by_cases p, rw[eq_true_of_provable h, Prop_to_bool_true],
                        rw[eq_false_of_provable_neg h, Prop_to_bool_false]},
  right_inv := λ x, by cases x; finish }

noncomputable instance Prop_encodable : encodable Prop :=
 @encodable.of_equiv _ _ (by apply_instance) equiv_Prop_bool

instance Prop_separable : separable_space Prop :=
{ exists_countable_closure_eq_univ :=
  by {use set.univ, refine ⟨set.countable_encodable _, by simp⟩}}

@[ematch]lemma is_open_of_compl_closed {α : Type*} [topological_space α] {S : set α} (H : (: is_closed (-S) :)) : is_open S :=
by rwa[<-is_closed_compl_iff]

@[ematch]lemma is_closed_of_compl_open {α : Type*} [topological_space α] {S : set α} (H : (: is_open (-S) :)) : is_closed S :=
by rwa[<-is_open_compl_iff]

def clopens (α : Type*) [topological_space α] : Type* := {S : set α // is_clopen S}

instance clopens_lattice {α : Type*} [topological_space α] : lattice (clopens α) :=
{ sup := λ S₁ S₂, ⟨S₁.1 ∪ S₂.1, by {apply is_clopen_union, tidy}⟩,
  le := λ S₁ S₂, S₁.1 ⊆ S₂.1,
  lt := λ S₁ S₂, S₁.1 ⊆ S₂.1 ∧ S₁.1 ≠ S₂.1,
  le_refl := by tidy,
  le_trans := by tidy,
  lt_iff_le_not_le :=
    by {intros; split; intros,
      {split, {from a_1.left},
        intro H, apply a_1.right, refine le_antisymm _ _, from a_1.left, from ‹_›},
        {/- `tidy` says -/ cases a_1, cases b, cases a, cases a_property,
        cases b_property, dsimp at *, fsplit,
        work_on_goal 0 { assumption }, intros a, induction a, solve_by_elim}},
  le_antisymm := by {intros, apply subtype.eq, refine le_antisymm _ _; from ‹_›},
  le_sup_left := by {intros, simp, intros x Hx, left, from ‹_›},
  le_sup_right := by {intros, simp, intros x Hx, right, from ‹_›},
  sup_le := by {intros, intros x Hx, cases Hx, from a_1 ‹_›, from a_2 ‹_›},
  inf := λ S₁ S₂, ⟨S₁.1 ∩ S₂.1, by {apply is_clopen_inter, from S₁.property, from S₂.property}⟩,
  inf_le_left := by {intros, simp, intros x Hx, from Hx.left},
  inf_le_right := by {intros, simp, intros x Hx, from Hx.right},
  le_inf := by {intros, simp, intros x Hx, from ⟨a_1 ‹_›, a_2 ‹_›⟩}}

instance clopens_bounded_lattice {α : Type*} [topological_space α] : bounded_lattice (clopens α) :=
{top := ⟨set.univ, is_clopen_univ⟩,
  le_top := by tidy,
  bot := ⟨∅, is_clopen_empty⟩,
  bot_le := by tidy,
 .. clopens_lattice}

noncomputable def finset_clopens_mk {α : Type*} [topological_space α] {X : finset (set α)} (H : ∀ S ∈ X, is_clopen S) : finset (clopens α) :=
begin
  apply finset.image, show finset _, from finset.attach X,
  intro x, cases x with x Hx, use x, from H x Hx
end

lemma is_clopen_finite_inter {α : Type*} [topological_space α] {X : finset (set α)}
  (H_X : ∀ S ∈ X, is_clopen S) : is_clopen (finset.inf X id) :=
begin
  revert H_X, apply finset.induction_on X, intro _, from is_clopen_univ,
  intros a A H_a H_A IH, simp at ⊢ IH, apply is_clopen_inter,
  from IH a (or.inl rfl), apply H_A, intros S H_S, from IH S (or.inr H_S)
end

lemma is_clopen_finite_inter' {α α' : Type*} [topological_space α] {X : finset α'} {f : α' → set (α)} (H_f : ∀ x ∈ X, is_clopen (f x)) : is_clopen (finset.inf X f) :=
begin
  revert H_f, apply finset.induction_on X, intro _, from is_clopen_univ,
  intros a A H_a H_A IH, simp at ⊢ IH, apply is_clopen_inter,
  from IH a (or.inl rfl), apply H_A, intros S H_S, from IH S (or.inr H_S)
end

namespace cantor_space
section cantor_space
variables {α : Type*}

def principal_open (x : α) : set (set α) := {S | x ∈ S}

def co_principal_open (x : α) : set (set α) := {S | x ∉ S}

@[simp]lemma neg_principal_open {x : α} : co_principal_open x = -(principal_open x)  :=
by unfold principal_open; refl

@[simp]lemma neg_co_principal_open {x : α} : - (co_principal_open x) = principal_open x :=
by {simp[principal_open]}

-- lemma is_open_induced_iff' {α β : Type*} {f : α → β} [t : topological_space β] {s : set α} {f : α → β} :
--    (∃t, is_open t ∧ f ⁻¹' t = s) ↔ @topological_space.is_open α (t.induced f) s := is_open_induced_iff.symm

def opens_over (x : α) : set(set(set α)) := {principal_open x, co_principal_open x, set.univ, ∅}

@[simp]lemma principal_open_mem_opens_over {x : α} : principal_open x ∈ opens_over x :=
by {right,right,right, from set.mem_singleton _}

@[simp]lemma co_principal_open_mem_opens_over {x : α} : co_principal_open x ∈ opens_over x :=
by {right,right,left, refl}

@[simp]lemma univ_mem_opens_over {x : α} : set.univ ∈ opens_over x :=
by {right,left, refl}

@[simp]lemma empty_mem_opens_over {x : α} : ∅ ∈ opens_over x :=
by {left, refl}

/-- Given a : α, τ is the topology induced by pulling back the
  discrete topology on Prop along the a'th projection map -/
def τ (a : α) : topological_space (set α) :=
induced (λS, a ∈ S) (by apply_instance : topological_space Prop)

lemma fiber_over_false {α : Type*} {a : α} : (λ x : set α, a ∈ x) ⁻¹' {false} = {y | a ∉ y} :=
begin
  ext, split; simp[set.mem_preimage]
end

lemma fiber_over_true {α : Type*} {a : α} : (λ x : set α, a ∈ x) ⁻¹' {true} = {y | a ∈ y} :=
begin
  ext, split; simp[set.mem_preimage]
end

lemma opens_over_sub_τ (a : α) : opens_over a ⊆ (τ a).is_open :=
begin
  unfold τ, intros S HS, unfold opens_over at HS,
  repeat{cases HS}, apply is_open_empty, apply _root_.is_open_univ,
  apply is_open_induced_iff.mpr, fsplit, exact {false}, fsplit,
  apply is_open_discrete,
    {ext1, ext1, dsimp at *, fsplit,
      work_on_goal 0 { intros a_1 a_2, cases a_1,
      work_on_goal 1 { assumption } }, work_on_goal 1 { intros a_1 },
    rwa[<-a_1], rwa[fiber_over_false]},
  apply is_open_induced_iff.mpr, fsplit, exact {true}, fsplit,
  apply is_open_discrete,
    {ext1, ext1, fsplit,
      work_on_goal 0 { intros a_1, cases a_1, work_on_goal 0 { cc },
      dsimp at a_1, cases a_1 }, intros a_1, rwa[fiber_over_true]},
end

lemma opens_over_le_τ (a : α) : τ a ≤ generate_from (opens_over a) :=
by { rw [le_generate_from_iff_subset_is_open], exact opens_over_sub_τ a }

lemma τ_le_product_topology (a : α) : product_topology ≤ τ a :=
infi_le _ _

lemma le_iff_opens_sub {β : Type*} {τ₁ τ₂ : topological_space β} :
  τ₂ ≤ τ₁ ↔ {S | τ₁.is_open S} ⊆ {S | τ₂.is_open S} := by refl

lemma τ_le_opens_over (a : α) : generate_from (opens_over a) ≤ τ a :=
begin
  apply le_iff_opens_sub.mpr, rintros X ⟨H_w, H_h_left, rfl⟩,
   by_cases htrue : true ∈ H_w; by_cases hfalse : false ∈ H_w,
   { constructor, unfold opens_over, repeat{split}, right,left,
    ext, by_cases a ∈ x, split, from λ _, trivial, intro, simp[h], from ‹_›,
    split, from λ _, trivial, intro, simp[h], from ‹_›},
   { constructor, unfold opens_over, repeat{split}, right, right, right,
     simp, ext, by_cases a ∈ x, split, intro H, simp[principal_open], from ‹_›,
     intro H, simp*, split; intros, simp [h, hfalse] at a_1, cases a_1,
     simp[principal_open, *, -a_1] at a_1, cases a_1},
   { constructor, unfold opens_over, repeat{split}, right, right, left,
     simp, ext, split; intros; simp[*, -a_1] at a_1; by_cases a ∈ x,
     tidy {tactics := with_cc}, },
   { have : H_w = ∅, ext, split; intros, by_cases x; simp* at a_1; cases a_1, cases a_1,
    subst this, simp, by apply @is_open_empty _ (generate_from _)}
end

@[simp]lemma is_open_generated_from_basic {β : Type*} [topological_space β] {s : set (set β)} {x ∈ s} :
  is_open (generate_from s) x := by {constructor, from ‹_›}

lemma is_open_principal_open {a : α} : is_open (principal_open a) :=
by { apply (le_trans (τ_le_product_topology _) (opens_over_le_τ a)), simp[opens_over] }

lemma is_open_co_principal_open {a : α} : is_open (co_principal_open a) :=
by { apply (le_trans (τ_le_product_topology _) (opens_over_le_τ a)), simp[opens_over] }

lemma is_closed_principal_open {a : α} : is_closed (principal_open a) :=
by {apply is_closed_of_compl_open, from is_open_co_principal_open}

lemma is_closed_co_principal_open {a : α} : is_closed (co_principal_open a) :=
by {apply is_closed_of_compl_open,
    simp only [neg_principal_open, lattice.neg_neg], from is_open_principal_open}

lemma is_clopen_principal_open {a : α} : is_clopen (principal_open a) :=
  ⟨is_open_principal_open, is_closed_principal_open⟩

lemma is_clopen_co_principal_open {a : α} : is_clopen (co_principal_open a) :=
  ⟨is_open_co_principal_open, is_closed_co_principal_open⟩

@[reducible]def principal_open_finset (F : finset α) : set (set α) := {S | F.to_set ⊆ S}

lemma mem_principal_open_finset_iff {F : finset α} {x : set α} : x ∈ (principal_open_finset F) ↔ (↑F : set α) ⊆ x := by refl

@[simp]lemma principal_open_finset_insert {F : finset α} {a : α} : principal_open_finset (insert a F) = principal_open_finset {a} ∩ principal_open_finset F :=
begin
  ext x, /- `tidy` says -/ dsimp at *, fsplit, work_on_goal 0 { intros a_1, fsplit, work_on_goal 0 { intros a_2 a_3, cases a_3, work_on_goal 0 { induction a_3 }, work_on_goal 1 { cases a_3 } }, work_on_goal 1 { intros a_2 a_3 } }, work_on_goal 2 { intros a_1 a_2 a_3, cases a_1 },
    { unfold finset.to_set at a_1, exact a_1 (by simp : a_2 ∈ _) },
    { unfold finset.to_set at a_1, exact a_1 (by finish : a_2 ∈ _) },
    { unfold finset.to_set at *, simp[set.mem_insert_iff] at a_3,
      cases a_3 with a_3₁ a_3₂,
        { finish },
        { exact a_1_right ‹_› } }
end

lemma principal_open_finset_eq_inter (F : finset α) : principal_open_finset F = (finset.inf F (principal_open)) :=
begin
  apply finset.induction_on F,
    {tidy},
  intros a A h_a IH, simp, rw[<-IH], ext, split; intros,
  tidy, apply a_1_left, simp[finset.to_set]
end

@[reducible] def co_principal_open_finset (F : finset α) : set (set α) := {S | F.to_set ⊆ (-S)}

@[simp]lemma co_principal_open_finset_insert {F : finset α} {a : α} : co_principal_open_finset (insert a F) = co_principal_open_finset {a} ∩ co_principal_open_finset F :=
begin
  ext x, /- `tidy` says -/ dsimp at *, fsplit, work_on_goal 0 { intros a_1, fsplit, work_on_goal 0 { intros a_2 a_3, cases a_3, work_on_goal 0 { induction a_3 }, work_on_goal 1 { cases a_3 } }, work_on_goal 1 { intros a_2 a_3 } }, work_on_goal 2 { intros a_1 a_2 a_3, cases a_1 },
    { unfold finset.to_set at a_1, exact a_1 (by simp : a_2 ∈ _) },
    { unfold finset.to_set at a_1, exact a_1 (by finish : a_2 ∈ _) },
    { unfold finset.to_set at *, simp[set.mem_insert_iff] at a_3,
      cases a_3 with a_3₁ a_3₂,
        { finish },
        { exact a_1_right ‹_› } }
end

lemma co_principal_open_finset_eq_inter (F : finset α) : co_principal_open_finset F = (finset.inf F (co_principal_open)) :=
begin
  apply finset.induction_on F,
    {tidy},
  intros a A h_a IH, simp, rw[<-IH], ext, split; intros,
  tidy, apply a_1_left, simp[finset.to_set], from a_1
end

lemma is_clopen_principal_open_finset (F : finset α) : is_clopen (principal_open_finset F) :=
begin
  rw[principal_open_finset_eq_inter], apply is_clopen_finite_inter',
  from λ _ _, is_clopen_principal_open
end

lemma is_clopen_co_principal_open_finset (F : finset α) : is_clopen (co_principal_open_finset F) :=
begin
  rw[co_principal_open_finset_eq_inter], apply is_clopen_finite_inter',
  from λ _ _, is_clopen_co_principal_open
end

lemma product_topology_generate_from : (product_topology : topological_space (set α)) = generate_from (⋃(a : α), opens_over a) :=
begin
  apply le_antisymm,
  { unfold product_topology Pi.topological_space,
    apply generate_from_mono,
    intros X HX, rcases HX with ⟨W, ⟨H₁, H₂⟩⟩, simp, cases H₁ with a Ha,
    use τ a, split, use a, refl, apply opens_over_le_τ a, constructor, cc },
  refine le_infi _, intro a,
  refine le_trans _ (τ_le_opens_over a), apply generate_from_mono,
  intros X H, constructor, simp, use a, exact H
end

def standard_basis : set (set (set α)) :=
{T : set (set α) | ∃ p_ins p_out : finset α, T = (finset.inf p_ins principal_open) ∩ (finset.inf p_out co_principal_open) ∧ p_ins ∩ p_out = ∅} ∪ {∅}

lemma ins₁_out₂_disjoint {x : set α} {p_ins₁ p_out₁ p_ins₂ p_out₂ : finset α}
  (H_mem₁ : x ∈ finset.inf p_ins₁ principal_open ∩ finset.inf p_out₁ co_principal_open)
  (H_mem₂ : x ∈ finset.inf p_ins₂ principal_open ∩ finset.inf p_out₂ co_principal_open)
  (H_disjoint₁ : p_ins₁ ∩ p_out₁ = ∅) (H_disjoint₂ : p_ins₂ ∩ p_out₂ = ∅)
  {a : α} (Ha_left : a ∈ p_ins₁)
  (Ha_right : a ∈ p_out₂) : false :=
begin
  rw[<-principal_open_finset_eq_inter, <-co_principal_open_finset_eq_inter] at H_mem₁ H_mem₂,
  suffices : a ∉ x ∧ a ∈ x, from (not_and_self _).mp this, split,
  rw[set.mem_inter_iff] at H_mem₂, apply H_mem₂.right ‹_›,
  rw[set.mem_inter_iff] at H_mem₁, apply H_mem₁.left ‹_›
end

@[simp]lemma principal_open_mem_standard_basis {a : α} : (principal_open a) ∈ (@standard_basis α) :=
by {simp[standard_basis], right, use {a}, use ∅, tidy}

@[simp]lemma co_principal_open_mem_standard_basis {a : α} : co_principal_open a ∈ (@standard_basis α) :=
by {simp[standard_basis], right, use ∅, use {a}, tidy}

lemma univ_mem_standard_basis : set.univ ∈ (@standard_basis α) :=
by {simp[standard_basis], use ∅, use ∅, tidy}

lemma intersection_standard_basis_nonempty' {α : Type*} {p_ins p_out : finset α} {H : p_ins ∩ p_out = ∅} : ∃ X, X ∈ finset.inf p_ins principal_open ∩ finset.inf p_out co_principal_open :=
begin
  use p_ins.to_set, rw[<-principal_open_finset_eq_inter, <-co_principal_open_finset_eq_inter],
  simp[finset.to_set], intros x Hx, simp, intro H', apply ((finset.ext).mp H x).mp,
  rw[finset.mem_inter], from ⟨‹_›,‹_›⟩
end

lemma intersection_standard_basis_nonempty {α : Type*} {T : set (set α)} {p_ins p_out : finset α} {H_eq : T = finset.inf p_ins principal_open ∩ finset.inf p_out co_principal_open} {H : p_ins ∩ p_out = ∅} : ¬⋂₀ finset.to_set (finset.image principal_open p_ins ∪ finset.image co_principal_open p_out) = ∅ :=
begin
  intro H', simp[finset.to_set] at H', replace H' := (set.ext_iff _ _).mp H',
  cases @intersection_standard_basis_nonempty' _ p_ins p_out ‹_› with a H_a, subst H_eq,
  rw[<-principal_open_finset_eq_inter, <-co_principal_open_finset_eq_inter] at H_a, cases H_a,
  specialize H' a, apply H'.mp, simp, simp[not_forall] at H',
  rcases H' with ⟨s, ⟨⟨w', Hw'_1, Hw'_2⟩, H_a'⟩⟩; intros t Ht; cases Ht;
  rcases Ht with ⟨w, H_w, H_w_eq⟩; subst H_w_eq, tidy
end

lemma standard_basis_reindex {α : Type*} {T : set (set α)} {p_ins p_out : finset α} {H_eq : T = finset.inf p_ins principal_open ∩ finset.inf p_out co_principal_open} {H : p_ins ∩ p_out = ∅} : ⋂₀ finset.to_set (finset.image principal_open p_ins ∪ finset.image co_principal_open p_out) = T :=
begin
  subst H_eq, rw[<-principal_open_finset_eq_inter, <-co_principal_open_finset_eq_inter],
  simp[finset.to_set], ext; split; intro H',
    {rw[set.mem_sInter] at H',

    simp[principal_open_finset, co_principal_open_finset], split,
    intros a Ha, specialize H' (principal_open a), apply H',
    right, use a, from ⟨‹_›, rfl⟩,

    intros a Ha, specialize H' (co_principal_open a), apply H',
    left, use a, from ⟨‹_›, rfl⟩,},

    {rw[set.mem_sInter], intros T hT, simp at hT, cases hT,
    simp[finset.to_set] at H', tidy}
end

lemma is_topological_basis_standard_basis : @is_topological_basis (set α) _ standard_basis :=
begin
  repeat{split},
  {intros t₁ H₁ t₂ H₂ x Hx, cases H₁; cases H₂,
    {rcases H₁ with ⟨p_ins₁, p_out₁, H₁, H₁'⟩, rcases H₂ with ⟨p_ins₂, p_out₂, H₂, H₂'⟩,
      use (finset.inf (p_ins₁ ∪ p_ins₂) principal_open) ∩ (finset.inf (p_out₁ ∪ p_out₂) co_principal_open), split, swap, split,
    split, rw[<-principal_open_finset_eq_inter], unfold principal_open_finset,
    simp, intros a Ha, simp[finset.to_set] at Ha, subst H₁, subst H₂,
    simp at Hx, rcases Hx with ⟨⟨Hx1, Hx2⟩, Hx3, Hx4⟩, cases Ha,
    rw[<-principal_open_finset_eq_inter] at Hx1, apply Hx1, from Ha,
    rw[<-principal_open_finset_eq_inter] at Hx3, apply Hx3, from Ha,

    rw[<-co_principal_open_finset_eq_inter], unfold co_principal_open_finset,
    simp, intros a Ha, simp[finset.to_set] at Ha, subst H₁, subst H₂,
    simp at Hx, rcases Hx with ⟨⟨Hx1, Hx2⟩, Hx3, Hx4⟩, cases Ha,
    rw[<-co_principal_open_finset_eq_inter] at Hx2, apply Hx2, from Ha,
    rw[<-co_principal_open_finset_eq_inter] at Hx4, apply Hx4, from Ha,

    rw[<-principal_open_finset_eq_inter, <-co_principal_open_finset_eq_inter],
    intros a Ha, unfold principal_open_finset co_principal_open_finset at Ha,
    cases Ha with Ha₁ Ha₂, substs H₁ H₂, split,
    rw[<-principal_open_finset_eq_inter, <-co_principal_open_finset_eq_inter],
    split, intros x Hx, apply Ha₁, simp[finset.to_set], left, from Hx,
    intros x Hx, apply Ha₂, simp[finset.to_set], left, from Hx,

    rw[<-principal_open_finset_eq_inter, <-co_principal_open_finset_eq_inter],
    split, intros x Hx, apply Ha₁, simp[finset.to_set], right, from Hx,
    intros x Hx, apply Ha₂, simp[finset.to_set], right, from Hx,

    use (p_ins₁ ∪ p_ins₂), use (p_out₁ ∪ p_out₂), refine ⟨rfl, _⟩,
    simp only [finset.inter_distrib_left, finset.inter_distrib_right],
    ext1, split; intro Ha, swap, cases Ha, simp [H₁', H₂'] at Ha,
    repeat{cases Ha}; exfalso; substs H₁ H₂; cases Hx,
    from ins₁_out₂_disjoint Hx_left Hx_right ‹_› ‹_› Ha_left Ha_right,
    from ins₁_out₂_disjoint Hx_right Hx_left ‹_› ‹_› Ha_right Ha_left
    },
    {replace H₂ := set.mem_singleton_iff.mp H₂, subst H₂, exfalso, simpa using Hx},
    {replace H₁ := set.mem_singleton_iff.mp H₁, subst H₁, exfalso, simpa using Hx},
    {replace H₁ := set.mem_singleton_iff.mp H₁, subst H₁, exfalso, simpa using Hx}
  },
  {ext, split; intros, trivial, rw[set.mem_sUnion], use set.univ,
    use univ_mem_standard_basis},
  {rw[product_topology_generate_from], refine le_antisymm _ _, swap,

    {apply generate_from_mono,
     intros X H_X, rcases H_X with ⟨w, ⟨a, H_w⟩, H_X⟩,
     unfold standard_basis, simp, subst H_w, repeat{cases H_X}, left, refl,
     right, use ∅, use ∅, {simp, refl}, right, use ∅, use {a},
     {/- `tidy` says -/ simp, ext1,   fsplit, work_on_goal 0
     { intros a_1, fsplit, work_on_goal 0 { fsplit },
     fsplit, work_on_goal 0 { assumption },  fsplit },
     intros a_1 a_2, cases a_1, cases a_1_right, solve_by_elim}, right, use {a}, use ∅,
     {/- `tidy` says -/ simp, ext1, fsplit, work_on_goal 0
     { intros a_1, fsplit, work_on_goal 0 { fsplit, work_on_goal 0 { assumption }, fsplit },
     fsplit }, intros a_1, cases a_1, cases a_1_left, assumption}},

  {
  apply le_generate_from_iff_subset_is_open.mpr, intros T hT, unfold standard_basis at hT,
  cases hT with hT h_empty, swap, rw[set.mem_singleton_iff] at h_empty, subst h_empty,
  apply @is_open_empty _ (generate_from _),

  simp, have := is_topological_basis_of_subbasis (product_topology_generate_from), swap, from α,
  rw[<-product_topology_generate_from],
  apply is_open_of_is_topological_basis this, simp,
  rcases hT with ⟨p_ins, p_out, H_eq, H⟩,
  use ((finset.image principal_open p_ins) ∪ (finset.image co_principal_open p_out)).to_set,
  split, split, from finset.finite_to_set _, split,
  apply finset.induction_on p_ins, apply finset.induction_on p_out,
  simp, intros x Hx, cases Hx, intros a A H_a H_A, simp, intros x Hx,
  simp[finset.to_set] at Hx, cases Hx, rw[set.mem_Union], use a, rw[Hx],
  rw[<-neg_principal_open], from co_principal_open_mem_opens_over,
  rw[set.mem_Union], cases Hx with a Hx, use a, rw[<-Hx.right],
  rw[<-neg_principal_open], from co_principal_open_mem_opens_over,
  intros a A H_a H_A, simp, intros x Hx, simp[finset.to_set] at Hx, cases Hx,
  rw[Hx], rw[set.mem_Union], use a, from principal_open_mem_opens_over,
  cases Hx with Hx Hx', rw[set.mem_Union], cases Hx with a Hx,
  use a, rw[<-Hx.right, <-neg_principal_open], from co_principal_open_mem_opens_over,
  cases Hx' with a Hx, rw[set.mem_Union],
  use a, rw[<-Hx.right], from principal_open_mem_opens_over,

  by {apply intersection_standard_basis_nonempty; from ‹_›},

  by {apply standard_basis_reindex; from ‹_›}
}}
end

open cardinal

lemma countable_chain_condition_set {α : Type u} : countable_chain_condition (set α) :=
begin
  apply countable_chain_condition_pi, intros s hs,
  apply countable_chain_condition_of_countable, apply le_of_lt,
  convert @power_lt_omega (mk (ulift Prop)) (mk s) _ _ using 1,
  { refine quotient.sound ⟨equiv.arrow_congr (equiv.refl _) equiv.ulift.symm⟩ },
  { rw [prop_eq_two], convert cardinal.nat_lt_omega 2, rw [nat.cast_bit0, nat.cast_one] },
  rwa lt_omega_iff_finite
end

end cantor_space
end cantor_space


/-
Copyright (c) 2019 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import category_theory.limits.shapes.finite_limits
import order.complete_lattice

universes u

open category_theory
open category_theory.limits

namespace category_theory.limits.complete_lattice

variables {α : Type u}

@[priority 100] -- see Note [lower instance priority]
instance has_finite_limits_of_semilattice_inf_top [semilattice_inf_top α] :
  has_finite_limits α :=
⟨λ J 𝒥₁ 𝒥₂, by exactI
  { has_limit := λ F, has_limit.mk
    { cone :=
      { X := finset.univ.inf F.obj,
        π := { app := λ j, hom_of_le (finset.inf_le (fintype.complete _)) } },
      is_limit := { lift := λ s, hom_of_le (finset.le_inf (λ j _, (s.π.app j).down.down)) } } }⟩

@[priority 100] -- see Note [lower instance priority]
instance has_finite_colimits_of_semilattice_sup_bot [semilattice_sup_bot α] :
  has_finite_colimits α :=
⟨λ J 𝒥₁ 𝒥₂, by exactI
  { has_colimit := λ F, has_colimit.mk
    { cocone :=
      { X := finset.univ.sup F.obj,
        ι := { app := λ i, hom_of_le (finset.le_sup (fintype.complete _)) } },
      is_colimit := { desc := λ s, hom_of_le (finset.sup_le (λ j _, (s.ι.app j).down.down)) } } }⟩

variables {J : Type u} [small_category J]

/--
The limit cone over any functor into a complete lattice.
-/
def limit_cone [complete_lattice α] (F : J ⥤ α) : limit_cone F :=
{ cone :=
  { X := infi F.obj,
    π :=
    { app := λ j, hom_of_le (complete_lattice.Inf_le _ _ (set.mem_range_self _)) } },
  is_limit :=
  { lift := λ s, hom_of_le (complete_lattice.le_Inf _ _
    begin rintros _ ⟨j, rfl⟩, exact le_of_hom (s.π.app j), end) } }

/--
The colimit cocone over any functor into a complete lattice.
-/
def colimit_cocone [complete_lattice α] (F : J ⥤ α) : colimit_cocone F :=
{ cocone :=
  { X := supr F.obj,
    ι :=
    { app := λ j, hom_of_le (complete_lattice.le_Sup _ _ (set.mem_range_self _)) } },
  is_colimit :=
  { desc := λ s, hom_of_le (complete_lattice.Sup_le _ _
    begin rintros _ ⟨j, rfl⟩, exact le_of_hom (s.ι.app j), end) } }

-- It would be nice to only use the `Inf` half of the complete lattice, but
-- this seems not to have been described separately.
@[priority 100] -- see Note [lower instance priority]
instance has_limits_of_complete_lattice [complete_lattice α] : has_limits α :=
{ has_limits_of_shape := λ J 𝒥, by exactI
  { has_limit := λ F, has_limit.mk (limit_cone F) } }

@[priority 100] -- see Note [lower instance priority]
instance has_colimits_of_complete_lattice [complete_lattice α] : has_colimits α :=
{ has_colimits_of_shape := λ J 𝒥, by exactI
  { has_colimit := λ F, has_colimit.mk (colimit_cocone F) } }

noncomputable theory
variables [complete_lattice α] (F : J ⥤ α)

/--
The limit of a functor into a complete lattice is the infimum of the objects in the image.
-/
def limit_iso_infi : limit F ≅ infi F.obj :=
is_limit.cone_point_unique_up_to_iso (limit.is_limit F) (limit_cone F).is_limit

@[simp] lemma limit_iso_infi_hom (j : J) :
  (limit_iso_infi F).hom ≫ hom_of_le (infi_le _ j) = limit.π F j := by tidy
@[simp] lemma limit_iso_infi_inv (j : J) :
  (limit_iso_infi F).inv ≫ limit.π F j = hom_of_le (infi_le _ j) := rfl

/--
The colimit of a functor into a complete lattice is the supremum of the objects in the image.
-/
def colimit_iso_supr : colimit F ≅ supr F.obj :=
is_colimit.cocone_point_unique_up_to_iso (colimit.is_colimit F) (colimit_cocone F).is_colimit

@[simp] lemma colimit_iso_supr_hom (j : J) :
  colimit.ι F j ≫ (colimit_iso_supr F).hom = hom_of_le (le_supr _ j) := rfl
@[simp] lemma colimit_iso_supr_inv (j : J) :
  hom_of_le (le_supr _ j) ≫ (colimit_iso_supr F).inv = colimit.ι F j := by tidy

end category_theory.limits.complete_lattice


/-
Copyright (c) 2019 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import category_theory.limits.shapes.finite_limits
import category_theory.limits.shapes.binary_products
import category_theory.limits.shapes.terminal

universes v u

open category_theory
namespace category_theory.limits

variables (C : Type u) [category.{v} C]

/--
A category has finite products if there is a chosen limit for every diagram
with shape `discrete J`, where we have `[decidable_eq J]` and `[fintype J]`.
-/
-- We can't simply make this an abbreviation, as we do with other `has_Xs` limits typeclasses,
-- because of https://github.com/leanprover-community/lean/issues/429
class has_finite_products : Prop :=
(out (J : Type v) [decidable_eq J] [fintype J] : has_limits_of_shape (discrete J) C)

instance has_limits_of_shape_discrete
  (J : Type v) [fintype J] [has_finite_products C] :
  has_limits_of_shape (discrete J) C :=
by { haveI := @has_finite_products.out C _ _ J (classical.dec_eq _), apply_instance }

/-- If `C` has finite limits then it has finite products. -/
lemma has_finite_products_of_has_finite_limits [has_finite_limits C] : has_finite_products C :=
⟨λ J 𝒥₁ 𝒥₂, by { resetI, apply_instance }⟩

/--
If a category has all products then in particular it has finite products.
-/
lemma has_finite_products_of_has_products [has_products C] : has_finite_products C :=
⟨by apply_instance⟩

/--
A category has finite coproducts if there is a chosen colimit for every diagram
with shape `discrete J`, where we have `[decidable_eq J]` and `[fintype J]`.
-/
class has_finite_coproducts : Prop :=
(out (J : Type v) [decidable_eq J] [fintype J] : has_colimits_of_shape (discrete J) C)

attribute [class] has_finite_coproducts

instance has_colimits_of_shape_discrete
  (J : Type v) [fintype J] [has_finite_coproducts C] :
  has_colimits_of_shape (discrete J) C :=
by { haveI := @has_finite_coproducts.out C _ _ J (classical.dec_eq _), apply_instance }

/-- If `C` has finite colimits then it has finite coproducts. -/
lemma has_finite_coproducts_of_has_finite_colimits [has_finite_colimits C] :
  has_finite_coproducts C :=
⟨λ J 𝒥₁ 𝒥₂, by { resetI, apply_instance }⟩

/--
If a category has all coproducts then in particular it has finite coproducts.
-/
lemma has_finite_coproducts_of_has_coproducts [has_coproducts C] : has_finite_coproducts C :=
⟨by apply_instance⟩

end category_theory.limits


/-
Copyright (c) 2020 Kenny Lau. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kenny Lau, Ken Lee, Chris Hughes
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.tactic.ring
import Mathlib.algebra.big_operators.basic
import Mathlib.data.fintype.basic
import Mathlib.data.int.gcd
import Mathlib.data.set.disjointed
import Mathlib.PostPort

universes u v

namespace Mathlib

/-!
# Coprime elements of a ring

## Main definitions

* `is_coprime x y`: that `x` and `y` are coprime, defined to be the existence of `a` and `b` such
that `a * x + b * y = 1`. Note that elements with no common divisors are not necessarily coprime,
e.g., the multivariate polynomials `x₁` and `x₂` are not coprime.

-/

/-- The proposition that `x` and `y` are coprime, defined to be the existence of `a` and `b` such
that `a * x + b * y = 1`. Note that elements with no common divisors are not necessarily coprime,
e.g., the multivariate polynomials `x₁` and `x₂` are not coprime. -/
@[simp] def is_coprime {R : Type u} [comm_semiring R] (x : R) (y : R) :=
  ∃ (a : R), ∃ (b : R), a * x + b * y = 1

theorem nat.is_coprime_iff_coprime {m : ℕ} {n : ℕ} : is_coprime ↑m ↑n ↔ nat.coprime m n := sorry

theorem is_coprime.symm {R : Type u} [comm_semiring R] {x : R} {y : R} (H : is_coprime x y) :
    is_coprime y x :=
  sorry

theorem is_coprime_comm {R : Type u} [comm_semiring R] {x : R} {y : R} :
    is_coprime x y ↔ is_coprime y x :=
  { mp := is_coprime.symm, mpr := is_coprime.symm }

theorem is_coprime_self {R : Type u} [comm_semiring R] {x : R} : is_coprime x x ↔ is_unit x := sorry

theorem is_coprime_zero_left {R : Type u} [comm_semiring R] {x : R} : is_coprime 0 x ↔ is_unit x :=
  sorry

theorem is_coprime_zero_right {R : Type u} [comm_semiring R] {x : R} : is_coprime x 0 ↔ is_unit x :=
  iff.trans is_coprime_comm is_coprime_zero_left

theorem is_coprime_one_left {R : Type u} [comm_semiring R] {x : R} : is_coprime 1 x := sorry

theorem is_coprime_one_right {R : Type u} [comm_semiring R] {x : R} : is_coprime x 1 := sorry

theorem is_coprime.dvd_of_dvd_mul_right {R : Type u} [comm_semiring R] {x : R} {y : R} {z : R}
    (H1 : is_coprime x z) (H2 : x ∣ y * z) : x ∣ y :=
  sorry

theorem is_coprime.dvd_of_dvd_mul_left {R : Type u} [comm_semiring R] {x : R} {y : R} {z : R}
    (H1 : is_coprime x y) (H2 : x ∣ y * z) : x ∣ z :=
  sorry

theorem is_coprime.mul_left {R : Type u} [comm_semiring R] {x : R} {y : R} {z : R}
    (H1 : is_coprime x z) (H2 : is_coprime y z) : is_coprime (x * y) z :=
  sorry

theorem is_coprime.mul_right {R : Type u} [comm_semiring R] {x : R} {y : R} {z : R}
    (H1 : is_coprime x y) (H2 : is_coprime x z) : is_coprime x (y * z) :=
  eq.mpr (id (Eq._oldrec (Eq.refl (is_coprime x (y * z))) (propext is_coprime_comm)))
    (is_coprime.mul_left
      (eq.mp (Eq._oldrec (Eq.refl (is_coprime x y)) (propext is_coprime_comm)) H1)
      (eq.mp (Eq._oldrec (Eq.refl (is_coprime x z)) (propext is_coprime_comm)) H2))

theorem is_coprime.prod_left {R : Type u} [comm_semiring R] {x : R} {I : Type v} {s : I → R}
    {t : finset I} :
    (∀ (i : I), i ∈ t → is_coprime (s i) x) → is_coprime (finset.prod t fun (i : I) => s i) x :=
  sorry

theorem is_coprime.prod_right {R : Type u} [comm_semiring R] {x : R} {I : Type v} {s : I → R}
    {t : finset I} :
    (∀ (i : I), i ∈ t → is_coprime x (s i)) → is_coprime x (finset.prod t fun (i : I) => s i) :=
  sorry

theorem is_coprime.mul_dvd {R : Type u} [comm_semiring R] {x : R} {y : R} {z : R}
    (H : is_coprime x y) (H1 : x ∣ z) (H2 : y ∣ z) : x * y ∣ z :=
  sorry

theorem finset.prod_dvd_of_coprime {R : Type u} [comm_semiring R] {z : R} {I : Type v} {s : I → R}
    {t : finset I} (Hs : set.pairwise_on (↑t) (is_coprime on s))
    (Hs1 : ∀ (i : I), i ∈ t → s i ∣ z) : (finset.prod t fun (x : I) => s x) ∣ z :=
  sorry

theorem fintype.prod_dvd_of_coprime {R : Type u} [comm_semiring R] {z : R} {I : Type v} {s : I → R}
    [fintype I] (Hs : pairwise (is_coprime on s)) (Hs1 : ∀ (i : I), s i ∣ z) :
    (finset.prod finset.univ fun (x : I) => s x) ∣ z :=
  finset.prod_dvd_of_coprime (pairwise.pairwise_on Hs ↑finset.univ)
    fun (i : I) (_x : i ∈ finset.univ) => Hs1 i

theorem is_coprime.of_mul_left_left {R : Type u} [comm_semiring R] {x : R} {y : R} {z : R}
    (H : is_coprime (x * y) z) : is_coprime x z :=
  sorry

theorem is_coprime.of_mul_left_right {R : Type u} [comm_semiring R] {x : R} {y : R} {z : R}
    (H : is_coprime (x * y) z) : is_coprime y z :=
  is_coprime.of_mul_left_left (eq.mp (Eq._oldrec (Eq.refl (is_coprime (x * y) z)) (mul_comm x y)) H)

theorem is_coprime.of_mul_right_left {R : Type u} [comm_semiring R] {x : R} {y : R} {z : R}
    (H : is_coprime x (y * z)) : is_coprime x y :=
  eq.mpr (id (Eq._oldrec (Eq.refl (is_coprime x y)) (propext is_coprime_comm)))
    (is_coprime.of_mul_left_left
      (eq.mp (Eq._oldrec (Eq.refl (is_coprime x (y * z))) (propext is_coprime_comm)) H))

theorem is_coprime.of_mul_right_right {R : Type u} [comm_semiring R] {x : R} {y : R} {z : R}
    (H : is_coprime x (y * z)) : is_coprime x z :=
  is_coprime.of_mul_right_left
    (eq.mp (Eq._oldrec (Eq.refl (is_coprime x (y * z))) (mul_comm y z)) H)

theorem is_coprime.mul_left_iff {R : Type u} [comm_semiring R] {x : R} {y : R} {z : R} :
    is_coprime (x * y) z ↔ is_coprime x z ∧ is_coprime y z :=
  sorry

theorem is_coprime.mul_right_iff {R : Type u} [comm_semiring R] {x : R} {y : R} {z : R} :
    is_coprime x (y * z) ↔ is_coprime x y ∧ is_coprime x z :=
  sorry

theorem is_coprime.prod_left_iff {R : Type u} [comm_semiring R] {x : R} {I : Type v} {s : I → R}
    {t : finset I} :
    is_coprime (finset.prod t fun (i : I) => s i) x ↔ ∀ (i : I), i ∈ t → is_coprime (s i) x :=
  sorry

theorem is_coprime.prod_right_iff {R : Type u} [comm_semiring R] {x : R} {I : Type v} {s : I → R}
    {t : finset I} :
    is_coprime x (finset.prod t fun (i : I) => s i) ↔ ∀ (i : I), i ∈ t → is_coprime x (s i) :=
  sorry

theorem is_coprime.of_prod_left {R : Type u} [comm_semiring R] {x : R} {I : Type v} {s : I → R}
    {t : finset I} (H1 : is_coprime (finset.prod t fun (i : I) => s i) x) (i : I) (hit : i ∈ t) :
    is_coprime (s i) x :=
  iff.mp is_coprime.prod_left_iff H1 i hit

theorem is_coprime.of_prod_right {R : Type u} [comm_semiring R] {x : R} {I : Type v} {s : I → R}
    {t : finset I} (H1 : is_coprime x (finset.prod t fun (i : I) => s i)) (i : I) (hit : i ∈ t) :
    is_coprime x (s i) :=
  iff.mp is_coprime.prod_right_iff H1 i hit

theorem is_coprime.pow_left {R : Type u} [comm_semiring R] {x : R} {y : R} {m : ℕ}
    (H : is_coprime x y) : is_coprime (x ^ m) y :=
  eq.mpr (id (Eq._oldrec (Eq.refl (is_coprime (x ^ m) y)) (Eq.symm (finset.card_range m))))
    (eq.mpr
      (id
        (Eq._oldrec (Eq.refl (is_coprime (x ^ finset.card (finset.range m)) y))
          (Eq.symm (finset.prod_const x))))
      (is_coprime.prod_left fun (_x : ℕ) (_x : _x ∈ finset.range m) => H))

theorem is_coprime.pow_right {R : Type u} [comm_semiring R] {x : R} {y : R} {n : ℕ}
    (H : is_coprime x y) : is_coprime x (y ^ n) :=
  eq.mpr (id (Eq._oldrec (Eq.refl (is_coprime x (y ^ n))) (Eq.symm (finset.card_range n))))
    (eq.mpr
      (id
        (Eq._oldrec (Eq.refl (is_coprime x (y ^ finset.card (finset.range n))))
          (Eq.symm (finset.prod_const y))))
      (is_coprime.prod_right fun (_x : ℕ) (_x : _x ∈ finset.range n) => H))

theorem is_coprime.pow {R : Type u} [comm_semiring R] {x : R} {y : R} {m : ℕ} {n : ℕ}
    (H : is_coprime x y) : is_coprime (x ^ m) (y ^ n) :=
  is_coprime.pow_right (is_coprime.pow_left H)

theorem is_coprime.is_unit_of_dvd {R : Type u} [comm_semiring R] {x : R} {y : R}
    (H : is_coprime x y) (d : x ∣ y) : is_unit x :=
  sorry

theorem is_coprime.map {R : Type u} [comm_semiring R] {x : R} {y : R} (H : is_coprime x y)
    {S : Type v} [comm_semiring S] (f : R →+* S) : is_coprime (coe_fn f x) (coe_fn f y) :=
  sorry

theorem is_coprime.of_add_mul_left_left {R : Type u} [comm_semiring R] {x : R} {y : R} {z : R}
    (h : is_coprime (x + y * z) y) : is_coprime x y :=
  sorry

theorem is_coprime.of_add_mul_right_left {R : Type u} [comm_semiring R] {x : R} {y : R} {z : R}
    (h : is_coprime (x + z * y) y) : is_coprime x y :=
  is_coprime.of_add_mul_left_left
    (eq.mp (Eq._oldrec (Eq.refl (is_coprime (x + z * y) y)) (mul_comm z y)) h)

theorem is_coprime.of_add_mul_left_right {R : Type u} [comm_semiring R] {x : R} {y : R} {z : R}
    (h : is_coprime x (y + x * z)) : is_coprime x y :=
  eq.mpr (id (Eq._oldrec (Eq.refl (is_coprime x y)) (propext is_coprime_comm)))
    (is_coprime.of_add_mul_left_left
      (eq.mp (Eq._oldrec (Eq.refl (is_coprime x (y + x * z))) (propext is_coprime_comm)) h))

theorem is_coprime.of_add_mul_right_right {R : Type u} [comm_semiring R] {x : R} {y : R} {z : R}
    (h : is_coprime x (y + z * x)) : is_coprime x y :=
  is_coprime.of_add_mul_left_right
    (eq.mp (Eq._oldrec (Eq.refl (is_coprime x (y + z * x))) (mul_comm z x)) h)

theorem is_coprime.of_mul_add_left_left {R : Type u} [comm_semiring R] {x : R} {y : R} {z : R}
    (h : is_coprime (y * z + x) y) : is_coprime x y :=
  is_coprime.of_add_mul_left_left
    (eq.mp (Eq._oldrec (Eq.refl (is_coprime (y * z + x) y)) (add_comm (y * z) x)) h)

theorem is_coprime.of_mul_add_right_left {R : Type u} [comm_semiring R] {x : R} {y : R} {z : R}
    (h : is_coprime (z * y + x) y) : is_coprime x y :=
  is_coprime.of_add_mul_right_left
    (eq.mp (Eq._oldrec (Eq.refl (is_coprime (z * y + x) y)) (add_comm (z * y) x)) h)

theorem is_coprime.of_mul_add_left_right {R : Type u} [comm_semiring R] {x : R} {y : R} {z : R}
    (h : is_coprime x (x * z + y)) : is_coprime x y :=
  is_coprime.of_add_mul_left_right
    (eq.mp (Eq._oldrec (Eq.refl (is_coprime x (x * z + y))) (add_comm (x * z) y)) h)

theorem is_coprime.of_mul_add_right_right {R : Type u} [comm_semiring R] {x : R} {y : R} {z : R}
    (h : is_coprime x (z * x + y)) : is_coprime x y :=
  is_coprime.of_add_mul_right_right
    (eq.mp (Eq._oldrec (Eq.refl (is_coprime x (z * x + y))) (add_comm (z * x) y)) h)

namespace is_coprime

theorem add_mul_left_left {R : Type u} [comm_ring R] {x : R} {y : R} (h : is_coprime x y) (z : R) :
    is_coprime (x + y * z) y :=
  sorry

theorem add_mul_right_left {R : Type u} [comm_ring R] {x : R} {y : R} (h : is_coprime x y) (z : R) :
    is_coprime (x + z * y) y :=
  eq.mpr (id (Eq._oldrec (Eq.refl (is_coprime (x + z * y) y)) (mul_comm z y)))
    (add_mul_left_left h z)

theorem add_mul_left_right {R : Type u} [comm_ring R] {x : R} {y : R} (h : is_coprime x y) (z : R) :
    is_coprime x (y + x * z) :=
  eq.mpr (id (Eq._oldrec (Eq.refl (is_coprime x (y + x * z))) (propext is_coprime_comm)))
    (add_mul_left_left (symm h) z)

theorem add_mul_right_right {R : Type u} [comm_ring R] {x : R} {y : R} (h : is_coprime x y)
    (z : R) : is_coprime x (y + z * x) :=
  eq.mpr (id (Eq._oldrec (Eq.refl (is_coprime x (y + z * x))) (propext is_coprime_comm)))
    (add_mul_right_left (symm h) z)

theorem mul_add_left_left {R : Type u} [comm_ring R] {x : R} {y : R} (h : is_coprime x y) (z : R) :
    is_coprime (y * z + x) y :=
  eq.mpr (id (Eq._oldrec (Eq.refl (is_coprime (y * z + x) y)) (add_comm (y * z) x)))
    (add_mul_left_left h z)

theorem mul_add_right_left {R : Type u} [comm_ring R] {x : R} {y : R} (h : is_coprime x y) (z : R) :
    is_coprime (z * y + x) y :=
  eq.mpr (id (Eq._oldrec (Eq.refl (is_coprime (z * y + x) y)) (add_comm (z * y) x)))
    (add_mul_right_left h z)

theorem mul_add_left_right {R : Type u} [comm_ring R] {x : R} {y : R} (h : is_coprime x y) (z : R) :
    is_coprime x (x * z + y) :=
  eq.mpr (id (Eq._oldrec (Eq.refl (is_coprime x (x * z + y))) (add_comm (x * z) y)))
    (add_mul_left_right h z)

theorem mul_add_right_right {R : Type u} [comm_ring R] {x : R} {y : R} (h : is_coprime x y)
    (z : R) : is_coprime x (z * x + y) :=
  eq.mpr (id (Eq._oldrec (Eq.refl (is_coprime x (z * x + y))) (add_comm (z * x) y)))
    (add_mul_right_right h z)

theorem add_mul_left_left_iff {R : Type u} [comm_ring R] {x : R} {y : R} {z : R} :
    is_coprime (x + y * z) y ↔ is_coprime x y :=
  { mp := of_add_mul_left_left, mpr := fun (h : is_coprime x y) => add_mul_left_left h z }

theorem add_mul_right_left_iff {R : Type u} [comm_ring R] {x : R} {y : R} {z : R} :
    is_coprime (x + z * y) y ↔ is_coprime x y :=
  { mp := of_add_mul_right_left, mpr := fun (h : is_coprime x y) => add_mul_right_left h z }

theorem add_mul_left_right_iff {R : Type u} [comm_ring R] {x : R} {y : R} {z : R} :
    is_coprime x (y + x * z) ↔ is_coprime x y :=
  { mp := of_add_mul_left_right, mpr := fun (h : is_coprime x y) => add_mul_left_right h z }

theorem add_mul_right_right_iff {R : Type u} [comm_ring R] {x : R} {y : R} {z : R} :
    is_coprime x (y + z * x) ↔ is_coprime x y :=
  { mp := of_add_mul_right_right, mpr := fun (h : is_coprime x y) => add_mul_right_right h z }

theorem mul_add_left_left_iff {R : Type u} [comm_ring R] {x : R} {y : R} {z : R} :
    is_coprime (y * z + x) y ↔ is_coprime x y :=
  { mp := of_mul_add_left_left, mpr := fun (h : is_coprime x y) => mul_add_left_left h z }

theorem mul_add_right_left_iff {R : Type u} [comm_ring R] {x : R} {y : R} {z : R} :
    is_coprime (z * y + x) y ↔ is_coprime x y :=
  { mp := of_mul_add_right_left, mpr := fun (h : is_coprime x y) => mul_add_right_left h z }

theorem mul_add_left_right_iff {R : Type u} [comm_ring R] {x : R} {y : R} {z : R} :
    is_coprime x (x * z + y) ↔ is_coprime x y :=
  { mp := of_mul_add_left_right, mpr := fun (h : is_coprime x y) => mul_add_left_right h z }

theorem mul_add_right_right_iff {R : Type u} [comm_ring R] {x : R} {y : R} {z : R} :
    is_coprime x (z * x + y) ↔ is_coprime x y :=
  { mp := of_mul_add_right_right, mpr := fun (h : is_coprime x y) => mul_add_right_right h z }

end Mathlib