import data.list.func
import .list2d
import .boolset2d
import .component1d
import .direction

--         _                  _ _   _
--    __ _| | __ _  ___  _ __(_) |_| |__  _ __ ___
--   / _` | |/ _` |/ _ \| '__| | __| '_ \| '_ ` _ \
--  | (_| | | (_| | (_) | |  | | |_| | | | | | | | |
--   \__,_|_|\__, |\___/|_|  |_|\__|_| |_|_| |_| |_|
--           |___/

def component_extend_rows (avail ini : bset2d) : bset2d
  := list.func.pointwise component1d avail ini
def component_extend_cols (avail ini : bset2d) : bset2d
  := list2d.transpose (component_extend_rows (list2d.transpose avail) (list2d.transpose ini))
def component_step (avail : bset2d) : bset2d → bset2d
  := (component_extend_cols avail) ∘ (component_extend_rows avail)
def comp_measure (avail ini : bset2d) : ℕ
  := avail.count - ini.count

def component2d_aux : ℕ → bset2d → bset2d → bset2d
| 0 _ cur := cur
| (b0+1) avail cur := let next := (component_step avail cur) in
  if comp_measure avail next < comp_measure avail cur
  then component2d_aux b0 avail next
  else cur

def component2d (avail ini : bset2d) : bset2d :=
  let ini_pure := list2d.pointwise2d band avail ini in
  component2d_aux (comp_measure avail ini_pure) avail ini_pure

--   _           _            _   _
--  (_)_ __   __| |_   _  ___| |_(_)_   _____
--  | | '_ \ / _` | | | |/ __| __| \ \ / / _ \
--  | | | | | (_| | |_| | (__| |_| |\ V /  __/
--  |_|_| |_|\__,_|\__,_|\___|\__|_| \_/ \___|
--

inductive in_component2d (avail ini : bset2d) : ℕ×ℕ → Prop
| triv (xy : ℕ×ℕ) (Ha : xy ∈ avail) (Hi : xy ∈ ini)
  : in_component2d xy
| move (d : direction) (xy : ℕ×ℕ) (Ha : xy ∈ avail)
  (Hc : in_component2d (d.shift xy))
  : in_component2d xy

theorem in_component2d_trans (avail ini ini2 : bset2d) :
  (∀ xy : ℕ×ℕ, xy ∈ avail → xy ∈ ini2
    → in_component2d avail ini xy) →
  ∀ xy : ℕ×ℕ, in_component2d avail ini2 xy → in_component2d avail ini xy :=
begin
  intros H1 xy H2, induction H2 with xy Ha Hi d xy Ha Hc IH,
  exact H1 xy Ha Hi,
  exact in_component2d.move d _ Ha IH,
end
theorem in_component2d_transpose : ∀ (avail ini : bset2d) (xy : ℕ×ℕ),
  in_component2d avail.transpose ini.transpose xy →
  in_component2d avail ini (prod.swap xy) :=
begin
  introv H,
  induction H with xy Ha Hi d xy Ha Hc IH, {
    unfold has_mem.mem at Ha Hi,
    rw list2d.get2d_transpose at *,
    exact in_component2d.triv _ Ha Hi,
  }, {
    unfold has_mem.mem at Ha Hc,
    rw list2d.get2d_transpose at Ha,
    apply in_component2d.move d.transpose, exact Ha,
    simp [direction.transpose_shift], exact IH
  }
end
theorem in_component2d_subset_avail : ∀ (avail ini : bset2d) (xy : ℕ×ℕ),
  in_component2d avail ini xy → xy ∈ avail :=
begin
  introv H, cases H with xy Ha Hi d xy Ha Hi,
  exact Ha, exact Ha,
end
theorem in_component2d_of_supset : ∀ (avail ini ini2 : bset2d),
  ini2 ⊆ ini →
  ∀ xy : ℕ×ℕ, in_component2d avail ini2 xy →
  in_component2d avail ini xy :=
begin
  introv Hsub Ha, refine in_component2d_trans avail ini ini2 _ xy Ha,
  clear Ha xy, introv Ha Hi,
  exact in_component2d.triv xy Ha (Hsub xy Hi),
end

--             _                 _
--    _____  _| |_ ___ _ __   __| |    _ __ _____      _____
--   / _ \ \/ / __/ _ \ '_ \ / _` |   | '__/ _ \ \ /\ / / __|
--  |  __/>  <| ||  __/ | | | (_| |   | | | (_) \ V  V /\__ \
--   \___/_/\_\\__\___|_| |_|\__,_|___|_|  \___/ \_/\_/ |___/
--                               |_____|

theorem component_extend_rows_valid : ∀ (avail ini : bset2d) (xy : ℕ×ℕ),
  xy ∈ (component_extend_rows avail ini) →
  in_component2d avail ini xy
:=
begin
  unfold component_extend_rows, introv H,
  cases xy with x y, unfold has_mem.mem at H, unfold list2d.get2d at H,
  rw list.func.get_pointwise at H,
  have H1 := component1d_valid _ _ _ H, clear H,
  induction H1 with x Ha Hi x Ha Hc IH x Ha Hc IH,
  { apply in_component2d.triv (x,y), exact Ha, exact Hi, },
  { apply in_component2d.move direction.right, exact Ha, exact IH, },
  { apply in_component2d.move direction.left, exact Ha, exact IH, },
  simp [default, component1d],
end
theorem component_extend_rows_subset_avail
  : ∀ (avail ini : bset2d), (component_extend_rows avail ini) ⊆ avail :=
begin
  intros avail ini xy, cases xy with x y,
  unfold has_mem.mem, unfold list2d.get2d,
  unfold component_extend_rows, rw list.func.get_pointwise,
  exact component1d_subset_avail _ _ _,
  simp! [default, component1d],
end
theorem component_extend_rows_supset
  : ∀ (avail ini : bset2d), ini ⊆ avail →
  ini ⊆ (component_extend_rows avail ini) :=
begin
  intros avail ini H xy, cases xy with x y,
  unfold has_mem.mem, unfold list2d.get2d,
  unfold component_extend_rows, rw list.func.get_pointwise,
  intro H2, exact component1d_supset _ _ _ (H (x,y) H2) H2,
  simp! [default, component1d],
end

theorem component_extend_rows_works {avail ini : bset2d} {xy : ℕ×ℕ}
  : ∀ (d : direction),
  xy ∈ avail → (d.shift xy) ∈ avail → (d.shift xy) ∈ ini →
  (d = direction.left ∨ d = direction.right) →
  xy ∈ (component_extend_rows avail ini) :=
begin
  introv Ha Hda Hdi Hd, cases xy with x y,
  unfold has_mem.mem, unfold list2d.get2d,
  unfold component_extend_rows, rw list.func.get_pointwise,
  cases Hd, {
    simp [Hd, direction.shift, list2d.get2d] at *,
    cases x, { exact component1d_supset _ _ _ Ha Hdi, },
    simp at Hda Hdi, rw (component1d_succ_eq _ _ x Hda Ha),
    exact component1d_supset _ _ _ Hda Hdi,
  }, {
    simp [Hd, direction.shift, list2d.get2d] at *,
    rw ←(component1d_succ_eq _ _ x Ha Hda),
    exact component1d_supset _ _ _ Hda Hdi,
  },
  simp! [default, component1d],
end

--             _                 _              _
--    _____  _| |_ ___ _ __   __| |    ___ ___ | |___
--   / _ \ \/ / __/ _ \ '_ \ / _` |   / __/ _ \| / __|
--  |  __/>  <| ||  __/ | | | (_| |  | (_| (_) | \__ \
--   \___/_/\_\\__\___|_| |_|\__,_|___\___\___/|_|___/
--                               |_____|

theorem component_extend_cols_valid : ∀ (avail ini : bset2d) (xy : ℕ×ℕ),
  xy ∈ (component_extend_cols avail ini) →
  in_component2d avail ini xy
:=
begin
  unfold component_extend_cols, unfold has_mem.mem, introv,
  rw list2d.get2d_transpose, introv H,
  have H := component_extend_rows_valid _ _ _ H,
  have H := in_component2d_transpose _ _ _ H,
  simp at H, exact H,
end
theorem component_extend_cols_subset_avail
  : ∀ (avail ini : bset2d), (component_extend_cols avail ini) ⊆ avail :=
begin
  intros avail ini xy H, unfold has_mem.mem at H,
  unfold component_extend_cols at H, rw list2d.get2d_transpose at H,
  have H := component_extend_rows_subset_avail _ _ _ H,
  unfold has_mem.mem at H,
  rw list2d.get2d_transpose at H, simp at H, exact H,
end
theorem component_extend_cols_supset
  : ∀ (avail ini : bset2d), ini ⊆ avail →
  ini ⊆ (component_extend_cols avail ini) :=
begin
  intros avail ini H1 xy H2, unfold component_extend_cols,
  unfold has_mem.mem,
  rw list2d.get2d_transpose, apply component_extend_rows_supset, {
    intro xy, unfold has_mem.mem,
    simp [list2d.get2d_transpose], apply H1,
  },
  unfold has_mem.mem,
  rw list2d.get2d_transpose, simp, exact H2,
end

theorem component_extend_cols_works {avail ini : bset2d} {xy : ℕ×ℕ}
  : ∀ (d : direction),
  xy ∈ avail → (d.shift xy) ∈ avail → (d.shift xy) ∈ ini →
  (d = direction.up ∨ d = direction.down) →
  xy ∈ (component_extend_cols avail ini) :=
begin
  introv Ha Hda Hdi Hd,
  unfold component_extend_cols, unfold has_mem.mem, cases xy with x y, simp,
  apply component_extend_rows_works d.transpose,
  { simp [has_mem.mem], exact Ha },
  { simp [has_mem.mem, direction.transpose_shift], exact Hda },
  { simp [has_mem.mem, direction.transpose_shift], exact Hdi },
  { cases Hd, rw Hd, left, refl, rw Hd, right, refl, },
end

--                                    _
--    ___ ___  _ __ ___  _ __     ___| |_ ___ _ __
--   / __/ _ \| '_ ` _ \| '_ \   / __| __/ _ \ '_ \
--  | (_| (_) | | | | | | |_) |  \__ \ ||  __/ |_) |
--   \___\___/|_| |_| |_| .__/___|___/\__\___| .__/
--                      |_| |_____|          |_|

theorem component_step_valid : ∀ (avail ini : bset2d) (xy : ℕ×ℕ),
  xy ∈ (component_step avail ini) →
  in_component2d avail ini xy
:=
begin
  unfold component_step, simp, introv H,
  apply in_component2d_trans _ _ (component_extend_rows avail ini), {
    clear H xy, intros xy H1 H2,
    exact component_extend_rows_valid _ _ _ H2,
  },
  { exact component_extend_cols_valid _ _ _ H, },
end
theorem component_step_subset_avail
  : ∀ (avail ini : bset2d), (component_step avail ini) ⊆ avail :=
begin
  intros, unfold component_step, simp,
  apply component_extend_cols_subset_avail,
end
theorem component_step_supset
  : ∀ (avail ini : bset2d), ini ⊆ avail →
  ini ⊆ (component_step avail ini) :=
begin
  introv H, unfold component_step, simp,
  apply @bset2d.subset.trans _ (component_extend_rows avail ini),
  exact component_extend_rows_supset _ _ H,
  apply component_extend_cols_supset,
  exact component_extend_rows_subset_avail _ _,
end

theorem component_step_complete_of_nlt_measure
  : ∀ (avail ini : bset2d),
  ini ⊆ avail →
  (¬ comp_measure avail (component_step avail ini) < comp_measure avail ini) →
  ∀ xy : ℕ×ℕ, in_component2d avail ini xy →
  xy ∈ ini
:=
begin
  introv Hia_sub Hm_nlt Hin,
  have Hsub : (component_step avail ini) ⊆ ini, {
    clear Hin xy,
    have Hm_ge : comp_measure avail (component_step avail ini) ≥ comp_measure avail ini
      := not_lt.mp Hm_nlt, clear Hm_nlt,
    unfold comp_measure at Hm_ge,
    have Hca_le : (component_step avail ini).count ≤ avail.count
      := bset2d.count_le_of_subset (component_step avail ini) avail
        (component_step_subset_avail avail _),
    have Hci_le : (component_step avail ini).count ≤ ini.count
      := (nat.sub_le_sub_left_iff Hca_le).mp Hm_ge,
    have Hic_sub : ini ⊆ (component_step avail ini)
      := component_step_supset avail ini Hia_sub,
    have Hic_le : ini.count ≤ (component_step avail ini).count
      := bset2d.count_le_of_subset ini _ Hic_sub,
    have Hic_eq : ini.count = (component_step avail ini).count
      := le_antisymm Hic_le Hci_le,
    exact bset2d.subset_eq_of_count_eq ini (component_step avail ini) Hic_sub Hic_eq,
  },
  induction Hin with xy Ha Hi d xy Ha Hc IH, { exact Hi, }, {
  have Had : (d.shift xy) ∈ avail
    := in_component2d_subset_avail avail ini (d.shift xy) Hc,
  apply Hsub,
  have Hlr : xy ∈ (component_extend_rows avail ini)
    → xy ∈ (component_step avail ini)
    := component_extend_cols_supset avail _
      (component_extend_rows_subset_avail avail ini) xy,
  have Hud : (d.shift xy) ∈ (component_extend_rows avail ini)
    := component_extend_rows_supset avail _ Hia_sub (d.shift xy) IH,
  unfold component_step, simp,
  cases d,
  { exact component_extend_cols_works direction.up Ha Had Hud
      (or.intro_left _ rfl), },
  { exact component_extend_cols_works direction.down Ha Had Hud
      (or.intro_right _ rfl), },
  { exact Hlr (component_extend_rows_works direction.left Ha Had IH
      (or.intro_left _ rfl)), },
  { exact Hlr (component_extend_rows_works direction.right Ha Had IH
      (or.intro_right _ rfl)), },
  },
end

--
--    ___ ___  _ __ ___  _ __     __ _ _   ___  __
--   / __/ _ \| '_ ` _ \| '_ \   / _` | | | \ \/ /
--  | (_| (_) | | | | | | |_) | | (_| | |_| |>  <
--   \___\___/|_| |_| |_| .__/___\__,_|\__,_/_/\_\
--                      |_| |_____|

theorem component2d_aux_valid : ∀ (b : ℕ) (avail ini : bset2d) (xy : ℕ×ℕ),
  ini ⊆ avail →
  xy ∈ (component2d_aux b avail ini) →
  in_component2d avail ini xy
:=
begin
  intro b, induction b with b IH, {
    introv Hsub H,
    unfold component2d_aux at H,
    exact in_component2d.triv xy (Hsub xy H) H,
  }, {
    introv Hsub H,
    unfold component2d_aux at H, simp at H,
    by_cases Hcond : (comp_measure avail (component_step avail ini) < comp_measure avail ini),
    { rw if_pos Hcond at H,
      apply in_component2d_trans _ _ (component_step avail ini),
      { clear H xy, introv Ha Hc, apply component_step_valid, exact Hc, },
      { apply IH _ _ _ _ H, apply component_step_subset_avail, },
    }, {
      rw if_neg Hcond at H,
      exact in_component2d.triv xy (Hsub xy H) H,
    }
  }
end

theorem component2d_aux_complete : ∀ (b : ℕ) (avail ini : bset2d) (xy : ℕ×ℕ),
  ini ⊆ avail →
  comp_measure avail ini ≤ b →
  in_component2d avail ini xy →
  xy ∈ (component2d_aux b avail ini)
:=
begin
  intro b, induction b with b IH, {
    introv Hsub Hm Hin,
    unfold component2d_aux,
    refine component_step_complete_of_nlt_measure avail ini Hsub _ xy Hin,
    { simp at Hm, rw Hm, apply nat.not_lt_zero, },
  }, {
    introv Hsub Hm Hin,
    unfold component2d_aux, simp,
    by_cases Hcond
      : (comp_measure avail (component_step avail ini) < comp_measure avail ini), {
      rw if_pos Hcond,
      apply IH,
      { apply component_step_subset_avail, },
      { exact nat.succ_le_succ_iff.mp (le_trans (nat.succ_le_iff.mpr Hcond) Hm) },
      { refine in_component2d_of_supset avail _ ini _ xy Hin,
        exact component_step_supset avail ini Hsub, },
    }, {
      rw if_neg Hcond,
      exact component_step_complete_of_nlt_measure avail ini Hsub Hcond xy Hin,
    },
  },
end

--                                                    _   ____     _
--    ___ ___  _ __ ___  _ __   ___  _ __   ___ _ __ | |_|___ \ __| |
--   / __/ _ \| '_ ` _ \| '_ \ / _ \| '_ \ / _ \ '_ \| __| __) / _` |
--  | (_| (_) | | | | | | |_) | (_) | | | |  __/ | | | |_ / __/ (_| |
--   \___\___/|_| |_| |_| .__/ \___/|_| |_|\___|_| |_|\__|_____\__,_|
--                      |_|

theorem component2d_valid : ∀ (avail ini : bset2d) (xy : ℕ×ℕ),
  xy ∈ (component2d avail ini) →
  in_component2d avail ini xy
:=
begin
  unfold component2d, simp, introv H,
  apply in_component2d_trans _ _ (list2d.pointwise2d band avail ini),
  clear H xy, introv Ha Hri, {
    unfold has_mem.mem at Hri,
    rw list2d.get2d_pointwise at Hri, simp at Hri, cases Hri with Ha Hi,
    apply in_component2d.triv xy Ha, exact Hi,
    simp!,
  }, {
    apply component2d_aux_valid _ _ _ _ _ H, {
      clear H, intro xy, intro H,
      unfold has_mem.mem at H,
      rw list2d.get2d_pointwise at H, simp at H, cases H with Ha Hi,
      exact Ha,
      simp!,
    },
  },
end
theorem component2d_complete : ∀ (avail ini : bset2d) (xy : ℕ×ℕ),
  in_component2d avail ini xy →
  xy ∈ (component2d avail ini)
:=
begin
  introv Hin, unfold component2d, simp,
  apply component2d_aux_complete _ avail _ xy, {
    clear Hin xy, intros xy H,
    unfold has_mem.mem at H,
    simp [list2d.get2d_pointwise] at H,
    exact H.elim_left,
  }, exact le_refl _, {
    refine in_component2d_trans avail _ ini _ xy Hin,
    intros xy Ha Hi,
    apply in_component2d.triv xy Ha,
    simp [has_mem.mem, list2d.get2d_pointwise], exact and.intro Ha Hi,
  },
end
theorem component2d_op_closed : ∀ {avail ini : bset2d} {xy : ℕ×ℕ} {d : direction},
  d.shift xy ∈ (component2d avail ini) →
  xy ∈ avail →
  xy ∈ (component2d avail ini) :=
begin
  introv Hc Ha, apply component2d_complete,
  have Hc := component2d_valid avail ini (d.shift xy) Hc,
  exact in_component2d.move d xy Ha Hc,
end
theorem component2d_closed : ∀ {avail ini : bset2d} {xy : ℕ×ℕ} {d : direction},
  xy ∈ (component2d avail ini) →
  d.shift xy ∈ avail →
  d.shift xy ∈ (component2d avail ini) :=
begin
  introv Hc Ha, cases direction.opposite_shift d xy with Heq Hrev,
  { rw Heq, exact Hc, },
  rw ←Hrev at Hc, exact component2d_op_closed Hc Ha,
end
theorem component2d_subset_avail : ∀ {avail ini : bset2d},
  (component2d avail ini) ⊆ avail :=
λ avail ini xy Hin, in_component2d_subset_avail _ _ _ (component2d_valid _ _ _ Hin)

theorem component2d_supset : ∀ {avail ini : bset2d},
  ini ⊆ avail → ini ⊆ (component2d avail ini) :=
assume avail ini Hsub xy Hin,
  component2d_complete _ _ _ (in_component2d.triv xy (Hsub xy Hin) Hin)


import linear_algebra.finite_dimensional
import ring_theory.ideal.basic
import algebra.field
import ring_theory.subring
import ring_theory.integral_closure
import ring_theory.fractional_ideal
import data.rat.basic
import ring_theory.algebra
import ring_theory.algebraic
import field_theory.separable
import field_theory.normal
import data.padics.padic_integers
import algebra.category.CommRing.basic
import category_theory.concrete_category.bundled
import algebra.free_monoid

open function
open_locale classical big_operators

def is_integrally_closed_domain (R : Type*) [comm_ring R] : Prop := ∀ {r s : R}, s ≠ 0 → (∃ (n : ℕ) (f : ℕ → R)
(hf : f 0 = 1), ∑ ij in finset.nat.antidiagonal n, f ij.1 * r ^ ij.2 * s ^ ij.1 = 0) → s ∣ r

class dedekind_id (R : Type*) [integral_domain R] : Prop :=
    (noetherian : is_noetherian_ring R)
    (int_closed : is_integrally_closed_domain R)
    (max_nonzero_primes : ∀ P : ideal R, P ≠ ⊥ → P.is_prime → P.is_maximal)

class number_field (K : Type*) :=
   (fld : field K)
   (alg : algebra ℚ K)
   (fd : finite_dimensional ℚ K)

instance field_of_number_field (K : Type*) [number_field K] : field K := _inst_1.fld

instance algebra_of_number_field (K : Type*) [number_field K] : algebra ℚ K := _inst_1.alg

instance infinite_of_number_field (K : Type*) [number_field K] : infinite K := begin
  let f : ℤ → K := (λ n, (n : ℚ) • (1 : K)),
  apply infinite.of_injective f,
  intros x y hxy,
  have hxy2 : (x : ℚ) • (1 : K) = (y : ℚ) • (1 : K), exact hxy,
  have h : 0 = ((x : ℚ) - (y : ℚ)) • (1 : K), calc 0 = (x : ℚ) • (1 : K) - (y : ℚ) • (1 : K) : by rw sub_eq_zero.mpr hxy
  ... = (x : ℚ) • (1 : K) + (-((y : ℚ) • (1 : K))) : sub_eq_add_neg (↑x • 1) (↑y • 1)
  ... = (x : ℚ) • (1 : K) + ((-(y : ℚ)) • (1 : K)) : by rw neg_smul
  ... = ((x : ℚ) + (-(y : ℚ))) • (1 : K) : by rw add_smul
  ... = ((x : ℚ) - (y : ℚ)) • (1 : K) : by rw sub_eq_add_neg,
  have h2 : ((x : ℚ) - (y : ℚ)) = 0 ∨ (1 : K) = 0, {exact (@smul_eq_zero ℚ K _ _ _ ((x : ℚ) - (y : ℚ)) (1 : K)).1 (eq.symm h)},
  cases h2, {have h3 : (x : ℚ) = (y : ℚ), exact sub_eq_zero.mp h2,
    exact (rat.coe_int_inj (x : ℤ) (y : ℤ)).1 h3},
  {exfalso, revert h2, simp}
end

def number_ring (K : Type*) [number_field K] := @integral_closure ℤ K _ (@field.to_comm_ring K _inst_1.fld) _

theorem integral_domain_of_number_ring (K : Type*) [number_field K] : integral_domain (number_ring K) :=
(number_ring K).integral_domain

example (K : Type*) [field K] (x : K) (h : x ≠ 0): x * (field.inv x) = 1 := field.mul_inv_cancel h

/-- A predicate to express that a ring is a field.

This is mainly useful because such a predicate does not contain data,
and can therefore be easily transported along ring isomorphisms. -/
structure is_field (R : Type*) [ring R] : Prop :=
    (exists_pair_ne : ∃ (x y : R), x ≠ y)
    (mul_comm : ∀ (x y : R), x * y = y * x)
    (mul_inv_cancel' : ∀ {a : R}, a ≠ 0 → ∃ b, a * b = 1)

/-- Every field satisfies the predicate for integral domains. -/
lemma field.to_is_field (R : Type*) [field R] : is_field R :=
    {mul_inv_cancel' := λ a ha, ⟨a⁻¹, field.mul_inv_cancel ha⟩,
   .. (‹_› : field R) }

noncomputable def is_field.to_field (R : Type*) [ring R] (h : is_field R) : field R :=
    {inv := (λ a, if ha : a = 0 then 0 else classical.some (is_field.mul_inv_cancel' h ha)),
    inv_zero := (dif_pos rfl),
    mul_inv_cancel := (λ a ha, begin
        convert classical.some_spec (is_field.mul_inv_cancel' h ha),
        exact dif_neg ha
    end),
    .._inst_1, ..h}

/-- There is a unique inverse in a field.
-/
lemma uniq_inv_of_is_field (R : Type*) [comm_ring R] [is_field R]: ∀ (x : R), x ≠ 0 → ∃! (y : R), x * y = 1 := begin
    intros x hx,
    apply exists_unique_of_exists_of_unique,
        {exact _inst_2.mul_inv_cancel' hx},
    intros y z hxy hxz,
    calc y = y * 1 : eq.symm (mul_one y)
    ... = y * (x * z) : by rw hxz
    ... = (y * x) * z : eq.symm (mul_assoc y x z)
    ... = (x * y) * z : by rw mul_comm y x
    ... = 1 * z : by rw hxy
    ... = z : one_mul z
end

/-- If the quotient of a `comm_ring` by an ideal is a field, then the ideal is maximal
-/
lemma maximal_ideal_of_is_field_quotient (R : Type*) [comm_ring R] (I : ideal R)
[@is_field I.quotient (comm_ring.to_ring (ideal.quotient I))] : I.is_maximal := begin
    apply ideal.is_maximal_iff.2,
    split, {intro h,
        rcases (_inst_2.exists_pair_ne) with ⟨⟨x⟩, ⟨y⟩, hxy⟩,
        apply hxy,
        apply ideal.quotient.eq.2,
        rw ←mul_one (x-y),
        apply submodule.smul_mem',
        exact h},
    {intros J x hIJ hxnI hxJ,
        have hxn0 : (ideal.quotient.mk I x) ≠ 0,
        {exact @mt ((ideal.quotient.mk I x) = 0) (x ∈ I) ideal.quotient.eq_zero_iff_mem.1 hxnI},
        have hinvx : ∃ (y : I.quotient), (ideal.quotient.mk I x) * y = 1, {exact _inst_2.mul_inv_cancel' hxn0},
        rcases hinvx with ⟨⟨y⟩, hy⟩,
        change (ideal.quotient.mk I x) * (ideal.quotient.mk I y) = 1 at hy,
        rw ←((ideal.quotient.mk I).map_mul x y) at hy,
        have hxy1I : x*y-1 ∈ I, exact ideal.quotient.eq.1 hy,
        have hxy1J : x*y-1 ∈ J, exact hIJ hxy1I,
        have hxyJ : x*y ∈ J, exact ideal.mul_mem_right J hxJ,
        have hend : x*y-(x*y-1) ∈ J, exact ideal.sub_mem J hxyJ hxy1J,
        have h1 : 1 = x*y-(x*y-1), by ring,
        rw h1,
        exact hend}
end

/-- The quotient of a ring by an ideal is a field iff the ideal is maximal.
-/
theorem maximal_ideal_iff_is_field_quotient (R : Type*) [comm_ring R] (I : ideal R) :
I.is_maximal ↔ (@is_field I.quotient (comm_ring.to_ring (ideal.quotient I))) := begin
    split,
    {intro h,
        exact @field.to_is_field I.quotient (@ideal.quotient.field _ _ I h)},
    {intro h,
        exact @maximal_ideal_of_is_field_quotient R _ I h,}
end

instance dedekind_domain_of_number_ring (K : Type*) [number_field K] : dedekind_id (number_ring K) := {
  noetherian := sorry,
  int_closed := sorry,
  max_nonzero_primes := (begin
    intros P hP hPp,
    have hid : integral_domain P.quotient, exact @ideal.quotient.integral_domain _ _ P hPp,
    have hfin : fintype P.quotient, {sorry},
    have hf : is_field (P.quotient), {sorry},
    exact @maximal_ideal_of_is_field_quotient (number_ring K) _ P hf,
  end)}

noncomputable theory
open_locale classical

open finite_dimensional
open ring.fractional_ideal

namespace number_field

variables (K : Type*) [number_field K]

variables (g : fraction_map (number_ring K) K)

def fractional_ideal := { Q : ring.fractional_ideal g // is_unit Q }

@[ext]
lemma ext {I J : fractional_ideal K g} : (I.1 : submodule (number_ring K) g.codomain) = J.1.1 → I = J :=
begin
  rw <-subtype.val_eq_coe,
  rw subtype.ext_iff_val,
  rw subtype.ext_iff_val,
  rintros,
  assumption,
end

instance : no_zero_divisors (ring.fractional_ideal g) :=
begin sorry, end

instance : has_mul (fractional_ideal K g) :=
begin
  constructor,
  rintros a b,
  use a.1*b.1,
  apply is_unit.mul,
  use a.2,
  use b.2,
end

lemma blossom (I J : fractional_ideal K g) : (I * J).val = I.val * J.val :=
begin
  split,
end

lemma blossom' (I J : ring.fractional_ideal g) : (I * J).val = I.val * J.val :=
begin
  split,
end

instance : has_one (fractional_ideal K g) :=
begin
  use 1,
  simp,
end

lemma idk (I J : ring.fractional_ideal g) : (I/J).val = I.val / J.val :=
begin
  by_cases J=0,
  subst J,
  unfold has_div.div,
  simp,
  sorry,
  sorry,
end

lemma work (I J : ring.fractional_ideal g) : I/J = I * J⁻¹ :=
begin
  unfold has_div.div,
  split_ifs,
  rw h,
  simp,
  right,
  unfold has_inv.inv,
  unfold has_div.div,
  split_ifs,
  assumption,

  exfalso,
  simp at h_1,
  assumption,

  ext x,
  unfold has_inv.inv,
  unfold has_div.div,
  split_ifs,
  split,

  rintros h,
  simp at *,

  sorry,
  sorry,
end

@[simp] lemma coe_one : (1 : fractional_ideal K g).1 = 1 := rfl

lemma mul_one' (I : ring.fractional_ideal g) : I = I * 1 :=
begin
  simp only [mul_one],
end

noncomputable instance fractional_ideal_has_div :
  has_div (fractional_ideal K g) :=
begin
  constructor,
  rintros I J,
  use I.1 / J.1,
  sorry,
--  by_contra,
--  simp at a,
--  rw submodule.ext at a,

--  apply left_ne_zero_of_mul I.1 J.1,

--  cases I with I1 I2,
--  apply I2,
--  simp at a,
--  rw <-mul_left_cancel_iff (ring.fractional_ideal g) J.1 (I1 / ↑J) 0 at a,
--  rw subtype.ext_iff_val at a,
--  rw subtype.val_eq_coe at a,
--  rw subtype.val_eq_coe at a,
--  simp at *,

--  rw mul_left_inj J.1.1 _ _ at a,
end

noncomputable instance : has_inv (fractional_ideal K g) := ⟨λ I, 1 / I⟩

lemma pls_work (I : ring.fractional_ideal g) (h : I ≠ 0) : I * (1 / I) = 1 :=
begin
  rw [ring.fractional_ideal.div_nonzero h],
  apply le_antisymm,
  {
    apply submodule.mul_le.mpr _,
    intros x hx y hy,
    rw [mul_comm],
    sorry,
--    exact submodule.mem_div_iff_forall_mul_mem.mp hy x hx,
  },
  {
    sorry,
  },
end

instance is_group : group (fractional_ideal K g) :=
begin
  constructor,
  {
    rintros a,
    rw subtype.ext_iff_val,
    rw blossom,
    have h : a⁻¹.val = a.val⁻¹,
    split,
    rw h,
    rw coe_one,
    unfold has_inv.inv,
    simp,

    sorry,

--    rw inv_mul_eq_one,
--    apply ring.fractional_ideal.coe_inv_of_nonzero,

--    use a.2,
  },
  {
    rintros a b c,
    rw subtype.ext_iff_val,
    repeat{rw blossom},
    rw subtype.ext_iff_val,
    repeat{rw blossom'},
    rw submodule.mul_assoc,
  },
  {
    rintros a,
    rw subtype.ext_iff_val,
    rw subtype.ext_iff_val,
    simp,
    cases a,
    sorry,
  },
  {
    rintros a,
    sorry,
  },
end

def principal_fractional_ideal : subgroup (fractional_ideal K g) :=
{
  carrier := { P : fractional_ideal K g | ∃ a : K, P.1 = ring.fractional_ideal.span_singleton a },
  one_mem' := sorry,
  mul_mem' := sorry,
  inv_mem' := sorry,
}

def class_group := quotient_group.quotient (principal_fractional_ideal K g)

instance class_number_is_finite : fintype (class_group K g) :=
begin
  sorry,
end

def class_number := fintype.card (class_group K g)

-- def equiv (I J : ring.fractional_ideal g) : Prop := ∃ a : number_ring K, (ideal.span{a})*I = J

-- theorem symmetricity : symmetric (equiv g) :=

def gal_ext (F L : Type*) [field F] [field L] [algebra F L] := (is_separable F L) ∧ (normal F L)

def gal_grp (F L : Type*) [field F] [field L] [algebra F L] : (Type : Type 1) := {σ : ring_aut L | ∀ x : F, σ (x • (1:L)) = (x • (1:L)) }

class zp_ext (L : Type*) [field L] (p : ℕ) [fact p.prime] ( h : ℕ → set L ) :=
( blah2 : ∀ i : ℕ, number_field (h i) )
( blah : ∀ i j : ℕ, i < j ↔ (h i) ⊂ (h j) )
( blah4 : ∀ i : ℕ, algebra (h 0) (h i) )
( blah3 : ∀ i : ℕ, gal_ext (h 0) (h i) )
( blah5 : ∀ i : ℕ, gal_grp (h 0) (h i) = zmod (p^i) )
( blah6 : L = ⋃ (i : ℕ), (h i) )

instance nth_ext (L : Type*) [field L] (p : ℕ) ( n : ℕ ) [fact p.prime] ( h : ℕ → set L ) [ zp_ext L p h ] : number_field (h n) := zp_ext.blah2 p n

variables {p : ℕ} [fact p.prime]

variables (L : Type 0) [field L] ( h : ℕ → set L ) [zp_ext L p h] (n : ℕ) [ gn : (fraction_map (number_ring (h n)) (h n) ) ]

instance any_ext : ∀ m : ℕ, number_field (h m) :=
begin
  sorry,
end

lemma ne : ∀ m : ℕ, nonempty ( fraction_map (number_ring (h m)) (h m) ) :=
begin
  sorry,
end

def class_no_tower' : ℕ → ℕ := λ m, class_number (h m) (classical.choice (ne L h m) )

-- def nth_class_no_for_tower : ℕ := class_number (h n) gn

theorem main : ∃ N : ℕ, ∀ m ≥ N, ∃ a b c : ℕ, padic_val_rat p (class_number (h m) (classical.choice (ne L h m) ) ) = a*p^m + b*m + c :=
begin
sorry,
end

-- def class_no_tower : ℕ → ℕ := λ n, (nth_class_no_for_tower L h n gn)

-- (localization_map (non_zero_divisors (number_ring (h n)) ) : fraction_map (number_ring (h n)) (h n) )
-- theorem main (L : Type*) [field L] ( h : ℕ → set L ) [zp_ext L p h] [∀ n : ℕ, number_field (h n)] [f : en = class_number (h n) _ ]

end number_field


/-
Copyright (c) 2018 Reid Barton. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Reid Barton

Type of continuous maps and the compact-open topology on them.
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.topology.subset_properties
import Mathlib.topology.continuous_map
import Mathlib.tactic.tidy
import Mathlib.PostPort

universes u_1 u_2 u_3

namespace Mathlib

namespace continuous_map

def compact_open.gen {α : Type u_1} {β : Type u_2} [topological_space α] [topological_space β] (s : set α) (u : set β) : set (continuous_map α β) :=
  set_of fun (f : continuous_map α β) => ⇑f '' s ⊆ u

-- The compact-open topology on the space of continuous maps α → β.

protected instance compact_open {α : Type u_1} {β : Type u_2} [topological_space α] [topological_space β] : topological_space (continuous_map α β) :=
  topological_space.generate_from
    (set_of
      fun (m : set (continuous_map α β)) =>
        ∃ (s : set α), ∃ (hs : is_compact s), ∃ (u : set β), ∃ (hu : is_open u), m = sorry)

def induced {α : Type u_1} {β : Type u_2} {γ : Type u_3} [topological_space α] [topological_space β] [topological_space γ] {g : β → γ} (hg : continuous g) (f : continuous_map α β) : continuous_map α γ :=
  mk (g ∘ ⇑f)

/-- C(α, -) is a functor. -/
theorem continuous_induced {α : Type u_1} {β : Type u_2} {γ : Type u_3} [topological_space α] [topological_space β] [topological_space γ] {g : β → γ} (hg : continuous g) : continuous (induced hg) := sorry

def ev (α : Type u_1) (β : Type u_2) [topological_space α] [topological_space β] (p : continuous_map α β × α) : β :=
  coe_fn (prod.fst p) (prod.snd p)

-- The evaluation map C(α, β) × α → β is continuous if α is locally compact.

theorem continuous_ev {α : Type u_1} {β : Type u_2} [topological_space α] [topological_space β] [locally_compact_space α] : continuous (ev α β) := sorry

def coev (α : Type u_1) (β : Type u_2) [topological_space α] [topological_space β] (b : β) : continuous_map α (β × α) :=
  mk fun (a : α) => (b, a)

theorem image_coev {α : Type u_1} {β : Type u_2} [topological_space α] [topological_space β] {y : β} (s : set α) : ⇑(coev α β y) '' s = set.prod (singleton y) s := sorry

-- The coevaluation map β → C(α, β × α) is continuous (always).

theorem continuous_coev {α : Type u_1} {β : Type u_2} [topological_space α] [topological_space β] : continuous (coev α β) := sorry


import quantum_lemmas

open Matrix

local notation `|0^(` n `)⟩` := ket_zeros n

------------------------------------------------------------------------------
-- no-cloning theorem (with 1 input qubit and 1 ancilla qubit)

section no_cloning_1

-- Note: lean can't detect contradiction from `/√2 = 1/2`. Convert it to reals.
lemma no_cloning_contra_h : /√2 = 1/2 → false
:= begin
    intros h,
    let c1 := eq_of_one_div_eq_one_div h,
    norm_cast at c1,
    have c2: (2 : ℝ) = 4, {
        calc 2 = √2 * √2 : by {rw real.mul_self_sqrt, linarith}
           ... = 2 * 2 : by rw c1
           ... = (4 : ℝ) : by linarith,
    },
    linarith,
end

lemma no_cloning_contra : ¬ (∀ (x y : Vector 2), (x† ⬝ y) = (x† ⬝ y) ⊗ (x† ⬝ y))
:= begin
    intros h,
    have f1: (|0⟩† ⬝ |+⟩) = λ _ _, /√2, {
        unfold_qubits; grind_matrix, grind_dot_product; finish_complex_arith,
    },
    have f2: (|0⟩† ⬝ |+⟩) = λ _ _, 1/2, {
        rw h,
        rw f1,
        unfold kron,
        apply funext, intro i,
        apply funext, intro j,
        norm_cast,
        rw div_mul_div,
        rw real.mul_self_sqrt,
        norm_cast, simp,
        linarith,
    },
    have f1': (|0⟩† ⬝ |+⟩) 0 0 = /√2, {
        rw f1,
    },
    have f2': (|0⟩† ⬝ |+⟩) 0 0 = 1/2, {
        rw f2,
    },
    have c: /√2 = 1/2, {
        rw <- f1',
        rw <- f2',
    },
    apply no_cloning_contra_h c,
end

theorem no_cloning_1
    : ¬ (∃ (U : Matrix 4 4), U.unitary ∧ ∀ s : Vector 2, U ⬝ (s ⊗ |0⟩) = s ⊗ s)
:= begin
    intros h, rcases h with ⟨U, ⟨H1, H2⟩⟩,

    -- Part 1: derive the main contradictory fact.
    have f1: ∀ (x y : Vector 2), (x† ⬝ y) = (x† ⬝ y) ⊗ (x† ⬝ y), {
        intros x y,
        have g1: (x† ⊗ (|0⟩†)) ⬝ (U† ⬝ U) ⬝ (y ⊗ |0⟩) = (x† ⊗ (x†)) ⬝ (y ⊗ y), {
            rw <- matrix.mul_assoc,
            rw <- adjoint_kron,
            rw <- adjoint_mul,
            rw H2,
            rw matrix.mul_assoc,
            rw H2,
            congr' 1,
            rw <- adjoint_kron,
        },
        calc (x†) ⬝ y = (x† ⬝ y) ⊗ (|0⟩† ⬝ |0⟩) : by simp
                  ... = (x† ⊗ (|0⟩†)) ⬝ (y ⊗ |0⟩) : by rw kron_mixed_prod
                  ... = (x† ⊗ (|0⟩†)) ⬝ (U† ⬝ U) ⬝ (y ⊗ |0⟩) : by {rw unfold_unitary H1, simp}
                  ... = (x† ⊗ (x†)) ⬝ (y ⊗ y) : g1
                  ... = (x† ⬝ y) ⊗ (x† ⬝ y) : by rw kron_mixed_prod,
    },

    -- Part 2:  derive false from the `f1`.
    apply no_cloning_contra f1,
end

end no_cloning_1

------------------------------------------------------------------------------
-- no-cloning theorem 2 (with n input qubit and n ancilla qubit)
-- Similar to no_cloning_1, but generalized with n qubits.

section no_cloning_2

-- Note: The vector size needs to have this formula: (2 * 2^n) to make it easier to match.
lemma no_cloning_contra_2 (n : ℕ) : ¬ (∀ (x y : Vector 2 * (2^n)), (x† ⬝ y) = (x† ⬝ y) ⊗ (x† ⬝ y))
:= begin
    intros h,
    have f1: ((|0⟩ ⊗ |0^(n)⟩)†) ⬝ (|+⟩ ⊗ |0^(n)⟩) = λ _ _, /√2, {
        rw adjoint_kron,
        rw kron_mixed_prod,
        simp,
        unfold_qubits; grind_matrix, grind_dot_product; finish_complex_arith,
    },
    have f2: ((|0⟩ ⊗ |0^(n)⟩)†) ⬝ (|+⟩ ⊗ |0^(n)⟩) = λ _ _, 1/2, {
        rw h,
        rw f1,
        unfold kron,
        apply funext, intro i,
        apply funext, intro j,
        norm_cast,
        rw div_mul_div,
        rw real.mul_self_sqrt,
        norm_cast, simp,
        linarith,
    },

    let fin0 := (⟨0, by simp⟩ : fin (1*1)),
    have f1': (((|0⟩ ⊗ |0^(n)⟩)†) ⬝ (|+⟩ ⊗ |0^(n)⟩)) fin0 fin0 = /√2, {
        rw f1,
    },
    have f2': (((|0⟩ ⊗ |0^(n)⟩)†) ⬝ (|+⟩ ⊗ |0^(n)⟩)) fin0 fin0 = 1/2, {
        rw f2,
    },
    have c: /√2 = 1/2, {
        rw <- f1',
        rw <- f2',
    },
    apply no_cloning_contra_h c,
end

theorem no_cloning_2 (n : ℕ) (npos : 0 < n)
    : ¬ (∃ (U : Square (2^n * 2^n))
         , U.unitary ∧ ∀ (s : Vector 2^n), U ⬝ (s ⊗ |0^(n)⟩) = s ⊗ s)
:= begin
    intros h, rcases h with ⟨U, ⟨H1, H2⟩⟩,

    -- Part 1: derive the main contradictory fact.
    have f1: ∀ (x y : Vector 2^n), (x† ⬝ y) = (x† ⬝ y) ⊗ (x† ⬝ y), {
        intros x y,
        have g1: (x† ⊗ (|0^(n)⟩†)) ⬝ (U† ⬝ U) ⬝ (y ⊗ |0^(n)⟩) = (x† ⊗ (x†)) ⬝ (y ⊗ y), {
            rw <- matrix.mul_assoc,
            rw <- adjoint_kron,
            rw <- adjoint_mul,
            rw H2,
            rw matrix.mul_assoc,
            rw H2,
            congr' 1,
            rw <- adjoint_kron,
        },
        calc (x†) ⬝ y = (x† ⬝ y) ⊗ (|0^(n)⟩† ⬝ |0^(n)⟩) : by simp
                  ... = (x† ⊗ (|0^(n)⟩†)) ⬝ (y ⊗ |0^(n)⟩) : by rw kron_mixed_prod
                  ... = (x† ⊗ (|0^(n)⟩†)) ⬝ (U† ⬝ U) ⬝ (y ⊗ |0^(n)⟩) : by {rw unfold_unitary H1, simp}
                  ... = (x† ⊗ (x†)) ⬝ (y ⊗ y) : g1
                  ... = (x† ⬝ y) ⊗ (x† ⬝ y) : by rw kron_mixed_prod,
    },

    -- Part 2:  derive false from the `f1`.
    cases n, {
        exfalso, linarith,
    }, {
        apply no_cloning_contra_2 _ f1,
    },
end

end no_cloning_2

------------------------------------------------------------------------------
-- no-cloning theorem 3 (with 1 input qubit and (n+1) ancilla qubits)

section no_cloning_3_helpers

variables {n : ℕ}
variables {U : Square (2 ^ (n + 2))} {f : (Vector 2) → Vector (2^n)}

-- Any `f x` must be unit, since `U` is a unitary operator.
lemma no_cloning_3_unit {x : Vector 2} :
    (∀ s : Vector 2, s.unit → U ⬝ (s ⊗ (|0^(n+1)⟩)) = (s ⊗ (s ⊗ (f s))))
    → U.unitary → x.unit
    → (f x).unit
:= begin
    intros h u xu,
    have f1: (x ⊗ (x ⊗ f x)).unit, {
        rw <- h _ xu,
        unfold matrix.unit,
        rw unitary_preserve_norm _ _ _ u,
        change ((x ⊗ |0^(n + 1)⟩).unit),
        apply unit_kron_of_unit; try {simp *},
        unfold matrix.unit ket_zeros, simp,
    },
    apply unit_kron_right,
    apply unit_kron_right f1; assumption,
    assumption,
end

-- The contradictory formula
lemma no_cloning_3_contradiction {x y : Vector 2} :
    (∀ s : Vector 2, s.unit → U ⬝ (s ⊗ (|0^(n+1)⟩)) = (s ⊗ (s ⊗ (f s))))
    → U.unitary → x.unit → y.unit
    → (x†) ⬝ y ≠ 0
    → (x† ⬝ y) ⬝ ((f x)† ⬝ f y) = 1
:= begin
    intros h u xu yu h',

    have fx1: x ⊗ (x ⊗ (f x)) = U ⬝ (x ⊗ (|0^(n+1)⟩)), by rw h; assumption,
    have fy1: y ⊗ (y ⊗ (f y)) = U ⬝ (y ⊗ (|0^(n+1)⟩)), by rw h; assumption,

    have f1: ((x ⊗ (x ⊗ (f x)))†) ⬝ (y ⊗ (y ⊗ (f y))) = ((x ⊗ (|0^(n+1)⟩))†) ⬝ (y ⊗ (|0^(n+1)⟩)), {
        rw fx1, rw fy1,
        rw unitary_preserve_norm; assumption,
    },

    repeat { rw adjoint_kron at f1 },
    repeat { rw kron_mixed_prod at f1 },
    unfold ket_zeros at f1, simp at f1,
    repeat { rw kron_one_by_one_eq_mul at f1 },
    repeat { rw kron_square_one_eq_mul at f1 },

    have f2: ((x†) ⬝ y) ⬝ (x† ⬝ y ⬝ (f x† ⬝ f y)) = (x† ⬝ y) ⬝ 1, {
        simp, assumption,
    },

    apply matrix_mul_cancel_left_square_one f2; assumption,
end

end no_cloning_3_helpers

theorem no_cloning_3 {n}
    : ¬ (∃ (U : Square (2 ^ (n + 2))) (f : (Vector 2) → Vector (2^n))
         , U.unitary
         ∧ (∀ s : Vector 2, s.unit → U ⬝ (s ⊗ (|0^(n+1)⟩)) = (s ⊗ (s ⊗ (f s)))))
:= begin
    by_contradiction H,
    rcases H with ⟨U, ⟨f, H⟩⟩,
    rcases H with ⟨u, h⟩,

    -- Step 1. Derive facts about "f" based on the fact that
    --         U is a unitary operatros.
    have f_ket0_unit: (f |0⟩).unit, {
        apply no_cloning_3_unit h u; try {solve1 {simp *}},
    },
    have f_ket_plus_unit: (f |+⟩).unit, {
        apply no_cloning_3_unit h u; try {solve1 {simp *}},
    },
    have f1: |⟪ f |0⟩, f |+⟩ ⟫| ≤ 1, {
        apply inner_product_bound_of_unit; assumption,
    },

    -- Step 2. Derive the contradictory fact from the expected result state.
    have c1: (|0⟩† ⬝ |+⟩) ⬝ ((f |0⟩)† ⬝ f |+⟩) = 1, {
        apply no_cloning_3_contradiction h; simp <|> assumption,
        rw inner_product_zero_iff, rw inner_ket0_ket_plus, simp,
    },

    -- Step 3, combine Step #1 and #3 to deduce "false".
    have c2: ⟪ f |0⟩, f |+⟩ ⟫ = √2, {
        have c1': ⟪ |0⟩, |+⟩ ⟫ * ⟪ f |0⟩, f |+⟩ ⟫ = 1, {
            rw <- matrix.ext_iff at c1, specialize c1 0 0,
            rw matrix_mul_square_one at c1, simp at c1,
            apply c1,
        },
        rw inner_ket0_ket_plus at c1',
        have c2_1: (√2 * (/√2 * ⟪ f |0⟩, f |+⟩ ⟫) : ℂ) = √2 * 1, {
            rw c1',
        },
        calc ⟪ f |0⟩, f |+⟩ ⟫ = √2 * (/√2 * ⟪ f |0⟩, f |+⟩ ⟫) : by {simp,}
                         ... = √2 : by {rw c2_1, simp,},
    },
    have c3: |(√2 : ℂ)| ≤ 1 → false, {
        simp, rw _root_.abs_of_nonneg, {
            contrapose!, intro h, clear h, simp,
        }, {
            simp,
        }
    },
    apply c3,
    rw <- c2, assumption,
end

------------------------------------------------------------------------------
-- no-cloning theorem 3 (with 1 input qubit and (n+1) ancilla qubits)
-- Alternative proof based on partial measure.

lemma no_cloning_3_alt_helper1 (i : fin 4) : (/√2 • (|0⟩ ⊗ |0⟩) i 0)† * (/√2 • (|1⟩ ⊗ |1⟩)) i 0 = 0
:= begin
    unfold_qubits,
    unfold kron kron_div kron_mod,
    repeat { destruct_fin }; simp,
end

lemma no_cloning_3_alt_helper2 : ⟦(|+⟩ ⊗ |+⟩)⟧ 1 = 1/4
:= begin
    unfold quantum.measure,
    unfold_qubits,
    unfold kron kron_div kron_mod,
    repeat { destruct_fin }; simp; ring,
end

lemma no_cloning_3_alt_helper3 : ⟦(/√2 • (|0⟩ ⊗ |0⟩)) + (/√2 • (|1⟩ ⊗ |1⟩))⟧ 1 = 0
:= begin
    unfold quantum.measure,
    unfold_qubits,
    unfold kron kron_div kron_mod,
    repeat { destruct_fin }; simp,
end

theorem no_cloning_3_alt {n}
    : ¬ (∃ (U : Square (2 ^ (n + 2))) (f : (Vector 2) → Vector (2^n))
         , U.unitary
         ∧ (∀ s : Vector 2, s.unit → U ⬝ (s ⊗ (|0^(n+1)⟩)) = (s ⊗ (s ⊗ (f s)))))
:= begin
    by_contradiction H,
    rcases H with ⟨U, ⟨f, H⟩⟩,
    rcases H with ⟨u, H⟩,

    let U_0 := (H (|0⟩)),
    let U_1 := (H (|1⟩)),
    let U_plus := (H |+⟩),

    -- Step 1. Compute the state after cloning |+⟩
    have step1 : U ⬝ (|+⟩ ⊗ |0^(n+1)⟩) = /√2 • U ⬝ (|0⟩ ⊗ |0^(n+1)⟩)
                                      + /√2 • U ⬝ (|1⟩ ⊗ |0^(n+1)⟩), {
        iterate 2 { rw <- matrix.mul_smul },
        iterate 2 { rw <- kron_smul_left },
        rw <- matrix.mul_add,
        congr' 1,
        rw <- kron_dist_over_add_left,
        congr' 1,
        rw ket_plus_alt_def,
    },

    -- Step 2. Compute the state after cloning |0⟩ or |1⟩ with a 50% probability.
    --         This should be identical to the Step #1 when combined.
    have step2_1: /√2 • U ⬝ (|0⟩ ⊗ |0^(n+1)⟩) = /√2 • |0⟩ ⊗ (|0⟩ ⊗ f |0⟩), {
        congr' 1, apply H, simp,
    },
    have step2_2: /√2 • U ⬝ (|1⟩ ⊗ |0^(n+1)⟩) = /√2 • |1⟩ ⊗ (|1⟩ ⊗ f |1⟩), {
        congr' 1, apply H, simp,
    },

    -- Step 3. Equate the results of Step #1 and #2, which will be contradictory.
    have step3: |+⟩ ⊗ (|+⟩ ⊗ f |+⟩) = (/√2 • |0⟩ ⊗ (|0⟩ ⊗ f |0⟩)) + (/√2 • |1⟩ ⊗ (|1⟩ ⊗ f |1⟩)), {
        rw <- U_plus; try {solve1 {simp}},
        rw step1,
        rw <- step2_1,
        rw <- step2_2,
    },

    -- Step 4. Reformulate the equation from Step #3, before making a partial measurement.
    have step4: (|+⟩ ⊗ |+⟩) ⊗ f |+⟩ = (/√2 • (|0⟩ ⊗ |0⟩)) ⊗ f |0⟩ + (/√2 • (|1⟩ ⊗ |1⟩)) ⊗ f |1⟩, {
        rw kron_assoc_l2r,
        rw step3,
        simp,
        repeat { rw kron_assoc },
        rw push_cast_matrix_add; try {ring},
        iterate 2 { rw push_cast_matrix_smul; try {ring} },
        iterate 2 { rw cast_roundtrip },
    },
    clear step1 step2_1 step2_2 step3 U_plus U_0 U_1,

    -- Step 5. Derive facts about "f" based on the fact that
    --         U is a unitary operatros.
    have f_ket0_unit: (f |0⟩).unit, {
        apply no_cloning_3_unit H u; try {solve1 {simp *}},
    },
    have f_ket1_unit: (f |1⟩).unit, {
        apply no_cloning_3_unit H u; try {solve1 {simp *}},
    },
    have f_ket_plus_unit: (f |+⟩).unit, {
        apply no_cloning_3_unit H u; try {solve1 {simp *}},
    },

    -- Step 6. Find contradiction form the partial measurements of both sides.
    have c1: ⟦(|+⟩ ⊗ |+⟩)⟧ 1 = ⟦(/√2 • (|0⟩ ⊗ |0⟩)) + (/√2 • (|1⟩ ⊗ |1⟩))⟧ 1, {
        have p1: ⦃ (|+⟩ ⊗ |+⟩) ⊗ f |+⟩ ⦄ = ⟦(|+⟩ ⊗ |+⟩)⟧, {
            apply partial_measure_proj_kron,
            apply trace_proj_eq_one_of_unit; assumption,
        },
        have p2: ⦃ (/√2 • (|0⟩ ⊗ |0⟩)) ⊗ f |0⟩ + (/√2 • (|1⟩ ⊗ |1⟩)) ⊗ f |1⟩ ⦄
                = ⟦ (/√2 • (|0⟩ ⊗ |0⟩)) + (/√2 • (|1⟩ ⊗ |1⟩)) ⟧, {
            apply partial_measure_add_kron_of_orthogonal,
            apply trace_proj_eq_one_of_unit; assumption,
            apply trace_proj_eq_one_of_unit; assumption, {
                apply no_cloning_3_alt_helper1,
            },
        },
        rw <- p1,
        rw <- p2,
        rw step4,
    },
    have c2: (1/4 : ℝ) = 0, {
        rw <- no_cloning_3_alt_helper2,
        rw <- no_cloning_3_alt_helper3,
        apply c1,
    },
    norm_num at c2,
end


/-
Copyright (c) 2020 Markus Himmel. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Markus Himmel, Scott Morrison
-/
import category_theory.preadditive.yoneda.basic
import category_theory.preadditive.projective
import algebra.category.Group.epi_mono
import algebra.category.Module.epi_mono

/-!
An object is projective iff the preadditive coyoneda functor on it preserves epimorphisms.
-/

universes v u

open opposite

namespace category_theory
variables {C : Type u} [category.{v} C]

section preadditive
variables [preadditive C]

namespace projective

lemma projective_iff_preserves_epimorphisms_preadditive_coyoneda_obj (P : C) :
  projective P ↔ (preadditive_coyoneda.obj (op P)).preserves_epimorphisms :=
begin
  rw projective_iff_preserves_epimorphisms_coyoneda_obj,
  refine ⟨λ (h : (preadditive_coyoneda.obj (op P) ⋙ (forget _)).preserves_epimorphisms), _, _⟩,
  { exactI functor.preserves_epimorphisms_of_preserves_of_reflects (preadditive_coyoneda.obj (op P))
      (forget _) },
  { introI,
    exact (infer_instance : (preadditive_coyoneda.obj (op P) ⋙ forget _).preserves_epimorphisms) }
end

lemma projective_iff_preserves_epimorphisms_preadditive_coyoneda_obj' (P : C) :
  projective P ↔ (preadditive_coyoneda_obj (op P)).preserves_epimorphisms :=
begin
  rw projective_iff_preserves_epimorphisms_coyoneda_obj,
  refine ⟨λ (h : (preadditive_coyoneda_obj (op P) ⋙ (forget _)).preserves_epimorphisms), _, _⟩,
  { exactI functor.preserves_epimorphisms_of_preserves_of_reflects (preadditive_coyoneda_obj (op P))
      (forget _) },
  { introI,
    exact (infer_instance : (preadditive_coyoneda_obj (op P) ⋙ forget _).preserves_epimorphisms) }
end

end projective

end preadditive

end category_theory


/-
Copyright (c) 2017 Daniel Selsam. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Daniel Selsam

Properties of continuous functions.
-/
import .tfacts .util

namespace certigrad
namespace T
open list

axiom continuous_id : ∀ {ishape : S} (x : T ishape), is_continuous (λ (x₀ : T ishape), x₀) x
axiom continuous_const : ∀ {ishape oshape : S} (y : T oshape) (x : T ishape), is_continuous (λ (x₀ : T ishape), y) x

axiom continuous_add_fs {ishape oshape : S} (f g : T ishape → T oshape) (x : T ishape) :
  is_continuous f x → is_continuous g x → is_continuous (λ x₀, f x₀ + g x₀) x

lemma continuous_sumr {α : Type} {ishape oshape : S} (f : α → T ishape → T oshape) (x : T ishape) :
  ∀ (γs : list α), (∀ (γ : α), γ ∈ γs → is_continuous (λ (x₀ : T ishape), f γ x₀) x) →
  is_continuous (λ (x₀ : T ishape), list.sumr (map (λ γ, f γ x₀) γs)) x
| [] H := by apply (continuous_const 0)

| (γ::γs) H :=
begin
dunfold sumr map,
apply (continuous_add_fs _ _ _ (H γ mem_of_cons_same)),
apply continuous_sumr,
intros γ' H_γ',
exact H γ' (mem_cons_of_mem _ H_γ')
end

axiom continuous_chain_full {ishape oshape fshape : S} {f : T ishape → T oshape} {g : T ishape → T oshape → T fshape} {x : T ishape} :
  is_continuous f x → is_continuous (λ x₀, g x₀ (f x)) x → is_continuous (g x) (f x) → is_continuous (λ x₀, g x₀ (f x₀)) x

lemma continuous_chain {ishape oshape fshape : S} (f : T ishape → T oshape) (g : T oshape → T fshape) (x : T ishape) :
  is_continuous f x → is_continuous g (f x) → is_continuous (λ x, g (f x)) x :=
assume (H_cont_f : is_continuous f x) (H_cont_g : is_continuous g (f x)),
let h : T ishape → T oshape → T fshape := λ x y, g y in
have H_cont_h₁ : is_continuous (λ x₀, h x₀ (f x)) x, by apply (continuous_const (g (f x))),
have H_cont_h₂ : is_continuous (h x) (f x), from H_cont_g,
continuous_chain_full H_cont_f H_cont_h₁ H_cont_h₂

axiom continuous_binary {ishape oshape : S} (f : T ishape → T ishape → T oshape) (θ : T ishape) :
  is_continuous (λ θ₀, f θ₀ θ) θ → is_continuous (λ θ₀, f θ θ₀) θ → is_continuous (λ θ₀, f θ₀ θ₀) θ

lemma continuous_congr {ishape oshape : S} (f g : T ishape → T oshape) (x : T ishape) :
  (∀ x₀, g x₀ = f x₀) → is_continuous f x → is_continuous g x :=
begin intros H H_f, assert H_gf : g = f, { exact funext H }, rw H_gf, exact H_f end

axiom continuous_lift₀ {shape : S} (α : ℝ) : is_continuous (λ α : ℝ, const α shape) α
axiom continuous_scale {shape : S} (α : ℝ) (x : T shape) : is_continuous (λ x₀, α ⬝ x₀) x
axiom continuous_neg {shape : S} {θ : T shape} : is_continuous neg θ
axiom continuous_exp {shape : S} {θ : T shape} : is_continuous exp θ
axiom continuous_log {shape : S} {θ : T shape} : θ > 0 → is_continuous log θ
axiom continuous_sqrt {shape : S} {θ : T shape} : θ > 0 → is_continuous sqrt θ
axiom continuous_add₁ {shape : S} {θ x : T shape} : is_continuous (λ θ₀, θ₀ + x) θ
axiom continuous_add₂ {shape : S} {θ x : T shape} : is_continuous (λ θ₀, x + θ₀) θ
axiom continuous_mul₁ {shape : S} {θ x : T shape} : is_continuous (λ θ₀, θ₀ * x) θ
axiom continuous_mul₂ {shape : S} {θ x : T shape} : is_continuous (λ θ₀, x * θ₀) θ
axiom continuous_sub₁ {shape : S} {θ x : T shape} : is_continuous (λ θ₀, θ₀ - x) θ
axiom continuous_sub₂ {shape : S} {θ x : T shape} : is_continuous (λ θ₀, x - θ₀) θ
axiom continuous_div₁ {shape : S} {θ x : T shape} : square x > 0 → is_continuous (λ θ₀, θ₀ / x) θ
axiom continuous_div₂ {shape : S} {θ x : T shape} : square θ > 0 → is_continuous (λ θ₀, x / θ₀) θ
axiom continuous_sum {shape : S} {θ : T shape} : is_continuous sum θ
axiom continuous_gemm₁ {m n p : ℕ} (M : T [m, n]) (N : T [n, p]) : is_continuous (λ M₀, T.gemm M₀ N) M
axiom continuous_gemm₂ {m n p : ℕ} (M : T [m, n]) (N : T [n, p]) : is_continuous (λ N₀, T.gemm M N₀) N

lemma continuous_square {shape : S} (θ : T shape) : is_continuous (λ x, T.square x) θ :=
by { apply continuous_binary (λ θ₁ θ₂, θ₁ * θ₂), apply continuous_mul₁, apply continuous_mul₂ }

axiom continuous_mvn_pdf_μ {shape : S} (μ σ x : T shape) (H_σ : σ > 0) : is_continuous (λ θ, mvn_pdf θ σ x) μ
axiom continuous_mvn_pdf_σ {shape : S} (μ σ x : T shape) (H_σ : σ > 0) : is_continuous (λ θ, mvn_pdf μ θ x) σ

lemma continuous_scale_fs {ishape oshape : S} {f : T ishape → ℝ} {g : T ishape → T oshape} {θ : T ishape} :
                          is_continuous f θ → is_continuous g θ → is_continuous (λ θ₀, f θ₀ ⬝ g θ₀) θ :=
assume (H_cont_f : is_continuous f θ) (H_cont_g : is_continuous g θ),
begin
apply (continuous_binary (λ θ₁ θ₂, f θ₁ ⬝ g θ₂)),
apply (continuous_chain f (λ θ₀, θ₀ ⬝ g θ) _ H_cont_f),
simp [T.smul.def],
apply (continuous_chain (λ θ₀, const θ₀ oshape) (λ θ₀, g θ * θ₀) _),
apply continuous_lift₀,
apply continuous_mul₂,
apply (continuous_chain g (λ θ₀, f θ ⬝ θ₀) _ H_cont_g),
apply continuous_scale
end

lemma continuous_fscale {ishape oshape : S} {f : T ishape → ℝ} {x : T oshape} {θ : T ishape} :
                        is_continuous f θ → is_continuous (λ θ₀, f θ₀ ⬝ x) θ :=
assume (H_cont_f : is_continuous f θ),
begin
apply continuous_scale_fs,
exact H_cont_f,
apply continuous_const
end

lemma continuous_scale_f {ishape oshape : S} (α : ℝ) (f : T ishape → T oshape) (x : T ishape) : is_continuous f x → is_continuous (λ x₀, α ⬝ f x₀) x :=
assume (H_f_cont : is_continuous f x),
continuous_scale_fs (continuous_const α x) H_f_cont

-- Note: this could be proved from the `select`/`replicate` formulation,
-- but it is arguably a more natural way of axiomatizing the property.
axiom continuous_multiple_args :
  ∀ (parents : list reference) (oshape : S) (tgt : reference) (m : env)
    (f : dvec T parents^.p2 → T oshape) (θ : T tgt.2),
    (∀ (idx : ℕ), at_idx parents idx tgt →
    is_continuous (λ θ₀, f (dvec.update_at θ₀ (env.get_ks parents (env.insert tgt θ m)) idx)) θ)
    →
    is_continuous (λ θ₀, f (env.get_ks parents (env.insert tgt θ₀ m))) θ

end T

section tactic
open tactic

meta def prove_continuous_core : tactic unit :=
first [
       applyc `certigrad.T.continuous_id
     , applyc `certigrad.T.continuous_const
     , applyc `certigrad.T.continuous_add_fs
     , applyc `certigrad.T.continuous_sumr

     -- TODO(dhs): bug in Lean
     -- This causes a silent "sorry" in prove_continuous_core with
     -- no explanation
--     , applyc `certigrad.T.continuous_mvn_kl₁
--     , applyc `certigrad.T.continuous_mvn_kl₂,

     , applyc `certigrad.T.continuous_lift₀
     , applyc `certigrad.T.continuous_scale
     , applyc `certigrad.T.continuous_neg
     , applyc `certigrad.T.continuous_exp
     , applyc `certigrad.T.continuous_log
     , applyc `certigrad.T.continuous_sqrt
     , applyc `certigrad.T.continuous_add₁
     , applyc `certigrad.T.continuous_add₂
     , applyc `certigrad.T.continuous_mul₁
     , applyc `certigrad.T.continuous_mul₂
     , applyc `certigrad.T.continuous_sub₁
     , applyc `certigrad.T.continuous_sub₂
     , applyc `certigrad.T.continuous_div₁
     , applyc `certigrad.T.continuous_div₂
     , applyc `certigrad.T.continuous_sum
     , applyc `certigrad.T.continuous_gemm₁
     , applyc `certigrad.T.continuous_gemm₂
     , applyc `certigrad.T.continuous_square
     , applyc `certigrad.T.continuous_mvn_pdf_μ
     , applyc `certigrad.T.continuous_mvn_pdf_σ
     , applyc `certigrad.T.continuous_scale_fs
     , applyc `certigrad.T.continuous_scale_f
     , applyc `certigrad.T.continuous_chain
     , assumption
]

meta def prove_continuous : tactic unit := repeat (prove_continuous_core <|> prove_preconditions_core)

end tactic

namespace T

lemma continuous_mvn_kl₁ {shape : S} (μ σ : T shape) (H_σ : σ > 0) : is_continuous (λ μ₀, mvn_kl μ₀ σ) μ :=
by { dunfold mvn_kl, prove_continuous }

lemma continuous_mvn_kl₂ {shape : S} (μ σ : T shape) (H_σ : σ > 0) : is_continuous (λ σ₀, mvn_kl μ σ₀) σ :=
have H_σ₂ : square σ > 0, from square_pos_of_pos H_σ,
by { dunfold mvn_kl, prove_continuous }

lemma continuous_bernoulli_neglogpdf₁ {shape : S} (p x : T shape) (H_p₁ : p > 0) (H_p₂ : 1 - p > 0) :
is_continuous (λ p₀, bernoulli_neglogpdf p₀ x) p :=
by { dunfold bernoulli_neglogpdf, prove_continuous }

lemma continuous_bernoulli_neglogpdf₂ {shape : S} (p x : T shape) (H_p₁ : p > 0) (H_p₂ : 1 - p > 0) :
is_continuous (λ x₀, bernoulli_neglogpdf p x₀) x :=
begin
dunfold bernoulli_neglogpdf,
apply continuous_binary (λ θ₁ θ₂, - T.sum (θ₁ * T.log (eps shape + p) + (1 - θ₂) * T.log (eps shape + (1 + -p)))),
dsimp,
prove_continuous,
-- TODO(dhs): not sure why this is necessary
apply continuous_chain (λ x, 1 - x) (λ y, y * log (eps shape + (1 + - p))),
prove_continuous,
end

end T
end certigrad


import algebra.module.linear_map
import data.real.basic

def f (x y z : ℝ) : ℝ  := x-z
theorem cpge_applin_1_b [module ℝ (prod ℝ (prod ℝ ℝ))] [E : set (prod ℝ ℝ)]:
∃ g : (linear_map  ℝ (prod ℝ (prod ℝ ℝ)) ℝ),
∀ x y z : ℝ , (f x y z) = (g (x, y, z)) := sorry


-- Copyright © 2019 François G. Dorais. All rights reserved.
-- Released under Apache 2.0 license as described in the file LICENSE.

import .basic
import .substitution
import .homomorphism

namespace universal
variables {τ : Type} {σ : Type*} (sig : signature τ σ)

structure identity :=
(cod : τ)
(dom : list τ)
(eqn : equation sig dom cod)

variable {sig}

definition equation.to_identity {dom} {{cod}} : equation sig dom cod → identity sig :=
λ e, ⟨_, _, e⟩

definition term.to_identity {dom} {{cod}} : term sig dom cod → term sig dom cod → identity sig :=
λ x₁ x₂, ⟨_, _, ⟨x₁, x₂⟩⟩

namespace identity
variables {sig} (ax : identity sig)

abbreviation lhs : term sig ax.dom ax.cod := ax.eqn.lhs

abbreviation rhs : term sig ax.dom ax.cod := ax.eqn.rhs

abbreviation subst {dom : list τ} (sub : substitution sig ax.dom dom) : identity sig :=
{ cod := ax.cod
, dom := dom
, eqn := ax.eqn.subst sub
}

theorem subst_lhs {dom : list τ} (sub : substitution sig ax.dom dom) :
(ax.subst sub).lhs = ax.lhs.subst sub := rfl

theorem subst_rhs {dom : list τ} (sub : substitution sig ax.dom dom) :
(ax.subst sub).rhs = ax.rhs.subst sub := rfl

end identity

namespace algebra
variables (alg : algebra sig) {alg₁ : algebra sig} {alg₂ : algebra sig} (h : homomorphism alg₁ alg₂)

definition satisfies (ax : identity sig) : Prop :=
∀ (val : Π (i : index ax.dom), alg.sort i.val), alg.eval ax.lhs val = alg.eval ax.rhs val

theorem satisfies_of_injective_hom [homomorphism.injective h] (ax : identity sig) :
alg₂.satisfies ax → alg₁.satisfies ax :=
begin
intros H₂ val₁,
apply homomorphism.injective.elim h,
rw h.eval,
rw h.eval,
apply H₂,
end

theorem satisfies_of_surjective_hom [homomorphism.surjective h] (ax : identity sig) :
alg₁.satisfies ax → alg₂.satisfies ax :=
begin
intros H₁ val₂,
have : nonempty (Π (i : index ax.dom), { x : alg₁.sort i.val // h.map i.val x = val₂ i}),
begin
apply index.choice,
intro i,
cases homomorphism.surjective.elim h i.val (val₂ i) with x hx,
exact nonempty.intro ⟨x, hx⟩,
end,
cases this with pval₁,
let val₁ := λ i, (pval₁ i).val,
have : val₂ = (λ i, h.map _ (val₁ i)), from funext (λ i, eq.symm (pval₁ i).property),
rw this,
rw ← h.eval,
rw ← h.eval,
apply congr_arg,
apply H₁,
end

end algebra

end universal