import combinatorics.simple_graph.basic combinatorics.simple_graph.connectivity data.set.basic
import graph_theory.basic
open function set classical

variables {V V' V'' : Type*} {x y z : V} {x' y' z' : V'} {f : V → V'} {g : V' → V''}
variables {G G₁ G₂ : simple_graph V} {G' G'₁ G'₂ : simple_graph V'} {G'' : simple_graph V''}

namespace simple_graph

def pull (f : V → V') (G' : simple_graph V') : simple_graph V :=
{ adj := G'.adj on f,
  symm := λ _ _ h, G'.symm h,
  loopless := λ _, G'.loopless _ }

namespace pull
lemma comp : pull (g ∘ f) = pull f ∘ pull g :=
by { ext x y, exact iff.rfl }

def to_iso (f : V ≃ V') (G' : simple_graph V') : pull f G' ≃g G' :=
⟨f,λ x y, iff.rfl⟩

lemma from_iso (φ : G ≃g G') : pull φ G' = G :=
by { ext x y, have := φ.map_rel_iff', exact this }

lemma mono : monotone (pull f) :=
by { intros G'₁ G'₂ h x' y', apply h }
end pull

-- TODO: this is an alternative definition for pull
def pull' (f : V → V') (G' : simple_graph V') : simple_graph V :=
{ adj := λ x y, x ≠ y ∧ (f x = f y ∨ G'.adj (f x) (f y)),
  symm := λ x y ⟨h₁,h₂⟩, by { refine ⟨h₁.symm,_⟩, cases h₂, left, exact h₂.symm,
    right, exact h₂.symm },
  loopless := λ x, by { push_neg, intro, contradiction } }

namespace pull'
lemma comp : pull' (g ∘ f) = pull' f ∘ pull' g :=
begin
  ext G'' x y, split,
  { rintros ⟨h₁,h₂⟩, refine ⟨h₁,_⟩, by_cases f x = f y,
    { left, exact h },
    { right, exact ⟨h,h₂⟩ } },
  { rintros ⟨h₁,h₂⟩, refine ⟨h₁,_⟩, cases h₂,
    { left, convert congr_arg g h₂ },
    { rcases h₂ with ⟨h₃,h₄⟩, cases h₄, left, exact h₄, right, exact h₄ } }
end

lemma iff_pull_of_inj (hf : injective f) : pull f G' = pull' f G' :=
begin
  ext x y, split,
  { intro h₁, refine ⟨simple_graph.ne_of_adj _ h₁,_⟩, right, exact h₁ },
  { rintros ⟨h₁,h₂⟩, cases h₂, have := hf h₂, contradiction, exact h₂ }
end

def to_iso (f : V ≃ V') (G' : simple_graph V') : pull' f G' ≃g G' :=
by { rewrite ← iff_pull_of_inj f.injective, apply pull.to_iso }

lemma from_iso (φ : G ≃g G') : pull' φ G' = G :=
by { rewrite ← iff_pull_of_inj φ.injective, apply pull.from_iso }

lemma mono : monotone (pull' f) :=
by { rintros G H h x y ⟨h₁,h₂⟩, refine ⟨h₁,_⟩, cases h₂, left, exact h₂, right, exact h h₂ }
end pull'

@[ext] def map (f : V → V') (G : simple_graph V) : simple_graph V' :=
{ adj := ne ⊓ relation.map G.adj f f,
  symm := λ x y ⟨h₁,u,v,h₂,h₃,h₄⟩, ⟨h₁.symm,v,u,h₂.symm,h₄,h₃⟩,
  loopless := λ _ ⟨h,_⟩, h rfl }

namespace map
noncomputable instance : decidable_rel (map f G).adj := by { classical, apply_instance }

@[simp] lemma id : map id G = G :=
begin
  ext : 1,
  simp only [map, relation.map, id.def, exists_eq_right_right, exists_eq_right, inf_eq_right],
  apply ne_of_adj,
end

lemma adj (f : V → V') : G.adj x y → f x = f y ∨ (map f G).adj (f x) (f y) :=
by { intro h₁, by_cases f x = f y, left, exact h, right, refine ⟨h,x,y,h₁,rfl,rfl⟩ }

lemma comp : map (g ∘ f) = map g ∘ map f :=
begin
  ext G x'' y'', split,
  { rintro ⟨h₁,u,v,h₂,rfl,rfl⟩, exact ⟨h₁,f u,f v,⟨ne_of_apply_ne _ h₁,u,v,h₂,rfl,rfl⟩,rfl,rfl⟩ },
  { rintro ⟨h₁,x',y',⟨h₂,x,y,h₃,rfl,rfl⟩,rfl,rfl⟩, exact ⟨h₁,x,y,h₃,rfl,rfl⟩ }
end

lemma left_inverse_of_injective (h : injective f) : left_inverse (pull f) (map f) :=
begin
  intro G, ext x y, split,
  { rintro ⟨h₁,u,v,h₂,h₃,h₄⟩, rw [←h h₃, ←h h₄], exact h₂ },
  { intro h₁, exact ⟨h.ne (G.ne_of_adj h₁),x,y,h₁,rfl,rfl⟩ }
end

lemma left_inverse_of_injective' (h : injective f) : left_inverse (pull' f) (map f) :=
begin
  intro G, ext x y, split,
  { rintro ⟨h₁,h₂⟩, cases h₂, have := h h₂, contradiction,
    rcases h₂ with ⟨h₂,x',y',h₃,h₄,h₅⟩, rwa [←h h₄, ←h h₅] },
  { intro h₁, refine ⟨G.ne_of_adj h₁, _⟩, by_cases h₂ : f x = f y,
    left, exact h₂, right, exact ⟨h₂,x,y,h₁,rfl,rfl⟩ }
end

lemma right_inverse_of_surjective (h : surjective f) : right_inverse (pull f) (map f) :=
begin
  intro G', ext x' y', split,
  { rintro ⟨-,x,y,h₂,rfl,rfl⟩, exact h₂ },
  { intro h₁, cases h x' with x, cases h y' with y, substs x' y',
    exact ⟨G'.ne_of_adj h₁,x,y,h₁,rfl,rfl⟩ }
end

lemma right_inverse_of_surjective' (h : surjective f) : right_inverse (pull' f) (map f) :=
begin
  intro G', ext x' y', split,
  { rintro ⟨h₁,x,y,⟨-,h₃⟩,rfl,rfl⟩, cases h₃, contradiction, exact h₃ },
  { intro h₁, cases h x' with x, cases h y' with y, substs x' y',
    refine ⟨G'.ne_of_adj h₁,x,y,_,rfl,rfl⟩, refine ⟨_,_⟩, intro h₂,
    exact G'.ne_of_adj h₁ (congr_arg f h₂), right, exact h₁ }
end

def to_iso (f : V ≃ V') (G : simple_graph V) : G ≃g map f G :=
by { convert ← pull.to_iso f _, apply left_inverse_of_injective f.left_inv.injective }

lemma from_iso (φ : G ≃g G') : G' = map φ G :=
by { convert ← congr_arg _ (pull.from_iso φ),
  apply right_inverse_of_surjective φ.right_inv.surjective }

lemma mono : monotone (map f) :=
by { rintros G₁ G₂ h₁ x' y' ⟨h₂,x,y,h₃,rfl,rfl⟩, exact ⟨h₂,x,y,h₁ h₃,rfl,rfl⟩ }

lemma le {φ : G →g G'} : map φ G ≤ G' :=
by { rintros x' y' ⟨-,x,y,h₂,rfl,rfl⟩, exact φ.map_rel h₂ }

end map

def merge_edge [decidable_eq V] {G : simple_graph V} (e : G.dart) : V → V :=
update id e.snd e.fst

def contract_edge (G : simple_graph V) [decidable_eq V] (e : G.dart) :=
G.map (merge_edge e)

infix ` / ` := contract_edge

noncomputable instance {G : simple_graph V} [decidable_eq V] {e : G.dart} :
  decidable_rel (G/e).adj :=
by { classical, apply_instance }

namespace contract_edge
variables [fintype V] [decidable_eq V] [decidable_eq V'] [decidable_rel G.adj]

@[reducible] def preserved (f : V → V') (G : simple_graph V) : Type* :=
{e : G.dart // f e.fst ≠ f e.snd}

def proj_edge (e : G.dart) : preserved (merge_edge e) G → (G/e).dart :=
λ ⟨⟨⟨x,y⟩,hxy⟩,h₁⟩, ⟨(merge_edge e x, merge_edge e y), ⟨h₁,x,y,hxy,rfl,rfl⟩⟩

lemma proj_edge_surj {e : G.dart} : surjective (proj_edge e) :=
begin
  rintro ⟨⟨x',y'⟩,⟨h₁,⟨x,y,h₂,h₃,h₄⟩⟩⟩, refine ⟨⟨⟨(x,y),h₂⟩,_⟩,_⟩,
  { rw [h₃,h₄], exact h₁ },
  { simp only [proj_edge, prod.mk.inj_iff], exact ⟨h₃,h₄⟩ }
end

lemma fewer_edges {e : G.dart} [decidable_rel (G/e).adj] :
  fintype.card (G/e).dart < fintype.card G.dart :=
calc fintype.card (G/e).dart ≤ fintype.card (preserved (merge_edge e) G) :
  fintype.card_le_of_surjective _ proj_edge_surj
                        ...  < fintype.card (G.dart) :
  by { apply fintype.card_lt_of_injective_of_not_mem _ subtype.coe_injective,
    swap, exact e, simp [merge_edge,update] }

end contract_edge

def select (P : V → Prop) (G : simple_graph V) : simple_graph (subtype P) :=
pull subtype.val G

namespace select
variables {P : V → Prop} {P' : V' → Prop}

lemma mono {P : V → Prop} : monotone (select P) :=
by { apply pull.mono }

def fmap (f : V → V') (P' : V' → Prop) : {x : V // P' (f x)} → {x' : V' // P' x'} :=
λ x, ⟨f x, x.prop⟩

def push_walk (p : walk G x y) (hp : ∀ z ∈ p.support, P z) :
  walk (select P G) ⟨x, hp x (walk.start_mem_support p)⟩ ⟨y, hp y (walk.end_mem_support p)⟩ :=
begin
  induction p with a a b c h₁ p ih, refl,
  have hp' : ∀ z ∈ p.support, P z := by { intros z hz, apply hp, right, exact hz },
  refine walk.cons _ (ih hp'), exact h₁
end

lemma mem_push_walk {p : G.walk x y} {hp : ∀ z ∈ p.support, P z} {z' : subtype P} :
  z' ∈ (push_walk p hp).support ↔ z'.val ∈ p.support :=
begin
  induction p with a a b c h₁ p ih,
  { simp [push_walk, subtype.ext_iff, subtype.coe_mk] },
  { split,
    { rintro (h|h), left, subst h, right, exact ih.mp h },
    { rintro (h|h), left, subst h, simp, right, exact ih.mpr h } }
end

def pull_walk {x y} (p : walk (select P G) x y) : walk G x.val y.val :=
by { induction p with a a b c h₁ p ih, refl, refine walk.cons h₁ ih }

lemma pull_walk_spec {x y} (p : walk (select P G) x y) : ∀ z ∈ (pull_walk p).support, P z :=
begin
  induction p with a a b c h₁ p ih,
  { intros z hz, cases hz, rw hz, exact a.prop, cases hz },
  { intros z hz, cases hz, rw hz, exact a.prop, exact ih z hz }
end

end select

namespace is_smaller

lemma select_left {pred : V → Prop} : G ≼s G' -> select pred G ≼s G' :=
λ ⟨⟨f,h₁⟩,h₂⟩,
let g : {x // pred x} -> V' := f ∘ subtype.val
in ⟨⟨g,λ a b,h₁⟩,h₂.comp subtype.val_injective⟩

end is_smaller

def embed (f : V → V') : simple_graph V → simple_graph (range f) :=
select (range f) ∘ map f

namespace embed
noncomputable def iso (f_inj : injective f) : G ≃g embed f G :=
let φ : V → range f := λ x, ⟨f x, x, rfl⟩,
    ψ : range f → V := λ y, some y.prop in
{ to_fun := φ,
  inv_fun := ψ,
  left_inv := λ x, f_inj (some_spec (subtype.prop (φ x))),
  right_inv := λ y, subtype.ext (some_spec y.prop),
  map_rel_iff' := λ a b, by { dsimp only [φ], split,
  { rintros ⟨-,x,y,h₂,h₃,h₄⟩, rwa [←f_inj h₃, ←f_inj h₄] },
  { intro h₁, refine ⟨f_inj.ne (G.ne_of_adj h₁),a,b,h₁,rfl,rfl⟩ } } }

lemma le_select {f : G →g G'} (f_inj : injective f) : embed f G ≤ select (range f) G' :=
select.mono map.le

end embed
end simple_graph


example (P Q R S T U: Type) (p: P) (h: P → Q) (i: Q → R) (j: Q → T) (k: S → T) (l: T → U) : U :=
begin
    have q := h(p),
    have t := j(q),
    have u := l(t),
    exact u,
end


import util.meta.tactic
import util.cast
import util.logic
import data.pfun

import data.stream

universes u v w

open nat function

namespace coind

local attribute [instance, priority 0] classical.prop_decidable

@[congr]
lemma pi_congr_eq {a : Sort u} {p q : a → Sort v} (h : ∀ x, p x = q x)
: (Π x, p x) = Π x, q x :=
congr_arg (λ r : a → Sort v, ∀ x, r x) (funext h)

prefix `♯`:0 := cast (by simp [*] <|> cc <|> solve_by_elim)

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

/-
coinductive ind {α : Type u} (β : α → Type v) : Type (max u v)
| intro : ∀ a, (β a → ind) → ind
-/

inductive cofix' : ℕ → Type (max u v)
| continue : cofix' 0
| intro {n} : ∀ a, (β a → cofix' n) → cofix' (succ n)

variables {β}

def head' : Π {n}, cofix' β (succ n) → α
 | n (cofix'.intro i _) := i

def children' : Π {n} (x : cofix' β (succ n)), (β (head' x) → cofix' β n)
 | n (cofix'.intro _ f) := f

def agree
: ∀ {n : ℕ}, cofix' β n → cofix' β (n+1) → Prop
 | 0 continue _ := true
 | n (cofix'.intro x y) (cofix'.intro x' y') :=
   x = x' ∧ ∀ i j : β _, i == j → agree (y i) (y' j)

@[simp]
lemma agree_trival {x : cofix' β 0} {y : cofix' β 1}
: agree x y :=
by { cases x, trivial }

lemma agree_def {n : ℕ} (x : cofix' β (succ n)) (y : cofix' β (succ n+1))
  (h₀ : head' x = head' y)
  (h₁ : ∀ (i : β _) (j : β _), i == j → agree (children' x i) (children' y j))
: agree x y :=
begin
  cases x, cases y,
  unfold agree,
  cases h₀,
  existsi rfl,
  unfold children' at h₁,
  intro, apply h₁,
end

lemma agree_children {n : ℕ} (x : cofix' β (succ n)) (y : cofix' β (succ n+1))
  {i j}
  (h₀ : i == j)
  (h₁ : agree x y)
: agree (children' x i) (children' y j) :=
begin
  cases x, cases y,
  unfold agree at h₁,
  cases h₁ with h h₁, subst x_a,
  unfold children',
  cases h₀, apply h₁,
  assumption,
end

def truncate {α : Type u} {β : α → Type v}
: ∀ {n : ℕ}, cofix' β (n+1) → cofix' β n
 | 0 (cofix'.intro _ _) := cofix'.continue _
 | (succ n) (cofix'.intro i f) := cofix'.intro i $ truncate ∘ f

structure cofix  {α : Type u} (β : α → Type v) : Type (max u v) :=
  (approx : ∀ n, cofix' β n)
  (consistent : ∀ n, agree (approx n) (approx $ succ n))

lemma truncate_eq_of_agree {α : Type u} {β : α → Type v} {n : ℕ}
  (x : cofix' β n)
  (y : cofix' β (succ n))
  (h : agree x y)
: truncate y = x :=
begin
  revert x y,
  induction n
  ; intros x y
  ; cases x ; cases y,
  { intro h', refl },
  { simp [agree,truncate,exists_imp_iff_forall_imp],
    introv h₀ h₁,
    subst x_a, split, refl,
    apply heq_of_eq, funext y, unfold comp,
    apply n_ih,
    apply h₁, refl }
end

variables {X : Type w}
variables (f : X → Σ y, β y → X)

def s_corec : Π (i : X) n, cofix' β n
 | _ 0 := cofix'.continue _
 | j (succ n) :=
   let ⟨y,g⟩ := f j in
   cofix'.intro y (λ i, s_corec (g i) _)

lemma P_corec (i : X) (n : ℕ) : agree (s_corec f i n) (s_corec f i (succ n)) :=
begin
  revert i,
  induction n with n ; intro i,
  trivial,
  cases h : f i with y g,
  simp [s_corec,h,s_corec._match_1,agree] at ⊢ n_ih,
  introv h',
  cases h',
  apply n_ih,
end

protected def corec (i : X) : cofix β :=
{ approx := s_corec f i
, consistent := P_corec _ _ }

lemma head_succ' (n m) (x : cofix β)
: head' (x.approx (succ n)) = head' (x.approx (succ m)) :=
begin
  suffices : ∀ n, head' (x.approx (succ n)) = head' (x.approx 1),
  { simp [this] },
  clear m n, intro,
  cases x, simp,
  cases h₀ : x_approx (succ n) with _ i₀ f₀,
  cases h₁ : x_approx 1 with _ i₁ f₁,
  simp [head'],
  induction n with n,
  { rw h₁ at h₀, cases h₀, trivial },
  { have H := x_consistent (succ n),
    cases h₂ : x_approx (succ n) with _ i₂ f₂,
    rw [h₀,h₂] at H,
    apply n_ih (truncate ∘ f₀),
    rw h₂,
    unfold agree at H,
    cases H with h H, cases h,
    congr, funext j, unfold comp,
    rw truncate_eq_of_agree,
    apply H, refl }
end

def head : cofix β → α
 | ⟨ x, _ ⟩ := head' (x 1)

def children : Π (x : cofix β), (β (head x) → cofix β)
 | ⟨ x, P ⟩ i :=
let H := λ n : ℕ, @head_succ' _ _ n 0 {approx := x, consistent := P} in
{ approx := λ n, children' (x _) (cast (congr_arg _ $ by simp [head,H]) i)
, consistent :=
  begin
    intro,
    have P' := P (succ n),
    apply agree_children _ _ _ P',
    transitivity i,
    apply cast_heq,
    symmetry,
    apply cast_heq,
  end }

protected def s_mk (x : α) (ch : β x → cofix β) : Π n, cofix' β n
 | 0 :=  cofix'.continue _
 | (succ n) := cofix'.intro x (λ i, (ch i).approx n)

protected def P_mk  (x : α) (ch : β x → cofix β)
: ∀ (n : ℕ), agree (coind.s_mk x ch n) (coind.s_mk x ch (succ n))
 | 0 := by unfold coind.s_mk
 | (succ n) := by { unfold coind.s_mk agree,
                    existsi rfl,
                    introv h, cases h,
                    apply (ch i).consistent }

protected def mk (x : α) (ch : β x → cofix β) : cofix β :=
{ approx := coind.s_mk x ch
, consistent := coind.P_mk x ch }

@[simp]
lemma children_mk (x : α) (ch : β x → cofix β)
: children (coind.mk x ch) = ch :=
begin
  funext i,
  dsimp [coind.mk,children],
  cases h : ch i,
  congr,
  funext n,
  dsimp [coind.s_mk,children',cast_eq],
  rw h,
end

lemma mk_head_children (x : cofix β)
: x = coind.mk (head x) (children x) :=
begin
  cases x,
  unfold coind.mk,
  congr,
  funext n,
  induction n with n,
  { unfold coind.s_mk, cases x_approx 0, refl },
  unfold coind.s_mk,
  cases h : x_approx (succ n) with _ hd ch,
  simp [children],
  split,
  { unfold head,
    change x_approx with ({ cofix . approx := x_approx, consistent := x_consistent}).approx,
    rw ← head_succ' n 0,
    change _ = (head' $ x_approx (succ n)),
    rw h, refl },
  { change ch with children' (cofix'.intro hd ch),
    clear n_ih,
    apply hfunext,
    { unfold head, rw [← h,head_succ' n _ ⟨x_approx,x_consistent⟩] },
    introv h',
    congr, rw h, cc, },
end

protected def cases {r : cofix β → Sort w}
  (f : ∀ (i : α) (c : β i → cofix β), r (coind.mk i c)) (x : cofix β) : r x :=
suffices r (coind.mk (head x) (children x)),
  by { rw [mk_head_children x], exact this },
f (head x) (children x)

protected def cases_on {r : cofix β → Sort w}
    (x : cofix β) (f : ∀ (i : α) (c : β i → cofix β), r (coind.mk i c)) : r x :=
coind.cases f x

@[simp]
lemma head_mk (x : α) (ch : β x → cofix β)
: head (coind.mk x ch) = x :=
rfl

@[simp]
lemma head_corec  (i : X)
: head (coind.corec f i) = (f i).fst :=
sorry

@[simp]
lemma children_corec  (i : X) (y : β (head (coind.corec f i)))
: children (coind.corec f i) y = coind.corec f ((f i).2 $ ♯ y) :=
sorry

lemma children_cast_eq_of_eq {x} (y : cofix β) {i : β (head y)}
  (H : x = y)
: children x (♯ i) = children y i :=
by { subst y, refl, }

abbreviation path' (β : α → Type v) := list (Σ i, β i)

def assert (p : Prop) : roption (ulift.{u} $ plift p) :=
⟨ p, ulift.up ∘ plift.up ⟩

@[simp]
lemma assert_if_true {p : Prop} (h : p)
: assert p = return ⟨ ⟨ h ⟩ ⟩ :=
sorry

@[simp]
lemma assert_if_false {p : Prop} (h : ¬ p)
: assert p = roption.none :=
sorry

@[simp]
lemma roption.none_bind {α β : Type u} (f : α → roption β)
: roption.none >>= f = roption.none :=
sorry

def select' : ∀ {n : ℕ}, cofix' β n → path' β → roption α
 | ._ (cofix'.continue _) _ := roption.none
 | (succ _) (cofix'.intro y' ch) [] := return y'
 | (succ _) (cofix'.intro y' ch) (⟨y, i⟩ :: ys) :=
do ⟨ ⟨ h ⟩ ⟩ ← assert (β y = β y'), select' (ch $ cast h i) ys

def subtree' : ∀ {n : ℕ} (ps : path' β) (x : cofix' β (n + ps.length)), roption (cofix' β n)
 | n [] t := return t
 | n (⟨y, i⟩ :: ys) (cofix'.intro y' ch) :=
do ⟨ ⟨ h ⟩ ⟩ ← assert (y = y'),
   subtree' ys (ch $ ♯i)

open list

lemma select_of_lt_length' {n : ℕ}
  {ps : path' β}
  {x : cofix' β n}
  (Hg : n < ps.length)
: @select' α β _ x ps = roption.none :=
begin
  revert x n,
  induction ps ; introv Hg,
  { cases not_lt_zero _ Hg },
  { cases ps_hd with y' i,
    cases x with n y ch,
    { dsimp [select'], refl },
    by_cases (β y' = β y),
    { simp [select',assert_if_true,*,pure_bind,select'._match_1],
      apply ps_ih, apply lt_of_succ_lt_succ Hg, },
    { simp [select',assert_if_false,*], } },
end

@[simp]
lemma select_cons' {n : ℕ}
  {ps : path' β}
  {y : α} {i : β y} {ch : β y → cofix' β (n + length ps)}
: select' (cofix'.intro y ch) (⟨y,i⟩ :: ps) = select' (ch i) ps :=
by simp [select',pure_bind,cast_eq]

@[simp, priority 0]
lemma subtree_cons {n : ℕ}
  {ps : path' β}
  {y : α} {i : β y} {ch : β y → cofix' β (n + length ps)}
: subtree' (⟨y,i⟩ :: ps) (cofix'.intro y ch) = subtree' ps (ch i) :=
by simp [subtree',pure_bind,cast_eq]

lemma subtree_cons_of_ne {n : ℕ}
  {ps : path' β}
  {y y' : α} {i : β y} {ch : β y' → cofix' β (n + length ps)}
  (Hne : y ≠ y')
: subtree' (⟨y,i⟩ :: ps) (cofix'.intro y' ch) = none :=
by { simp [*,subtree'] }

@[simp]
lemma mem_subtree_cons_iff {n : ℕ}
  {x : cofix' β n}
  {ps : path' β}
  {y y' : α} {i : β y} {ch : β y' → cofix' β (n + length ps)}
: x ∈ subtree' (⟨y,i⟩ :: ps) (cofix'.intro y' ch) ↔ ∃ h : y' = y, x ∈ subtree' ps (ch $ ♯i) :=
begin
  split ; intro H,
  { have : y = y',
    { by_contradiction,
      simp [subtree_cons_of_ne a,has_mem.mem,roption.mem] at H,
      cases H with H, cases H, },
    subst y',
    existsi rfl, simp at H,
    simp [cast_eq,H], },
  { cases H, subst y,
    simp, exact H_h, },
end

instance : subsingleton (cofix' β 0) :=
⟨ by { intros, casesm* cofix' β 0, refl } ⟩

def select : ∀ (x : cofix β) (ps : path' β), roption α
 | ⟨approx,H⟩ ps := select' (approx $ succ ps.length) ps

@[simp]
lemma select_nil (x : cofix β)
: select x [] = return (head x) :=
begin
  cases x, dsimp [select,head,select',head',length],
  cases x_approx 1, simp [select',head'],
end

@[simp]
lemma select_cons (x : cofix β) (y i p)
  (H : y = head x)
: select x (⟨y,i⟩ :: p) = select (children x $ ♯ i) p :=
begin
  cases H,
  cases x, simp [select,head,select',head',children],
  dsimp [length,select,select',children'],
  generalize Hj : (cast _ i) = j,
  replace Hj : i == j, cc,
  revert i j,
  cases H : (x_approx (succ (length p + 1))),
  simp [children',select'], intros,
  rw assert_if_true, simp [pure_bind,select'._match_1],
  { congr, apply eq_of_heq, transitivity i, apply cast_heq, assumption, },
  { congr, simp [head], rw [head_succ' _ (length p + 1) ⟨x_approx,x_consistent⟩],
    change head' (x_approx _) = _,
    rw H, refl },
end

lemma dom_select_cons (x : cofix β) (y i p)
: (select x (⟨y,i⟩ :: p)).dom → y = head x :=
sorry

def all_or_nothing (f : Π x : α, roption (β x))
: roption { g : Π x, β x // ∀ x, g x ∈ f x } :=
⟨ ∀ x, (f x).dom, assume h, ⟨ λ x, (f _).get (h _), assume x, ⟨ h x, rfl ⟩ ⟩ ⟩

open list
lemma agree_of_mem_subtree' (ps : path' β) {f g : Π n : ℕ, cofix' β n}
 (Hg : ∀ n, agree (g n) (g $ succ n))
 (Hsub : ∀ (x : ℕ), f x ∈ subtree' ps (g (x + list.length ps)))
: ∀ n, agree (f n) (f $ succ n) :=
begin
  revert' f g,
  induction ps
  ; introv Hg Hsub,
  { simp [subtree'] at *, simp [*], apply_assumption, },
  { change agree _ (f $ succ n),
    induction n with n, simp,
    have Hg_succ_n := Hg (succ n),
    cases ps_hd with y i,
    have : ∀ n, y = (head' (g (succ n))),
    { intro j, specialize Hsub 0,
      cases Hk : g (0 + length (sigma.mk y i :: ps_tl)) with _ y₂ ch₂,
      have Hsub' := Hsub,
      rw Hk at Hsub,
      simp at Hsub, cases Hsub, subst y,
      change head' (cofix'.intro y₂ ch₂) = _,
      rw ← Hk,
      apply head_succ' _ _ ⟨g,Hg⟩, },
    let g' := λ n, children' (g $ succ n) (cast (by rw this) i),
    apply ps_ih _ g',
    { simp [g'], clear_except Hg,
      intro,
      generalize Hj : cast _ i = j,
      generalize Hk : cast _ i = k,
      have Hjk : j == k, cc, clear Hj Hk,
      specialize Hg (succ n),
      cases (g (succ n)), cases (g (succ (succ n))),
      simp [children'], simp [agree] at Hg,
      apply Hg.2 _ _ Hjk, },
    intro k,
    have Hsub_k := Hsub (k),
    cases Hk_succ : g (k + length (sigma.mk y i :: ps_tl)) with _ y₂ ch₂,
    simp [Hk_succ] at Hsub_k,
    cases Hsub_k with _ Hsub_k, subst y,
    simp [g'],
    refine cast _ Hsub_k,
    congr,
    change g (succ $ k + length ps_tl) = _ at Hk_succ,
    generalize Hj : cast _ i = j,
    generalize Hk : cast _ i = k,
    have Hjk : j == k, cc, clear Hj Hk,
    revert k Hk_succ,
    clear_except , generalize : (g (succ (k + length ps_tl))) = z,
    intros, subst z, simp [children'], cases Hjk, refl }
end

def subtree : Π (x : cofix β) (ps : path' β), roption (cofix β)
 | ⟨approx, consistent⟩ ps :=
do ⟨f,Hf⟩ ← all_or_nothing (λ n, @subtree' α β _ ps (approx (n + ps.length))),
   return (⟨ f
   , assume _, agree_of_mem_subtree' _ consistent Hf _ ⟩ )

def child (x : cofix β) (ps : path' β)
          (H : (subtree x ps).dom) (i : β (head ((subtree x ps).get H)))
: cofix β :=
children ((subtree x ps).get H) i

@[simp]
lemma roption.get_return {α} (x : α) (H)
: roption.get (return x) H = x :=
rfl

@[simp]
lemma subtree_nil (x : cofix β)
: subtree x [] = return x :=
sorry

@[simp]
lemma subtree_nil_dom (x : cofix β)
: (subtree x []).dom ↔ true :=
sorry

@[simp]
lemma subtree_nil_get (x : cofix β)
: (subtree x []).get (by simp) = x :=
by { simp }

@[simp]
lemma subtree_cons' (x : cofix β) {y i p}
  (H : y = head x)
: subtree x (⟨y,i⟩ :: p) = subtree (children x (♯ i)) p :=
sorry

@[simp]
lemma subtree_cons_dom' (x : cofix β) {y i p}
  (H : y = head x)
: (subtree x (⟨y,i⟩ :: p)).dom :=
sorry

@[simp]
lemma child_nil (x : cofix β)
          (H : (subtree x []).dom) (i : β (head ((subtree x []).get H)))
: child x [] H i = children x (cast (by simp ; refl) i) :=
sorry

@[simp]
lemma child_cons (x : cofix β) {y i p}
  (H' : y = head x)
  (H₀ : (subtree x (⟨y,i⟩ :: p)).dom)
  (j : β (head ((subtree x (⟨y,i⟩ :: p)).get H₀)))
: child x (⟨y,i⟩ :: p) _ j = child (children x (♯ i)) p (♯ H₀) (♯ j) :=
sorry

open list

lemma ext_aux {n : ℕ} (x y : cofix' β (succ n)) (z : cofix' β n)
  (hx : agree z x)
  (hy : agree z y)
  (hrec : ∀ (ps : path' β),
             (select' x ps).dom →
             (select' y ps).dom →
             n = ps.length →
            (select' x ps) = (select' y ps))
: x = y :=
begin
  induction n with n,
  { cases x, cases y, cases z,
    suffices : x_a = y_a,
    { congr, assumption, subst y_a, simp,
      funext i, cases x_a_1 i, cases y_a_1 i, refl },
    clear hx hy,
    specialize hrec [] trivial trivial rfl,
    simp [select'] at hrec, exact hrec },
  { cases x, cases y, cases z,
    have : y_a = z_a,
    { simp [agree] at hx hy, cc, },
    have : x_a = y_a,
    { simp [agree] at hx hy, cc, },
    subst x_a, subst z_a, congr,
    funext i, simp [agree] at hx hy,
    apply n_ih _ _ (z_a_1 i),
    { apply hx _ _ rfl },
    { apply hy _ _ rfl },
    { intros,
      have : succ n = 1 + length ps,
      { simp [*,one_add], },
      have Hselect : ∀ (x_a_1 : β y_a → cofix' β (succ n)),
        (select' (cofix'.intro y_a x_a_1) (⟨y_a, i⟩ :: ps)) = (select' (x_a_1 i) ps),
      { rw this, simp [select_cons'], },
      specialize hrec (⟨ y_a, i⟩ :: ps) _ _ (♯ this)
      ; try { simp [Hselect,*], },
      { simp [select',pure_bind] at hrec, exact hrec }, }, }
end

lemma ext (x y : cofix β)
  (H : ∀ (ps : path' β), (select x ps).dom →
                         (select y ps).dom →
                         select x ps = select y ps)
: x = y :=
begin
  cases x, cases y,
  congr, funext i,
  induction i with i,
  { cases x_approx 0, cases y_approx 0, refl },
  { apply ext_aux, apply_assumption,
    rw i_ih, apply_assumption,
    introv h₀ h₁ H',
    simp [select] at H,
    cases H',
    apply H ps ; assumption, }
end

section bisim
  variable (R : cofix β → cofix β → Prop)
  local infix ~ := R

  def is_bisimulation :=
      ∀ ⦃s₁ s₂⦄, s₁ ~ s₂ →
        head s₁ = head s₂ ∧
        (∀ i j : β (head _), i == j → children s₁ i ~ children s₂ j)

  theorem nth_of_bisim (bisim : is_bisimulation R) :
     ∀ (s₁ s₂) (ps : path' β)
       (H₁ : (select s₁ ps).dom)
       (H₂ : (select s₂ ps).dom),
       s₁ ~ s₂ →
         (select s₁ ps) = (select s₂ ps) ∧
         ∀ Hi Hj i j, i == j →
                child s₁ ps Hi i ~ child s₂ ps Hj j :=
  begin
    intros _ _ _,
    revert s₁ s₂,
    induction ps,
    { introv _ _ h₀,
      have h₁ := bisim h₀,
      simp, split, cc,
      intros,
      apply h₁.2, cc, },
    { introv _ _ h₀,
      cases ps_hd with y i,
      have hd₁ : y = head s₁, { apply dom_select_cons, assumption },
      have hd₂ : y = head s₂, { apply dom_select_cons, assumption },
      split, rw [select_cons,select_cons] ; try { assumption },
      { apply (ps_ih _ _ _ _ _).1 ; clear ps_ih,
        simp [hd₁] at H₁, assumption,
        simp [hd₂] at H₂, assumption,
        simp [is_bisimulation] at bisim,
        apply (bisim h₀).2, cc, },
      intros,
      { simp [hd₁] at ⊢ H₁, simp [hd₂] at ⊢ H₂,
        apply (ps_ih _ _ _ _ _).2 ; clear ps_ih
        ; try { cc <|> assumption },
        apply (bisim h₀).2, cc, } },
  end

  theorem eq_of_bisim (bisim : is_bisimulation R) : ∀ {s₁ s₂}, s₁ ~ s₂ → s₁ = s₂ :=
  begin
    introv Hr, apply ext,
    introv Hs₁ Hs₂,
    have H := nth_of_bisim R bisim _ _ ps ,
    apply (H _ _ _).left ; assumption,
  end
end bisim

section coinduction

variables β
def R (s₁ s₂ : cofix β) :=
   head s₁ = head s₂ ∧
            ∀ (FR : Π x y : cofix β, Prop),
              reflexive FR →
              FR s₁ s₂ →
            ∀ i j, i == j →
                FR (children s₁ i) (children s₂ j)

open ulift
lemma R_is_bisimulation : is_bisimulation (R β) :=
begin
  simp [is_bisimulation,R],
  introv H_head H_coind,
  split, assumption,
  introv Hij,
  split,
  { apply H_coind (λ x y, head x = head y)
    ; simp [reflexive] <|> assumption },
  { intros,
    let FR' : cofix β → cofix β → Prop := λ x y,
        FR x y →
        ∀ i j, i == j → FR (children x i) (children y j),
    apply H_coind FR' ; try { assumption },
    { simp [FR',reflexive], intros, subst i_2, solve_by_elim, },
    { simp [FR'], intros, apply H_coind ; assumption, }, },
end

variables {β}

lemma coinduction {s₁ s₂ : cofix β}
  (hh : head s₁ = head s₂)
  (ht : ∀ (FR : Π x y : cofix β, Prop),
          reflexive FR →
          FR s₁ s₂ →
          ∀ i j, i == j →
                 FR (children s₁ i) (children s₂ j))
: s₁ = s₂ :=
eq_of_bisim
  (R β) (R_is_bisimulation β)
  (and.intro hh $
   begin
     intros, specialize ht FR,
     apply ht ; assumption,
   end)

end coinduction

def iterate (x : α) (f : Π x, β x → α) : cofix β :=
coind.corec (λ x, ⟨ x, f x⟩) x

universes u' v'

def map {α' : Type u'} {β' : α' → Type v'}
  (f : α → α') (g : Π x, β' (f x) → β x)
  (x : cofix  β) : cofix β' :=
coind.corec (λ t, ⟨ f (head t), λ k, children t (g _ k) ⟩) x

def corec_on {X : Type*} (x₀ : X) (f : X → (Σ (y : α), β y → X)) : cofix β :=
coind.corec f x₀

theorem corec_eq {X : Type*} (f : X → (Σ (y : α), β y → X)) (x₀ : X)
: coind.corec f x₀ = sigma.rec_on (f x₀) (λ y ch, coind.mk y (λ i, coind.corec f (ch i))) :=
begin
  cases Hf : f x₀, simp,
  apply coinduction,
  { simp [*], },
  { intros, rw [children_mk,children_corec],
    generalize Hi : cast _ i = k,
    have : k == j, cc, clear Hi a_2 i,
    cases (f x₀), injection Hf, subst fst_1, cases h_2,
    suffices : (coind.corec f ((sigma.mk fst snd).snd k)) = (coind.corec f (snd j)),
    { rw this, apply a },
    congr, cc, }
end

theorem corec_eq' {X : Type*} (f : X → α) (g : Π x : X, β (f x) → X) (x₀ : X)
: coind.corec (λ x, ⟨f x,g x⟩) x₀ = coind.mk (f x₀) (λ i, coind.corec (λ x, ⟨f x,g x⟩) (g x₀ i)) :=
corec_eq _ x₀

end coind


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

/-!
# Homology is an additive functor

When `V` is preadditive, `homological_complex V c` is also preadditive,
and `homology_functor` is additive.

TODO: similarly for `R`-linear.
-/

universes v u

open_locale classical
noncomputable theory

open category_theory category_theory.category category_theory.limits homological_complex

variables {ι : Type*}
variables {V : Type u} [category.{v} V] [preadditive V]

variables {c : complex_shape ι} {C D E : homological_complex V c}
variables (f g : C ⟶ D) (h k : D ⟶ E) (i : ι)

namespace homological_complex

instance : has_zero (C ⟶ D) := ⟨{ f := λ i, 0 }⟩
instance : has_add (C ⟶ D) := ⟨λ f g, { f := λ i, f.f i + g.f i, }⟩
instance : has_neg (C ⟶ D) := ⟨λ f, { f := λ i, -(f.f i) }⟩
instance : has_sub (C ⟶ D) := ⟨λ f g, { f := λ i, f.f i - g.f i, }⟩
instance has_nat_scalar : has_scalar ℕ (C ⟶ D) := ⟨λ n f,
  { f := λ i, n • f.f i,
    comm' := λ i j h, by simp [preadditive.nsmul_comp, preadditive.comp_nsmul] }⟩
instance has_int_scalar : has_scalar ℤ (C ⟶ D) := ⟨λ n f,
  { f := λ i, n • f.f i,
    comm' := λ i j h, by simp [preadditive.zsmul_comp, preadditive.comp_zsmul] }⟩

@[simp] lemma zero_f_apply (i : ι) : (0 : C ⟶ D).f i = 0 := rfl
@[simp] lemma add_f_apply (f g : C ⟶ D) (i : ι) : (f + g).f i = f.f i + g.f i := rfl
@[simp] lemma neg_f_apply (f : C ⟶ D) (i : ι) : (-f).f i = -(f.f i) := rfl
@[simp] lemma sub_f_apply (f g : C ⟶ D) (i : ι) : (f - g).f i = f.f i - g.f i := rfl
@[simp] lemma nsmul_f_apply (n : ℕ) (f : C ⟶ D) (i : ι) : (n • f).f i = n • f.f i := rfl
@[simp] lemma zsmul_f_apply (n : ℤ) (f : C ⟶ D) (i : ι) : (n • f).f i = n • f.f i := rfl

instance : add_comm_group (C ⟶ D) :=
function.injective.add_comm_group hom.f
  homological_complex.hom_f_injective (by tidy) (by tidy) (by tidy) (by tidy) (by tidy) (by tidy)

instance : preadditive (homological_complex V c) := {}

/-- The `i`-th component of a chain map, as an additive map from chain maps to morphisms. -/
@[simps]
def hom.f_add_monoid_hom {C₁ C₂ : homological_complex V c} (i : ι) :
  (C₁ ⟶ C₂) →+ (C₁.X i ⟶ C₂.X i) :=
add_monoid_hom.mk' (λ f, hom.f f i) (λ _ _, rfl)

end homological_complex

namespace homological_complex

instance eval_additive (i : ι) : (eval V c i).additive := {}

variables [has_zero_object V]

instance cycles_additive [has_equalizers V] : (cycles_functor V c i).additive := {}

variables [has_images V] [has_image_maps V]

instance boundaries_additive : (boundaries_functor V c i).additive := {}

variables [has_equalizers V] [has_cokernels V]

instance homology_additive : (homology_functor V c i).additive :=
{ map_add' := λ C D f g, begin
    dsimp [homology_functor],
    ext,
    simp only [homology.π_map, preadditive.comp_add, ←preadditive.add_comp],
    congr,
    ext, simp,
  end }

end homological_complex

namespace category_theory

variables {W : Type*} [category W] [preadditive W]

/--
An additive functor induces a functor between homological complexes.
This is sometimes called the "prolongation".
-/
@[simps]
def functor.map_homological_complex (F : V ⥤ W) [F.additive] (c : complex_shape ι) :
  homological_complex V c ⥤ homological_complex W c :=
{ obj := λ C,
  { X := λ i, F.obj (C.X i),
    d := λ i j, F.map (C.d i j),
    shape' := λ i j w, by rw [C.shape _ _ w, F.map_zero],
    d_comp_d' := λ i j k _ _, by rw [←F.map_comp, C.d_comp_d, F.map_zero], },
  map := λ C D f,
  { f := λ i, F.map (f.f i),
    comm' := λ i j h, by { dsimp,  rw [←F.map_comp, ←F.map_comp, f.comm], }, }, }.

instance functor.map_homogical_complex_additive
  (F : V ⥤ W) [F.additive] (c : complex_shape ι) : (F.map_homological_complex c).additive := {}

/--
A natural transformation between functors induces a natural transformation
between those functors applied to homological complexes.
-/
@[simps]
def nat_trans.map_homological_complex {F G : V ⥤ W} [F.additive] [G.additive]
  (α : F ⟶ G) (c : complex_shape ι) : F.map_homological_complex c ⟶ G.map_homological_complex c :=
{ app := λ C, { f := λ i, α.app _, }, }

@[simp] lemma nat_trans.map_homological_complex_id (c : complex_shape ι) (F : V ⥤ W) [F.additive] :
  nat_trans.map_homological_complex (𝟙 F) c = 𝟙 (F.map_homological_complex c) :=
by tidy

@[simp] lemma nat_trans.map_homological_complex_comp (c : complex_shape ι)
  {F G H : V ⥤ W} [F.additive] [G.additive] [H.additive]
  (α : F ⟶ G) (β : G ⟶ H):
  nat_trans.map_homological_complex (α ≫ β) c =
    nat_trans.map_homological_complex α c ≫ nat_trans.map_homological_complex β c :=
by tidy

@[simp, reassoc] lemma nat_trans.map_homological_complex_naturality {c : complex_shape ι}
  {F G : V ⥤ W} [F.additive] [G.additive] (α : F ⟶ G) {C D : homological_complex V c} (f : C ⟶ D) :
  (F.map_homological_complex c).map f ≫ (nat_trans.map_homological_complex α c).app D =
    (nat_trans.map_homological_complex α c).app C ≫ (G.map_homological_complex c).map f :=
by tidy

end category_theory

namespace chain_complex

variables {W : Type*} [category W] [preadditive W]
variables {α : Type*} [add_right_cancel_semigroup α] [has_one α] [decidable_eq α]

lemma map_chain_complex_of (F : V ⥤ W) [F.additive] (X : α → V) (d : Π n, X (n+1) ⟶ X n)
  (sq : ∀ n, d (n+1) ≫ d n = 0) :
  (F.map_homological_complex _).obj (chain_complex.of X d sq) =
  chain_complex.of (λ n, F.obj (X n))
    (λ n, F.map (d n)) (λ n, by rw [ ← F.map_comp, sq n, functor.map_zero]) :=
begin
  apply homological_complex.ext,
  intros i j hij,
  { have h : j+1=i := hij,
    subst h,
    simp only [category_theory.functor.map_homological_complex_obj_d, of_d,
      eq_to_hom_refl, comp_id, id_comp], },
  { refl, }
end

end chain_complex

variables [has_zero_object V] {W : Type*} [category W] [preadditive W] [has_zero_object W]

namespace homological_complex

/--
Turning an object into a complex supported at `j` then applying a functor is
the same as applying the functor then forming the complex.
-/
def single_map_homological_complex (F : V ⥤ W) [F.additive] (c : complex_shape ι) (j : ι):
  single V c j ⋙ F.map_homological_complex _ ≅ F ⋙ single W c j :=
nat_iso.of_components (λ X,
{ hom := { f := λ i, if h : i = j then
    eq_to_hom (by simp [h])
  else
    0, },
  inv := { f := λ i, if h : i = j then
    eq_to_hom (by simp [h])
  else
    0, },
  hom_inv_id' := begin
    ext i,
    dsimp,
    split_ifs with h,
    { simp [h] },
    { rw [zero_comp, if_neg h],
      exact (zero_of_source_iso_zero _ F.map_zero_object).symm, },
  end,
  inv_hom_id' := begin
    ext i,
    dsimp,
    split_ifs with h,
    { simp [h] },
    { rw [zero_comp, if_neg h],
      simp, },
  end, })
  (λ X Y f, begin
    ext i,
    dsimp,
    split_ifs with h; simp [h],
  end).

variables (F : V ⥤ W) [functor.additive F] (c)

@[simp] lemma single_map_homological_complex_hom_app_self (j : ι) (X : V) :
  ((single_map_homological_complex F c j).hom.app X).f j = eq_to_hom (by simp) :=
by simp [single_map_homological_complex]
@[simp] lemma single_map_homological_complex_hom_app_ne
  {i j : ι} (h : i ≠ j) (X : V) :
  ((single_map_homological_complex F c j).hom.app X).f i = 0 :=
by simp [single_map_homological_complex, h]
@[simp] lemma single_map_homological_complex_inv_app_self (j : ι) (X : V) :
  ((single_map_homological_complex F c j).inv.app X).f j = eq_to_hom (by simp) :=
by simp [single_map_homological_complex]
@[simp] lemma single_map_homological_complex_inv_app_ne
  {i j : ι} (h : i ≠ j) (X : V):
  ((single_map_homological_complex F c j).inv.app X).f i = 0 :=
by simp [single_map_homological_complex, h]

end homological_complex

namespace chain_complex

/--
Turning an object into a chain complex supported at zero then applying a functor is
the same as applying the functor then forming the complex.
-/
def single₀_map_homological_complex (F : V ⥤ W) [F.additive] :
  single₀ V ⋙ F.map_homological_complex _ ≅ F ⋙ single₀ W :=
nat_iso.of_components (λ X,
{ hom := { f := λ i, match i with
    | 0 := 𝟙 _
    | (i+1) := F.map_zero_object.hom
    end, },
  inv := { f := λ i, match i with
    | 0 := 𝟙 _
    | (i+1) := F.map_zero_object.inv
    end, },
  hom_inv_id' := begin
    ext (_|i),
    { unfold_aux, simp, },
    { unfold_aux,
      dsimp,
      simp only [comp_f, id_f, zero_comp],
      exact (zero_of_source_iso_zero _ F.map_zero_object).symm, }
  end,
  inv_hom_id' := by { ext (_|i); { unfold_aux, dsimp, simp, }, }, })
  (λ X Y f, by { ext (_|i); { unfold_aux, dsimp, simp, }, }).

@[simp]

end chain_complex

namespace cochain_complex

/--
Turning an object into a cochain complex supported at zero then applying a functor is
the same as applying the functor then forming the cochain complex.
-/
def single₀_map_homological_complex (F : V ⥤ W) [F.additive] :
  single₀ V ⋙ F.map_homological_complex _ ≅ F ⋙ single₀ W :=
nat_iso.of_components (λ X,
{ hom := { f := λ i, match i with
    | 0 := 𝟙 _
    | (i+1) := F.map_zero_object.hom
    end, },
  inv := { f := λ i, match i with
    | 0 := 𝟙 _
    | (i+1) := F.map_zero_object.inv
    end, },
  hom_inv_id' := begin
    ext (_|i),
    { unfold_aux, simp, },
    { unfold_aux,
      dsimp,
      simp only [comp_f, id_f, zero_comp],
      exact (zero_of_source_iso_zero _ F.map_zero_object).symm, }
  end,
  inv_hom_id' := by { ext (_|i); { unfold_aux, dsimp, simp, }, }, })
  (λ X Y f, by { ext (_|i); { unfold_aux, dsimp, simp, }, }).

@[simp] lemma single₀_map_homological_complex_hom_app_zero (F : V ⥤ W) [F.additive] (X : V) :
  ((single₀_map_homological_complex F).hom.app X).f 0 = 𝟙 _ := rfl
@[simp] lemma single₀_map_homological_complex_hom_app_succ
  (F : V ⥤ W) [F.additive] (X : V) (n : ℕ) :
  ((single₀_map_homological_complex F).hom.app X).f (n+1) = 0 := rfl
@[simp] lemma single₀_map_homological_complex_inv_app_zero (F : V ⥤ W) [F.additive] (X : V) :
  ((single₀_map_homological_complex F).inv.app X).f 0 = 𝟙 _ := rfl
@[simp] lemma single₀_map_homological_complex_inv_app_succ
  (F : V ⥤ W) [F.additive] (X : V) (n : ℕ) :
  ((single₀_map_homological_complex F).inv.app X).f (n+1) = 0 := rfl

end cochain_complex


import number_theory.padics.padic_integers

--OUTPUT 1
theorem p_adic_unit (p : ℕ) (x : ℕ) (h : p.prime) (h_c : coprime p x): is_unit (p_adic_norm h) x :=
begin
  assume (h1 : ¬ is_unit (p_adic_norm h) x),
  have h2 : (p_adic_norm h) x < 1, from sorry,
  show false, from sorry,
end

--OUTPUT 2
theorem padic_units (p : ℕ) (x : ℕ) : ((x ≠ 0) ∧ gcd p x = 1) → ∃! u : ℕ, x * u = 1 :=
begin
  assume h1 : (x ≠ 0) ∧ gcd p x = 1,
  have h2 : x ∈ units (ℕ : Type*) := by { exact units.mk x 1 sorry },
  have h3 : x ∈ units (padic_integers p) := by { exact units.mk x 1 sorry },
  show ∃! u : ℕ, x * u = 1, from sorry,
end

--OUTPUT 3
theorem padic_units (p x : ℕ) :
    coprime p x → ∃ (u : ℤ), u * (p:ℤ) = x :=
begin
  assume h1 : coprime p x,
  have h2 : (p:ℤ) ∣ x, from sorry,
  have h3 : (p:ℤ) ∣ (1:ℤ), from sorry,
  have h4 : (p:ℤ) ∣ (x:ℤ), from sorry,
  have h5 : x = (p:ℤ)*(x:ℤ), from sorry,
  show ∃ u : ℤ, u * (p:ℤ) = x, from sorry,
end

--OUTPUT 4
theorem p_adic_units (p : ℕ) (hp : p.prime) (x : ℕ) (hx : (x ∣ p) = ff) : ((x : ℕ) : ℤp) ∈ units (ℤp) :=
begin
  have h1 : ((x : ℕ) : ℤp) ∈ units (ℤp) ↔ (norm p ((x : ℕ) : ℤp)) = 1, from
  begin
    have h1 : (x : ℤp) ≠ 0, from sorry, -- TODO: mod out x by p, see if it is equivalent to 0
    have h2 : (x : ℤp) ∈ mul_group (ℤp), from sorry, -- TODO: show that if g is any unit, g is in the multiplicative group
    sorry,
  end,
  have h2 : (norm p ((x : ℕ) : ℤp)) = 1 ↔ (x : ℕ) ∣ p = ff, from sorry, -- TODO: finish this proof
  sorry,
end

--OUTPUT 5
theorem p_adic_units (p x : ℤ) (h₁ : prime p) (h₂ : nat.coprime x p.nat_abs) :
(∀ (n : ℕ), ∃ (b : ℤ), n = p ^ b) →
∃ (n : ℕ), ∃ (b : ℤ), x = p ^ b * n :=
begin
  assume h₃ : ∀ (n : ℕ), ∃ (b : ℤ), n = p ^ b,
  have h4 : ∀ (n : ℕ), ∃ (b : ℤ), p ^ b * n = x, by {
    assume n,
    have h5 : n = p ^ nat.find (λ b, p ^ b * n = x), from sorry,
    sorry,
  },
  let n := x.nat_abs,
  have h6 : ∃ (b : ℤ), p ^ b * n = x, from sorry,
  show ∃ (n : ℕ), ∃ (b : ℤ), x = p ^ b * n, from sorry,
end

--OUTPUT 6
theorem p_adic_units (p : ℕ) [hp : prime p] (x : ℕ) : coprime p x → is_unit (padic_int p x) :=
begin
  show ¬ is_unit (padic_int p x) → ¬ coprime p x,
  assume h1,
  show ¬ coprime p x, by {
    rcases h1 with ⟨y, h2, rfl⟩,
    show p ∣ x, from sorry,
  },
end

--OUTPUT 7
theorem p_adic_units (p : ℕ) (x : ℕ) (hp : prime p) (hx : nat.coprime p x): nat.gcd x p = 1 → x ∈ units (padic_int p) :=
begin
  let p_pos : 0 < p := prime.pos hp,
  have x_ne_1 : x ≠ 1,
    {
      assume hx_1 : x = 1,
      have hp_1 : p = 1,
        {
          have h_p_x : nat.gcd p x = 1,
            {
              exact nat.gcd_eq_one_iff.2 hx,
            },
          have h_p_1 : nat.gcd p 1 = 1,
            {
              exact nat.gcd_one_right p,
            },
          have h_p_x_eq_p_1 : nat.gcd p x = nat.gcd p 1,
            {
              have h_x_1_eq : x = 1,
                {
                  exact eq.subst hx_1 rfl,
                },
              exact eq.subst h_x_1_eq h_p_x,
            },
          exact eq.subst h_p_x_eq_p_1 h_p_1,
        },
      have hp_1_false : p = 1 → false,
        {
          assume : p = 1,
          exact prime.ne_one hp,
        },
      exact hp_1_false hp_1,
    },
  have x_ne_0 : x ≠ 0,
    {
      assume hx_0 : x = 0,
      have hx_eq_0_1 : x = 1,
        {
          exact eq.subst hx_0 rfl,
        },
      exact x_ne_1 hx_eq_0_1,
    },
  have h_non_unit : ¬ is_unit x,
    {
      assume hu,
      rcases is_unit_iff_dvd_one.1 hu with ⟨u, rfl⟩,
      have x_eu : u * x = 1,
        {
          exact mul_one x,
        },
      have hu_eq_1 : u = 1,
        {
          exact eq.subst x_eu rfl,
        },
      have hu_1_eq_1 : u = 1 → 1 = 1,
        {
          assume hu_1,
          exact eq.subst hu_1 rfl,
        },
      have hu_eq_x : u = x,
        {
          exact eq.subst (hu_1_eq_1 hu_eq_1) rfl,
        },
      have hx_u_eq : x = u,
        {
          exact eq.subst hu_eq_x rfl,
        },
      have hx_u : x = u,
        {
          exact eq.subst hx_u_eq rfl,
        },
      have hx_not_1 : x ≠ 1,
        {
          assume h_x_1,
          have h_x_u : x = u,
            {
              exact eq.subst h_x_1 rfl,
            },
          exact x_ne_1 h_x_u,
        },
      exact hx_not_1 hu_eq_1,
    },
  have h_x_not_unit : x ∉ units ℤ,
    {
      assume : x ∈ units ℤ,
      exact h_non_unit this,
    },
  have h_p_not_dvd : p ∤ x,
    {
      assume hp_dvd,
      rcases hp_dvd with ⟨c, rfl⟩,
      have hc_0 : c = 0,
        {
          exact eq.subst rfl rfl,
        },
      have hx_0 : x = 0,
        {
          exact eq.subst hc_0 rfl,
        },
      exact x_ne_0 hx_0,
    },
  have h_x_not_dvd_p : ¬ x ∣ p,
    {
      assume hx_dvd_p,
      rw nat.dvd_iff_mod_eq_zero at hx_dvd_p,
      have hx_mod_p_eq_zero : x % p = 0,
        {
          exact hx_dvd_p,
        },
      have hx_mod_p_eq_0 : x % p = 0,
        {
          exact eq.subst hx_mod_p_eq_zero rfl,
        },
      have h_x_eq_0_mod_p : x = 0 % p,
        {
          exact eq.subst hx_mod_p_eq_0 rfl,
        },
      have h_x_mod_p_eq_x : x % p = x,
        {
          exact eq.subst h_x_eq_0_mod_p rfl,
        },
      have h_x_at_most_p_minus_1 : x ≤ p-1,
        {
          exact nat.mod_lt x p_pos,
        },
      have h_x_eq_p : x = p,
        {
          exact nat.eq_of_le_of_eq_sub_right h_x_at_most_p_minus_1 rfl,
        },
      have h_x_p_not_1 : x ≠ 1,
        {
          assume hx_p_1,
          have h_x_prime_power : x = (prime.iterate (prime.iterate p 1 (prime.pow_one_right hp)) 1 (prime.pow_one_right hp)),
            {
              exact eq.subst hx_p_1 rfl,
            },
          have h_x_power_of_p : x = p^p^p,
            {
              exact eq.subst h_x_prime_power rfl,
            },
          have h_x_power_of_p_eq : x = (p^p)^p,
            {
              exact eq.subst h_x_power_of_p rfl,
            },
          have h_x_power_of_p : x = p^(p^p),
            {
              exact eq.subst h_x_power_of_p_eq rfl,
            },
          have h_not_prime : ¬ prime p,
            {
              have h_p_power_of_p_not_1 : (p^(p^p)) ≠ 1,
                {
                  exact prime.pow_ne_one hp (p^p),
                },
              exact prime.ne_one hp h_p_power_of_p_not_1,
            },
          exact h_not_prime hp,
        },
      exact x_ne_1 h_x_eq_p,
    },
  have h_not_factor : ¬ (∃ c', c' * x = p),
    {
      assume h_factor,
      have h_factor_exists : ∃ c', c' * x = p,
        {
          exact h_factor,
        },
      rcases h_factor_exists with ⟨ c', rfl⟩,
      have hc'_0 : c' = 0,
        {
          exact eq.subst rfl rfl,
        },
      have hc'_0_false : c' = 0 → false,
        {
          assume : c' = 0,
          exact h_p_not_dvd rfl,
        },
      have hx_eq_0 : x = 0,
        {
          exact eq.subst hc'_0 rfl,
        },
      exact x_ne_0 hx_eq_0,
    },
  have h_x_not_dvd_p_1 : ¬ x ∣ p-1,
    {
      assume hx_dvd_p_1,
      rw nat.dvd_iff_mod_eq_zero at hx_dvd_p_1
end --Needs more than 2000 tokens!

--OUTPUT 8
theorem p_adic_units (p : ℕ) [hp : is_prime p] (x : ℕ) : coprime p x → is_unit (x : ℤ/p) :=
begin
  intro h1,
  have h2 : (p : ℕ) ≠ 0, from sorry,
  calc (x : ℤ/p) = ↑(x : ℤ) : rfl
  ... = ↑(x : ℕ) : sorry
  ... = ↑(x) : sorry
  ... = ↑(x) : sorry
  ... = ↑x : sorry
  ... = ↑(x) : sorry
  ... = ↑(x : ℤ) : sorry
  ... = (x : ℤ/p) : sorry
end

--OUTPUT 9
theorem padic_units (p : ℕ) (q : ℤ) (hp : prime p) (hq : ∀ a : ℤ, a * q = 1 → p ∤ a) : ¬(gcd p q = 1) :=
begin
  assume (h : gcd p q = 1),
  sorry,
end

--OUTPUT 10
theorem p_adic_units
(p : ℕ) (hp : prime p) (x : ℕ) : x.coprime p → x.nat_abs ∈ units (p_adic_int p) := sorry

/--`theorem`
Galois' Conjugates
Given a prime number $p$ and a natural number $x$, let $y$ be a $p$-adic conjugate of $x$, that is, $y \equiv x \pmod {p^2}$. Then $y$ is a unit.
`proof`
We prove the contrapositive, that is, if $y$ is not a unit, then $p | y$.
We know that $y \equiv x \pmod {p^2}$. Also, we have that $y \equiv 0 \pmod p$, as this is true for all $p$-adic conjugates.
Thus, $p | y$.
This completes the proof.

QED
-/
theorem p_adic_conjugates
(p : ℕ) (hp : prime p) (x : ℕ) (y : ℕ) : y ≡ x [ZMOD p^2] → y.nat_abs ∉ units (p_adic_int p) → p ∣ y := sorry

/--`theorem`
Finite Cardinality Characteristic
Let $\struct {G, \circ}$ be a group. Then the number of elements of $G$ is either finite or countably infinite.
`proof`
The proof is by induction on the number of elements of $G$. The base case is when $G$ has no elements.
In this case, $G$ is empty, so the number of elements of $G$ is finite.

Now assume that the result holds for all groups with $n$ elements, for all natural numbers $n$ no bigger than some fixed $k$, and assume that $G$ has $k+1$ elements. Let $x$ be one of the $k+1$ elements of $G$.

We claim that $G$ is the disjoint union of the following sets:
:$S_1 = \set{e}$
:$S_2 = \set{x}$
:$S_3 = \set{a : a \in G, a \neq e, a \neq x}$
:$S_4 = \set{a \circ x^{-1} : a \in G}$

To show that $G$ is the disjoint union of $S_1, S_2, S_3,$ and $S_4$, we must show that the following are true:
:$G = S_1 \cup S_2 \cup S_3 \cup S_4$
:$S_1 \cap S_2 = \emptyset$
:$S_1 \cap S_3 = \emptyset$
:$S_1 \cap S_4 = \emptyset$
:$S_2 \cap S_3 = \emptyset$
:$S_2 \cap S_4 = \emptyset$
:$S_3 \cap S_4 = \emptyset$

First, $G = S_1 \cup S_2 \cup S_3 \cup S_4$.
This is true because the members of $S_1$, $S_2$, $S_3$, and $S_4$ are all elements of $G$.

Second, $S_1 \cap S_2 = \emptyset$.
This is true because $S_1$ and $S_2$ are both singleton sets, so they can only intersect if they have the same element, but $x \neq e$.

Third, $S_1 \cap S_3 = \emptyset$.
This is true because $G$ is a group, so the identity element is unique.

Fourth, $S_1 \cap S_4 = \emptyset$.
This is true because $S_4$ does not contain $e$ or $x$.

Fifth, $S_2 \cap S_3 = \emptyset$.
This is true because $S_2$ and $S_3$ are disjoint by construction.

Sixth, $S_2 \cap S_4 = \emptyset$.
This is true because $S_2$ contains $x$, and there is no element $a$ such that $a \circ x^{-1} = x$.

Last, $S_3 \cap S_4 = \emptyset$.
This is true because $S_3$ does not contain $x$ and $S_4$ does not contain $e$.

The sets $S_1$, $S_2$, and $S_3$ are all finite, so we need only show that $S_4$ is finite.

Because $S_4$ is the set of all elements of $G$ that are conjugates of $x$, its cardinality is the number of conjugates of $x$.

Suppose that $x$ has $k$ conjugates. Then the number of elements of $G$ is the sum of $k$, 1, and $k$, which is $k + 1 + k = 2k + 1$, so the number of elements of $G$ is finite.

We conclude that if $G$ has $2k+1$ elements, it cannot have $k+1$ conjugates, so $G$ has no more than $k$ conjugates.

Assume that $G$ has $k+1$ conjugates. Then $G$ has $2k+1$ elements, because of the above argument.
This contradicts the induction hypothesis, which states that a group with $2k+1$ elements must have $k$ or fewer conjugates, so $G$ must have $k$ or fewer conjugates.

Because $G$ has $k$ or fewer conjugates, the number of elements of $G$ is either $2k+1$ or less than $2k+1$.

We conclude that if $G$ has $k+1$ elements, it cannot have $k+1$ conjugates, so $G$ has either $k$ elements or fewer, or $2k+1$ elements or less.

We conclude that if $G$ has $k+1$ elements, it has either $k$ or fewer elements, or it has $2k+1$ or fewer elements.
{{qed}}
-/
theorem finite_cardinality_characteristic {G : Type*} [group G] : (finite (set.card G)) ∨ (set.card G = cardinal.omega) :=
begin
  sorry,
end

/- FEW SHOT PROMPTS TO CODEX(START)
/--`theorem`
Power Set is Closed under Intersection
Let $S$ be a set.

Let $\powerset S$ be the power set of $S$.

Then:
:$\forall A, B \in \powerset S: A \cap B \in \powerset S$
`proof`
Let $A, B \in \powerset S$.

Then by the definition of power set, $A \subseteq S$ and $B \subseteq S$.

From Intersection is Subset we have that $A \cap B \subseteq A$.

It follows from Subset Relation is Transitive that $A \cap B \subseteq S$.

Thus $A \cap B \in \powerset S$ and closure is proved.
{{qed}}
-/
theorem power_set_intersection_closed {α : Type*} (S : set α) : ∀ A B ∈ 𝒫 S, (A ∩ B) ∈ 𝒫 S :=
begin
  assume (A : set α) (hA : A ∈ 𝒫 S) (B : set α) (hB : B ∈ 𝒫 S),
  have h1 : (A ⊆ S) ∧ (B ⊆ S), from sorry,
  have h2 : (A ∩ B) ⊆ A, from sorry,
  have h3 : (A ∩ B) ⊆ S, from sorry,
  show (A ∩ B) ∈  𝒫 S, from sorry,
end

/--`theorem`
Square of Sum
 :$\forall x, y \in \R: \paren {x + y}^2 = x^2 + 2 x y + y^2$
`proof`
Follows from the distribution of multiplication over addition:

{{begin-eqn}}
{{eqn | l = \left({x + y}\right)^2
      | r = \left({x + y}\right) \cdot \left({x + y}\right)
}}
{{eqn | r = x \cdot \left({x + y}\right) + y \cdot \left({x + y}\right)
      | c = Real Multiplication Distributes over Addition
}}
{{eqn | r = x \cdot x + x \cdot y + y \cdot x + y \cdot y
      | c = Real Multiplication Distributes over Addition
}}
{{eqn | r = x^2 + 2xy + y^2
      | c =
}}
{{end-eqn}}
{{qed}}
-/
theorem square_of_sum (x y : ℝ) : (x + y)^2 = (x^2 + 2*x*y + y^2) :=
begin
  calc (x + y)^2 = (x+y)*(x+y) : by sorry
  ... = x*(x+y) + y*(x+y) : by sorry
  ... = x*x + x*y + y*x + y*y : by sorry
  ... = x^2 + 2*x*y + y^2 : by sorry,
end

/--`theorem`
Identity of Group is Unique
Let $\struct {G, \circ}$ be a group. Then there is a unique identity element $e \in G$.
`proof`
From Group has Latin Square Property, there exists a unique $x \in G$ such that:
:$a x = b$

and there exists a unique $y \in G$ such that:
:$y a = b$

Setting $b = a$, this becomes:

There exists a unique $x \in G$ such that:
:$a x = a$

and there exists a unique $y \in G$ such that:
:$y a = a$

These $x$ and $y$ are both $e$, by definition of identity element.
{{qed}}
-/
theorem group_identity_unique {G : Type*} [group G] : ∃! e : G, ∀ a : G, e * a = a ∧ a * e = a :=
begin
  have h1 : ∀ a b : G, ∃! x : G, a * x = b, from sorry,
  have h2 : ∀ a b : G, ∃! y : G, y * a = b, from sorry,

  have h3 : ∀ a : G, ∃! x : G, a * x = a, from sorry,
  have h4 : ∀ a : G, ∃! y : G, y * a = a, from sorry,

  have h5 : ∀ a : G, classical.some (h3 a) = (1 : G), from sorry,
  have h6 : ∀ a : G, classical.some (h4 a) = (1 : G), from sorry,

  show ∃! e : G, ∀ a : G, e * a = a ∧ a * e = a, from by {
    use (1 : G),
    have h7 : ∀ e : G, (∀ a : G, e * a = a ∧ a * e = a) → e = 1, from by {
      assume (e : G) (h7 : ∀ a : G, e * a = a ∧ a * e = a),
      have h8 : ∀ a : G, e = classical.some (h3 a), from sorry,
      have h9 : ∀ a : G, e = classical.some (h4 a), from sorry,
      show e = (1 : G), from sorry,
    },
    sorry,
  }
end

/--`theorem`
p-adic units
Given a prime number $p$ and a natural number $x$, if $x$ is coprime to $p$, then $x$ is a unit in the $p$-adic integers.
`proof`
Let us prove the contrapositive, that is, is $x$ is not a unit of $\mathbb{Z}_p$, then $x$ is not coprime to $p$.
We know that any element of $\mathbb{Z}_p$ is a unit if and only if it has norm 1, thus $\Vert x \Vert \neq 1$. Also, since every element of $\mathbb{Z}_p$ must have norm less than or equal to 1, we conclude that $\Vert x \Vert < 1$.
But this must imply that $p | x$.
This completes our proof.

QED
-/
theorem
FEW SHOT PROMPTS TO CODEX(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 category_theory.category.Kleisli
! leanprover-community/mathlib commit c3291da49cfa65f0d43b094750541c0731edc932
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.CategoryTheory.Category.Basic

/-!
# The Kleisli construction on the Type category

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

Define the Kleisli category for (control) monads.
`category_theory/monad/kleisli` defines the general version for a monad on `C`, and demonstrates
the equivalence between the two.

## TODO

Generalise this to work with category_theory.monad
-/

universe u v

namespace CategoryTheory

#print CategoryTheory.KleisliCat /-
/-- The Kleisli category on the (type-)monad `m`. Note that the monad is not assumed to be lawful
yet. -/
@[nolint unused_arguments]
def KleisliCat (m : Type u → Type v) :=
  Type u
#align category_theory.Kleisli CategoryTheory.KleisliCat
-/

#print CategoryTheory.KleisliCat.mk /-
/-- Construct an object of the Kleisli category from a type. -/
def KleisliCat.mk (m) (α : Type u) : KleisliCat m :=
  α
#align category_theory.Kleisli.mk CategoryTheory.KleisliCat.mk
-/

#print CategoryTheory.KleisliCat.categoryStruct /-
instance KleisliCat.categoryStruct {m} [Monad.{u, v} m] : CategoryStruct (KleisliCat m)
    where
  Hom α β := α → m β
  id α x := pure x
  comp X Y Z f g := f >=> g
#align category_theory.Kleisli.category_struct CategoryTheory.KleisliCat.categoryStruct
-/

#print CategoryTheory.KleisliCat.category /-
instance KleisliCat.category {m} [Monad.{u, v} m] [LawfulMonad m] : Category (KleisliCat m) := by
  refine' {   id_comp' := _
              comp_id' := _
              assoc' := _ } <;> intros <;> ext <;> unfold_projs <;>
    simp only [(· >=> ·), functor_norm]
#align category_theory.Kleisli.category CategoryTheory.KleisliCat.category
-/

/- warning: category_theory.Kleisli.id_def -> CategoryTheory.KleisliCat.id_def is a dubious translation:
lean 3 declaration is
  forall {m : Type.{u1} -> Type.{u2}} [_inst_1 : Monad.{u1, u2} m] (α : CategoryTheory.KleisliCat.{u1, u2} m), Eq.{succ (max u1 u2)} (Quiver.Hom.{succ (max u1 u2), succ u1} (CategoryTheory.KleisliCat.{u1, u2} m) (CategoryTheory.CategoryStruct.toQuiver.{max u1 u2, succ u1} (CategoryTheory.KleisliCat.{u1, u2} m) (CategoryTheory.KleisliCat.categoryStruct.{u1, u2} m _inst_1)) α α) (CategoryTheory.CategoryStruct.id.{max u1 u2, succ u1} (CategoryTheory.KleisliCat.{u1, u2} m) (CategoryTheory.KleisliCat.categoryStruct.{u1, u2} m _inst_1) α) (Pure.pure.{u1, u2} m (Applicative.toHasPure.{u1, u2} m (Monad.toApplicative.{u1, u2} m _inst_1)) α)
but is expected to have type
  forall {m : Type.{u2} -> Type.{u1}} [_inst_1 : Monad.{u2, u1} m] (α : CategoryTheory.KleisliCat.{u2, u1} m), Eq.{max (succ u1) (succ u2)} (Quiver.Hom.{succ (max u1 u2), succ u2} (CategoryTheory.KleisliCat.{u2, u1} m) (CategoryTheory.CategoryStruct.toQuiver.{max u1 u2, succ u2} (CategoryTheory.KleisliCat.{u2, u1} m) (CategoryTheory.KleisliCat.categoryStruct.{u2, u1} m _inst_1)) α α) (CategoryTheory.CategoryStruct.id.{max u1 u2, succ u2} (CategoryTheory.KleisliCat.{u2, u1} m) (CategoryTheory.KleisliCat.categoryStruct.{u2, u1} m _inst_1) α) (Pure.pure.{u2, u1} m (Applicative.toPure.{u2, u1} m (Monad.toApplicative.{u2, u1} m _inst_1)) α)
Case conversion may be inaccurate. Consider using '#align category_theory.Kleisli.id_def CategoryTheory.KleisliCat.id_defₓ'. -/
@[simp]
theorem KleisliCat.id_def {m} [Monad m] (α : KleisliCat m) : 𝟙 α = @pure m _ α :=
  rfl
#align category_theory.Kleisli.id_def CategoryTheory.KleisliCat.id_def

/- warning: category_theory.Kleisli.comp_def -> CategoryTheory.KleisliCat.comp_def is a dubious translation:
lean 3 declaration is
  forall {m : Type.{u1} -> Type.{u2}} [_inst_1 : Monad.{u1, u2} m] (α : CategoryTheory.KleisliCat.{u1, u2} m) (β : CategoryTheory.KleisliCat.{u1, u2} m) (γ : CategoryTheory.KleisliCat.{u1, u2} m) (xs : Quiver.Hom.{succ (max u1 u2), succ u1} (CategoryTheory.KleisliCat.{u1, u2} m) (CategoryTheory.CategoryStruct.toQuiver.{max u1 u2, succ u1} (CategoryTheory.KleisliCat.{u1, u2} m) (CategoryTheory.KleisliCat.categoryStruct.{u1, u2} m _inst_1)) α β) (ys : Quiver.Hom.{succ (max u1 u2), succ u1} (CategoryTheory.KleisliCat.{u1, u2} m) (CategoryTheory.CategoryStruct.toQuiver.{max u1 u2, succ u1} (CategoryTheory.KleisliCat.{u1, u2} m) (CategoryTheory.KleisliCat.categoryStruct.{u1, u2} m _inst_1)) β γ) (a : α), Eq.{succ u2} (m γ) (CategoryTheory.CategoryStruct.comp.{max u1 u2, succ u1} (CategoryTheory.KleisliCat.{u1, u2} m) (CategoryTheory.KleisliCat.categoryStruct.{u1, u2} m _inst_1) α β γ xs ys a) (Bind.bind.{u1, u2} m (Monad.toHasBind.{u1, u2} m _inst_1) β γ (xs a) ys)
but is expected to have type
  forall {m : Type.{u2} -> Type.{u1}} [_inst_1 : Monad.{u2, u1} m] (α : CategoryTheory.KleisliCat.{u2, u1} m) (β : CategoryTheory.KleisliCat.{u2, u1} m) (γ : CategoryTheory.KleisliCat.{u2, u1} m) (xs : Quiver.Hom.{max (succ u1) (succ u2), succ u2} (CategoryTheory.KleisliCat.{u2, u1} m) (CategoryTheory.CategoryStruct.toQuiver.{max u1 u2, succ u2} (CategoryTheory.KleisliCat.{u2, u1} m) (CategoryTheory.KleisliCat.categoryStruct.{u2, u1} m _inst_1)) α β) (ys : Quiver.Hom.{max (succ u1) (succ u2), succ u2} (CategoryTheory.KleisliCat.{u2, u1} m) (CategoryTheory.CategoryStruct.toQuiver.{max u1 u2, succ u2} (CategoryTheory.KleisliCat.{u2, u1} m) (CategoryTheory.KleisliCat.categoryStruct.{u2, u1} m _inst_1)) β γ) (a : α), Eq.{succ u1} (m γ) (CategoryTheory.CategoryStruct.comp.{max u1 u2, succ u2} (CategoryTheory.KleisliCat.{u2, u1} m) (CategoryTheory.KleisliCat.categoryStruct.{u2, u1} m _inst_1) α β γ xs ys a) (Bind.bind.{u2, u1} m (Monad.toBind.{u2, u1} m _inst_1) β γ (xs a) ys)
Case conversion may be inaccurate. Consider using '#align category_theory.Kleisli.comp_def CategoryTheory.KleisliCat.comp_defₓ'. -/
theorem KleisliCat.comp_def {m} [Monad m] (α β γ : KleisliCat m) (xs : α ⟶ β) (ys : β ⟶ γ) (a : α) :
    (xs ≫ ys) a = xs a >>= ys :=
  rfl
#align category_theory.Kleisli.comp_def CategoryTheory.KleisliCat.comp_def

instance : Inhabited (KleisliCat id) :=
  ⟨PUnit⟩

instance {α : Type u} [Inhabited α] : Inhabited (KleisliCat.mk id α) :=
  ⟨show α from default⟩

end CategoryTheory