/-
Copyright (c) 2019 Simon Hudon. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Simon Hudon
-/
import control.monad.basic
import data.fintype.basic
import data.list.prod_sigma

/-!
Type class for finitely enumerable types. The property is stronger
than `fintype` in that it assigns each element a rank in a finite
enumeration.
-/

universes u v
open finset

/-- `fin_enum α` means that `α` is finite and can be enumerated in some order,
  i.e. `α` has an explicit bijection with `fin n` for some n. -/
class fin_enum (α : Sort*) :=
(card : ℕ)
(equiv [] : α ≃ fin card)
[dec_eq : decidable_eq α]

attribute [instance, priority 100] fin_enum.dec_eq

namespace fin_enum

variables {α : Type u} {β : α → Type v}

/-- transport a `fin_enum` instance across an equivalence -/
def of_equiv (α) {β} [fin_enum α] (h : β ≃ α) : fin_enum β :=
{ card := card α,
  equiv := h.trans (equiv α),
  dec_eq := (h.trans (equiv _)).decidable_eq }

/-- create a `fin_enum` instance from an exhaustive list without duplicates -/
def of_nodup_list [decidable_eq α] (xs : list α) (h : ∀ x : α, x ∈ xs) (h' : list.nodup xs) :
  fin_enum α :=
{ card := xs.length,
  equiv := ⟨λ x, ⟨xs.index_of x,by rw [list.index_of_lt_length]; apply h⟩,
           λ ⟨i,h⟩, xs.nth_le _ h,
           λ x, by simp [of_nodup_list._match_1],
           λ ⟨i,h⟩, by simp [of_nodup_list._match_1,*]; rw list.nth_le_index_of;
             apply list.nodup_dedup ⟩ }

/-- create a `fin_enum` instance from an exhaustive list; duplicates are removed -/
def of_list [decidable_eq α] (xs : list α) (h : ∀ x : α, x ∈ xs) : fin_enum α :=
of_nodup_list xs.dedup (by simp *) (list.nodup_dedup _)

/-- create an exhaustive list of the values of a given type -/
def to_list (α) [fin_enum α] : list α :=
(list.fin_range (card α)).map (equiv α).symm

open function

@[simp] lemma mem_to_list [fin_enum α] (x : α) : x ∈ to_list α :=
by simp [to_list]; existsi equiv α x; simp

@[simp] lemma nodup_to_list [fin_enum α] : list.nodup (to_list α) :=
by simp [to_list]; apply list.nodup.map; [apply equiv.injective, apply list.nodup_fin_range]

/-- create a `fin_enum` instance using a surjection -/
def of_surjective {β} (f : β → α) [decidable_eq α] [fin_enum β] (h : surjective f) : fin_enum α :=
of_list ((to_list β).map f) (by intro; simp; exact h _)

/-- create a `fin_enum` instance using an injection -/
noncomputable def of_injective {α β} (f : α → β) [decidable_eq α] [fin_enum β] (h : injective f) :
  fin_enum α :=
of_list ((to_list β).filter_map (partial_inv f))
begin
  intro x,
  simp only [mem_to_list, true_and, list.mem_filter_map],
  use f x,
  simp only [h, function.partial_inv_left],
end

instance pempty : fin_enum pempty :=
of_list [] (λ x, pempty.elim x)

instance empty : fin_enum empty :=
of_list [] (λ x, empty.elim x)

instance punit : fin_enum punit :=
of_list [punit.star] (λ x, by cases x; simp)

instance prod {β} [fin_enum α] [fin_enum β] : fin_enum (α × β) :=
of_list ( (to_list α).product (to_list β) ) (λ x, by cases x; simp)

instance sum {β} [fin_enum α] [fin_enum β] : fin_enum (α ⊕ β) :=
of_list ( (to_list α).map sum.inl ++ (to_list β).map sum.inr ) (λ x, by cases x; simp)

instance fin {n} : fin_enum (fin n) :=
of_list (list.fin_range _) (by simp)

instance quotient.enum [fin_enum α] (s : setoid α)
  [decidable_rel ((≈) : α → α → Prop)] : fin_enum (quotient s) :=
fin_enum.of_surjective quotient.mk (λ x, quotient.induction_on x (λ x, ⟨x, rfl⟩))

/-- enumerate all finite sets of a given type -/
def finset.enum [decidable_eq α] : list α → list (finset α)
| [] := [∅]
| (x :: xs) :=
  do r ← finset.enum xs,
     [r,{x} ∪ r]

@[simp]lemma finset.mem_enum [decidable_eq α] (s : finset α) (xs : list α) :
  s ∈ finset.enum xs ↔ ∀ x ∈ s, x ∈ xs :=
begin
  induction xs generalizing s; simp [*,finset.enum],
  { simp [finset.eq_empty_iff_forall_not_mem,(∉)], refl },
  { split, rintro ⟨a,h,h'⟩ x hx,
    cases h',
    { right, apply h, subst a, exact hx, },
    { simp only [h', mem_union, mem_singleton] at hx ⊢, cases hx,
      { exact or.inl hx },
      { exact or.inr (h _ hx) } },
    intro h, existsi s \ ({xs_hd} : finset α),
    simp only [and_imp, union_comm, mem_sdiff, mem_singleton],
    simp only [or_iff_not_imp_left] at h,
    existsi h,
    by_cases xs_hd ∈ s,
    { have : {xs_hd} ⊆ s, simp only [has_subset.subset, *, forall_eq, mem_singleton],
      simp only [union_sdiff_of_subset this, or_true, finset.union_sdiff_of_subset,
        eq_self_iff_true], },
    { left, symmetry, simp only [sdiff_eq_self],
      intro a, simp only [and_imp, mem_inter, mem_singleton, not_mem_empty],
      intros h₀ h₁, subst a, apply h h₀, } }
end

instance finset.fin_enum [fin_enum α] : fin_enum (finset α) :=
of_list (finset.enum (to_list α)) (by intro; simp)

instance subtype.fin_enum [fin_enum α] (p : α → Prop) [decidable_pred p] : fin_enum {x // p x} :=
of_list ((to_list α).filter_map $ λ x, if h : p x then some ⟨_,h⟩ else none)
  (by rintro ⟨x,h⟩; simp; existsi x; simp *)

instance (β : α → Type v)
  [fin_enum α] [∀ a, fin_enum (β a)] : fin_enum (sigma β) :=
of_list
  ((to_list α).bind $ λ a, (to_list (β a)).map $ sigma.mk a)
  (by intro x; cases x; simp)

instance psigma.fin_enum [fin_enum α] [∀ a, fin_enum (β a)] :
  fin_enum (Σ' a, β a) :=
fin_enum.of_equiv _ (equiv.psigma_equiv_sigma _)

instance psigma.fin_enum_prop_left {α : Prop} {β : α → Type v} [∀ a, fin_enum (β a)] [decidable α] :
  fin_enum (Σ' a, β a) :=
if h : α then of_list ((to_list (β h)).map $ psigma.mk h) (λ ⟨a,Ba⟩, by simp)
else of_list [] (λ ⟨a,Ba⟩, (h a).elim)

instance psigma.fin_enum_prop_right {β : α → Prop} [fin_enum α] [∀ a, decidable (β a)] :
  fin_enum (Σ' a, β a) :=
fin_enum.of_equiv {a // β a} ⟨λ ⟨x, y⟩, ⟨x, y⟩, λ ⟨x, y⟩, ⟨x, y⟩, λ ⟨x, y⟩, rfl, λ ⟨x, y⟩, rfl⟩

instance psigma.fin_enum_prop_prop {α : Prop} {β : α → Prop} [decidable α] [∀ a, decidable (β a)] :
  fin_enum (Σ' a, β a) :=
if h : ∃ a, β a
  then of_list [⟨h.fst,h.snd⟩] (by rintro ⟨⟩; simp)
  else of_list [] (λ a, (h ⟨a.fst,a.snd⟩).elim)

@[priority 100]
instance [fin_enum α] : fintype α :=
{ elems := univ.map (equiv α).symm.to_embedding,
  complete := by intros; simp; existsi (equiv α x); simp }

/-- For `pi.cons x xs y f` create a function where every `i ∈ xs` is mapped to `f i` and
`x` is mapped to `y`  -/
def pi.cons [decidable_eq α] (x : α) (xs : list α) (y : β x)
  (f : Π a, a ∈ xs → β a) :
  Π a, a ∈ (x :: xs : list α) → β a
| b h :=
  if h' : b = x then cast (by rw h') y
    else f b (list.mem_of_ne_of_mem h' h)

/-- Given `f` a function whose domain is `x :: xs`, produce a function whose domain
is restricted to `xs`.  -/
def pi.tail {x : α} {xs : list α} (f : Π a, a ∈ (x :: xs : list α) → β a) :
  Π a, a ∈ xs → β a
| a h := f a (list.mem_cons_of_mem _ h)

/-- `pi xs f` creates the list of functions `g` such that, for `x ∈ xs`, `g x ∈ f x` -/
def pi {β : α → Type (max u v)} [decidable_eq α] : Π xs : list α, (Π a, list (β a)) →
  list (Π a, a ∈ xs → β a)
| [] fs := [λ x h, h.elim]
| (x :: xs) fs :=
  fin_enum.pi.cons x xs <$> fs x <*> pi xs fs

lemma mem_pi {β : α → Type (max u v)} [fin_enum α] [∀a, fin_enum (β a)] (xs : list α)
  (f : Π a, a ∈ xs → β a) :
  f ∈ pi xs (λ x, to_list (β x)) :=
begin
  induction xs; simp [pi,-list.map_eq_map] with monad_norm functor_norm,
  { ext a ⟨ ⟩ },
  { existsi pi.cons xs_hd xs_tl (f _ (list.mem_cons_self _ _)),
    split, exact ⟨_,rfl⟩,
    existsi pi.tail f, split,
    { apply xs_ih, },
    { ext x h, simp [pi.cons], split_ifs, subst x, refl, refl }, }
end

/-- enumerate all functions whose domain and range are finitely enumerable -/
def pi.enum (β : α → Type (max u v)) [fin_enum α] [∀a, fin_enum (β a)] : list (Π a, β a) :=
(pi (to_list α) (λ x, to_list (β x))).map (λ f x, f x (mem_to_list _))

lemma pi.mem_enum {β : α → Type (max u v)} [fin_enum α] [∀a, fin_enum (β a)] (f : Π a, β a) :
  f ∈ pi.enum β :=
by simp [pi.enum]; refine ⟨λ a h, f a, mem_pi _ _, rfl⟩

instance pi.fin_enum {β : α → Type (max u v)}
  [fin_enum α] [∀a, fin_enum (β a)] : fin_enum (Πa, β a) :=
of_list (pi.enum _) (λ x, pi.mem_enum _)

instance pfun_fin_enum (p : Prop) [decidable p] (α : p → Type*)
  [Π hp, fin_enum (α hp)] : fin_enum (Π hp : p, α hp) :=
if hp : p then of_list ( (to_list (α hp)).map $ λ x hp', x ) (by intro; simp; exact ⟨x hp,rfl⟩)
          else of_list [λ hp', (hp hp').elim] (by intro; simp; ext hp'; cases hp hp')

end fin_enum


/-
Copyright (c) 2022 María Inés de Frutos-Fernández, Filippo A. E. Nuccio. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: María Inés de Frutos-Fernández, Filippo A. E. Nuccio
-/
import ring_theory.dedekind_domain.integral_closure

import algebra_comp
import padic

/-!
--TODO: Fix comments
# Mixed characteristic local fields
This file defines a number field, the ring of integers corresponding to it and includes some
basic facts about the embeddings into an algebraic closed field.
## Main definitions
 - `mixed_char_local_field` defines a number field as a field which has characteristic zero and is
    finite dimensional over ℚ.
 - `ring_of_integers` defines the ring of integers (or number ring) corresponding to a number field
    as the integral closure of ℤ in the number field.
## Main Result
 - `eq_roots`: let `x ∈ K` with `K` number field and let `A` be an algebraic closed field of
    char. 0, then the images of `x` by the embeddings of `K` in `A` are exactly the roots in
    `A` of the minimal polynomial of `x` over `ℚ`.
## Implementation notes
The definitions that involve a field of fractions choose a canonical field of fractions,
but are independent of that choice.
## References
* [D. Marcus, *Number Fields*][marcus1977number]
* [J.W.S. Cassels, A. Fröhlich, *Algebraic Number Theory*][cassels1967algebraic]
* [P. Samuel, *Algebraic Theory of Numbers*][samuel1970algebraic]
## Tags
number field, ring of integers
-/

noncomputable theory

-- For instances and lemmas that only need `K` to be a `ℚₚ`-algebra
namespace padic_algebra

variables (p : ℕ) [fact(nat.prime p)] (K L : Type*) [field K] [hK : algebra ℚ_[p] K] [field L]
  [algebra ℚ_[p] L]

include hK

instance to_int_algebra : algebra ℤ_[p] K := algebra.comp ℤ_[p] ℚ_[p] K
--(ring_hom.comp hK.to_ring_hom (@padic_int.coe.ring_hom p _)).to_algebra

@[simp] lemma int_algebra_map_def : algebra_map ℤ_[p] K =
  (padic_algebra.to_int_algebra p K).to_ring_hom := rfl

@[priority 10000] instance : is_scalar_tower ℤ_[p] ℚ_[p] K := is_scalar_tower.comp ℤ_[p] ℚ_[p] K
/- ⟨λ _ _ _, begin
  simp only [algebra.smul_def, int_algebra_map_def, padic.algebra_map_def, map_mul,
    ring_hom.comp_apply, ← mul_assoc],
  refl,
end⟩ -/

@[priority 1000] instance int_is_scalar_tower [algebra K L] [is_scalar_tower ℚ_[p] K L] :
  is_scalar_tower ℤ_[p] K L :=
is_scalar_tower.comp' ℤ_[p] ℚ_[p] K L
/- { smul_assoc := λ x y z,
  begin
    nth_rewrite 0 [← one_smul ℚ_[p] y],
    rw [← one_smul ℚ_[p] (y • z), ← smul_assoc, ← smul_assoc, ← smul_assoc],
  end } -/

omit hK

lemma algebra_map_injective {E : Type*} [field E] [algebra ℤ_[p] E] [algebra ℚ_[p] E]
  [is_scalar_tower ℤ_[p] ℚ_[p] E] : function.injective ⇑(algebra_map ℤ_[p] E) :=
algebra_map_injective' ℤ_[p] ℚ_[p] E

end padic_algebra

/-- A mixed characteristic local field is a field which has characteristic zero and is finite
dimensional over `ℚ_[p]`, for some prime `p`. -/
class mixed_char_local_field (p : out_param(ℕ)) [fact(nat.prime p)] (K : Type*) [field K]
  extends algebra ℚ_[p] K :=
[to_finite_dimensional : finite_dimensional ℚ_[p] K]

@[priority 100, nolint dangerous_instance]
instance mixed_char_local_field.to_char_zero (p : out_param(ℕ)) [fact(nat.prime p)]
  (K : Type*) [field K] [mixed_char_local_field p K] : char_zero K :=
⟨λ n m h, by rwa [← map_nat_cast (algebra_map ℚ_[p] K), ← map_nat_cast (algebra_map ℚ_[p] K),
  (algebra_map ℚ_[p] K).injective.eq_iff, nat.cast_inj] at h⟩

attribute [priority 100, instance] mixed_char_local_field.to_finite_dimensional

/- attribute [nolint dangerous_instance] mixed_char_local_field.to_char_zero

-- See note [lower instance priority]
attribute [priority 100, instance] mixed_char_local_field.to_char_zero
  mixed_char_local_field.to_finite_dimensional -/

namespace mixed_char_local_field

variables (p : ℕ) [fact(nat.prime p)] (K L : Type*) [field K] [mixed_char_local_field p K] [field L]
  [mixed_char_local_field p L]

-- We need to mark this one with high priority to avoid timeouts.
@[priority 10000] instance : is_scalar_tower ℤ_[p] ℚ_[p] K := infer_instance

protected lemma is_algebraic : algebra.is_algebraic ℚ_[p] K := algebra.is_algebraic_of_finite _ _

/-- The ring of integers of a mixed characteristic local field is the integral closure of ℤ_[p]
  in the local field. -/
def ring_of_integers := integral_closure ℤ_[p] K

localized "notation (name := ring_of_integers)
  `𝓞` := mixed_char_local_field.ring_of_integers" in mixed_char_local_field

lemma mem_ring_of_integers (x : K) : x ∈ 𝓞 p K ↔ is_integral ℤ_[p] x := iff.rfl

lemma is_integral_of_mem_ring_of_integers {x : K} (hx : x ∈ 𝓞 p K) :
  is_integral ℤ_[p] (⟨x, hx⟩ : 𝓞 p K) :=
begin
  obtain ⟨P, hPm, hP⟩ := hx,
  refine ⟨P, hPm, _⟩,
  rw [← polynomial.aeval_def, ← subalgebra.coe_eq_zero, polynomial.aeval_subalgebra_coe,
    polynomial.aeval_def,  subtype.coe_mk, hP],
end

/-- Given an algebra between two local fields over ℚ_[p], create an algebra between their two rings
of integers. For now, this is not an instance by default as it creates an equal-but-not-defeq
diamond with `algebra.id` when `K = L`. This is caused by `x = ⟨x, x.prop⟩` not being defeq on
subtypes. This will likely change in Lean 4. -/
def ring_of_integers_algebra [algebra K L] [is_scalar_tower ℚ_[p] K L] : algebra (𝓞 p K) (𝓞 p L) :=
ring_hom.to_algebra
{ to_fun := λ k, ⟨algebra_map K L k, is_integral.algebra_map k.2⟩,
  map_zero' := subtype.ext $ by simp only [subtype.coe_mk, subalgebra.coe_zero, map_zero],
  map_one'  := subtype.ext $ by simp only [subtype.coe_mk, subalgebra.coe_one, map_one],
  map_add'  := λ x y, subtype.ext $ by simp only [map_add, subalgebra.coe_add, subtype.coe_mk],
  map_mul'  := λ x y, subtype.ext $ by simp only [subalgebra.coe_mul, map_mul, subtype.coe_mk] }

namespace ring_of_integers

variables {K}

--set_option profiler true
-- Takes 2.62 s
--set_option trace.class_instances true
-- I had to increase the priority of `mixed_char_local_field.is_scalar_tower` for this to work.
-- Otherwise it times out if the is_scalar_tower argument is implicit
noncomputable! instance : is_fraction_ring (𝓞 p K) K :=
integral_closure.is_fraction_ring_of_finite_extension ℚ_[p] _

instance : is_integral_closure (𝓞 p K) ℤ_[p] K :=
integral_closure.is_integral_closure _ _

--set_option profiler true
-- Takes 3.29 s
-- Times out if the is_scalar_tower argument is implicit (without the priority fix)
noncomputable! instance : is_integrally_closed (𝓞 p K) :=
integral_closure.is_integrally_closed_of_finite_extension ℚ_[p]

lemma is_integral_coe (x : 𝓞 p K) : is_integral ℤ_[p] (x : K) := x.2

/-- The ring of integers of `K` is equivalent to any integral closure of `ℤ_[p]` in `K` -/
protected noncomputable! def equiv (R : Type*) [comm_ring R] [algebra ℤ_[p] R] [algebra R K]
  [is_scalar_tower ℤ_[p] R K] [is_integral_closure R ℤ_[p] K] : 𝓞 p K ≃+* R :=
(is_integral_closure.equiv ℤ_[p] R K _).symm.to_ring_equiv

variables (K)

instance : char_zero (𝓞 p K) := char_zero.of_module _ K

noncomputable! instance : is_noetherian ℤ_[p] (𝓞 p K) :=
is_integral_closure.is_noetherian ℤ_[p] ℚ_[p] K (𝓞 p K)

noncomputable! lemma algebra_map_injective :
  function.injective ⇑(algebra_map ℤ_[p] (ring_of_integers p K)) :=
begin
  have hinj : function.injective ⇑(algebra_map ℤ_[p] K),
  { exact algebra_map_injective' ℤ_[p] ℚ_[p] K},
  rw injective_iff_map_eq_zero (algebra_map ℤ_[p] ↥(𝓞 p K)),
  intros x hx,
  rw [← subtype.coe_inj, subalgebra.coe_zero] at hx,
  rw injective_iff_map_eq_zero (algebra_map ℤ_[p] K) at hinj,
  exact hinj x hx,
end

/-- The ring of integers of a mixed characteristic local field is not a field. -/
lemma not_is_field : ¬ is_field (𝓞 p K) :=
by simpa [← (is_integral_closure.is_integral_algebra ℤ_[p] K).is_field_iff_is_field
  (algebra_map_injective p K)] using (padic_int.not_is_field p)

noncomputable! instance : is_dedekind_domain (𝓞 p K) :=
is_integral_closure.is_dedekind_domain ℤ_[p] ℚ_[p] K _

-- TODO : ring of integers is local
noncomputable!  instance : local_ring (𝓞 p K) :=
{ exists_pair_ne := ⟨0, 1, zero_ne_one⟩,
  is_unit_or_is_unit_of_add_one := λ a b hab,
  begin
    by_cases ha : is_unit a,
    { exact or.inl ha, },
    { right, sorry }
  end }

end ring_of_integers

end mixed_char_local_field

namespace padic

open mixed_char_local_field

instance mixed_char_local_field (p : ℕ) [fact(nat.prime p)] : mixed_char_local_field p ℚ_[p] :=
{ to_finite_dimensional :=
  -- The vector space structure of `ℚ` over itself can arise in multiple ways:
  -- all fields are vector spaces over themselves (used in `rat.finite_dimensional`)
  -- all char 0 fields have a canonical embedding of `ℚ` (used in `mixed_char_local_field`).
  -- Show that these coincide:
  by convert (infer_instance : finite_dimensional ℚ_[p] ℚ_[p]), }

/-- The ring of integers of `ℚ_[p]` as a mixed characteristic local field is just `ℤ_[p]`. -/
noncomputable def ring_of_integers_equiv (p : ℕ) [fact(nat.prime p)] :
  ring_of_integers p ℚ_[p] ≃+* ℤ_[p] :=
ring_of_integers.equiv p ℤ_[p]

end padic


/-
Copyright (c) 2014 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Leonardo de Moura
-/
prelude
import Init.SizeOf
import Init.Data.Nat.Basic

universe u v

set_option codegen false

inductive Acc {α : Sort u} (r : α → α → Prop) : α → Prop where
  | intro (x : α) (h : (y : α) → r y x → Acc r y) : Acc r x

abbrev Acc.ndrec.{u1, u2} {α : Sort u2} {r : α → α → Prop} {C : α → Sort u1}
    (m : (x : α) → ((y : α) → r y x → Acc r y) → ((y : α) → (a : r y x) → C y) → C x)
    {a : α} (n : Acc r a) : C a :=
Acc.rec (motive := fun α _ => C α) m n

abbrev Acc.ndrecOn.{u1, u2} {α : Sort u2} {r : α → α → Prop} {C : α → Sort u1}
    {a : α} (n : Acc r a)
    (m : (x : α) → ((y : α) → r y x → Acc r y) → ((y : α) → (a : r y x) → C y) → C x)
    : C a :=
Acc.rec (motive := fun α _ => C α) m n

namespace Acc
variable {α : Sort u} {r : α → α → Prop}

def inv {x y : α} (h₁ : Acc r x) (h₂ : r y x) : Acc r y :=
Acc.recOn (motive := fun (x : α) _ => r y x → Acc r y)
  h₁ (fun x₁ ac₁ ih h₂ => ac₁ y h₂) h₂

end Acc

inductive WellFounded {α : Sort u} (r : α → α → Prop) : Prop where
  | intro (h : ∀ a, Acc r a) : WellFounded r

namespace WellFounded
def apply {α : Sort u} {r : α → α → Prop} (wf : WellFounded r) (a : α) : Acc r a :=
  WellFounded.recOn (motive := fun x => (y : α) → Acc r y)
    wf (fun p => p) a

section
variable {α : Sort u} {r : α → α → Prop} (hwf : WellFounded r)

theorem recursion {C : α → Sort v} (a : α) (h : ∀ x, (∀ y, r y x → C y) → C x) : C a := by
  induction (apply hwf a) with
  | intro x₁ ac₁ ih => exact h x₁ ih

theorem induction {C : α → Prop} (a : α) (h : ∀ x, (∀ y, r y x → C y) → C x) : C a :=
  recursion hwf a h

variable {C : α → Sort v}
variable (F : ∀ x, (∀ y, r y x → C y) → C x)

def fixF (x : α) (a : Acc r x) : C x := by
  induction a with
  | intro x₁ ac₁ ih => exact F x₁ ih

def fixFEq (x : α) (acx : Acc r x) : fixF F x acx = F x (fun (y : α) (p : r y x) => fixF F y (Acc.inv acx p)) := by
  induction acx with
  | intro x r ih => exact rfl

end

variable {α : Sort u} {C : α → Sort v} {r : α → α → Prop}

-- Well-founded fixpoint
def fix (hwf : WellFounded r) (F : ∀ x, (∀ y, r y x → C y) → C x) (x : α) : C x :=
  fixF F x (apply hwf x)

-- Well-founded fixpoint satisfies fixpoint equation
theorem fix_eq (hwf : WellFounded r) (F : ∀ x, (∀ y, r y x → C y) → C x) (x : α) :
    fix hwf F x = F x (fun y h => fix hwf F y) :=
  fixFEq F x (apply hwf x)
end WellFounded

open WellFounded

-- Empty relation is well-founded
def emptyWf {α : Sort u} : WellFounded (@emptyRelation α) := by
  apply WellFounded.intro
  intro a
  apply Acc.intro a
  intro b h
  cases h

-- Subrelation of a well-founded relation is well-founded
namespace Subrelation
variable {α : Sort u} {r q : α → α → Prop}

def accessible {a : α} (h₁ : Subrelation q r) (ac : Acc r a) : Acc q a := by
  induction ac with
  | intro x ax ih =>
    apply Acc.intro
    intro y h
    exact ih y (h₁ h)

def wf (h₁ : Subrelation q r) (h₂ : WellFounded r) : WellFounded q :=
  ⟨fun a => accessible @h₁ (apply h₂ a)⟩
end Subrelation

-- The inverse image of a well-founded relation is well-founded
namespace InvImage
variable {α : Sort u} {β : Sort v} {r : β → β → Prop}

private def accAux (f : α → β) {b : β} (ac : Acc r b) : (x : α) → f x = b → Acc (InvImage r f) x := by
  induction ac with
  | intro x acx ih =>
    intro z e
    apply Acc.intro
    intro y lt
    subst x
    apply ih (f y) lt y rfl

def accessible {a : α} (f : α → β) (ac : Acc r (f a)) : Acc (InvImage r f) a :=
  accAux f ac a rfl

def wf (f : α → β) (h : WellFounded r) : WellFounded (InvImage r f) :=
  ⟨fun a => accessible f (apply h (f a))⟩
end InvImage

def invImage (f : α → β) (h : WellFounded r) : WellFounded (InvImage r f) :=
  InvImage.wf f h

-- The transitive closure of a well-founded relation is well-founded
namespace TC
variable {α : Sort u} {r : α → α → Prop}

def accessible {z : α} (ac : Acc r z) : Acc (TC r) z := by
  induction ac with
  | intro x acx ih =>
    apply Acc.intro x
    intro y rel
    induction rel with
    | base a b rab => exact ih a rab
    | trans a b c rab rbc ih₁ ih₂ => apply Acc.inv (ih₂ acx ih) rab

def wf (h : WellFounded r) : WellFounded (TC r) :=
  ⟨fun a => accessible (apply h a)⟩
end TC

-- less-than is well-founded
def Nat.lt_wf : WellFounded Nat.lt := by
  apply WellFounded.intro
  intro n
  induction n with
  | zero      =>
    apply Acc.intro 0
    intro _ h
    apply absurd h (Nat.not_lt_zero _)
  | succ n ih =>
    apply Acc.intro (Nat.succ n)
    intro m h
    have : m = n ∨ m < n := Nat.eq_or_lt_of_le (Nat.le_of_succ_le_succ h)
    match this with
    | Or.inl e => subst e; assumption
    | Or.inr e => exact Acc.inv ih e

def Measure {α : Sort u} : (α → Nat) → α → α → Prop :=
  InvImage (fun a b => a < b)

def measure {α : Sort u} (f : α → Nat) : WellFounded (Measure f) :=
  invImage f Nat.lt_wf

def SizeofMeasure (α : Sort u) [SizeOf α] : α → α → Prop :=
  Measure sizeOf

def sizeofMeasure (α : Sort u) [SizeOf α] : WellFounded (SizeofMeasure α) :=
  measure sizeOf

namespace Prod
open WellFounded

section
variable {α : Type u} {β : Type v}
variable  (ra  : α → α → Prop)
variable  (rb  : β → β → Prop)

-- Lexicographical order based on ra and rb
inductive Lex : α × β → α × β → Prop where
  | left  {a₁} (b₁) {a₂} (b₂) (h : ra a₁ a₂) : Lex (a₁, b₁) (a₂, b₂)
  | right (a) {b₁ b₂} (h : rb b₁ b₂)         : Lex (a, b₁)  (a, b₂)

-- relational product based on ra and rb
inductive RProd : α × β → α × β → Prop where
  | intro {a₁ b₁ a₂ b₂} (h₁ : ra a₁ a₂) (h₂ : rb b₁ b₂) : RProd (a₁, b₁) (a₂, b₂)
end

section

variable {α : Type u} {β : Type v}
variable {ra  : α → α → Prop} {rb  : β → β → Prop}

def lexAccessible (aca : (a : α) → Acc ra a) (acb : (b : β) → Acc rb b) (a : α) (b : β) : Acc (Lex ra rb) (a, b) := by
  induction (aca a) generalizing b with
  | intro xa aca iha =>
    induction (acb b) with
    | intro xb acb ihb =>
      apply Acc.intro (xa, xb)
      intro p lt
      cases lt with
      | left  _ _ h => apply iha _ h
      | right _ h   => apply ihb _ h

-- The lexicographical order of well founded relations is well-founded
def lex (ha : WellFounded ra) (hb : WellFounded rb) : WellFounded (Lex ra rb) :=
  ⟨fun (a, b) => lexAccessible (WellFounded.apply ha) (WellFounded.apply hb) a b⟩

-- relational product is a Subrelation of the Lex
def RProdSubLex (a : α × β) (b : α × β) (h : RProd ra rb a b) : Lex ra rb a b := by
  cases h with
  | intro h₁ h₂ => exact Lex.left _ _ h₁

-- The relational product of well founded relations is well-founded
def rprod (ha : WellFounded ra) (hb : WellFounded rb) : WellFounded (RProd ra rb) := by
  apply Subrelation.wf (r := Lex ra rb) (h₂ := lex ha hb)
  intro a b h
  exact RProdSubLex a b h

end

end Prod

namespace PSigma
section
variable {α : Sort u} {β : α → Sort v}
variable  (r  : α → α → Prop)
variable  (s  : ∀ a, β a → β a → Prop)

-- Lexicographical order based on r and s
inductive Lex : PSigma β → PSigma β → Prop where
  | left  : ∀ {a₁ : α} (b₁ : β a₁) {a₂ : α} (b₂ : β a₂), r a₁ a₂ → Lex ⟨a₁, b₁⟩ ⟨a₂, b₂⟩
  | right : ∀ (a : α)  {b₁ b₂ : β a}, s a b₁ b₂ → Lex ⟨a, b₁⟩ ⟨a, b₂⟩
end

section
variable {α : Sort u} {β : α → Sort v}
variable {r  : α → α → Prop} {s : ∀ (a : α), β a → β a → Prop}

def lexAccessible {a} (aca : Acc r a) (acb : (a : α) → WellFounded (s a)) (b : β a) : Acc (Lex r s) ⟨a, b⟩ := by
  induction aca with
  | intro xa aca iha =>
    induction (WellFounded.apply (acb xa) b) with
    | intro xb acb ihb =>
      apply Acc.intro
      intro p lt
      cases lt with
      | left  => apply iha; assumption
      | right => apply ihb; assumption

-- The lexicographical order of well founded relations is well-founded
def lex (ha : WellFounded r) (hb : (x : α) → WellFounded (s x)) : WellFounded (Lex r s) :=
  WellFounded.intro fun ⟨a, b⟩ => lexAccessible (WellFounded.apply ha a) hb b
end

section
variable {α : Sort u} {β : Sort v}

def lexNdep (r : α → α → Prop) (s : β → β → Prop) :=
  Lex r (fun a => s)

def lexNdepWf {r  : α → α → Prop} {s : β → β → Prop} (ha : WellFounded r) (hb : WellFounded s) : WellFounded (lexNdep r s) :=
  WellFounded.intro fun ⟨a, b⟩ => lexAccessible (WellFounded.apply ha a) (fun x => hb) b
end

section
variable {α : Sort u} {β : Sort v}

-- Reverse lexicographical order based on r and s
inductive RevLex (r  : α → α → Prop) (s  : β → β → Prop) : @PSigma α (fun a => β) → @PSigma α (fun a => β) → Prop where
  | left  : {a₁ a₂ : α} → (b : β) → r a₁ a₂ → RevLex r s ⟨a₁, b⟩ ⟨a₂, b⟩
  | right : (a₁ : α) → {b₁ : β} → (a₂ : α) → {b₂ : β} → s b₁ b₂ → RevLex r s ⟨a₁, b₁⟩ ⟨a₂, b₂⟩
end

section
open WellFounded
variable {α : Sort u} {β : Sort v}
variable {r  : α → α → Prop} {s : β → β → Prop}

def revLexAccessible {b} (acb : Acc s b) (aca : (a : α) → Acc r a): (a : α) → Acc (RevLex r s) ⟨a, b⟩ := by
  induction acb with
  | intro xb acb ihb =>
    intro a
    induction (aca a) with
    | intro xa aca iha =>
      apply Acc.intro
      intro p lt
      cases lt with
      | left  => apply iha; assumption
      | right => apply ihb; assumption

def revLex (ha : WellFounded r) (hb : WellFounded s) : WellFounded (RevLex r s) :=
  WellFounded.intro fun ⟨a, b⟩ => revLexAccessible (apply hb b) (WellFounded.apply ha) a
end

section
def SkipLeft (α : Type u) {β : Type v} (s : β → β → Prop) : @PSigma α (fun a => β) → @PSigma α (fun a => β) → Prop :=
  RevLex emptyRelation s

def skipLeft (α : Type u) {β : Type v} {s : β → β → Prop} (hb : WellFounded s) : WellFounded (SkipLeft α s) :=
  revLex emptyWf hb

def mkSkipLeft {α : Type u} {β : Type v} {b₁ b₂ : β} {s : β → β → Prop} (a₁ a₂ : α) (h : s b₁ b₂) : SkipLeft α s ⟨a₁, b₁⟩ ⟨a₂, b₂⟩ :=
  RevLex.right _ _ h
end

end PSigma


/-
Copyright (c) 2022 Devon Tuma. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Devon Tuma
-/
import computational_monads.simulation_semantics.constructions.tracking_oracle

/-!
# Query Counting Simulation Oracle

Defines a simple `counting_oracle` simulation oracle that just counts the number of queries made.
The internal state of the oracle is exactly a `n : ℕ` giving the amount of queries at that point.
This value is always finite as the `oracle_comp` monad doesn't have unbounded recursion.

-/

open oracle_comp oracle_spec

variables {α β γ : Type} {spec spec' : oracle_spec}
  (oa : oracle_comp spec α) (ob : α → oracle_comp spec β) (n m : ℕ)

/-- Simulation oracle that just counts the number of queries to the oracles -/
def counting_oracle (spec : oracle_spec) : sim_oracle spec spec ℕ :=
⟪query | λ n _ _ _, n + 1 , 0⟫

namespace counting_oracle

lemma apply_eq (i : spec.ι) (x : spec.domain i × ℕ) :
  counting_oracle spec i x = do {u ← query i x.1, return (u, (x.2 + 1 : ℕ))} :=
tracking_oracle.apply_eq query (λ n _ _ _, n + 1) 0 i x

section support

@[simp] lemma support_apply (i : spec.ι) (x : spec.domain i × ℕ) :
  (counting_oracle spec i x).support = {y | x.2 + 1 = y.2} :=
begin
  refine trans (tracking_oracle.support_apply query _ 0 i x) _,
  ext x,
  simp only [prod.eq_iff_fst_eq_snd_eq, support_query, set.top_eq_univ, set.image_univ,
    set.mem_range, exists_eq_left, set.mem_set_of_eq],
end

end support

section distribution_semantics

section prob_event

end prob_event

end distribution_semantics

end counting_oracle


/-
Copyright (c) 2023 María Inés de Frutos-Fernández. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: María Inés de Frutos-Fernández
-/
import pow_mult_faithful
import seminorm_from_const
import spectral_norm

/-!
# Unique norm extension theorem

Let `K` be a field complete with respect to a nontrivial nonarchimedean multiplicative norm and
`L/K` be an algebraic extension. We show that the spectral norm on `L` is a nonarchimedean
multiplicative norm, and any power-multiplicative `K`-algebra norm on `L` coincides with the
spectral norm. More over, if `L/K` is finite, then `L` is a complete space.
This result is [BGR, Theorem 3.2.4/2].

## Main Definitions

* `spectral_mul_alg_norm` : the spectral norm is a multiplicative `K`-algebra norm on `L`.

## Main Results
* `spectral_norm_unique'` : any power-multiplicative `K`-algebra norm on `L` coincides with the
  spectral norm.
* `spectral_norm_is_mul` : the spectral norm on `L` is multiplicative.
* `spectral_norm_complete_space` : if `L/K` is finite dimensional, then `L` is a complete space
  with respect to topology induced by the spectral norm.

## References
* [S. Bosch, U. Güntzer, R. Remmert, *Non-Archimedean Analysis*][bosch-guntzer-remmert]

## Tags

spectral, spectral norm, unique, seminorm, norm, nonarchimedean
-/

noncomputable theory

open_locale nnreal

variables {K : Type*} [nontrivially_normed_field K] {L : Type*} [field L] [algebra K L]
  (h_alg : algebra.is_algebraic K L)

/--If `K` is a field complete with respect to a nontrivial nonarchimedean multiplicative norm and
  `L/K` is an algebraic extension, then any power-multiplicative `K`-algebra norm on `L` coincides
  with the spectral norm. -/
lemma spectral_norm_unique' [complete_space K] {f : algebra_norm K L} (hf_pm : is_pow_mul f)
  (hna : is_nonarchimedean (norm : K → ℝ)) : f = spectral_alg_norm h_alg hna :=
begin
  apply eq_of_pow_mult_faithful f hf_pm _
    (spectral_alg_norm_is_pow_mul h_alg hna),
  intro x,
  set E : Type* := id K⟮x⟯ with hEdef,
  letI hE : field E := (by rw [hEdef, id.def] ; apply_instance),
  letI : algebra K E := K⟮x⟯.algebra,
  set id1 : K⟮x⟯ →ₗ[K] E :=
  { to_fun := id,
    map_add' := λ x y, rfl,
    map_smul' := λ r x, rfl, },
  set id2 : E →ₗ[K] K⟮x⟯ :=
  { to_fun := id,
    map_add' := λ x y, rfl,
    map_smul' := λ r x, rfl },
  set hs_norm : ring_norm E :=
  { to_fun    := (λ y : E, spectral_norm K L (id2 y : L)),
    map_zero' := by rw [map_zero, subfield.coe_zero, spectral_norm_zero],
    add_le'   := λ a b,
    by simp only [← spectral_alg_norm_def h_alg hna, subfield.coe_add]; exact map_add_le_add _ _ _,
    neg'      := λ a,
    by simp only [← spectral_alg_norm_def h_alg hna, subfield.coe_neg, map_neg, map_neg_eq_map],
    mul_le'  := λ a b,
    by simp only [← spectral_alg_norm_def h_alg hna, subfield.coe_mul]; exact map_mul_le_mul _ _ _,
    eq_zero_of_map_eq_zero' := λ a ha,
    begin
      simp only [←spectral_alg_norm_def h_alg hna, linear_map.coe_mk, id.def,
        map_eq_zero_iff_eq_zero, algebra_map.lift_map_eq_zero_iff] at ha,
      exact ha
    end },
  letI n1 : normed_ring E := norm_to_normed_ring hs_norm,
  letI N1 : normed_space K E :=
  { norm_smul_le := λ k y,
    begin
      change (spectral_alg_norm h_alg hna (id2 (k • y) : L) : ℝ) ≤
        ‖ k ‖ * spectral_alg_norm h_alg hna (id2 y : L),
      simp only [linear_map.coe_mk, id.def, intermediate_field.coe_smul, map_smul_eq_mul],
    end,
    ..K⟮x⟯.algebra },
  set hf_norm : ring_norm K⟮x⟯ :=
  { to_fun := λ y, f((algebra_map K⟮x⟯ L) y),
    map_zero' := map_zero _,
    add_le'  := λ a b, map_add_le_add _ _ _,
    neg' := λ y, by { simp only [map_neg, map_neg_eq_map] },
    mul_le'  := λ a b, map_mul_le_mul _ _ _,
    eq_zero_of_map_eq_zero' := λ a ha,
    begin
      simp only [map_eq_zero_iff_eq_zero, map_eq_zero] at ha,
      exact ha
    end },
  letI n2 : normed_ring K⟮x⟯ := norm_to_normed_ring hf_norm,
  letI N2 : normed_space K K⟮x⟯ :=
  { norm_smul_le :=  λ k y,
    begin
      change (f ((algebra_map K⟮x⟯ L) (k • y)) : ℝ) ≤ ‖ k ‖ * f (algebra_map K⟮x⟯ L y),
      have : (algebra_map ↥K⟮x⟯ L) (k • y) = k • (algebra_map ↥K⟮x⟯ L y),
      { rw [← is_scalar_tower.algebra_map_smul K⟮x⟯ k y, smul_eq_mul, map_mul,
          ← is_scalar_tower.algebra_map_apply K ↥K⟮x⟯ L, algebra.smul_def] },
      rw [ this, map_smul_eq_mul],
    end,
    ..K⟮x⟯.algebra },
  haveI hKx_fin : finite_dimensional K ↥K⟮x⟯ := intermediate_field.adjoin.finite_dimensional
    (is_algebraic_iff_is_integral.mp (h_alg x)),
  haveI : finite_dimensional K E := hKx_fin,
  set Id1 : K⟮x⟯ →L[K] E := ⟨id1, id1.continuous_of_finite_dimensional⟩ with hId1,
  set Id2 : E →L[K] K⟮x⟯ := ⟨id2, id2.continuous_of_finite_dimensional⟩ with hId2,
  have hC1 : ∃ (C1 : ℝ), 0 < C1 ∧ ∀ (y : K⟮x⟯), ‖ id1 y ‖ ≤ C1 * ‖ y ‖ :=
  Id1.is_bounded_linear_map.bound,
  have hC2 : ∃ (C2 : ℝ), 0 < C2 ∧ ∀ (y : E), ‖ id2 y ‖ ≤ C2 * ‖ y ‖ :=
  Id2.is_bounded_linear_map.bound,
  obtain ⟨C1, hC1_pos, hC1⟩ := hC1,
  obtain ⟨C2, hC2_pos, hC2⟩ := hC2,
  use [C2, C1, hC2_pos, hC1_pos],
  rw forall_and_distrib,
  split,
  { intro y, exact hC2 ⟨y, (intermediate_field.algebra_adjoin_le_adjoin K _) y.2⟩ },
  { intro y, exact hC1 ⟨y, (intermediate_field.algebra_adjoin_le_adjoin K _) y.2⟩ },
end

/-- If `K` is a field complete with respect to a nontrivial nonarchimedean multiplicative norm and
  `L/K` is an algebraic extension, then any multiplicative ring norm on `L` extending the norm on
  `K` coincides with the spectral norm. -/
lemma spectral_norm_unique_field_norm_ext [complete_space K] (h_alg : algebra.is_algebraic K L)
  {f : mul_ring_norm L} (hf_ext : function_extends (norm : K → ℝ) f)
  (hna : is_nonarchimedean (norm : K → ℝ)) (x : L) :
  f x = spectral_norm K L x :=
begin
  set g : algebra_norm K L :=
  { smul' := λ k x, by simp only [mul_ring_norm.to_fun_eq_coe, algebra.smul_def, map_mul, hf_ext k],
    mul_le' := λ x y, by simp only [mul_ring_norm.to_fun_eq_coe, map_mul_le_mul],
    ..f },
  have hg_pow : is_pow_mul g := mul_ring_norm.is_pow_mul _,
  have hgx : f x = g x := rfl,
  rw [hgx, spectral_norm_unique' h_alg hg_pow hna], refl,
end

/-- `seminorm_from_const` can be regarded as an algebra norm, when one assumes that
`(spectral_alg_norm h_alg hna).to_ring_seminorm 1 ≤ 1` and `0 ≠ spectral_alg_norm h_alg hna x`
for some `x : L` -/
def alg_norm_from_const (hna : is_nonarchimedean (norm : K → ℝ))
  (h1 : (spectral_alg_norm h_alg hna).to_ring_seminorm 1 ≤ 1) {x : L}
  (hx : 0 ≠ spectral_alg_norm h_alg hna x) :
  algebra_norm K L  :=
{ smul' := λ k y,
  begin
    have h_mul : ∀ (y : L), spectral_norm K L ((algebra_map K L k) * y) =
      spectral_norm K L (algebra_map K L k) * spectral_norm K L y,
    { intro y,
      rw [spectral_norm_extends, ← algebra.smul_def,
        ← spectral_alg_norm_def h_alg hna, map_smul_eq_mul _ _ _],
      refl, },
    have h : spectral_norm K L (algebra_map K L k) =
      seminorm_from_const' h1 hx (spectral_norm_is_pow_mul h_alg hna) (algebra_map K L k),
    {  rw seminorm_from_const_apply_of_is_mul h1 hx _ h_mul, refl, },
    simp only [ring_norm.to_fun_eq_coe, seminorm_from_const_ring_norm_of_field_def],
    rw [← spectral_norm_extends k, algebra.smul_def, h],
    exact seminorm_from_const_is_mul_of_is_mul _ _ _ h_mul _,
  end,
  ..(seminorm_from_const_ring_norm_of_field h1 hx.symm (spectral_alg_norm_is_pow_mul h_alg hna)) }

lemma alg_norm_from_const_def (hna : is_nonarchimedean (norm : K → ℝ))
  (h1 : (spectral_alg_norm h_alg hna).to_ring_seminorm 1 ≤ 1) {x y : L}
  (hx : 0 ≠ spectral_alg_norm h_alg hna x) :
  alg_norm_from_const h_alg hna h1 hx y =
    seminorm_from_const h1 hx (spectral_norm_is_pow_mul h_alg hna) y :=
rfl

/--If `K` is a field complete with respect to a nontrivial nonarchimedean multiplicative norm and
  `L/K` is an algebraic extension, then the spectral norm on `L` is multiplicative. -/
lemma spectral_norm_is_mul [complete_space K] (hna : is_nonarchimedean (norm : K → ℝ))
  (x y : L) : spectral_alg_norm h_alg hna (x * y) =
    spectral_alg_norm h_alg hna x * spectral_alg_norm h_alg hna y :=
begin
  by_cases hx : spectral_alg_norm h_alg hna x = 0,
  { rw [hx, zero_mul],
    rw [map_eq_zero_iff_eq_zero] at hx ⊢,
    rw [hx, zero_mul],  },
  { have hf1 : (spectral_alg_norm h_alg hna).to_ring_seminorm 1 ≤ 1 :=
    spectral_alg_norm_is_norm_le_one_class h_alg hna,
    set f : algebra_norm K L := alg_norm_from_const h_alg hna hf1 (ne.symm hx) with hf,
    have hf_pow : is_pow_mul f := seminorm_from_const_is_pow_mul hf1 (ne.symm hx)
      (spectral_norm_is_pow_mul h_alg hna),
    have hf_na : is_nonarchimedean f :=
    seminorm_from_const_is_nonarchimedean _ _ _ (spectral_norm_is_nonarchimedean h_alg hna),
    rw [← spectral_norm_unique' h_alg hf_pow, hf],
    simp only [alg_norm_from_const_def],
    exact seminorm_from_const_c_is_mul _ _ _ _, }
  end

/-- The spectral norm is a multiplicative `K`-algebra norm on `L`.-/
def spectral_mul_alg_norm [complete_space K] (hna : is_nonarchimedean (norm : K → ℝ)) :
  mul_algebra_norm K L  :=
{ map_one' := spectral_alg_norm_is_norm_one_class h_alg hna,
  map_mul' := spectral_norm_is_mul h_alg hna,
  ..spectral_alg_norm h_alg hna }

lemma spectral_mul_ring_norm_def [complete_space K] (hna : is_nonarchimedean (norm : K → ℝ))
  (x : L) : spectral_mul_alg_norm h_alg hna x = spectral_norm K L x :=
rfl

/-- `L` with the spectral norm is a `normed_field`. -/
def spectral_norm_to_normed_field [complete_space K] (h_alg : algebra.is_algebraic K L)
  (h : is_nonarchimedean (norm : K → ℝ)) : normed_field L :=
{ norm      := λ (x : L), (spectral_norm K L x : ℝ),
  dist      := λ (x y : L), (spectral_norm K L (x - y) : ℝ),
  dist_self := λ x, by { simp only [sub_self, spectral_norm_zero] },
  dist_comm := λ x y, by { simp only [dist], rw [← neg_sub, spectral_norm_neg h_alg h] },
  dist_triangle := λ x y z, begin
    simp only [dist_eq_norm],
    rw ← sub_add_sub_cancel x y z,
    exact add_le_of_is_nonarchimedean spectral_norm_nonneg
      (spectral_norm_is_nonarchimedean h_alg h) _ _,
  end,
  eq_of_dist_eq_zero := λ x y hxy,
  begin
    simp only [← spectral_mul_ring_norm_def h_alg h] at hxy,
    rw ← sub_eq_zero,
    exact mul_algebra_norm.eq_zero_of_map_eq_zero' _ _ hxy,
  end,
  dist_eq := λ x y, by refl,
  norm_mul' := λ x y,
  by simp only [← spectral_mul_ring_norm_def h_alg h]; exact map_mul _ _ _,
  ..(infer_instance : field L) }

/-- `L` with the spectral norm is a `normed_add_comm_group`. -/
def spectral_norm_to_normed_add_comm_group [complete_space K] (h_alg : algebra.is_algebraic K L)
  (h : is_nonarchimedean (norm : K → ℝ)) : normed_add_comm_group L :=
begin
  haveI : normed_field L := spectral_norm_to_normed_field h_alg h,
  apply_instance,
end

/-- `L` with the spectral norm is a `seminormed_add_comm_group`. -/
def spectral_norm_to_seminormed_add_comm_group [complete_space K] (h_alg : algebra.is_algebraic K L)
  (h : is_nonarchimedean (norm : K → ℝ)) : seminormed_add_comm_group L :=
begin
  haveI : normed_field L := spectral_norm_to_normed_field h_alg h,
  apply_instance,
end

/-- `L` with the spectral norm is a `normed_space` over `K`. -/
def spectral_norm_to_normed_space [complete_space K] (h_alg : algebra.is_algebraic K L)
  (h : is_nonarchimedean (norm : K → ℝ)) :
  @normed_space K L _ (spectral_norm_to_seminormed_add_comm_group h_alg h) :=
{ norm_smul_le := λ r x,
  begin
    change spectral_alg_norm h_alg h (r • x) ≤ ‖ r ‖*(spectral_alg_norm h_alg h x),
    exact le_of_eq (map_smul_eq_mul _ _ _),
  end,
  ..(infer_instance : module K L) }

/-- The metric space structure on `L` induced by the spectral norm. -/
def ms [complete_space K] (h : is_nonarchimedean (norm : K → ℝ)) : metric_space L :=
(spectral_norm_to_normed_field h_alg h).to_metric_space

/-- The uniform space structure on `L` induced by the spectral norm. -/
def us [complete_space K] (h : is_nonarchimedean (norm : K → ℝ)) :
  uniform_space L := (ms h_alg h).to_uniform_space -- normed_field.to_uniform_space

/-- If `L/K` is finite dimensional, then `L` is a complete space with respect to topology induced
  by the spectral norm. -/
@[priority 100] instance spectral_norm_complete_space [complete_space K]
  (h : is_nonarchimedean (norm : K → ℝ)) [h_fin : finite_dimensional K L] :
  @complete_space L (us h_alg h) :=
@finite_dimensional.complete K _ L (spectral_norm_to_normed_add_comm_group h_alg h)
  (spectral_norm_to_normed_space h_alg h) _ h_fin


/-
Copyright (c) 2021 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johan Commelin, Scott Morrison

! This file was ported from Lean 3 source module algebra.homology.complex_shape
! leanprover-community/mathlib commit c4658a649d216f57e99621708b09dcb3dcccbd23
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Algebra.Group.Defs
import Mathlib.Logic.Relation
import Mathlib.Tactic.Simps.Basic

/-!
# Shapes of homological complexes

We define a structure `ComplexShape ι` for describing the shapes of homological complexes
indexed by a type `ι`.
This is intended to capture chain complexes and cochain complexes, indexed by either `ℕ` or `ℤ`,
as well as more exotic examples.

Rather than insisting that the indexing type has a `succ` function
specifying where differentials should go,
inside `c : ComplexShape` we have `c.Rel : ι → ι → Prop`,
and when we define `HomologicalComplex`
we only allow nonzero differentials `d i j` from `i` to `j` if `c.Rel i j`.
Further, we require that `{ j // c.Rel i j }` and `{ i // c.Rel i j }` are subsingletons.
This means that the shape consists of some union of lines, rays, intervals, and circles.

Convenience functions `c.next` and `c.prev` provide these related elements
when they exist, and return their input otherwise.

This design aims to avoid certain problems arising from dependent type theory.
In particular we never have to ensure morphisms `d i : X i ⟶ X (succ i)` compose as
expected (which would often require rewriting by equations in the indexing type).
Instead such identities become separate proof obligations when verifying that a
complex we've constructed is of the desired shape.

If `α` is an `AddRightCancelSemigroup`, then we define `up α : ComplexShape α`,
the shape appropriate for cohomology, so `d : X i ⟶ X j` is nonzero only when `j = i + 1`,
as well as `down α : ComplexShape α`, appropriate for homology,
so `d : X i ⟶ X j` is nonzero only when `i = j + 1`.
(Later we'll introduce `CochainComplex` and `ChainComplex` as abbreviations for
`HomologicalComplex` with one of these shapes baked in.)
-/

open Classical

noncomputable section

/-- A `c : ComplexShape ι` describes the shape of a chain complex,
with chain groups indexed by `ι`.
Typically `ι` will be `ℕ`, `ℤ`, or `Fin n`.

There is a relation `Rel : ι → ι → Prop`,
and we will only allow a non-zero differential from `i` to `j` when `Rel i j`.

There are axioms which imply `{ j // c.Rel i j }` and `{ i // c.Rel i j }` are subsingletons.
This means that the shape consists of some union of lines, rays, intervals, and circles.

Below we define `c.next` and `c.prev` which provide these related elements.
-/
@[ext]
structure ComplexShape (ι : Type _) where
  /-- Nonzero differentials `X i ⟶ X j` shall be allowed
    on homological complexes when `Rel i j` holds. -/
  Rel : ι → ι → Prop
  /-- There is at most one nonzero differential from `X i`. -/
  next_eq : ∀ {i j j'}, Rel i j → Rel i j' → j = j'
  /-- There is at most one nonzero differential to `X j`. -/
  prev_eq : ∀ {i i' j}, Rel i j → Rel i' j → i = i'
#align complex_shape ComplexShape
#align complex_shape.ext ComplexShape.ext
#align complex_shape.ext_iff ComplexShape.ext_iff

namespace ComplexShape

variable {ι : Type _}

/-- The complex shape where only differentials from each `X.i` to itself are allowed.

This is mostly only useful so we can describe the relation of "related in `k` steps" below.
-/
@[simps]
def refl (ι : Type _) : ComplexShape ι where
  Rel i j := i = j
  next_eq w w' := w.symm.trans w'
  prev_eq w w' := w.trans w'.symm
#align complex_shape.refl ComplexShape.refl
#align complex_shape.refl_rel ComplexShape.refl_Rel

/-- The reverse of a `ComplexShape`.
-/
@[simps]
def symm (c : ComplexShape ι) : ComplexShape ι where
  Rel i j := c.Rel j i
  next_eq w w' := c.prev_eq w w'
  prev_eq w w' := c.next_eq w w'
#align complex_shape.symm ComplexShape.symm
#align complex_shape.symm_rel ComplexShape.symm_Rel

@[simp]

/-- The "composition" of two `ComplexShape`s.

We need this to define "related in k steps" later.
-/
@[simp]
def trans (c₁ c₂ : ComplexShape ι) : ComplexShape ι where
  Rel := Relation.Comp c₁.Rel c₂.Rel
  next_eq w w' := by
    obtain ⟨k, w₁, w₂⟩ := w
    obtain ⟨k', w₁', w₂'⟩ := w'
    rw [c₁.next_eq w₁ w₁'] at w₂
    exact c₂.next_eq w₂ w₂'
  prev_eq w w' := by
    obtain ⟨k, w₁, w₂⟩ := w
    obtain ⟨k', w₁', w₂'⟩ := w'
    rw [c₂.prev_eq w₂ w₂'] at w₁
    exact c₁.prev_eq w₁ w₁'
#align complex_shape.trans ComplexShape.trans

instance subsingleton_next (c : ComplexShape ι) (i : ι) : Subsingleton { j // c.Rel i j } := by
  constructor
  rintro ⟨j, rij⟩ ⟨k, rik⟩
  congr
  exact c.next_eq rij rik

instance subsingleton_prev (c : ComplexShape ι) (j : ι) : Subsingleton { i // c.Rel i j } := by
  constructor
  rintro ⟨i, rik⟩ ⟨j, rjk⟩
  congr
  exact c.prev_eq rik rjk

/-- An arbitary choice of index `j` such that `Rel i j`, if such exists.
Returns `i` otherwise.
-/
def next (c : ComplexShape ι) (i : ι) : ι :=
  if h : ∃ j, c.Rel i j then h.choose else i
#align complex_shape.next ComplexShape.next

/-- An arbitary choice of index `i` such that `Rel i j`, if such exists.
Returns `j` otherwise.
-/
def prev (c : ComplexShape ι) (j : ι) : ι :=
  if h : ∃ i, c.Rel i j then h.choose else j
#align complex_shape.prev ComplexShape.prev

theorem next_eq' (c : ComplexShape ι) {i j : ι} (h : c.Rel i j) : c.next i = j := by
  apply c.next_eq _ h
  rw [next]
  rw [dif_pos]
  exact Exists.choose_spec ⟨j, h⟩
#align complex_shape.next_eq' ComplexShape.next_eq'

theorem prev_eq' (c : ComplexShape ι) {i j : ι} (h : c.Rel i j) : c.prev j = i := by
  apply c.prev_eq _ h
  rw [prev, dif_pos]
  exact Exists.choose_spec (⟨i, h⟩ : ∃ k, c.Rel k j)
#align complex_shape.prev_eq' ComplexShape.prev_eq'

/-- The `ComplexShape` allowing differentials from `X i` to `X (i+a)`.
(For example when `a = 1`, a cohomology theory indexed by `ℕ` or `ℤ`)
-/
@[simps]
def up' {α : Type _} [AddRightCancelSemigroup α] (a : α) : ComplexShape α where
  Rel i j := i + a = j
  next_eq hi hj := hi.symm.trans hj
  prev_eq hi hj := add_right_cancel (hi.trans hj.symm)
#align complex_shape.up' ComplexShape.up'
#align complex_shape.up'_rel ComplexShape.up'_Rel

/-- The `ComplexShape` allowing differentials from `X (j+a)` to `X j`.
(For example when `a = 1`, a homology theory indexed by `ℕ` or `ℤ`)
-/
@[simps]
def down' {α : Type _} [AddRightCancelSemigroup α] (a : α) : ComplexShape α where
  Rel i j := j + a = i
  next_eq hi hj := add_right_cancel (hi.trans hj.symm)
  prev_eq hi hj := hi.symm.trans hj
#align complex_shape.down' ComplexShape.down'
#align complex_shape.down'_rel ComplexShape.down'_Rel

theorem down'_mk {α : Type _} [AddRightCancelSemigroup α] (a : α) (i j : α) (h : j + a = i) :
  (down' a).Rel i j := h
#align complex_shape.down'_mk ComplexShape.down'_mk

/-- The `ComplexShape` appropriate for cohomology, so `d : X i ⟶ X j` only when `j = i + 1`.
-/
@[simps!]
def up (α : Type _) [AddRightCancelSemigroup α] [One α] : ComplexShape α :=
  up' 1
#align complex_shape.up ComplexShape.up
#align complex_shape.up_rel ComplexShape.up_Rel

/-- The `ComplexShape` appropriate for homology, so `d : X i ⟶ X j` only when `i = j + 1`.
-/
@[simps!]
def down (α : Type _) [AddRightCancelSemigroup α] [One α] : ComplexShape α :=
  down' 1
#align complex_shape.down ComplexShape.down
#align complex_shape.down_rel ComplexShape.down_Rel

theorem down_mk {α : Type _} [AddRightCancelSemigroup α] [One α] (i j : α) (h : j + 1 = i) :
  (down α).Rel i j :=
  down'_mk (1 : α) i j h
#align complex_shape.down_mk ComplexShape.down_mk

end ComplexShape


import data.nat.prime
import data.zmod.basic
import data.complex.basic
import analysis.special_functions.pow
import analysis.analytic.basic
import analysis.calculus.iterated_deriv
import tprod
import algebra.module.basic
import field_theory.tower
import fg_quotient

local attribute [semireducible] with_zero
open_locale classical
noncomputable theory

variables {k : Type} [field k][char_zero k][finite_dimensional ℚ k]

def disc (a b : k) : k :=
-16*(4*a^3+27*b^2)

structure elliptic_curve_nf (k : Type) [field k][char_zero k][finite_dimensional ℚ k] :=
(a b : k)
(disc_nonzero : disc a b ≠ 0)

namespace elliptic_curve_nf

variable (E : elliptic_curve_nf k)

def finite_points (E : elliptic_curve_nf k) := {P : k × k // let ⟨x, y⟩ := P in
  y^2  = x^3 + E.a*x + E.b}

lemma finite_points.ext_iff {x1 y1 : k} (h1 : y1^2  = x1^3 + E.a*x1 + E.b)
  {x2 y2 : k} (h2 : y2^2  = x2^3 + E.a*x2 + E.b) :
  (⟨(x1, y1), h1⟩ : E.finite_points) = ⟨(x2, y2), h2⟩ ↔ x1 = x2 ∧ y1 = y2 :=
begin
  split,
  { intro h,
    rw subtype.ext_iff at h,
    change (x1, y1) = (x2, y2) at h,
    exact prod.mk.inj h },
  { rintro ⟨rfl, rfl⟩,
    refl },
end

def points (E : elliptic_curve_nf k) := with_zero E.finite_points

instance : has_zero (points E) := with_zero.has_zero

def points_mk {x y : k} (h : y^2  = x^3 + E.a*x + E.b) : points E := some ⟨⟨x, y⟩, h⟩

lemma ext_iff
  {x1 y1 : k} (h1 : y1^2  = x1^3 + E.a*x1 + E.b)
  {x2 y2 : k} (h2 : y2^2  = x2^3 + E.a*x2 + E.b) :
  E.points_mk h1 = E.points_mk h2 ↔ x1 = x2 ∧ y1 = y2 :=
begin
  split,
  { intro h,
    change some _ = some _ at h,
    rw option.some_inj at h,
    rwa finite_points.ext_iff at h },
  { rintro ⟨rfl, rfl⟩,
    refl }
end

def is_finite (P : points E) := ∃ {x y : k} (h : y^2  = x^3 + E.a*x + E.b), P = E.points_mk h

lemma not_is_finite_zero : ¬ E.is_finite 0.

lemma is_finite_some (P : finite_points E) : E.is_finite (some P) :=
begin
  rcases P with ⟨⟨x, y⟩, h⟩,
  use [x, y, h],
  refl,
end

def x_coord : Π {P : points E}, E.is_finite P → k
| none h0 := false.elim (E.not_is_finite_zero h0) -- 0 can't happen
| (some ⟨(x,y),h⟩) _ := x

lemma x_coord_some {x y : k} (h : y^2  = x^3 + E.a*x + E.b) :
  E.x_coord (E.is_finite_some ⟨(x,y),h⟩) = x := rfl

def y_coord : Π {P : points E}, E.is_finite P → k
| none h0 := false.elim (E.not_is_finite_zero h0)
| (some ⟨(x,y),h⟩) _ := y

lemma y_coord_some {x y : k} (h : y^2  = x^3 + E.a*x + E.b) :
  E.y_coord (E.is_finite_some ⟨(x,y),h⟩) = y := rfl

lemma is_zero_or_finite (P : points E) :
  P = 0 ∨ E.is_finite P :=
begin
  rcases P with (_ | ⟨⟨x, y⟩, h⟩),
  { left, refl },
  { right, exact ⟨x, y, h, rfl⟩ }
end

def is_on_curve (x y : k) := y^2 = x^3 + E.a*x + E.b

lemma is_on_curve_def {x y : k} : E.is_on_curve x y ↔ y^2 = x^3 + E.a*x + E.b :=
iff.rfl

lemma coords_are_on_curve {P : points E} (hP : E.is_finite P) :
  E.is_on_curve (E.x_coord hP) (E.y_coord hP) :=
match P, hP with
| none, h0 := false.elim (E.not_is_finite_zero h0)
| some ⟨(x,y),h⟩, _ := h
end

lemma is_zero_or_finite' (P : points E) : P = 0 ∨ ∃ (x y : k)
  (h : E.is_on_curve x y), P = E.points_mk h :=
begin
  cases E.is_zero_or_finite P,
  { left, assumption },
  { right,
    rcases h with ⟨x, y, h1, rfl⟩,
    use [x, y, h1] }
end

lemma is_finite_spec {P : points E} (hP : E.is_finite P) :
  P = E.points_mk (E.coords_are_on_curve hP) :=
begin
  cases E.is_zero_or_finite' P,
  { subst h,
    exfalso,
    exact E.not_is_finite_zero hP },
  { rcases h with ⟨x, y, h1, rfl⟩,
    refl }
end

lemma is_on_curve_neg {x y : k} (h : E.is_on_curve x y) : E.is_on_curve x (-y) :=
begin
  rw is_on_curve_def at *,
  convert h using 1,
  ring,
end

def neg_finite : finite_points E → finite_points E
| P :=
  let ⟨⟨x, y⟩, hP⟩ := P in
  ⟨(x, -y), begin
    change y^2  = x^3 + E.a*x + E.b at hP,
    change (-y)^2 = x^3 + E.a*x + E.b,
    convert hP using 1,
    ring,
  end⟩

def neg : points E → points E
| 0 := 0
| (some P) := (some (neg_finite E P))

instance : has_neg (points E) := ⟨E.neg⟩

lemma neg_zero : -(0 : points E) = 0 := rfl

lemma neg_finite_def {x y : k} (h : E.is_on_curve x y) :
  -(E.points_mk h) = E.points_mk (E.is_on_curve_neg h) := rfl

lemma neg_finite_def' {x y : k} (h : E.is_on_curve x y) :
  E.neg_finite ⟨(x, y), h⟩ = ⟨⟨x,-y⟩, E.is_on_curve_neg h⟩ := rfl

lemma neg_some_some_neg (P : finite_points E) :
  -(id (some P) : E.points) = some (E.neg_finite P) := rfl

def double : points E → points E
| 0 := 0
| (some P) :=
let ⟨⟨x, y⟩, h⟩ := P in
if h2 : y = 0 then 0 else
  let A : k := E.a in
  let B : k := E.b in
  let d := 2*y in
  let sd := (3*x^2+A) in
  let td := y*d-sd*x in
  let x₂dd := sd^2-2*x*d^2 in
  let y₂ddd := sd*x₂dd+td*d^2 in
  let y₂' := -y₂ddd/d^3 in
  let x₂ := x₂dd/d^2 in
  some ⟨⟨x₂, y₂'⟩, begin
    show y₂'^2  = x₂^3 + A*x₂ + B,
    simp only [x₂, y₂', y₂ddd, x₂dd, sd, d, td],
    have h1: 2 * y ≠ 0,
    { simp,
      exact h2  },
    change y^2=x^3+A*x+B at h,
    apply eq_of_sub_eq_zero,
    rw ← sub_eq_zero at h,
    field_simp,
    have : (-((y * (2 * y) - (3 * x ^ 2 + A) * x) * (2 * y) ^ 2) + -((3 * x ^ 2 + A) * ((3 * x ^ 2 + A) ^ 2 - 2 * x * (2 * y) ^ 2))) ^ 2 * (((2 * y) ^ 2) ^ 3 * (2 * y) ^ 2) - ((2 * y) ^ 3) ^ 2 * (((3 * x ^ 2 + A) ^ 2 - 2 * x * (2 * y) ^ 2) ^ 3 * (2 * y) ^ 2 + A * ((3 * x ^ 2 + A) ^ 2 - 2 * x * (2 * y) ^ 2) * ((2 * y) ^ 2) ^ 3 + B * (((2 * y) ^ 2) ^ 3 * (2 * y) ^ 2)) = 16384*y^14*(y^2-(x^3+A*x+B)),
      ring,
    rw this, clear this,
    rw h,
    simp,
  end⟩

lemma double_zero : E.double 0 = 0 := rfl

lemma double_order_two {x : k} (h : E.is_on_curve x 0) :
  E.double (E.points_mk h) = 0 := begin
    change dite _ _ _ = _,
    simp,
  end
  -- not rfl in this case

lemma double_finite {x y : k} (hy : y ≠ 0) (h : E.is_on_curve x y) :
  E.is_finite (E.double (E.points_mk h)) :=
begin
  change E.is_finite (dite (y = 0) _ _),
  rw dif_neg hy,
  exact E.is_finite_some _,
end

lemma double_x_of_finite {x y : k} (hy : y ≠ 0) (h : E.is_on_curve x y) :
  E.x_coord (E.double_finite hy h) = ((3*x^2+E.a)^2-2*x*(2*y)^2)/(2*y)^2 :=
begin
  convert E.x_coord_some _,
  exact dif_neg hy,
end

lemma double_y_of_finite {x y : k} (hy : y ≠ 0) (h : E.is_on_curve x y) :
  E.y_coord (E.double_finite hy h) =
(-((3*x^2+E.a)*((3*x^2+E.a)^2-2*x*(2*y)^2)+(y*(2*y)-(3*x^2+E.a)*x)*(2*y)^2))/(2*y)^3 :=
begin
  convert E.y_coord_some _,
  exact dif_neg hy,
end

--(deterministic) timeout
def add : points E → points E → points E
| 0 P := P
| P 0 := P
| (some P) (some Q) :=
let ⟨⟨x1, y1⟩, h1⟩ := P in
let ⟨⟨x2, y2⟩, h2⟩ := Q in
if hd : x1 = x2 then (if y1 = y2 then double E (some P) else 0) else
  let A : k := E.a in
  let B : k := E.b in
  let d := (x1 - x2) in
  let sd := (y1 - y2) in
  let td := y1*d-sd*x1 in
  let x₃dd := sd^2-(x1+x2)*d*d in
  let y₃ddd := sd*x₃dd+td*d*d in
  let x₃ := x₃dd/d^2 in
  let y₃' := -y₃ddd/d^3 in
  some ⟨⟨x₃, y₃'⟩, begin
    show y₃'^2  = x₃^3 + A*x₃ + B,
    simp only [x₃, y₃', y₃ddd, x₃dd, sd, d, td],
    field_simp,
    change y1^2=x1^3+A*x1+B at h1,
    change y2^2=x2^3+A*x2+B at h2,
    apply eq_of_sub_eq_zero,
    rw ← sub_eq_zero at h1 h2 hd,
    field_simp,
    have h : (-((y1 * (x1 - x2) - (y1 - y2) * x1) * (x1 - x2) * (x1 - x2)) + -((y1 - y2) * ((y1 - y2) ^ 2 - (x1 + x2) * (x1 - x2) * (x1 - x2)))) ^ 2 * (((x1 - x2) ^ 2) ^ 3 * (x1 - x2) ^ 2) - ((x1 - x2) ^ 3) ^ 2 * (((y1 - y2) ^ 2 - (x1 + x2) * (x1 - x2) * (x1 - x2)) ^ 3 * (x1 - x2) ^ 2 + A * ((y1 - y2) ^ 2 - (x1 + x2) * (x1 - x2) * (x1 - x2)) * ((x1 - x2) ^ 2) ^ 3 + B * (((x1 - x2) ^ 2) ^ 3 * (x1 - x2) ^ 2))
    =(x1-x2)^11*((y1^2-(x1^3+A*x1+B))*(y1^2-2*y1*y2+B+3*x1*x2^2-x2^3-x1^3+A*x2)+(y2^2-(x2^3+A*x2+B))*(-y2^2+2*y1*y2-B-3*x1^2*x2+x1^3+x2^3-A*x1)),
    { ring },
    rw h1 at h,
    rw h2 at h,
    simpa using h,
    end⟩

instance : has_add (points E) := ⟨E.add⟩

theorem zero_add (P : points E) : (0 : points E) + P = P := begin
    cases P,
    { refl },
    { refl },
  end
theorem add_zero (P : points E) : P + 0 = P := begin
    cases P,
    { refl },
    { refl },
end
lemma add_self (P : points E) : P + P = E.double P := begin
  cases P,
  {refl},
  { rcases P with ⟨⟨x, y⟩, h⟩,
    change dite _ _ _ = _,
    rw dif_pos rfl,
    split_ifs,
    { refl },
    { refl },
  },
end

lemma add_left_neg_finite {x y : k}(h : E.is_on_curve x y) :
  (id (some ⟨⟨x,-y⟩, E.is_on_curve_neg h⟩):points E) + some⟨⟨x,y⟩,h⟩ = 0 := begin
    simp,
    change dite _ _ _ = _,
    rw dif_pos rfl,
    split_ifs,
    {have hy: y=0,
      { rw ← add_self_eq_zero,
        rw ← h_1,
        rw ← sub_eq_add_neg,
        rw ← sub_eq_zero at h_1,
        exact h_1 }, -- not linarith here
      rw hy at h,
      convert E.double_order_two h,
      rw h_1, exact hy },
    { refl },
  end

theorem add_left_neg (P : points E) : (-P) + P = 0 := begin
    cases P,
    { refl },
    { change -(id(some P): points E) + some P = 0,
      rw neg_some_some_neg,
      rcases P with ⟨⟨x, y⟩, h⟩,
      change E.is_on_curve x y at h,
      rw E.neg_finite_def',
      apply add_left_neg_finite},
  end

-- had to break up add_comm_finite to avoid timeout
theorem add_comm_equal {x1 x2 y1 y2 : k}(h1 : E.is_on_curve x1 y1)
  (h2 : E.is_on_curve x2 y2)(h3: x1=x2)(h4: y1=y2) :
  E.points_mk h1 + E.points_mk h2 = E.points_mk h2 + E.points_mk h1 := begin
    have heq: E.points_mk h1 = E.points_mk h2,
      { rw ext_iff,
        exact ⟨h3, h4⟩,
      },
    rw heq,
end

theorem add_comm_neg {x1 x2 y1 y2 : k}(h1 : E.is_on_curve x1 y1)
  (h2 : E.is_on_curve x2 y2)(h3: x1=x2)(h4: ¬ y1=y2) :
  E.points_mk h1 + E.points_mk h2 = E.points_mk h2 + E.points_mk h1 := begin
    change dite _ _ _ = dite _ _ _,
    split_ifs,
    { exfalso,
      apply h4,
      rw h_1  },
    { refl },
    { exfalso,
      apply h,
      rw h3 },

end

theorem add_comm_general {x1 x2 y1 y2 : k}(h1 : E.is_on_curve x1 y1)
  (h2 : E.is_on_curve x2 y2)(h3: ¬ x1=x2) :
  E.points_mk h1 + E.points_mk h2 = E.points_mk h2 + E.points_mk h1 := begin
    change dite _ _ _ = dite _ _ _,
    split_ifs,
    { exfalso,
      apply h3,
      rw h },
    { exfalso,
      apply h3,
      rw h },
    { rw option.some_inj,
      rw finite_points.ext_iff,
      split,
      { have h5: x1-x2 ≠ 0,
        { rw sub_ne_zero,
          exact h3 },
        have h6: x2-x1 ≠ 0,
        { rw sub_ne_zero,
          exact h },
        rw ← sub_eq_zero,
        field_simp,
        ring,
      },
      { have h5: x1-x2 ≠ 0,
        { rw sub_ne_zero,
          exact h3 },
        have h6: x2-x1 ≠ 0,
        { rw sub_ne_zero,
          exact h },
        rw ← sub_eq_zero,
        field_simp,
        ring,
      },

    },

end

theorem add_comm_finite {x1 x2 y1 y2 : k}(h1 : E.is_on_curve x1 y1)
  (h2 : E.is_on_curve x2 y2) :
  E.points_mk h1 + E.points_mk h2 = E.points_mk h2 + E.points_mk h1 := begin
    have hx: x1=x2 ∨ ¬ x1=x2,
      { tauto },
    cases hx,
    { have hy: y1=y2 ∨ ¬ y1=y2,
      { tauto },
      cases hy,
      { apply add_comm_equal,
        exact hx,
        exact hy },
      { apply add_comm_neg,
        exact hx,
        exact hy },
    },
    { apply add_comm_general,
      exact hx },
end

theorem add_comm (P Q : points E) : P + Q = Q + P := begin
  cases E.is_zero_or_finite' P,
  { rw h,
    rw add_zero,
    rw zero_add
  },
  { cases E.is_zero_or_finite' Q,
    { rw h_1,
      rw add_zero,
      rw zero_add
    },
    { cases h with x1 h,
      cases h with y1 hP,
      cases hP with hP1 hP2,
      cases h_1 with x2 h_1,
      cases h_1 with y2 hQ,
      cases hQ with hQ1 hQ2,
      rw [hP2, hQ2],
      apply E.add_comm_finite,
    },
  },
end

instance : add_comm_group (points E) :=
{ zero := 0,
  add := (+),
  neg := has_neg.neg,
  zero_add := E.zero_add,
  add_zero := E.add_zero,
  add_assoc := begin
    sorry,
  end,
  add_left_neg := E.add_left_neg,
  add_comm := E.add_comm,
}

theorem fg : add_group.fg (points E) := begin
  sorry,
end

def torsion_points (E : elliptic_curve_nf k) :
(set (points E)) :=
{P | ∃ (n : ℤ), (n • P = 0)∧(n ≠ 0)}

def torsion_subgroup (E : elliptic_curve_nf k) : add_subgroup (points E) :=
{ carrier := (torsion_points E),
  zero_mem' := begin
    unfold torsion_points,
    rw set.mem_set_of_eq,
    use 1,
    simp,
  end,
  add_mem' := begin
    unfold torsion_points at *,
    intros a b ha hb,
    cases ha with na hna,
    cases hna with ha1 ha2,
    cases hb with nb hnb,
    cases hnb with hb1 hb2,
    rw set.mem_set_of_eq,
    use na*nb,
    split,
    { rw smul_add,
      rw mul_comm,
      rw mul_smul,
      rw ha1,
      rw mul_comm,
      rw mul_smul,
      rw hb1,
      simp},
    { simp,
      tauto
    },
  end,
  neg_mem' := begin
    unfold torsion_points at *,
    intros x hx,
    cases hx with n hn,
    cases hn with hn1 hn2,
    rw set.mem_set_of_eq,
    use n,
    rw smul_neg,
    rw hn1,
    simp,
    exact hn2,
  end,
}

def torsion_free (E : elliptic_curve_nf k) :=
  (quotient_add_group.quotient (torsion_subgroup E))

instance: add_comm_group (torsion_free E) := begin
  unfold torsion_free,
  apply_instance,
end

theorem torsion_free_fg : add_group.fg (torsion_free E) := begin
  apply add_fg_quotient_of_fg,
  apply fg,
end

def generators (E : elliptic_curve_nf k) :=
  {S : set (torsion_free E) | (set.finite S) ∧ (add_subgroup.closure S = ⊤)}

def sizes (E : elliptic_curve_nf k) : (set ℕ) :=
  {n : ℕ | ∃ (S : generators E), (fintype.card (fintype S)) = n}

theorem sizes_non_empty : ∃ (n : ℕ), (n ∈ sizes E) := begin
  unfold sizes,
  have h : ∃ (S : set (torsion_free E)), (add_subgroup.closure S = ⊤) ∧ (S.finite),
  {rw ← add_group.fg_iff,
  exact torsion_free_fg E},
  cases h with S hS,
  cases hS with hclosure hfinite,
  use fintype.card (fintype S),
  rw set.mem_set_of_eq,
  use S,
  {simp only [elliptic_curve_nf.generators.equations._eqn_1],
  rw set.mem_set_of_eq,
  exact ⟨hfinite, hclosure⟩},
  {refl},
end
open_locale classical
noncomputable def rank : ℕ :=
  nat.find (sizes_non_empty E)

def primes : Type := sorry

def good_primes (E : elliptic_curve_nf k) : Type := sorry

def residue_characteristic (p : primes) : ℕ := sorry

def residue_field (p : primes) : Type := sorry

def p_points (p : good_primes E) :
  finset (residue_field p × residue_field p):= sorry

noncomputable def a_p (p : good_primes E) : ℤ :=
  residue_characteristic p - finset.card (p_points E p)

def half_plane := {z : ℂ // complex.re z > 3/2}

instance : has_coe half_plane ℂ := ⟨subtype.val⟩

noncomputable def local_factor (s : ℂ) : good_primes E → ℂ
| p := 1 - (a_p E p) * (residue_characteristic p) ^ (-s) + (residue_characteristic p) ^ (1-2*s)

theorem hasse_bound (p : good_primes E) :
  (a_p E p)^2 ≤ 4 * (residue_characteristic p) := sorry

theorem converges (s : half_plane) :
  prodable (local_factor E s) := sorry

noncomputable def L_function_product  (s : half_plane) : ℂ :=
1/(tprod (local_factor E s))

theorem analytic_continuation: ∃ f : ℂ → ℂ, (differentiable ℂ f)∧(∀ z : half_plane, f z = L_function_product E z)
∧ (∀ g : ℂ → ℂ, (differentiable ℂ g)∧(∀ z : half_plane, g z = L_function_product E z) → g = f) := sorry

noncomputable def L_function : ℂ → ℂ := classical.some (analytic_continuation E)

noncomputable def L_derivative (E : elliptic_curve_nf k) : ℕ → ℂ → ℂ
|n := iterated_deriv n (L_function E)

theorem has_order_of_vanishing : ∃ n : ℕ, L_derivative E n 1 ≠ 0 := sorry

noncomputable def analytic_rank (E : elliptic_curve_nf k) : ℕ :=
  nat.find (has_order_of_vanishing E)

theorem BSD : analytic_rank E = rank E := sorry

end elliptic_curve_nf


--

-- New notation that overlaps with existing notation
syntax (name := myPair) (priority := high) "(" term "," term ")" : term

macro_rules (kind := myPair)
| `(($a, $b)) => `([$a, $b])

#eval (1, 2) -- not ambiguous since myPair parser has higher priority

theorem ex1 : (1, 2) = [1, 2] :=
rfl

-- Define macro for expanding the builtin triple notation
-- Macros bypass builtin elaboration functions
macro_rules
| `(($a, $b, $c)) => `($a + $b + $c)

#eval (1, 2, 3)

syntax (name := mySingleton) "[" term "]" : term

macro_rules (kind := mySingleton)
| `([$a]) => `(2 * $a)

-- TODO: "ambiguous, possible interpretations" error messages print with
-- a lot of detail since most mvars have not been resolved yet
#check [1] -- ambiguous it can be `mySingleton` or the singleton list

syntax (priority := 100) "(" term "," term ", " term ")" : term -- priority without a kind

macro_rules
| `(($a, $b, $c)) => `([$a, $b, $c])

#eval (1,2,3)

theorem ex2 : (1, 2, 3) = [1, 2, 3] :=
rfl

theorem ex3 : (1, 2, 3, 4) = Prod.mk 1 (Prod.mk 2 (Prod.mk 3 4)) :=
rfl


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

import .basic fin.extra

namespace tup
variables {α : Type*} {n : ℕ}

definition conj : α ^ n → α → α ^ (n + 1) :=
λ xs x ⟨i,_⟩, if h : i < n then xs[⟨i,h⟩] else x

notation xs && x := conj xs x

lemma ith_conj_of_lt {x : α} {xs : α ^ n} {i : ℕ} {hi : i < n + 1} (h : i < n) :
(conj xs x)[⟨i, hi⟩] = xs[⟨i,h⟩] := dif_pos h

lemma ith_conj_of_ge {x : α} {xs : α ^ n} {i : ℕ} (hi : i < n+1) (h : i ≥ n) :
(conj xs x)[⟨i, hi⟩] = x := dif_neg (not_lt_of_ge h)

lemma ith_conj_last {x : α} {xs : α ^ n} :
(conj xs x)[⟨n, nat.lt_succ_self n⟩] = x :=
ith_conj_of_ge _ (le_refl n)

lemma conj_val_of_lt {x : α} {xs : α ^ n} :
∀ {i : fin (n+1)} (h : i.val < n), (conj xs x)[i] = xs[⟨i.val,h⟩]
| ⟨i,hi⟩ h := by simp [ith_conj_of_lt h]

lemma conj_val_of_ge {x : α} {xs : α ^ n} :
∀ {i : fin (n+1)} (h : i.val ≥ n), (conj xs x)[i] = x
| ⟨i,hi⟩ h := by simp [ith_conj_of_ge hi h]

@[simp] lemma conj_last {x : α} {xs : α ^ n} :
(conj xs x)[fin.last n] = x :=
conj_val_of_ge (le_refl n)

@[simp] lemma conj_lift {x : α} {xs : α ^ n} :
∀ {i : fin n}, (conj xs x)[fin.lift i] = xs[i] :=
λ ⟨i, ih⟩, conj_val_of_lt ih

@[reducible] definition last : α ^ (n+1) → α :=
λ xs, xs[⟨n, nat.lt_succ_self n⟩]

@[reducible] definition left : α ^ (n+1) → α ^ n :=
λ xs i, xs[fin.lift i]

@[simp] lemma ith_left {xs : α ^ (n+1)} {i : ℕ} {hi : i < n} :
xs.left[⟨i,hi⟩] = xs[⟨i,nat.lt_succ_of_lt hi⟩] := rfl

definition last_of_nonzero (h : n ≠ 0) : α ^ n → α :=
match n, h with
| 0, h := absurd rfl h
| (n+1), _ := last
end

definition left_of_nonzero (h : n ≠ 0) : α ^ n → α ^ (n-1) :=
match n, h with
| 0, h := absurd rfl h
| (n+1), _ := left
end

@[simp] lemma last_conj {x : α} {xs : α ^ n} :
last (conj xs x) = x := conj_last

@[simp] lemma left_conj {x : α} {xs : α ^ n} :
left (conj xs x) = xs := ext $ λ _, conj_lift

lemma conj_left_last (xs : α ^ (n + 1)) :
conj (left xs) (last xs) = xs :=
ext $ λ ⟨i,hi⟩,
if h : i = n then
  by simp [h, ith_conj_last]
else
  have h : i < n, from nat.lt_of_le_and_ne (nat.le_of_lt_succ hi) h,
  by simp [ith_conj_of_lt h]; reflexivity

end tup

#exit

section rec
universe u
variables {α : Type u} {C : Π {n : ℕ}, α ^ n → Sort*}
open tup

@[recursor 6]
definition tup.conj_rec :
C nil → (Π {n : ℕ} (xs : α ^ n) (x : α), C xs → C (xs && x)) → (Π {n : ℕ} (xs : tup.{u} α n), C xs)
| h0 _ 0 xs := eq.rec_on (eq.symm (eq_nil xs)) h0
| h0 hs (n+1) xs := eq.rec_on (conj_left_last xs) (hs (left xs) (last xs) (tup.conj_rec h0 hs (left xs)))

@[elab_as_eliminator]
definition tup.conj_rec_on {n : ℕ} (xs : α ^ n) :
C nil → (Π {n : ℕ} (xs : α ^ n) (x : α), C xs → C (xs && x)) → C xs :=
assume h0 hs, tup.conj_rec h0 hs xs

end rec


import .frac
import ..myfield.basic

namespace hidden

open myint
open myring
open ordered_myring
open ordered_integral_domain

def myrat := quotient frac.frac.setoid

namespace myrat

instance deceq: decidable_eq myrat := quotient.decidable_eq

private lemma class_setoid (x y : frac) :
⟦x⟧ = ⟦y⟧ ↔ x ≈ y := iff.intro quotient.exact quotient.sound

theorem class_equiv {x y : frac} :
⟦x⟧ = ⟦y⟧ ↔ x.num * y.denom = y.num * x.denom :=
begin
  split; assume h,
    rwa [←frac.setoid_equiv, ←class_setoid],
  rwa [class_setoid, frac.setoid_equiv],
end

def neg : myrat → myrat :=
quotient.lift (λ x, ⟦-x⟧) frac.neg_well_defined

instance: has_neg myrat := ⟨neg⟩
instance has_neg2: has_neg (quotient frac.frac.setoid) := ⟨neg⟩

private theorem neg_eq_cls {x: frac}:
-⟦x⟧ = ⟦-x⟧ := rfl

private lemma one_pos: (0: myint) < 1 := nontrivial_zero_lt_one myint.nontrivial

instance: has_zero myrat := ⟨⟦⟨0, 1, one_pos⟩⟧⟩

theorem rat_zero: (0: myrat) = ⟦⟨0, 1, one_pos⟩⟧ := rfl

instance: has_one myrat := ⟨⟦⟨1, 1, one_pos⟩⟧⟩

theorem rat_one: (1: myrat) = ⟦⟨1, 1, one_pos⟩⟧ := rfl

instance: has_coe myint myrat := ⟨λ m, ⟦⟨m, 1, one_pos⟩⟧⟩

theorem nontrivial: (0: myrat) ≠ 1 :=
begin
  assume hydroxide,
  have := quotient.exact hydroxide,
  rw frac.setoid_equiv at this,
  cases quotient.exact this,
end

theorem coe_int {m : myint} : (↑m : myrat) = ⟦⟨m, 1, one_pos⟩⟧ :=
rfl

theorem coe_cancel {m n : myint}:
(↑m : myrat) = ↑n ↔ m = n :=
begin
  split; assume h, {
    rw [coe_int, coe_int, class_equiv] at h,
    dsimp only [] at h,
    rwa [mul_one, mul_one] at h,
  }, {
    congr, assumption,
  },
end

def add : myrat → myrat → myrat :=
quotient.lift₂ (λ x y, ⟦x + y⟧) frac.add_well_defined

instance: has_add myrat := ⟨add⟩
instance has_add2: has_add (quotient frac.frac.setoid) := ⟨add⟩

private theorem add_eq_cls {x y: frac}:
⟦x⟧ + ⟦y⟧ = ⟦x + y⟧ := rfl

theorem two_nzero: (2: myrat) ≠ 0 :=
begin
  assume water,
  have := quotient.exact water,
  rw frac.setoid_equiv at this,
  cases (quotient.exact this),
end

def sub (x y : myrat) : myrat :=
x + -y

instance: has_sub myrat := ⟨sub⟩
instance has_sub2: has_sub (quotient frac.frac.setoid) := ⟨sub⟩

private theorem sub_eq_cls {x y: frac}:
⟦x⟧ - ⟦y⟧ = ⟦x + -y⟧ := rfl

variables {x y z : myrat}
variables {m n k : myint}

theorem add_coe: (↑m : myrat) + ↑n = ↑(m + n) :=
begin
  repeat { rw coe_int, },
  apply congr_arg quotient.mk,
  rw ←frac.frac_add_add,
  dsimp [frac.add],
  repeat {rw mul_one},
  refl,
end

theorem neg_coe: -(↑m : myrat) = ↑(-m) :=
begin
  repeat { rw coe_int, },
  rw [neg_eq_cls, frac.frac_neg_neg],
  dsimp [frac.neg],
  refl,
end

def mul : myrat → myrat → myrat :=
quotient.lift₂ (λ x y, ⟦x * y⟧) frac.mul_well_defined

instance: has_mul myrat := ⟨mul⟩
instance has_mul2: has_mul (quotient frac.frac.setoid) := ⟨mul⟩

def inv : myrat → myrat :=
quotient.lift (λ x, ⟦x⁻¹⟧) frac.inv_well_defined

instance: has_inv myrat := ⟨inv⟩
instance has_inv2: has_inv (quotient frac.frac.setoid) := ⟨inv⟩

-- Multiplication

private theorem mul_eq_cls {x y : frac}:
⟦x⟧ * ⟦y⟧ = ⟦x * y⟧ := rfl

-- Reciprocal "inv"

private theorem inv_eq_cls {x : frac}:
⟦x⟧⁻¹ = ⟦x⁻¹⟧ := rfl

@[simp]
theorem zero_inv : 0⁻¹ = (0 : myrat) :=
rfl

private theorem inv_self_mul : x ≠ 0 → x * x⁻¹ = 1 :=
begin
  cases quotient.exists_rep x with a ha, subst ha,
  assume hx,
  rw [inv_eq_cls, mul_eq_cls, rat_one],
  rw class_equiv,
  dsimp only [],
  rw [frac.mul_num, frac.mul_denom],
  have : a.num ≠ 0,
    rw rat_zero at hx,
    have h : ¬⟦a⟧ = ⟦{num := 0, denom := 1, denom_pos := one_pos}⟧,
      from hx,
    clear hx,
    rw [class_equiv, mul_one, zero_mul] at h,
    assumption,
  rw [frac.inv_num_nonzero this, frac.inv_denom_nonzero this],
  ac_refl,
end

instance: myring myrat := ⟨
  by apply_instance,
  λ x y z: myrat,
  begin
    cases quotient.exists_rep x with a ha, subst ha,
    cases quotient.exists_rep y with b hb, subst hb,
    cases quotient.exists_rep z with c hc, subst hc,
    apply congr_arg quotient.mk,
    rw frac.num_and_denom_eq,
    repeat { rw frac.add_num <|> rw frac.add_denom <|> rw myring.add_mul },
    split; ac_refl,
  end,
  λ x: myrat,
  begin
    cases quotient.exists_rep x with a ha, subst ha,
    rw [rat_zero, add_eq_cls],
    rw frac.sound_exact_iff,
    rw frac.setoid_equiv,
    rw frac.add_denom,
    rw frac.add_num,
    dsimp only [],
    rw myring.zero_mul,
    rw myring.add_zero,
    repeat {rw myring.mul_one},
  end,
  λ x: myrat,
  begin
    cases quotient.exists_rep x with a ha, subst ha,
    rw neg_eq_cls,
    rw add_eq_cls,
    apply quotient.sound,
    rw frac.setoid_equiv,
    dsimp only [],
    repeat {rw myring.zero_mul},
    rw frac.add_num,
    rw mul_one,
    rw frac.neg_denom,
    rw frac.neg_num,
    rw neg_mul,
    from add_neg _,
  end,
  λ x y z: myrat,
  begin
    cases quotient.exists_rep x with a ha,
    cases quotient.exists_rep y with b hb,
    cases quotient.exists_rep z with c hc,
    rw [←ha, ←hb, ←hc],
    repeat {rw mul_eq_cls,},
    rw class_equiv,
    repeat { rw frac.mul_num <|> rw frac.mul_denom, },
    ac_refl,
  end,
  λ x y: myrat,
  begin
    cases quotient.exists_rep x with a ha,
    cases quotient.exists_rep y with b hb,
    rw [←ha, ←hb],
    repeat {rw mul_eq_cls,},
    rw class_equiv,
    repeat { rw frac.mul_num <|> rw frac.mul_denom, },
    ac_refl,
  end,
  λ x: myrat,
  begin
    cases quotient.exists_rep x with a ha,
    rw [←ha, rat_one],
    rw mul_eq_cls,
    rw class_equiv,
    rw [frac.mul_num, frac.mul_denom],
    dsimp only [],
    repeat {rw myring.mul_one},
  end,
  λ x y z: myrat,
  begin
    cases quotient.exists_rep x with a ha, subst ha,
    cases quotient.exists_rep y with b hb, subst hb,
    cases quotient.exists_rep z with c hc, subst hc,
    repeat { rw mul_eq_cls <|> rw add_eq_cls, },
    rw class_equiv,
    repeat { rw frac.mul_num <|> rw frac.mul_denom <|> rw frac.add_num <|> rw frac.add_denom, },
    -- ac_refl can't expand brackets
    repeat { rw myring.add_mul <|> rw myring.mul_add, },
    ac_refl,
  end⟩

instance: myfield myrat := {
  mul_inv := λ x hx, inv_self_mul hx,
  nontrivial := nontrivial
}

-- Moved here as they might be useful
-- theorem one_plus_one : 1 + 1 = (2 : myrat):= rfl

-- theorem double_eq_add_self : 2 * x = x + x :=
-- by rw [←one_plus_one, add_mul, one_mul]

-- theorem half_plus_half {ε : myrat} : ε / 2 + ε / 2 = ε :=
-- begin
--   rw [←double_eq_add_self, mul_comm, div_mul_cancel two_nzero],
-- end

end myrat

end hidden


/-- A `Vec` is just a `List α` of statically known size -/
def Vec (α : Type _) (n : Nat) : Type _
  := Fin n → α

abbrev TypeVec : Nat → Type _
  := Vec (Type _)

/-- A dependent vector is a heterogenous list of statically known size -/
def DVec {n : Nat} (αs : TypeVec n) : Type _
  := (i : Fin n) → (αs i)

/-- A vector that repeats a single element `a` -/
def Vec.const {α : Type _} (a : α) (n : Nat) : Vec α n
  := fun _ => a

/- `Vec` is defeq to a `DVec` with constant type -/
unif_hint (α : Type _) (n : Nat) where
  |- Vec α n =?= DVec (Vec.const α n)

namespace DVec
  def hd {n : Nat} {αs : TypeVec (n+1)} (v : DVec αs) : (αs 0)
    := v 0
end DVec

namespace Vec
  export DVec (hd)
end Vec

def ts : TypeVec 1 := Vec.const Nat 1

-- works
example (v : DVec ts) : Nat :=
  v.hd

-- works
example (v : Vec Nat 1) : Nat :=
  DVec.hd v

-- Vec.hd exists
#check @Vec.hd

-- works
example (v : Vec Nat 1) : Nat :=
  v.hd


/-
Copyright © 2020 Nicolò Cavalleri. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Nicolò Cavalleri
-/

import geometry.manifold.algebra.monoid

/-!
# Lie groups

A Lie group is a group that is also a smooth manifold, in which the group operations of
multiplication and inversion are smooth maps. Smoothness of the group multiplication means that
multiplication is a smooth mapping of the product manifold `G` × `G` into `G`.

Note that, since a manifold here is not second-countable and Hausdorff a Lie group here is not
guaranteed to be second-countable (even though it can be proved it is Hausdorff). Note also that Lie
groups here are not necessarily finite dimensional.

## Main definitions and statements

* `lie_add_group I G` : a Lie additive group where `G` is a manifold on the model with corners `I`.
* `lie_group I G`     : a Lie multiplicative group where `G` is a manifold on the model with
                        corners `I`.
* `normed_space_lie_add_group` : a normed vector space over a nondiscrete normed field
                                 is an additive Lie group.

## Implementation notes

A priori, a Lie group here is a manifold with corners.

The definition of Lie group cannot require `I : model_with_corners 𝕜 E E` with the same space as the
model space and as the model vector space, as one might hope, beause in the product situation,
the model space is `model_prod E E'` and the model vector space is `E × E'`, which are not the same,
so the definition does not apply. Hence the definition should be more general, allowing
`I : model_with_corners 𝕜 E H`.
-/

noncomputable theory

open_locale manifold

/-- A Lie (additive) group is a group and a smooth manifold at the same time in which
the addition and negation operations are smooth. -/
-- See note [Design choices about smooth algebraic structures]
@[ancestor has_smooth_add]
class lie_add_group {𝕜 : Type*} [nondiscrete_normed_field 𝕜]
  {H : Type*} [topological_space H]
  {E : Type*} [normed_group E] [normed_space 𝕜 E] (I : model_with_corners 𝕜 E H)
  (G : Type*) [add_group G] [topological_space G] [charted_space H G]
  extends has_smooth_add I G : Prop :=
(smooth_neg : smooth I I (λ a:G, -a))

/-- A Lie group is a group and a smooth manifold at the same time in which
the multiplication and inverse operations are smooth. -/
-- See note [Design choices about smooth algebraic structures]
@[ancestor has_smooth_mul, to_additive]
class lie_group {𝕜 : Type*} [nondiscrete_normed_field 𝕜]
  {H : Type*} [topological_space H]
  {E : Type*} [normed_group E] [normed_space 𝕜 E] (I : model_with_corners 𝕜 E H)
  (G : Type*) [group G] [topological_space G] [charted_space H G]
  extends has_smooth_mul I G : Prop :=
(smooth_inv : smooth I I (λ a:G, a⁻¹))

section lie_group

variables {𝕜 : Type*} [nondiscrete_normed_field 𝕜]
{H : Type*} [topological_space H]
{E : Type*} [normed_group E] [normed_space 𝕜 E] {I : model_with_corners 𝕜 E H}
{F : Type*} [normed_group F] [normed_space 𝕜 F] {J : model_with_corners 𝕜 F F}
{G : Type*} [topological_space G] [charted_space H G] [group G] [lie_group I G]
{E' : Type*} [normed_group E'] [normed_space 𝕜 E']
{H' : Type*} [topological_space H'] {I' : model_with_corners 𝕜 E' H'}
{M : Type*} [topological_space M] [charted_space H' M]
{E'' : Type*} [normed_group E''] [normed_space 𝕜 E'']
{H'' : Type*} [topological_space H''] {I'' : model_with_corners 𝕜 E'' H''}
{M' : Type*} [topological_space M'] [charted_space H'' M']

section

variable (I)

@[to_additive]
lemma smooth_inv : smooth I I (λ x : G, x⁻¹) :=
lie_group.smooth_inv

/-- A Lie group is a topological group. This is not an instance for technical reasons,
see note [Design choices about smooth algebraic structures]. -/
@[to_additive
"An additive Lie group is an additive topological group. This is not an instance for technical
reasons, see note [Design choices about smooth algebraic structures]."]
lemma topological_group_of_lie_group : topological_group G :=
{ continuous_inv := (smooth_inv I).continuous,
  .. has_continuous_mul_of_smooth I }

end

@[to_additive]
lemma smooth.inv {f : M → G}
  (hf : smooth I' I f) : smooth I' I (λx, (f x)⁻¹) :=
(smooth_inv I).comp hf

@[to_additive]
lemma smooth_on.inv {f : M → G} {s : set M}
  (hf : smooth_on I' I f s) : smooth_on I' I (λx, (f x)⁻¹) s :=
(smooth_inv I).comp_smooth_on hf

@[to_additive]
lemma smooth.div {f g : M → G}
  (hf : smooth I' I f) (hg : smooth I' I g) : smooth I' I (f / g) :=
by { rw div_eq_mul_inv, exact ((smooth_mul I).comp (hf.prod_mk hg.inv) : _), }

@[to_additive]
lemma smooth_on.div {f g : M → G} {s : set M}
  (hf : smooth_on I' I f s) (hg : smooth_on I' I g s) : smooth_on I' I (f / g) s :=
by { rw div_eq_mul_inv, exact ((smooth_mul I).comp_smooth_on (hf.prod_mk hg.inv) : _), }

end lie_group

section prod_lie_group

/- Instance of product group -/
@[to_additive]
instance {𝕜 : Type*} [nondiscrete_normed_field 𝕜] {H : Type*} [topological_space H]
  {E : Type*} [normed_group E] [normed_space 𝕜 E]  {I : model_with_corners 𝕜 E H}
  {G : Type*} [topological_space G] [charted_space H G] [group G] [lie_group I G]
  {E' : Type*} [normed_group E'] [normed_space 𝕜 E']
  {H' : Type*} [topological_space H'] {I' : model_with_corners 𝕜 E' H'}
  {G' : Type*} [topological_space G'] [charted_space H' G']
  [group G'] [lie_group I' G'] :
  lie_group (I.prod I') (G×G') :=
{ smooth_inv := smooth_fst.inv.prod_mk smooth_snd.inv,
  ..has_smooth_mul.prod _ _ _ _ }

end prod_lie_group

/-! ### Normed spaces are Lie groups -/

instance normed_space_lie_add_group {𝕜 : Type*} [nondiscrete_normed_field 𝕜]
  {E : Type*} [normed_group E] [normed_space 𝕜 E] :
  lie_add_group (𝓘(𝕜, E)) E :=
{ smooth_add := smooth_iff.2 ⟨continuous_add, λ x y, times_cont_diff_add.times_cont_diff_on⟩,
  smooth_neg := smooth_iff.2 ⟨continuous_neg, λ x y, times_cont_diff_neg.times_cont_diff_on⟩,
  .. model_space_smooth }


import tactic.induction
import tactic.ring_exp  -- this gets us split_ifs, apparently

/-
# 1. Lists
We'll prove CPS equivalences for the following list functions:
* `append`
* `map`
* `filter`
* `foldr`

For higher-order functions, two CPS versions are provided:
* A "partial CPS" version, where higher-order arguments are taken in direct
  style; and
* A "higher-order CPS" version, where both the function and its function
  arguments are in CPS.

In this file, proofs are written out verbosely in calc mode to proide some
insight into where patterns that will hopefully emerge in more complex CPS-
equivalence proofs come from in simpler instances.
-/

inductive llist (α : Sort _)
| nil : llist
| cons : α → llist → llist

namespace llist

-- ## 1.1. `append`
-- A basic list append function
def append {α : Sort _} : llist α → llist α → llist α
| llist.nil ys := ys
| (llist.cons x xs) ys := llist.cons x (append xs ys)

-- List append in continuation-passing style
def append_cps {α β : Sort _} : llist α → llist α → (llist α → β) → β
| llist.nil ys k := k ys
| (llist.cons x xs) ys k := append_cps xs ys (λas, k (llist.cons x as))

lemma append_cps_equiv_append {α β : Sort _} :
  ∀ (xs ys : llist α) (k : llist α → β),
    append_cps xs ys k = k (append xs ys) :=
begin
  intros xs ys,
  induction' xs,
  {
    intro k,
    refl,
  },
  {
    intro k,
    calc append_cps (llist.cons x xs) ys k
         = append_cps xs ys (λas, k (llist.cons x as)) : rfl
     ... = (λas, k (llist.cons x as)) (append xs ys) : ih ys (λas, k
                                                              (llist.cons x as))
     ... = k (llist.cons x (append xs ys)) : rfl
     ... = k (append (llist.cons x xs) ys) : rfl
  }
end

-- ## 1.2. `map`
-- A basic list map function
def map {α β : Sort _} (f : α → β) : llist α → llist β
| llist.nil := llist.nil
| (llist.cons x xs) := llist.cons (f x) (map xs)

-- ### 1.2.1. `map_cps`
-- A "partial-CPS" map function: it returns via a continuation, but the mapping
-- function is not in CPS
def map_cps {α β γ : Sort _} (f : α → β) : llist α → (llist β → γ) → γ
| llist.nil k := k llist.nil
| (llist.cons x xs) k := map_cps xs (λxs', k (llist.cons (f x) xs'))

lemma map_cps_equiv_map {α β γ : Sort _} :
  ∀ (f : α → β) (xs : llist α) (k : llist β → γ),
    map_cps f xs k = k (map f xs) :=
begin
  intros f xs,
  -- The key is to induct *without* binding k!
  induction' xs,
  {
    intro k,
    refl,
  },
  {
    intro k,
    calc map_cps f (llist.cons x xs) k
         = map_cps f xs (λxs', k (llist.cons (f x) xs')) : rfl
     ... = (λxs', k (llist.cons (f x) xs')) (map f xs) : ih f (λxs', k
                                                         (llist.cons (f x) xs'))
     ... = k (llist.cons (f x) (map f xs)) : rfl
     ... = k (map f (llist.cons x xs)) : rfl
  }
end

-- ### 1.2.2. `map_full_cps`
-- A full ("higher-order") CPS map: it returns via a continuation, and its
-- function argument must also be in CPS
def map_full_cps {α β γ : Sort _}
  (f : α → (β → γ) → γ) : llist α → (llist β → γ) → γ
| llist.nil k := k llist.nil
| (llist.cons x xs) k := map_full_cps xs (λxs', f x (λx', k (llist.cons x' xs')))

lemma map_full_cps_equiv_map {α β γ : Sort _} :
  ∀ (f : α → β)
    (xs : llist α)
    (k : llist β → γ),
    map_full_cps (λx kf, kf (f x)) xs k = k (map f xs) :=
begin
  intros f xs,
  induction' xs,
  {
    intro k,
    refl,
  },
  {
    intro k,
    let f_cps := (λx (kf : β → γ), kf (f x)),
    calc map_full_cps f_cps (llist.cons x xs) k
         = map_full_cps f_cps xs (λxs', f_cps x (λx', k (llist.cons x' xs')))
            : rfl
         -- the below avoids having to rewrite f_cps
     ... = (λxs', f_cps x (λx', k (llist.cons x' xs'))) (map f xs) : by apply ih
     ... = f_cps x (λx', k (llist.cons x' (map f xs))) : rfl
     -- The lines below are technically superfluous, but nonetheless reassuring
     ... = (λx', k (llist.cons x' (map f xs))) (f x) : rfl
     ... = k (llist.cons (f x) (map f xs)) : rfl
     ... = k (map f (llist.cons x xs)) : rfl
  }
end

-- ## 1.3. `filter`
-- A basic list filter function
def filter {α : Sort _} (p : α → Prop) [decidable_pred p] : llist α → llist α
| llist.nil := llist.nil
| (llist.cons x xs) := if p x then llist.cons x (filter xs) else filter xs

-- ### 1.3.1 `filter_cps`
-- A "partial CPS" filter function: the result is returned using a continuation,
-- but the predicate returns a Prop directly
def filter_cps {α β : Sort _} (p : α → Prop) [decidable_pred p] :
    llist α → (llist α → β) → β
| llist.nil k := k llist.nil
| (llist.cons x xs) k := filter_cps xs (λxs', if p x
                                              then k (llist.cons x xs')
                                              else k xs')

-- We'll use the fact that function application "distributes" over ite to enable
-- calc-mode proofs about filter to go through cleanly without casework
lemma ite_distro (γ δ : Sort _) (f : γ → δ) (x y : γ) (b : Prop) [decidable b] :
  (if b then f x else f y) = f (if b then x else y) := by split_ifs; refl

lemma filter_cps_equiv_filter {α β : Sort _} (p : α → Prop) [decidable_pred p] :
  ∀ (xs : llist α) (k : llist α → β),
    filter_cps p xs k = k (filter p xs) :=
begin
  intro xs,
  induction' xs,
  {
    intro k,
    refl,
  },
  {
    intro k,
    resetI,  -- deal with decidability type-class synthesis issues
    calc filter_cps p (llist.cons x xs) k
         = filter_cps p xs (λxs', if p x then k (llist.cons x xs') else k xs')
            : rfl
     ... = (λxs', if p x then k (llist.cons x xs') else k xs') (filter p xs)
            : by rw ih
     ... = if p x then k (llist.cons x (filter p xs)) else k (filter p xs)
            : rfl
     ... = k (if p x then llist.cons x (filter p xs) else filter p xs)
            : by apply ite_distro
     ... = k (filter p (llist.cons x xs)) : rfl
  }
end

-- ### 1.3.2 `filter_full_cps`
-- A "full"/"higher order" CPS filter: the predicate is now also in CPS
def filter_full_cps {α β : Sort _} (p : α → (unit → β) → (unit → β) → β) :
  llist α → (llist α → β) → β
| llist.nil k := k llist.nil
| (llist.cons x xs) k := filter_full_cps xs
                                         (λxs', p x (λ _, k (llist.cons x xs'))
                                         (λ _, k xs'))

lemma filter_full_cps_equiv_filter {α β : Sort _}
                                   (p : α → Prop)
                                   [decidable_pred p] :
  ∀ (xs : llist α) (k : llist α → β),
  filter_full_cps (λ (x : α) (sk : unit → β) (fk : unit → β),
                    if p x then sk () else fk ())
                  xs
                  k
  = k (filter p xs) :=
begin
  intro xs,
  induction' xs,
  {
    intro k,
    refl,
  },
  {
    intro k,
    resetI,  -- deal with decidability type-class synthesis issues
    let p_cps := (λ (x : α) (sk fk : unit → β), if p x then sk () else fk ()),
    calc filter_full_cps p_cps (llist.cons x xs) k
         = filter_full_cps p_cps xs (λxs', p_cps x (λ _,
              k (llist.cons x xs')) (λ _, k xs')) : rfl
     ... = (λxs', p_cps x (λ _, k (llist.cons x xs')) (λ _, k xs'))
              (filter p xs) : by apply ih
     ... = p_cps x (λ _, k (llist.cons x (filter p xs)))
              (λ _, k (filter p xs)) : rfl
     ... = if p x then (λ _, k (llist.cons x (filter p xs))) ()
                  else (λ _, k (filter p xs)) () : rfl
     ... = if p x then k (llist.cons x (filter p xs)) else k (filter p xs) : rfl
     ... = k (if p x then llist.cons x (filter p xs) else filter p xs)
              : by apply ite_distro
     ... = k (filter p (llist.cons x xs)) : rfl
  }
end

-- ## 1.4. `foldr`
-- A standard list (right) fold
def foldr {α β : Sort _} (g : α → β → β) (z : β) : llist α → β
| llist.nil := z
| (llist.cons x xs) := g x (foldr xs)

-- ### 1.4.1 `foldr_cps`
-- A partial-CPS right fold: the result is returned via a continuation, but the
-- argument g is in direct style

-- Unfortunately, some compilation issues in Lean prevent this version from
-- working (we'd need to needlessly restrict β and γ to the same universe):
-- def foldr_cps {α β γ : Sort _} (g : α → β → β) (z : β)
--     : llist α → (β → γ) → γ
-- | llist.nil k := k z
-- | (llist.cons x xs) k := foldr_cps xs (λz', k (g x z'))

def foldr_cps {α β γ : Sort _} (g : α → β → β) (z : β) (l : llist α)
  : (β → γ) → γ :=
@llist.rec_on α (λ _, (β → γ) → γ) l
(λk, k z)
(λx xs r k, r (λ z', k (g x z')))

lemma foldr_cps_equiv_foldr {α β γ : Sort _} :
  ∀ (g : α → β → β) (z : β) (xs : llist α) (k : β → γ),
    foldr_cps g z xs k = k (foldr g z xs) :=
begin
  intros g z xs,
  induction' xs,
  {
    intro k,
    refl,
  },
  {
    intro k,
    calc foldr_cps g z (llist.cons x xs) k
         = foldr_cps g z xs (λz', k (g x z')) : rfl
     ... = (λz', k (g x z')) (foldr g z xs) : ih g z (λz', k (g x z'))
     ... = k (g x (foldr g z xs)) : rfl
     ... = k (foldr g z (llist.cons x xs)) : rfl
  }
end

-- ### 1.4.2 `foldr_full_cps`
-- A full-CPS right fold: both g and the fold function are in CPS

-- Same issue as above
-- def foldr_full_cps {α β γ : Sort _} (g : α → β → (β → γ) → γ) (z : β)
--     : llist α → (β → γ) → γ
-- | llist.nil k := k z
-- | (llist.cons x xs) k := foldr_full_cps xs (λz', g x z' (λz'', k z''))

def foldr_full_cps {α β γ : Sort _} (g : α → β → (β → γ) → γ)
                                    (z : β)
                                    (l : llist α) : (β → γ) → γ :=
@llist.rec_on α (λ _, (β → γ) → γ) l
(λk, k z)
(λx xs r k, r (λz', g x z' (λz'', k z'')))

lemma foldr_full_cps_equiv_foldr {α β γ : Sort _} :
  ∀ (g : α → β → β) (z : β) (xs : llist α) (k : β → γ),
    foldr_full_cps (λa b k, k (g a b)) z xs k = k (foldr g z xs) :=
begin
  intros g z xs,
  induction' xs,
  {
    intro k,
    refl,
  },
  {
    intro k,
    let g_cps := (λ(a : α) (b : β) (k : β → γ), k (g a b)),
    calc foldr_full_cps g_cps z (llist.cons x xs) k
         = foldr_full_cps g_cps z xs (λz', g_cps x z' (λz'', k z'')) : rfl
     ... = (λz', g_cps x z' (λz'', k z'')) (foldr g z xs) : ih g z (λz',
                                                              g_cps x z'
                                                              (λz'', k z''))
     ... = g_cps x (foldr g z xs) (λz'', k z'') : rfl
     ... = k (g x (foldr g z xs)) : rfl
     ... = k (foldr g z (llist.cons x xs)) : rfl
  }
end

end llist