/-
Copyright (c) 2020 Joseph Myers. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Joseph Myers
-/
import linear_algebra.affine_space.basic
import linear_algebra.tensor_product
import linear_algebra.prod
import linear_algebra.pi
import data.set.intervals.unordered_interval

/-!
# Affine maps

This file defines affine maps.

## Main definitions

* `affine_map` is the type of affine maps between two affine spaces with the same ring `k`.  Various
  basic examples of affine maps are defined, including `const`, `id`, `line_map` and `homothety`.

## Notations

* `P1 →ᵃ[k] P2` is a notation for `affine_map k P1 P2`;
* `affine_space V P`: a localized notation for `add_torsor V P` defined in
  `linear_algebra.affine_space.basic`.

## Implementation notes

`out_param` is used in the definition of `[add_torsor V P]` to make `V` an implicit argument
(deduced from `P`) in most cases; `include V` is needed in many cases for `V`, and type classes
using it, to be added as implicit arguments to individual lemmas.  As for modules, `k` is an
explicit argument rather than implied by `P` or `V`.

This file only provides purely algebraic definitions and results. Those depending on analysis or
topology are defined elsewhere; see `analysis.normed_space.add_torsor` and
`topology.algebra.affine`.

## References

* https://en.wikipedia.org/wiki/Affine_space
* https://en.wikipedia.org/wiki/Principal_homogeneous_space
-/

open_locale affine

/-- An `affine_map k P1 P2` (notation: `P1 →ᵃ[k] P2`) is a map from `P1` to `P2` that
induces a corresponding linear map from `V1` to `V2`. -/
structure affine_map (k : Type*) {V1 : Type*} (P1 : Type*) {V2 : Type*} (P2 : Type*)
    [ring k]
    [add_comm_group V1] [module k V1] [affine_space V1 P1]
    [add_comm_group V2] [module k V2] [affine_space V2 P2] :=
(to_fun : P1 → P2)
(linear : linear_map k V1 V2)
(map_vadd' : ∀ (p : P1) (v : V1), to_fun (v +ᵥ p) =  linear v +ᵥ to_fun p)

notation P1 ` →ᵃ[`:25 k:25 `] `:0 P2:0 := affine_map k P1 P2

instance (k : Type*) {V1 : Type*} (P1 : Type*) {V2 : Type*} (P2 : Type*)
    [ring k]
    [add_comm_group V1] [module k V1] [affine_space V1 P1]
    [add_comm_group V2] [module k V2] [affine_space V2 P2]:
    has_coe_to_fun (P1 →ᵃ[k] P2) := ⟨_, affine_map.to_fun⟩

namespace linear_map

variables {k : Type*} {V₁ : Type*} {V₂ : Type*} [ring k] [add_comm_group V₁] [module k V₁]
  [add_comm_group V₂] [module k V₂] (f : V₁ →ₗ[k] V₂)

/-- Reinterpret a linear map as an affine map. -/
def to_affine_map : V₁ →ᵃ[k] V₂ :=
{ to_fun := f,
  linear := f,
  map_vadd' := λ p v, f.map_add v p }

@[simp] lemma coe_to_affine_map : ⇑f.to_affine_map = f := rfl

@[simp] lemma to_affine_map_linear : f.to_affine_map.linear = f := rfl

end linear_map

namespace affine_map

variables {k : Type*} {V1 : Type*} {P1 : Type*} {V2 : Type*} {P2 : Type*}
    {V3 : Type*} {P3 : Type*} {V4 : Type*} {P4 : Type*} [ring k]
    [add_comm_group V1] [module k V1] [affine_space V1 P1]
    [add_comm_group V2] [module k V2] [affine_space V2 P2]
    [add_comm_group V3] [module k V3] [affine_space V3 P3]
    [add_comm_group V4] [module k V4] [affine_space V4 P4]
include V1 V2

/-- Constructing an affine map and coercing back to a function
produces the same map. -/
@[simp] lemma coe_mk (f : P1 → P2) (linear add) :
  ((mk f linear add : P1 →ᵃ[k] P2) : P1 → P2) = f := rfl

/-- `to_fun` is the same as the result of coercing to a function. -/
@[simp] lemma to_fun_eq_coe (f : P1 →ᵃ[k] P2) : f.to_fun = ⇑f := rfl

/-- An affine map on the result of adding a vector to a point produces
the same result as the linear map applied to that vector, added to the
affine map applied to that point. -/
@[simp] lemma map_vadd (f : P1 →ᵃ[k] P2) (p : P1) (v : V1) :
  f (v +ᵥ p) = f.linear v +ᵥ f p := f.map_vadd' p v

/-- The linear map on the result of subtracting two points is the
result of subtracting the result of the affine map on those two
points. -/
@[simp] lemma linear_map_vsub (f : P1 →ᵃ[k] P2) (p1 p2 : P1) :
  f.linear (p1 -ᵥ p2) = f p1 -ᵥ f p2 :=
by conv_rhs { rw [←vsub_vadd p1 p2, map_vadd, vadd_vsub] }

/-- Two affine maps are equal if they coerce to the same function. -/
@[ext] lemma ext {f g : P1 →ᵃ[k] P2} (h : ∀ p, f p = g p) : f = g :=
begin
  rcases f with ⟨f, f_linear, f_add⟩,
  rcases g with ⟨g, g_linear, g_add⟩,
  have : f = g := funext h,
  subst g,
  congr' with v,
  cases (add_torsor.nonempty : nonempty P1) with p,
  apply vadd_right_cancel (f p),
  erw [← f_add, ← g_add]
end

lemma ext_iff {f g : P1 →ᵃ[k] P2} : f = g ↔ ∀ p, f p = g p := ⟨λ h p, h ▸ rfl, ext⟩

lemma coe_fn_injective : function.injective (λ (f : P1 →ᵃ[k] P2) (x : P1), f x) :=
λ f g H, ext $ congr_fun H

protected lemma congr_arg (f : P1 →ᵃ[k] P2) {x y : P1} (h : x = y) : f x = f y :=
congr_arg _ h

protected lemma congr_fun {f g : P1 →ᵃ[k] P2} (h : f = g) (x : P1) : f x = g x :=
h ▸ rfl

variables (k P1)

/-- Constant function as an `affine_map`. -/
def const (p : P2) : P1 →ᵃ[k] P2 :=
{ to_fun := function.const P1 p,
  linear := 0,
  map_vadd' := λ p v, by simp }

@[simp] lemma coe_const (p : P2) : ⇑(const k P1 p) = function.const P1 p := rfl

@[simp] lemma const_linear (p : P2) : (const k P1 p).linear = 0 := rfl

variables {k P1}

instance nonempty : nonempty (P1 →ᵃ[k] P2) :=
(add_torsor.nonempty : nonempty P2).elim $ λ p, ⟨const k P1 p⟩

/-- Construct an affine map by verifying the relation between the map and its linear part at one
base point. Namely, this function takes a map `f : P₁ → P₂`, a linear map `f' : V₁ →ₗ[k] V₂`, and
a point `p` such that for any other point `p'` we have `f p' = f' (p' -ᵥ p) +ᵥ f p`. -/
def mk' (f : P1 → P2) (f' : V1 →ₗ[k] V2) (p : P1) (h : ∀ p' : P1, f p' = f' (p' -ᵥ p) +ᵥ f p) :
  P1 →ᵃ[k] P2 :=
{ to_fun := f,
  linear := f',
  map_vadd' := λ p' v, by rw [h, h p', vadd_vsub_assoc, f'.map_add, vadd_vadd] }

@[simp] lemma coe_mk' (f : P1 → P2) (f' : V1 →ₗ[k] V2) (p h) : ⇑(mk' f f' p h) = f := rfl

@[simp] lemma mk'_linear (f : P1 → P2) (f' : V1 →ₗ[k] V2) (p h) : (mk' f f' p h).linear = f' := rfl

/-- The set of affine maps to a vector space is an additive commutative group. -/
instance : add_comm_group (P1 →ᵃ[k] V2) :=
{ zero := ⟨0, 0, λ p v, (zero_vadd _ _).symm⟩,
  add := λ f g, ⟨f + g, f.linear + g.linear, λ p v, by simp [add_add_add_comm]⟩,
  neg := λ f, ⟨-f, -f.linear, λ p v, by simp [add_comm]⟩,
  add_assoc := λ f₁ f₂ f₃, ext $ λ p, add_assoc _ _ _,
  zero_add := λ f, ext $ λ p, zero_add (f p),
  add_zero := λ f, ext $ λ p, add_zero (f p),
  add_comm := λ f g, ext $ λ p, add_comm (f p) (g p),
  add_left_neg := λ f, ext $ λ p, add_left_neg (f p) }

@[simp, norm_cast] lemma coe_zero : ⇑(0 : P1 →ᵃ[k] V2) = 0 := rfl
@[simp] lemma zero_linear : (0 : P1 →ᵃ[k] V2).linear = 0 := rfl
@[simp, norm_cast] lemma coe_add (f g : P1 →ᵃ[k] V2) : ⇑(f + g) = f + g := rfl
@[simp]
lemma add_linear (f g : P1 →ᵃ[k] V2) : (f + g).linear = f.linear + g.linear := rfl

/-- The space of affine maps from `P1` to `P2` is an affine space over the space of affine maps
from `P1` to the vector space `V2` corresponding to `P2`. -/
instance : affine_space (P1 →ᵃ[k] V2) (P1 →ᵃ[k] P2) :=
{ vadd := λ f g, ⟨λ p, f p +ᵥ g p, f.linear + g.linear, λ p v,
    by simp [vadd_vadd, add_right_comm]⟩,
  zero_vadd := λ f, ext $ λ p, zero_vadd _ (f p),
  add_vadd := λ f₁ f₂ f₃, ext $ λ p, add_vadd (f₁ p) (f₂ p) (f₃ p),
  vsub := λ f g, ⟨λ p, f p -ᵥ g p, f.linear - g.linear, λ p v,
    by simp [vsub_vadd_eq_vsub_sub, vadd_vsub_assoc, add_sub, sub_add_eq_add_sub]⟩,
  vsub_vadd' := λ f g, ext $ λ p, vsub_vadd (f p) (g p),
  vadd_vsub' := λ f g, ext $ λ p, vadd_vsub (f p) (g p) }

@[simp] lemma vadd_apply (f : P1 →ᵃ[k] V2) (g : P1 →ᵃ[k] P2) (p : P1) :
  (f +ᵥ g) p = f p +ᵥ g p :=
rfl

@[simp] lemma vsub_apply (f g : P1 →ᵃ[k] P2) (p : P1) :
  (f -ᵥ g : P1 →ᵃ[k] V2) p = f p -ᵥ g p :=
rfl

/-- `prod.fst` as an `affine_map`. -/
def fst : (P1 × P2) →ᵃ[k] P1 :=
{ to_fun := prod.fst,
  linear := linear_map.fst k V1 V2,
  map_vadd' := λ _ _, rfl }

@[simp] lemma coe_fst : ⇑(fst : (P1 × P2) →ᵃ[k] P1) = prod.fst := rfl
@[simp] lemma fst_linear : (fst : (P1 × P2) →ᵃ[k] P1).linear = linear_map.fst k V1 V2 := rfl

/-- `prod.snd` as an `affine_map`. -/
def snd : (P1 × P2) →ᵃ[k] P2 :=
{ to_fun := prod.snd,
  linear := linear_map.snd k V1 V2,
  map_vadd' := λ _ _, rfl }

@[simp] lemma coe_snd : ⇑(snd : (P1 × P2) →ᵃ[k] P2) = prod.snd := rfl
@[simp] lemma snd_linear : (snd : (P1 × P2) →ᵃ[k] P2).linear = linear_map.snd k V1 V2 := rfl

variables (k P1)
omit V2

/-- Identity map as an affine map. -/
def id : P1 →ᵃ[k] P1 :=
{ to_fun := id,
  linear := linear_map.id,
  map_vadd' := λ p v, rfl }

/-- The identity affine map acts as the identity. -/
@[simp] lemma coe_id : ⇑(id k P1) = _root_.id := rfl

@[simp] lemma id_linear : (id k P1).linear = linear_map.id := rfl

variable {P1}

/-- The identity affine map acts as the identity. -/
lemma id_apply (p : P1) : id k P1 p = p := rfl

variables {k P1}

instance : inhabited (P1 →ᵃ[k] P1) := ⟨id k P1⟩

include V2 V3

/-- Composition of affine maps. -/
def comp (f : P2 →ᵃ[k] P3) (g : P1 →ᵃ[k] P2) : P1 →ᵃ[k] P3 :=
{ to_fun := f ∘ g,
  linear := f.linear.comp g.linear,
  map_vadd' := begin
    intros p v,
    rw [function.comp_app, g.map_vadd, f.map_vadd],
    refl
  end }

/-- Composition of affine maps acts as applying the two functions. -/
@[simp] lemma coe_comp (f : P2 →ᵃ[k] P3) (g : P1 →ᵃ[k] P2) :
  ⇑(f.comp g) = f ∘ g := rfl

/-- Composition of affine maps acts as applying the two functions. -/
lemma comp_apply (f : P2 →ᵃ[k] P3) (g : P1 →ᵃ[k] P2) (p : P1) :
  f.comp g p = f (g p) := rfl

omit V3

@[simp] lemma comp_id (f : P1 →ᵃ[k] P2) : f.comp (id k P1) = f := ext $ λ p, rfl

@[simp] lemma id_comp (f : P1 →ᵃ[k] P2) : (id k P2).comp f = f := ext $ λ p, rfl

include V3 V4

lemma comp_assoc (f₃₄ : P3 →ᵃ[k] P4) (f₂₃ : P2 →ᵃ[k] P3) (f₁₂ : P1 →ᵃ[k] P2) :
  (f₃₄.comp f₂₃).comp f₁₂ = f₃₄.comp (f₂₃.comp f₁₂) :=
rfl

omit V2 V3 V4

instance : monoid (P1 →ᵃ[k] P1) :=
{ one := id k P1,
  mul := comp,
  one_mul := id_comp,
  mul_one := comp_id,
  mul_assoc := comp_assoc }

@[simp] lemma coe_mul (f g : P1 →ᵃ[k] P1) : ⇑(f * g) = f ∘ g := rfl
@[simp] lemma coe_one : ⇑(1 : P1 →ᵃ[k] P1) = _root_.id := rfl

/-! ### Definition of `affine_map.line_map` and lemmas about it -/

/-- The affine map from `k` to `P1` sending `0` to `p₀` and `1` to `p₁`. -/
def line_map (p₀ p₁ : P1) : k →ᵃ[k] P1 :=
((linear_map.id : k →ₗ[k] k).smul_right (p₁ -ᵥ p₀)).to_affine_map +ᵥ const k k p₀

lemma coe_line_map (p₀ p₁ : P1) : (line_map p₀ p₁ : k → P1) = λ c, c • (p₁ -ᵥ p₀) +ᵥ p₀ := rfl

lemma line_map_apply (p₀ p₁ : P1) (c : k) : line_map p₀ p₁ c = c • (p₁ -ᵥ p₀) +ᵥ p₀ := rfl

lemma line_map_apply_module' (p₀ p₁ : V1) (c : k) : line_map p₀ p₁ c = c • (p₁ - p₀) + p₀ := rfl

omit V1

lemma line_map_apply_ring' (a b c : k) : line_map a b c = c * (b - a) + a :=
rfl

lemma line_map_apply_ring (a b c : k) : line_map a b c = (1 - c) * a + c * b :=
line_map_apply_module a b c

include V1

lemma line_map_vadd_apply (p : P1) (v : V1) (c : k) :
  line_map p (v +ᵥ p) c = c • v +ᵥ p :=
by rw [line_map_apply, vadd_vsub]

@[simp] lemma line_map_linear (p₀ p₁ : P1) :
  (line_map p₀ p₁ : k →ᵃ[k] P1).linear = linear_map.id.smul_right (p₁ -ᵥ p₀) :=
add_zero _

lemma line_map_same_apply (p : P1) (c : k) : line_map p p c = p := by simp [line_map_apply]

@[simp] lemma line_map_same (p : P1) : line_map p p = const k k p :=
ext $ line_map_same_apply p

@[simp] lemma line_map_apply_zero (p₀ p₁ : P1) : line_map p₀ p₁ (0:k) = p₀ :=
by simp [line_map_apply]

@[simp] lemma line_map_apply_one (p₀ p₁ : P1) : line_map p₀ p₁ (1:k) = p₁ :=
by simp [line_map_apply]

include V2

@[simp] lemma apply_line_map (f : P1 →ᵃ[k] P2) (p₀ p₁ : P1) (c : k) :
  f (line_map p₀ p₁ c) = line_map (f p₀) (f p₁) c :=
by simp [line_map_apply]

@[simp] lemma comp_line_map (f : P1 →ᵃ[k] P2) (p₀ p₁ : P1) :
  f.comp (line_map p₀ p₁) = line_map (f p₀) (f p₁) :=
ext $ f.apply_line_map p₀ p₁

@[simp] lemma fst_line_map (p₀ p₁ : P1 × P2) (c : k) :
  (line_map p₀ p₁ c).1 = line_map p₀.1 p₁.1 c :=
fst.apply_line_map p₀ p₁ c

@[simp] lemma snd_line_map (p₀ p₁ : P1 × P2) (c : k) :
  (line_map p₀ p₁ c).2 = line_map p₀.2 p₁.2 c :=
snd.apply_line_map p₀ p₁ c

omit V2

lemma line_map_symm (p₀ p₁ : P1) :
  line_map p₀ p₁ = (line_map p₁ p₀).comp (line_map (1:k) (0:k)) :=
by { rw [comp_line_map], simp }

lemma line_map_apply_one_sub (p₀ p₁ : P1) (c : k) :
  line_map p₀ p₁ (1 - c) = line_map p₁ p₀ c :=
by { rw [line_map_symm p₀, comp_apply], congr, simp [line_map_apply] }

@[simp] lemma line_map_vsub_left (p₀ p₁ : P1) (c : k) :
  line_map p₀ p₁ c -ᵥ p₀ = c • (p₁ -ᵥ p₀) :=
vadd_vsub _ _

@[simp] lemma left_vsub_line_map (p₀ p₁ : P1) (c : k) :
  p₀ -ᵥ line_map p₀ p₁ c = c • (p₀ -ᵥ p₁) :=
by rw [← neg_vsub_eq_vsub_rev, line_map_vsub_left, ← smul_neg, neg_vsub_eq_vsub_rev]

@[simp] lemma line_map_vsub_right (p₀ p₁ : P1) (c : k) :
  line_map p₀ p₁ c -ᵥ p₁ = (1 - c) • (p₀ -ᵥ p₁) :=
by rw [← line_map_apply_one_sub, line_map_vsub_left]

@[simp] lemma right_vsub_line_map (p₀ p₁ : P1) (c : k) :
  p₁ -ᵥ line_map p₀ p₁ c = (1 - c) • (p₁ -ᵥ p₀) :=
by rw [← line_map_apply_one_sub, left_vsub_line_map]

lemma line_map_vadd_line_map (v₁ v₂ : V1) (p₁ p₂ : P1) (c : k) :
  line_map v₁ v₂ c +ᵥ line_map p₁ p₂ c = line_map (v₁ +ᵥ p₁) (v₂ +ᵥ p₂) c :=
((fst : V1 × P1 →ᵃ[k] V1) +ᵥ snd).apply_line_map  (v₁, p₁) (v₂, p₂) c

lemma line_map_vsub_line_map (p₁ p₂ p₃ p₄ : P1) (c : k) :
  line_map p₁ p₂ c -ᵥ line_map p₃ p₄ c = line_map (p₁ -ᵥ p₃) (p₂ -ᵥ p₄) c :=
-- Why Lean fails to find this instance without a hint?
by letI : affine_space (V1 × V1) (P1 × P1) := prod.add_torsor; exact
((fst : P1 × P1 →ᵃ[k] P1) -ᵥ (snd : P1 × P1 →ᵃ[k] P1)).apply_line_map (_, _) (_, _) c

/-- Decomposition of an affine map in the special case when the point space and vector space
are the same. -/
lemma decomp (f : V1 →ᵃ[k] V2) : (f : V1 → V2) = f.linear + (λ z, f 0) :=
begin
  ext x,
  calc
    f x = f.linear x +ᵥ f 0                      : by simp [← f.map_vadd]
    ... = (f.linear.to_fun + λ (z : V1), f 0) x  : by simp
end

/-- Decomposition of an affine map in the special case when the point space and vector space
are the same. -/
lemma decomp' (f : V1 →ᵃ[k] V2) : (f.linear : V1 → V2) = f - (λ z, f 0) :=
by rw decomp ; simp only [linear_map.map_zero, pi.add_apply, add_sub_cancel, zero_add]

omit V1

lemma image_interval {k : Type*} [linear_ordered_field k] (f : k →ᵃ[k] k)
  (a b : k) :
  f '' set.interval a b = set.interval (f a) (f b) :=
begin
  have : ⇑f = (λ x, x + f 0) ∘ λ x, x * (f 1 - f 0),
  { ext x,
    change f x = x • (f 1 -ᵥ f 0) +ᵥ f 0,
    rw [← f.linear_map_vsub, ← f.linear.map_smul, ← f.map_vadd],
    simp only [vsub_eq_sub, add_zero, mul_one, vadd_eq_add, sub_zero, smul_eq_mul] },
  rw [this, set.image_comp],
  simp only [set.image_add_const_interval, set.image_mul_const_interval]
end

section

variables {ι : Type*} {V : Π i : ι, Type*} {P : Π i : ι, Type*} [Π i, add_comm_group (V i)]
  [Π i, module k (V i)] [Π i, add_torsor (V i) (P i)]

include V

/-- Evaluation at a point as an affine map. -/
def proj (i : ι) : (Π i : ι, P i) →ᵃ[k] P i :=
{ to_fun := λ f, f i,
  linear := @linear_map.proj k ι _ V _ _ i,
  map_vadd' := λ p v, rfl }

@[simp] lemma proj_apply (i : ι) (f : Π i, P i) : @proj k _ ι V P _ _ _ i f = f i := rfl

@[simp] lemma proj_linear (i : ι) :
   (@proj k _ ι V P _ _ _ i).linear = @linear_map.proj k ι _ V _ _ i := rfl

lemma pi_line_map_apply (f g : Π i, P i) (c : k) (i : ι) :
  line_map f g c i = line_map (f i) (g i) c :=
(proj i : (Π i, P i) →ᵃ[k] P i).apply_line_map f g c

end

end affine_map

namespace affine_map

variables {k : Type*} {V1 : Type*} {P1 : Type*} {V2 : Type*} [comm_ring k]
    [add_comm_group V1] [module k V1] [affine_space V1 P1] [add_comm_group V2] [module k V2]
include V1

/-- If `k` is a commutative ring, then the set of affine maps with codomain in a `k`-module
is a `k`-module. -/
instance : module k (P1 →ᵃ[k] V2) :=
{ smul := λ c f, ⟨c • f, c • f.linear, λ p v, by simp [smul_add]⟩,
  one_smul := λ f, ext $ λ p, one_smul _ _,
  mul_smul := λ c₁ c₂ f, ext $ λ p, mul_smul _ _ _,
  smul_add := λ c f g, ext $ λ p, smul_add _ _ _,
  smul_zero := λ c, ext $ λ p, smul_zero _,
  add_smul := λ c₁ c₂ f, ext $ λ p, add_smul _ _ _,
  zero_smul := λ f, ext $ λ p, zero_smul _ _ }

@[simp] lemma coe_smul (c : k) (f : P1 →ᵃ[k] V2) : ⇑(c • f) = c • f := rfl

/-- `homothety c r` is the homothety about `c` with scale factor `r`. -/
def homothety (c : P1) (r : k) : P1 →ᵃ[k] P1 :=
r • (id k P1 -ᵥ const k P1 c) +ᵥ const k P1 c

lemma homothety_def (c : P1) (r : k) :
  homothety c r = r • (id k P1 -ᵥ const k P1 c) +ᵥ const k P1 c :=
rfl

lemma homothety_apply (c : P1) (r : k) (p : P1) : homothety c r p = r • (p -ᵥ c : V1) +ᵥ c := rfl

lemma homothety_eq_line_map (c : P1) (r : k) (p : P1) : homothety c r p = line_map c p r := rfl

@[simp] lemma homothety_one (c : P1) : homothety c (1:k) = id k P1 :=
by { ext p, simp [homothety_apply] }

lemma homothety_mul (c : P1) (r₁ r₂ : k) :
  homothety c (r₁ * r₂) = (homothety c r₁).comp (homothety c r₂) :=
by { ext p, simp [homothety_apply, mul_smul] }

@[simp] lemma homothety_zero (c : P1) : homothety c (0:k) = const k P1 c :=
by { ext p, simp [homothety_apply] }

@[simp] lemma homothety_add (c : P1) (r₁ r₂ : k) :
  homothety c (r₁ + r₂) = r₁ • (id k P1 -ᵥ const k P1 c) +ᵥ homothety c r₂ :=
by simp only [homothety_def, add_smul, vadd_vadd]

/-- `homothety` as a multiplicative monoid homomorphism. -/
def homothety_hom (c : P1) : k →* P1 →ᵃ[k] P1 :=
⟨homothety c, homothety_one c, homothety_mul c⟩

@[simp] lemma coe_homothety_hom (c : P1) : ⇑(homothety_hom c : k →* _) = homothety c := rfl

/-- `homothety` as an affine map. -/
def homothety_affine (c : P1) : k →ᵃ[k] (P1 →ᵃ[k] P1) :=
⟨homothety c, (linear_map.lsmul k _).flip (id k P1 -ᵥ const k P1 c),
  function.swap (homothety_add c)⟩

@[simp] lemma coe_homothety_affine (c : P1) :
  ⇑(homothety_affine c : k →ᵃ[k] _) = homothety c :=
rfl

end affine_map


example : (p → q → False) ↔ (¬ p ∨ ¬ q) := by
  apply Iff.intro
  . intro h
    byCases hp:p <;> byCases hq:q
    . specialize h hp hq; contradiction
    . exact Or.inr hq
    . exact Or.inl hp
    . exact Or.inr hq
  . intro
    | Or.inl hnp => intros; contradiction
    | Or.inr hnq => intros; contradiction


/-
Copyright (c) 2022 David Kurniadi Angdinata. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: David Kurniadi Angdinata

! This file was ported from Lean 3 source module ring_theory.dedekind_domain.S_integer
! leanprover-community/mathlib commit 00ab77614e085c9ef49479babba1a7d826d3232e
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.RingTheory.DedekindDomain.AdicValuation

/-!
# `S`-integers and `S`-units of fraction fields of Dedekind domains

Let `K` be the field of fractions of a Dedekind domain `R`, and let `S` be a set of prime ideals in
the height one spectrum of `R`. An `S`-integer of `K` is defined to have `v`-adic valuation at most
one for all primes ideals `v` away from `S`, whereas an `S`-unit of `Kˣ` is defined to have `v`-adic
valuation exactly one for all prime ideals `v` away from `S`.

This file defines the subalgebra of `S`-integers of `K` and the subgroup of `S`-units of `Kˣ`, where
`K` can be specialised to the case of a number field or a function field separately.

## Main definitions

 * `set.integer`: `S`-integers.
 * `set.unit`: `S`-units.
 * TODO: localised notation for `S`-integers.

## Main statements

 * `set.unit_equiv_units_integer`: `S`-units are units of `S`-integers.
 * TODO: proof that `S`-units is the kernel of a map to a product.
 * TODO: proof that `∅`-integers is the usual ring of integers.
 * TODO: finite generation of `S`-units and Dirichlet's `S`-unit theorem.

## References

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

## Tags

S integer, S-integer, S unit, S-unit
-/

namespace Set

noncomputable section

open IsDedekindDomain

open nonZeroDivisors

universe u v

variable {R : Type u} [CommRing R] [IsDomain R] [IsDedekindDomain R]
  (S : Set <| HeightOneSpectrum R) (K : Type v) [Field K] [Algebra R K] [IsFractionRing R K]

/-! ## `S`-integers -/

/- ./././Mathport/Syntax/Translate/Basic.lean:635:2: warning: expanding binder collection (v «expr ∉ » S) -/
/- ./././Mathport/Syntax/Translate/Basic.lean:635:2: warning: expanding binder collection (v «expr ∉ » S) -/
/-- The `R`-subalgebra of `S`-integers of `K`. -/
@[simps]
def integer : Subalgebra R K :=
  {
    (⨅ (v) (_ : v ∉ S), (v : HeightOneSpectrum R).Valuation.ValuationSubring.toSubring).copy
        { x : K | ∀ (v) (_ : v ∉ S), (v : HeightOneSpectrum R).Valuation x ≤ 1 } <|
      Set.ext fun _ => by simpa only [SetLike.mem_coe, Subring.mem_infᵢ] with
    algebraMap_mem' := fun x v _ => v.valuation_le_one x }
#align set.integer Set.integer

/- ./././Mathport/Syntax/Translate/Basic.lean:635:2: warning: expanding binder collection (v «expr ∉ » S) -/
theorem integer_eq :
    (S.integer K).toSubring =
      ⨅ (v) (_ : v ∉ S), (v : HeightOneSpectrum R).Valuation.ValuationSubring.toSubring :=
  SetLike.ext' <| by simpa only [integer, Subring.copy_eq]
#align set.integer_eq Set.integer_eq

theorem integer_valuation_le_one (x : S.integer K) {v : HeightOneSpectrum R} (hv : v ∉ S) :
    v.Valuation (x : K) ≤ 1 :=
  x.property v hv
#align set.integer_valuation_le_one Set.integer_valuation_le_one

/-! ## `S`-units -/

/- ./././Mathport/Syntax/Translate/Basic.lean:635:2: warning: expanding binder collection (v «expr ∉ » S) -/
/- ./././Mathport/Syntax/Translate/Basic.lean:635:2: warning: expanding binder collection (v «expr ∉ » S) -/
/-- The subgroup of `S`-units of `Kˣ`. -/
@[simps]
def unit : Subgroup Kˣ :=
  (⨅ (v) (_ : v ∉ S), (v : HeightOneSpectrum R).Valuation.ValuationSubring.unitGroup).copy
      { x : Kˣ | ∀ (v) (_ : v ∉ S), (v : HeightOneSpectrum R).Valuation (x : K) = 1 } <|
    Set.ext fun _ => by simpa only [SetLike.mem_coe, Subgroup.mem_infᵢ, Valuation.mem_unitGroup_iff]
#align set.unit Set.unit

/- ./././Mathport/Syntax/Translate/Basic.lean:635:2: warning: expanding binder collection (v «expr ∉ » S) -/
theorem unit_eq :
    S.Unit K = ⨅ (v) (_ : v ∉ S), (v : HeightOneSpectrum R).Valuation.ValuationSubring.unitGroup :=
  Subgroup.copy_eq _ _ _
#align set.unit_eq Set.unit_eq

theorem unit_valuation_eq_one (x : S.Unit K) {v : HeightOneSpectrum R} (hv : v ∉ S) :
    v.Valuation (x : K) = 1 :=
  x.property v hv
#align set.unit_valuation_eq_one Set.unit_valuation_eq_one

/-- The group of `S`-units is the group of units of the ring of `S`-integers. -/
@[simps]
def unitEquivUnitsInteger : S.Unit K ≃* (S.integer K)ˣ
    where
  toFun x :=
    ⟨⟨x, fun v hv => (x.property v hv).le⟩, ⟨↑x⁻¹, fun v hv => (x⁻¹.property v hv).le⟩,
      Subtype.ext x.val.val_inv, Subtype.ext x.val.inv_val⟩
  invFun x :=
    ⟨Units.mk0 x fun hx => x.NeZero ((Subring.coe_eq_zero_iff _).mp hx), fun v hv =>
      eq_one_of_one_le_mul_left (x.val.property v hv) (x.inv.property v hv) <|
        Eq.ge <| by
          rw [← map_mul]
          convert v.valuation.map_one
          exact subtype.mk_eq_mk.mp x.val_inv⟩
  left_inv _ := by
    ext
    rfl
  right_inv _ := by
    ext
    rfl
  map_mul' _ _ := by
    ext
    rfl
#align set.unit_equiv_units_integer Set.unitEquivUnitsInteger

end Set


/-
The aim is to create a generic tactic that can prove the following theorem:
theorem main {α : Type*} (a : α) (P : α → Prop) (h : P a) : ∃ x, P x
-/

open tactic

meta def conclusion : expr → tactic expr
| `(∃ _, %%t) := conclusion t
| t           := return t

meta def depth : expr → tactic nat
| `(∃ _, %%t) := do t ← depth t, return (t + 1)
| t           := return 0

meta structure match_info : Type :=
(limit : ℕ) (mapping : ℕ → option expr)

meta def merge : match_info → match_info → tactic match_info
| (match_info.mk 0 _)              m                                := return m
| m                                (match_info.mk 0 _)              := return m
| (match_info.mk (nat.succ n₁) f₁) (match_info.mk (nat.succ n₂) f₂) :=
  let n := min n₁ n₂ in
    if (f₁ n = f₂ n ∨ f₁ n = none ∨ f₂ n = none)
      then do m ← merge {limit := n₁, mapping := f₁}
                        {limit := n₂, mapping := f₂},
        return {limit   := m.limit + 1,
                mapping := λ k, if k ≠ n then m.mapping k else
                                if f₁ n ≠ none then f₁ n else f₂ n}
      else failed

meta def match_expr : expr → expr → tactic match_info
| (expr.app a₁ a₂) (expr.app b₁ b₂) :=
  do m₁ ← match_expr a₁ b₁,
     m₂ ← match_expr a₂ b₂,
     merge m₁ m₂
| (expr.var n)          t                     :=
  return {limit := n + 1, mapping := λ m, if m = n then t else none }
| t₁                    t₂                    :=
  if t₁ = t₂ then return {limit := 0, mapping := λ _, none} else failed

meta def find_element_of_type (t : expr) : tactic expr :=
-- searches for an element of given type in the local context.
-- Fails if it can't find one.
do l ← local_context,
  first $ l.map (λ h,
    (infer_type h >>= (unify t) >> return h))

meta def build_term (m : match_info) : ℕ → expr → expr → tactic expr
/- arguments to build_term
  d : ℕ the depth, how many nested ∃ there are
  h : expr the term built so far
  t : expr the type of the term we are trying to build
-/
| 0            h t := return h
| (nat.succ n) h t := do match t with
  | `(Exists %%motive) :=
  do e ← match m.mapping n with
    | (some e) := return e
    | none     := match motive with
      | `(λ _ : %%search_type, _) := find_element_of_type search_type
      | _ := failed end end,
  previous_t ← whnf (expr.app motive e),
  term ← build_term n h previous_t,
  a ← to_expr ```(@Exists.intro _ %%motive %%e %%term),
  return a
  | _ := failed
  end

meta def main_tactic : tactic unit :=
do t ← target,
  c ← conclusion t,
  d ← depth t,
  l ← local_context,
  first $ l.map (λ h,
    do ht ← infer_type h >>= whnf,
    m ← match_expr c ht,
    answer ← (build_term m d h t),
    exact answer)

meta def tactic.interactive.main_tactic : tactic unit := main_tactic

example {α : Type*} (a : α) (P : α → Prop) (h : P a) : ∃ x, P x :=
by main_tactic

example {α : Type*} (a b: α) (P : α → α → Prop)
(h : P a b) : ∃ x y, P x y :=
by main_tactic

example {α : Type*} (a b c: α) (P : α → α → Prop) (f : α → α)
(h₁ : P (f a) b) (h₂ : P (f c) (f a)) (h₃ : P b c) : ∃ x y, P (f x) y :=
by main_tactic

example {α : Type*} (a : α) (P : Prop) (h : P) : ∃ (z : α), P :=
by main_tactic

example {α : Type*} (a b: α) (P : α → α → Prop)
(h : P a b) : ∃ x y, ∃ (z : α), P x y :=
by main_tactic


/-
Copyright (c) 2021 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import category_theory.preadditive.additive_functor
import category_theory.linear.basic

/-!
# Linear Functors

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

An additive functor between two `R`-linear categories is called *linear*
if the induced map on hom types is a morphism of `R`-modules.

# Implementation details

`functor.linear` is a `Prop`-valued class, defined by saying that
for every two objects `X` and `Y`, the map
`F.map : (X ⟶ Y) → (F.obj X ⟶ F.obj Y)` is a morphism of `R`-modules.

-/

namespace category_theory

variables (R : Type*) [semiring R]

/-- An additive functor `F` is `R`-linear provided `F.map` is an `R`-module morphism. -/
class functor.linear {C D : Type*} [category C] [category D]
  [preadditive C] [preadditive D] [linear R C] [linear R D] (F : C ⥤ D) [F.additive] : Prop :=
(map_smul' : Π {X Y : C} {f : X ⟶ Y} {r : R}, F.map (r • f) = r • F.map f . obviously)

section linear

namespace functor

section
variables {R} {C D : Type*} [category C] [category D]
  [preadditive C] [preadditive D] [category_theory.linear R C] [category_theory.linear R D]
  (F : C ⥤ D) [additive F] [linear R F]

@[simp]
lemma map_smul {X Y : C} (r : R) (f : X ⟶ Y) : F.map (r • f) = r • F.map f :=
functor.linear.map_smul'

instance : linear R (𝟭 C) :=
{}

instance {E : Type*} [category E] [preadditive E] [category_theory.linear R E]
  (G : D ⥤ E) [additive G] [linear R G]:
  linear R (F ⋙ G) :=
{}

variables (R)

/-- `F.map_linear_map` is an `R`-linear map whose underlying function is `F.map`. -/
@[simps]
def map_linear_map {X Y : C} : (X ⟶ Y) →ₗ[R] (F.obj X ⟶ F.obj Y) :=
{ map_smul' := λ r f, F.map_smul r f,
  ..F.map_add_hom }

lemma coe_map_linear_map {X Y : C} : ⇑(F.map_linear_map R : (X ⟶ Y) →ₗ[R] _) = @map C _ D _ F X Y :=
rfl

end

section induced_category
variables {C : Type*} {D : Type*} [category D] [preadditive D] [category_theory.linear R D]
   (F : C → D)

instance induced_functor_linear : functor.linear R (induced_functor F) := {}

end induced_category

instance full_subcategory_inclusion_linear
  {C : Type*} [category C] [preadditive C] [category_theory.linear R C] (Z : C → Prop) :
  (full_subcategory_inclusion Z).linear R := {}

section

variables {R} {C D : Type*} [category C] [category D]
  [preadditive C] [preadditive D]
  (F : C ⥤ D) [additive F]

instance nat_linear : F.linear ℕ :=
{ map_smul' := λ X Y f r, F.map_add_hom.map_nsmul f r, }

instance int_linear : F.linear ℤ :=
{ map_smul' := λ X Y f r, (F.map_add_hom : (X ⟶ Y) →+ (F.obj X ⟶ F.obj Y)).map_zsmul f r, }

variables [category_theory.linear ℚ C] [category_theory.linear ℚ D]

instance rat_linear : F.linear ℚ :=
{ map_smul' := λ X Y f r, F.map_add_hom.to_rat_linear_map.map_smul r f, }

end

end functor

namespace equivalence

variables {C D : Type*} [category C] [category D]
  [preadditive C] [linear R C] [preadditive D] [linear R D]

instance inverse_linear (e : C ≌ D) [e.functor.additive] [e.functor.linear R] :
  e.inverse.linear R :=
{ map_smul' := λ X Y r f, by { apply e.functor.map_injective, simp, }, }

end equivalence

end linear

end category_theory


/-
Copyright (c) 2020 Scott Morrison, Bhavik Mehta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison, Bhavik Mehta
-/
import category_theory.limits.shapes.products
import category_theory.limits.preserves.basic

/-!
# Preserving products

Constructions to relate the notions of preserving products and reflecting products
to concrete fans.

In particular, we show that `pi_comparison G f` is an isomorphism iff `G` preserves
the limit of `f`.
-/

noncomputable theory

universes v u₁ u₂

open category_theory category_theory.category category_theory.limits

variables {C : Type u₁} [category.{v} C]
variables {D : Type u₂} [category.{v} D]
variables (G : C ⥤ D)

namespace category_theory.limits

variables {J : Type v} (f : J → C)

/--
The map of a fan is a limit iff the fan consisting of the mapped morphisms is a limit. This
essentially lets us commute `fan.mk` with `functor.map_cone`.
-/
def is_limit_map_cone_fan_mk_equiv {P : C} (g : Π j, P ⟶ f j) :
  is_limit (G.map_cone (fan.mk P g)) ≃
  is_limit (fan.mk _ (λ j, G.map (g j)) : fan (λ j, G.obj (f j))) :=
begin
  refine (is_limit.postcompose_hom_equiv _ _).symm.trans (is_limit.equiv_iso_limit _),
  refine discrete.nat_iso (λ j, iso.refl (G.obj (f j))),
  refine cones.ext (iso.refl _) (λ j, by { dsimp, simp }),
end

/-- The property of preserving products expressed in terms of fans. -/
def is_limit_fan_mk_obj_of_is_limit [preserves_limit (discrete.functor f) G]
  {P : C} (g : Π j, P ⟶ f j) (t : is_limit (fan.mk _ g)) :
  is_limit (fan.mk (G.obj P) (λ j, G.map (g j)) : fan (λ j, G.obj (f j))) :=
is_limit_map_cone_fan_mk_equiv _ _ _ (preserves_limit.preserves t)

/-- The property of reflecting products expressed in terms of fans. -/
def is_limit_of_is_limit_fan_mk_obj [reflects_limit (discrete.functor f) G]
  {P : C} (g : Π j, P ⟶ f j) (t : is_limit (fan.mk _ (λ j, G.map (g j)) : fan (λ j, G.obj (f j)))) :
  is_limit (fan.mk P g) :=
reflects_limit.reflects ((is_limit_map_cone_fan_mk_equiv _ _ _).symm t)

section

variables [has_product f]

/--
If `G` preserves products and `C` has them, then the fan constructed of the mapped projection of a
product is a limit.
-/
def is_limit_of_has_product_of_preserves_limit [preserves_limit (discrete.functor f) G] :
  is_limit (fan.mk _ (λ (j : J), G.map (pi.π f j)) : fan (λ j, G.obj (f j))) :=
is_limit_fan_mk_obj_of_is_limit G f _ (product_is_product _)

variables [has_product (λ (j : J), G.obj (f j))]

/-- If `pi_comparison G f` is an isomorphism, then `G` preserves the limit of `f`. -/
def preserves_product.of_iso_comparison [i : is_iso (pi_comparison G f)] :
  preserves_limit (discrete.functor f) G :=
begin
  apply preserves_limit_of_preserves_limit_cone (product_is_product f),
  apply (is_limit_map_cone_fan_mk_equiv _ _ _).symm _,
  apply is_limit.of_point_iso (limit.is_limit (discrete.functor (λ (j : J), G.obj (f j)))),
  apply i,
end

variable [preserves_limit (discrete.functor f) G]

/--
If `G` preserves limits, we have an isomorphism from the image of a product to the product of the
images.
-/
def preserves_product.iso : G.obj (∏ f) ≅ ∏ (λ j, G.obj (f j)) :=
is_limit.cone_point_unique_up_to_iso
  (is_limit_of_has_product_of_preserves_limit G f)
  (limit.is_limit _)

@[simp]
lemma preserves_product.iso_hom : (preserves_product.iso G f).hom = pi_comparison G f :=
rfl

instance : is_iso (pi_comparison G f) :=
begin
  rw ← preserves_product.iso_hom,
  apply_instance,
end

end

/--
The map of a cofan is a colimit iff the cofan consisting of the mapped morphisms is a colimit.
This essentially lets us commute `cofan.mk` with `functor.map_cocone`.
-/
def is_colimit_map_cocone_cofan_mk_equiv {P : C} (g : Π j, f j ⟶ P) :
  is_colimit (G.map_cocone (cofan.mk P g)) ≃
  is_colimit (cofan.mk _ (λ j, G.map (g j)) : cofan (λ j, G.obj (f j))) :=
begin
  refine (is_colimit.precompose_hom_equiv _ _).symm.trans (is_colimit.equiv_iso_colimit _),
  refine discrete.nat_iso (λ j, iso.refl (G.obj (f j))),
  refine cocones.ext (iso.refl _) (λ j, by { dsimp, simp }),
end

/-- The property of preserving coproducts expressed in terms of cofans. -/
def is_colimit_cofan_mk_obj_of_is_colimit [preserves_colimit (discrete.functor f) G]
  {P : C} (g : Π j, f j ⟶ P) (t : is_colimit (cofan.mk _ g)) :
  is_colimit (cofan.mk (G.obj P) (λ j, G.map (g j)) : cofan (λ j, G.obj (f j))) :=
is_colimit_map_cocone_cofan_mk_equiv _ _ _ (preserves_colimit.preserves t)

/-- The property of reflecting coproducts expressed in terms of cofans. -/
def is_colimit_of_is_colimit_cofan_mk_obj [reflects_colimit (discrete.functor f) G]
  {P : C} (g : Π j, f j ⟶ P)
  (t : is_colimit (cofan.mk _ (λ j, G.map (g j)) : cofan (λ j, G.obj (f j)))) :
  is_colimit (cofan.mk P g) :=
reflects_colimit.reflects ((is_colimit_map_cocone_cofan_mk_equiv _ _ _).symm t)

section

variables [has_coproduct f]

/--
If `G` preserves coproducts and `C` has them,
then the cofan constructed of the mapped inclusion of a coproduct is a colimit.
-/
def is_colimit_of_has_coproduct_of_preserves_colimit [preserves_colimit (discrete.functor f) G] :
  is_colimit (cofan.mk _ (λ (j : J), G.map (sigma.ι f j)) : cofan (λ j, G.obj (f j))) :=
is_colimit_cofan_mk_obj_of_is_colimit G f _ (coproduct_is_coproduct _)

variables [has_coproduct (λ (j : J), G.obj (f j))]

/-- If `sigma_comparison G f` is an isomorphism, then `G` preserves the colimit of `f`. -/
def preserves_coproduct.of_iso_comparison [i : is_iso (sigma_comparison G f)] :
  preserves_colimit (discrete.functor f) G :=
begin
  apply preserves_colimit_of_preserves_colimit_cocone (coproduct_is_coproduct f),
  apply (is_colimit_map_cocone_cofan_mk_equiv _ _ _).symm _,
  apply is_colimit.of_point_iso (colimit.is_colimit (discrete.functor (λ (j : J), G.obj (f j)))),
  apply i,
end

variable [preserves_colimit (discrete.functor f) G]

/--
If `G` preserves colimits,
we have an isomorphism from the image of a coproduct to the coproduct of the images.
-/
def preserves_coproduct.iso : G.obj (∐ f) ≅ ∐ (λ j, G.obj (f j)) :=
is_colimit.cocone_point_unique_up_to_iso
  (is_colimit_of_has_coproduct_of_preserves_colimit G f)
  (colimit.is_colimit _)

@[simp]
lemma preserves_coproduct.inv_hom : (preserves_coproduct.iso G f).inv = sigma_comparison G f :=
rfl

instance : is_iso (sigma_comparison G f) :=
begin
  rw ← preserves_coproduct.inv_hom,
  apply_instance,
end

end

end category_theory.limits


namespace Ex1
def f (x : Nat) : Nat := by
  cases x with
  | zero => exact 1
  | succ x' =>
    apply Nat.mul 2
    exact f x'

#eval f 10

example : f x.succ = 2 * f x := rfl
end Ex1

namespace Ex2
inductive Foo where
  | mk : List Foo → Foo

mutual
def g (x : Foo) : Nat := by
  cases x with
  | mk xs => exact gs xs

def gs (xs : List Foo) : Nat := by
  cases xs with
  | nil => exact 1
  | cons x xs =>
    apply Nat.add
    exact g x
    exact gs xs
end
end Ex2

namespace Ex3

inductive Foo where
  | a | b | c
  | pair: Foo × Foo → Foo

def Foo.deq (a b : Foo) : Decidable (a = b) := by
  cases a <;> cases b
  any_goals apply isFalse Foo.noConfusion
  any_goals apply isTrue rfl
  case pair a b =>
    let (a₁, a₂) := a
    let (b₁, b₂) := b
    exact match deq a₁ b₁, deq a₂ b₂ with
    | isTrue h₁, isTrue h₂ => isTrue (by rw [h₁,h₂])
    | isFalse h₁, _ => isFalse (fun h => by cases h; cases (h₁ rfl))
    | _, isFalse h₂ => isFalse (fun h => by cases h; cases (h₂ rfl))

end Ex3


variables (f : ℕ → ℕ) (k : ℕ)

example (h₁ : f 0 = 0) (h₂ : k = 0) : f k = 0 :=
  by simp *


import linear_algebra.finsupp

variables {R α β γ M N P : Type} [comm_ring R]
variables [add_comm_group M] [module R M]
variables [add_comm_group N] [module R N]
variables [add_comm_group P] [module R P]

noncomputable theory

namespace poly_example

variables (R α)

@[derive add_comm_group, derive module R]
def free_module : Type := finsupp α R

variables {R α}

def extend (f : α → M) : free_module R α →ₗ[R] M :=
finsupp.total _ _ _ f

def X (a : α) : free_module R α := finsupp.single a 1

@[simp] lemma extend_X (f : α → M) (a : α) : extend f (X a : free_module R α) = f a :=
by simp [extend, X]

@[simp] lemma extend_X' (f : free_module R α →ₗ[R] M) : extend (f ∘ X) = f :=
by ext; simp [extend, X]

@[ext] lemma hom_ext {f g : free_module R α →ₗ[R] M} (h : ∀ a, f (X a) = g (X a)) : f = g :=
by rw [← extend_X' f, function.comp]; simp only [h, extend_X']

variable (R)

def map (f : α → β) : free_module R α →ₗ[R] free_module R β :=
extend (X ∘ f)

variable {R}
lemma map_id  : map R (id : α → α) = linear_map.id :=
hom_ext (λ a, by rw [map, extend_X]; refl)

lemma map_comp (f : α → β) (g : β → γ) : map R (g ∘ f) = (map R g).comp (map R f) :=
hom_ext begin
  rw [map, map, map],
  intro i,
  rw [extend_X, linear_map.comp_apply, extend_X, extend_X],
end

@[simp] lemma extend_comp (f : M →ₗ[R] N) (g : α → M) :
  f.comp (extend g) = extend (λ x, f (g x)) :=
by ext; simp only [linear_map.coe_comp, function.comp_app, extend_X]

@[simp] lemma extend_comp_apply (f : M →ₗ[R] N) (g : α → M) (x : free_module R α) :
  f (extend g x) = extend (λ x, f (g x)) x :=
by rw [← extend_comp]; refl

def lcomp : (M →ₗ[R] N) →ₗ[R] (P →ₗ[R] M) →ₗ[R] (P →ₗ[R] N) :=
{ to_fun := λ f,
  { to_fun := linear_map.comp f,
    map_add' := by intros; ext; simp,
    map_smul' := by intros; ext; simp },
  map_add' := by intros; ext; simp,
  map_smul' := by intros; ext; simp }

def lcompop : (P →ₗ[R] M) →ₗ[R] (M →ₗ[R] N) →ₗ[R] (P →ₗ[R] N) :=
{ to_fun := λ f,
  { to_fun := λ g, linear_map.comp g f,
    map_add' := by intros; ext; simp,
    map_smul' := by intros; ext; simp },
  map_add' := by intros; ext; simp,
  map_smul' := by intros; ext; simp }

def swap : (M →ₗ[R] N →ₗ[R] P) →ₗ[R] (N →ₗ[R] M →ₗ[R] P) :=
{ to_fun := λ f,
  { to_fun := λ n,
    { to_fun := λ m, f m n,
      map_add' := λ _ _, by rw [f.map_add]; refl,
      map_smul' := λ _ _, by rw [f.map_smul]; refl, },
    map_add' := λ _ _, by simp only [(f _).map_add]; refl,
    map_smul' := λ _ _, by simp only [(f _).map_smul]; refl },
  map_add' := λ _ _, rfl,
  map_smul' := λ _ _, rfl }

@[simp] lemma extend_apply (f : α → M →ₗ[R] N) (x : free_module R α) (m : M) :
  extend f x m = extend (λ a, f a m) x :=
show swap (extend f) m x = extend (λ a, f a m) x,
begin
  refine congr_fun _ _,
  refine congr_arg _ _,
  ext,
  simp [swap]
end

variable {M}

attribute [irreducible] free_module extend X

def mul : free_module R ℕ →ₗ[R] free_module R ℕ →ₗ[R] free_module R ℕ :=
extend (λ n, extend (λ m, X (n + m)))

-- free_module R ℕ →ₗ[R] free_module R ℕ →ₗ[R] free_module R ℕ →ₗ[R] free_module R ℕ

lemma mul_assoc (p q r : free_module R ℕ) : mul (mul p q) r = mul p (mul q r) :=
--by simp only [mul, add_assoc, extend_apply, extend_comp_apply, extend_X]

-- #print mul_assoc

show (lcomp (@mul R _)).comp mul p q r = (lcompop (@mul R _)).comp (lcomp.comp mul) p q r,
--by congr' 3; ext; simp [lcomp, lcompop, mul, add_assoc]
begin
  congr' 3,
  apply hom_ext,
  intro,
  apply hom_ext,
  intro,
  apply hom_ext,
  intro,
  dsimp [mul, lcomp, lcompop],
  rw [extend_X, extend_X, extend_X, extend_X, extend_X, extend_X, extend_X, add_assoc],
end

lemma mul_comm (p q : free_module R ℕ) : mul p q = mul q p :=
show mul p q = swap mul p q,
begin
  refine linear_map.congr_fun _ _,
  refine linear_map.congr_fun _ _,
  ext,
  simp [mul, swap, add_comm]
end

@[derive module R] def matrix : Type := free_module

end