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

namespace option
variables {α : Type*} {β : Type*} {γ : Type*}

lemma coe_def : (coe : α → option α) = some := rfl

lemma some_ne_none (x : α) : some x ≠ none := λ h, option.no_confusion h

protected lemma «forall» {p : option α → Prop} : (∀ x, p x) ↔ p none ∧ ∀ x, p (some x) :=
⟨λ h, ⟨h _, λ x, h _⟩, λ h x, option.cases_on x h.1 h.2⟩

protected lemma «exists» {p : option α → Prop} : (∃ x, p x) ↔ p none ∨ ∃ x, p (some x) :=
⟨λ ⟨x, hx⟩, (option.cases_on x or.inl $ λ x hx, or.inr ⟨x, hx⟩) hx,
  λ h, h.elim (λ h, ⟨_, h⟩) (λ ⟨x, hx⟩, ⟨_, hx⟩)⟩

@[simp] theorem get_mem : ∀ {o : option α} (h : is_some o), option.get h ∈ o
| (some a) _ := rfl

theorem get_of_mem {a : α} : ∀ {o : option α} (h : is_some o), a ∈ o → option.get h = a
| _ _ rfl := rfl

@[simp] lemma not_mem_none (a : α) : a ∉ (none : option α) :=
λ h, option.no_confusion h

@[simp] lemma some_get : ∀ {x : option α} (h : is_some x), some (option.get h) = x
| (some x) hx := rfl

@[simp] lemma get_some (x : α) (h : is_some (some x)) : option.get h = x := rfl

@[simp] lemma get_or_else_some (x y : α) : option.get_or_else (some x) y = x := rfl

@[simp] lemma get_or_else_coe (x y : α) : option.get_or_else ↑x y = x := rfl

lemma get_or_else_of_ne_none {x : option α} (hx : x ≠ none) (y : α) : some (x.get_or_else y) = x :=
by cases x; [contradiction, rw get_or_else_some]

theorem mem_unique {o : option α} {a b : α} (ha : a ∈ o) (hb : b ∈ o) : a = b :=
option.some.inj $ ha.symm.trans hb

theorem mem.left_unique : relator.left_unique ((∈) : α → option α → Prop) :=
⟨λ a o b, mem_unique⟩

theorem some_injective (α : Type*) : function.injective (@some α) :=
λ _ _, some_inj.mp

/-- `option.map f` is injective if `f` is injective. -/
theorem map_injective {f : α → β} (Hf : function.injective f) : function.injective (option.map f)
| none      none      H := rfl
| (some a₁) (some a₂) H := by rw Hf (option.some.inj H)

@[ext] theorem ext : ∀ {o₁ o₂ : option α}, (∀ a, a ∈ o₁ ↔ a ∈ o₂) → o₁ = o₂
| none     none     H := rfl
| (some a) o        H := ((H _).1 rfl).symm
| o        (some b) H := (H _).2 rfl

theorem eq_none_iff_forall_not_mem {o : option α} :
  o = none ↔ (∀ a, a ∉ o) :=
⟨λ e a h, by rw e at h; cases h, λ h, ext $ by simpa⟩

@[simp] theorem none_bind {α β} (f : α → option β) : none >>= f = none := rfl

@[simp] theorem some_bind {α β} (a : α) (f : α → option β) : some a >>= f = f a := rfl

@[simp] theorem none_bind' (f : α → option β) : none.bind f = none := rfl

@[simp] theorem some_bind' (a : α) (f : α → option β) : (some a).bind f = f a := rfl

@[simp] theorem bind_some : ∀ x : option α, x >>= some = x :=
@bind_pure α option _ _

@[simp] theorem bind_eq_some {α β} {x : option α} {f : α → option β} {b : β} :
  x >>= f = some b ↔ ∃ a, x = some a ∧ f a = some b :=
by cases x; simp

@[simp] theorem bind_eq_some' {x : option α} {f : α → option β} {b : β} :
  x.bind f = some b ↔ ∃ a, x = some a ∧ f a = some b :=
by cases x; simp

@[simp] theorem bind_eq_none' {o : option α} {f : α → option β} :
  o.bind f = none ↔ (∀ b a, a ∈ o → b ∉ f a) :=
by simp only [eq_none_iff_forall_not_mem, not_exists, not_and, mem_def, bind_eq_some']

@[simp] theorem bind_eq_none {α β} {o : option α} {f : α → option β} :
  o >>= f = none ↔ (∀ b a, a ∈ o → b ∉ f a) :=
bind_eq_none'

lemma bind_comm {α β γ} {f : α → β → option γ} (a : option α) (b : option β) :
  a.bind (λx, b.bind (f x)) = b.bind (λy, a.bind (λx, f x y)) :=
by cases a; cases b; refl

lemma bind_assoc (x : option α) (f : α → option β) (g : β → option γ) :
  (x.bind f).bind g = x.bind (λ y, (f y).bind g) := by cases x; refl

lemma join_eq_some {x : option (option α)} {a : α} : x.join = some a ↔ x = some (some a) := by simp

lemma join_ne_none {x : option (option α)} : x.join ≠ none ↔ ∃ z, x = some (some z) := by simp

lemma join_ne_none' {x : option (option α)} : ¬(x.join = none) ↔ ∃ z, x = some (some z) := by simp

lemma join_eq_none {o : option (option α)} : o.join = none ↔ o = none ∨ o = some none :=
by rcases o with _|_|_; simp

lemma bind_id_eq_join {x : option (option α)} : x >>= id = x.join := by simp

lemma join_eq_join : mjoin = @join α :=
funext (λ x, by rw [mjoin, bind_id_eq_join])

lemma bind_eq_bind {α β : Type*} {f : α → option β} {x : option α} :
  x >>= f = x.bind f := rfl

@[simp] lemma map_eq_map {α β} {f : α → β} :
  (<$>) f = option.map f := rfl

theorem map_none {α β} {f : α → β} : f <$> none = none := rfl

theorem map_some {α β} {a : α} {f : α → β} : f <$> some a = some (f a) := rfl

@[simp] theorem map_none' {f : α → β} : option.map f none = none := rfl

@[simp] theorem map_some' {a : α} {f : α → β} : option.map f (some a) = some (f a) := rfl

theorem map_eq_some {α β} {x : option α} {f : α → β} {b : β} :
  f <$> x = some b ↔ ∃ a, x = some a ∧ f a = b :=
by cases x; simp

@[simp] theorem map_eq_some' {x : option α} {f : α → β} {b : β} :
  x.map f = some b ↔ ∃ a, x = some a ∧ f a = b :=
by cases x; simp

lemma map_eq_none {α β} {x : option α} {f : α → β} :
  f <$> x = none ↔ x = none :=
by { cases x; simp only [map_none, map_some, eq_self_iff_true] }

@[simp] lemma map_eq_none' {x : option α} {f : α → β} :
  x.map f = none ↔ x = none :=
by { cases x; simp only [map_none', map_some', eq_self_iff_true] }

lemma map_congr {f g : α → β} {x : option α} (h : ∀ a ∈ x, f a = g a) :
  option.map f x = option.map g x :=
by { cases x; simp only [map_none', map_some', h, mem_def] }

@[simp] theorem map_id' : option.map (@id α) = id := map_id

@[simp] lemma map_map (h : β → γ) (g : α → β) (x : option α) :
  option.map h (option.map g x) = option.map (h ∘ g) x :=
by { cases x; simp only [map_none', map_some'] }

lemma comp_map (h : β → γ) (g : α → β) (x : option α) :
  option.map (h ∘ g) x = option.map h (option.map g x) := (map_map _ _ _).symm

@[simp] lemma map_comp_map (f : α → β) (g : β → γ) :
  option.map g ∘ option.map f = option.map (g ∘ f) :=
by { ext x, rw comp_map }

lemma mem_map_of_mem {α β : Type*} {a : α} {x : option α} (g : α → β) (h : a ∈ x) : g a ∈ x.map g :=
mem_def.mpr ((mem_def.mp h).symm ▸ map_some')

lemma bind_map_comm {α β} {x : option (option α) } {f : α → β} :
  x >>= option.map f = x.map (option.map f) >>= id :=
by { cases x; simp }

lemma join_map_eq_map_join {f : α → β} {x : option (option α)} :
  (x.map (option.map f)).join = x.join.map f :=
by { rcases x with _ | _ | x; simp }

lemma join_join {x : option (option (option α))} :
  x.join.join = (x.map join).join :=
by { rcases x with _ | _ | _ | x; simp }

lemma mem_of_mem_join {a : α} {x : option (option α)} (h : a ∈ x.join) : some a ∈ x :=
mem_def.mpr ((mem_def.mp h).symm ▸ join_eq_some.mp h)

section pmap

variables {p : α → Prop} (f : Π (a : α), p a → β) (x : option α)

@[simp] lemma pbind_eq_bind (f : α → option β) (x : option α) :
  x.pbind (λ a _, f a) = x.bind f :=
by { cases x; simp only [pbind, none_bind', some_bind'] }

lemma map_bind {α β γ} (f : β → γ) (x : option α) (g : α → option β) :
  option.map f (x >>= g) = (x >>= λ a, option.map f (g a)) :=
by simp_rw [←map_eq_map, ←bind_pure_comp_eq_map,is_lawful_monad.bind_assoc]

lemma map_bind' (f : β → γ) (x : option α) (g : α → option β) :
  option.map f (x.bind g) = x.bind (λ a, option.map f (g a)) :=
by { cases x; simp }

lemma map_pbind (f : β → γ) (x : option α) (g : Π a, a ∈ x → option β) :
  option.map f (x.pbind g) = (x.pbind (λ a H, option.map f (g a H))) :=
by { cases x; simp only [pbind, map_none'] }

lemma pbind_map (f : α → β) (x : option α) (g : Π (b : β), b ∈ x.map f → option γ) :
  pbind (option.map f x) g = x.pbind (λ a h, g (f a) (mem_map_of_mem _ h)) :=
by { cases x; refl }

@[simp] lemma pmap_none (f : Π (a : α), p a → β) {H} : pmap f (@none α) H = none := rfl

@[simp] lemma pmap_some (f : Π (a : α), p a → β) {x : α} (h : p x) :
  pmap f (some x) = λ _, some (f x h) := rfl

lemma mem_pmem {a : α} (h : ∀ a ∈ x, p a) (ha : a ∈ x) :
  f a (h a ha) ∈ pmap f x h :=
by { rw mem_def at ha ⊢, subst ha, refl }

lemma pmap_map (g : γ → α) (x : option γ) (H) :
  pmap f (x.map g) H = pmap (λ a h, f (g a) h) x (λ a h, H _ (mem_map_of_mem _ h)) :=
by { cases x; simp only [map_none', map_some', pmap] }

lemma map_pmap (g : β → γ) (f : Π a, p a → β) (x H) :
  option.map g (pmap f x H) = pmap (λ a h, g (f a h)) x H :=
by { cases x; simp only [map_none', map_some', pmap] }

@[simp] lemma pmap_eq_map (p : α → Prop) (f : α → β) (x H) :
  @pmap _ _ p (λ a _, f a) x H = option.map f x :=
by { cases x; simp only [map_none', map_some', pmap] }

lemma bind_pmap {α β γ} {p : α → Prop} (f : Π a, p a → β) (x : option α) (g : β → option γ) (H) :
  (pmap f x H) >>= g = x.pbind (λ a h, g (f a (H _ h))) :=
by { cases x; simp only [pmap, none_bind, some_bind, pbind] }

variables {f x}

lemma pbind_eq_none {f : Π (a : α), a ∈ x → option β}
  (h' : ∀ a ∈ x, f a H = none → x = none) :
  x.pbind f = none ↔ x = none :=
begin
  cases x,
  { simp },
  { simp only [pbind, iff_false],
    intro h,
    cases h' x rfl h }
end

lemma pbind_eq_some {f : Π (a : α), a ∈ x → option β} {y : β} :
  x.pbind f = some y ↔ ∃ (z ∈ x), f z H = some y :=
begin
  cases x,
  { simp },
  { simp only [pbind],
    split,
    { intro h,
      use x,
      simpa only [mem_def, exists_prop_of_true] using h },
    { rintro ⟨z, H, hz⟩,
      simp only [mem_def] at H,
      simpa only [H] using hz } }
end

@[simp] lemma pmap_eq_none_iff {h} :
  pmap f x h = none ↔ x = none :=
by { cases x; simp }

@[simp] lemma pmap_eq_some_iff {hf} {y : β} :
  pmap f x hf = some y ↔ ∃ (a : α) (H : x = some a), f a (hf a H) = y :=
begin
  cases x,
  { simp only [not_mem_none, exists_false, pmap, not_false_iff, exists_prop_of_false] },
  { split,
    { intro h,
      simp only [pmap] at h,
      exact ⟨x, rfl, h⟩ },
    { rintro ⟨a, H, rfl⟩,
      simp only [mem_def] at H,
      simp only [H, pmap] } }
end

@[simp] lemma join_pmap_eq_pmap_join {f : Π a, p a → β} {x : option (option α)} (H) :
  (pmap (pmap f) x H).join = pmap f x.join (λ a h, H (some a) (mem_of_mem_join h) _ rfl) :=
by { rcases x with _ | _ | x; simp }

end pmap

@[simp] theorem seq_some {α β} {a : α} {f : α → β} : some f <*> some a = some (f a) := rfl

@[simp] theorem some_orelse' (a : α) (x : option α) : (some a).orelse x = some a := rfl

@[simp] theorem some_orelse (a : α) (x : option α) : (some a <|> x) = some a := rfl

@[simp] theorem none_orelse' (x : option α) : none.orelse x = x :=
by cases x; refl

@[simp] theorem none_orelse (x : option α) : (none <|> x) = x := none_orelse' x

@[simp] theorem orelse_none' (x : option α) : x.orelse none = x :=
by cases x; refl

@[simp] theorem orelse_none (x : option α) : (x <|> none) = x := orelse_none' x

@[simp] theorem is_some_none : @is_some α none = ff := rfl

@[simp] theorem is_some_some {a : α} : is_some (some a) = tt := rfl

theorem is_some_iff_exists {x : option α} : is_some x ↔ ∃ a, x = some a :=
by cases x; simp [is_some]; exact ⟨_, rfl⟩

@[simp] theorem is_none_none : @is_none α none = tt := rfl

@[simp] theorem is_none_some {a : α} : is_none (some a) = ff := rfl

@[simp] theorem not_is_some {a : option α} : is_some a = ff ↔ a.is_none = tt :=
by cases a; simp

lemma eq_some_iff_get_eq {o : option α} {a : α} :
  o = some a ↔ ∃ h : o.is_some, option.get h = a :=
by cases o; simp

lemma not_is_some_iff_eq_none {o : option α} :  ¬o.is_some ↔ o = none :=
by cases o; simp

lemma ne_none_iff_is_some {o : option α} : o ≠ none ↔ o.is_some :=
by cases o; simp

lemma ne_none_iff_exists {o : option α} : o ≠ none ↔ ∃ (x : α), some x = o :=
by {cases o; simp}

lemma ne_none_iff_exists' {o : option α} : o ≠ none ↔ ∃ (x : α), o = some x :=
ne_none_iff_exists.trans $ exists_congr $ λ _, eq_comm

lemma bex_ne_none {p : option α → Prop} :
  (∃ x ≠ none, p x) ↔ ∃ x, p (some x) :=
⟨λ ⟨x, hx, hp⟩, ⟨get $ ne_none_iff_is_some.1 hx, by rwa [some_get]⟩,
  λ ⟨x, hx⟩, ⟨some x, some_ne_none x, hx⟩⟩

lemma ball_ne_none {p : option α → Prop} :
  (∀ x ≠ none, p x) ↔ ∀ x, p (some x) :=
⟨λ h x, h (some x) (some_ne_none x),
  λ h x hx, by simpa only [some_get] using h (get $ ne_none_iff_is_some.1 hx)⟩

theorem iget_mem [inhabited α] : ∀ {o : option α}, is_some o → o.iget ∈ o
| (some a) _ := rfl

theorem iget_of_mem [inhabited α] {a : α} : ∀ {o : option α}, a ∈ o → o.iget = a
| _ rfl := rfl

@[simp] theorem guard_eq_some {p : α → Prop} [decidable_pred p] {a b : α} :
  guard p a = some b ↔ a = b ∧ p a :=
by by_cases p a; simp [option.guard, h]; intro; contradiction

@[simp] theorem guard_eq_some' {p : Prop} [decidable p] :
  ∀ u, _root_.guard p = some u ↔ p
| () := by by_cases p; simp [guard, h, pure]; intro; contradiction

theorem lift_or_get_choice {f : α → α → α} (h : ∀ a b, f a b = a ∨ f a b = b) :
  ∀ o₁ o₂, lift_or_get f o₁ o₂ = o₁ ∨ lift_or_get f o₁ o₂ = o₂
| none     none     := or.inl rfl
| (some a) none     := or.inl rfl
| none     (some b) := or.inr rfl
| (some a) (some b) := by simpa [lift_or_get] using h a b

@[simp] lemma lift_or_get_none_left {f} {b : option α} : lift_or_get f none b = b :=
by cases b; refl

@[simp] lemma lift_or_get_none_right {f} {a : option α} : lift_or_get f a none = a :=
by cases a; refl

@[simp] lemma lift_or_get_some_some {f} {a b : α} :
  lift_or_get f (some a) (some b) = f a b := rfl

/-- given an element of `a : option α`, a default element `b : β` and a function `α → β`, apply this
function to `a` if it comes from `α`, and return `b` otherwise. -/
def cases_on' : option α → β → (α → β) → β
| none     n s := n
| (some a) n s := s a

@[simp] lemma cases_on'_none (x : β) (f : α → β) : cases_on' none x f = x := rfl

@[simp] lemma cases_on'_some (x : β) (f : α → β) (a : α) : cases_on' (some a) x f = f a := rfl

@[simp] lemma cases_on'_coe (x : β) (f : α → β) (a : α) : cases_on' (a : option α) x f = f a := rfl

@[simp] lemma cases_on'_none_coe (f : option α → β) (o : option α) :
  cases_on' o (f none) (f ∘ coe) = f o :=
by cases o; refl

section
open_locale classical

/-- An arbitrary `some a` with `a : α` if `α` is nonempty, and otherwise `none`. -/
noncomputable def choice (α : Type*) : option α :=
if h : nonempty α then
  some h.some
else
  none

lemma choice_eq {α : Type*} [subsingleton α] (a : α) : choice α = some a :=
begin
  dsimp [choice],
  rw dif_pos (⟨a⟩ : nonempty α),
  congr,
end

lemma choice_eq_none {α : Type*} (h : α → false) : choice α = none :=
begin
  dsimp [choice],
  rw dif_neg (not_nonempty_iff_imp_false.mpr h),
end

lemma choice_is_some_iff_nonempty {α : Type*} : (choice α).is_some ↔ nonempty α :=
begin
  fsplit,
  { intro h, exact ⟨option.get h⟩, },
  { rintro ⟨a⟩,
    dsimp [choice],
    rw dif_pos,
    fsplit,
    exact ⟨a⟩, },
end

end

end option


structure Pos where
  protected succ :: protected pred : Nat
  deriving Repr

protected def Pos.add : Pos → Pos → Pos
  | .succ x, .succ y => .succ (x + y).succ

instance : Add Pos := ⟨Pos.add⟩

instance (x : Nat) : OfNat Pos x.succ := ⟨.succ x⟩

/-- View for `Pos` type. -/
inductive PosView where
  | one
  | succ (x : Pos)

/--
  Convert `Pos` into `PosView`.
  Remark: nonrecursive views do not impact performance of the generated code if marked as `[inline]`
 -/
@[inline] def Pos.view (p : Pos) : PosView :=
  match p with
  | { pred := 0 }          => PosView.one
  | { pred := Nat.succ n } => PosView.succ ⟨n⟩

/--
  Helper theorem for proving termination.
  In the future, we should be able to mark it as a forward reasoning theorem for `decreasing_tactic`,
  and it will be applied automatically for us. -/
theorem sizeof_lt_of_view_eq (h : Pos.view p₁ = PosView.succ p₂) : sizeOf p₂ < sizeOf p₁ := by
  match p₁, p₂ with
  | { pred := Nat.succ n }, { pred := Nat.succ m } => simp [Pos.view] at h; simp_arith [h]
  | { pred := Nat.succ n }, { pred := 0 }          => simp [Pos.view] at h; simp_arith [h]
  | { pred := 0 },          _                      => simp [Pos.view] at h

/-- `1` as notation for `PosView.one` -/
instance : OfNat PosView (nat_lit 1) where
  ofNat := PosView.one

def f (p : Pos) : Pos :=
  match h : p.view with -- It would also be nice to have a feature to force Lean to applies "views" automatically for us.
  | 1 => 1
  | .succ x =>
    have : sizeOf x < sizeOf p := sizeof_lt_of_view_eq h -- See comment at `sizeof_lt_of_view_eq`
    f x + x + 1


/-
Copyright (c) 2020 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.limits.shapes.images
import Mathlib.category_theory.limits.shapes.kernels
import Mathlib.PostPort

universes u v

namespace Mathlib

/-!
# The morphism from `image f` to `kernel g` when `f ≫ g = 0`

We define the map, as the lift of `image.ι f` to `kernel g`,
and check some basic properties:

* this map is a monomorphism
* given `A --0--> B --g--> C`, where `[mono g]`, this map is an epimorphism
* given `A --f--> B --0--> C`, where `[epi f]`, this map is an epimorphism

In later files, we define the homology of complex as the cokernel of this map,
and say a complex is exact at a point if this map is an epimorphism.
-/

namespace category_theory

/-!
At this point we assume that we have all images, and all equalizers.
We need to assume all equalizers, not just kernels, so that
`factor_thru_image` is an epimorphism.
-/

/--
The morphism from `image f` to `kernel g` when `f ≫ g = 0`.
-/
def image_to_kernel_map {V : Type u} [category V] [limits.has_zero_morphisms V]
    [limits.has_images V] [limits.has_equalizers V] {A : V} {B : V} {C : V} (f : A ⟶ B) (g : B ⟶ C)
    (w : f ≫ g = 0) : limits.image f ⟶ limits.kernel g :=
  limits.kernel.lift g (limits.image.ι f) sorry

@[simp] theorem image_to_kernel_map_zero_left {V : Type u} [category V]
    [limits.has_zero_morphisms V] [limits.has_images V] [limits.has_equalizers V] {A : V} {B : V}
    {C : V} (g : B ⟶ C) [limits.has_zero_object V] {w : 0 ≫ g = 0} :
    image_to_kernel_map 0 g w = 0 :=
  sorry

theorem image_to_kernel_map_zero_right {V : Type u} [category V] [limits.has_zero_morphisms V]
    [limits.has_images V] [limits.has_equalizers V] {A : V} {B : V} {C : V} (f : A ⟶ B)
    {w : f ≫ 0 = 0} : image_to_kernel_map f 0 w = limits.image.ι f ≫ inv (limits.kernel.ι 0) :=
  sorry

theorem image_to_kernel_map_comp_right {V : Type u} [category V] [limits.has_zero_morphisms V]
    [limits.has_images V] [limits.has_equalizers V] {A : V} {B : V} {C : V} (f : A ⟶ B) (g : B ⟶ C)
    {D : V} (h : C ⟶ D) (w : f ≫ g = 0) :
    image_to_kernel_map f (g ≫ h)
          (eq.mpr
            (id
              (Eq.trans
                ((fun (a a_1 : A ⟶ D) (e_1 : a = a_1) (ᾰ ᾰ_1 : A ⟶ D) (e_2 : ᾰ = ᾰ_1) =>
                    congr (congr_arg Eq e_1) e_2)
                  (f ≫ g ≫ h) 0 (Eq.trans (reassoc_of w D h) limits.zero_comp) 0 0 (Eq.refl 0))
                (propext (eq_self_iff_true 0))))
            trivial) =
        image_to_kernel_map f g w ≫
          limits.kernel.lift (g ≫ h) (limits.kernel.ι g)
            (eq.mpr
              (id
                (Eq.trans
                  ((fun (a a_1 : limits.kernel g ⟶ D) (e_1 : a = a_1) (ᾰ ᾰ_1 : limits.kernel g ⟶ D)
                      (e_2 : ᾰ = ᾰ_1) => congr (congr_arg Eq e_1) e_2)
                    (limits.kernel.ι g ≫ g ≫ h) 0
                    (Eq.trans (limits.kernel.condition_assoc g h) limits.zero_comp) 0 0 (Eq.refl 0))
                  (propext (eq_self_iff_true 0))))
              trivial) :=
  sorry

theorem image_to_kernel_map_comp_left {V : Type u} [category V] [limits.has_zero_morphisms V]
    [limits.has_images V] [limits.has_equalizers V] {A : V} {B : V} {C : V} (f : A ⟶ B) (g : B ⟶ C)
    {Z : V} (h : Z ⟶ A) (w : f ≫ g = 0) :
    image_to_kernel_map (h ≫ f) g
          (eq.mpr
            (id
              (Eq.trans
                ((fun (a a_1 : Z ⟶ C) (e_1 : a = a_1) (ᾰ ᾰ_1 : Z ⟶ C) (e_2 : ᾰ = ᾰ_1) =>
                    congr (congr_arg Eq e_1) e_2)
                  ((h ≫ f) ≫ g) 0
                  (Eq.trans
                    (Eq.trans (category.assoc h f g)
                      ((fun (ᾰ ᾰ_1 : Z ⟶ A) (e_1 : ᾰ = ᾰ_1) (ᾰ_2 ᾰ_3 : A ⟶ C) (e_2 : ᾰ_2 = ᾰ_3) =>
                          congr (congr_arg category_struct.comp e_1) e_2)
                        h h (Eq.refl h) (f ≫ g) 0 w))
                    limits.comp_zero)
                  0 0 (Eq.refl 0))
                (propext (eq_self_iff_true 0))))
            trivial) =
        limits.image.pre_comp h f ≫ image_to_kernel_map f g w :=
  sorry

@[simp] theorem image_to_kernel_map_comp_iso {V : Type u} [category V] [limits.has_zero_morphisms V]
    [limits.has_images V] [limits.has_equalizers V] {A : V} {B : V} {C : V} (f : A ⟶ B) (g : B ⟶ C)
    {D : V} (h : C ⟶ D) [is_iso h] (w : f ≫ g ≫ h = 0) :
    image_to_kernel_map f (g ≫ h) w =
        image_to_kernel_map f g
            (iff.mp (cancel_mono h)
              (eq.mpr
                (id
                  ((fun (a a_1 : A ⟶ D) (e_1 : a = a_1) (ᾰ ᾰ_1 : A ⟶ D) (e_2 : ᾰ = ᾰ_1) =>
                      congr (congr_arg Eq e_1) e_2)
                    ((f ≫ g) ≫ h) (f ≫ g ≫ h) (category.assoc f g h) (0 ≫ h) 0 limits.zero_comp))
                (eq.mp (Eq.refl (f ≫ g ≫ h = 0)) w))) ≫
          iso.inv (limits.kernel_comp_is_iso g h) :=
  sorry

@[simp] theorem image_to_kernel_map_iso_comp {V : Type u} [category V] [limits.has_zero_morphisms V]
    [limits.has_images V] [limits.has_equalizers V] {A : V} {B : V} {C : V} (f : A ⟶ B) (g : B ⟶ C)
    {Z : V} (h : Z ⟶ A) [is_iso h] (w : (h ≫ f) ≫ g = 0) :
    image_to_kernel_map (h ≫ f) g w =
        limits.image.pre_comp h f ≫
          image_to_kernel_map f g
            (iff.mp (cancel_epi h)
              (eq.mpr
                (id
                  ((fun (a a_1 : Z ⟶ C) (e_1 : a = a_1) (ᾰ ᾰ_1 : Z ⟶ C) (e_2 : ᾰ = ᾰ_1) =>
                      congr (congr_arg Eq e_1) e_2)
                    (h ≫ f ≫ g) (h ≫ f ≫ g) (Eq.refl (h ≫ f ≫ g)) (h ≫ 0) 0 limits.comp_zero))
                (eq.mp
                  ((fun (a a_1 : Z ⟶ C) (e_1 : a = a_1) (ᾰ ᾰ_1 : Z ⟶ C) (e_2 : ᾰ = ᾰ_1) =>
                      congr (congr_arg Eq e_1) e_2)
                    ((h ≫ f) ≫ g) (h ≫ f ≫ g) (category.assoc h f g) 0 0 (Eq.refl 0))
                  w))) :=
  sorry

@[simp] theorem image_to_kernel_map_comp_hom_inv_comp {V : Type u} [category V]
    [limits.has_zero_morphisms V] [limits.has_images V] [limits.has_equalizers V] {A : V} {B : V}
    {C : V} (f : A ⟶ B) (g : B ⟶ C) {Z : V} {i : B ≅ Z} (w : (f ≫ iso.hom i) ≫ iso.inv i ≫ g = 0) :
    image_to_kernel_map (f ≫ iso.hom i) (iso.inv i ≫ g) w =
        iso.inv (limits.image.post_comp_is_iso f (iso.hom i)) ≫
          image_to_kernel_map f g
              (eq.mpr (id (Eq.refl (f ≫ g = 0)))
                (eq.mp
                  ((fun (a a_1 : A ⟶ C) (e_1 : a = a_1) (ᾰ ᾰ_1 : A ⟶ C) (e_2 : ᾰ = ᾰ_1) =>
                      congr (congr_arg Eq e_1) e_2)
                    ((f ≫ iso.hom i) ≫ iso.inv i ≫ g) (f ≫ g)
                    (Eq.trans (category.assoc f (iso.hom i) (iso.inv i ≫ g))
                      ((fun (ᾰ ᾰ_1 : A ⟶ B) (e_1 : ᾰ = ᾰ_1) (ᾰ_2 ᾰ_3 : B ⟶ C) (e_2 : ᾰ_2 = ᾰ_3) =>
                          congr (congr_arg category_struct.comp e_1) e_2)
                        f f (Eq.refl f) (iso.hom i ≫ iso.inv i ≫ g) g (iso.hom_inv_id_assoc i g)))
                    0 0 (Eq.refl 0))
                  w)) ≫
            iso.inv (limits.kernel_is_iso_comp (iso.inv i) g) :=
  sorry

/--
`image_to_kernel_map` for `A --0--> B --g--> C`, where `[mono g]` is an epi
(i.e. the sequence is exact at `B`).
-/
theorem image_to_kernel_map_epi_of_zero_of_mono {V : Type u} [category V]
    [limits.has_zero_morphisms V] [limits.has_images V] [limits.has_equalizers V] {A : V} {B : V}
    {C : V} (g : B ⟶ C) [mono g] [limits.has_zero_object V] :
    epi
        (image_to_kernel_map 0 g
          (eq.mpr
            (id
              (Eq.trans
                ((fun (a a_1 : A ⟶ C) (e_1 : a = a_1) (ᾰ ᾰ_1 : A ⟶ C) (e_2 : ᾰ = ᾰ_1) =>
                    congr (congr_arg Eq e_1) e_2)
                  (0 ≫ g) 0 limits.zero_comp 0 0 (Eq.refl 0))
                (propext (eq_self_iff_true 0))))
            trivial)) :=
  sorry

/--
`image_to_kernel_map` for `A --f--> B --0--> C`, where `[epi g]` is an epi
(i.e. the sequence is exact at `B`).
-/
theorem image_to_kernel_map_epi_of_epi_of_zero {V : Type u} [category V]
    [limits.has_zero_morphisms V] [limits.has_images V] [limits.has_equalizers V] {A : V} {B : V}
    {C : V} (f : A ⟶ B) [epi f] :
    epi
        (image_to_kernel_map f 0
          (eq.mpr
            (id
              (Eq.trans
                ((fun (a a_1 : A ⟶ C) (e_1 : a = a_1) (ᾰ ᾰ_1 : A ⟶ C) (e_2 : ᾰ = ᾰ_1) =>
                    congr (congr_arg Eq e_1) e_2)
                  (f ≫ 0) 0 limits.comp_zero 0 0 (Eq.refl 0))
                (propext (eq_self_iff_true 0))))
            trivial)) :=
  sorry

end Mathlib


/-
Copyright (c) 2019 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Johannes Hölzl

Linear structures on function with finite support `ι →₀ β`.
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.mv_polynomial.default
import Mathlib.linear_algebra.dimension
import Mathlib.linear_algebra.direct_sum.finsupp
import Mathlib.PostPort

universes u_1 u_2 u_3 u_4 u_5 u v w

namespace Mathlib

namespace finsupp

theorem linear_independent_single {R : Type u_1} {M : Type u_2} {ι : Type u_3} [ring R]
    [add_comm_group M] [module R M] {φ : ι → Type u_4} {f : (ι : ι) → φ ι → M}
    (hf : ∀ (i : ι), linear_independent R (f i)) :
    linear_independent R
        fun (ix : sigma fun (i : ι) => φ i) =>
          single (sigma.fst ix) (f (sigma.fst ix) (sigma.snd ix)) :=
  sorry

theorem is_basis_single {R : Type u_1} {M : Type u_2} {ι : Type u_3} [ring R] [add_comm_group M]
    [module R M] {φ : ι → Type u_4} (f : (ι : ι) → φ ι → M) (hf : ∀ (i : ι), is_basis R (f i)) :
    is_basis R
        fun (ix : sigma fun (i : ι) => φ i) =>
          single (sigma.fst ix) (f (sigma.fst ix) (sigma.snd ix)) :=
  sorry

theorem is_basis_single_one {R : Type u_1} {ι : Type u_3} [ring R] :
    is_basis R fun (i : ι) => single i 1 :=
  sorry

/-- If b : ι → M and c : κ → N are bases then so is λ i, b i.1 ⊗ₜ c i.2 : ι × κ → M ⊗ N. -/
theorem is_basis.tensor_product {R : Type u_1} {M : Type u_2} {N : Type u_3} {ι : Type u_4}
    {κ : Type u_5} [comm_ring R] [add_comm_group M] [module R M] [add_comm_group N] [module R N]
    {b : ι → M} (hb : is_basis R b) {c : κ → N} (hc : is_basis R c) :
    is_basis R fun (i : ι × κ) => tensor_product.tmul R (b (prod.fst i)) (c (prod.snd i)) :=
  sorry

theorem dim_eq {K : Type u} {V : Type v} {ι : Type v} [field K] [add_comm_group V]
    [vector_space K V] : vector_space.dim K (ι →₀ V) = cardinal.mk ι * vector_space.dim K V :=
  sorry

end finsupp

/- We use `universe variables` instead of `universes` here because universes introduced by the
   `universes` keyword do not get replaced by metavariables once a lemma has been proven. So if you
   prove a lemma using universe `u`, you can only apply it to universe `u` in other lemmas of the
   same section. -/

theorem equiv_of_dim_eq_lift_dim {K : Type u} {V : Type v} {V' : Type w} [field K]
    [add_comm_group V] [vector_space K V] [add_comm_group V'] [vector_space K V']
    (h : cardinal.lift (vector_space.dim K V) = cardinal.lift (vector_space.dim K V')) :
    Nonempty (linear_equiv K V V') :=
  sorry

/-- Two `K`-vector spaces are equivalent if their dimension is the same. -/
def equiv_of_dim_eq_dim {K : Type u} {V₁ : Type v} {V₂ : Type v} [field K] [add_comm_group V₁]
    [vector_space K V₁] [add_comm_group V₂] [vector_space K V₂]
    (h : vector_space.dim K V₁ = vector_space.dim K V₂) : linear_equiv K V₁ V₂ :=
  Classical.choice sorry

/-- An `n`-dimensional `K`-vector space is equivalent to `fin n → K`. -/
def fin_dim_vectorspace_equiv {K : Type u} {V : Type v} [field K] [add_comm_group V]
    [vector_space K V] (n : ℕ) (hn : vector_space.dim K V = ↑n) : linear_equiv K V (fin n → K) :=
  Classical.choice sorry

theorem eq_bot_iff_dim_eq_zero {K : Type u} {V : Type v} [field K] [add_comm_group V]
    [vector_space K V] (p : submodule K V) (h : vector_space.dim K ↥p = 0) : p = ⊥ :=
  let e : linear_equiv K ↥p ↥⊥ :=
    equiv_of_dim_eq_dim
      (eq.mpr (id (Eq._oldrec (Eq.refl (vector_space.dim K ↥p = vector_space.dim K ↥⊥)) dim_bot))
        h);
  linear_equiv.eq_bot_of_equiv p e

theorem injective_of_surjective {K : Type u} {V₁ : Type v} {V₂ : Type v} [field K]
    [add_comm_group V₁] [vector_space K V₁] [add_comm_group V₂] [vector_space K V₂]
    (f : linear_map K V₁ V₂) (hV₁ : vector_space.dim K V₁ < cardinal.omega)
    (heq : vector_space.dim K V₂ = vector_space.dim K V₁) (hf : linear_map.range f = ⊤) :
    linear_map.ker f = ⊥ :=
  sorry

theorem cardinal_mk_eq_cardinal_mk_field_pow_dim {K : Type u} {V : Type u} [field K]
    [add_comm_group V] [vector_space K V] (h : vector_space.dim K V < cardinal.omega) :
    cardinal.mk V = cardinal.mk K ^ vector_space.dim K V :=
  sorry

theorem cardinal_lt_omega_of_dim_lt_omega {K : Type u} {V : Type u} [field K] [add_comm_group V]
    [vector_space K V] [fintype K] (h : vector_space.dim K V < cardinal.omega) :
    cardinal.mk V < cardinal.omega :=
  eq.mpr
    (id
      (Eq._oldrec (Eq.refl (cardinal.mk V < cardinal.omega))
        (cardinal_mk_eq_cardinal_mk_field_pow_dim h)))
    (cardinal.power_lt_omega (iff.mpr cardinal.lt_omega_iff_fintype (Nonempty.intro infer_instance))
      h)

end Mathlib


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

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

universes u u_1 l u_2 u_3 u_4 u_5

namespace Mathlib

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

namespace semiquot

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

protected instance is_lawful_monad : is_lawful_monad semiquot := sorry

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

end Mathlib


/-
Copyright (c) 2021 Aaron Anderson. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Aaron Anderson
-/
import data.set_like.basic
import model_theory.semantics

/-!
# Definable Sets
This file defines what it means for a set over a first-order structure to be definable.

## Main Definitions
* `set.definable` is defined so that `A.definable L s` indicates that the
set `s` of a finite cartesian power of `M` is definable with parameters in `A`.
* `set.definable₁` is defined so that `A.definable₁ L s` indicates that
`(s : set M)` is definable with parameters in `A`.
* `set.definable₂` is defined so that `A.definable₂ L s` indicates that
`(s : set (M × M))` is definable with parameters in `A`.
* A `first_order.language.definable_set` is defined so that `L.definable_set A α` is the boolean
  algebra of subsets of `α → M` defined by formulas with parameters in `A`.

## Main Results
* `L.definable_set A α` forms a `boolean_algebra`
* `set.definable.image_comp` shows that definability is closed under projections in finite
  dimensions.

-/

universes u v w

namespace set

variables {M : Type w} (A : set M) (L : first_order.language.{u v}) [L.Structure M]
open_locale first_order
open first_order.language first_order.language.Structure

variables {α : Type*} {β : Type*}

/-- A subset of a finite Cartesian product of a structure is definable over a set `A` when
  membership in the set is given by a first-order formula with parameters from `A`. -/
def definable (s : set (α → M)) : Prop :=
∃ (φ : L[[A]].formula α), s = set_of φ.realize

variables {L} {A} {B : set M} {s : set (α → M)}

lemma definable.map_expansion {L' : first_order.language} [L'.Structure M] (h : A.definable L s)
  (φ : L →ᴸ L') [φ.is_expansion_on M] :
  A.definable L' s :=
begin
  obtain ⟨ψ, rfl⟩ := h,
  refine ⟨(φ.add_constants A).on_formula ψ, _⟩,
  ext x,
  simp only [mem_set_of_eq, Lhom.realize_on_formula],
end

lemma empty_definable_iff :
  (∅ : set M).definable L s ↔ ∃ (φ : L.formula α), s = set_of φ.realize :=
begin
  rw [definable, equiv.exists_congr_left (Lequiv.add_empty_constants L (∅ : set M)).on_formula],
  simp,
end

lemma definable_iff_empty_definable_with_params :
  A.definable L s ↔ (∅ : set M).definable (L[[A]]) s :=
empty_definable_iff.symm

lemma definable.mono (hAs : A.definable L s) (hAB : A ⊆ B) :
  B.definable L s :=
begin
  rw [definable_iff_empty_definable_with_params] at *,
  exact hAs.map_expansion (L.Lhom_with_constants_map (set.inclusion hAB)),
end

@[simp]
lemma definable_empty : A.definable L (∅ : set (α → M)) :=
⟨⊥, by {ext, simp} ⟩

@[simp]
lemma definable_univ : A.definable L (univ : set (α → M)) :=
⟨⊤, by {ext, simp} ⟩

@[simp]
lemma definable.inter {f g : set (α → M)} (hf : A.definable L f) (hg : A.definable L g) :
  A.definable L (f ∩ g) :=
begin
  rcases hf with ⟨φ, rfl⟩,
  rcases hg with ⟨θ, rfl⟩,
  refine ⟨φ ⊓ θ, _⟩,
  ext,
  simp,
end

@[simp]
lemma definable.union {f g : set (α → M)} (hf : A.definable L f) (hg : A.definable L g) :
  A.definable L (f ∪ g) :=
begin
  rcases hf with ⟨φ, hφ⟩,
  rcases hg with ⟨θ, hθ⟩,
  refine ⟨φ ⊔ θ, _⟩,
  ext,
  rw [hφ, hθ, mem_set_of_eq, formula.realize_sup, mem_union, mem_set_of_eq,
    mem_set_of_eq],
end

lemma definable_finset_inf {ι : Type*} {f : Π (i : ι), set (α → M)}
  (hf : ∀ i, A.definable L (f i)) (s : finset ι) :
  A.definable L (s.inf f) :=
begin
  classical,
  refine finset.induction definable_univ (λ i s is h, _) s,
  rw finset.inf_insert,
  exact (hf i).inter h,
end

lemma definable_finset_sup {ι : Type*} {f : Π (i : ι), set (α → M)}
  (hf : ∀ i, A.definable L (f i)) (s : finset ι) :
  A.definable L (s.sup f) :=
begin
  classical,
  refine finset.induction definable_empty (λ i s is h, _) s,
  rw finset.sup_insert,
  exact (hf i).union h,
end

lemma definable_finset_bInter {ι : Type*} {f : Π (i : ι), set (α → M)}
  (hf : ∀ i, A.definable L (f i)) (s : finset ι) :
  A.definable L (⋂ i ∈ s, f i) :=
begin
  rw ← finset.inf_set_eq_bInter,
  exact definable_finset_inf hf s,
end

lemma definable_finset_bUnion {ι : Type*} {f : Π (i : ι), set (α → M)}
  (hf : ∀ i, A.definable L (f i)) (s : finset ι) :
  A.definable L (⋃ i ∈ s, f i) :=
begin
  rw ← finset.sup_set_eq_bUnion,
  exact definable_finset_sup hf s,
end

@[simp]
lemma definable.compl {s : set (α → M)} (hf : A.definable L s) :
  A.definable L sᶜ :=
begin
  rcases hf with ⟨φ, hφ⟩,
  refine ⟨φ.not, _⟩,
  rw hφ,
  refl,
end

@[simp]
lemma definable.sdiff {s t : set (α → M)} (hs : A.definable L s)
  (ht : A.definable L t) :
  A.definable L (s \ t) :=
hs.inter ht.compl

lemma definable.preimage_comp (f : α → β) {s : set (α → M)}
  (h : A.definable L s) :
  A.definable L ((λ g : β → M, g ∘ f) ⁻¹' s) :=
begin
  obtain ⟨φ, rfl⟩ := h,
  refine ⟨(φ.relabel f), _⟩,
  ext,
  simp only [set.preimage_set_of_eq, mem_set_of_eq, formula.realize_relabel],
end

lemma definable.image_comp_equiv {s : set (β → M)}
  (h : A.definable L s) (f : α ≃ β) :
  A.definable L ((λ g : β → M, g ∘ f) '' s) :=
begin
  refine (congr rfl _).mp (h.preimage_comp f.symm),
  rw image_eq_preimage_of_inverse,
  { intro i,
    ext b,
    simp only [function.comp_app, equiv.apply_symm_apply], },
  { intro i,
    ext a,
    simp }
end

/-- This lemma is only intended as a helper for `definable.image_comp. -/
lemma definable.image_comp_sum_inl_fin (m : ℕ) {s : set ((α ⊕ fin m) → M)}
  (h : A.definable L s) :
  A.definable L ((λ g : (α ⊕ fin m) → M, g ∘ sum.inl) '' s) :=
begin
  obtain ⟨φ, rfl⟩ := h,
  refine ⟨(bounded_formula.relabel id φ).exs, _⟩,
  ext x,
  simp only [set.mem_image, mem_set_of_eq, bounded_formula.realize_exs,
    bounded_formula.realize_relabel, function.comp.right_id, fin.cast_add_zero, fin.cast_refl],
  split,
  { rintro ⟨y, hy, rfl⟩,
    exact ⟨y ∘ sum.inr,
      (congr (congr rfl (sum.elim_comp_inl_inr y).symm) (funext fin_zero_elim)).mp hy⟩ },
  { rintro ⟨y, hy⟩,
    exact ⟨sum.elim x y, (congr rfl (funext fin_zero_elim)).mp hy, sum.elim_comp_inl _ _⟩, },
end

/-- Shows that definability is closed under finite projections. -/
lemma definable.image_comp_embedding {s : set (β → M)} (h : A.definable L s)
  (f : α ↪ β) [finite β] :
  A.definable L ((λ g : β → M, g ∘ f) '' s) :=
begin
  classical,
  casesI nonempty_fintype β,
  refine (congr rfl (ext (λ x, _))).mp (((h.image_comp_equiv
    (equiv.set.sum_compl (range f))).image_comp_equiv (equiv.sum_congr
    (equiv.of_injective f f.injective) (fintype.equiv_fin _).symm)).image_comp_sum_inl_fin _),
  simp only [mem_preimage, mem_image, exists_exists_and_eq_and],
  refine exists_congr (λ y, and_congr_right (λ ys, eq.congr_left (funext (λ a, _)))),
  simp,
end

/-- Shows that definability is closed under finite projections. -/
lemma definable.image_comp {s : set (β → M)} (h : A.definable L s)
  (f : α → β) [finite α] [finite β] :
  A.definable L ((λ g : β → M, g ∘ f) '' s) :=
begin
  classical,
  casesI nonempty_fintype α,
  casesI nonempty_fintype β,
  have h := (((h.image_comp_equiv (equiv.set.sum_compl (range f))).image_comp_equiv
    (equiv.sum_congr (_root_.equiv.refl _)
    (fintype.equiv_fin _).symm)).image_comp_sum_inl_fin _).preimage_comp (range_splitting f),
  have h' : A.definable L ({ x : α → M |
    ∀ a, x a = x (range_splitting f (range_factorization f a))}),
  { have h' : ∀ a, A.definable L {x : α → M | x a =
      x (range_splitting f (range_factorization f a))},
    { refine λ a, ⟨(var a).equal (var (range_splitting f (range_factorization f a))), ext _⟩,
      simp, },
    refine (congr rfl (ext _)).mp (definable_finset_bInter h' finset.univ),
    simp },
  refine (congr rfl (ext (λ x, _))).mp (h.inter h'),
  simp only [equiv.coe_trans, mem_inter_iff, mem_preimage, mem_image,
    exists_exists_and_eq_and, mem_set_of_eq],
  split,
  { rintro ⟨⟨y, ys, hy⟩, hx⟩,
    refine ⟨y, ys, _⟩,
    ext a,
    rw [hx a, ← function.comp_apply x, ← hy],
    simp, },
  { rintro ⟨y, ys, rfl⟩,
    refine ⟨⟨y, ys, _⟩, λ a, _⟩,
    { ext,
      simp [set.apply_range_splitting f] },
    { rw [function.comp_apply, function.comp_apply, apply_range_splitting f,
        range_factorization_coe], }}
end

variables (L) {M} (A)

/-- A 1-dimensional version of `definable`, for `set M`. -/
def definable₁ (s : set M) : Prop := A.definable L { x : fin 1 → M | x 0 ∈ s }

/-- A 2-dimensional version of `definable`, for `set (M × M)`. -/
def definable₂ (s : set (M × M)) : Prop := A.definable L { x : fin 2 → M | (x 0, x 1) ∈ s }

end set

namespace first_order
namespace language
open set

variables (L : first_order.language.{u v}) {M : Type w} [L.Structure M] (A : set M) (α : Type*)

/-- Definable sets are subsets of finite Cartesian products of a structure such that membership is
  given by a first-order formula. -/
def definable_set := { s : set (α → M) // A.definable L s}

namespace definable_set
variables {L A α} {s t : L.definable_set A α} {x : α → M}

instance : set_like (L.definable_set A α) (α → M) :=
{ coe := subtype.val,
  coe_injective' := subtype.val_injective }

instance : has_top (L.definable_set A α) := ⟨⟨⊤, definable_univ⟩⟩
instance : has_bot (L.definable_set A α) := ⟨⟨⊥, definable_empty⟩⟩
instance : has_sup (L.definable_set A α) := ⟨λ s t, ⟨s ∪ t, s.2.union t.2⟩⟩
instance : has_inf (L.definable_set A α) := ⟨λ s t, ⟨s ∩ t, s.2.inter t.2⟩⟩
instance : has_compl (L.definable_set A α) := ⟨λ s, ⟨sᶜ, s.2.compl⟩⟩
instance : has_sdiff (L.definable_set A α) := ⟨λ s t, ⟨s \ t, s.2.sdiff t.2⟩⟩

instance : inhabited (L.definable_set A α) := ⟨⊥⟩

lemma le_iff : s ≤ t ↔ (s : set (α → M)) ≤ (t : set (α → M)) := iff.rfl

@[simp] lemma mem_top : x ∈ (⊤ : L.definable_set A α) := mem_univ x
@[simp] lemma not_mem_bot {x : α → M} : ¬ x ∈ (⊥ : L.definable_set A α) := not_mem_empty x
@[simp]

@[simp, norm_cast] lemma coe_top : ((⊤ : L.definable_set A α) : set (α → M)) = univ := rfl
@[simp, norm_cast] lemma coe_bot : ((⊥ : L.definable_set A α) : set (α → M)) = ∅ := rfl
@[simp, norm_cast] lemma coe_sup (s t : L.definable_set A α) : (↑(s ⊔ t) : set (α → M)) = s ∪ t :=
rfl
@[simp, norm_cast] lemma coe_inf (s t : L.definable_set A α) : (↑(s ⊓ t) : set (α → M)) = s ∩ t :=
rfl
@[simp, norm_cast] lemma coe_compl (s : L.definable_set A α) : (↑(sᶜ) : set (α → M)) = sᶜ := rfl
@[simp, norm_cast] lemma coe_sdiff (s t : L.definable_set A α) : (↑(s \ t) : set (α → M)) = s \ t :=
rfl

instance : boolean_algebra (L.definable_set A α) :=
subtype.coe_injective.boolean_algebra _ coe_sup coe_inf coe_top coe_bot coe_compl coe_sdiff

end definable_set
end language
end first_order


-- 5.8 Exercises
-- #1

-- 3.7 Exercises
-- #3

variable p : Prop

example : ¬ (p ↔ ¬ p) :=
begin
  intro h,
  cases h with h1 h2,
  have hnp : ¬ p := λ hp : p, (h1 hp) hp,
  have hp : p := h2 hnp,
  contradiction,
end


/- The formalism of forcing, following Justin Moore's notes -/

import order.bounded_lattice tactic order.complete_boolean_algebra set_theory.zfc .to_mathlib

open lattice

universe u

@[class]def forcing_notion (α : Type u) : Type u := order_top α

-- @[instance]def has_top_forcing_notion (α : Type u) [H : forcing_notion α] : has_top α := sorry

instance partial_order_of_forcing_notion (α : Type u) [H : forcing_notion α] : partial_order α :=
{ le := H.le,
  lt := H.lt,
  le_refl := H.le_refl,
  le_trans := H.le_trans,
  lt_iff_le_not_le := H.lt_iff_le_not_le,
  le_antisymm := H.le_antisymm }

def order_top.mk {α : Type u} [H₁ : partial_order α] [H₂ : has_top α] (H : ∀ a : α, a ≤ ⊤) : order_top α :=
{ top := ⊤,
  le := (≤),
  lt := (<),
  le_refl := H₁.le_refl,
  le_trans := H₁.le_trans,
  lt_iff_le_not_le := H₁.lt_iff_le_not_le,
  le_antisymm := H₁.le_antisymm,
  le_top := H }

@[instance]example {α : Type u} : forcing_notion (set α) :=
order_top.mk (λ _, le_top)

/- A pfilter is an order-theoretic filter on the partial order α  -/
structure pfilter (α : Type u) [partial_order α] : Type u :=
(X : set α)
(nonempty : X ≠ ∅)
(upward_closed : ∀ (p q : α) (H_le : p ≤ q) (H_mem : p ∈ X), q ∈ X)
(downward_directed : ∀ (p q ∈ X), ∃ r ∈ X, r ≤ p ∧ r ≤ q)

inductive Name (P : Type u) [forcing_notion P] : Type (u+1)
| mk (α : Type u) (A : α → Name) (B : α → P) : Name

postfix `-name`:100 := Name

instance : partial_order punit :=
{ le := λ _ _, true,
  lt := λ _ _, false,
  le_refl := by simp,
  le_trans := by simp,
  lt_iff_le_not_le := by simp,
  le_antisymm := by finish }

instance : has_top punit := ⟨punit.star⟩

instance : forcing_notion punit := order_top.mk (by finish)

instance forcing_notion_complete_boolean_algebra {α : Type u} [complete_boolean_algebra α] : forcing_notion α := order_top.mk (by finish)

--TODO(jesse) rewrite in terms of pSet.rec and Name.rec
def pSet_equiv_trivial_name : pSet.{u} ≃ (punit-name : Type (u+1)) :=
{ to_fun := λ u,
  begin
    induction u with α A ih,
    from ⟨α, ih, λ _, punit.star⟩
  end,
  inv_fun := λ v,
  begin
    induction v with α A B ih,
    from ⟨α, ih⟩
  end,
  left_inv :=
    λ x, by induction x; finish,
  right_inv :=
    λ y, by induction y; finish }

-- def Pcheck {P} [forcing_notion P] : pSet.{u} → (P-name : Type (u+1))
-- | ⟨α, A⟩ := ⟨α, λ a, Pcheck (A a), λ _, ⊤⟩

namespace pfilter

-- note: this will require a smallness argument, since we're going to be reconstructing a type in the ground model

/-
from Moore's "The method of forcing":

If G is any filter and ẋ is any Q-name, define
ẋ(G) recursively by ẋ(G) := { ẏ(G) : ∃p ∈ G (( ẏ, p) ∈ ẋ)}

x ↦ ẋ is a map (Name α).{u} → Type u, parametrized by a pfilter (G : pfilter α)

However, what does it mean for a filter in this case to be generic?
-/
def eval {P : Type u} [forcing_notion P] (𝒢 : pfilter P) : P-name → Type u
| ⟨α, A, B⟩ := Σ p : {a : α // B a ∈ 𝒢.X}, eval (A p.1)

def eval_image {P : Type u} [forcing_notion P] (𝒢 : pfilter P): Type (u + 1) :=
{α // ∃ x, α = eval 𝒢 x} -- this should be our new model of set theory

--TODO 6.8. 6.9, and 6.10 from Moore's notes

-- def foo {P : Type u} [forcing_notion P] (𝒢 : pfilter P)  : pSet.{u} → (eval_image.{u} 𝒢) := λ x, ⟨eval 𝒢 (Pcheck x), ⟨_, rfl⟩⟩

-- now foo is the canonical map from pSet to eval_image
-- need to check that (foo x) is "equivalent" to x again in some way

end pfilter


import game.limits.Blockus_Time
import game.sets.L01defs
import game.sup_inf.GLBprop_if_LUBprop
import game.limits.bounded_if_convergent
import data.real.basic
import tactic.linarith
import game.limits.seq_limitProd
import game.limits.Lemmas

namespace xena -- hide
/-
# Chapter 7 : Limits

## Level 12

Prove the reciprocal property of limits. Good luck.
-/

/-
Lemma : stuff1
{a b : ℝ} (ha : a ≠ 0) (hb : b ≠ 0) : | ( 1 /a - 1 / b) | = | (b - a) / (a * b) |
-/

/-
Lemma : stuff2
{a b : ℝ} (ha : a ≠ 0) (hb : b ≠ 0) :  | (b - a) / ( a * b) | = 1 / (|a| * |b|) * |a - b|
-/

/-
Lemma : stuff3
{a b : ℝ} (ha : a ≠ 0) (hb : b ≠ 0) (pb : 0 < b) (c : a ≥ b) : 1 / a ≤ 1 / b
-/

/-
Lemma : stuff4
{a b c : ℝ} (ha : a ≠ 0) (hb : b ≠ 0) (hc : c ≠ 0) (hab : a ≥ b) : 1 / (a * c) ≤ 1 / (b * c)
-/

/-
Lemma : stuff5
{a b c : ℝ} (ha : 0 < a) (hb : 0 ≤ b) (hc : 0 < c) (hbc : b < c)
-/

local notation `|`x`|` := abs x

lemma lim_recip (b : ℕ → ℝ) (k : ℝ) (hk : k ≠ 0) (hb : is_limit b k) (hbnz : ∀ n : ℕ, b n ≠ 0) :
is_limit (λn , 1 / b n) (1 / k) :=
begin

  apply lim_le_iff_lim_lt.mpr,

  intro ε,
  intro hε,

  unfold_coes,
  have R := lim_nz_ev_bd_away_from_zero,
  have D := R b _ _,
  unfold ev_bd_away_from_zero at D,
  cases D with c hc, cases hc with y hy,
  cases hy with N1 hN1,

  ------
  swap, exact k, swap, exact hk, swap, exact hb,
  -----
  unfold is_limit at hb,
  have H1 := hb(c * |k| * ε),
  have duh4 := abs_pos_of_ne_zero hk,
  have H2 : 0 < (c * |k|), exact mul_pos y duh4,
  have H3 : 0 < (c * |k| * ε), exact mul_pos H2 hε,
  specialize H1 H3, cases H1 with N2 hN2,
  use max N1 N2,

  intros n hn,
  rw max_le_iff at hn,
  cases hn with hn1 hn2,
  have L : | 1 / b n - 1 / k | = | (k - b n) / ( b n * k) |,
  have L1 := hbnz n, revert hk, revert L1, exact stuff1 _ _,

  rw L,
  have L2 : | (k - b n) / ( b n * k) | = 1 / (|b n| * |k|) * |b n - k|, have L1 := hbnz n,
  revert hk, revert L1, exact stuff2 _ _,
  rw L2,

  have L1 := hbnz n,
  have L3 := hN1 n hn1,
  have duh : | b n | ≠ 0, linarith,
  have duh2 : c ≠ 0, linarith,

  have L4 : 1 / |b n| ≤ 1 / c, exact stuff3 duh duh2 y L3,
  have duh3 := abs_nonneg (b n - k),
  have duh4 := abs_pos_of_ne_zero hk,
  have duh5 := abs_nonneg (k),

  have L5 : c * |k| ≤ |b n| * |k|, exact mul_le_mul_right1 duh5 L3,
  have L505 : 0 < |b n|, linarith,
  have L5051 : |k| ≠ 0, linarith,
  have L51 : 0 < c * |k|, exact mul_pos y duh4,
  have L5101 : 0 < (1 : ℝ), linarith,
  have L511 : 0 < 1 / (c * |k|), exact div_pos (L5101) (L51),
  have L512 : 0 ≤ 1 / (c * |k|), exact lt_imp_le L511,
  have L52 : 0 < |b n| * |k|, exact mul_pos L505 duh4,
  have L6 : 1 / (|b n| * |k|) ≤ 1 / (c * |k|), exact stuff4 duh duh2 L5051 L3,
  have L7 : (1 / (|b n| * |k|)) * |b n - k| ≤ (1 / (c * |k|)) * |b n - k|, exact mul_le_mul_right1 duh3 L6,

  have duh6 : |b n - k| < (c * |k| * ε), have H4 := hN2(n), specialize H4 hn2, exact H4,

  have W : 0 < 1 / (c * |k|), linarith,
  have H6 : (1 / (c * |k|)) * |b n - k| < (1 / (c * |k|)) * (c * |k| * ε),
  exact stuff5 L511 duh3 H3 duh6,

  have L65 : (c * |k|) ≠ 0, linarith,
  have H7 : 1 / (c * |k|) * (c * |k| * ε) = ε, exact soul_sucking_deep_sadness hε L65,
  rw H7 at H6,

  have H8 := bs_lemma L505 y duh4 duh3 hε duh L5051 duh2 L3 _,
  swap, have H9 : 1 / (c * |k|) * |b n - k| ≤ ε, exact lt_imp_le H6, exact H9,
  exact H8,

end

end xena


import order.hom.complete_lattice
import program
import order.fixed_points
import .complete_lattice.I
open tv
open order_hom

def xT_propagate (i_pos i_neg : I) : Program -> I
| [] := i_pos
| (r::p) := (i_pos.assign r.head (r.eval_body i_pos i_neg)) ⊔ (xT_propagate p)
def T_propagate (p : Program) (i_neg i_pos : I) : I := xT_propagate i_pos i_neg p

theorem T_monotone (p : Program) (i_neg : I) : monotone (T_propagate p i_neg) := λ a b c, begin
  induction p,
  exact c,
  refine sup_le_sup _ p_ih,
  refine I.assign_step c _,
  exact Rule.eval_body_monotone p_hd i_neg c,
end

def T (p : Program) (i_neg : I) : I →o I := ⟨T_propagate p i_neg, T_monotone p i_neg⟩

lemma T_increasing {p : Program} {i ii : I} : ii <= T p i ii := begin
  induction p, refl,
  exact le_sup_of_le_right p_ih,
end

@[simp] lemma  T_fp_le_eq_iff {p : Program} {i ii : I} : T p i ii <= ii ↔ T p i ii = ii :=
  (iff.intro (λ h, le_antisymm h T_increasing) (λ h, (eq.symm h).ge))

lemma T_fp_eq_unstep {p_tl : Program} {p_hd : Rule}  {i ii : I} (h : i = T (p_hd::p_tl) ii i) : i = T p_tl ii i  :=
  le_antisymm T_increasing (sup_le_iff.mp (le_antisymm_iff.mp h).right).right

lemma T_fp_rule_sat_iff {p : Program} {i ii : I} : i = T p ii i ↔ ∀ r ∈ p, Rule.reduct_satisfied r i ii := begin
  -- ==>
  split; assume h,
  induction p,
  by_contradiction, finish,
  assume r rmem,
  change r.eval_body i ii <= r.eval_head i,
  cases rmem, rw <- rmem at h,
  change i = (λ b, if r.head = b then (r.eval_body i ii) else i b) ⊔ (xT_propagate i ii p_tl) at h,
  cases r.eval_body i ii,
  any_goals { rw h, unfold Rule.eval_head, refine le_sup_iff.mpr _, left, simp },
  exact p_ih (T_fp_eq_unstep h) r rmem,
  -- <==
  refine le_antisymm T_increasing _,
  induction p,
  exact rfl.ge,
  change (i.assign p_hd.head (p_hd.eval_body i ii)) ⊔ (xT_propagate i ii p_tl) <= i,
  apply sup_le_iff.mpr,
  split,
  have h2 := @h p_hd (or.inl rfl), change p_hd.eval_body i ii <= p_hd.eval_head i at h2,
  unfold I.assign,
  refine I.less_than_or_equal.mk _, assume a,
  split_ifs,
  rw <- h_1, exact h2,
  exact rfl.le,
  refine p_ih _, simp at *, assume r rmem, exact h.right r rmem,
end

theorem T_fp_model_iff {p : Program} {i : I} : i = T p i i ↔ p.model i :=
  (iff.intro (λ h, ⟨ T_fp_rule_sat_iff.mp h ⟩)
             (λ h, T_fp_rule_sat_iff.mpr h.p))

def Program.is_local_op (p : Program) (f : I -> I) := ∀ {i : I}, p.localize (f i) = f (p.localize i)

def Program.is_local_biop (p : Program) (f : I -> I -> I) := ∀ {i1 i2 : I}, p.localize (f i1 i2) = f (p.localize i1) (p.localize i2)

lemma I.assign.is_local_op {p : Program} (v : tv) {a : atom} (amem : a ∈ p.atoms) : p.is_local_op (I.assign' a v) := begin
  assume i, unfold I.assign', unfold I.assign, ext,
  unfold Program.localize, simp, unfold localize, split_ifs, repeat{refl},
  rw h_1 at amem, contradiction, repeat{refl},
end

lemma I.sup_right.is_local_biop {p : Program} : p.is_local_biop I.sup := begin
  intros i1 i2, ext a, unfold I.sup, unfold Program.localize, simp, unfold localize, split_ifs, repeat{refl},
end

lemma I.eval.unlocalize {p : Program} {i : I} {atoms : list atom} : (∀ a ∈ atoms, a ∈ p.atoms) -> (p.localize i).eval atoms = i.eval atoms := begin
  intro all_atoms,
  induction atoms, refl,
  unfold I.eval, repeat {rw list.map_cons},
  have atoms_hd_pmem : atoms_hd ∈ p.atoms := all_atoms atoms_hd (list.mem_cons_self atoms_hd atoms_tl),
  have atoms_hd_unchanged : p.localize i atoms_hd = i atoms_hd := by {unfold Program.localize, simp, unfold localize, split_ifs, refl},
  rw atoms_hd_unchanged,
  have rest_eq : list.map ((p.localize) i) atoms_tl = list.map i atoms_tl := begin
    apply atoms_ih, intros b bmem, apply all_atoms, exact list.mem_of_mem_tail bmem,
  end,
  rw rest_eq,
end

lemma Rule.eval_pbody.unlocalize {p : Program} {r : Rule} (i : I) (pmem : r ∈ p) : r.eval_pbody (p.localize i) = r.eval_pbody i := by {
  unfold Rule.eval_pbody, rw I.eval.unlocalize (r.atom_program_mem_pbody pmem) }
lemma Rule.eval_nbody.unlocalize {p : Program} {r : Rule} (i : I) (pmem : r ∈ p) : r.eval_nbody (p.localize i) = r.eval_nbody i := by {
  unfold Rule.eval_nbody, rw I.eval.unlocalize (r.atom_program_mem_nbody pmem) }
lemma Rule.eval_body.unlocalize {p : Program} {r : Rule} (i ii : I) (pmem : r ∈ p) : r.eval_body (p.localize i) (p.localize ii) = r.eval_body i ii := by {
  unfold Rule.eval_body, rw [Rule.eval_pbody.unlocalize i pmem, Rule.eval_nbody.unlocalize ii pmem]}
lemma Rule.eval_body_pos.unlocalize {p : Program} {r : Rule} {i ii : I} (pmem : r ∈ p) : r.eval_body (p.localize i) ii = r.eval_body i ii := by {
  unfold Rule.eval_body, rw [Rule.eval_pbody.unlocalize i pmem]}

lemma T.is_local_op {p : Program} {ii : I} : p.is_local_op (T p ii) := λ i, begin
  have generalized : ∀ {p' : Program}, p ⊆ p' -> (p'.localize) ((T p ii) i) = (T p ii) ((p'.localize) i) := λ p' pss, begin
    unfold T, simp, unfold T_propagate, induction p, refl, unfold xT_propagate, unfold has_sup.sup,
    rw [I.sup_right.is_local_biop, I.assign_eq_assign', I.assign.is_local_op, <-I.assign_eq_assign'],
    have p_hd_mem_p' : p_hd ∈ p' := pss (list.mem_cons_self p_hd p_tl),
    rw [Rule.eval_body_pos.unlocalize p_hd_mem_p'],
    refine sup_eq_sup_split (and.intro rfl _), simp,
    exact p_ih (list.cons_subset.mp pss).right,
    exact Exists.intro p_hd (Exists.intro ((list.cons_subset.mp pss).left) (or.inl rfl)),
  end,
  exact generalized rfl.subset,
end

-- @[reducible]
-- def T_repeat (p : Program) (i_neg : I) : Π(i_pos : I), I
-- | i :=

-- def T_lfp (p : Program) (i_neg : I) := T_repeat p i_neg I.bot

-- theorem T_lfp_lattice_lfp_mp {p : Program} {ii : I} : lfp (T p ii) = T_lfp p ii := begin

-- end

-- example {p : Program} {i : I} : i = lfp (T p i) := begin
--   unfold_coes,
-- end

theorem T_fp_stable_model_iff {p : Program} {i : I}: i = lfp (T p i) ↔ p.stable_model i := begin
split; assume h,
unfold lfp at h, simp at h,
change i = Inf {a : I | (T p i) a = a} at h,
have i_fp : (T p i) i = i := begin
  -- suggest,
end,
refine Program.stable_model.mk (T_fp_model_iff.mp h) _,

end


import freealg

open interactive
open lean.parser
open tactic
open tactic.interactive («let» «have» simp refl)
open freealg

------------------------- Conversion Tactic: [(finset α) or (set α) or boolean_lattice] to [boolean_ring]

lemma finset.inter_is_inf (α : Type) [decidable_eq α] (X Y : finset α) : X ∩ Y = X ⊓ Y := rfl
lemma finset.union_is_sup (α : Type) [decidable_eq α] (X Y : finset α) : X ∪ Y = X ⊔ Y := rfl
lemma finset.empt_is_bot (α : Type) [decidable_eq α] : (finset.has_emptyc.emptyc : finset α) = ⊥ := rfl
lemma finset.subset_is_le (α : Type) [decidable_eq α] (X Y : finset α) : (X ⊆ Y) = (X ≤ Y) := rfl

lemma set.union_is_sup (α : Type) (X Y : set α) : X ∪ Y = X ⊔ Y := rfl
lemma set.inter_is_inf (α : Type) (X Y : set α) : X ∩ Y = X ⊓ Y := rfl
lemma set.empt_is_bot (α : Type) : (set.has_emptyc.emptyc : set α) = ⊥ := rfl
lemma set.univ_is_top (α : Type) : (set.univ : set α) = ⊤ := rfl
lemma set.subset_is_le (α : Type) (X Y : set α) : (X ⊆ Y) = (X ≤ Y) := rfl

lemma ne_is_not_eq {α : Type} [boolean_algebra α] {X Y : α} : (X ≠ Y) = ¬(X = Y) := rfl

meta def to_ring_eqn : tactic unit := do
`[
  try {simp only
  [finset.inter_is_inf, finset.union_is_sup, finset.empt_is_bot, finset.subset_is_le] at *},
  try {simp only
  [set.union_is_sup, set.inter_is_inf, set.empt_is_bot, set.univ_is_top, set.subset_is_le] at *},
  try {simp only
  [top_to_ring, bot_to_ring, symm_diff_to_ring,diff_to_ring, compl_to_ring, le_to_ring] at *},
  try {simp only [inf_to_ring, sup_to_ring] at *},
  try {simp only [ne_is_not_eq] at *},
  try {rw [bring_to_left] at *}
]

#check and

lemma convert_ands {A B A' B' : Prop} :
  A = A' → B = B' → (A ∧ B) = (A' ∧ B') :=
begin
  cc,
end

meta def get_proof_normalization : expr → tactic (expr × expr)
| e := do
  match e with
  | `(%%L ∧ %%R) := do
    (pfLT, pfLE) <- get_proof_normalization L,
    (pfRT, pfRE) <- get_proof_normalization R,
    match (pfLT, pfRT) with
    | (`(_ = %%newL), `(_ = %%newR)) := do
      proof_type <- to_expr ``(%%e = (%%newL ∧ %%newR)),
      proof_expr <- to_expr
        ``(convert_ands %%pfLE %%pfRE :
            %%proof_type),
      return (proof_type, proof_expr)
    | _ := fail "Not here"
    end
   | `(%%A = %%B) := do
    proof_type <- to_expr ``(%%e = (%%A + %%B + 1 = 1)),
    proof_expr <- to_expr ``(bring_to_left : %%proof_type),
    return (proof_type, proof_expr)
  | _ := fail "Not here"
  end

meta def normalize_target : tactic unit := do
  texpr <- target,
  name <- get_unused_name `Hnormal,
  (newTargetExpr, proofTerm) <- get_proof_normalization texpr,
  hypExpr <- assertv name newTargetExpr proofTerm,
  rewrite_target hypExpr,
  clear hypExpr,
  return ()

meta def find_splittable_hyp : tactic expr := do
  hyps <- local_context,
  hyps <- hyps.mfilter (fun hyp,
    (do `(%%A ∧ %%B) <- infer_type hyp,
        return tt)
    <|> return ff),
  match hyps with
  | (x :: xs) := return x
  | [] := fail "No splittable hypothesis found"
  end

meta def split_hyps : tactic unit := do
  repeat $ (do
    hyp <- find_splittable_hyp,
    cases hyp,
    skip)

------------------------------ Normalization Tactics (in a free boolean algebra) -------------------------
meta def ids_list : lean.parser (list name) := types.list_of ident
meta def meta_build_vector : list pexpr -> pexpr
| [] := ``(vector.nil)
| (v :: vs) := ``(vector.cons %%v %%(meta_build_vector vs))
meta def list_with_idx {T : Type} : (list T) → nat -> list (nat × T)
| [] n := []
| (v :: vs) n := (n, v) :: list_with_idx vs (n + 1)

meta def tactic.interactive.introduce_varmap_rewrite (vname : parse ident) (vars : parse ids_list) : tactic unit :=
  do
    names <- vars.mmap (fun name, get_local name),
    («let» vname ``(vector _ %%(vars.length)) $ meta_build_vector (names.map to_pexpr)),
    mmap
      (λ (pair : (nat × expr)),
        let name := prod.snd pair in
        let idx := prod.fst pair in
        do
          vname_expr <- get_local vname,
          hname <- get_unused_name `Hv,
          -- TODO: maybe clean this up with definev/assertv instead.
          («have» hname ``(%%name = _) ``(on_var %%vname_expr %%idx (by norm_num))),
          hname_expr <- get_local hname,
          tactic.try (rewrite_target hname_expr),
          clear hname_expr,
          return ())
      (list_with_idx names 0),
    return ()

meta def find_matching_type (e : expr) : list expr → tactic expr
| []         := tactic.failed
| (H :: Hs)  := do t ← tactic.infer_type H,
                   (tactic.unify e t >> return H) <|> find_matching_type Hs
set_option pp.all false
meta def get_sets_in_expr : expr → tactic (list name)
-- TODO maybe return the expressions themselves as they're less fragile then raw names
-- something something expressions have a unique and a pretty name, which is slightly concerning
-- (maybe).
| e :=
  match e with
  -- This mostly handles basic expressions
  | expr.local_const unique pretty _ _ :=
    do
      expr <- get_local pretty,
      ((do
        `(%%typ) <- tactic.infer_type expr,
        boolalg_hyp <- to_expr ``(infer_instance : boolean_algebra %%typ),
        return [pretty])
      <|>
        return [])
  | expr.app e1 e2 :=
    do l1 <- get_sets_in_expr e1,
       l2 <- get_sets_in_expr e2,
       return (l1 ++ l2)
  | _ := do return []
  end

meta def assert_expr_is_boolalg (e : expr) : tactic unit :=
do
  typ <- tactic.infer_type e,
  boolalg_hyp <- to_expr ``(infer_instance : boolean_algebra %%typ),
  return ()

meta def is_boolalg_eqn : expr → tactic bool
| e :=
  ((do `(%%L = %%R) <- (infer_type e),
    assert_expr_is_boolalg L,
    assert_expr_is_boolalg R,
    return tt)
  <|>
  (do `(%%L ≠ %%R) <- (infer_type e),
    assert_expr_is_boolalg L,
    assert_expr_is_boolalg R,
    return tt)
  <|>
  (do `(¬ %%L = %%R) <- (infer_type e),
    assert_expr_is_boolalg L,
    assert_expr_is_boolalg R,
    return tt)
  <|>
  (return ff))

def keep_unique {T: Type}[decidable_eq T]: list T -> list T
| [] := []
| (x :: xs) := let tl := keep_unique xs in
                if list.mem x tl then tl else x :: tl

/- A bound variable with a de-Bruijn index. -/
-- | var _ := tactic.failed ()
/- A type universe: `Sort u` -/
-- | sort l := do return ()
/- A global constant. These include definitions, constants and inductive type stuff present
in the environment as well as hard-coded definitions. -/
-- | const name l := do return ()
/- [WARNING] Do not trust the types for `mvar` and `local_const`,
they are sometimes dummy values. Use `tactic.infer_type` instead. -/
/- An `mvar` is a 'hole' yet to be filled in by the elaborator or tactic state. -/
-- | mvar unique pretty type := do return ()
/- A local constant. For example, if our tactic state was `h : P ⊢ Q`, `h` would be a local constant. -/
-- | local_const unique pretty binder type := do return ()
/- Function application. -/
-- | app e1 e2 := do return ()
/- Lambda abstraction. eg ```(λ a : α, x)`` -/
-- | lam name binder type body := do return ()
/- Pi type constructor. eg ```(Π a : α, x)`` and ```(α → β)`` -/
-- | pi name binder type body := do return ()
/- An explicit let binding. -/
--| elet name type assignment body := do return ()
/- A macro, see the docstring for `macro_def`.
  The list of expressions are local constants and metavariables that the macro depends on.
  -/
-- | expr.macro macro_def body := do return ()
meta def dummy : tactic unit :=
  do tactic.trace "Hello World"

lemma switch_target {T : Type} [boolean_algebra T] (A B C : T):
  (A = 1) → (A * B = A * C) → B = C :=
  λ h1 h2, by {rw [h1,one_mul, one_mul] at h2, from h2}

-- expects that goal is conjunction of ring equations
-- expects that assumptions are just ring equations
meta def simplify_one_set (extra_sets : list name): tactic unit :=
  do
    -- Convert to ring equations, and also
    -- convert ring hypothesis to be of the form <eqn> = 1

    -- TODO: gather sets from goals and hypothesis evntually
    -- before we convert the goal as that's expensive.
    timetac "rewrite to ring equation" $ to_ring_eqn,
    normalize_target,
    timetac "rewrite ∧ to ring equns" $ try `[apply no_inverses],
    context <- tactic.local_context,
    boolalg_hyps <- timetac "get boolalg hyp" $ context.mfilter is_boolalg_eqn,
    -- Rewrite target to be Π (hypothesis) * original target
    -- Clear original ring hypothesis as they are not needed anymore
    tactic.timetac "rewrite target" $ boolalg_hyps.mmap
      (fun (hyp : expr), do
        `(%%Lh = 1) <- infer_type hyp,
        `(%%Ltarget = %%Rtarget) <- target,
        `[apply (switch_target %%Lh %%Ltarget %%Rtarget %%hyp)],
        return ()
      ),

    -- Gather sets in the goal
    texpr <- target,
    list_of_sets <- timetac "get set names" $ get_sets_in_expr texpr,
    vname <- get_unused_name `V,
    tactic.timetac "rewrite names" $ tactic.interactive.introduce_varmap_rewrite vname
      (keep_unique $ list_of_sets ++ extra_sets),
    vname_expr <- get_local vname,

    -- Some goals are already discharged by this point, so everything else
    -- goes in a try block.
    tactic.timetac "final simp" $
    tactic.try (simp none tt ([``(freealg.on_one %%vname_expr),
                   ``(freealg.on_add %%vname_expr),
                   ``(freealg.on_mul %%vname_expr),
                   ``(freealg.on_zero %%vname_expr),
                   ``(freealg.on_var %%vname_expr)].map simp_arg_type.expr)
                    list.nil loc.wildcard),
    tactic.timetac "evaluate ring stuff" $ tactic.try (refl)

meta def split_goal (solver : tactic unit): tactic unit := do
  texpr <- target,
  match texpr with
  | `(%%A ∨ %%B) := do
    (left >> split_goal <|> right >> split_goal)
  | _ := solver
  end

meta def tactic.interactive.timed_simplify_sets
  (extra_sets : (parse (optional ids_list))): tactic unit :=
    do timetac "simplify sets" $ simplify_one_set (match extra_sets with | some l := l | none := [] end)

lemma fourlemma (T : Type) (A B C D : set T) : A ⊆ B → C ⊆ Bᶜ → D ⊆ Bᶜ → ((A ∩ C = ∅ ) ∧ (A ∩ D = ∅)):=
begin
  intros,
  timed_simplify_sets,
end

--lemma fourtrans (T : Type) (A B C D : set T) : (A ⊆ B) → (B ⊆ C) → (C ⊆ D) → (A ⊆ D) :=
--begin
--  intros,
--  timed_simplify_sets,
--end

--lemma dummylemma (T: Type) (X Y Z : set T) : (T = nat) → (X ⊆ Y) → (X ∩ Z) ⊆ (Y ∩ Z) :=
--begin
--  intros H1 H2,
--  simplify_sets,
--end

--lemma foo_alg2 (α : Type) (A: boolean_algebra α) (X Y Z P Q W: α):
--  (X ⊔ (Y ⊔ Z)) ⊔ ((W ⊓ P ⊓ Q)ᶜ ⊔ (P ⊔ W ⊔ Q)) = ⊤ :=
--begin
--  simplify_sets,
--end


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

! This file was ported from Lean 3 source module control.bifunctor
! leanprover-community/mathlib commit 69c6a5a12d8a2b159f20933e60115a4f2de62b58
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Control.Functor
import Mathbin.Data.Sum.Basic

/-!
# Functors with two arguments

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

This file defines bifunctors.

A bifunctor is a function `F : Type* → Type* → Type*` along with a bimap which turns `F α β` into
`F α' β'` given two functions `α → α'` and `β → β'`. It further
* respects the identity: `bimap id id = id`
* composes in the obvious way: `(bimap f' g') ∘ (bimap f g) = bimap (f' ∘ f) (g' ∘ g)`

## Main declarations

* `bifunctor`: A typeclass for the bare bimap of a bifunctor.
* `is_lawful_bifunctor`: A typeclass asserting this bimap respects the bifunctor laws.
-/

universe u₀ u₁ u₂ v₀ v₁ v₂

open Function

#print Bifunctor /-
/-- Lawless bifunctor. This typeclass only holds the data for the bimap. -/
class Bifunctor (F : Type u₀ → Type u₁ → Type u₂) where
  bimap : ∀ {α α' β β'}, (α → α') → (β → β') → F α β → F α' β'
#align bifunctor Bifunctor
-/

export Bifunctor (bimap)

#print LawfulBifunctor /-
/-- Bifunctor. This typeclass asserts that a lawless `bifunctor` is lawful. -/
class LawfulBifunctor (F : Type u₀ → Type u₁ → Type u₂) [Bifunctor F] where
  id_bimap : ∀ {α β} (x : F α β), bimap id id x = x
  bimap_bimap :
    ∀ {α₀ α₁ α₂ β₀ β₁ β₂} (f : α₀ → α₁) (f' : α₁ → α₂) (g : β₀ → β₁) (g' : β₁ → β₂) (x : F α₀ β₀),
      bimap f' g' (bimap f g x) = bimap (f' ∘ f) (g' ∘ g) x
#align is_lawful_bifunctor LawfulBifunctor
-/

export LawfulBifunctor (id_bimap bimap_bimap)

attribute [higher_order.1bimap_id_id] id_bimap

attribute [higher_order.1bimap_comp_bimap] bimap_bimap

export LawfulBifunctor (bimap_id_id bimap_comp_bimap)

variable {F : Type u₀ → Type u₁ → Type u₂} [Bifunctor F]

namespace Bifunctor

#print Bifunctor.fst /-
/-- Left map of a bifunctor. -/
@[reducible]
def fst {α α' β} (f : α → α') : F α β → F α' β :=
  bimap f id
#align bifunctor.fst Bifunctor.fst
-/

#print Bifunctor.snd /-
/-- Right map of a bifunctor. -/
@[reducible]
def snd {α β β'} (f : β → β') : F α β → F α β' :=
  bimap id f
#align bifunctor.snd Bifunctor.snd
-/

variable [LawfulBifunctor F]

#print Bifunctor.id_fst /-
@[higher_order.1fst_id]
theorem id_fst : ∀ {α β} (x : F α β), fst id x = x :=
  @id_bimap _ _ _
#align bifunctor.id_fst Bifunctor.id_fst
-/

#print Bifunctor.id_snd /-
@[higher_order.1snd_id]
theorem id_snd : ∀ {α β} (x : F α β), snd id x = x :=
  @id_bimap _ _ _
#align bifunctor.id_snd Bifunctor.id_snd
-/

#print Bifunctor.comp_fst /-
@[higher_order.1fst_comp_fst]
theorem comp_fst {α₀ α₁ α₂ β} (f : α₀ → α₁) (f' : α₁ → α₂) (x : F α₀ β) :
    fst f' (fst f x) = fst (f' ∘ f) x := by simp [fst, bimap_bimap]
#align bifunctor.comp_fst Bifunctor.comp_fst
-/

#print Bifunctor.fst_snd /-
@[higher_order.1fst_comp_snd]
theorem fst_snd {α₀ α₁ β₀ β₁} (f : α₀ → α₁) (f' : β₀ → β₁) (x : F α₀ β₀) :
    fst f (snd f' x) = bimap f f' x := by simp [fst, bimap_bimap]
#align bifunctor.fst_snd Bifunctor.fst_snd
-/

#print Bifunctor.snd_fst /-
@[higher_order.1snd_comp_fst]
theorem snd_fst {α₀ α₁ β₀ β₁} (f : α₀ → α₁) (f' : β₀ → β₁) (x : F α₀ β₀) :
    snd f' (fst f x) = bimap f f' x := by simp [snd, bimap_bimap]
#align bifunctor.snd_fst Bifunctor.snd_fst
-/

#print Bifunctor.comp_snd /-
@[higher_order.1snd_comp_snd]
theorem comp_snd {α β₀ β₁ β₂} (g : β₀ → β₁) (g' : β₁ → β₂) (x : F α β₀) :
    snd g' (snd g x) = snd (g' ∘ g) x := by simp [snd, bimap_bimap]
#align bifunctor.comp_snd Bifunctor.comp_snd
-/

attribute [functor_norm]
  bimap_bimap comp_snd comp_fst snd_comp_snd snd_comp_fst fst_comp_snd fst_comp_fst bimap_comp_bimap bimap_id_id fst_id snd_id

end Bifunctor

open Functor

instance : Bifunctor Prod where bimap := @Prod.map

instance : LawfulBifunctor Prod := by refine' { .. } <;> intros <;> cases x <;> rfl

#print Bifunctor.const /-
instance Bifunctor.const : Bifunctor Const where bimap α α' β β f _ := f
#align bifunctor.const Bifunctor.const
-/

#print LawfulBifunctor.const /-
instance LawfulBifunctor.const : LawfulBifunctor Const := by refine' { .. } <;> intros <;> rfl
#align is_lawful_bifunctor.const LawfulBifunctor.const
-/

#print Bifunctor.flip /-
instance Bifunctor.flip : Bifunctor (flip F)
    where bimap α α' β β' f f' x := (bimap f' f x : F β' α')
#align bifunctor.flip Bifunctor.flip
-/

#print LawfulBifunctor.flip /-
instance LawfulBifunctor.flip [LawfulBifunctor F] : LawfulBifunctor (flip F) := by
  refine' { .. } <;> intros <;> simp [bimap, functor_norm]
#align is_lawful_bifunctor.flip LawfulBifunctor.flip
-/

instance : Bifunctor Sum where bimap := @Sum.map

instance : LawfulBifunctor Sum := by refine' { .. } <;> intros <;> cases x <;> rfl

open Bifunctor Functor

#print Bifunctor.functor /-
instance (priority := 10) Bifunctor.functor {α} : Functor (F α) where map _ _ := snd
#align bifunctor.functor Bifunctor.functor
-/

#print Bifunctor.lawfulFunctor /-
instance (priority := 10) Bifunctor.lawfulFunctor [LawfulBifunctor F] {α} : LawfulFunctor (F α) :=
  by refine' { .. } <;> intros <;> simp [Functor.map, functor_norm]
#align bifunctor.is_lawful_functor Bifunctor.lawfulFunctor
-/

section Bicompl

variable (G : Type _ → Type u₀) (H : Type _ → Type u₁) [Functor G] [Functor H]

instance : Bifunctor (bicompl F G H)
    where bimap α α' β β' f f' x := (bimap (map f) (map f') x : F (G α') (H β'))

instance [LawfulFunctor G] [LawfulFunctor H] [LawfulBifunctor F] :
    LawfulBifunctor (bicompl F G H) := by
  constructor <;> intros <;> simp [bimap, map_id, map_comp_map, functor_norm]

end Bicompl

section Bicompr

variable (G : Type u₂ → Type _) [Functor G]

instance : Bifunctor (bicompr G F)
    where bimap α α' β β' f f' x := (map (bimap f f') x : G (F α' β'))

instance [LawfulFunctor G] [LawfulBifunctor F] : LawfulBifunctor (bicompr G F) := by
  constructor <;> intros <;> simp [bimap, functor_norm]

end Bicompr


/-
Copyright (c) 2018 Jeremy Avigad. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Jeremy Avigad

Multivariate polynomial functors.

Note: eventually the W and M constructions as multivariate polynomial functors will go here.
-/
import ..mvfunctor ..pfunctor
import for_mathlib
universes u v

/-
multivariate polynomial functors
-/

structure mvpfunctor (n : ℕ) :=
(A : Type.{u}) (B : A → typevec.{u} n)

namespace mvpfunctor
open mvfunctor (liftp liftr)

variables {n m : ℕ} (P : mvpfunctor.{u} n)

def apply (α : typevec.{u} n) : Type u := Σ a : P.A, P.B a ⟹ α

def map {α β : typevec n} (f : α ⟹ β) : P.apply α → P.apply β :=
λ ⟨a, g⟩, ⟨a, typevec.comp f g⟩

instance : mvfunctor P.apply :=
⟨@mvpfunctor.map n P⟩

theorem map_eq {α β : typevec n} (g : α ⟹ β) (a : P.A) (f : P.B a ⟹ α) :
  @mvfunctor.map _ P.apply _ _ _ g ⟨a, f⟩ = ⟨a, g ⊚ f⟩ :=
rfl

theorem id_map {α : typevec n} : ∀ x : P.apply α, typevec.id <$$> x = x
| ⟨a, g⟩ := rfl

theorem comp_map {α β γ : typevec n} (f : α ⟹ β) (g : β ⟹ γ) :
  ∀ x : P.apply α, (g ⊚ f) <$$> x = g <$$> (f <$$> x)
| ⟨a, h⟩ := rfl

def comp (P : mvpfunctor.{u} n) (Q : fin' n → mvpfunctor.{u} m) : mvpfunctor m :=
{ A := Σ a₂ : P.1, Π i, P.2 a₂ i → (Q i).1,
  B := λ a, λ i, Σ j (b : P.2 a.1 j), (Q j).2 (a.snd j b) i }

variables {P} {Q : fin' n → mvpfunctor.{u} m} {α β : typevec.{u} m}

def comp.mk (x : P.apply (λ i, (Q i).apply α)) : (comp P Q).apply α :=
⟨ ⟨ x.1, λ i a, (x.2 _ a).1  ⟩, λ i a, (x.snd a.fst (a.snd).fst).snd i (a.snd).snd ⟩

def comp.get (x : (comp P Q).apply α) : P.apply (λ i, (Q i).apply α) :=
⟨ x.1.1, λ i a, ⟨x.fst.snd i a, λ (j : fin' m) (b : (Q i).B _ j), x.snd j ⟨i, ⟨a, b⟩⟩⟩ ⟩

lemma comp.get_map (f : α ⟹ β) (x : (comp P Q).apply α) :
  comp.get (f <$$> x) = (λ i (x : (Q i).apply α), f <$$> x) <$$> comp.get x :=
by cases x; refl

@[simp]
lemma comp.get_mk (x : P.apply (λ i, (Q i).apply α)) : comp.get (comp.mk x) = x :=
begin
  cases x,
  simp! [comp.get,comp.mk],
  ext; intros; refl
end

@[simp]
lemma comp.mk_get (x : (comp P Q).apply α) : comp.mk (comp.get x) = x :=
begin
  cases x,
  dsimp [comp.get,comp.mk],
  ext; intros, refl, refl,
  congr, ext; intros; refl,
  ext, congr, rcases x_1 with ⟨a,b,c⟩; refl,
end

/-
lifting predicates and relations
-/

theorem liftp_iff {α : typevec n} (p : Π ⦃i⦄ , α i → Prop) (x : P.apply α) :
  liftp p x ↔ ∃ a f, x = ⟨a, f⟩ ∧ ∀ i j, p (f i j) :=
begin
  split,
  { rintros ⟨y, hy⟩, cases h : y with a f,
    refine ⟨a, λ i j, (f i j).val, _, λ i j, (f i j).property⟩,
    rw [←hy, h, map_eq], refl },
  rintros ⟨a, f, xeq, pf⟩,
  use ⟨a, λ i j, ⟨f i j, pf i j⟩⟩,
  rw [xeq], reflexivity
end

theorem liftr_iff {α : typevec n} (r : Π ⦃i⦄, α i → α i → Prop) (x y : P.apply α) :
  liftr r x y ↔ ∃ a f₀ f₁, x = ⟨a, f₀⟩ ∧ y = ⟨a, f₁⟩ ∧ ∀ i j, r (f₀ i j) (f₁ i j) :=
begin
  split,
  { rintros ⟨u, xeq, yeq⟩, cases h : u with a f,
    use [a, λ i j, (f i j).val.fst, λ i j, (f i j).val.snd],
    split, { rw [←xeq, h], refl },
    split, { rw [←yeq, h], refl },
    intros i j, exact (f i j).property },
  rintros ⟨a, f₀, f₁, xeq, yeq, h⟩,
  use ⟨a, λ i j, ⟨(f₀ i j, f₁ i j), h i j⟩⟩,
  dsimp, split,
  { rw [xeq], refl },
  rw [yeq], refl
end

end mvpfunctor

/-
Decomposing an n+1-ary pfunctor.
-/

namespace mvpfunctor
open typevec
variables {n : ℕ} (P : mvpfunctor.{u} (n+1))

def drop : mvpfunctor n :=
{ A := P.A, B := λ a, (P.B a).drop }

def last : pfunctor :=
{ A := P.A, B := λ a, (P.B a).last }

@[reducible] def append_contents {α : typevec n} {β : Type*}
    {a : P.A} (f' : P.drop.B a ⟹ α) (f : P.last.B a → β) :
  P.B a ⟹ α.append1 β :=
split_fun f' f

end mvpfunctor


/-
Copyright (c) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kevin Buzzard, Scott Morrison, Jakob von Raumer
-/
import category_theory.monoidal.braided
import category_theory.closed.monoidal
import algebra.category.Module.basic
import linear_algebra.tensor_product
import category_theory.linear.yoneda
import category_theory.monoidal.linear

/-!
# The symmetric monoidal category structure on R-modules

Mostly this uses existing machinery in `linear_algebra.tensor_product`.
We just need to provide a few small missing pieces to build the
`monoidal_category` instance and then the `symmetric_category` instance.

Note the universe level of the modules must be at least the universe level of the ring,
so that we have a monoidal unit.
For now, we simplify by insisting both universe levels are the same.

We then construct the monoidal closed structure on `Module R`.

If you're happy using the bundled `Module R`, it may be possible to mostly
use this as an interface and not need to interact much with the implementation details.
-/

universes v w x u

open category_theory

namespace Module

variables {R : Type u} [comm_ring R]

namespace monoidal_category
-- The definitions inside this namespace are essentially private.
-- After we build the `monoidal_category (Module R)` instance,
-- you should use that API.

open_locale tensor_product
local attribute [ext] tensor_product.ext

/-- (implementation) tensor product of R-modules -/
def tensor_obj (M N : Module R) : Module R := Module.of R (M ⊗[R] N)
/-- (implementation) tensor product of morphisms R-modules -/
def tensor_hom {M N M' N' : Module R} (f : M ⟶ N) (g : M' ⟶ N') :
  tensor_obj M M' ⟶ tensor_obj N N' :=
tensor_product.map f g

lemma tensor_id (M N : Module R) : tensor_hom (𝟙 M) (𝟙 N) = 𝟙 (Module.of R (M ⊗ N)) :=
by { ext1, refl }

lemma tensor_comp {X₁ Y₁ Z₁ X₂ Y₂ Z₂ : Module R}
  (f₁ : X₁ ⟶ Y₁) (f₂ : X₂ ⟶ Y₂) (g₁ : Y₁ ⟶ Z₁) (g₂ : Y₂ ⟶ Z₂) :
    tensor_hom (f₁ ≫ g₁) (f₂ ≫ g₂) = tensor_hom f₁ f₂ ≫ tensor_hom g₁ g₂ :=
by { ext1, refl }

/-- (implementation) the associator for R-modules -/
def associator (M : Module.{v} R) (N : Module.{w} R) (K : Module.{x} R) :
  tensor_obj (tensor_obj M N) K ≅ tensor_obj M (tensor_obj N K) :=
(tensor_product.assoc R M N K).to_Module_iso

section

/-! The `associator_naturality` and `pentagon` lemmas below are very slow to elaborate.

We give them some help by expressing the lemmas first non-categorically, then using
`convert _aux using 1` to have the elaborator work as little as possible. -/

open tensor_product (assoc map)

private lemma associator_naturality_aux
  {X₁ X₂ X₃ : Type*}
  [add_comm_monoid X₁] [add_comm_monoid X₂] [add_comm_monoid X₃]
  [module R X₁] [module R X₂] [module R X₃]
  {Y₁ Y₂ Y₃ : Type*}
  [add_comm_monoid Y₁] [add_comm_monoid Y₂] [add_comm_monoid Y₃]
  [module R Y₁] [module R Y₂] [module R Y₃]
  (f₁ : X₁ →ₗ[R] Y₁) (f₂ : X₂ →ₗ[R] Y₂) (f₃ : X₃ →ₗ[R] Y₃) :
  (↑(assoc R Y₁ Y₂ Y₃) ∘ₗ (map (map f₁ f₂) f₃)) = ((map f₁ (map f₂ f₃)) ∘ₗ ↑(assoc R X₁ X₂ X₃)) :=
begin
  apply tensor_product.ext_threefold,
  intros x y z,
  refl
end

variables (R)

private lemma pentagon_aux
  (W X Y Z : Type*)
  [add_comm_monoid W] [add_comm_monoid X] [add_comm_monoid Y] [add_comm_monoid Z]
  [module R W] [module R X] [module R Y] [module R Z] :
  ((map (1 : W →ₗ[R] W) (assoc R X Y Z).to_linear_map).comp (assoc R W (X ⊗[R] Y) Z).to_linear_map)
    .comp (map ↑(assoc R W X Y) (1 : Z →ₗ[R] Z)) =
  (assoc R W X (Y ⊗[R] Z)).to_linear_map.comp (assoc R (W ⊗[R] X) Y Z).to_linear_map :=
begin
  apply tensor_product.ext_fourfold,
  intros w x y z,
  refl
end

end

lemma associator_naturality {X₁ X₂ X₃ Y₁ Y₂ Y₃ : Module R}
  (f₁ : X₁ ⟶ Y₁) (f₂ : X₂ ⟶ Y₂) (f₃ : X₃ ⟶ Y₃) :
    tensor_hom (tensor_hom f₁ f₂) f₃ ≫ (associator Y₁ Y₂ Y₃).hom =
    (associator X₁ X₂ X₃).hom ≫ tensor_hom f₁ (tensor_hom f₂ f₃) :=
by convert associator_naturality_aux f₁ f₂ f₃ using 1

lemma pentagon (W X Y Z : Module R) :
  tensor_hom (associator W X Y).hom (𝟙 Z) ≫ (associator W (tensor_obj X Y) Z).hom
  ≫ tensor_hom (𝟙 W) (associator X Y Z).hom =
    (associator (tensor_obj W X) Y Z).hom ≫ (associator W X (tensor_obj Y Z)).hom :=
by convert pentagon_aux R W X Y Z using 1

/-- (implementation) the left unitor for R-modules -/
def left_unitor (M : Module.{u} R) : Module.of R (R ⊗[R] M) ≅ M :=
(linear_equiv.to_Module_iso (tensor_product.lid R M) : of R (R ⊗ M) ≅ of R M).trans (of_self_iso M)

/-- (implementation) the right unitor for R-modules -/
def right_unitor (M : Module.{u} R) : Module.of R (M ⊗[R] R) ≅ M :=
(linear_equiv.to_Module_iso (tensor_product.rid R M) : of R (M ⊗ R) ≅ of R M).trans (of_self_iso M)

lemma right_unitor_naturality {M N : Module R} (f : M ⟶ N) :
  tensor_hom f (𝟙 (Module.of R R)) ≫ (right_unitor N).hom = (right_unitor M).hom ≫ f :=
begin
  ext x y, dsimp,
  erw [tensor_product.rid_tmul, tensor_product.rid_tmul],
  rw linear_map.map_smul,
  refl,
end

lemma triangle (M N : Module.{u} R) :
  (associator M (Module.of R R) N).hom ≫ tensor_hom (𝟙 M) (left_unitor N).hom =
    tensor_hom (right_unitor M).hom (𝟙 N) :=
begin
  apply tensor_product.ext_threefold,
  intros x y z,
  change R at y,
  dsimp [tensor_hom, associator],
  erw [tensor_product.lid_tmul, tensor_product.rid_tmul],
  exact (tensor_product.smul_tmul _ _ _).symm
end

end monoidal_category

open monoidal_category

instance monoidal_category : monoidal_category (Module.{u} R) :=
{ -- data
  tensor_obj   := tensor_obj,
  tensor_hom   := @tensor_hom _ _,
  tensor_unit  := Module.of R R,
  associator   := associator,
  left_unitor  := left_unitor,
  right_unitor := right_unitor,
  -- properties
  tensor_id'               := λ M N, tensor_id M N,
  tensor_comp'             := λ M N K M' N' K' f g h, tensor_comp f g h,
  associator_naturality'   := λ M N K M' N' K' f g h, associator_naturality f g h,
  left_unitor_naturality'  := λ M N f, left_unitor_naturality f,
  right_unitor_naturality' := λ M N f, right_unitor_naturality f,
  pentagon'                := λ M N K L, pentagon M N K L,
  triangle'                := λ M N, triangle M N, }

/-- Remind ourselves that the monoidal unit, being just `R`, is still a commutative ring. -/
instance : comm_ring ((𝟙_ (Module.{u} R) : Module.{u} R) : Type u) :=
(by apply_instance : comm_ring R)

namespace monoidal_category

@[simp]
lemma hom_apply {K L M N : Module.{u} R} (f : K ⟶ L) (g : M ⟶ N) (k : K) (m : M) :
  (f ⊗ g) (k ⊗ₜ m) = f k ⊗ₜ g m := rfl

@[simp]
lemma left_unitor_hom_apply {M : Module.{u} R} (r : R) (m : M) :
  ((λ_ M).hom : 𝟙_ (Module R) ⊗ M ⟶ M) (r ⊗ₜ[R] m) = r • m :=
tensor_product.lid_tmul m r

@[simp]
lemma left_unitor_inv_apply {M : Module.{u} R} (m : M) :
  ((λ_ M).inv : M ⟶ 𝟙_ (Module.{u} R) ⊗ M) m = 1 ⊗ₜ[R] m :=
tensor_product.lid_symm_apply m

@[simp]
lemma right_unitor_hom_apply {M : Module.{u} R} (m : M) (r : R) :
  ((ρ_ M).hom : M ⊗ 𝟙_ (Module R) ⟶ M) (m ⊗ₜ r) = r • m :=
tensor_product.rid_tmul m r

@[simp]
lemma right_unitor_inv_apply {M : Module.{u} R} (m : M) :
  ((ρ_ M).inv : M ⟶ M ⊗ 𝟙_ (Module.{u} R)) m = m ⊗ₜ[R] 1 :=
tensor_product.rid_symm_apply m

@[simp]
lemma associator_hom_apply {M N K : Module.{u} R} (m : M) (n : N) (k : K) :
  ((α_ M N K).hom : (M ⊗ N) ⊗ K ⟶ M ⊗ (N ⊗ K)) ((m ⊗ₜ n) ⊗ₜ k) = (m ⊗ₜ (n ⊗ₜ k)) := rfl

@[simp]
lemma associator_inv_apply {M N K : Module.{u} R} (m : M) (n : N) (k : K) :
  ((α_ M N K).inv : M ⊗ (N ⊗ K) ⟶ (M ⊗ N) ⊗ K) (m ⊗ₜ (n ⊗ₜ k)) = ((m ⊗ₜ n) ⊗ₜ k) := rfl

end monoidal_category

/-- (implementation) the braiding for R-modules -/
def braiding (M N : Module R) : tensor_obj M N ≅ tensor_obj N M :=
linear_equiv.to_Module_iso (tensor_product.comm R M N)

@[simp] lemma braiding_naturality {X₁ X₂ Y₁ Y₂ : Module.{u} R} (f : X₁ ⟶ Y₁) (g : X₂ ⟶ Y₂) :
  (f ⊗ g) ≫ (Y₁.braiding Y₂).hom =
    (X₁.braiding X₂).hom ≫ (g ⊗ f) :=
begin
  apply tensor_product.ext',
  intros x y,
  refl
end

@[simp] lemma hexagon_forward (X Y Z : Module.{u} R) :
  (α_ X Y Z).hom ≫ (braiding X _).hom ≫ (α_ Y Z X).hom =
  ((braiding X Y).hom ⊗ 𝟙 Z) ≫ (α_ Y X Z).hom ≫ (𝟙 Y ⊗ (braiding X Z).hom) :=
begin
  apply tensor_product.ext_threefold,
  intros x y z,
  refl,
end

@[simp] lemma hexagon_reverse (X Y Z : Module.{u} R) :
  (α_ X Y Z).inv ≫ (braiding _ Z).hom ≫ (α_ Z X Y).inv =
  (𝟙 X ⊗ (Y.braiding Z).hom) ≫ (α_ X Z Y).inv ≫ ((X.braiding Z).hom ⊗ 𝟙 Y) :=
begin
  apply (cancel_epi (α_ X Y Z).hom).1,
  apply tensor_product.ext_threefold,
  intros x y z,
  refl,
end

local attribute [ext] tensor_product.ext

/-- The symmetric monoidal structure on `Module R`. -/
instance symmetric_category : symmetric_category (Module.{u} R) :=
{ braiding := braiding,
  braiding_naturality' := λ X₁ X₂ Y₁ Y₂ f g, braiding_naturality f g,
  hexagon_forward' := hexagon_forward,
  hexagon_reverse' := hexagon_reverse, }

namespace monoidal_category

@[simp] lemma braiding_hom_apply {M N : Module.{u} R} (m : M) (n : N) :
  ((β_ M N).hom : M ⊗ N ⟶ N ⊗ M) (m ⊗ₜ n) = n ⊗ₜ m := rfl

@[simp] lemma braiding_inv_apply {M N : Module.{u} R} (m : M) (n : N) :
  ((β_ M N).inv : N ⊗ M ⟶ M ⊗ N) (n ⊗ₜ m) = m ⊗ₜ n := rfl

end monoidal_category

open opposite

instance : monoidal_preadditive (Module.{u} R) :=
by refine ⟨_, _, _, _⟩; dsimp only [auto_param]; intros;
  refine tensor_product.ext (linear_map.ext $ λ x, linear_map.ext $ λ y, _);
  simp only [linear_map.compr₂_apply, tensor_product.mk_apply, monoidal_category.hom_apply,
    linear_map.zero_apply, tensor_product.tmul_zero, tensor_product.zero_tmul,
    linear_map.add_apply, tensor_product.tmul_add, tensor_product.add_tmul]

instance : monoidal_linear R (Module.{u} R) :=
by refine ⟨_, _⟩; dsimp only [auto_param]; intros;
  refine tensor_product.ext (linear_map.ext $ λ x, linear_map.ext $ λ y, _);
  simp only [linear_map.compr₂_apply, tensor_product.mk_apply, monoidal_category.hom_apply,
    linear_map.smul_apply, tensor_product.tmul_smul, tensor_product.smul_tmul]

/--
Auxiliary definition for the `monoidal_closed` instance on `Module R`.
(This is only a separate definition in order to speed up typechecking. )
-/
@[simps]
def monoidal_closed_hom_equiv (M N P : Module.{u} R) :
  ((monoidal_category.tensor_left M).obj N ⟶ P) ≃
    (N ⟶ ((linear_coyoneda R (Module R)).obj (op M)).obj P) :=
{ to_fun := λ f, linear_map.compr₂ (tensor_product.mk R N M) ((β_ N M).hom ≫ f),
  inv_fun := λ f, (β_ M N).hom ≫ tensor_product.lift f,
  left_inv := λ f, begin ext m n,
    simp only [tensor_product.mk_apply, tensor_product.lift.tmul, linear_map.compr₂_apply,
      function.comp_app, coe_comp, monoidal_category.braiding_hom_apply],
  end,
  right_inv := λ f, begin ext m n,
    simp only [tensor_product.mk_apply, tensor_product.lift.tmul, linear_map.compr₂_apply,
      symmetric_category.symmetry_assoc],
  end, }

instance : monoidal_closed (Module.{u} R) :=
{ closed' := λ M,
  { is_adj :=
    { right := (linear_coyoneda R (Module.{u} R)).obj (op M),
      adj := adjunction.mk_of_hom_equiv
      { hom_equiv := λ N P, monoidal_closed_hom_equiv M N P, } } } }

lemma ihom_map_apply {M N P : Module.{u} R} (f : N ⟶ P) (g : Module.of R (M ⟶ N)) :
  (ihom M).map f g = g ≫ f := rfl

-- I can't seem to express the function coercion here without writing `@coe_fn`.
@[simp]
lemma monoidal_closed_curry {M N P : Module.{u} R} (f : M ⊗ N ⟶ P) (x : M) (y : N) :
  @coe_fn _ _ linear_map.has_coe_to_fun ((monoidal_closed.curry f : N →ₗ[R] (M →ₗ[R] P)) y) x =
    f (x ⊗ₜ[R] y) :=
rfl

@[simp]
lemma monoidal_closed_uncurry {M N P : Module.{u} R}
  (f : N ⟶ (M ⟶[Module.{u} R] P)) (x : M) (y : N) :
  monoidal_closed.uncurry f (x ⊗ₜ[R] y) = (@coe_fn _ _ linear_map.has_coe_to_fun (f y)) x :=
rfl

/-- Describes the counit of the adjunction `M ⊗ - ⊣ Hom(M, -)`. Given an `R`-module `N` this
should give a map `M ⊗ Hom(M, N) ⟶ N`, so we flip the order of the arguments in the identity map
`Hom(M, N) ⟶ (M ⟶ N)` and uncurry the resulting map `M ⟶ Hom(M, N) ⟶ N.` -/
lemma ihom_ev_app (M N : Module.{u} R) :
  (ihom.ev M).app N = tensor_product.uncurry _ _ _ _ linear_map.id.flip :=
begin
  ext,
  exact Module.monoidal_closed_uncurry _ _ _,
end

/-- Describes the unit of the adjunction `M ⊗ - ⊣ Hom(M, -)`. Given an `R`-module `N` this should
define a map `N ⟶ Hom(M, M ⊗ N)`, which is given by flipping the arguments in the natural
`R`-bilinear map `M ⟶ N ⟶ M ⊗ N`. -/
lemma ihom_coev_app (M N : Module.{u} R) :
  (ihom.coev M).app N = (tensor_product.mk _ _ _).flip :=
rfl

lemma monoidal_closed_pre_app {M N : Module.{u} R} (P : Module.{u} R) (f : N ⟶ M) :
  (monoidal_closed.pre f).app P = linear_map.lcomp R _ f :=
rfl

end Module