/-
Copyright (c) 2020 Kenny Lau. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kenny Lau
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.category_theory.sites.canonical
import Mathlib.category_theory.sites.sheaf_of_types
import Mathlib.PostPort

universes u u_1

namespace Mathlib

/-!
# Grothendieck Topology and Sheaves on the Category of Types

In this file we define a Grothendieck topology on the category of types,
and construct the canonical functor that sends a type to a sheaf over
the category of types, and make this an equivalence of categories.

Then we prove that the topology defined is the canonical topology.
-/

namespace category_theory

/-- A Grothendieck topology associated to the category of all types.
A sieve is a covering iff it is jointly surjective. -/
def types_grothendieck_topology : grothendieck_topology (Type u) :=
  grothendieck_topology.mk
    (fun (α : Type u) (S : sieve α) => ∀ (x : α), coe_fn S PUnit fun (_x : PUnit) => x) sorry sorry
    sorry

/-- The discrete sieve on a type, which only includes arrows whose image is a subsingleton. -/
@[simp] theorem discrete_sieve_apply (α : Type u) (β : Type u) (f : β ⟶ α) :
    coe_fn (discrete_sieve α) β f = ∃ (x : α), ∀ (y : β), f y = x :=
  Eq.refl (coe_fn (discrete_sieve α) β f)

theorem discrete_sieve_mem (α : Type u) : discrete_sieve α ∈ coe_fn types_grothendieck_topology α :=
  fun (x : α) => Exists.intro x fun (y : PUnit) => rfl

/-- The discrete presieve on a type, which only includes arrows whose domain is a singleton. -/
def discrete_presieve (α : Type u) : presieve α :=
  fun (β : Type u) (f : β ⟶ α) => ∃ (x : β), ∀ (y : β), y = x

theorem generate_discrete_presieve_mem (α : Type u) :
    sieve.generate (discrete_presieve α) ∈ coe_fn types_grothendieck_topology α :=
  sorry

theorem is_sheaf_yoneda' {α : Type u} :
    presieve.is_sheaf types_grothendieck_topology (functor.obj yoneda α) :=
  sorry

/-- The yoneda functor that sends a type to a sheaf over the category of types -/
@[simp] theorem yoneda'_map (α : Type u) (β : Type u) (f : α ⟶ β) :
    functor.map yoneda' f = functor.map yoneda f :=
  Eq.refl (functor.map yoneda' f)

@[simp] theorem yoneda'_comp : yoneda' ⋙ induced_functor subtype.val = yoneda := rfl

/-- Given a presheaf `P` on the category of types, construct
a map `P(α) → (α → P(*))` for all type `α`. -/
def eval (P : Type uᵒᵖ ⥤ Type u) (α : Type u) (s : functor.obj P (opposite.op α)) (x : α) :
    functor.obj P (opposite.op PUnit) :=
  functor.map P (has_hom.hom.op (↾fun (_x : PUnit) => x)) s

/-- Given a sheaf `S` on the category of types, construct a map
`(α → S(*)) → S(α)` that is inverse to `eval`. -/
def types_glue (S : Type uᵒᵖ ⥤ Type u) (hs : presieve.is_sheaf types_grothendieck_topology S)
    (α : Type u) (f : α → functor.obj S (opposite.op PUnit)) : functor.obj S (opposite.op α) :=
  presieve.is_sheaf_for.amalgamate sorry
    (fun (β : Type u) (g : β ⟶ α) (hg : discrete_presieve α g) =>
      functor.map S (has_hom.hom.op (↾fun (x : β) => PUnit.unit)) (f (g (classical.some hg))))
    sorry

theorem eval_types_glue {S : Type uᵒᵖ ⥤ Type u}
    {hs : presieve.is_sheaf types_grothendieck_topology S} {α : Type u}
    (f : α → functor.obj S (opposite.op PUnit)) : eval S α (types_glue S hs α f) = f :=
  sorry

theorem types_glue_eval {S : Type uᵒᵖ ⥤ Type u}
    {hs : presieve.is_sheaf types_grothendieck_topology S} {α : Type u}
    (s : functor.obj S (opposite.op α)) : types_glue S hs α (eval S α s) = s :=
  sorry

/-- Given a sheaf `S`, construct an equivalence `S(α) ≃ (α → S(*))`. -/
def eval_equiv (S : Type uᵒᵖ ⥤ Type u) (hs : presieve.is_sheaf types_grothendieck_topology S)
    (α : Type u) : functor.obj S (opposite.op α) ≃ (α → functor.obj S (opposite.op PUnit)) :=
  equiv.mk (eval S α) (types_glue S hs α) types_glue_eval eval_types_glue

theorem eval_map (S : Type uᵒᵖ ⥤ Type u) (α : Type u) (β : Type u) (f : β ⟶ α)
    (s : functor.obj S (opposite.op α)) (x : β) :
    eval S β (functor.map S (has_hom.hom.op f) s) x = eval S α s (f x) :=
  sorry

/-- Given a sheaf `S`, construct an isomorphism `S ≅ [-, S(*)]`. -/
def equiv_yoneda (S : Type uᵒᵖ ⥤ Type u) (hs : presieve.is_sheaf types_grothendieck_topology S) :
    S ≅ functor.obj yoneda (functor.obj S (opposite.op PUnit)) :=
  nat_iso.of_components (fun (α : Type uᵒᵖ) => equiv.to_iso (eval_equiv S hs (opposite.unop α)))
    sorry

/-- Given a sheaf `S`, construct an isomorphism `S ≅ [-, S(*)]`. -/
@[simp] theorem equiv_yoneda'_inv (S : SheafOfTypes types_grothendieck_topology) :
    iso.inv (equiv_yoneda' S) = iso.inv (equiv_yoneda (subtype.val S) (equiv_yoneda'._proof_1 S)) :=
  Eq.refl (iso.inv (equiv_yoneda' S))

theorem eval_app (S₁ : SheafOfTypes types_grothendieck_topology)
    (S₂ : SheafOfTypes types_grothendieck_topology) (f : S₁ ⟶ S₂) (α : Type u)
    (s : functor.obj (subtype.val S₁) (opposite.op α)) (x : α) :
    eval (subtype.val S₂) α (nat_trans.app f (opposite.op α) s) x =
        nat_trans.app f (opposite.op PUnit) (eval (subtype.val S₁) α s x) :=
  Eq.symm (congr_fun (nat_trans.naturality' f (has_hom.hom.op (↾fun (_x : PUnit) => x))) s)

/-- `yoneda'` induces an equivalence of category between `Type u` and
`Sheaf types_grothendieck_topology`. -/
@[simp] theorem type_equiv_inverse_obj (X : SheafOfTypes types_grothendieck_topology) :
    functor.obj (equivalence.inverse type_equiv) X = functor.obj (↑X) (opposite.op PUnit) :=
  Eq.refl (functor.obj (↑X) (opposite.op PUnit))

theorem subcanonical_types_grothendieck_topology : sheaf.subcanonical types_grothendieck_topology :=
  sheaf.subcanonical.of_yoneda_is_sheaf types_grothendieck_topology
    fun (X : Type u) => is_sheaf_yoneda'

theorem types_grothendieck_topology_eq_canonical :
    types_grothendieck_topology = sheaf.canonical_topology (Type u) :=
  sorry

end Mathlib


import tactic.default

theorem addition_of_natural_numbers_is_commutative (m n : ℕ) :
  m + n = n + m :=
begin
  induction n with d hd,
  {
    ring,
  },
  {
    ring,
  }
end


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

A data type for semiquotients, which are classically equivalent to
nonempty sets, but are useful for programming; the idea is that
a semiquotient set `S` represents some (particular but unknown)
element of `S`. This can be used to model nondeterministic functions,
which return something in a range of values (represented by the
predicate `S`) but are not completely determined.
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.set.lattice
import Mathlib.PostPort

universes u u_1 l u_2 u_3 u_4 u_5

namespace Mathlib

/-- A member of `semiquot α` is classically a nonempty `set α`,
  and in the VM is represented by an element of `α`; the relation
  between these is that the VM element is required to be a member
  of the set `s`. The specific element of `s` that the VM computes
  is hidden by a quotient construction, allowing for the representation
  of nondeterministic functions. -/
structure semiquot (α : Type u_1)
  mk' ::
where (s : set α) (val : trunc ↥s)

namespace semiquot

protected instance has_mem {α : Type u_1} : has_mem α (semiquot α) :=
  has_mem.mk fun (a : α) (q : semiquot α) => a ∈ s q

/-- Construct a `semiquot α` from `h : a ∈ s` where `s : set α`. -/
def mk {α : Type u_1} {a : α} {s : set α} (h : a ∈ s) : semiquot α :=
  mk' s (trunc.mk { val := a, property := h })

theorem ext_s {α : Type u_1} {q₁ : semiquot α} {q₂ : semiquot α} : q₁ = q₂ ↔ s q₁ = s q₂ := sorry

theorem ext {α : Type u_1} {q₁ : semiquot α} {q₂ : semiquot α} : q₁ = q₂ ↔ ∀ (a : α), a ∈ q₁ ↔ a ∈ q₂ :=
  iff.trans ext_s set.ext_iff

theorem exists_mem {α : Type u_1} (q : semiquot α) : ∃ (a : α), a ∈ q := sorry

theorem eq_mk_of_mem {α : Type u_1} {q : semiquot α} {a : α} (h : a ∈ q) : q = mk h :=
  iff.mpr ext_s rfl

theorem nonempty {α : Type u_1} (q : semiquot α) : set.nonempty (s q) :=
  exists_mem q

/-- `pure a` is `a` reinterpreted as an unspecified element of `{a}`. -/
protected def pure {α : Type u_1} (a : α) : semiquot α :=
  mk (set.mem_singleton a)

@[simp] theorem mem_pure' {α : Type u_1} {a : α} {b : α} : a ∈ semiquot.pure b ↔ a = b :=
  set.mem_singleton_iff

/-- Replace `s` in a `semiquot` with a superset. -/
def blur' {α : Type u_1} (q : semiquot α) {s : set α} (h : s q ⊆ s) : semiquot α :=
  mk' s (trunc.lift (fun (a : ↥(s q)) => trunc.mk { val := subtype.val a, property := sorry }) sorry (val q))

/-- Replace `s` in a `q : semiquot α` with a union `s ∪ q.s` -/
def blur {α : Type u_1} (s : set α) (q : semiquot α) : semiquot α :=
  blur' q sorry

theorem blur_eq_blur' {α : Type u_1} (q : semiquot α) (s : set α) (h : s q ⊆ s) : blur s q = blur' q h := sorry

@[simp] theorem mem_blur' {α : Type u_1} (q : semiquot α) {s : set α} (h : s q ⊆ s) {a : α} : a ∈ blur' q h ↔ a ∈ s :=
  iff.rfl

/-- Convert a `trunc α` to a `semiquot α`. -/
def of_trunc {α : Type u_1} (q : trunc α) : semiquot α :=
  mk' set.univ (trunc.map (fun (a : α) => { val := a, property := trivial }) q)

/-- Convert a `semiquot α` to a `trunc α`. -/
def to_trunc {α : Type u_1} (q : semiquot α) : trunc α :=
  trunc.map subtype.val (val q)

/-- If `f` is a constant on `q.s`, then `q.lift_on f` is the value of `f`
at any point of `q`. -/
def lift_on {α : Type u_1} {β : Type u_2} (q : semiquot α) (f : α → β) (h : ∀ (a b : α), a ∈ q → b ∈ q → f a = f b) : β :=
  trunc.lift_on (val q) (fun (x : ↥(s q)) => f (subtype.val x)) sorry

theorem lift_on_of_mem {α : Type u_1} {β : Type u_2} (q : semiquot α) (f : α → β) (h : ∀ (a b : α), a ∈ q → b ∈ q → f a = f b) (a : α) (aq : a ∈ q) : lift_on q f h = f a :=
  eq.mpr
    (id (Eq._oldrec (Eq.refl (∀ (h : ∀ (a b : α), a ∈ q → b ∈ q → f a = f b), lift_on q f h = f a)) (eq_mk_of_mem aq)))
    (fun (h : ∀ (a_1 b : α), a_1 ∈ mk aq → b ∈ mk aq → f a_1 = f b) => Eq.refl (lift_on (mk aq) f h)) h

def map {α : Type u_1} {β : Type u_2} (f : α → β) (q : semiquot α) : semiquot β :=
  mk' (f '' s q) (trunc.map (fun (x : ↥(s q)) => { val := f (subtype.val x), property := sorry }) (val q))

@[simp] theorem mem_map {α : Type u_1} {β : Type u_2} (f : α → β) (q : semiquot α) (b : β) : b ∈ map f q ↔ ∃ (a : α), a ∈ q ∧ f a = b :=
  set.mem_image (fun (a : α) => f a) (s q) b

def bind {α : Type u_1} {β : Type u_2} (q : semiquot α) (f : α → semiquot β) : semiquot β :=
  mk' (set.Union fun (a : α) => set.Union fun (H : a ∈ s q) => s (f a))
    (trunc.bind (val q)
      fun (a : ↥(s q)) =>
        trunc.map (fun (b : ↥(s (f (subtype.val a)))) => { val := subtype.val b, property := sorry })
          (val (f (subtype.val a))))

@[simp] theorem mem_bind {α : Type u_1} {β : Type u_2} (q : semiquot α) (f : α → semiquot β) (b : β) : b ∈ bind q f ↔ ∃ (a : α), ∃ (H : a ∈ q), b ∈ f a :=
  set.mem_bUnion_iff

protected instance monad : Monad semiquot :=
  { toApplicative :=
      { toFunctor := { map := map, mapConst := fun (α β : Type u_1) => map ∘ function.const β },
        toPure := { pure := semiquot.pure },
        toSeq :=
          { seq := fun (α β : Type u_1) (f : semiquot (α → β)) (x : semiquot α) => bind f fun (_x : α → β) => map _x x },
        toSeqLeft :=
          { seqLeft :=
              fun (α β : Type u_1) (a : semiquot α) (b : semiquot β) =>
                (fun (α β : Type u_1) (f : semiquot (α → β)) (x : semiquot α) => bind f fun (_x : α → β) => map _x x) β α
                  (map (function.const β) a) b },
        toSeqRight :=
          { seqRight :=
              fun (α β : Type u_1) (a : semiquot α) (b : semiquot β) =>
                (fun (α β : Type u_1) (f : semiquot (α → β)) (x : semiquot α) => bind f fun (_x : α → β) => map _x x) β β
                  (map (function.const α id) a) b } },
    toBind := { bind := bind } }

@[simp] theorem map_def {α : Type u_1} {β : Type u_1} : Functor.map = map :=
  rfl

@[simp] theorem bind_def {α : Type u_1} {β : Type u_1} : bind = bind :=
  rfl

@[simp] theorem mem_pure {α : Type u_1} {a : α} {b : α} : a ∈ pure b ↔ a = b :=
  set.mem_singleton_iff

theorem mem_pure_self {α : Type u_1} (a : α) : a ∈ pure a :=
  set.mem_singleton a

@[simp] theorem pure_inj {α : Type u_1} {a : α} {b : α} : pure a = pure b ↔ a = b :=
  iff.trans ext_s set.singleton_eq_singleton_iff

protected instance is_lawful_monad : is_lawful_monad semiquot := sorry

protected instance has_le {α : Type u_1} : HasLessEq (semiquot α) :=
  { LessEq := fun (s t : semiquot α) => s s ⊆ s t }

protected instance partial_order {α : Type u_1} : partial_order (semiquot α) :=
  partial_order.mk (fun (s t : semiquot α) => ∀ {x : α}, x ∈ s → x ∈ t)
    (preorder.lt._default fun (s t : semiquot α) => ∀ {x : α}, x ∈ s → x ∈ t) sorry sorry sorry

protected instance semilattice_sup {α : Type u_1} : semilattice_sup (semiquot α) :=
  semilattice_sup.mk (fun (s : semiquot α) => blur (s s)) partial_order.le partial_order.lt sorry sorry sorry sorry sorry
    sorry

@[simp] theorem pure_le {α : Type u_1} {a : α} {s : semiquot α} : pure a ≤ s ↔ a ∈ s :=
  set.singleton_subset_iff

def is_pure {α : Type u_1} (q : semiquot α) :=
  ∀ (a b : α), a ∈ q → b ∈ q → a = b

def get {α : Type u_1} (q : semiquot α) (h : is_pure q) : α :=
  lift_on q id h

theorem get_mem {α : Type u_1} {q : semiquot α} (p : is_pure q) : get q p ∈ q := sorry

theorem eq_pure {α : Type u_1} {q : semiquot α} (p : is_pure q) : q = pure (get q p) := sorry

@[simp] theorem pure_is_pure {α : Type u_1} (a : α) : is_pure (pure a) :=
  fun (a_1 b : α) (H : a_1 ∈ pure a) (H_1 : b ∈ pure a) =>
    idRhs (a_1 = b)
      (of_eq_true (eq_true_intro (Eq.trans (eq.mp (propext mem_pure) H) (Eq.symm (eq.mp (propext mem_pure) H_1)))))

theorem is_pure_iff {α : Type u_1} {s : semiquot α} : is_pure s ↔ ∃ (a : α), s = pure a := sorry

theorem is_pure.mono {α : Type u_1} {s : semiquot α} {t : semiquot α} (st : s ≤ t) (h : is_pure t) : is_pure s :=
  fun (a b : α) (H : a ∈ s) (H_1 : b ∈ s) => idRhs (a = b) (h a b (st H) (st H_1))

theorem is_pure.min {α : Type u_1} {s : semiquot α} {t : semiquot α} (h : is_pure t) : s ≤ t ↔ s = t := sorry

theorem is_pure_of_subsingleton {α : Type u_1} [subsingleton α] (q : semiquot α) : is_pure q :=
  fun (a b : α) (H : a ∈ q) (H : b ∈ q) => idRhs (a = b) (subsingleton.elim a b)

/-- `univ : semiquot α` represents an unspecified element of `univ : set α`. -/
def univ {α : Type u_1} [Inhabited α] : semiquot α :=
  mk sorry

protected instance inhabited {α : Type u_1} [Inhabited α] : Inhabited (semiquot α) :=
  { default := univ }

@[simp] theorem mem_univ {α : Type u_1} [Inhabited α] (a : α) : a ∈ univ :=
  set.mem_univ

theorem univ_unique {α : Type u_1} (I : Inhabited α) (J : Inhabited α) : univ = univ := sorry

@[simp] theorem is_pure_univ {α : Type u_1} [Inhabited α] : is_pure univ ↔ subsingleton α := sorry

protected instance order_top {α : Type u_1} [Inhabited α] : order_top (semiquot α) :=
  order_top.mk univ partial_order.le partial_order.lt sorry sorry sorry sorry

protected instance semilattice_sup_top {α : Type u_1} [Inhabited α] : semilattice_sup_top (semiquot α) :=
  semilattice_sup_top.mk order_top.top order_top.le order_top.lt sorry sorry sorry sorry semilattice_sup.sup sorry sorry
    sorry


/-
Copyright (c) 2020 Kenji Nakagawa. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kenji Nakagawa, Anne Baanen, Filippo A. E. Nuccio
-/
import ring_theory.dedekind_domain.basic
import ring_theory.trace

/-!
# Integral closure of Dedekind domains

This file shows the integral closure of a Dedekind domain (in particular, the ring of integers
of a number field) is a Dedekind domain.

## Implementation notes

The definitions that involve a field of fractions choose a canonical field of fractions,
but are independent of that choice. The `..._iff` lemmas express this independence.

Often, definitions assume that Dedekind domains are not fields. We found it more practical
to add a `(h : ¬ is_field A)` assumption whenever this is explicitly needed.

## References

* [D. Marcus, *Number Fields*][marcus1977number]
* [J.W.S. Cassels, A. Frölich, *Algebraic Number Theory*][cassels1967algebraic]
* [J. Neukirch, *Algebraic Number Theory*][Neukirch1992]

## Tags

dedekind domain, dedekind ring
-/

variables (R A K : Type*) [comm_ring R] [comm_ring A] [field K]

open_locale non_zero_divisors polynomial

variables [is_domain A]

section is_integral_closure

/-! ### `is_integral_closure` section

We show that an integral closure of a Dedekind domain in a finite separable
field extension is again a Dedekind domain. This implies the ring of integers
of a number field is a Dedekind domain. -/

open algebra
open_locale big_operators

variables {A K} [algebra A K] [is_fraction_ring A K]
variables {L : Type*} [field L] (C : Type*) [comm_ring C]
variables [algebra K L] [finite_dimensional K L] [algebra A L] [is_scalar_tower A K L]
variables [algebra C L] [is_integral_closure C A L] [algebra A C] [is_scalar_tower A C L]

lemma is_integral_closure.range_le_span_dual_basis [is_separable K L]
  {ι : Type*} [fintype ι] [decidable_eq ι] (b : basis ι K L)
  (hb_int : ∀ i, is_integral A (b i)) [is_integrally_closed A] :
  ((algebra.linear_map C L).restrict_scalars A).range ≤
    submodule.span A (set.range $ (trace_form K L).dual_basis (trace_form_nondegenerate K L) b) :=
begin
  let db := (trace_form K L).dual_basis (trace_form_nondegenerate K L) b,
  rintros _ ⟨x, rfl⟩,
  simp only [linear_map.coe_restrict_scalars_eq_coe, algebra.linear_map_apply],
  have hx : is_integral A (algebra_map C L x) :=
    (is_integral_closure.is_integral A L x).algebra_map,
  suffices : ∃ (c : ι → A), algebra_map C L x = ∑ i, c i • db i,
  { obtain ⟨c, x_eq⟩ := this,
    rw x_eq,
    refine submodule.sum_mem _ (λ i _, submodule.smul_mem _ _ (submodule.subset_span _)),
    rw set.mem_range,
    exact ⟨i, rfl⟩ },
  suffices : ∃ (c : ι → K), ((∀ i, is_integral A (c i)) ∧ algebra_map C L x = ∑ i, c i • db i),
  { obtain ⟨c, hc, hx⟩ := this,
    have hc' : ∀ i, is_localization.is_integer A (c i) :=
      λ i, is_integrally_closed.is_integral_iff.mp (hc i),
    use λ i, classical.some (hc' i),
    refine hx.trans (finset.sum_congr rfl (λ i _, _)),
    conv_lhs { rw [← classical.some_spec (hc' i)] },
    rw [← is_scalar_tower.algebra_map_smul K (classical.some (hc' i)) (db i)] },
  refine ⟨λ i, db.repr (algebra_map C L x) i, (λ i, _), (db.sum_repr _).symm⟩,
  rw bilin_form.dual_basis_repr_apply,
  exact is_integral_trace (is_integral_mul hx (hb_int i))
end

lemma integral_closure_le_span_dual_basis [is_separable K L]
  {ι : Type*} [fintype ι] [decidable_eq ι] (b : basis ι K L)
  (hb_int : ∀ i, is_integral A (b i)) [is_integrally_closed A] :
  (integral_closure A L).to_submodule ≤ submodule.span A (set.range $
    (trace_form K L).dual_basis (trace_form_nondegenerate K L) b) :=
begin
  refine le_trans _ (is_integral_closure.range_le_span_dual_basis (integral_closure A L) b hb_int),
  intros x hx,
  exact ⟨⟨x, hx⟩, rfl⟩
end

variables (A) (K)

include K

/-- Send a set of `x`'es in a finite extension `L` of the fraction field of `R`
to `(y : R) • x ∈ integral_closure R L`. -/
lemma exists_integral_multiples (s : finset L) :
  ∃ (y ≠ (0 : A)), ∀ x ∈ s, is_integral A (y • x) :=
begin
  haveI := classical.dec_eq L,
  refine s.induction _ _,
  { use [1, one_ne_zero],
    rintros x ⟨⟩ },
  { rintros x s hx ⟨y, hy, hs⟩,
    obtain ⟨x', y', hy', hx'⟩ := exists_integral_multiple
      ((is_fraction_ring.is_algebraic_iff A K L).mpr (is_algebraic_of_finite _ _ x))
      ((injective_iff_map_eq_zero (algebra_map A L)).mp _),
    refine ⟨y * y', mul_ne_zero hy hy', λ x'' hx'', _⟩,
    rcases finset.mem_insert.mp hx'' with (rfl | hx''),
    { rw [mul_smul, algebra.smul_def, algebra.smul_def, mul_comm _ x'', hx'],
      exact is_integral_mul is_integral_algebra_map x'.2 },
    { rw [mul_comm, mul_smul, algebra.smul_def],
      exact is_integral_mul is_integral_algebra_map (hs _ hx'') },
    { rw is_scalar_tower.algebra_map_eq A K L,
      apply (algebra_map K L).injective.comp,
      exact is_fraction_ring.injective _ _ } }
end

variables (L)

/-- If `L` is a finite extension of `K = Frac(A)`,
then `L` has a basis over `A` consisting of integral elements. -/
lemma finite_dimensional.exists_is_basis_integral :
  ∃ (s : finset L) (b : basis s K L), (∀ x, is_integral A (b x)) :=
begin
  letI := classical.dec_eq L,
  letI : is_noetherian K L := is_noetherian.iff_fg.2 infer_instance,
  let s' := is_noetherian.finset_basis_index K L,
  let bs' := is_noetherian.finset_basis K L,
  obtain ⟨y, hy, his'⟩ := exists_integral_multiples A K (finset.univ.image bs'),
  have hy' : algebra_map A L y ≠ 0,
  { refine mt ((injective_iff_map_eq_zero (algebra_map A L)).mp _ _) hy,
    rw is_scalar_tower.algebra_map_eq A K L,
    exact (algebra_map K L).injective.comp (is_fraction_ring.injective A K) },
  refine ⟨s', bs'.map { to_fun := λ x, algebra_map A L y * x,
                        inv_fun := λ x, (algebra_map A L y)⁻¹ * x,
                        left_inv := _,
                        right_inv := _,
                        .. algebra.lmul _ _ (algebra_map A L y) },
          _⟩,
  { intros x, simp only [inv_mul_cancel_left₀ hy'] },
  { intros x, simp only [mul_inv_cancel_left₀ hy'] },
  { rintros ⟨x', hx'⟩,
    simp only [algebra.smul_def, finset.mem_image, exists_prop, finset.mem_univ, true_and] at his',
    simp only [basis.map_apply, linear_equiv.coe_mk],
    exact his' _ ⟨_, rfl⟩ }
end

variables (A K L) [is_separable K L]
include L

/- If `L` is a finite separable extension of `K = Frac(A)`, where `A` is
integrally closed and Noetherian, the integral closure `C` of `A` in `L` is
Noetherian. -/
lemma is_integral_closure.is_noetherian_ring [is_integrally_closed A] [is_noetherian_ring A] :
  is_noetherian_ring C :=
begin
  haveI := classical.dec_eq L,
  obtain ⟨s, b, hb_int⟩ := finite_dimensional.exists_is_basis_integral A K L,
  rw is_noetherian_ring_iff,
  let b' := (trace_form K L).dual_basis (trace_form_nondegenerate K L) b,
  letI := is_noetherian_span_of_finite A (set.finite_range b'),
  let f : C →ₗ[A] submodule.span A (set.range b') :=
    (submodule.of_le (is_integral_closure.range_le_span_dual_basis C b hb_int)).comp
    ((algebra.linear_map C L).restrict_scalars A).range_restrict,
  refine is_noetherian_of_tower A (is_noetherian_of_ker_bot f _),
  rw [linear_map.ker_comp, submodule.ker_of_le, submodule.comap_bot, linear_map.ker_cod_restrict],
  exact linear_map.ker_eq_bot_of_injective (is_integral_closure.algebra_map_injective C A L)
end

variables {A K}

/- If `L` is a finite separable extension of `K = Frac(A)`, where `A` is
integrally closed and Noetherian, the integral closure of `A` in `L` is
Noetherian. -/
lemma integral_closure.is_noetherian_ring [is_integrally_closed A] [is_noetherian_ring A] :
  is_noetherian_ring (integral_closure A L) :=
is_integral_closure.is_noetherian_ring A K L (integral_closure A L)

variables (A K) [is_domain C]
/- If `L` is a finite separable extension of `K = Frac(A)`, where `A` is a Dedekind domain,
the integral closure `C` of `A` in `L` is a Dedekind domain.

Can't be an instance since `A`, `K` or `L` can't be inferred. See also the instance
`integral_closure.is_dedekind_domain_fraction_ring` where `K := fraction_ring A`
and `C := integral_closure A L`.
-/
lemma is_integral_closure.is_dedekind_domain [h : is_dedekind_domain A] :
  is_dedekind_domain C :=
begin
  haveI : is_fraction_ring C L := is_integral_closure.is_fraction_ring_of_finite_extension A K L C,
  exact
  ⟨is_integral_closure.is_noetherian_ring A K L C,
   h.dimension_le_one.is_integral_closure _ L _,
   (is_integrally_closed_iff L).mpr (λ x hx, ⟨is_integral_closure.mk' C x
      (is_integral_trans (is_integral_closure.is_integral_algebra A L) _ hx),
    is_integral_closure.algebra_map_mk' _ _ _⟩)⟩
end

/- If `L` is a finite separable extension of `K = Frac(A)`, where `A` is a Dedekind domain,
the integral closure of `A` in `L` is a Dedekind domain.

Can't be an instance since `K` can't be inferred. See also the instance
`integral_closure.is_dedekind_domain_fraction_ring` where `K := fraction_ring A`.
-/
lemma integral_closure.is_dedekind_domain [h : is_dedekind_domain A] :
  is_dedekind_domain (integral_closure A L) :=
is_integral_closure.is_dedekind_domain A K L (integral_closure A L)

omit K

variables [algebra (fraction_ring A) L] [is_scalar_tower A (fraction_ring A) L]
variables [finite_dimensional (fraction_ring A) L] [is_separable (fraction_ring A) L]

/- If `L` is a finite separable extension of `Frac(A)`, where `A` is a Dedekind domain,
the integral closure of `A` in `L` is a Dedekind domain.

See also the lemma `integral_closure.is_dedekind_domain` where you can choose
the field of fractions yourself.
-/
instance integral_closure.is_dedekind_domain_fraction_ring
  [is_dedekind_domain A] : is_dedekind_domain (integral_closure A L) :=
integral_closure.is_dedekind_domain A (fraction_ring A) L

end is_integral_closure


import Mathlib.Algebra.Ring.Basic
import Mathlib.Data.Nat.Basic
import Mathlib.Data.Vector
import Mathlib.Data.Set.Basic
import Mathlib.Tactic.Set
import Mathlib.Tactic.Have

import Etch.Basic
import Etch.Op

section defs

abbrev Addr := ℕ
abbrev Val  := ℕ
abbrev Ident := ℕ
def Heap  := Addr → Option ℕ
instance : EmptyCollection Heap := ⟨ fun _ ↦ none ⟩
instance : Membership (ℕ × Val) Heap where mem p s := s p.1 = some p.2
instance (a b : Type) : Membership (a × b) (a → Option b) where mem p s := s p.1 = some p.2

def dom [DecidableEq α] : (α → Option β) → Set α := fun h ↦ { n | ∃ v, h n = some v }
lemma mem_dom_update [DecidableEq α] (h : α → Option β) : a ∈ dom (Function.update h a (some v)) := by simp [dom]

instance : Insert (Addr × ℕ) Heap := ⟨ fun p s ↦ Function.update s p.1 p.2 ⟩
instance : Singleton (Addr × ℕ) Heap := ⟨ fun p ↦ Function.update (∅ : Heap) p.1 p.2 ⟩
notation a " ↦ " b => (a, b)
--notation:max h "[" x " := " y "]" => Function.update h x (some y)

class VariableType (Var : Type) where type : Var → Type
attribute [reducible] VariableType.type
open VariableType

variable (V) [VariableType V] [DecidableEq V]

@[ext]
structure TypedStore where
  val : (v : V) → type v

variable {V}

def TypedStore.update (st : TypedStore V) (x : V) (y : type x) : TypedStore V :=
⟨ Function.update st.val x y ⟩

notation:max h "[" x " := " y "]" => TypedStore.update h x y

-- todo move
@[simps]
def Op.nat (n : ℕ) : Op ℕ where
  argTypes := ![]
  spec := fun _ ↦ n
  opName := "nat_lit"

variable (V)
inductive E : Type → Type 1
| call {α} (op : Op α) (args : (i : Fin op.arity) → E (op.argTypes i)) : E α
| var    : (v : V) → E (type v)

variable {V}
def E.eval (st : TypedStore V) : {α : Type} → E V α → α
| _, var v => st.val v
| _, call op args => op.spec fun param ↦ (args param).eval st

@[simp] theorem TypedStore.val_update_ne (x y : V) (v : type x) (l : TypedStore V) (h : x ≠ y) : (l[x := v]).val y = l.val y := by
  simp [val, update, Function.update]
  intro h'
  exfalso
  apply h h'.symm

@[simp] theorem TypedStore.val_update_eq (x : V) (v : type x) (l : TypedStore V) [DecidableEq V] : (l[x := v]).val x = v := by
  simp [update, Function.update]

example (x y : V)  (v : type x) (l : TypedStore V) [DecidableEq V] (h : x ≠ y) : (l[x := v]).val y = l.val y := by simp [h]

variable (st : TypedStore V)

@[simp] theorem E.eval_nat : (E.call (.nat n) args).eval st = n := rfl
@[simp] theorem E.eval_neg : (E.call .neg ![arg]).eval st = !arg.eval st := rfl -- by simp [E.eval]
-- todo: this isn't automatically used by simp?
@[simp] theorem E.asdf (a b : E V α) [Tagged α] [DecidableEq α] : E.eval l (E.call Op.eq ![a, b]) = decide (a.eval l = b.eval l) := rfl
@[simp] theorem E.eval_lt {α} [Tagged α] [LT α] [DecidableRel (LT.lt : α → α → _) ] (a b : E V α) : (E.call .lt ![a, b]).eval st = true ↔ a.eval st < b.eval st := by simp [E.eval, Op.lt]
@[simp] theorem E.eval_lt_false {α} [Tagged α] [LT α] [DecidableRel (LT.lt : α → α → _) ] (a b : E V α) : (E.call .lt ![a, b]).eval st = false ↔ ¬ (a.eval st < b.eval st) := by simp [E.eval, Op.lt]

variable (V)

inductive P
| store {α} (lval : E V ℕ) (rval : E V α)
| load  (lval : E V ℕ) (y : V)
| put (x : V) (e : E V (type x))
| seq (c₁ c₂ : P) : P
| while (c : E V Bool) (body : P)
| skip
@[match_pattern] infixr:25 ";; " => P.seq

def TypedConfigSet := Heap → TypedStore V → Prop

variable {V}

class Representable (α : Type _) where
  defines : α → Addr → Heap → Prop

class Storable (α : Type _) extends Representable α where
  store : Heap → Addr → α → Heap
  footprint : α → Addr → Set Addr
  valid (h a v) : defines v a (store h a v)
  frame (a loc v h) : a ∉ footprint v loc → (store h loc v) a = h a

def exprDefines [Representable α] : α → E V Addr → Heap → TypedStore V → Prop :=
  fun val a h s ↦ Representable.defines val (a.eval s) h
notation "⦃" addr " ↪ " val "⦄" => exprDefines val addr

instance : Storable Val where
  defines v addr h := (addr, v) ∈ h
  store   h addr v := Function.update h addr v
  footprint _ addr := { addr }
  --disjoint a₁ a₂ := a₁ ≠ a₂
  valid h a v := by simp [Membership.mem, Storable.store]
  frame a loc v h := by
    intro hf
    simp only [Membership.mem, Storable.store, Function.update]
    split
    . contradiction
    . rfl

inductive Sem  : P V → TypedConfigSet V → Heap → TypedStore V → Prop
| skip : Q h l → Sem .skip Q h l
| put  : Q h l[x := y.eval l] → Sem (.put x y) Q h l
| store {α} {rval : E V α} (hr : Storable α)
        (h1 : lval.eval l ∈ dom h)
        : Q (Storable.store h (lval.eval l) (rval.eval l)) l →
          Sem (.store lval rval) Q h l
| load (v : type y) {lval : E V ℕ} [hr : Representable (type y)]
       (hv : ⦃lval ↪ v⦄ h l)
       : Q h l[y := v] → Sem (.load lval y) Q h l
| seq : Sem c₁ (Sem c₂ Q) h l → Sem (c₁;; c₂) Q h l
| whileDone (condFalse : x.eval l = false)
            : Q h l → Sem (.while x c) Q h l
| whileLoop (condTrue  : x.eval l = true)
            : Sem c (Sem (.while x c) Q) h l →
              Sem (.while x c) Q h l

notation c " / " h ", " l " ⇓ " Q => Sem c Q h l

end defs

section instances
variable {V} [VariableType V] [DecidableEq V]
open VariableType

instance [Tagged α] [Add α] : Add (E V α) := ⟨ λ a b => E.call .add ![a, b] ⟩
instance [Tagged α] [Sub α] : Sub (E V α) := ⟨ λ a b => E.call .sub ![a, b] ⟩
instance [Tagged α] [Mul α] : Mul (E V α) := ⟨ λ a b => E.call .mul ![a, b] ⟩
instance [Tagged α] [OfNat α (nat_lit 1)] : OfNat (E V α) (nat_lit 1) := ⟨ E.call .one ![] ⟩
instance : OfNat (E V ℕ) n := ⟨ E.call (.nat n) ![] ⟩
abbrev zero : E V ℕ := 0
instance : Coe ℕ (E V ℕ) := ⟨ fun n => E.call (.nat n) ![] ⟩

@[simp] theorem E.eval_nat' : E.eval st (0 : E V ℕ) = 0 := rfl

infixr:35 " ∧ₕ " => fun a b h ↦ a h ∧ b h

def List.defines [Representable α] (addr : Addr) : List α → Heap → Prop
| [] => fun _ ↦ True
| v :: vs => Representable.defines v addr ∧ₕ defines (addr + 1) vs

instance [Representable α] : Representable (List α) where defines vec := vec.defines
instance [Representable α] : Representable (Vector α n) where defines vec addr heap := ∀ i, Representable.defines (vec.nth i) (addr + i) heap

infixr:40 " << " => λ a b => E.call Op.lt ![a, b]
infixr:40 " != " => λ a b => E.call Op.neg ![E.call Op.eq ![a, b]]

namespace tests₁

inductive V₁ | x | y deriving DecidableEq
@[reducible] instance : VariableType V₁ := ⟨ fun | .x => ℕ | .y => ℕ ⟩
def V₁.var : (v : V₁) → E V₁ (type v)  := E.var
open V₁

def l₁ : TypedStore V₁ := ⟨fun |.x => 2 |.y => 7⟩

example : (.store x.var y.var;; .skip) / {2 ↦ 0} , l₁ ⇓ (fun h _ ↦ ⦃2↪7⦄ h l₁) := by
  apply Sem.seq
  apply Sem.store
  . apply mem_dom_update
  . apply Sem.skip
    apply Storable.valid

example : (.store (x.var + 1) (y.var * 3);; .skip) / {3 ↦ 0} , l₁ ⇓ (fun h _ ↦ ⦃3↪21⦄ h l₁) := by
  apply Sem.seq
  apply Sem.store
  . apply mem_dom_update
  . apply Sem.skip
    apply Storable.valid

example : (P.while (x.var << (3 : E V₁ ℕ)) (.put x (x.var + 1))) /  {}, ⟨fun |x |y => (0 : ℕ)⟩ ⇓ fun _ _ ↦ True := by
  apply Sem.whileLoop
  . simp only
  apply Sem.put
  apply Sem.whileLoop
  . simp only
  apply Sem.put
  apply Sem.whileLoop
  . simp only
  apply Sem.put
  apply Sem.whileDone
  . simp only
  trivial

lemma cong_locals (Q : TypedConfigSet V) (c : P V) (l₁ l₂) (hl : l₁ = l₂) : (c / h, l₁ ⇓ Q) ↔ (c / h, l₂ ⇓ Q) := by rw [hl]
example (k : ℕ) : (.while (x.var != zero) (.put x (x.var - 1))) /  {}, ⟨fun |x => k |y => (0 : ℕ)⟩ ⇓ fun _ l ↦ l.val x = (0 : ℕ) := by
  induction k
  . apply Sem.whileDone
    . simp
    . trivial
  case succ n ih =>
    apply Sem.whileLoop
    . rfl
    . apply Sem.put
      rw [cong_locals]
      . apply ih
      . ext z; cases z <;> rfl

end tests₁
end instances

section tests₂

open VariableType

inductive V | ctr | v | total | base deriving DecidableEq
@[reducible] instance V.VariableType : VariableType V := ⟨ fun | ctr => ℕ | base => ℕ | v => ℕ | total => ℕ ⟩

def V.var : (v : V) → E V (type v)  := E.var
def V.initial : TypedStore V := ⟨fun | ctr | v | total | base => (0 : ℕ)⟩
open V

-- see "bug?" below
@[simp] theorem duplicate_of_succ_sub_succ_eq_sub (l : List ℕ) : Nat.succ (List.length l) - 1 = (List.length l) := by simp

def List.sum [Zero α] [Add α] (l : List α) : α := l.foldr (f := (. + .)) 0
@[simp] theorem List.sum_cons [Zero α] [Add α] (x : α) : (x :: xs).sum = x + xs.sum := rfl

def loopSum : P V :=
.while (ctr.var != 0)
  (.load base.var v;; .put total (total.var + v.var);; .put base (base.var + 1);; .put ctr (ctr.var - 1))

example (array : List ℕ) (hlen : ctr.var.eval l = array.length) (hArr : ⦃base.var ↪ array⦄ h l)
  : loopSum / h, l ⇓ fun _ l' ↦ total.var.eval l' = total.var.eval l + array.sum := by
  induction array generalizing l with
  | nil =>
    --cases hlen
    apply Sem.whileDone
    . simp [E.eval] at hlen; simp [E.eval, hlen]
    . trivial
  | cons x xs ih =>
    apply Sem.whileLoop
    . simp [E.eval] at hlen; simp [E.eval, hlen]
    . apply Sem.seq
      apply Sem.load
      . exact hArr.1
      apply Sem.seq; apply Sem.put
      apply Sem.seq; apply Sem.put
      apply Sem.put
      simp only [E.eval] at hlen
      simp [E.eval, TypedStore.val, hlen]
      rw [← add_assoc]
      set l' := l[v := x][total := TypedStore.val l total + x][base := TypedStore.val l base + 1][ctr := Nat.succ (List.length xs) - 1]
      change (loopSum / _, l' ⇓ _) -- not necessary
      have h : l.val total + x = l'.val total := by simp
      rw [h]
      apply ih
      . simp [E.eval]
        rw [Nat.succ_sub_succ_eq_sub, Nat.sub_zero] -- bug? simp doesn't use these here
      . exact hArr.2


import DmdAnal.Order
import Init.Data.List
import Mathlib.Init.Function
import Mathlib.Init.Set
import Mathlib.Order.Basic

open Function

abbrev Map (α β : Type) := List (α × β)

namespace Map

def empty : Map α β := []

def update [DecidableEq α] (m : Map α β) (k : α) (v : Option β) : Map α β :=
  match v with
  | none   => List.filter (¬ ·.fst = k) m
  | some v => (k,v) :: m

def lookup [DecidableEq α] (m : Map α β) (k : α) : Option β :=
  List.lookup k m

def dom (m : Map α β) :=
  List.map Prod.fst m

macro:max m:term noWs "[" k:term " ↦ " v:term "]" : term => `(update $m $k $v)

end Map

abbrev Con := Int

inductive Lb where
  | l0
  | l1
  deriving Repr

inductive Ub where
  | u0
  | u1
  | uN
  deriving Repr

inductive Card where
  | mk (l: Lb) (u: Ub)
  deriving Repr

namespace Card

def c00 : Card := ⟨Lb.l0, Ub.u0⟩
def c01 : Card := ⟨Lb.l0, Ub.u1⟩
def c0N : Card := ⟨Lb.l0, Ub.uN⟩
def c10 : Card := ⟨Lb.l1, Ub.u0⟩
def c11 : Card := ⟨Lb.l1, Ub.u1⟩
def c1N : Card := ⟨Lb.l1, Ub.uN⟩

end Card

open Card

mutual
  inductive Demand where
    | mk (n : Card) (sd : SubDemand)
    deriving Repr

  inductive SubDemand where
    | poly (n : Card) : SubDemand
    | ap (n : Card) (sd : SubDemand) : SubDemand
    | sel (alts : List (Con × (List Demand))) : SubDemand
    deriving Repr
end

#eval Demand.mk Card.c0N (SubDemand.poly Card.c0N)

/-
mutual
  inductive EquiD : Demand → Demand → Prop where
    | bot : EquiD ⟨c10, sd₁⟩ ⟨c10, sd₂⟩
    | abs : EquiD ⟨c00, sd₁⟩ ⟨c00, sd₂⟩
    | cong : EquiSD sd₁ sd₂ → EquiD ⟨n, sd₁⟩ ⟨n, sd₂⟩
  inductive EquiSD : SubDemand → SubDemand → Prop where
    | ap_bot : EquiSD (SubDemand.ap c10 sd₁) (SubDemand.ap c10 sd₂)
    | ap_abs : EquiSD (SubDemand.ap c00 sd₁) (SubDemand.ap c00 sd₂)
    | ap_poly : {n ∉ [c11,c1N]} → EquiSD (SubDemand.ap n (SubDemand.poly n)) (SubDemand.poly n)
    | sel : {n : Card} → (∀c ∈ Map.dom alts, ∀d ∈ Map.lookup c alts, d = Demand.mk n (SubDemand.poly n)) → EquiSD (SubDemand.sel alts) (SubDemand.poly n)
    | cong_ap : EquiSD (SubDemand.ap n sd₁) (SubDemand.ap n sd₂)
end
-/

namespace Card

@[inline]
def concLb : Lb -> Set ℕ
  | Lb.l0 => { n | n >= 0 }
  | Lb.l1 => { n | n >= 1 }

@[inline]
def concUb : Ub -> Set ℕ
  | Ub.u0 => {0}
  | Ub.u1 => {0,1}
  | Ub.uN => { n | true }

@[inline]
def conc : Card -> Set ℕ
  | ⟨ l, u ⟩ => concLb l ∩ concUb u

@[inline]
def absLb (s : Set ℕ) : Lb := match infi s with
  | 0 => Lb.l0
  | _ => Lb.l1

@[inline]
def absUb (s : Set ℕ) : Ub := match supr s with
  | 0 => Ub.u0
  | 1 => Ub.u1
  | _ => Ub.uN

@[inline]
def abs (s : Set ℕ) : Card := ⟨ absLb s, absUb s ⟩

def concLb_injective : Function.injective concLb
  | Lb.l0, Lb.l0 => by simp
  | Lb.l0, Lb.l1 => by delta concLb; simp; intro; show ¬ ({n | True} = {n | n >= 1}) by sorry
  | Lb.l1, Lb.l0 => by delta concLb; simp
  | Lb.l1, Lb.l1 => by simp

--match (a₁, a₂) with
--  | (Lb.l0, Lb.l0) => by simp
--  | (Lb.l0, Lb.l1) => by contradiction
--  | (Lb.l1, Lb.l0) => by sorry
--  | (Lb.l1, Lb.l1) => by sorry

def concUb_injective : Function.injective concUb := by
  intros a₁ a₂ h
  simp

def conc_injective : Function.injective conc := by
  intros a₁ a₂ h

instance CompleteLattic Card :=
  {

  }

theorem galois_abs_conc : galoisConnection abs conc := by sorry

end Card