/-
Copyright (c) 2019 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.category_theory.yoneda
import Mathlib.topology.sheaves.presheaf
import Mathlib.topology.category.TopCommRing
import Mathlib.topology.algebra.continuous_functions
import Mathlib.PostPort

universes v u_1 u

namespace Mathlib

/-!
# Presheaves of functions

We construct some simple examples of presheaves of functions on a topological space.
* `presheaf_to_Type X f`, where `f : X → Type`,
  is the presheaf of dependently-typed (not-necessarily continuous) functions
* `presheaf_to_Type X T`, where `T : Type`,
  is the presheaf of (not-necessarily-continuous) functions to a fixed target type `T`
* `presheaf_to_Top X T`, where `T : Top`,
  is the presheaf of continuous functions into a topological space `T`
* `presheaf_To_TopCommRing X R`, where `R : TopCommRing`
  is the presheaf valued in `CommRing` of functions functions into a topological ring `R`
* as an example of the previous construction,
  `presheaf_to_TopCommRing X (TopCommRing.of ℂ)`
  is the presheaf of rings of continuous complex-valued functions on `X`.
-/

namespace Top

/--
The presheaf of dependently typed functions on `X`, with fibres given by a type family `f`.
There is no requirement that the functions are continuous, here.
-/
def presheaf_to_Types (X : Top) (T : ↥X → Type v) : presheaf (Type v) X :=
  category_theory.functor.mk
    (fun (U : topological_space.opens ↥Xᵒᵖ) => (x : ↥(opposite.unop U)) → T ↑x)
    fun (U V : topological_space.opens ↥Xᵒᵖ) (i : U ⟶ V) (g : (x : ↥(opposite.unop U)) → T ↑x)
      (x : ↥(opposite.unop V)) => g (coe_fn (category_theory.has_hom.hom.unop i) x)

@[simp] theorem presheaf_to_Types_obj (X : Top) {T : ↥X → Type v}
    {U : topological_space.opens ↥Xᵒᵖ} :
    category_theory.functor.obj (presheaf_to_Types X T) U = ((x : ↥(opposite.unop U)) → T ↑x) :=
  rfl

@[simp] theorem presheaf_to_Types_map (X : Top) {T : ↥X → Type v} {U : topological_space.opens ↥Xᵒᵖ}
    {V : topological_space.opens ↥Xᵒᵖ} {i : U ⟶ V}
    {f : category_theory.functor.obj (presheaf_to_Types X T) U} :
    category_theory.functor.map (presheaf_to_Types X T) i f =
        fun (x : ↥(opposite.unop V)) => f (coe_fn (category_theory.has_hom.hom.unop i) x) :=
  rfl

/--
The presheaf of functions on `X` with values in a type `T`.
There is no requirement that the functions are continuous, here.
-/
-- We don't just define this in terms of `presheaf_to_Types`,

-- as it's helpful later to see (at a syntactic level) that `(presheaf_to_Type X T).obj U`

-- is a non-dependent function.

-- We don't use `@[simps]` to generate the projection lemmas here,

-- as it turns out to be useful to have `presheaf_to_Type_map`

-- written as an equality of functions (rather than being applied to some argument).

def presheaf_to_Type (X : Top) (T : Type v) : presheaf (Type v) X :=
  category_theory.functor.mk (fun (U : topological_space.opens ↥Xᵒᵖ) => ↥(opposite.unop U) → T)
    fun (U V : topological_space.opens ↥Xᵒᵖ) (i : U ⟶ V) (g : ↥(opposite.unop U) → T) =>
      g ∘ ⇑(category_theory.has_hom.hom.unop i)

@[simp] theorem presheaf_to_Type_obj (X : Top) {T : Type v} {U : topological_space.opens ↥Xᵒᵖ} :
    category_theory.functor.obj (presheaf_to_Type X T) U = (↥(opposite.unop U) → T) :=
  rfl

@[simp] theorem presheaf_to_Type_map (X : Top) {T : Type v} {U : topological_space.opens ↥Xᵒᵖ}
    {V : topological_space.opens ↥Xᵒᵖ} {i : U ⟶ V}
    {f : category_theory.functor.obj (presheaf_to_Type X T) U} :
    category_theory.functor.map (presheaf_to_Type X T) i f =
        f ∘ ⇑(category_theory.has_hom.hom.unop i) :=
  rfl

/-- The presheaf of continuous functions on `X` with values in fixed target topological space `T`. -/
def presheaf_to_Top (X : Top) (T : Top) : presheaf (Type v) X :=
  category_theory.functor.op (topological_space.opens.to_Top X) ⋙
    category_theory.functor.obj category_theory.yoneda T

@[simp] theorem presheaf_to_Top_obj (X : Top) (T : Top) (U : topological_space.opens ↥Xᵒᵖ) :
    category_theory.functor.obj (presheaf_to_Top X T) U =
        (category_theory.functor.obj (topological_space.opens.to_Top X) (opposite.unop U) ⟶ T) :=
  rfl

/-- The (bundled) commutative ring of continuous functions from a topological space
to a topological commutative ring, with pointwise multiplication. -/
-- TODO upgrade the result to TopCommRing?

def continuous_functions (X : Topᵒᵖ) (R : TopCommRing) : CommRing :=
  CommRing.of
    (opposite.unop X ⟶ category_theory.functor.obj (category_theory.forget₂ TopCommRing Top) R)

namespace continuous_functions

/-- Pulling back functions into a topological ring along a continuous map is a ring homomorphism. -/
def pullback {X : Topᵒᵖ} {Y : Topᵒᵖ} (f : X ⟶ Y) (R : TopCommRing) :
    continuous_functions X R ⟶ continuous_functions Y R :=
  ring_hom.mk (fun (g : ↥(continuous_functions X R)) => category_theory.has_hom.hom.unop f ≫ g)
    sorry sorry sorry sorry

/-- A homomorphism of topological rings can be postcomposed with functions from a source space `X`;
this is a ring homomorphism (with respect to the pointwise ring operations on functions). -/
def map (X : Topᵒᵖ) {R : TopCommRing} {S : TopCommRing} (φ : R ⟶ S) :
    continuous_functions X R ⟶ continuous_functions X S :=
  ring_hom.mk
    (fun (g : ↥(continuous_functions X R)) =>
      g ≫ category_theory.functor.map (category_theory.forget₂ TopCommRing Top) φ)
    sorry sorry sorry sorry

end continuous_functions

/-- An upgraded version of the Yoneda embedding, observing that the continuous maps
from `X : Top` to `R : TopCommRing` form a commutative ring, functorial in both `X` and `R`. -/
def CommRing_yoneda : TopCommRing ⥤ Topᵒᵖ ⥤ CommRing :=
  category_theory.functor.mk
    (fun (R : TopCommRing) =>
      category_theory.functor.mk (fun (X : Topᵒᵖ) => continuous_functions X R)
        fun (X Y : Topᵒᵖ) (f : X ⟶ Y) => continuous_functions.pullback f R)
    fun (R S : TopCommRing) (φ : R ⟶ S) =>
      category_theory.nat_trans.mk fun (X : Topᵒᵖ) => continuous_functions.map X φ

/--
The presheaf (of commutative rings), consisting of functions on an open set `U ⊆ X` with
values in some topological commutative ring `T`.

For example, we could construct the presheaf of continuous complex valued functions of `X` as
```
presheaf_to_TopCommRing X (TopCommRing.of ℂ)
```
(this requires `import topology.instances.complex`).
-/
def presheaf_to_TopCommRing (X : Top) (T : TopCommRing) : presheaf CommRing X :=
  category_theory.functor.op (topological_space.opens.to_Top X) ⋙
    category_theory.functor.obj CommRing_yoneda T

end Mathlib


example (A B C D E F G H I J K L : Prop)
(f1 : A → B) (f2 : B → E) (f3 : E → D) (f4 : D → A) (f5 : E → F)
(f6 : F → C) (f7 : B → C) (f8 : F → G) (f9 : G → J) (f10 : I → J)
(f11 : J → I) (f12 : I → H) (f13 : E → H) (f14 : H → K) (f15 : I → L)
 : A → L :=
begin
intro a,
apply f15,
apply f11,
apply f9,
apply f8,
apply f5,
exact f2(f1(a)),
end


/-
Copyright (c) 2019 Sébastien Gouëzel. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Sébastien Gouëzel
-/

import tactic.interactive
import tactic.norm_num

/-!
# `field_simp` tactic

Tactic to clear denominators in algebraic expressions, based on `simp` with a specific simpset.
-/

namespace tactic

/-- Try to prove a goal of the form `x ≠ 0` by calling `assumption`, or `norm_num1` if `x` is
a numeral. -/
meta def field_simp.ne_zero : tactic unit := do
  goal ← tactic.target,
  match goal with
  | `(%%e ≠ 0) := assumption <|> do n ← e.to_rat, `[norm_num1]
  | _ := tactic.fail "goal should be of the form `x ≠ 0`"
  end

namespace interactive
open interactive interactive.types

/--
The goal of `field_simp` is to reduce an expression in a field to an expression of the form `n / d`
where neither `n` nor `d` contains any division symbol, just using the simplifier (with a carefully
crafted simpset named `field_simps`) to reduce the number of division symbols whenever possible by
iterating the following steps:

- write an inverse as a division
- in any product, move the division to the right
- if there are several divisions in a product, group them together at the end and write them as a
  single division
- reduce a sum to a common denominator

If the goal is an equality, this simpset will also clear the denominators, so that the proof
can normally be concluded by an application of `ring` or `ring_exp`.

`field_simp [hx, hy]` is a short form for
`simp [-one_div, -mul_eq_zero, hx, hy] with field_simps {discharger := [field_simp.ne_zero]}`

Note that this naive algorithm will not try to detect common factors in denominators to reduce the
complexity of the resulting expression. Instead, it relies on the ability of `ring` to handle
complicated expressions in the next step.

As always with the simplifier, reduction steps will only be applied if the preconditions of the
lemmas can be checked. This means that proofs that denominators are nonzero should be included. The
fact that a product is nonzero when all factors are, and that a power of a nonzero number is
nonzero, are included in the simpset, but more complicated assertions (especially dealing with sums)
should be given explicitly. If your expression is not completely reduced by the simplifier
invocation, check the denominators of the resulting expression and provide proofs that they are
nonzero to enable further progress.

To check that denominators are nonzero, `field_simp` will look for facts in the context, and
will try to apply `norm_num` to close numerical goals.

The invocation of `field_simp` removes the lemma `one_div` from the simpset, as this lemma
works against the algorithm explained above. It also removes
`mul_eq_zero : x * y = 0 ↔ x = 0 ∨ y = 0`, as `norm_num` can not work on disjunctions to
close goals of the form `24 ≠ 0`, and replaces it with `mul_ne_zero : x ≠ 0 → y ≠ 0 → x * y ≠ 0`
creating two goals instead of a disjunction.

For example,
```lean
example (a b c d x y : ℂ) (hx : x ≠ 0) (hy : y ≠ 0) :
  a + b / x + c / x^2 + d / x^3 = a + x⁻¹ * (y * b / y + (d / x + c) / x) :=
begin
  field_simp,
  ring
end
```

See also the `cancel_denoms` tactic, which tries to do a similar simplification for expressions
that have numerals in denominators.
The tactics are not related: `cancel_denoms` will only handle numeric denominators, and will try to
entirely remove (numeric) division from the expression by multiplying by a factor.
-/
meta def field_simp (no_dflt : parse only_flag) (hs : parse simp_arg_list)
  (attr_names : parse with_ident_list)
  (locat : parse location)
  (cfg : simp_config_ext := {discharger := field_simp.ne_zero}) : tactic unit :=
let attr_names := `field_simps :: attr_names,
    hs := simp_arg_type.except `one_div :: simp_arg_type.except `mul_eq_zero :: hs in
propagate_tags (simp_core cfg.to_simp_config cfg.discharger no_dflt hs attr_names locat >> skip)

add_tactic_doc
{ name       := "field_simp",
  category   := doc_category.tactic,
  decl_names := [`tactic.interactive.field_simp],
  tags       := ["simplification", "arithmetic"] }

end interactive
end tactic


namespace BasicFunctions

#eval 2+2

def sampleFuct1 x := x*x + 3
def result1 := sampleFuct1 50
#eval println! "Result1: {result1}"

def sampleFunc2 (x:Nat) := 2*x*x - x+3
def result2 := sampleFunc2 (11)
#eval println! "Result2: {result2}"

def sampleFunction3 (x : Nat) :=
  if x > 100 then
    2 * x * x - x + 3
  else
    2 * x * x + x - 37
#eval println! "Result3: {sampleFunction3 3}"

end BasicFunctions

def twice (f : Nat → Nat) (a : Nat) := f (f a)
theorem twiceAdd2 (a : Nat) : twice (fun x => x + 2) a = a + 4 :=
  rfl

--
#eval twice (· + 2) 10

inductive Weekday where
  | sunday    : Weekday
  | monday    : Weekday
  | tuesday   : Weekday
  | wednesday : Weekday
  | thursday  : Weekday
  | friday    : Weekday
  | saturday  : Weekday

#check Weekday.sunday
#check Weekday.monday

open Weekday
#check sunday
#check tuesday

def natOfWeekday (d : Weekday) : Nat :=
  match d with
  | sunday    => 1
  | monday    => 2
  | tuesday   => 3
  | wednesday => 4
  | thursday  => 5
  | friday    => 6
  | saturday  => 7
#eval natOfWeekday monday

def Weekday.isMonday : Weekday → Bool :=
  fun
    | monday => true
    | _      => false

#eval isMonday sunday
#eval isMonday monday

instance: ToString Weekday where
  toString (d:Weekday):String :=
    match d with
      | sunday => "Sunday"
      | monday => "Monday"
      | tuesday => "Tuesday"
      | wednesday => "Wednesday"
      | thursday => "Thursday"
      | friday => "Friday"
      | saturday => "Saturday"

def Weekday.next (d : Weekday) : Weekday :=
  match d with
  | sunday    => monday
  | monday    => tuesday
  | tuesday   => wednesday
  | wednesday => thursday
  | thursday  => friday
  | friday    => saturday
  | saturday  => sunday

def Weekday.previous : Weekday -> Weekday
  | sunday    => saturday
  | monday    => sunday
  | tuesday   => monday
  | wednesday => tuesday
  | thursday  => wednesday
  | friday    => thursday
  | saturday  => friday

#eval Weekday.next Weekday.wednesday
#eval next wednesday
#eval next (previous wednesday)

theorem Weekday.nextOfPrevious (d : Weekday) : next (previous d) = d :=
  match d with
  | sunday    => rfl
  | monday    => rfl
  | tuesday   => rfl
  | wednesday => rfl
  | thursday  => rfl
  | friday    => rfl
  | saturday  => rfl

theorem Weekday.nextOfPrevious' (d : Weekday) : next (previous d) = d := by
  cases d       -- A proof by case distinction
  all_goals rfl  -- Each case is solved using `rfl`

def hello := "world"


/-
Copyright (c) 2022 Jannis Limperg. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Asta H. From, Jannis Limperg
-/
import Aesop

set_option aesop.check.all true

attribute [aesop safe (cases (patterns := [List.Mem _ []]))] List.Mem
attribute [aesop unsafe 50% constructors] List.Mem
attribute [aesop unsafe 50% (cases (patterns := [List.Mem _ (_ :: _)]))] List.Mem

@[aesop safe [constructors, (cases (patterns := [All _ [], All _ (_ :: _)]))]]
inductive All (P : α → Prop) : List α → Prop where
  | none : All P []
  | more {x xs} : P x → All P xs → All P (x :: xs)

@[simp]
theorem All.cons (P : α → Prop) (x : α) (xs : List α)
  : All P (x :: xs) ↔ (P x ∧ All P xs) := by
  aesop

theorem mem (P : α → Prop) (xs : List α)
  : All P xs ↔ ∀ a : α, a ∈ xs → P a := by
  induction xs
  case nil => aesop
  case cons x xs ih => aesop (simp_options := { useHyps := false })

theorem mem' (P : α → Prop) (xs : List α)
  : All P xs ↔ ∀ a : α, a ∈ xs → P a := by
  induction xs <;> aesop


import Smt

theorem symm (p q : Bool) : p == q → q == p := by
  smt
  cases p <;> cases q <;> simp_all


/-
Copyright (c) 2020 Adam Topaz. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Scott Morrison, Adam Topaz.
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.algebra.algebra.subalgebra
import Mathlib.algebra.monoid_algebra
import Mathlib.linear_algebra.default
import Mathlib.data.equiv.transfer_instance
import Mathlib.PostPort

universes u_1 u_2 l u_3

namespace Mathlib

/-!
# Free Algebras

Given a commutative semiring `R`, and a type `X`, we construct the free `R`-algebra on `X`.

## Notation

1. `free_algebra R X` is the free algebra itself. It is endowed with an `R`-algebra structure.
2. `free_algebra.ι R` is the function `X → free_algebra R X`.
3. Given a function `f : X → A` to an R-algebra `A`, `lift R f` is the lift of `f` to an
  `R`-algebra morphism `free_algebra R X → A`.

## Theorems

1. `ι_comp_lift` states that the composition `(lift R f) ∘ (ι R)` is identical to `f`.
2. `lift_unique` states that whenever an R-algebra morphism `g : free_algebra R X → A` is
  given whose composition with `ι R` is `f`, then one has `g = lift R f`.
3. `hom_ext` is a variant of `lift_unique` in the form of an extensionality theorem.
4. `lift_comp_ι` is a combination of `ι_comp_lift` and `lift_unique`. It states that the lift
  of the composition of an algebra morphism with `ι` is the algebra morphism itself.
5. `equiv_monoid_algebra_free_monoid : free_algebra R X ≃ₐ[R] monoid_algebra R (free_monoid X)`
6. An inductive principle `induction`.

## Implementation details

We construct the free algebra on `X` as a quotient of an inductive type `free_algebra.pre` by an
inductively defined relation `free_algebra.rel`. Explicitly, the construction involves three steps:
1. We construct an inductive type `free_algebra.pre R X`, the terms of which should be thought
  of as representatives for the elements of `free_algebra R X`.
  It is the free type with maps from `R` and `X`, and with two binary operations `add` and `mul`.
2. We construct an inductive relation `free_algebra.rel R X` on `free_algebra.pre R X`.
  This is the smallest relation for which the quotient is an `R`-algebra where addition resp.
  multiplication are induced by `add` resp. `mul` from 1., and for which the map from `R` is the
  structure map for the algebra.
3. The free algebra `free_algebra R X` is the quotient of `free_algebra.pre R X` by
  the relation `free_algebra.rel R X`.
-/

namespace free_algebra

/--
This inductive type is used to express representatives of the free algebra.
-/
inductive pre (R : Type u_1) [comm_semiring R] (X : Type u_2)
where
| of : X → pre R X
| of_scalar : R → pre R X
| add : pre R X → pre R X → pre R X
| mul : pre R X → pre R X → pre R X

namespace pre

protected instance inhabited (R : Type u_1) [comm_semiring R] (X : Type u_2) : Inhabited (pre R X) :=
  { default := of_scalar 0 }

-- Note: These instances are only used to simplify the notation.

/-- Coercion from `X` to `pre R X`. Note: Used for notation only. -/
/-- Coercion from `R` to `pre R X`. Note: Used for notation only. -/
def has_coe_generator (R : Type u_1) [comm_semiring R] (X : Type u_2) : has_coe X (pre R X) :=
  has_coe.mk of

/-- Multiplication in `pre R X` defined as `pre.mul`. Note: Used for notation only. -/
def has_coe_semiring (R : Type u_1) [comm_semiring R] (X : Type u_2) : has_coe R (pre R X) :=
  has_coe.mk of_scalar

/-- Addition in `pre R X` defined as `pre.add`. Note: Used for notation only. -/
def has_mul (R : Type u_1) [comm_semiring R] (X : Type u_2) : Mul (pre R X) :=
  { mul := mul }

/-- Zero in `pre R X` defined as the image of `0` from `R`. Note: Used for notation only. -/
def has_add (R : Type u_1) [comm_semiring R] (X : Type u_2) : Add (pre R X) :=
  { add := add }

/-- One in `pre R X` defined as the image of `1` from `R`. Note: Used for notation only. -/
def has_zero (R : Type u_1) [comm_semiring R] (X : Type u_2) : HasZero (pre R X) :=
  { zero := of_scalar 0 }

/--
def has_one (R : Type u_1) [comm_semiring R] (X : Type u_2) : HasOne (pre R X) :=
  { one := of_scalar 1 }

Scalar multiplication defined as multiplication by the image of elements from `R`.
Note: Used for notation only.
-/
def has_scalar (R : Type u_1) [comm_semiring R] (X : Type u_2) : has_scalar R (pre R X) :=
  has_scalar.mk fun (r : R) (m : pre R X) => mul (of_scalar r) m

end pre

/--
Given a function from `X` to an `R`-algebra `A`, `lift_fun` provides a lift of `f` to a function
from `pre R X` to `A`. This is mainly used in the construction of `free_algebra.lift`.
-/
def lift_fun (R : Type u_1) [comm_semiring R] (X : Type u_2) {A : Type u_3} [semiring A] [algebra R A] (f : X → A) : pre R X → A :=
  fun (t : pre R X) =>
    pre.rec_on t f (⇑(algebra_map R A)) (fun (_x _x : pre R X) => Add.add) fun (_x _x : pre R X) => Mul.mul

/--
An inductively defined relation on `pre R X` used to force the initial algebra structure on
the associated quotient.
-/
-- force `of_scalar` to be a central semiring morphism

inductive rel (R : Type u_1) [comm_semiring R] (X : Type u_2) : pre R X → pre R X → Prop
where
| add_scalar : ∀ {r s : R}, rel R X (↑(r + s)) (↑r + ↑s)
| mul_scalar : ∀ {r s : R}, rel R X (↑(r * s)) (↑r * ↑s)
| central_scalar : ∀ {r : R} {a : pre R X}, rel R X (↑r * a) (a * ↑r)
| add_assoc : ∀ {a b c : pre R X}, rel R X (a + b + c) (a + (b + c))
| add_comm : ∀ {a b : pre R X}, rel R X (a + b) (b + a)
| zero_add : ∀ {a : pre R X}, rel R X (0 + a) a
| mul_assoc : ∀ {a b c : pre R X}, rel R X (a * b * c) (a * (b * c))
| one_mul : ∀ {a : pre R X}, rel R X (1 * a) a
| mul_one : ∀ {a : pre R X}, rel R X (a * 1) a
| left_distrib : ∀ {a b c : pre R X}, rel R X (a * (b + c)) (a * b + a * c)
| right_distrib : ∀ {a b c : pre R X}, rel R X ((a + b) * c) (a * c + b * c)
| zero_mul : ∀ {a : pre R X}, rel R X (0 * a) 0
| mul_zero : ∀ {a : pre R X}, rel R X (a * 0) 0
| add_compat_left : ∀ {a b c : pre R X}, rel R X a b → rel R X (a + c) (b + c)
| add_compat_right : ∀ {a b c : pre R X}, rel R X a b → rel R X (c + a) (c + b)
| mul_compat_left : ∀ {a b c : pre R X}, rel R X a b → rel R X (a * c) (b * c)
| mul_compat_right : ∀ {a b c : pre R X}, rel R X a b → rel R X (c * a) (c * b)

-- commutative additive semigroup

-- multiplicative monoid

-- distributivity

-- other relations needed for semiring

-- compatibility

end free_algebra

/--
The free algebra for the type `X` over the commutative semiring `R`.
-/
def free_algebra (R : Type u_1) [comm_semiring R] (X : Type u_2) :=
  Quot sorry

namespace free_algebra

protected instance semiring (R : Type u_1) [comm_semiring R] (X : Type u_2) : semiring (free_algebra R X) :=
  semiring.mk (quot.map₂ Add.add sorry sorry) sorry (Quot.mk (rel R X) 0) sorry sorry sorry
    (quot.map₂ Mul.mul sorry sorry) sorry (Quot.mk (rel R X) 1) sorry sorry sorry sorry sorry sorry

protected instance inhabited (R : Type u_1) [comm_semiring R] (X : Type u_2) : Inhabited (free_algebra R X) :=
  { default := 0 }

protected instance has_scalar (R : Type u_1) [comm_semiring R] (X : Type u_2) : has_scalar R (free_algebra R X) :=
  has_scalar.mk
    fun (r : R) (a : free_algebra R X) => quot.lift_on a (fun (x : pre R X) => Quot.mk (rel R X) (↑r * x)) sorry

protected instance algebra (R : Type u_1) [comm_semiring R] (X : Type u_2) : algebra R (free_algebra R X) :=
  algebra.mk (ring_hom.mk (fun (r : R) => Quot.mk (rel R X) ↑r) sorry sorry sorry sorry) sorry sorry

protected instance ring (X : Type u_2) {S : Type u_1} [comm_ring S] : ring (free_algebra S X) :=
  algebra.semiring_to_ring S

/--
The canonical function `X → free_algebra R X`.
-/
def ι (R : Type u_1) [comm_semiring R] {X : Type u_2} : X → free_algebra R X :=
  fun (m : X) => Quot.mk (rel R X) ↑m

@[simp] theorem quot_mk_eq_ι (R : Type u_1) [comm_semiring R] {X : Type u_2} (m : X) : Quot.mk (rel R X) ↑m = ι R m :=
  rfl

/-- Internal definition used to define `lift` -/
/--
Given a function `f : X → A` where `A` is an `R`-algebra, `lift R f` is the unique lift
of `f` to a morphism of `R`-algebras `free_algebra R X → A`.
-/
def lift (R : Type u_1) [comm_semiring R] {X : Type u_2} {A : Type u_3} [semiring A] [algebra R A] : (X → A) ≃ alg_hom R (free_algebra R X) A :=
  equiv.mk (lift_aux R) (fun (F : alg_hom R (free_algebra R X) A) => ⇑F ∘ ι R) sorry sorry

@[simp] theorem lift_aux_eq (R : Type u_1) [comm_semiring R] {X : Type u_2} {A : Type u_3} [semiring A] [algebra R A] (f : X → A) : lift_aux R f = coe_fn (lift R) f :=
  rfl

@[simp] theorem lift_symm_apply (R : Type u_1) [comm_semiring R] {X : Type u_2} {A : Type u_3} [semiring A] [algebra R A] (F : alg_hom R (free_algebra R X) A) : coe_fn (equiv.symm (lift R)) F = ⇑F ∘ ι R :=
  rfl

@[simp] theorem ι_comp_lift {R : Type u_1} [comm_semiring R] {X : Type u_2} {A : Type u_3} [semiring A] [algebra R A] (f : X → A) : ⇑(coe_fn (lift R) f) ∘ ι R = f :=
  funext fun (x : X) => Eq.refl (function.comp (⇑(coe_fn (lift R) f)) (ι R) x)

@[simp] theorem lift_ι_apply {R : Type u_1} [comm_semiring R] {X : Type u_2} {A : Type u_3} [semiring A] [algebra R A] (f : X → A) (x : X) : coe_fn (coe_fn (lift R) f) (ι R x) = f x :=
  rfl

@[simp] theorem lift_unique {R : Type u_1} [comm_semiring R] {X : Type u_2} {A : Type u_3} [semiring A] [algebra R A] (f : X → A) (g : alg_hom R (free_algebra R X) A) : ⇑g ∘ ι R = f ↔ g = coe_fn (lift R) f :=
  equiv.symm_apply_eq (lift R)

/-!
At this stage we set the basic definitions as `@[irreducible]`, so from this point onwards one
should only use the universal properties of the free algebra, and consider the actual implementation
as a quotient of an inductive type as completely hidden.

Of course, one still has the option to locally make these definitions `semireducible` if so desired,
and Lean is still willing in some circumstances to do unification based on the underlying
definition.
-/

-- Marking `free_algebra` irreducible makes `ring` instances inaccessible on quotients.

-- https://leanprover.zulipchat.com/#narrow/stream/113488-general/topic/algebra.2Esemiring_to_ring.20breaks.20semimodule.20typeclass.20lookup/near/212580241

-- For now, we avoid this by not marking it irreducible.

@[simp] theorem lift_comp_ι {R : Type u_1} [comm_semiring R] {X : Type u_2} {A : Type u_3} [semiring A] [algebra R A] (g : alg_hom R (free_algebra R X) A) : coe_fn (lift R) (⇑g ∘ ι R) = g :=
  eq.mpr (id (Eq._oldrec (Eq.refl (coe_fn (lift R) (⇑g ∘ ι R) = g)) (Eq.symm (lift_symm_apply R g))))
    (equiv.apply_symm_apply (lift R) g)

/-- See note [partially-applied ext lemmas]. -/
theorem hom_ext {R : Type u_1} [comm_semiring R] {X : Type u_2} {A : Type u_3} [semiring A] [algebra R A] {f : alg_hom R (free_algebra R X) A} {g : alg_hom R (free_algebra R X) A} (w : ⇑f ∘ ι R = ⇑g ∘ ι R) : f = g :=
  equiv.injective (equiv.symm (lift R))
    (eq.mp (Eq._oldrec (Eq.refl (coe_fn (equiv.symm (lift R)) f = ⇑g ∘ ι R)) (Eq.symm (lift_symm_apply R g)))
      (eq.mp (Eq._oldrec (Eq.refl (⇑f ∘ ι R = ⇑g ∘ ι R)) (Eq.symm (lift_symm_apply R f))) w))

/--
The free algebra on `X` is "just" the monoid algebra on the free monoid on `X`.

This would be useful when constructing linear maps out of a free algebra,
for example.
-/
def equiv_monoid_algebra_free_monoid {R : Type u_1} [comm_semiring R] {X : Type u_2} : alg_equiv R (free_algebra R X) (monoid_algebra R (free_monoid X)) :=
  alg_equiv.of_alg_hom (coe_fn (lift R) fun (x : X) => coe_fn (monoid_algebra.of R (free_monoid X)) (free_monoid.of x))
    (coe_fn (monoid_algebra.lift R (free_monoid X) (free_algebra R X)) (coe_fn free_monoid.lift (ι R))) sorry sorry

protected instance nontrivial {R : Type u_1} [comm_semiring R] {X : Type u_2} [nontrivial R] : nontrivial (free_algebra R X) :=
  equiv.nontrivial (alg_equiv.to_equiv equiv_monoid_algebra_free_monoid)

/-- The left-inverse of `algebra_map`. -/
def algebra_map_inv {R : Type u_1} [comm_semiring R] {X : Type u_2} : alg_hom R (free_algebra R X) R :=
  coe_fn (lift R) 0

theorem algebra_map_left_inverse {R : Type u_1} [comm_semiring R] {X : Type u_2} : function.left_inverse ⇑algebra_map_inv ⇑(algebra_map R (free_algebra R X)) := sorry

-- this proof is copied from the approach in `free_abelian_group.of_injective`

theorem ι_injective {R : Type u_1} [comm_semiring R] {X : Type u_2} [nontrivial R] : function.injective (ι R) := sorry

end free_algebra

/- There is something weird in the above namespace that breaks the typeclass resolution of
`has_coe_to_sort` below. Closing it and reopening it fixes it... -/

namespace free_algebra

/-- An induction principle for the free algebra.

If `C` holds for the `algebra_map` of `r : R` into `free_algebra R X`, the `ι` of `x : X`, and is
preserved under addition and muliplication, then it holds for all of `free_algebra R X`.
-/
theorem induction (R : Type u_1) [comm_semiring R] (X : Type u_2) {C : free_algebra R X → Prop} (h_grade0 : ∀ (r : R), C (coe_fn (algebra_map R (free_algebra R X)) r)) (h_grade1 : ∀ (x : X), C (ι R x)) (h_mul : ∀ (a b : free_algebra R X), C a → C b → C (a * b)) (h_add : ∀ (a b : free_algebra R X), C a → C b → C (a + b)) (a : free_algebra R X) : C a := sorry

/-- The star ring formed by reversing the elements of products -/
protected instance star_ring (R : Type u_1) [comm_semiring R] (X : Type u_2) : star_ring (free_algebra R X) :=
  star_ring.mk sorry

@[simp] theorem star_ι (R : Type u_1) [comm_semiring R] (X : Type u_2) (x : X) : star (ι R x) = ι R x := sorry

@[simp] theorem star_algebra_map (R : Type u_1) [comm_semiring R] (X : Type u_2) (r : R) : star (coe_fn (algebra_map R (free_algebra R X)) r) = coe_fn (algebra_map R (free_algebra R X)) r := sorry

/-- `star` as an `alg_equiv` -/
def star_hom (R : Type u_1) [comm_semiring R] (X : Type u_2) : alg_equiv R (free_algebra R X) (free_algebra R Xᵒᵖ) :=
  alg_equiv.mk (ring_equiv.to_fun star_ring_equiv) (ring_equiv.inv_fun star_ring_equiv) sorry sorry sorry sorry sorry


/-
Copyright (c) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import tactic.abel
import category_theory.limits.shapes.biproducts
import category_theory.preadditive

/-!
# Basic facts about morphisms between biproducts in preadditive categories.

* In any category (with zero morphisms), if `biprod.map f g` is an isomorphism,
  then both `f` and `g` are isomorphisms.

The remaining lemmas hold in any preadditive category.

* If `f` is a morphism `X₁ ⊞ X₂ ⟶ Y₁ ⊞ Y₂` whose `X₁ ⟶ Y₁` entry is an isomorphism,
  then we can construct isomorphisms `L : X₁ ⊞ X₂ ≅ X₁ ⊞ X₂` and `R : Y₁ ⊞ Y₂ ≅ Y₁ ⊞ Y₂`
  so that `L.hom ≫ g ≫ R.hom` is diagonal (with `X₁ ⟶ Y₁` component still `f`),
  via Gaussian elimination.

* As a corollary of the previous two facts,
  if we have an isomorphism `X₁ ⊞ X₂ ≅ Y₁ ⊞ Y₂` whose `X₁ ⟶ Y₁` entry is an isomorphism,
  we can construct an isomorphism `X₂ ≅ Y₂`.

* If `f : W ⊞ X ⟶ Y ⊞ Z` is an isomorphism, either `𝟙 W = 0`,
  or at least one of the component maps `W ⟶ Y` and `W ⟶ Z` is nonzero.

* If `f : ⨁ S ⟶ ⨁ T` is an isomorphism,
  then every column (corresponding to a nonzero summand in the domain)
  has some nonzero matrix entry.
-/

open category_theory
open category_theory.preadditive
open category_theory.limits

universes v u

noncomputable theory

namespace category_theory

variables {C : Type u} [category.{v} C]
section
variables [has_zero_morphisms.{v} C] [has_binary_biproducts.{v} C]

/--
If
```
(f 0)
(0 g)
```
is invertible, then `f` is invertible.
-/
lemma is_iso_left_of_is_iso_biprod_map
  {W X Y Z : C} (f : W ⟶ Y) (g : X ⟶ Z) [is_iso (biprod.map f g)] : is_iso f :=
⟨⟨biprod.inl ≫ inv (biprod.map f g) ≫ biprod.fst,
  ⟨begin
    have t := congr_arg (λ p : W ⊞ X ⟶ W ⊞ X, biprod.inl ≫ p ≫ biprod.fst)
      (is_iso.hom_inv_id (biprod.map f g)),
    simp only [category.id_comp, category.assoc, biprod.inl_map_assoc] at t,
    simp [t],
  end,
  begin
    have t := congr_arg (λ p : Y ⊞ Z ⟶ Y ⊞ Z, biprod.inl ≫ p ≫ biprod.fst)
      (is_iso.inv_hom_id (biprod.map f g)),
    simp only [category.id_comp, category.assoc, biprod.map_fst] at t,
    simp only [category.assoc],
    simp [t],
  end⟩⟩⟩

/--
If
```
(f 0)
(0 g)
```
is invertible, then `g` is invertible.
-/
lemma is_iso_right_of_is_iso_biprod_map
  {W X Y Z : C} (f : W ⟶ Y) (g : X ⟶ Z) [is_iso (biprod.map f g)] : is_iso g :=
begin
  letI : is_iso (biprod.map g f) := by
  { rw [←biprod.braiding_map_braiding],
    apply_instance, },
  exact is_iso_left_of_is_iso_biprod_map g f,
end

end

section
variables [preadditive.{v} C] [has_binary_biproducts.{v} C]

variables {X₁ X₂ Y₁ Y₂ : C}
variables (f₁₁ : X₁ ⟶ Y₁) (f₁₂ : X₁ ⟶ Y₂) (f₂₁ : X₂ ⟶ Y₁) (f₂₂ : X₂ ⟶ Y₂)

/--
The "matrix" morphism `X₁ ⊞ X₂ ⟶ Y₁ ⊞ Y₂` with specified components.
-/
def biprod.of_components : X₁ ⊞ X₂ ⟶ Y₁ ⊞ Y₂ :=
biprod.fst ≫ f₁₁ ≫ biprod.inl +
biprod.fst ≫ f₁₂ ≫ biprod.inr +
biprod.snd ≫ f₂₁ ≫ biprod.inl +
biprod.snd ≫ f₂₂ ≫ biprod.inr

@[simp]
lemma biprod.inl_of_components :
  biprod.inl ≫ biprod.of_components f₁₁ f₁₂ f₂₁ f₂₂ =
    f₁₁ ≫ biprod.inl + f₁₂ ≫ biprod.inr :=
by simp [biprod.of_components]

@[simp]
lemma biprod.inr_of_components :
  biprod.inr ≫ biprod.of_components f₁₁ f₁₂ f₂₁ f₂₂ =
    f₂₁ ≫ biprod.inl + f₂₂ ≫ biprod.inr :=
by simp [biprod.of_components]

@[simp]
lemma biprod.of_components_fst :
  biprod.of_components f₁₁ f₁₂ f₂₁ f₂₂ ≫ biprod.fst =
    biprod.fst ≫ f₁₁ + biprod.snd ≫ f₂₁ :=
by simp [biprod.of_components]

@[simp]
lemma biprod.of_components_snd :
  biprod.of_components f₁₁ f₁₂ f₂₁ f₂₂ ≫ biprod.snd =
    biprod.fst ≫ f₁₂ + biprod.snd ≫ f₂₂ :=
by simp [biprod.of_components]

@[simp]
lemma biprod.of_components_eq (f : X₁ ⊞ X₂ ⟶ Y₁ ⊞ Y₂) :
  biprod.of_components (biprod.inl ≫ f ≫ biprod.fst) (biprod.inl ≫ f ≫ biprod.snd)
    (biprod.inr ≫ f ≫ biprod.fst) (biprod.inr ≫ f ≫ biprod.snd) = f :=
begin
  ext; simp,
end

@[simp]
lemma biprod.of_components_comp {X₁ X₂ Y₁ Y₂ Z₁ Z₂ : C}
  (f₁₁ : X₁ ⟶ Y₁) (f₁₂ : X₁ ⟶ Y₂) (f₂₁ : X₂ ⟶ Y₁) (f₂₂ : X₂ ⟶ Y₂)
  (g₁₁ : Y₁ ⟶ Z₁) (g₁₂ : Y₁ ⟶ Z₂) (g₂₁ : Y₂ ⟶ Z₁) (g₂₂ : Y₂ ⟶ Z₂) :
  biprod.of_components f₁₁ f₁₂ f₂₁ f₂₂ ≫ biprod.of_components g₁₁ g₁₂ g₂₁ g₂₂ =
    biprod.of_components
      (f₁₁ ≫ g₁₁ + f₁₂ ≫ g₂₁) (f₁₁ ≫ g₁₂ + f₁₂ ≫ g₂₂)
      (f₂₁ ≫ g₁₁ + f₂₂ ≫ g₂₁) (f₂₁ ≫ g₁₂ + f₂₂ ≫ g₂₂) :=
begin
  dsimp [biprod.of_components],
  apply biprod.hom_ext; apply biprod.hom_ext';
  simp only [add_comp, comp_add, add_comp_assoc, add_zero, zero_add,
    biprod.inl_fst, biprod.inl_snd, biprod.inr_fst, biprod.inr_snd,
    biprod.inl_fst_assoc, biprod.inl_snd_assoc, biprod.inr_fst_assoc, biprod.inr_snd_assoc,
    comp_zero, zero_comp,
    category.comp_id, category.assoc],
end

/--
The unipotent upper triangular matrix
```
(1 r)
(0 1)
```
as an isomorphism.
-/
@[simps]
def biprod.unipotent_upper {X₁ X₂ : C} (r : X₁ ⟶ X₂) : X₁ ⊞ X₂ ≅ X₁ ⊞ X₂ :=
{ hom := biprod.of_components (𝟙 _) r 0 (𝟙 _),
  inv := biprod.of_components (𝟙 _) (-r) 0 (𝟙 _), }

/--
The unipotent lower triangular matrix
```
(1 0)
(r 1)
```
as an isomorphism.
-/
@[simps]
def biprod.unipotent_lower {X₁ X₂ : C} (r : X₂ ⟶ X₁) : X₁ ⊞ X₂ ≅ X₁ ⊞ X₂ :=
{ hom := biprod.of_components (𝟙 _) 0 r (𝟙 _),
  inv := biprod.of_components (𝟙 _) 0 (-r) (𝟙 _), }

/--
If `f` is a morphism `X₁ ⊞ X₂ ⟶ Y₁ ⊞ Y₂` whose `X₁ ⟶ Y₁` entry is an isomorphism,
then we can construct isomorphisms `L : X₁ ⊞ X₂ ≅ X₁ ⊞ X₂` and `R : Y₁ ⊞ Y₂ ≅ Y₁ ⊞ Y₂`
so that `L.hom ≫ g ≫ R.hom` is diagonal (with `X₁ ⟶ Y₁` component still `f`),
via Gaussian elimination.

(This is the version of `biprod.gaussian` written in terms of components.)
-/
def biprod.gaussian' [is_iso f₁₁] :
  Σ' (L : X₁ ⊞ X₂ ≅ X₁ ⊞ X₂) (R : Y₁ ⊞ Y₂ ≅ Y₁ ⊞ Y₂) (g₂₂ : X₂ ⟶ Y₂),
    L.hom ≫ (biprod.of_components f₁₁ f₁₂ f₂₁ f₂₂) ≫ R.hom = biprod.map f₁₁ g₂₂ :=
⟨biprod.unipotent_lower (-(f₂₁ ≫ inv f₁₁)),
 biprod.unipotent_upper (-(inv f₁₁ ≫ f₁₂)),
 f₂₂ - f₂₁ ≫ (inv f₁₁) ≫ f₁₂,
 by ext; simp; abel⟩

/--
If `f` is a morphism `X₁ ⊞ X₂ ⟶ Y₁ ⊞ Y₂` whose `X₁ ⟶ Y₁` entry is an isomorphism,
then we can construct isomorphisms `L : X₁ ⊞ X₂ ≅ X₁ ⊞ X₂` and `R : Y₁ ⊞ Y₂ ≅ Y₁ ⊞ Y₂`
so that `L.hom ≫ g ≫ R.hom` is diagonal (with `X₁ ⟶ Y₁` component still `f`),
via Gaussian elimination.
-/
def biprod.gaussian (f : X₁ ⊞ X₂ ⟶ Y₁ ⊞ Y₂) [is_iso (biprod.inl ≫ f ≫ biprod.fst)] :
  Σ' (L : X₁ ⊞ X₂ ≅ X₁ ⊞ X₂) (R : Y₁ ⊞ Y₂ ≅ Y₁ ⊞ Y₂) (g₂₂ : X₂ ⟶ Y₂),
    L.hom ≫ f ≫ R.hom = biprod.map (biprod.inl ≫ f ≫ biprod.fst) g₂₂ :=
begin
  let := biprod.gaussian'
    (biprod.inl ≫ f ≫ biprod.fst) (biprod.inl ≫ f ≫ biprod.snd)
    (biprod.inr ≫ f ≫ biprod.fst) (biprod.inr ≫ f ≫ biprod.snd),
  simpa [biprod.of_components_eq],
end

/--
If `X₁ ⊞ X₂ ≅ Y₁ ⊞ Y₂` via a two-by-two matrix whose `X₁ ⟶ Y₁` entry is an isomorphism,
then we can construct an isomorphism `X₂ ≅ Y₂`, via Gaussian elimination.
-/
def biprod.iso_elim' [is_iso f₁₁] [is_iso (biprod.of_components f₁₁ f₁₂ f₂₁ f₂₂)] : X₂ ≅ Y₂ :=
begin
  obtain ⟨L, R, g, w⟩ := biprod.gaussian' f₁₁ f₁₂ f₂₁ f₂₂,
  letI : is_iso (biprod.map f₁₁ g) := by { rw ←w, apply_instance, },
  letI : is_iso g := (is_iso_right_of_is_iso_biprod_map f₁₁ g),
  exact as_iso g,
end

/--
If `f` is an isomorphism `X₁ ⊞ X₂ ≅ Y₁ ⊞ Y₂` whose `X₁ ⟶ Y₁` entry is an isomorphism,
then we can construct an isomorphism `X₂ ≅ Y₂`, via Gaussian elimination.
-/
def biprod.iso_elim (f : X₁ ⊞ X₂ ≅ Y₁ ⊞ Y₂) [is_iso (biprod.inl ≫ f.hom ≫ biprod.fst)] : X₂ ≅ Y₂ :=
begin
  letI : is_iso (biprod.of_components
       (biprod.inl ≫ f.hom ≫ biprod.fst)
       (biprod.inl ≫ f.hom ≫ biprod.snd)
       (biprod.inr ≫ f.hom ≫ biprod.fst)
       (biprod.inr ≫ f.hom ≫ biprod.snd)) :=
  by { simp only [biprod.of_components_eq], apply_instance, },
  exact biprod.iso_elim'
    (biprod.inl ≫ f.hom ≫ biprod.fst)
    (biprod.inl ≫ f.hom ≫ biprod.snd)
    (biprod.inr ≫ f.hom ≫ biprod.fst)
    (biprod.inr ≫ f.hom ≫ biprod.snd)
end

lemma biprod.column_nonzero_of_iso {W X Y Z : C}
  (f : W ⊞ X ⟶ Y ⊞ Z) [is_iso f] :
  𝟙 W = 0 ∨ biprod.inl ≫ f ≫ biprod.fst ≠ 0 ∨ biprod.inl ≫ f ≫ biprod.snd ≠ 0 :=
begin
  by_contradiction,
  rw [not_or_distrib, not_or_distrib, not_not, not_not] at h,
  rcases h with ⟨nz, a₁, a₂⟩,
  set x := biprod.inl ≫ f ≫ inv f ≫ biprod.fst,
  have h₁ : x = 𝟙 W, by simp [x],
  have h₀ : x = 0,
  { dsimp [x],
    rw [←category.id_comp (inv f), category.assoc, ←biprod.total],
    conv_lhs { slice 2 3, rw [comp_add], },
    simp only [category.assoc],
    rw [comp_add_assoc, add_comp],
    conv_lhs { congr, skip, slice 1 3, rw a₂, },
    simp only [zero_comp, add_zero],
    conv_lhs { slice 1 3, rw a₁, },
    simp only [zero_comp], },
  exact nz (h₁.symm.trans h₀),
end

end

variables [preadditive.{v} C]

lemma biproduct.column_nonzero_of_iso'
  {σ τ : Type v} [decidable_eq σ] [decidable_eq τ] [fintype τ]
  {S : σ → C} [has_biproduct.{v} S] {T : τ → C} [has_biproduct.{v} T]
  (s : σ) (f : ⨁ S ⟶ ⨁ T) [is_iso f] :
  (∀ t : τ, biproduct.ι S s ≫ f ≫ biproduct.π T t = 0) → 𝟙 (S s) = 0 :=
begin
  intro z,
  set x := biproduct.ι S s ≫ f ≫ inv f ≫ biproduct.π S s,
  have h₁ : x = 𝟙 (S s), by simp [x],
  have h₀ : x = 0,
  { dsimp [x],
    rw [←category.id_comp (inv f), category.assoc, ←biproduct.total],
    simp only [comp_sum_assoc],
    conv_lhs { congr, apply_congr, skip, simp only [reassoc_of z], },
    simp, },
  exact h₁.symm.trans h₀,
end

/--
If `f : ⨁ S ⟶ ⨁ T` is an isomorphism, and `s` is a non-trivial summand of the source,
then there is some `t` in the target so that the `s, t` matrix entry of `f` is nonzero.
-/
def biproduct.column_nonzero_of_iso
  {σ τ : Type v} [decidable_eq σ] [decidable_eq τ] [fintype τ]
  {S : σ → C} [has_biproduct.{v} S] {T : τ → C} [has_biproduct.{v} T]
  (s : σ) (nz : 𝟙 (S s) ≠ 0)
  [∀ t, decidable_eq (S s ⟶ T t)]
  (f : ⨁ S ⟶ ⨁ T) [is_iso f] :
  trunc (Σ' t : τ, biproduct.ι S s ≫ f ≫ biproduct.π T t ≠ 0) :=
begin
  apply trunc_sigma_of_exists,
  -- Do this before we run `classical`, so we get the right `decidable_eq` instances.
  have t := biproduct.column_nonzero_of_iso'.{v} s f,
  by_contradiction h,
  simp only [not_exists_not] at h,
  exact nz (t h)
end

end category_theory


/-
Copyright (c) 2016 Leonardo de Moura. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura

! This file was ported from Lean 3 source module data.set.functor
! leanprover-community/mathlib commit 207cfac9fcd06138865b5d04f7091e46d9320432
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Data.Set.Lattice
import Mathlib.Init.Set
import Mathlib.Control.Basic

/-!
# Functoriality of `Set`

This file defines the functor structure of `Set`.
-/

universe u

open Function

namespace Set

variable {α β : Type u} {s : Set α} {f : α → Set β} {g : Set (α → β)}

instance monad : Monad.{u} Set where
  pure a := {a}
  bind s f := ⋃ i ∈ s, f i
  seq s t := Set.seq s (t ())
  map := Set.image

@[simp]
theorem bind_def : s >>= f = ⋃ i ∈ s, f i :=
  rfl
#align set.bind_def Set.bind_def

@[simp]
theorem fmap_eq_image (f : α → β) : f <$> s = f '' s :=
  rfl
#align set.fmap_eq_image Set.fmap_eq_image

@[simp]
theorem seq_eq_set_seq (s : Set (α → β)) (t : Set α) : s <*> t = s.seq t :=
  rfl
#align set.seq_eq_set_seq Set.seq_eq_set_seq

@[simp]
theorem pure_def (a : α) : (pure a : Set α) = {a} :=
  rfl
#align set.pure_def Set.pure_def

/-- `Set.image2` in terms of monadic operations. Note that this can't be taken as the definition
because of the lack of universe polymorphism. -/
theorem image2_def {α β γ : Type _} (f : α → β → γ) (s : Set α) (t : Set β) :
    image2 f s t = f <$> s <*> t := by
  ext
  simp
#align set.image2_def Set.image2_def

instance : LawfulMonad Set := LawfulMonad.mk'
  (id_map := image_id)
  (pure_bind := bunionᵢ_singleton)
  (bind_assoc := fun _ _ _ => by simp only [bind_def, bunionᵢ_unionᵢ])
  (bind_pure_comp := fun _ _ => (image_eq_unionᵢ _ _).symm)
  (bind_map := fun _ _ => seq_def.symm)

instance : CommApplicative (Set : Type u → Type u) :=
  ⟨fun s t => prod_image_seq_comm s t⟩

instance : Alternative Set :=
  { Set.monad with
    orElse := fun s t => s ∪ (t ())
    failure := ∅ }

end Set


/-
Copyright (c) 2018 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import category_theory.natural_isomorphism
import data.equiv.basic

-- declare the `v`'s first; see `category_theory.category` for an explanation
universes v₁ v₂ v₃ u₁ u₂ u₃

namespace category_theory

variables {C : Type u₁} [category.{v₁} C] {D : Type u₂} [category.{v₂} D]

/--
A functor `F : C ⥤ D` is full if for each `X Y : C`, `F.map` is surjective.
In fact, we use a constructive definition, so the `full F` typeclass contains data,
specifying a particular preimage of each `f : F.obj X ⟶ F.obj Y`.

See https://stacks.math.columbia.edu/tag/001C.
-/
class full (F : C ⥤ D) :=
(preimage : ∀ {X Y : C} (f : (F.obj X) ⟶ (F.obj Y)), X ⟶ Y)
(witness' : ∀ {X Y : C} (f : (F.obj X) ⟶ (F.obj Y)), F.map (preimage f) = f . obviously)

restate_axiom full.witness'
attribute [simp] full.witness

/--
A functor `F : C ⥤ D` is faithful if for each `X Y : C`, `F.map` is injective.

See https://stacks.math.columbia.edu/tag/001C.
-/
class faithful (F : C ⥤ D) : Prop :=
(map_injective' [] : ∀ {X Y : C}, function.injective (@functor.map _ _ _ _ F X Y) . obviously)

restate_axiom faithful.map_injective'

namespace functor
lemma map_injective (F : C ⥤ D) [faithful F] {X Y : C} :
  function.injective $ @functor.map _ _ _ _ F X Y :=
faithful.map_injective F

/-- The specified preimage of a morphism under a full functor. -/
def preimage (F : C ⥤ D) [full F] {X Y : C} (f : F.obj X ⟶ F.obj Y) : X ⟶ Y :=
full.preimage.{v₁ v₂} f
@[simp] lemma image_preimage (F : C ⥤ D) [full F] {X Y : C} (f : F.obj X ⟶ F.obj Y) :
  F.map (preimage F f) = f :=
by unfold preimage; obviously
end functor

variables {F : C ⥤ D} [full F] [faithful F] {X Y Z : C}

@[simp] lemma preimage_id : F.preimage (𝟙 (F.obj X)) = 𝟙 X :=
F.map_injective (by simp)
@[simp] lemma preimage_comp (f : F.obj X ⟶ F.obj Y) (g : F.obj Y ⟶ F.obj Z) :
  F.preimage (f ≫ g) = F.preimage f ≫ F.preimage g :=
F.map_injective (by simp)
@[simp] lemma preimage_map (f : X ⟶ Y) :
  F.preimage (F.map f) = f :=
F.map_injective (by simp)

/-- If `F : C ⥤ D` is fully faithful, every isomorphism `F.obj X ≅ F.obj Y` has a preimage. -/
def preimage_iso (f : (F.obj X) ≅ (F.obj Y)) : X ≅ Y :=
{ hom := F.preimage f.hom,
  inv := F.preimage f.inv,
  hom_inv_id' := F.map_injective (by simp),
  inv_hom_id' := F.map_injective (by simp), }

@[simp] lemma preimage_iso_hom (f : (F.obj X) ≅ (F.obj Y)) :
  (preimage_iso f).hom = F.preimage f.hom := rfl
@[simp] lemma preimage_iso_inv (f : (F.obj X) ≅ (F.obj Y)) :
  (preimage_iso f).inv = F.preimage (f.inv) := rfl
@[simp] lemma preimage_iso_map_iso (f : X ≅ Y) : preimage_iso (F.map_iso f) = f :=
by tidy

variables (F)

/--
If the image of a morphism under a fully faithful functor in an isomorphism,
then the original morphisms is also an isomorphism.
-/
lemma is_iso_of_fully_faithful (f : X ⟶ Y) [is_iso (F.map f)] : is_iso f :=
⟨⟨F.preimage (inv (F.map f)),
  ⟨F.map_injective (by simp), F.map_injective (by simp)⟩⟩⟩

/-- If `F` is fully faithful, we have an equivalence of hom-sets `X ⟶ Y` and `F X ⟶ F Y`. -/
def equiv_of_fully_faithful {X Y} : (X ⟶ Y) ≃ (F.obj X ⟶ F.obj Y) :=
{ to_fun := λ f, F.map f,
  inv_fun := λ f, F.preimage f,
  left_inv := λ f, by simp,
  right_inv := λ f, by simp }

@[simp]
lemma equiv_of_fully_faithful_apply {X Y : C} (f : X ⟶ Y) :
  equiv_of_fully_faithful F f = F.map f := rfl
@[simp]
lemma equiv_of_fully_faithful_symm_apply {X Y} (f : F.obj X ⟶ F.obj Y) :
  (equiv_of_fully_faithful F).symm f = F.preimage f := rfl

end category_theory

namespace category_theory

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

instance full.id : full (𝟭 C) :=
{ preimage := λ _ _ f, f }

instance faithful.id : faithful (𝟭 C) := by obviously

variables {D : Type u₂} [category.{v₂} D] {E : Type u₃} [category.{v₃} E]
variables (F F' : C ⥤ D) (G : D ⥤ E)

instance faithful.comp [faithful F] [faithful G] : faithful (F ⋙ G) :=
{ map_injective' := λ _ _ _ _ p, F.map_injective (G.map_injective p) }

lemma faithful.of_comp [faithful $ F ⋙ G] : faithful F :=
{ map_injective' := λ X Y, (F ⋙ G).map_injective.of_comp }

section
variables {F F'}

lemma faithful.of_iso [faithful F] (α : F ≅ F') : faithful F' :=
{ map_injective' := λ X Y f f' h, F.map_injective
  (by rw [←nat_iso.naturality_1 α.symm, h, nat_iso.naturality_1 α.symm]) }
end

variables {F G}

lemma faithful.of_comp_iso {H : C ⥤ E} [ℋ : faithful H] (h : F ⋙ G ≅ H) : faithful F :=
@faithful.of_comp _ _ _ _ _ _ F G (faithful.of_iso h.symm)

alias faithful.of_comp_iso ← category_theory.iso.faithful_of_comp

-- We could prove this from `faithful.of_comp_iso` using `eq_to_iso`,
-- but that would introduce a cyclic import.
lemma faithful.of_comp_eq {H : C ⥤ E} [ℋ : faithful H] (h : F ⋙ G = H) : faithful F :=
@faithful.of_comp _ _ _ _ _ _ F G (h.symm ▸ ℋ)

alias faithful.of_comp_eq ← eq.faithful_of_comp

variables (F G)

/-- “Divide” a functor by a faithful functor. -/
protected def faithful.div (F : C ⥤ E) (G : D ⥤ E) [faithful G]
  (obj : C → D) (h_obj : ∀ X, G.obj (obj X) = F.obj X)
  (map : Π {X Y}, (X ⟶ Y) → (obj X ⟶ obj Y))
  (h_map : ∀ {X Y} {f : X ⟶ Y}, G.map (map f) == F.map f) :
  C ⥤ D :=
{ obj := obj,
  map := @map,
  map_id' :=
  begin
    assume X,
    apply G.map_injective,
    apply eq_of_heq,
    transitivity F.map (𝟙 X), from h_map,
    rw [F.map_id, G.map_id, h_obj X]
  end,
  map_comp' :=
  begin
    assume X Y Z f g,
    apply G.map_injective,
    apply eq_of_heq,
    transitivity F.map (f ≫ g), from h_map,
    rw [F.map_comp, G.map_comp],
    congr' 1;
      try { exact (h_obj _).symm };
      exact h_map.symm
  end }

-- This follows immediately from `functor.hext` (`functor.hext h_obj @h_map`),
-- but importing `category_theory.eq_to_hom` causes an import loop:
-- category_theory.eq_to_hom → category_theory.opposites →
-- category_theory.equivalence → category_theory.fully_faithful
lemma faithful.div_comp (F : C ⥤ E) [faithful F] (G : D ⥤ E) [faithful G]
  (obj : C → D) (h_obj : ∀ X, G.obj (obj X) = F.obj X)
  (map : Π {X Y}, (X ⟶ Y) → (obj X ⟶ obj Y))
  (h_map : ∀ {X Y} {f : X ⟶ Y}, G.map (map f) == F.map f) :
  (faithful.div F G obj @h_obj @map @h_map) ⋙ G = F :=
begin
  casesI F with F_obj _ _ _, casesI G with G_obj _ _ _,
  unfold faithful.div functor.comp,
  unfold_projs at h_obj,
  have: F_obj = G_obj ∘ obj := (funext h_obj).symm,
  substI this,
  congr,
  funext,
  exact eq_of_heq h_map
end

lemma faithful.div_faithful (F : C ⥤ E) [faithful F] (G : D ⥤ E) [faithful G]
  (obj : C → D) (h_obj : ∀ X, G.obj (obj X) = F.obj X)
  (map : Π {X Y}, (X ⟶ Y) → (obj X ⟶ obj Y))
  (h_map : ∀ {X Y} {f : X ⟶ Y}, G.map (map f) == F.map f) :
  faithful (faithful.div F G obj @h_obj @map @h_map) :=
(faithful.div_comp F G _ h_obj _ @h_map).faithful_of_comp

instance full.comp [full F] [full G] : full (F ⋙ G) :=
{ preimage := λ _ _ f, F.preimage (G.preimage f) }

/--
Given a natural isomorphism between `F ⋙ H` and `G ⋙ H` for a fully faithful functor `H`, we
can 'cancel' it to give a natural iso between `F` and `G`.
-/
def fully_faithful_cancel_right {F G : C ⥤ D} (H : D ⥤ E)
  [full H] [faithful H] (comp_iso: F ⋙ H ≅ G ⋙ H) : F ≅ G :=
nat_iso.of_components
  (λ X, preimage_iso (comp_iso.app X))
  (λ X Y f, H.map_injective (by simpa using comp_iso.hom.naturality f))

@[simp]
lemma fully_faithful_cancel_right_hom_app {F G : C ⥤ D} {H : D ⥤ E}
  [full H] [faithful H] (comp_iso: F ⋙ H ≅ G ⋙ H) (X : C) :
  (fully_faithful_cancel_right H comp_iso).hom.app X = H.preimage (comp_iso.hom.app X) :=
rfl

@[simp]
lemma fully_faithful_cancel_right_inv_app {F G : C ⥤ D} {H : D ⥤ E}
  [full H] [faithful H] (comp_iso: F ⋙ H ≅ G ⋙ H) (X : C) :
  (fully_faithful_cancel_right H comp_iso).inv.app X = H.preimage (comp_iso.inv.app X) :=
rfl

end category_theory


/-
Copyright (c) 2020 Markus Himmel. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Markus Himmel
-/
import category_theory.abelian.pseudoelements

/-!
# The four and five lemmas

Consider the following commutative diagram with exact rows in an abelian category:

```
A ---f--> B ---g--> C ---h--> D ---i--> E
|         |         |         |         |
α         β         γ         δ         ε
|         |         |         |         |
v         v         v         v         v
A' --f'-> B' --g'-> C' --h'-> D' --i'-> E'
```

We show:
- the "mono" version of the four lemma: if `α` is an epimorphism and `β` and `δ` are monomorphisms,
  then `γ` is a monomorphism,
- the "epi" version of the four lemma: if `β` and `δ` are epimorphisms and `ε` is a monomorphism,
  then `γ` is an epimorphism,
- the five lemma: if `α`, `β`, `δ` and `ε` are isomorphisms, then `γ` is an isomorphism.

## Implementation details

To show the mono version, we use pseudoelements. For the epi version, we use a completely different
arrow-theoretic proof. In theory, it should be sufficient to have one version and the other should
follow automatically by duality. In practice, mathlib's knowledge about duality isn't quite at the
point where this is doable easily.

However, one key duality statement about exactness is needed in the proof of the epi version of the
four lemma: we need to know that exactness of a pair `(f, g)`, which we defined via the map from
the image of `f` to the kernel of `g`, is the same as "co-exactness", defined via the map from the
cokernel of `f` to the coimage of `g` (more precisely, we only need the consequence that if `(f, g)`
is exact, then the factorization of `g` through the cokernel of `f` is monomorphic). Luckily, in the
case of abelian categories, we have the characterization that `(f, g)` is exact if and only if
`f ≫ g = 0` and `kernel.ι g ≫ cokernel.π f = 0`, and the latter condition is self dual, so the
equivalence of exactness and co-exactness follows easily.

## Tags

four lemma, five lemma, diagram lemma, diagram chase
-/
open category_theory (hiding comp_apply)
open category_theory.abelian.pseudoelement
open category_theory.limits

universes v u

variables {V : Type u} [category.{v} V] [abelian V]

local attribute [instance] preadditive.has_equalizers_of_has_kernels

open_locale pseudoelement

namespace category_theory.abelian

variables {A B C D A' B' C' D' : V}
variables {f : A ⟶ B} {g : B ⟶ C} {h : C ⟶ D}
variables {f' : A' ⟶ B'} {g' : B' ⟶ C'} {h' : C' ⟶ D'}
variables {α : A ⟶ A'} {β : B ⟶ B'} {γ : C ⟶ C'} {δ : D ⟶ D'}
variables (comm₁ : α ≫ f' = f ≫ β) (comm₂ : β ≫ g' = g ≫ γ) (comm₃ : γ ≫ h' = h ≫ δ)
include comm₁ comm₂ comm₃

section
variables (hfg : exact f g) (hgh : exact g h) (hf'g' : exact f' g')

/-- The four lemma, mono version. For names of objects and morphisms, refer to the following
    diagram:

```
A ---f--> B ---g--> C ---h--> D
|         |         |         |
α         β         γ         δ
|         |         |         |
v         v         v         v
A' --f'-> B' --g'-> C' --h'-> D'
```
-/

end

section
variables (hgh : exact g h) (hf'g' : exact f' g') (hg'h' : exact g' h')

/-- The four lemma, epi version. For names of objects and morphisms, refer to the following
    diagram:

```
A ---f--> B ---g--> C ---h--> D
|         |         |         |
α         β         γ         δ
|         |         |         |
v         v         v         v
A' --f'-> B' --g'-> C' --h'-> D'
```
-/
lemma epi_of_epi_of_epi_of_mono (hα : epi α) (hγ : epi γ) (hδ : mono δ) : epi β :=
preadditive.epi_of_cancel_zero _ $ λ R r hβr,
  have hf'r : f' ≫ r = 0, from limits.zero_of_epi_comp α $
    calc α ≫ f' ≫ r = f ≫ β ≫ r : by rw reassoc_of comm₁
                 ... = f ≫ 0      : by rw hβr
                 ... = 0           : has_zero_morphisms.comp_zero _ _,
  let y : R ⟶ pushout r g' := pushout.inl, z : C' ⟶ pushout r g' := pushout.inr in
  have mono y, from mono_inl_of_factor_thru_epi_mono_factorization r g' (cokernel.π f')
    (cokernel.desc f' g' hf'g'.w) (by simp) (cokernel.desc f' r hf'r) (by simp) _
    (colimit.is_colimit _),
  have hz : g ≫ γ ≫ z = 0, from
    calc g ≫ γ ≫ z = β ≫ g' ≫ z : by rw ←reassoc_of comm₂
                ... = β ≫ r ≫ y  : by rw ←pushout.condition
                ... = 0 ≫ y       : by rw reassoc_of hβr
                ... = 0           : has_zero_morphisms.zero_comp _ _,
  let v : pushout r g' ⟶ pushout (γ ≫ z) (h ≫ δ) := pushout.inl,
      w : D' ⟶ pushout (γ ≫ z) (h ≫ δ) := pushout.inr in
  have mono v, from mono_inl_of_factor_thru_epi_mono_factorization _ _ (cokernel.π g)
    (cokernel.desc g h hgh.w ≫ δ) (by simp) (cokernel.desc _ _ hz) (by simp) _
    (colimit.is_colimit _),
  have hzv : z ≫ v = h' ≫ w, from (cancel_epi γ).1 $
    calc γ ≫ z ≫ v = h ≫ δ ≫ w  : by rw [←category.assoc, pushout.condition, category.assoc]
                ... = γ ≫ h' ≫ w : by rw reassoc_of comm₃,
  suffices (r ≫ y) ≫ v = 0, by exactI zero_of_comp_mono _ (zero_of_comp_mono _ this),
  calc (r ≫ y) ≫ v = g' ≫ z ≫ v : by rw [pushout.condition, category.assoc]
                ... = g' ≫ h' ≫ w : by rw hzv
                ... = 0 ≫ w        : hg'h'.w_assoc _
                ... = 0            : has_zero_morphisms.zero_comp _ _

end

section five
variables {E E' : V} {i : D ⟶ E} {i' : D' ⟶ E'} {ε : E ⟶ E'} (comm₄ : δ ≫ i' = i ≫ ε)
variables (hfg : exact f g) (hgh : exact g h) (hhi : exact h i)
variables (hf'g' : exact f' g') (hg'h' : exact g' h') (hh'i' : exact h' i')
variables [is_iso α] [is_iso β] [is_iso δ] [is_iso ε]
include comm₄ hfg hgh hhi hf'g' hg'h' hh'i'

/-- The five lemma. For names of objects and morphisms, refer to the following diagram:

```
A ---f--> B ---g--> C ---h--> D ---i--> E
|         |         |         |         |
α         β         γ         δ         ε
|         |         |         |         |
v         v         v         v         v
A' --f'-> B' --g'-> C' --h'-> D' --i'-> E'
```
-/
lemma is_iso_of_is_iso_of_is_iso_of_is_iso_of_is_iso : is_iso γ :=
have mono γ, by apply mono_of_epi_of_mono_of_mono comm₁ comm₂ comm₃ hfg hgh hf'g'; apply_instance,
have epi γ, by apply epi_of_epi_of_epi_of_mono comm₂ comm₃ comm₄ hhi hg'h' hh'i'; apply_instance,
by exactI is_iso_of_mono_of_epi _

end five
end category_theory.abelian


import algebra.group_power
import topology.algebra.ring
import topology.opens
import category_theory.category
import category_theory.full_subcategory

import for_mathlib.open_embeddings
import for_mathlib.topological_groups

import sheaves.f_map

import Spa.stalk_valuation

/-!
# Adic spaces

Adic spaces were introduced by Huber in [Huber]. They form a very general category of objects
suitable for p-adic geometry.

In this file we define the category of adic spaces. The category of schemes (from algebraic
geometry) may provide some useful intuition for the definition.
One defines the category of “ringed spaces”, and for every commutative ring R
a ringed space Spec(R). A scheme is a ringed space that admits a cover by subspaces that
are isomorphic to spaces of the form Spec(R) for some ring R.

Similarly, for adic spaces we need two ingredients: a category CLVRS,
and the so-called ”adic spectrum” Spa(_), which is defined in Spa.lean.
An adic space is an object of CLVRS is that admits a cover by subspaces of the form Spa(A).

The main bulk of this file consists in setting up the category that we called CLVRS,
and that never got a proper name in the literature. (For example, Wedhorn calls this category `𝒱`.)

CLVRS (complete locally valued ringed space) is the category of topological spaces endowed
with a sheaf of complete topological rings and (an equivalence class of) valuations on the stalks
(which are required to be local rings; moreover the support of the valuation must be
the maximal ideal of the stalk).

Once we have the category CLVRS in place, the definition of adic spaces is made in
a couple of lines.
-/

universe u

open nat function
open topological_space
open spa

open_locale classical

/-- A convenient auxiliary category whose objects are topological spaces equipped with
a presheaf of topological rings and on each stalk (considered as abstract ring) an
equivalence class of valuations. The point of this category is that the local isomorphism
between a general adic space and an affinoid model Spa(A) can be checked in this category.
-/
structure PreValuedRingedSpace :=
(space : Type u)
[top   : topological_space space]
(presheaf : presheaf_of_topological_rings.{u u} space)
(valuation : ∀ x : space, Spv (stalk_of_rings presheaf.to_presheaf_of_rings x))

namespace PreValuedRingedSpace

variables (X : PreValuedRingedSpace.{u})

/-- Coercion from a PreValuedRingedSpace to the underlying topological space.-/
instance : has_coe_to_sort PreValuedRingedSpace.{u} :=
{ S := Type u,
  coe := λ X, X.space }

/-- The topology on the underlying space of a PreValuedRingedSpace.-/
instance : topological_space X := X.top

end PreValuedRingedSpace

/- Remainder of this file:

* Morphisms and isomorphisms in PreValuedRingedSpace.
* Open set in X -> restrict structure to obtain object of PreValuedRingedSpace
* Definition of adic space

* A morphism in PreValuedRingedSpace is a map of topological spaces,
  and an f-map of presheaves, such that the induced
  map on the stalks pulls one valuation back to the other.
-/

namespace PreValuedRingedSpace
open category_theory

/-- A morphism of pre-valued ringed spaces is a morphism of the structure presheaves
(of topological rings, hence *continuous* on sections),
such that for every point x in the domain the induced map on stalks pulls valuation on the stalk
back to the valuation of the stalk on the image of x.-/
structure hom (X Y : PreValuedRingedSpace.{u}) :=
(fmap : presheaf_of_topological_rings.f_map X.presheaf Y.presheaf)
(stalk : ∀ x : X,
  Spv.comap (stalk_map fmap.to_presheaf_of_rings_f_map x) (X.valuation x) = Y.valuation (fmap.f x))

attribute [simp] hom.stalk

/-- A morphism of pre-valued ringed spaces is determined by the data
of the morphism of the structure presheaves.-/
@[ext]
lemma hom_ext {X Y : PreValuedRingedSpace.{u}} (f g : hom X Y) :
  f.fmap = g.fmap → f = g :=
by { cases f, cases g, tidy }

/--The identity morphism of a pre-valued ringed space.-/
def id (X : PreValuedRingedSpace.{u}) : hom X X :=
{ fmap := presheaf_of_topological_rings.f_map_id _,
  stalk := λ x, by { dsimp, simp, } }

@[simp] lemma id_fmap {X : PreValuedRingedSpace} :
  (id X).fmap = presheaf_of_topological_rings.f_map_id _ := rfl

/--The composition of morphisms of pre-valued ringed spaces.-/
def comp {X Y Z : PreValuedRingedSpace.{u}} (f : hom X Y) (g : hom Y Z) : hom X Z :=
{ fmap := f.fmap.comp g.fmap,
  stalk := λ x,
  begin
    dsimp, simp only [comp_app, stalk_map.stalk_map_comp', hom.stalk, Spv.comap_comp],
    dsimp, simp only [hom.stalk],
  end }

/--Pre-valued ringed spaces form a large category.-/
instance large_category : large_category (PreValuedRingedSpace.{u}) :=
{ hom  := hom,
  id   := id,
  comp := λ X Y Z f g, comp f g,
  id_comp' :=
  begin
    intros X Y f, ext, dsimp [comp],
    exact presheaf_of_rings.f_map.id_comp _,
  end,
  comp_id' :=
  begin
    intros X Y f, ext, dsimp [comp],
    exact presheaf_of_rings.f_map.comp_id _,
  end }

end PreValuedRingedSpace

/--If U is an open subset of a pre-valued ringed space X, then there is a natural way
to view U as a pre-valued ringed space by restricting the structure presheaf from X.-/
noncomputable instance PreValuedRingedSpace.restrict {X : PreValuedRingedSpace.{u}} :
  has_coe (opens X) PreValuedRingedSpace :=
{ coe := λ U,
  { space := U,
    top := by apply_instance,
    presheaf := presheaf_of_topological_rings.restrict U X.presheaf,
    valuation :=
      λ u, Spv.mk (valuation.comap (presheaf_of_rings.restrict_stalk_map _ _) (X.valuation u).out) } }

namespace sheaf_of_topological_rings

/-- The sections of a sheaf of topological rings form a uniform space.
When this is made an instance, beware of diamonds.-/
def uniform_space {X : Type u} [topological_space X] (𝒪X : sheaf_of_topological_rings X)
  (U : opens X) : uniform_space (𝒪X.F.F U) :=
topological_add_group.to_uniform_space (𝒪X.F.F U)

end sheaf_of_topological_rings

section
local attribute [instance] sheaf_of_topological_rings.uniform_space

/--Category of topological spaces endowed with a sheaf of complete topological rings
and (an equivalence class of) valuations on the stalks (which are required to be local
rings; moreover the support of the valuation must be the maximal ideal of the stalk).
Wedhorn calls this category `𝒱`.-/
structure CLVRS :=
(space : Type) -- change this to (Type u) to enable universes
[top   : topological_space space]
(sheaf' : sheaf_of_topological_rings.{0 0} space)
(complete : ∀ U : opens space, complete_space (sheaf'.F.F U))
(valuation : ∀ x : space, Spv (stalk_of_rings sheaf'.to_presheaf_of_topological_rings.to_presheaf_of_rings x))
(local_stalks : ∀ x : space, is_local_ring (stalk_of_rings sheaf'.to_presheaf_of_rings x))
(supp_maximal : ∀ x : space, ideal.is_maximal (valuation x).supp)

end

namespace CLVRS
open category_theory

attribute [instance] top

/--A CLVRS is naturally a pre-valued ringed space.-/
def to_PreValuedRingedSpace (X : CLVRS) : PreValuedRingedSpace.{0} :=
{ presheaf := sheaf_of_topological_rings.to_presheaf_of_topological_rings X.sheaf',
  ..X }

/--The coercion from a CLVRS to a pre-valued ringed space.-/
instance : has_coe CLVRS PreValuedRingedSpace.{0} :=
⟨to_PreValuedRingedSpace⟩

/-- The topology on the underlying space of a CLVRS. -/
instance (X : CLVRS) : topological_space X := X.top

/-- The structure sheaf of a CLVRS. -/
def sheaf (X : CLVRS) : sheaf_of_topological_rings X := X.sheaf'

/--CLVRS is a full subcategory of PreValuedRingedSpace.-/
instance : large_category CLVRS := induced_category.category to_PreValuedRingedSpace

variables {X Y : CLVRS} (f : X ⟶ Y) (x : X)

/-- The underlying morphism of structure presheaves of a morphism of CLVRSs.-/
def fmap : presheaf_of_rings.f_map _ _:=
  (PreValuedRingedSpace.hom.fmap f).to_presheaf_of_rings_f_map

/-- The coercion of a morphims of CLVRSs to the map between the underlying topological spaces.-/
instance : has_coe_to_fun (X ⟶ Y) :=
{ F := λ f, X → Y,
  coe := λ f, (fmap f).f }

/-- The stalk of the structure sheaf at a point of a CLVRS.-/
def stalk (X : CLVRS) := stalk_of_rings (X.sheaf.to_presheaf_of_rings)

/-- The ring structure on the stalk of the structure sheaf of a CLVRS. -/
instance stalk.comm_ring : comm_ring (X.stalk x) := stalk_of_rings_is_comm_ring _ _

/-- The stalk of the structure sheaf of a CLVRS is a local ring. -/
instance stalk.is_local_ring : local_ring (X.stalk x) :=
local_of_is_local_ring $ X.local_stalks x

/-- The ring homomorphism on the stalks induced by a morphism of CLVRSs.-/
noncomputable def stalk_map : Y.stalk (f x) → X.stalk x :=
stalk_map (fmap f) x

/-- The map on the stalks induced by a morphism of CLVRSs is a ring homomorphism.-/
instance : is_ring_hom (stalk_map f x) := stalk_map.is_ring_hom _ _

section local_ring
open local_ring

/-- For every point in a CLVRS,
the support of the valuation on a stalk is the maximal ideal of the stalk.-/
lemma nonunits_eq_supp : nonunits_ideal (X.stalk x) = (X.valuation x).supp :=
unique_of_exists_unique (max_ideal_unique _) (nonunits_ideal.is_maximal _) (X.supp_maximal x)

/-- The map on stalks induced by a morphism of CLVRSs is compatible with the valuations
on the stalks: the pullback of the valuation on the source is the valuation on the target. -/
lemma comap_valuation :
  Spv.comap (stalk_map f x) (X.valuation x) = Y.valuation (f x) :=
PreValuedRingedSpace.hom.stalk _ _

/-- The map on stalks induced by a morphism of CLVRSs is a morphism of local rings. -/
lemma is_local_ring_hom :
  is_local_ring_hom (stalk_map f x) :=
{ map_nonunit :=
  begin
    intros s h,
    contrapose! h,
    rw [← mem_nonunits_iff, ← mem_nonunits_ideal, nonunits_eq_supp] at h ⊢,
    rwa [← comap_valuation, Spv.supp_comap] at h,
  end }

end local_ring

end CLVRS

/--The adic spectrum of a Huber pair.-/
noncomputable def Spa (A : Huber_pair) : PreValuedRingedSpace :=
{ space     := spa A,
  presheaf  := spa.presheaf_of_topological_rings A,
  valuation := λ x, Spv.mk (spa.presheaf.stalk_valuation x) }

open lattice

-- Notation for the proposition that an isomorphism exists between A and B
notation A `≊` B := nonempty (A ≅ B)

namespace CLVRS

/--A CLVRS is an adic space if every point has an open neighbourhood that is isomorphic
to the adic spectrum of a Huber pair.-/
def is_adic_space (X : CLVRS) : Prop :=
∀ x : X, ∃ (U : opens X) (R : Huber_pair), x ∈ U ∧ (Spa R ≊ U)

end CLVRS

/--A CLVRS is an adic space if every point has an open neighbourhood that is isomorphic
to the adic spectrum of a Huber pair.-/
def AdicSpace := {X : CLVRS // X.is_adic_space}

namespace AdicSpace
open category_theory

/--The category of adic spaces is the full subcategory of CLVRS that
consists of the objects that are adic spaces.-/
instance : large_category AdicSpace := category_theory.full_subcategory _

end AdicSpace


/-
Copyright (c) 2020 Simon Hudon. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Simon Hudon
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.nat.upto
import Mathlib.data.stream.basic
import Mathlib.data.pfun
import Mathlib.PostPort

universes u_3 l u_1 u_2

namespace Mathlib

/-!
# Fixed point

This module defines a generic `fix` operator for defining recursive
computations that are not necessarily well-founded or productive.
An instance is defined for `roption`.

## Main definition

 * class `has_fix`
 * `roption.fix`
-/

/-- `has_fix α` gives us a way to calculate the fixed point
of function of type `α → α`. -/
class has_fix (α : Type u_3) where
  fix : (α → α) → α

namespace roption

/-- A series of successive, finite approximation of the fixed point of `f`, defined by
`approx f n = f^[n] ⊥`. The limit of this chain is the fixed point of `f`. -/
def fix.approx {α : Type u_1} {β : α → Type u_2}
    (f : ((a : α) → roption (β a)) → (a : α) → roption (β a)) : stream ((a : α) → roption (β a)) :=
  sorry

/-- loop body for finding the fixed point of `f` -/
def fix_aux {α : Type u_1} {β : α → Type u_2}
    (f : ((a : α) → roption (β a)) → (a : α) → roption (β a)) {p : ℕ → Prop} (i : nat.upto p)
    (g : (j : nat.upto p) → i < j → (a : α) → roption (β a)) (a : α) : roption (β a) :=
  f
    fun (x : α) =>
      assert (¬p (subtype.val i)) fun (h : ¬p (subtype.val i)) => g (nat.upto.succ i h) sorry x

/-- The least fixed point of `f`.

If `f` is a continuous function (according to complete partial orders),
it satisfies the equations:

  1. `fix f = f (fix f)`          (is a fixed point)
  2. `∀ X, f X ≤ X → fix f ≤ X`   (least fixed point)
-/
protected def fix {α : Type u_1} {β : α → Type u_2}
    (f : ((a : α) → roption (β a)) → (a : α) → roption (β a)) (x : α) : roption (β x) :=
  assert (∃ (i : ℕ), dom sorry)
    fun (h : ∃ (i : ℕ), dom sorry) => well_founded.fix sorry (fix_aux f) nat.upto.zero x

protected theorem fix_def {α : Type u_1} {β : α → Type u_2}
    (f : ((a : α) → roption (β a)) → (a : α) → roption (β a)) {x : α}
    (h' : ∃ (i : ℕ), dom (fix.approx f i x)) :
    roption.fix f x = fix.approx f (Nat.succ (nat.find h')) x :=
  sorry

theorem fix_def' {α : Type u_1} {β : α → Type u_2}
    (f : ((a : α) → roption (β a)) → (a : α) → roption (β a)) {x : α}
    (h' : ¬∃ (i : ℕ), dom (fix.approx f i x)) : roption.fix f x = none :=
  sorry

end roption

namespace roption

protected instance has_fix {α : Type u_1} : has_fix (roption α) :=
  has_fix.mk
    fun (f : roption α → roption α) =>
      roption.fix (fun (x : Unit → roption α) (u : Unit) => f (x u)) Unit.unit

end roption

namespace pi

protected instance roption.has_fix {α : Type u_1} {β : Type u_2} : has_fix (α → roption β) :=
  has_fix.mk roption.fix

end Mathlib


/-
Copyright (c) 2022 Yury Kudryashov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yury Kudryashov
-/
import topology.metric_space.isometry

/-!
# Group actions by isometries

> THIS FILE IS SYNCHRONIZED WITH MATHLIB4.
> Any changes to this file require a corresponding PR to mathlib4.

In this file we define two typeclasses:

- `has_isometric_smul M X` says that `M` multiplicatively acts on a (pseudo extended) metric space
  `X` by isometries;
- `has_isometric_vadd` is an additive version of `has_isometric_smul`.

We also prove basic facts about isometric actions and define bundled isometries
`isometry_equiv.const_mul`, `isometry_equiv.mul_left`, `isometry_equiv.mul_right`,
`isometry_equiv.div_left`, `isometry_equiv.div_right`, and `isometry_equiv.inv`, as well as their
additive versions.

If `G` is a group, then `has_isometric_smul G G` means that `G` has a left-invariant metric while
`has_isometric_smul Gᵐᵒᵖ G` means that `G` has a right-invariant metric. For a commutative group,
these two notions are equivalent. A group with a right-invariant metric can be also represented as a
`normed_group`.
-/

open set
open_locale ennreal pointwise

universes u v w

variables (M : Type u) (G : Type v) (X : Type w)

/-- An additive action is isometric if each map `x ↦ c +ᵥ x` is an isometry. -/
class has_isometric_vadd [pseudo_emetric_space X] [has_vadd M X] : Prop :=
(isometry_vadd [] : ∀ c : M, isometry ((+ᵥ) c : X → X))

/-- A multiplicative action is isometric if each map `x ↦ c • x` is an isometry. -/
@[to_additive] class has_isometric_smul [pseudo_emetric_space X] [has_smul M X] : Prop :=
(isometry_smul [] : ∀ c : M, isometry ((•) c : X → X))

export has_isometric_vadd (isometry_vadd) has_isometric_smul (isometry_smul)

@[priority 100, to_additive]
instance has_isometric_smul.to_has_continuous_const_smul [pseudo_emetric_space X] [has_smul M X]
  [has_isometric_smul M X] : has_continuous_const_smul M X :=
⟨λ c, (isometry_smul X c).continuous⟩

@[priority 100, to_additive]
instance has_isometric_smul.opposite_of_comm [pseudo_emetric_space X] [has_smul M X]
  [has_smul Mᵐᵒᵖ X] [is_central_scalar M X] [has_isometric_smul M X] :
  has_isometric_smul Mᵐᵒᵖ X :=
⟨λ c x y, by simpa only [← op_smul_eq_smul] using (isometry_smul X c.unop x y)⟩

variables {M G X}

section emetric

variables [pseudo_emetric_space X] [group G] [mul_action G X] [has_isometric_smul G X]

@[simp, to_additive] lemma edist_smul_left [has_smul M X] [has_isometric_smul M X]
  (c : M) (x y : X) :
  edist (c • x) (c • y) = edist x y :=
isometry_smul X c x y

@[to_additive] lemma isometry_mul_left [has_mul M] [pseudo_emetric_space M]
  [has_isometric_smul M M] (a : M) : isometry ((*) a) :=
isometry_smul M a

@[simp, to_additive] lemma edist_mul_left [has_mul M] [pseudo_emetric_space M]
  [has_isometric_smul M M] (a b c : M) : edist (a * b) (a * c) = edist b c :=
isometry_mul_left a b c

@[to_additive] lemma isometry_mul_right [has_mul M] [pseudo_emetric_space M]
  [has_isometric_smul Mᵐᵒᵖ M] (a : M) : isometry (λ x, x * a) :=
isometry_smul M (mul_opposite.op a)

@[simp, to_additive] lemma edist_mul_right [has_mul M] [pseudo_emetric_space M]
  [has_isometric_smul Mᵐᵒᵖ M] (a b c : M) : edist (a * c) (b * c) = edist a b :=
isometry_mul_right c a b

@[simp, to_additive] lemma edist_div_right [div_inv_monoid M] [pseudo_emetric_space M]
  [has_isometric_smul Mᵐᵒᵖ M] (a b c : M) : edist (a / c) (b / c) = edist a b :=
by simp only [div_eq_mul_inv, edist_mul_right]

@[simp, to_additive] lemma edist_inv_inv [pseudo_emetric_space G] [has_isometric_smul G G]
  [has_isometric_smul Gᵐᵒᵖ G] (a b : G) : edist a⁻¹ b⁻¹ = edist a b :=
by rw [← edist_mul_left a, ← edist_mul_right _ _ b, mul_right_inv, one_mul,
  inv_mul_cancel_right, edist_comm]

@[to_additive] lemma isometry_inv [pseudo_emetric_space G] [has_isometric_smul G G]
  [has_isometric_smul Gᵐᵒᵖ G] : isometry (has_inv.inv : G → G) :=
edist_inv_inv

@[to_additive] lemma edist_inv [pseudo_emetric_space G] [has_isometric_smul G G]
  [has_isometric_smul Gᵐᵒᵖ G] (x y : G) : edist x⁻¹ y = edist x y⁻¹ :=
by rw [← edist_inv_inv, inv_inv]

@[simp, to_additive] lemma edist_div_left [pseudo_emetric_space G] [has_isometric_smul G G]
  [has_isometric_smul Gᵐᵒᵖ G] (a b c : G) : edist (a / b) (a / c) = edist b c :=
by rw [div_eq_mul_inv, div_eq_mul_inv, edist_mul_left, edist_inv_inv]

namespace isometry_equiv

/-- If a group `G` acts on `X` by isometries, then `isometry_equiv.const_smul` is the isometry of
`X` given by multiplication of a constant element of the group. -/
@[to_additive "If an additive group `G` acts on `X` by isometries, then `isometry_equiv.const_vadd`
is the isometry of `X` given by addition of a constant element of the group.", simps to_equiv apply]
def const_smul (c : G) : X ≃ᵢ X :=
{ to_equiv := mul_action.to_perm c,
  isometry_to_fun := isometry_smul X c }

@[simp, to_additive]
lemma const_smul_symm (c : G) : (const_smul c : X ≃ᵢ X).symm = const_smul c⁻¹ := ext $ λ _, rfl

variables [pseudo_emetric_space G]

/-- Multiplication `y ↦ x * y` as an `isometry_equiv`. -/
@[to_additive "Addition `y ↦ x + y` as an `isometry_equiv`.", simps apply to_equiv]
def mul_left [has_isometric_smul G G] (c : G) : G ≃ᵢ G :=
{ to_equiv := equiv.mul_left c,
  isometry_to_fun := edist_mul_left c }

@[simp, to_additive] lemma mul_left_symm [has_isometric_smul G G] (x : G) :
  (mul_left x).symm = isometry_equiv.mul_left x⁻¹ :=
const_smul_symm x --ext $ λ y, rfl

/-- Multiplication `y ↦ y * x` as an `isometry_equiv`. -/
@[to_additive "Addition `y ↦ y + x` as an `isometry_equiv`.", simps apply to_equiv]
def mul_right [has_isometric_smul Gᵐᵒᵖ G] (c : G) : G ≃ᵢ G :=
{ to_equiv := equiv.mul_right c,
  isometry_to_fun := λ a b, edist_mul_right a b c }

@[simp, to_additive] lemma mul_right_symm [has_isometric_smul Gᵐᵒᵖ G] (x : G) :
  (mul_right x).symm = mul_right x⁻¹ :=
ext $ λ y, rfl

/-- Division `y ↦ y / x` as an `isometry_equiv`. -/
@[to_additive "Subtraction `y ↦ y - x` as an `isometry_equiv`.", simps apply to_equiv]
def div_right [has_isometric_smul Gᵐᵒᵖ G] (c : G) : G ≃ᵢ G :=
{ to_equiv := equiv.div_right c,
  isometry_to_fun := λ a b, edist_div_right a b c }

@[simp, to_additive] lemma div_right_symm [has_isometric_smul Gᵐᵒᵖ G] (c : G) :
  (div_right c).symm = mul_right c :=
ext $ λ y, rfl

variables [has_isometric_smul G G] [has_isometric_smul Gᵐᵒᵖ G]

/-- Division `y ↦ x / y` as an `isometry_equiv`. -/
@[to_additive "Subtraction `y ↦ x - y` as an `isometry_equiv`.", simps apply symm_apply to_equiv]
def div_left (c : G) : G ≃ᵢ G :=
{ to_equiv := equiv.div_left c,
  isometry_to_fun := edist_div_left c }

variable (G)

/-- Inversion `x ↦ x⁻¹` as an `isometry_equiv`. -/
@[to_additive "Negation `x ↦ -x` as an `isometry_equiv`.", simps apply to_equiv]
def inv : G ≃ᵢ G :=
{ to_equiv := equiv.inv G,
  isometry_to_fun := edist_inv_inv }

@[simp, to_additive] lemma inv_symm : (inv G).symm = inv G := rfl

end isometry_equiv

namespace emetric

@[simp, to_additive] lemma smul_ball (c : G) (x : X) (r : ℝ≥0∞) :
  c • ball x r = ball (c • x) r :=
(isometry_equiv.const_smul c).image_emetric_ball _ _

@[simp, to_additive] lemma preimage_smul_ball (c : G) (x : X) (r : ℝ≥0∞) :
  ((•) c) ⁻¹' ball x r = ball (c⁻¹ • x) r :=
by rw [preimage_smul, smul_ball]

@[simp, to_additive] lemma smul_closed_ball (c : G) (x : X) (r : ℝ≥0∞) :
  c • closed_ball x r = closed_ball (c • x) r :=
(isometry_equiv.const_smul c).image_emetric_closed_ball _ _

@[simp, to_additive] lemma preimage_smul_closed_ball (c : G) (x : X) (r : ℝ≥0∞) :
  ((•) c) ⁻¹' closed_ball x r = closed_ball (c⁻¹ • x) r :=
by rw [preimage_smul, smul_closed_ball]

variables [pseudo_emetric_space G]

@[simp, to_additive]
lemma preimage_mul_left_ball [has_isometric_smul G G] (a b : G) (r : ℝ≥0∞) :
  ((*) a) ⁻¹' ball b r = ball (a⁻¹ * b) r :=
preimage_smul_ball a b r

@[simp, to_additive]
lemma preimage_mul_right_ball [has_isometric_smul Gᵐᵒᵖ G] (a b : G) (r : ℝ≥0∞) :
  (λ x, x * a) ⁻¹' ball b r = ball (b / a) r :=
by { rw div_eq_mul_inv, exact preimage_smul_ball (mul_opposite.op a) b r }

@[simp, to_additive]
lemma preimage_mul_left_closed_ball [has_isometric_smul G G] (a b : G) (r : ℝ≥0∞) :
  ((*) a) ⁻¹' closed_ball b r = closed_ball (a⁻¹ * b) r :=
preimage_smul_closed_ball a b r

@[simp, to_additive]
lemma preimage_mul_right_closed_ball [has_isometric_smul Gᵐᵒᵖ G] (a b : G) (r : ℝ≥0∞) :
  (λ x, x * a) ⁻¹' closed_ball b r = closed_ball (b / a) r :=
by { rw div_eq_mul_inv, exact preimage_smul_closed_ball (mul_opposite.op a) b r }

end emetric

end emetric

@[simp, to_additive]
lemma dist_smul [pseudo_metric_space X] [has_smul M X] [has_isometric_smul M X]
  (c : M) (x y : X) : dist (c • x) (c • y) = dist x y :=
(isometry_smul X c).dist_eq x y

@[simp, to_additive]
lemma nndist_smul [pseudo_metric_space X] [has_smul M X] [has_isometric_smul M X]
  (c : M) (x y : X) : nndist (c • x) (c • y) = nndist x y :=
(isometry_smul X c).nndist_eq x y

@[simp, to_additive]
lemma dist_mul_left [pseudo_metric_space M] [has_mul M] [has_isometric_smul M M]
  (a b c : M) : dist (a * b) (a * c) = dist b c :=
dist_smul a b c

@[simp, to_additive]
lemma nndist_mul_left [pseudo_metric_space M] [has_mul M] [has_isometric_smul M M]
  (a b c : M) : nndist (a * b) (a * c) = nndist b c :=
nndist_smul a b c

@[simp, to_additive] lemma dist_mul_right [has_mul M] [pseudo_metric_space M]
  [has_isometric_smul Mᵐᵒᵖ M] (a b c : M) : dist (a * c) (b * c) = dist a b :=
dist_smul (mul_opposite.op c) a b

@[simp, to_additive]
lemma nndist_mul_right [pseudo_metric_space M] [has_mul M] [has_isometric_smul Mᵐᵒᵖ M]
  (a b c : M) : nndist (a * c) (b * c) = nndist a b :=
nndist_smul (mul_opposite.op c) a b

@[simp, to_additive] lemma dist_div_right [div_inv_monoid M] [pseudo_metric_space M]
  [has_isometric_smul Mᵐᵒᵖ M] (a b c : M) : dist (a / c) (b / c) = dist a b :=
by simp only [div_eq_mul_inv, dist_mul_right]

@[simp, to_additive] lemma nndist_div_right [div_inv_monoid M] [pseudo_metric_space M]
  [has_isometric_smul Mᵐᵒᵖ M] (a b c : M) : nndist (a / c) (b / c) = nndist a b :=
by simp only [div_eq_mul_inv, nndist_mul_right]

@[simp, to_additive]
lemma dist_inv_inv [group G] [pseudo_metric_space G] [has_isometric_smul G G]
  [has_isometric_smul Gᵐᵒᵖ G] (a b : G) : dist a⁻¹ b⁻¹ = dist a b :=
(isometry_equiv.inv G).dist_eq a b

@[simp, to_additive]
lemma nndist_inv_inv [group G] [pseudo_metric_space G] [has_isometric_smul G G]
  [has_isometric_smul Gᵐᵒᵖ G] (a b : G) : nndist a⁻¹ b⁻¹ = nndist a b :=
(isometry_equiv.inv G).nndist_eq a b

@[simp, to_additive]
lemma dist_div_left [group G] [pseudo_metric_space G] [has_isometric_smul G G]
  [has_isometric_smul Gᵐᵒᵖ G] (a b c : G) : dist (a / b) (a / c) = dist b c :=
by simp [div_eq_mul_inv]

@[simp, to_additive]
lemma nndist_div_left [group G] [pseudo_metric_space G] [has_isometric_smul G G]
  [has_isometric_smul Gᵐᵒᵖ G] (a b c : G) : nndist (a / b) (a / c) = nndist b c :=
by simp [div_eq_mul_inv]

namespace metric

variables [pseudo_metric_space X] [group G] [mul_action G X] [has_isometric_smul G X]

@[simp, to_additive] lemma smul_ball (c : G) (x : X) (r : ℝ) :
  c • ball x r = ball (c • x) r :=
(isometry_equiv.const_smul c).image_ball _ _

@[simp, to_additive] lemma preimage_smul_ball (c : G) (x : X) (r : ℝ) :
  ((•) c) ⁻¹' ball x r = ball (c⁻¹ • x) r :=
by rw [preimage_smul, smul_ball]

@[simp, to_additive] lemma smul_closed_ball (c : G) (x : X) (r : ℝ) :
  c • closed_ball x r = closed_ball (c • x) r :=
(isometry_equiv.const_smul c).image_closed_ball _ _

@[simp, to_additive] lemma preimage_smul_closed_ball (c : G) (x : X) (r : ℝ) :
  ((•) c) ⁻¹' closed_ball x r = closed_ball (c⁻¹ • x) r :=
by rw [preimage_smul, smul_closed_ball]

@[simp, to_additive] lemma smul_sphere (c : G) (x : X) (r : ℝ) :
  c • sphere x r = sphere (c • x) r :=
(isometry_equiv.const_smul c).image_sphere _ _

@[simp, to_additive] lemma preimage_smul_sphere (c : G) (x : X) (r : ℝ) :
  ((•) c) ⁻¹' sphere x r = sphere (c⁻¹ • x) r :=
by rw [preimage_smul, smul_sphere]

variables [pseudo_metric_space G]

@[simp, to_additive]
lemma preimage_mul_left_ball [has_isometric_smul G G] (a b : G) (r : ℝ) :
  ((*) a) ⁻¹' ball b r = ball (a⁻¹ * b) r :=
preimage_smul_ball a b r

@[simp, to_additive]
lemma preimage_mul_right_ball [has_isometric_smul Gᵐᵒᵖ G] (a b : G) (r : ℝ) :
  (λ x, x * a) ⁻¹' ball b r = ball (b / a) r :=
by { rw div_eq_mul_inv, exact preimage_smul_ball (mul_opposite.op a) b r }

@[simp, to_additive]
lemma preimage_mul_left_closed_ball [has_isometric_smul G G] (a b : G) (r : ℝ) :
  ((*) a) ⁻¹' closed_ball b r = closed_ball (a⁻¹ * b) r :=
preimage_smul_closed_ball a b r

@[simp, to_additive]
lemma preimage_mul_right_closed_ball [has_isometric_smul Gᵐᵒᵖ G] (a b : G) (r : ℝ) :
  (λ x, x * a) ⁻¹' closed_ball b r = closed_ball (b / a) r :=
by { rw div_eq_mul_inv, exact preimage_smul_closed_ball (mul_opposite.op a) b r }

end metric

section instances

variables {Y : Type*} [pseudo_emetric_space X] [pseudo_emetric_space Y] [has_smul M X]
  [has_isometric_smul M X]

@[to_additive] instance [has_smul M Y] [has_isometric_smul M Y] :
  has_isometric_smul M (X × Y) :=
⟨λ c, (isometry_smul X c).prod_map (isometry_smul Y c)⟩

@[to_additive] instance prod.has_isometric_smul' {N}
  [has_mul M] [pseudo_emetric_space M] [has_isometric_smul M M]
  [has_mul N] [pseudo_emetric_space N] [has_isometric_smul N N] :
  has_isometric_smul (M × N) (M × N) :=
⟨λ c, (isometry_smul M c.1).prod_map (isometry_smul N c.2)⟩

@[to_additive] instance prod.has_isometric_smul'' {N}
  [has_mul M] [pseudo_emetric_space M] [has_isometric_smul Mᵐᵒᵖ M]
  [has_mul N] [pseudo_emetric_space N] [has_isometric_smul Nᵐᵒᵖ N] :
  has_isometric_smul (M × N)ᵐᵒᵖ (M × N) :=
⟨λ c, (isometry_mul_right c.unop.1).prod_map (isometry_mul_right c.unop.2)⟩

@[to_additive] instance units.has_isometric_smul [monoid M] : has_isometric_smul Mˣ X :=
⟨λ c, by convert isometry_smul X (c : M)⟩

@[to_additive] instance : has_isometric_smul M Xᵐᵒᵖ :=
⟨λ c x y, by simpa only using edist_smul_left c x.unop y.unop⟩

@[to_additive] instance ulift.has_isometric_smul : has_isometric_smul (ulift M) X :=
⟨λ c, by simpa only using isometry_smul X c.down⟩

@[to_additive] instance ulift.has_isometric_smul' : has_isometric_smul M (ulift X) :=
⟨λ c x y, by simpa only using edist_smul_left c x.1 y.1⟩

@[to_additive] instance {ι} {X : ι → Type*} [fintype ι] [Π i, has_smul M (X i)]
  [Π i, pseudo_emetric_space (X i)] [∀ i, has_isometric_smul M (X i)] :
  has_isometric_smul M (Π i, X i) :=
⟨λ c, isometry_dcomp (λ i, (•) c) (λ i, isometry_smul (X i) c)⟩

@[to_additive] instance pi.has_isometric_smul' {ι} {M X : ι → Type*} [fintype ι]
  [Π i, has_smul (M i) (X i)] [Π i, pseudo_emetric_space (X i)]
  [∀ i, has_isometric_smul (M i) (X i)] :
  has_isometric_smul (Π i, M i) (Π i, X i) :=
⟨λ c, isometry_dcomp (λ i, (•) (c i)) (λ i, isometry_smul _ _)⟩

@[to_additive] instance pi.has_isometric_smul'' {ι} {M : ι → Type*} [fintype ι]
  [Π i, has_mul (M i)] [Π i, pseudo_emetric_space (M i)] [∀ i, has_isometric_smul (M i)ᵐᵒᵖ (M i)] :
  has_isometric_smul (Π i, M i)ᵐᵒᵖ (Π i, M i) :=
⟨λ c, isometry_dcomp (λ i (x : M i), x * c.unop i) $ λ i, isometry_mul_right _⟩

instance additive.has_isometric_vadd : has_isometric_vadd (additive M) X :=
⟨λ c, isometry_smul X c.to_mul⟩

instance additive.has_isometric_vadd' [has_mul M] [pseudo_emetric_space M]
  [has_isometric_smul M M] : has_isometric_vadd (additive M) (additive M) :=
⟨λ c x y, edist_smul_left c.to_mul x.to_mul y.to_mul⟩

instance additive.has_isometric_vadd'' [has_mul M] [pseudo_emetric_space M]
  [has_isometric_smul Mᵐᵒᵖ M] : has_isometric_vadd (additive M)ᵃᵒᵖ (additive M) :=
⟨λ c x y, edist_smul_left (mul_opposite.op c.unop.to_mul) x.to_mul y.to_mul⟩

instance multiplicative.has_isometric_smul {M X} [has_vadd M X] [pseudo_emetric_space X]
  [has_isometric_vadd M X]: has_isometric_smul (multiplicative M) X :=
⟨λ c, isometry_vadd X c.to_add⟩

instance multiplicative.has_isometric_smul' [has_add M] [pseudo_emetric_space M]
  [has_isometric_vadd M M] : has_isometric_smul (multiplicative M) (multiplicative M) :=
⟨λ c x y, edist_vadd_left c.to_add x.to_add y.to_add⟩

instance multiplicative.has_isometric_vadd'' [has_add M] [pseudo_emetric_space M]
  [has_isometric_vadd Mᵃᵒᵖ M] :
  has_isometric_smul (multiplicative M)ᵐᵒᵖ (multiplicative M) :=
⟨λ c x y, edist_vadd_left (add_opposite.op c.unop.to_add) x.to_add y.to_add⟩

end instances


universe u

axiom elimEx (motive : Nat → Nat → Sort u) (x y : Nat)
  (diag  : (a : Nat) → motive a a)
  (upper : (delta a : Nat) → motive a (a + delta.succ))
  (lower : (delta a : Nat) → motive (a + delta.succ) a)
  : motive y x

theorem ex1 (p q : Nat) : p ≤ q ∨ p > q := by
  cases p, q using elimEx with
  | lower d => apply Or.inl -- Error
  | upper d => apply Or.inr -- Error
  | diag    => apply Or.inl; apply Nat.leRefl

theorem ex2 (p q : Nat) : p ≤ q ∨ p > q := by
  cases p, q using elimEx2 with -- Error
  | lower d => apply Or.inl
  | upper d => apply Or.inr
  | diag    => apply Or.inl; apply Nat.leRefl

theorem ex3 (p q : Nat) : p ≤ q ∨ p > q := by
  cases p /- Error -/ using elimEx with
  | lower d => apply Or.inl
  | upper d => apply Or.inr
  | diag    => apply Or.inl; apply Nat.leRefl

theorem ex4 (p q : Nat) : p ≤ q ∨ p > q := by
  cases p using Nat.add with -- Error
  | lower d => apply Or.inl
  | upper d => apply Or.inr
  | diag    => apply Or.inl; apply Nat.leRefl

theorem ex5 (x : Nat) : 0 + x = x := by
  match x with
  | 0   => done -- Error
  | y+1 => done -- Error

theorem ex5b (x : Nat) : 0 + x = x := by
  cases x with
  | zero   => done -- Error
  | succ y => done -- Error

inductive Vec : Nat → Type
  | nil  : Vec 0
  | cons : Bool → {n : Nat} → Vec n → Vec (n+1)

theorem ex6 (x : Vec 0) : x = Vec.nil := by
  cases x using Vec.casesOn with
  | nil  => rfl
  | cons => done -- Error

theorem ex7 (x : Vec 0) : x = Vec.nil := by
  cases x with -- Error: TODO: improve error location
  | nil  => rfl
  | cons => done

theorem ex8 (p q : Nat) : p ≤ q ∨ p > q := by
  cases p, q using elimEx with
  | lower d => apply Or.inl; admit
  | upper2 /- Error -/ d => apply Or.inr
  | diag    => apply Or.inl; apply Nat.leRefl

theorem ex9 (p q : Nat) : p ≤ q ∨ p > q := by
  cases p, q using elimEx with
  | lower d => apply Or.inl; admit
  | _ => apply Or.inr; admit
  | diag    => apply Or.inl; apply Nat.leRefl

theorem ex10 (p q : Nat) : p ≤ q ∨ p > q := by
  cases p, q using elimEx with
  | lower d => apply Or.inl; admit
  | upper d => apply Or.inr; admit
  | diag    => apply Or.inl; apply Nat.leRefl
  | _  /- error unused -/ => admit

theorem ex11 (p q : Nat) : p ≤ q ∨ p > q := by
  cases p, q using elimEx with
  | lower d => apply Or.inl; admit
  | upper d => apply Or.inr; admit
  | lower d /- error unused -/ => apply Or.inl; admit
  | diag    => apply Or.inl; apply Nat.leRefl


/-
Copyright (c) 2017 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura, Mario Carneiro

! This file was ported from Lean 3 source module init.data.array.basic
! leanprover-community/mathlib commit 7cb84a2a93c1e2d37b3ad5017fc5372973dbb9fb
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
prelude
import Leanbin.Init.Data.Nat.Default
import Leanbin.Init.Data.Bool.Default
import Leanbin.Init.IteSimp

universe u v w

/-- In the VM, d_array is implemented as a persistent array. -/
structure DArray (n : Nat) (α : Fin n → Type u) where
  data : ∀ i : Fin n, α i
#align d_array DArray

namespace DArray

variable {n : Nat} {α : Fin n → Type u} {α' : Fin n → Type v} {β : Type w}

/-- The empty array. -/
def nil {α} : DArray 0 α where data := fun ⟨x, h⟩ => absurd h (Nat.not_lt_zero x)
#align d_array.nil DArray.nil

/-- `read a i` reads the `i`th member of `a`. Has builtin VM implementation. -/
def read (a : DArray n α) (i : Fin n) : α i :=
  a.data i
#align d_array.read DArray.read

/-- `write a i v` sets the `i`th member of `a` to be `v`. Has builtin VM implementation. -/
def write (a : DArray n α) (i : Fin n) (v : α i) : DArray n α
    where data j := if h : i = j then Eq.recOn h v else a.read j
#align d_array.write DArray.write

def iterateAux (a : DArray n α) (f : ∀ i : Fin n, α i → β → β) : ∀ i : Nat, i ≤ n → β → β
  | 0, h, b => b
  | j + 1, h, b =>
    let i : Fin n := ⟨j, h⟩
    f i (a.read i) (iterate_aux j (le_of_lt h) b)
#align d_array.iterate_aux DArray.iterateAux

/-- Fold over the elements of the given array in ascending order. Has builtin VM implementation. -/
def iterate (a : DArray n α) (b : β) (f : ∀ i : Fin n, α i → β → β) : β :=
  iterateAux a f n (le_refl _) b
#align d_array.iterate DArray.iterate

/-- Map the array. Has builtin VM implementation. -/
def foreach (a : DArray n α) (f : ∀ i : Fin n, α i → α' i) : DArray n α' :=
  ⟨fun i => f _ (a.read i)⟩
#align d_array.foreach DArray.foreach

def map (f : ∀ i : Fin n, α i → α' i) (a : DArray n α) : DArray n α' :=
  foreach a f
#align d_array.map DArray.map

def map₂ {α'' : Fin n → Type w} (f : ∀ i : Fin n, α i → α' i → α'' i) (a : DArray n α)
    (b : DArray n α') : DArray n α'' :=
  foreach b fun i => f i (a.read i)
#align d_array.map₂ DArray.map₂

def foldl (a : DArray n α) (b : β) (f : ∀ i : Fin n, α i → β → β) : β :=
  iterate a b f
#align d_array.foldl DArray.foldl

def revIterateAux (a : DArray n α) (f : ∀ i : Fin n, α i → β → β) : ∀ i : Nat, i ≤ n → β → β
  | 0, h, b => b
  | j + 1, h, b =>
    let i : Fin n := ⟨j, h⟩
    rev_iterate_aux j (le_of_lt h) (f i (a.read i) b)
#align d_array.rev_iterate_aux DArray.revIterateAux

def revIterate (a : DArray n α) (b : β) (f : ∀ i : Fin n, α i → β → β) : β :=
  revIterateAux a f n (le_refl _) b
#align d_array.rev_iterate DArray.revIterate

@[simp]
theorem read_write (a : DArray n α) (i : Fin n) (v : α i) : read (write a i v) i = v := by
  simp [read, write]
#align d_array.read_write DArray.read_write

@[simp]
theorem read_write_of_ne (a : DArray n α) {i j : Fin n} (v : α i) :
    i ≠ j → read (write a i v) j = read a j := by intro h <;> simp [read, write, h]
#align d_array.read_write_of_ne DArray.read_write_of_ne

protected theorem ext {a b : DArray n α} (h : ∀ i, read a i = read b i) : a = b := by
  cases a <;> cases b <;> congr <;> exact funext h
#align d_array.ext DArray.ext

protected theorem ext' {a b : DArray n α}
    (h : ∀ (i : Nat) (h : i < n), read a ⟨i, h⟩ = read b ⟨i, h⟩) : a = b := by cases a; cases b;
  congr ; funext i; cases i; apply h
#align d_array.ext' DArray.ext'

protected def beqAux [∀ i, DecidableEq (α i)] (a b : DArray n α) : ∀ i : Nat, i ≤ n → Bool
  | 0, h => true
  | i + 1, h => if a.read ⟨i, h⟩ = b.read ⟨i, h⟩ then beq_aux i (le_of_lt h) else false
#align d_array.beq_aux DArray.beqAux

/-- Boolean element-wise equality check. -/
protected def beq [∀ i, DecidableEq (α i)] (a b : DArray n α) : Bool :=
  DArray.beqAux a b n (le_refl _)
#align d_array.beq DArray.beq

theorem of_beqAux_eq_true [∀ i, DecidableEq (α i)] {a b : DArray n α} :
    ∀ (i : Nat) (h : i ≤ n),
      DArray.beqAux a b i h = true →
        ∀ (j : Nat) (h' : j < i), a.read ⟨j, lt_of_lt_of_le h' h⟩ = b.read ⟨j, lt_of_lt_of_le h' h⟩
  | 0, h₁, h₂, j, h₃ => absurd h₃ (Nat.not_lt_zero _)
  | i + 1, h₁, h₂, j, h₃ =>
    by
    have h₂' : read a ⟨i, h₁⟩ = read b ⟨i, h₁⟩ ∧ DArray.beqAux a b i _ = tt :=
      by
      simp [DArray.beqAux] at h₂
      assumption
    have h₁' : i ≤ n := le_of_lt h₁
    have ih :
      ∀ (j : Nat) (h' : j < i),
        a.read ⟨j, lt_of_lt_of_le h' h₁'⟩ = b.read ⟨j, lt_of_lt_of_le h' h₁'⟩ :=
      of_beq_aux_eq_tt i h₁' h₂'.2
    by_cases hji : j = i
    · subst hji
      exact h₂'.1
    · have j_lt_i : j < i := lt_of_le_of_ne (Nat.le_of_lt_succ h₃) hji
      exact ih j j_lt_i
#align d_array.of_beq_aux_eq_tt DArray.of_beqAux_eq_true

theorem of_beq_eq_true [∀ i, DecidableEq (α i)] {a b : DArray n α} :
    DArray.beq a b = true → a = b := by
  unfold DArray.beq
  intro h
  have : ∀ (j : Nat) (h : j < n), a.read ⟨j, h⟩ = b.read ⟨j, h⟩ := of_beq_aux_eq_tt n (le_refl _) h
  apply DArray.ext' this
#align d_array.of_beq_eq_tt DArray.of_beq_eq_true

theorem of_beqAux_eq_false [∀ i, DecidableEq (α i)] {a b : DArray n α} :
    ∀ (i : Nat) (h : i ≤ n),
      DArray.beqAux a b i h = false →
        ∃ (j : Nat)(h' : j < i), a.read ⟨j, lt_of_lt_of_le h' h⟩ ≠ b.read ⟨j, lt_of_lt_of_le h' h⟩
  | 0, h₁, h₂ => by simp [DArray.beqAux] at h₂; contradiction
  | i + 1, h₁, h₂ =>
    by
    have h₂' : read a ⟨i, h₁⟩ ≠ read b ⟨i, h₁⟩ ∨ DArray.beqAux a b i _ = ff :=
      by
      simp [DArray.beqAux] at h₂
      assumption
    cases' h₂' with h h
    · exists i
      exists Nat.lt_succ_self _
      exact h
    · have h₁' : i ≤ n := le_of_lt h₁
      have ih :
        ∃ (j : Nat)(h' : j < i),
          a.read ⟨j, lt_of_lt_of_le h' h₁'⟩ ≠ b.read ⟨j, lt_of_lt_of_le h' h₁'⟩ :=
        of_beq_aux_eq_ff i h₁' h
      cases' ih with j ih
      cases' ih with h' ih
      exists j
      exists Nat.lt_succ_of_lt h'
      exact ih
#align d_array.of_beq_aux_eq_ff DArray.of_beqAux_eq_false

theorem of_beq_eq_false [∀ i, DecidableEq (α i)] {a b : DArray n α} :
    DArray.beq a b = false → a ≠ b := by
  unfold DArray.beq
  intro h hne
  have : ∃ (j : Nat)(h' : j < n), a.read ⟨j, h'⟩ ≠ b.read ⟨j, h'⟩ :=
    of_beq_aux_eq_ff n (le_refl _) h
  cases' this with j this
  cases' this with h' this
  subst hne
  contradiction
#align d_array.of_beq_eq_ff DArray.of_beq_eq_false

instance [∀ i, DecidableEq (α i)] : DecidableEq (DArray n α) := fun a b =>
  if h : DArray.beq a b = true then isTrue (of_beq_eq_true h)
  else isFalse (of_beq_eq_false (Bool.eq_false_of_not_eq_true h))

end DArray

/-- A non-dependent array (see `d_array`). Implemented in the VM as a persistent array.  -/
def Array' (n : Nat) (α : Type u) : Type u :=
  DArray n fun _ => α
#align array Array'

/--
`mk_array n v` creates a new array of length `n` where each element is `v`. Has builtin VM implementation. -/
def mkArray' {α} (n) (v : α) : Array' n α where data _ := v
#align mk_array mkArray'

namespace Array'

variable {n : Nat} {α : Type u} {β : Type v}

def nil {α} : Array' 0 α :=
  DArray.nil
#align array.nil Array'.nil

@[inline]
def read (a : Array' n α) (i : Fin n) : α :=
  DArray.read a i
#align array.read Array'.read

@[inline]
def write (a : Array' n α) (i : Fin n) (v : α) : Array' n α :=
  DArray.write a i v
#align array.write Array'.write

/-- Fold array starting from 0, folder function includes an index argument. -/
@[inline]
def iterate (a : Array' n α) (b : β) (f : Fin n → α → β → β) : β :=
  DArray.iterate a b f
#align array.iterate Array'.iterate

/-- Map each element of the given array with an index argument. -/
@[inline]
def foreach (a : Array' n α) (f : Fin n → α → β) : Array' n β :=
  DArray.foreach a f
#align array.foreach Array'.foreach

@[inline]
def map₂ (f : α → α → α) (a b : Array' n α) : Array' n α :=
  foreach b fun i => f (a.read i)
#align array.map₂ Array'.map₂

@[inline]
def foldl (a : Array' n α) (b : β) (f : α → β → β) : β :=
  iterate a b fun _ => f
#align array.foldl Array'.foldl

def revList (a : Array' n α) : List α :=
  a.foldl [] (· :: ·)
#align array.rev_list Array'.revList

def revIterate (a : Array' n α) (b : β) (f : Fin n → α → β → β) : β :=
  DArray.revIterate a b f
#align array.rev_iterate Array'.revIterate

def revFoldl (a : Array' n α) (b : β) (f : α → β → β) : β :=
  revIterate a b fun _ => f
#align array.rev_foldl Array'.revFoldl

def toList (a : Array' n α) : List α :=
  a.revFoldl [] (· :: ·)
#align array.to_list Array'.toList

theorem push_back_idx {j n} (h₁ : j < n + 1) (h₂ : j ≠ n) : j < n :=
  Nat.lt_of_le_and_ne (Nat.le_of_lt_succ h₁) h₂
#align array.push_back_idx Array'.push_back_idx

/-- `push_back a v` pushes value `v` to the end of the array. Has builtin VM implementation. -/
def pushBack (a : Array' n α) (v : α) : Array' (n + 1) α
    where data := fun ⟨j, h₁⟩ => if h₂ : j = n then v else a.read ⟨j, push_back_idx h₁ h₂⟩
#align array.push_back Array'.pushBack

theorem pop_back_idx {j n} (h : j < n) : j < n + 1 :=
  Nat.lt.step h
#align array.pop_back_idx Array'.pop_back_idx

/-- Discard _last_ element in the array. Has builtin VM implementation. -/
def popBack (a : Array' (n + 1) α) : Array' n α
    where data := fun ⟨j, h⟩ => a.read ⟨j, pop_back_idx h⟩
#align array.pop_back Array'.popBack

/-- Auxilliary function for monadically mapping a function over an array. -/
@[inline]
def mmapCore {β : Type v} {m : Type v → Type w} [Monad m] (a : Array' n α) (f : α → m β) :
    ∀ i ≤ n, m (Array' i β)
  | 0, _ => pure DArray.nil
  | i + 1, h => do
    let bs ← mmap_core i (le_of_lt h)
    let b ← f (a.read ⟨i, h⟩)
    pure <| bs b
#align array.mmap_core Array'.mmapCore

/-- Monadically map a function over the array. -/
@[inline]
def mmap {β : Type v} {m} [Monad m] (a : Array' n α) (f : α → m β) : m (Array' n β) :=
  a.mmapCore f _ (le_refl _)
#align array.mmap Array'.mmap

/-- Map a function over the array. -/
@[inline]
def map {β : Type v} (a : Array' n α) (f : α → β) : Array' n β :=
  a.map fun _ => f
#align array.map Array'.map

protected def Mem (v : α) (a : Array' n α) : Prop :=
  ∃ i : Fin n, read a i = v
#align array.mem Array'.Mem

instance : Membership α (Array' n α) :=
  ⟨Array'.Mem⟩

theorem read_mem (a : Array' n α) (i) : read a i ∈ a :=
  Exists.intro i rfl
#align array.read_mem Array'.read_mem

instance [Repr α] : Repr (Array' n α) :=
  ⟨repr ∘ toList⟩

unsafe instance [has_to_format α] : has_to_format (Array' n α) :=
  ⟨to_fmt ∘ toList⟩

unsafe instance [has_to_tactic_format α] : has_to_tactic_format (Array' n α) :=
  ⟨tactic.pp ∘ toList⟩

@[simp]
theorem read_write (a : Array' n α) (i : Fin n) (v : α) : read (write a i v) i = v :=
  DArray.read_write a i v
#align array.read_write Array'.read_write

@[simp]
theorem read_write_of_ne (a : Array' n α) {i j : Fin n} (v : α) :
    i ≠ j → read (write a i v) j = read a j :=
  DArray.read_write_of_ne a v
#align array.read_write_of_ne Array'.read_write_of_ne

def read' [Inhabited β] (a : Array' n β) (i : Nat) : β :=
  if h : i < n then a.read ⟨i, h⟩ else default
#align array.read' Array'.read'

def write' (a : Array' n α) (i : Nat) (v : α) : Array' n α :=
  if h : i < n then a.write ⟨i, h⟩ v else a
#align array.write' Array'.write'

theorem read_eq_read' [Inhabited α] (a : Array' n α) {i : Nat} (h : i < n) :
    read a ⟨i, h⟩ = read' a i := by simp [read', h]
#align array.read_eq_read' Array'.read_eq_read'

theorem write_eq_write' (a : Array' n α) {i : Nat} (h : i < n) (v : α) :
    write a ⟨i, h⟩ v = write' a i v := by simp [write', h]
#align array.write_eq_write' Array'.write_eq_write'

protected theorem ext {a b : Array' n α} (h : ∀ i, read a i = read b i) : a = b :=
  DArray.ext h
#align array.ext Array'.ext

protected theorem ext' {a b : Array' n α}
    (h : ∀ (i : Nat) (h : i < n), read a ⟨i, h⟩ = read b ⟨i, h⟩) : a = b :=
  DArray.ext' h
#align array.ext' Array'.ext'

instance [DecidableEq α] : DecidableEq (Array' n α) := by unfold Array'; infer_instance

end Array'