/-
Copyright (c) 2018 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.algebra.group.hom
import Mathlib.data.equiv.basic
import Mathlib.PostPort

universes u_1 u v

namespace Mathlib

/-!
# Type tags that turn additive structures into multiplicative, and vice versa

We define two type tags:

* `additive α`: turns any multiplicative structure on `α` into the corresponding
  additive structure on `additive α`;
* `multiplicative α`: turns any additive structure on `α` into the corresponding
  multiplicative structure on `multiplicative α`.

We also define instances `additive.*` and `multiplicative.*` that actually transfer the structures.
-/

/-- If `α` carries some multiplicative structure, then `additive α` carries the corresponding
additive structure. -/
/-- If `α` carries some additive structure, then `multiplicative α` carries the corresponding
def additive (α : Type u_1) :=
  α

multiplicative structure. -/
def multiplicative (α : Type u_1) :=
  α

namespace additive

/-- Reinterpret `x : α` as an element of `additive α`. -/
def of_mul {α : Type u} : α ≃ additive α :=
  equiv.mk (fun (x : α) => x) (fun (x : additive α) => x) sorry sorry

/-- Reinterpret `x : additive α` as an element of `α`. -/
def to_mul {α : Type u} : additive α ≃ α :=
  equiv.symm of_mul

@[simp] theorem of_mul_symm_eq {α : Type u} : equiv.symm of_mul = to_mul :=
  rfl

@[simp] theorem to_mul_symm_eq {α : Type u} : equiv.symm to_mul = of_mul :=
  rfl

end additive

namespace multiplicative

/-- Reinterpret `x : α` as an element of `multiplicative α`. -/
def of_add {α : Type u} : α ≃ multiplicative α :=
  equiv.mk (fun (x : α) => x) (fun (x : multiplicative α) => x) sorry sorry

/-- Reinterpret `x : multiplicative α` as an element of `α`. -/
def to_add {α : Type u} : multiplicative α ≃ α :=
  equiv.symm of_add

@[simp] theorem of_add_symm_eq {α : Type u} : equiv.symm of_add = to_add :=
  rfl

@[simp] theorem to_add_symm_eq {α : Type u} : equiv.symm to_add = of_add :=
  rfl

end multiplicative

@[simp] theorem to_add_of_add {α : Type u} (x : α) : coe_fn multiplicative.to_add (coe_fn multiplicative.of_add x) = x :=
  rfl

@[simp] theorem of_add_to_add {α : Type u} (x : multiplicative α) : coe_fn multiplicative.of_add (coe_fn multiplicative.to_add x) = x :=
  rfl

@[simp] theorem to_mul_of_mul {α : Type u} (x : α) : coe_fn additive.to_mul (coe_fn additive.of_mul x) = x :=
  rfl

@[simp] theorem of_mul_to_mul {α : Type u} (x : additive α) : coe_fn additive.of_mul (coe_fn additive.to_mul x) = x :=
  rfl

protected instance additive.inhabited {α : Type u} [Inhabited α] : Inhabited (additive α) :=
  { default := coe_fn additive.of_mul Inhabited.default }

protected instance multiplicative.inhabited {α : Type u} [Inhabited α] : Inhabited (multiplicative α) :=
  { default := coe_fn multiplicative.of_add Inhabited.default }

protected instance additive.has_add {α : Type u} [Mul α] : Add (additive α) :=
  { add := fun (x y : additive α) => coe_fn additive.of_mul (coe_fn additive.to_mul x * coe_fn additive.to_mul y) }

protected instance multiplicative.has_mul {α : Type u} [Add α] : Mul (multiplicative α) :=
  { mul :=
      fun (x y : multiplicative α) =>
        coe_fn multiplicative.of_add (coe_fn multiplicative.to_add x + coe_fn multiplicative.to_add y) }

@[simp] theorem of_add_add {α : Type u} [Add α] (x : α) (y : α) : coe_fn multiplicative.of_add (x + y) = coe_fn multiplicative.of_add x * coe_fn multiplicative.of_add y :=
  rfl

@[simp] theorem to_add_mul {α : Type u} [Add α] (x : multiplicative α) (y : multiplicative α) : coe_fn multiplicative.to_add (x * y) = coe_fn multiplicative.to_add x + coe_fn multiplicative.to_add y :=
  rfl

@[simp] theorem of_mul_mul {α : Type u} [Mul α] (x : α) (y : α) : coe_fn additive.of_mul (x * y) = coe_fn additive.of_mul x + coe_fn additive.of_mul y :=
  rfl

@[simp] theorem to_mul_add {α : Type u} [Mul α] (x : additive α) (y : additive α) : coe_fn additive.to_mul (x + y) = coe_fn additive.to_mul x * coe_fn additive.to_mul y :=
  rfl

protected instance additive.add_semigroup {α : Type u} [semigroup α] : add_semigroup (additive α) :=
  add_semigroup.mk Add.add mul_assoc

protected instance multiplicative.semigroup {α : Type u} [add_semigroup α] : semigroup (multiplicative α) :=
  semigroup.mk Mul.mul add_assoc

protected instance additive.add_comm_semigroup {α : Type u} [comm_semigroup α] : add_comm_semigroup (additive α) :=
  add_comm_semigroup.mk add_semigroup.add sorry sorry

protected instance multiplicative.comm_semigroup {α : Type u} [add_comm_semigroup α] : comm_semigroup (multiplicative α) :=
  comm_semigroup.mk semigroup.mul sorry sorry

protected instance additive.add_left_cancel_semigroup {α : Type u} [left_cancel_semigroup α] : add_left_cancel_semigroup (additive α) :=
  add_left_cancel_semigroup.mk add_semigroup.add sorry sorry

protected instance multiplicative.left_cancel_semigroup {α : Type u} [add_left_cancel_semigroup α] : left_cancel_semigroup (multiplicative α) :=
  left_cancel_semigroup.mk semigroup.mul sorry sorry

protected instance additive.add_right_cancel_semigroup {α : Type u} [right_cancel_semigroup α] : add_right_cancel_semigroup (additive α) :=
  add_right_cancel_semigroup.mk add_semigroup.add sorry sorry

protected instance multiplicative.right_cancel_semigroup {α : Type u} [add_right_cancel_semigroup α] : right_cancel_semigroup (multiplicative α) :=
  right_cancel_semigroup.mk semigroup.mul sorry sorry

protected instance additive.has_zero {α : Type u} [HasOne α] : HasZero (additive α) :=
  { zero := coe_fn additive.of_mul 1 }

@[simp] theorem of_mul_one {α : Type u} [HasOne α] : coe_fn additive.of_mul 1 = 0 :=
  rfl

@[simp] theorem to_mul_zero {α : Type u} [HasOne α] : coe_fn additive.to_mul 0 = 1 :=
  rfl

protected instance multiplicative.has_one {α : Type u} [HasZero α] : HasOne (multiplicative α) :=
  { one := coe_fn multiplicative.of_add 0 }

@[simp] theorem of_add_zero {α : Type u} [HasZero α] : coe_fn multiplicative.of_add 0 = 1 :=
  rfl

@[simp] theorem to_add_one {α : Type u} [HasZero α] : coe_fn multiplicative.to_add 1 = 0 :=
  rfl

protected instance additive.add_monoid {α : Type u} [monoid α] : add_monoid (additive α) :=
  add_monoid.mk add_semigroup.add sorry 0 sorry sorry

protected instance multiplicative.monoid {α : Type u} [add_monoid α] : monoid (multiplicative α) :=
  monoid.mk semigroup.mul sorry 1 sorry sorry

protected instance additive.add_comm_monoid {α : Type u} [comm_monoid α] : add_comm_monoid (additive α) :=
  add_comm_monoid.mk add_monoid.add sorry add_monoid.zero sorry sorry sorry

protected instance multiplicative.comm_monoid {α : Type u} [add_comm_monoid α] : comm_monoid (multiplicative α) :=
  comm_monoid.mk monoid.mul sorry monoid.one sorry sorry sorry

protected instance additive.has_neg {α : Type u} [has_inv α] : Neg (additive α) :=
  { neg := fun (x : additive α) => coe_fn multiplicative.of_add (coe_fn additive.to_mul x⁻¹) }

@[simp] theorem of_mul_inv {α : Type u} [has_inv α] (x : α) : coe_fn additive.of_mul (x⁻¹) = -coe_fn additive.of_mul x :=
  rfl

@[simp] theorem to_mul_neg {α : Type u} [has_inv α] (x : additive α) : coe_fn additive.to_mul (-x) = (coe_fn additive.to_mul x⁻¹) :=
  rfl

protected instance multiplicative.has_inv {α : Type u} [Neg α] : has_inv (multiplicative α) :=
  has_inv.mk fun (x : multiplicative α) => coe_fn additive.of_mul (-coe_fn multiplicative.to_add x)

@[simp] theorem of_add_neg {α : Type u} [Neg α] (x : α) : coe_fn multiplicative.of_add (-x) = (coe_fn multiplicative.of_add x⁻¹) :=
  rfl

@[simp] theorem to_add_inv {α : Type u} [Neg α] (x : multiplicative α) : coe_fn multiplicative.to_add (x⁻¹) = -coe_fn multiplicative.to_add x :=
  rfl

protected instance additive.has_sub {α : Type u} [Div α] : Sub (additive α) :=
  { sub := fun (x y : additive α) => coe_fn additive.of_mul (coe_fn additive.to_mul x / coe_fn additive.to_mul y) }

protected instance multiplicative.has_div {α : Type u} [Sub α] : Div (multiplicative α) :=
  { div :=
      fun (x y : multiplicative α) =>
        coe_fn multiplicative.of_add (coe_fn multiplicative.to_add x - coe_fn multiplicative.to_add y) }

@[simp] theorem of_add_sub {α : Type u} [Sub α] (x : α) (y : α) : coe_fn multiplicative.of_add (x - y) = coe_fn multiplicative.of_add x / coe_fn multiplicative.of_add y :=
  rfl

@[simp] theorem to_add_div {α : Type u} [Sub α] (x : multiplicative α) (y : multiplicative α) : coe_fn multiplicative.to_add (x / y) = coe_fn multiplicative.to_add x - coe_fn multiplicative.to_add y :=
  rfl

@[simp] theorem of_mul_div {α : Type u} [Div α] (x : α) (y : α) : coe_fn additive.of_mul (x / y) = coe_fn additive.of_mul x - coe_fn additive.of_mul y :=
  rfl

@[simp] theorem to_mul_sub {α : Type u} [Div α] (x : additive α) (y : additive α) : coe_fn additive.to_mul (x - y) = coe_fn additive.to_mul x / coe_fn additive.to_mul y :=
  rfl

protected instance additive.sub_neg_monoid {α : Type u} [div_inv_monoid α] : sub_neg_monoid (additive α) :=
  sub_neg_monoid.mk add_monoid.add sorry add_monoid.zero sorry sorry Neg.neg Sub.sub

protected instance multiplicative.div_inv_monoid {α : Type u} [sub_neg_monoid α] : div_inv_monoid (multiplicative α) :=
  div_inv_monoid.mk monoid.mul sorry monoid.one sorry sorry has_inv.inv Div.div

protected instance additive.add_group {α : Type u} [group α] : add_group (additive α) :=
  add_group.mk sub_neg_monoid.add sorry sub_neg_monoid.zero sorry sorry sub_neg_monoid.neg sub_neg_monoid.sub mul_left_inv

protected instance multiplicative.group {α : Type u} [add_group α] : group (multiplicative α) :=
  group.mk div_inv_monoid.mul sorry div_inv_monoid.one sorry sorry div_inv_monoid.inv div_inv_monoid.div add_left_neg

protected instance additive.add_comm_group {α : Type u} [comm_group α] : add_comm_group (additive α) :=
  add_comm_group.mk add_group.add sorry add_group.zero sorry sorry add_group.neg add_group.sub sorry sorry

protected instance multiplicative.comm_group {α : Type u} [add_comm_group α] : comm_group (multiplicative α) :=
  comm_group.mk group.mul sorry group.one sorry sorry group.inv group.div sorry sorry

/-- Reinterpret `α →+ β` as `multiplicative α →* multiplicative β`. -/
def add_monoid_hom.to_multiplicative {α : Type u} {β : Type v} [add_monoid α] [add_monoid β] : (α →+ β) ≃ (multiplicative α →* multiplicative β) :=
  equiv.mk
    (fun (f : α →+ β) => monoid_hom.mk (add_monoid_hom.to_fun f) (add_monoid_hom.map_zero' f) (add_monoid_hom.map_add' f))
    (fun (f : multiplicative α →* multiplicative β) => add_monoid_hom.mk (monoid_hom.to_fun f) sorry sorry) sorry sorry

/-- Reinterpret `α →* β` as `additive α →+ additive β`. -/
def monoid_hom.to_additive {α : Type u} {β : Type v} [monoid α] [monoid β] : (α →* β) ≃ (additive α →+ additive β) :=
  equiv.mk (fun (f : α →* β) => add_monoid_hom.mk (monoid_hom.to_fun f) (monoid_hom.map_one' f) (monoid_hom.map_mul' f))
    (fun (f : additive α →+ additive β) => monoid_hom.mk (add_monoid_hom.to_fun f) sorry sorry) sorry sorry

/-- Reinterpret `additive α →+ β` as `α →* multiplicative β`. -/
def add_monoid_hom.to_multiplicative' {α : Type u} {β : Type v} [monoid α] [add_monoid β] : (additive α →+ β) ≃ (α →* multiplicative β) :=
  equiv.mk (fun (f : additive α →+ β) => monoid_hom.mk (add_monoid_hom.to_fun f) sorry sorry)
    (fun (f : α →* multiplicative β) => add_monoid_hom.mk (monoid_hom.to_fun f) sorry sorry) sorry sorry

/-- Reinterpret `α →* multiplicative β` as `additive α →+ β`. -/
def monoid_hom.to_additive' {α : Type u} {β : Type v} [monoid α] [add_monoid β] : (α →* multiplicative β) ≃ (additive α →+ β) :=
  equiv.symm add_monoid_hom.to_multiplicative'

/-- Reinterpret `α →+ additive β` as `multiplicative α →* β`. -/
def add_monoid_hom.to_multiplicative'' {α : Type u} {β : Type v} [add_monoid α] [monoid β] : (α →+ additive β) ≃ (multiplicative α →* β) :=
  equiv.mk (fun (f : α →+ additive β) => monoid_hom.mk (add_monoid_hom.to_fun f) sorry sorry)
    (fun (f : multiplicative α →* β) => add_monoid_hom.mk (monoid_hom.to_fun f) sorry sorry) sorry sorry

/-- Reinterpret `multiplicative α →* β` as `α →+ additive β`. -/
def monoid_hom.to_additive'' {α : Type u} {β : Type v} [add_monoid α] [monoid β] : (multiplicative α →* β) ≃ (α →+ additive β) :=
  equiv.symm add_monoid_hom.to_multiplicative''


/-
Copyright (c) 2017 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl, Mario Carneiro
-/
import data.equiv.basic
import data.fun_like.embedding
import data.pprod
import data.set.basic
import data.sigma.basic

/-!
# Injective functions
-/

universes u v w x

namespace function

/-- `α ↪ β` is a bundled injective function. -/
@[nolint has_inhabited_instance] -- depending on cardinalities, an injective function may not exist
structure embedding (α : Sort*) (β : Sort*) :=
(to_fun : α → β)
(inj'   : injective to_fun)

infixr ` ↪ `:25 := embedding

instance {α : Sort u} {β : Sort v} : has_coe_to_fun (α ↪ β) (λ _, α → β) := ⟨embedding.to_fun⟩

initialize_simps_projections embedding (to_fun → apply)

instance {α : Sort u} {β : Sort v} : embedding_like (α ↪ β) α β :=
{ coe := embedding.to_fun,
  injective' := embedding.inj',
  coe_injective' := λ f g h, by { cases f, cases g, congr' } }

end function

section equiv

variables {α : Sort u} {β : Sort v} (f : α ≃ β)

/-- Convert an `α ≃ β` to `α ↪ β`.

This is also available as a coercion `equiv.coe_embedding`.
The explicit `equiv.to_embedding` version is preferred though, since the coercion can have issues
inferring the type of the resulting embedding. For example:

```lean
-- Works:
example (s : finset (fin 3)) (f : equiv.perm (fin 3)) : s.map f.to_embedding = s.map f := by simp
-- Error, `f` has type `fin 3 ≃ fin 3` but is expected to have type `fin 3 ↪ ?m_1 : Type ?`
example (s : finset (fin 3)) (f : equiv.perm (fin 3)) : s.map f = s.map f.to_embedding := by simp
```
-/
@[simps] protected def equiv.to_embedding : α ↪ β := ⟨f, f.injective⟩

instance equiv.coe_embedding : has_coe (α ≃ β) (α ↪ β) := ⟨equiv.to_embedding⟩

@[reducible]
instance equiv.perm.coe_embedding : has_coe (equiv.perm α) (α ↪ α) := equiv.coe_embedding

@[simp] lemma equiv.coe_eq_to_embedding  : ↑f = f.to_embedding := rfl

/-- Given an equivalence to a subtype, produce an embedding to the elements of the corresponding
set. -/
@[simps]
def equiv.as_embedding {p : β → Prop} (e : α ≃ subtype p) : α ↪ β :=
⟨coe ∘ e, subtype.coe_injective.comp e.injective⟩

@[simp]
lemma equiv.as_embedding_range {α β : Sort*} {p : β → Prop} (e : α ≃ subtype p) :
  set.range e.as_embedding = set_of p :=
set.ext $ λ x, ⟨λ ⟨y, h⟩, h ▸ subtype.coe_prop (e y), λ hs, ⟨e.symm ⟨x, hs⟩, by simp⟩⟩

end equiv

namespace function
namespace embedding

lemma coe_injective {α β} : @function.injective (α ↪ β) (α → β) coe_fn := fun_like.coe_injective

@[ext] lemma ext {α β} {f g : embedding α β} (h : ∀ x, f x = g x) : f = g := fun_like.ext f g h

lemma ext_iff {α β} {f g : embedding α β} : (∀ x, f x = g x) ↔ f = g := fun_like.ext_iff.symm

@[simp] theorem to_fun_eq_coe {α β} (f : α ↪ β) : to_fun f = f := rfl

@[simp] theorem coe_fn_mk {α β} (f : α → β) (i) :
  (@mk _ _ f i : α → β) = f := rfl

@[simp] lemma mk_coe {α β : Type*} (f : α ↪ β) (inj) : (⟨f, inj⟩ : α ↪ β) = f :=
by { ext, simp }

protected theorem injective {α β} (f : α ↪ β) : injective f := embedding_like.injective f

lemma apply_eq_iff_eq {α β} (f : α ↪ β) (x y : α) : f x = f y ↔ x = y :=
embedding_like.apply_eq_iff_eq f

/-- The identity map as a `function.embedding`. -/
@[refl, simps {simp_rhs := tt}]
protected def refl (α : Sort*) : α ↪ α :=
⟨id, injective_id⟩

/-- Composition of `f : α ↪ β` and `g : β ↪ γ`. -/
@[trans, simps {simp_rhs := tt}]
protected def trans {α β γ} (f : α ↪ β) (g : β ↪ γ) : α ↪ γ :=
⟨g ∘ f, g.injective.comp f.injective⟩

@[simp]
lemma equiv_to_embedding_trans_symm_to_embedding {α β : Sort*} (e : α ≃ β) :
  e.to_embedding.trans e.symm.to_embedding = embedding.refl _ :=
by { ext, simp, }

@[simp]
lemma equiv_symm_to_embedding_trans_to_embedding {α β : Sort*} (e : α ≃ β) :
  e.symm.to_embedding.trans e.to_embedding = embedding.refl _ :=
by { ext, simp, }

/-- Transfer an embedding along a pair of equivalences. -/
@[simps { fully_applied := ff }]
protected def congr {α : Sort u} {β : Sort v} {γ : Sort w} {δ : Sort x}
  (e₁ : α ≃ β) (e₂ : γ ≃ δ) (f : α ↪ γ) : (β ↪ δ) :=
(equiv.to_embedding e₁.symm).trans (f.trans e₂.to_embedding)

/-- A right inverse `surj_inv` of a surjective function as an `embedding`. -/
protected noncomputable def of_surjective {α β} (f : β → α) (hf : surjective f) :
  α ↪ β :=
⟨surj_inv hf, injective_surj_inv _⟩

/-- Convert a surjective `embedding` to an `equiv` -/
protected noncomputable def equiv_of_surjective {α β} (f : α ↪ β) (hf : surjective f) :
  α ≃ β :=
equiv.of_bijective f ⟨f.injective, hf⟩

/-- There is always an embedding from an empty type. --/
protected def of_is_empty {α β} [is_empty α] : α ↪ β :=
⟨is_empty_elim, is_empty_elim⟩

/-- Change the value of an embedding `f` at one point. If the prescribed image
is already occupied by some `f a'`, then swap the values at these two points. -/
def set_value {α β} (f : α ↪ β) (a : α) (b : β) [∀ a', decidable (a' = a)]
  [∀ a', decidable (f a' = b)] : α ↪ β :=
⟨λ a', if a' = a then b else if f a' = b then f a else f a',
  begin
    intros x y h,
    dsimp at h,
    split_ifs at h; try { substI b }; try { simp only [f.injective.eq_iff] at * }; cc
  end⟩

theorem set_value_eq {α β} (f : α ↪ β) (a : α) (b : β) [∀ a', decidable (a' = a)]
  [∀ a', decidable (f a' = b)] : set_value f a b a = b :=
by simp [set_value]

/-- Embedding into `option α` using `some`. -/
@[simps { fully_applied := ff }] protected def some {α} : α ↪ option α :=
⟨some, option.some_injective α⟩

/-- Embedding into `option α` using `coe`. Usually the correct synctatical form for `simp`. -/
@[simps { fully_applied := ff }]
def coe_option {α} : α ↪ option α := ⟨coe, option.some_injective α⟩

/-- Embedding into `with_top α`. -/
@[simps]
def coe_with_top {α} : α ↪ with_top α := { to_fun := coe, ..embedding.some}

/-- Given an embedding `f : α ↪ β` and a point outside of `set.range f`, construct an embedding
`option α ↪ β`. -/
@[simps] def option_elim {α β} (f : α ↪ β) (x : β) (h : x ∉ set.range f) :
  option α ↪ β :=
⟨λ o, o.elim x f, option.injective_iff.2 ⟨f.2, h⟩⟩

/-- Embedding of a `subtype`. -/
def subtype {α} (p : α → Prop) : subtype p ↪ α :=
⟨coe, λ _ _, subtype.ext_val⟩

@[simp] lemma coe_subtype {α} (p : α → Prop) : ⇑(subtype p) = coe := rfl

/-- Choosing an element `b : β` gives an embedding of `punit` into `β`. -/
def punit {β : Sort*} (b : β) : punit ↪ β :=
⟨λ _, b, by { rintros ⟨⟩ ⟨⟩ _, refl, }⟩

/-- Fixing an element `b : β` gives an embedding `α ↪ α × β`. -/
def sectl (α : Sort*) {β : Sort*} (b : β) : α ↪ α × β :=
⟨λ a, (a, b), λ a a' h, congr_arg prod.fst h⟩

/-- Fixing an element `a : α` gives an embedding `β ↪ α × β`. -/
def sectr {α : Sort*} (a : α) (β : Sort*): β ↪ α × β :=
⟨λ b, (a, b), λ b b' h, congr_arg prod.snd h⟩

/-- Restrict the codomain of an embedding. -/
def cod_restrict {α β} (p : set β) (f : α ↪ β) (H : ∀ a, f a ∈ p) : α ↪ p :=
⟨λ a, ⟨f a, H a⟩, λ a b h, f.injective (@congr_arg _ _ _ _ subtype.val h)⟩

@[simp] theorem cod_restrict_apply {α β} (p) (f : α ↪ β) (H a) :
  cod_restrict p f H a = ⟨f a, H a⟩ := rfl

/-- If `e₁` and `e₂` are embeddings, then so is `prod.map e₁ e₂ : (a, b) ↦ (e₁ a, e₂ b)`. -/
def prod_map {α β γ δ : Type*} (e₁ : α ↪ β) (e₂ : γ ↪ δ) : α × γ ↪ β × δ :=
⟨prod.map e₁ e₂, e₁.injective.prod_map e₂.injective⟩

@[simp] lemma coe_prod_map {α β γ δ : Type*} (e₁ : α ↪ β) (e₂ : γ ↪ δ) :
  ⇑(e₁.prod_map e₂) = prod.map e₁ e₂ :=
rfl

/-- If `e₁` and `e₂` are embeddings, then so is `λ ⟨a, b⟩, ⟨e₁ a, e₂ b⟩ : pprod α γ → pprod β δ`. -/
def pprod_map {α β γ δ : Sort*} (e₁ : α ↪ β) (e₂ : γ ↪ δ) : pprod α γ ↪ pprod β δ :=
⟨λ x, ⟨e₁ x.1, e₂ x.2⟩, e₁.injective.pprod_map e₂.injective⟩

section sum
open sum

/-- If `e₁` and `e₂` are embeddings, then so is `sum.map e₁ e₂`. -/
def sum_map {α β γ δ : Type*} (e₁ : α ↪ β) (e₂ : γ ↪ δ) : α ⊕ γ ↪ β ⊕ δ :=
⟨sum.map e₁ e₂,
    assume s₁ s₂ h, match s₁, s₂, h with
    | inl a₁, inl a₂, h := congr_arg inl $ e₁.injective $ inl.inj h
    | inr b₁, inr b₂, h := congr_arg inr $ e₂.injective $ inr.inj h
    end⟩

@[simp] theorem coe_sum_map {α β γ δ} (e₁ : α ↪ β) (e₂ : γ ↪ δ) :
  ⇑(sum_map e₁ e₂) = sum.map e₁ e₂ :=
rfl

/-- The embedding of `α` into the sum `α ⊕ β`. -/
@[simps] def inl {α β : Type*} : α ↪ α ⊕ β :=
⟨sum.inl, λ a b, sum.inl.inj⟩

/-- The embedding of `β` into the sum `α ⊕ β`. -/
@[simps] def inr {α β : Type*} : β ↪ α ⊕ β :=
⟨sum.inr, λ a b, sum.inr.inj⟩

end sum

section sigma

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

/-- `sigma.mk` as an `function.embedding`. -/
@[simps apply] def sigma_mk (a : α) : β a ↪ Σ x, β x :=
⟨sigma.mk a, sigma_mk_injective⟩

/-- If `f : α ↪ α'` is an embedding and `g : Π a, β α ↪ β' (f α)` is a family
of embeddings, then `sigma.map f g` is an embedding. -/
@[simps apply] def sigma_map (f : α ↪ α') (g : Π a, β a ↪ β' (f a)) :
  (Σ a, β a) ↪ Σ a', β' a' :=
⟨sigma.map f (λ a, g a), f.injective.sigma_map (λ a, (g a).injective)⟩

end sigma

/-- Define an embedding `(Π a : α, β a) ↪ (Π a : α, γ a)` from a family of embeddings
`e : Π a, (β a ↪ γ a)`. This embedding sends `f` to `λ a, e a (f a)`. -/
@[simps] def Pi_congr_right {α : Sort*} {β γ : α → Sort*} (e : ∀ a, β a ↪ γ a) :
  (Π a, β a) ↪ (Π a, γ a) :=
⟨λf a, e a (f a), λ f₁ f₂ h, funext $ λ a, (e a).injective (congr_fun h a)⟩

/-- An embedding `e : α ↪ β` defines an embedding `(γ → α) ↪ (γ → β)` that sends each `f`
to `e ∘ f`. -/
def arrow_congr_right {α : Sort u} {β : Sort v} {γ : Sort w}
  (e : α ↪ β) : (γ → α) ↪ (γ → β) :=
Pi_congr_right (λ _, e)

@[simp] lemma arrow_congr_right_apply {α : Sort u} {β : Sort v} {γ : Sort w}
  (e : α ↪ β) (f : γ ↪ α) : arrow_congr_right e f = e ∘ f := rfl

/-- An embedding `e : α ↪ β` defines an embedding `(α → γ) ↪ (β → γ)` for any inhabited type `γ`.
This embedding sends each `f : α → γ` to a function `g : β → γ` such that `g ∘ e = f` and
`g y = default` whenever `y ∉ range e`. -/
noncomputable def arrow_congr_left {α : Sort u} {β : Sort v} {γ : Sort w} [inhabited γ]
  (e : α ↪ β) : (α → γ) ↪ (β → γ) :=
⟨λ f, extend e f (λ _, default), λ f₁ f₂ h, funext $ λ x,
  by simpa only [extend_apply e.injective] using congr_fun h (e x)⟩

/-- Restrict both domain and codomain of an embedding. -/
protected def subtype_map {α β} {p : α → Prop} {q : β → Prop} (f : α ↪ β)
  (h : ∀{{x}}, p x → q (f x)) : {x : α // p x} ↪ {y : β // q y} :=
⟨subtype.map f h, subtype.map_injective h f.2⟩

open set

/-- `set.image` as an embedding `set α ↪ set β`. -/
@[simps apply] protected def image {α β} (f : α ↪ β) : set α ↪ set β :=
⟨image f, f.2.image_injective⟩

lemma swap_apply {α β : Type*} [decidable_eq α] [decidable_eq β] (f : α ↪ β) (x y z : α) :
  equiv.swap (f x) (f y) (f z) = f (equiv.swap x y z) :=
f.injective.swap_apply x y z

lemma swap_comp {α β : Type*} [decidable_eq α] [decidable_eq β] (f : α ↪ β) (x y : α) :
  equiv.swap (f x) (f y) ∘ f = f ∘ equiv.swap x y :=
f.injective.swap_comp x y

end embedding
end function

namespace equiv

open function.embedding

/-- The type of embeddings `α ↪ β` is equivalent to
    the subtype of all injective functions `α → β`. -/
def subtype_injective_equiv_embedding (α β : Sort*) :
  {f : α → β // function.injective f} ≃ (α ↪ β) :=
{ to_fun := λ f, ⟨f.val, f.property⟩,
  inv_fun := λ f, ⟨f, f.injective⟩,
  left_inv := λ f, by simp,
  right_inv := λ f, by {ext, refl} }

/-- If `α₁ ≃ α₂` and `β₁ ≃ β₂`, then the type of embeddings `α₁ ↪ β₁`
is equivalent to the type of embeddings `α₂ ↪ β₂`. -/
@[congr, simps apply] def embedding_congr {α β γ δ : Sort*}
  (h : α ≃ β) (h' : γ ≃ δ) : (α ↪ γ) ≃ (β ↪ δ) :=
{ to_fun := λ f, f.congr h h',
  inv_fun := λ f, f.congr h.symm h'.symm,
  left_inv := λ x, by {ext, simp},
  right_inv := λ x, by {ext, simp} }

@[simp] lemma embedding_congr_refl {α β : Sort*} :
  embedding_congr (equiv.refl α) (equiv.refl β) = equiv.refl (α ↪ β) :=
by {ext, refl}

@[simp] lemma embedding_congr_trans {α₁ β₁ α₂ β₂ α₃ β₃ : Sort*}
  (e₁ : α₁ ≃ α₂) (e₁' : β₁ ≃ β₂) (e₂ : α₂ ≃ α₃) (e₂' : β₂ ≃ β₃) :
  embedding_congr (e₁.trans e₂) (e₁'.trans e₂') =
  (embedding_congr e₁ e₁').trans (embedding_congr e₂ e₂') :=
rfl

@[simp] lemma embedding_congr_symm {α₁ β₁ α₂ β₂ : Sort*} (e₁ : α₁ ≃ α₂) (e₂ : β₁ ≃ β₂) :
  (embedding_congr e₁ e₂).symm = embedding_congr e₁.symm e₂.symm :=
rfl

lemma embedding_congr_apply_trans {α₁ β₁ γ₁ α₂ β₂ γ₂ : Sort*}
  (ea : α₁ ≃ α₂) (eb : β₁ ≃ β₂) (ec : γ₁ ≃ γ₂) (f : α₁ ↪ β₁) (g : β₁ ↪ γ₁) :
  equiv.embedding_congr ea ec (f.trans g) =
  (equiv.embedding_congr ea eb f).trans (equiv.embedding_congr eb ec g) :=
by {ext, simp}

@[simp]
lemma refl_to_embedding {α : Type*} : (equiv.refl α).to_embedding = function.embedding.refl α := rfl

@[simp]
lemma trans_to_embedding {α β γ : Type*} (e : α ≃ β) (f : β ≃ γ) :
  (e.trans f).to_embedding = e.to_embedding.trans f.to_embedding := rfl

end equiv

namespace set

/-- The injection map is an embedding between subsets. -/
@[simps apply] def embedding_of_subset {α} (s t : set α) (h : s ⊆ t) : s ↪ t :=
⟨λ x, ⟨x.1, h x.2⟩, λ ⟨x, hx⟩ ⟨y, hy⟩ h, by { congr, injection h }⟩

end set

section subtype

variable {α : Type*}

/-- A subtype `{x // p x ∨ q x}` over a disjunction of `p q : α → Prop` can be injectively split
into a sum of subtypes `{x // p x} ⊕ {x // q x}` such that `¬ p x` is sent to the right. -/
def subtype_or_left_embedding (p q : α → Prop) [decidable_pred p] :
  {x // p x ∨ q x} ↪ {x // p x} ⊕ {x // q x} :=
⟨λ x, if h : p x then sum.inl ⟨x, h⟩ else sum.inr ⟨x, x.prop.resolve_left h⟩,
  begin
    intros x y,
    dsimp only,
    split_ifs;
    simp [subtype.ext_iff]
  end⟩

lemma subtype_or_left_embedding_apply_left {p q : α → Prop} [decidable_pred p]
  (x : {x // p x ∨ q x}) (hx : p x) : subtype_or_left_embedding p q x = sum.inl ⟨x, hx⟩ :=
dif_pos hx

lemma subtype_or_left_embedding_apply_right {p q : α → Prop} [decidable_pred p]
  (x : {x // p x ∨ q x}) (hx : ¬ p x) :
  subtype_or_left_embedding p q x = sum.inr ⟨x, x.prop.resolve_left hx⟩ :=
dif_neg hx

/-- A subtype `{x // p x}` can be injectively sent to into a subtype `{x // q x}`,
if `p x → q x` for all `x : α`. -/
@[simps] def subtype.imp_embedding (p q : α → Prop) (h : p ≤ q) :
  {x // p x} ↪ {x // q x} :=
⟨λ x, ⟨x, h x x.prop⟩, λ x y, by simp [subtype.ext_iff]⟩

/-- A subtype `{x // p x ∨ q x}` over a disjunction of `p q : α → Prop` is equivalent to a sum of
subtypes `{x // p x} ⊕ {x // q x}` such that `¬ p x` is sent to the right, when
`disjoint p q`.

See also `equiv.sum_compl`, for when `is_compl p q`.  -/
@[simps apply] def subtype_or_equiv (p q : α → Prop) [decidable_pred p] (h : disjoint p q) :
  {x // p x ∨ q x} ≃ {x // p x} ⊕ {x // q x} :=
{ to_fun := subtype_or_left_embedding p q,
  inv_fun := sum.elim
    (subtype.imp_embedding _ _ (λ x hx, (or.inl hx : p x ∨ q x)))
    (subtype.imp_embedding _ _ (λ x hx, (or.inr hx : p x ∨ q x))),
  left_inv := λ x, begin
    by_cases hx : p x,
    { rw subtype_or_left_embedding_apply_left _ hx,
      simp [subtype.ext_iff] },
    { rw subtype_or_left_embedding_apply_right _ hx,
      simp [subtype.ext_iff] },
  end,
  right_inv := λ x, begin
    cases x,
    { simp only [sum.elim_inl],
      rw subtype_or_left_embedding_apply_left,
      { simp },
      { simpa using x.prop } },
    { simp only [sum.elim_inr],
      rw subtype_or_left_embedding_apply_right,
      { simp },
      { suffices : ¬ p x,
        { simpa },
        intro hp,
        simpa using h x ⟨hp, x.prop⟩ } }
  end }

@[simp] lemma subtype_or_equiv_symm_inl (p q : α → Prop) [decidable_pred p] (h : disjoint p q)
  (x : {x // p x}) : (subtype_or_equiv p q h).symm (sum.inl x) = ⟨x, or.inl x.prop⟩ :=
rfl

@[simp] lemma subtype_or_equiv_symm_inr (p q : α → Prop) [decidable_pred p] (h : disjoint p q)
  (x : {x // q x}) : (subtype_or_equiv p q h).symm (sum.inr x) = ⟨x, or.inr x.prop⟩ :=
rfl

end subtype


import algebra.category.CommRing.basic
import algebra.ring
import tactic
import category_theory.functor_category -- this transitively imports
import algebra.category.CommRing.basic
import algebra.ring
import category_theory.types
universes v u
/--
## This is the groupe AGL_1(R) : x ↦  ax + b invertible i.e with a inveritible !  The goal is to make
## into a groupe for composition !
-/
structure AGL_1 ( R : Type v) [comm_ring R] :=
(a b  : R)
(y : R)
(certif :  a * y = 1)

namespace AGL_1
section
variables {R : Type v} [comm_ring R]

@[ext]
lemma ext : ∀ {g1 g2 : AGL_1 R}, g1.a = g2.a → g1.b = g2.b → g1 = g2 := λ g1 g2, --- it's ok ? just don't use Bracket ?
begin
  intros h1 h2,
  cases g1,                                         ---  difficult i have to analyse !
  cases g2,
  congr ; try { assumption },
  change g1_a = g2_a at h1,
  rw h1 at g1_certif,
  apply_fun (*) g2_y at g1_certif,
  rwa [← mul_assoc, mul_comm g2_y, g2_certif, one_mul, mul_one] at g1_certif,
end

def one  : AGL_1(R) := {a := 1, b:=0, y := 1, certif := mul_one 1}
instance  : has_one (AGL_1 R) := ⟨one⟩
lemma one_a : (1 : AGL_1(R)).a = 1 := rfl
lemma one_b : (1 : AGL_1(R)).b = 0 := rfl
def of (r : R) : AGL_1(R) := {a := 1, b := r, y := 1, certif := mul_one 1}

lemma one_eq_of_one : one = of (0 : R) := rfl

 def mul_map' : AGL_1(R) → AGL_1 (R) → AGL_1(R) := λ g1 g2,
{ a := g1.a * g2.a,
  b := g1.a * g2.b + g1.b,
  y := g1.y * g2.y ,
  certif := begin
    have H : g1.a * g2.a * (g1.y * g2.y) = (g1.a * g1.y)  * (g2.a * g2.y),
        ring,
    rw H,
    rw [g1.certif,g2.certif],
    exact one_mul 1,
  end}

instance : inhabited (AGL_1 R) := ⟨1⟩

instance : has_mul (AGL_1 R) := ⟨AGL_1.mul_map'⟩

lemma a_comp (g1 g2 : AGL_1 R) : (g1 * g2).a = g1.a * g2.a :=  rfl
lemma b_comp (g1 g2 : AGL_1 R) : (g1 * g2).b = g1.a * g2.b + g1.b := rfl

meta def AGL_ring : tactic unit :=
`[simp only [one_a, one_b, a_comp, b_comp], ring]

run_cmd add_interactive [`AGL_ring]

def mul_inv : AGL_1 R → AGL_1 R := λ g,    --- change here ?
{ a := g.y,
  b:= - g.y * g.b,
  y := g.a ,
  certif := begin  rw  mul_comm, exact g.certif, end  }

instance : has_inv (AGL_1 R) := ⟨AGL_1.mul_inv⟩

lemma a_comp_inv (g : AGL_1 R) : (g⁻¹).a =g.y  :=  rfl
lemma b_comp_inv (g : AGL_1 R) : (g⁻¹).b = - g.y * g.b  := rfl

def Rotation (R : Type v)[comm_ring R]  (a : R) (y : R):   ( a * y = 1 ) → AGL_1(R) :=
λ certif, {a := a, b := 0, y := y, certif := certif}

def mul_one'  (g : AGL_1 R) :  g * 1 = g := begin ext; AGL_ring, end
def one_mul' (g : AGL_1 R)  : 1 * g = g := begin ext ;AGL_ring, end
def mul_assoc' (g1 g2 g3 : AGL_1 R) :  (g1 * g2) * g3 = g1 * (g2 * g3) :=
    begin
        ext; AGL_ring,
    end
instance [has_repr R] : has_repr (AGL_1 (R))  := ⟨λ x, repr (x.a) ++ " X + " ++ repr (x.b)⟩
lemma mul_right_inv' (g : AGL_1 R) : g * g⁻¹ = 1 :=begin
    ext,
    rw [a_comp,a_comp_inv], exact g.certif,
    rw [b_comp,b_comp_inv,← mul_assoc,one_b,mul_comm,mul_neg_eq_neg_mul_symm,g.certif],
    ring,
 end
 lemma mul_left_inv' (g : AGL_1 R) :  g⁻¹ * g = 1 :=begin
    ext,
    rw [a_comp,a_comp_inv, mul_comm],
    exact g.certif,
    rw [b_comp,one_b,a_comp_inv,mul_comm,b_comp_inv],
    ring,
 end
#eval of (3 : ℤ) * of(4 : ℤ)
instance : group (AGL_1 R) :=
  { mul             := mul_map',
    one             := 1,
    one_mul         := one_mul',
    mul_one         := mul_one',
    inv             :=  mul_inv,
    mul_assoc       := mul_assoc',
    mul_left_inv    := mul_left_inv',}
open CommRing
open is_ring_hom
variables (R' : Type v)[comm_ring R'] (f : R →  R')[is_ring_hom f]
def hom_map (R' : Type v) [comm_ring R'](f : R →  R')[is_ring_hom f] : AGL_1 R → AGL_1 R' := λ g,
    {
        a := f g.a,
        b := f g.b,
        y := f g.y,
        certif := begin rw [← map_mul (f),g.certif], exact map_one f,
        end
    }
lemma a_comp_hom (g : AGL_1 R) : (hom_map (R') (f) (g)).a = f g.a := rfl
lemma b_comp_hom (g : AGL_1 R) : (hom_map (R') (f) (g)).b = f g.b := rfl
lemma y_comp_hom (g : AGL_1 R) : (hom_map (R') (f) (g)).y = f g.y := rfl

lemma hom_map_group_comp (R' : Type v) [comm_ring R'](f : R → R')[is_ring_hom f] (g1 g2 : AGL_1 R) :
     hom_map (R')(f) (g1 * g2) = hom_map(R') (f) g1 * hom_map (R')(f) g2  := begin
        ext,
        rw [a_comp,a_comp_hom,a_comp_hom,a_comp_hom,a_comp],
        exact map_mul f,
        rw [b_comp,b_comp_hom,b_comp_hom,b_comp_hom,a_comp_hom,b_comp,← map_mul f,← map_add f],
     end

lemma hom_map_one (R' : Type v)[comm_ring R'](f : R → R')[is_ring_hom f] (g1 g2 : AGL_1 R) : hom_map R' (f) (1) = 1 :=
begin
    ext,
    rw [a_comp_hom,one_a,one_a],
    exact map_one f,
    rw [b_comp_hom,one_b,one_b],
    exact  map_zero f,
#print AGL_1
def AGL__1 : CommRing ⥤ Type v :=
{ obj := λ R, AGL_1 R,
  map :=λ R R' f, hom_map R' f,
}
end
end AGL_1


/-
Copyright (c) 2017 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 data.pfunctor.univariate.M
! leanprover-community/mathlib commit 23aa88e32dcc9d2a24cca7bc23268567ed4cd7d6
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Data.Pfunctor.Univariate.Basic

/-!
# M-types

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

M types are potentially infinite tree-like structures. They are defined
as the greatest fixpoint of a polynomial functor.
-/

universe u v w

open Nat Function

open List hiding head?

variable (F : PFunctor.{u})

-- mathport name: «expr♯ »
local prefix:0 "♯" => cast (by first |simp [*]|cc|solve_by_elim)

namespace PFunctor

namespace Approx

#print PFunctor.Approx.CofixA /-
/-- `cofix_a F n` is an `n` level approximation of a M-type -/
inductive CofixA : ℕ → Type u
  | continue : cofix_a 0
  | intro {n} : ∀ a, (F.B a → cofix_a n) → cofix_a (succ n)
#align pfunctor.approx.cofix_a PFunctor.Approx.CofixA
-/

#print PFunctor.Approx.CofixA.default /-
/-- default inhabitant of `cofix_a` -/
protected def CofixA.default [Inhabited F.A] : ∀ n, CofixA F n
  | 0 => CofixA.continue
  | succ n => CofixA.intro default fun _ => cofix_a.default n
#align pfunctor.approx.cofix_a.default PFunctor.Approx.CofixA.default
-/

instance [Inhabited F.A] {n} : Inhabited (CofixA F n) :=
  ⟨CofixA.default F n⟩

#print PFunctor.Approx.cofixA_eq_zero /-
theorem cofixA_eq_zero : ∀ x y : CofixA F 0, x = y
  | cofix_a.continue, cofix_a.continue => rfl
#align pfunctor.approx.cofix_a_eq_zero PFunctor.Approx.cofixA_eq_zero
-/

variable {F}

#print PFunctor.Approx.head' /-
/-- The label of the root of the tree for a non-trivial
approximation of the cofix of a pfunctor.
-/
def head' : ∀ {n}, CofixA F (succ n) → F.A
  | n, cofix_a.intro i _ => i
#align pfunctor.approx.head' PFunctor.Approx.head'
-/

#print PFunctor.Approx.children' /-
/-- for a non-trivial approximation, return all the subtrees of the root -/
def children' : ∀ {n} (x : CofixA F (succ n)), F.B (head' x) → CofixA F n
  | n, cofix_a.intro a f => f
#align pfunctor.approx.children' PFunctor.Approx.children'
-/

#print PFunctor.Approx.approx_eta /-
theorem approx_eta {n : ℕ} (x : CofixA F (n + 1)) : x = CofixA.intro (head' x) (children' x) := by
  cases x <;> rfl
#align pfunctor.approx.approx_eta PFunctor.Approx.approx_eta
-/

#print PFunctor.Approx.Agree /-
/-- Relation between two approximations of the cofix of a pfunctor
that state they both contain the same data until one of them is truncated -/
inductive Agree : ∀ {n : ℕ}, CofixA F n → CofixA F (n + 1) → Prop
  | continue (x : CofixA F 0) (y : CofixA F 1) : agree x y
  |
  intro {n} {a} (x : F.B a → CofixA F n) (x' : F.B a → CofixA F (n + 1)) :
    (∀ i : F.B a, agree (x i) (x' i)) → agree (CofixA.intro a x) (CofixA.intro a x')
#align pfunctor.approx.agree PFunctor.Approx.Agree
-/

#print PFunctor.Approx.AllAgree /-
/-- Given an infinite series of approximations `approx`,
`all_agree approx` states that they are all consistent with each other.
-/
def AllAgree (x : ∀ n, CofixA F n) :=
  ∀ n, Agree (x n) (x (succ n))
#align pfunctor.approx.all_agree PFunctor.Approx.AllAgree
-/

#print PFunctor.Approx.agree_trival /-
@[simp]
theorem agree_trival {x : CofixA F 0} {y : CofixA F 1} : Agree x y := by constructor
#align pfunctor.approx.agree_trival PFunctor.Approx.agree_trival
-/

#print PFunctor.Approx.agree_children /-
theorem agree_children {n : ℕ} (x : CofixA F (succ n)) (y : CofixA F (succ n + 1)) {i j}
    (h₀ : HEq i j) (h₁ : Agree x y) : Agree (children' x i) (children' y j) :=
  by
  cases' h₁ with _ _ _ _ _ _ hagree; cases h₀
  apply hagree
#align pfunctor.approx.agree_children PFunctor.Approx.agree_children
-/

#print PFunctor.Approx.truncate /-
/-- `truncate a` turns `a` into a more limited approximation -/
def truncate : ∀ {n : ℕ}, CofixA F (n + 1) → CofixA F n
  | 0, cofix_a.intro _ _ => CofixA.continue
  | succ n, cofix_a.intro i f => CofixA.intro i <| truncate ∘ f
#align pfunctor.approx.truncate PFunctor.Approx.truncate
-/

#print PFunctor.Approx.truncate_eq_of_agree /-
theorem truncate_eq_of_agree {n : ℕ} (x : CofixA F n) (y : CofixA F (succ n)) (h : Agree x y) :
    truncate y = x := by
  induction n generalizing x y <;> cases x <;> cases y
  · rfl
  · cases' h with _ _ _ _ _ h₀ h₁
    cases h
    simp only [truncate, Function.comp, true_and_iff, eq_self_iff_true, heq_iff_eq]
    ext y
    apply n_ih
    apply h₁
#align pfunctor.approx.truncate_eq_of_agree PFunctor.Approx.truncate_eq_of_agree
-/

variable {X : Type w}

variable (f : X → F.Obj X)

#print PFunctor.Approx.sCorec /-
/-- `s_corec f i n` creates an approximation of height `n`
of the final coalgebra of `f` -/
def sCorec : ∀ (i : X) (n), CofixA F n
  | _, 0 => CofixA.continue
  | j, succ n => CofixA.intro (f j).1 fun i => s_corec ((f j).2 i) _
#align pfunctor.approx.s_corec PFunctor.Approx.sCorec
-/

#print PFunctor.Approx.P_corec /-
theorem P_corec (i : X) (n : ℕ) : Agree (sCorec f i n) (sCorec f i (succ n)) :=
  by
  induction' n with n generalizing i
  constructor
  cases' h : f i with y g
  constructor
  introv
  apply n_ih
#align pfunctor.approx.P_corec PFunctor.Approx.P_corec
-/

#print PFunctor.Approx.Path /-
/-- `path F` provides indices to access internal nodes in `corec F` -/
def Path (F : PFunctor.{u}) :=
  List F.IdxCat
#align pfunctor.approx.path PFunctor.Approx.Path
-/

#print PFunctor.Approx.Path.inhabited /-
instance Path.inhabited : Inhabited (Path F) :=
  ⟨[]⟩
#align pfunctor.approx.path.inhabited PFunctor.Approx.Path.inhabited
-/

open List Nat

instance : Subsingleton (CofixA F 0) :=
  ⟨by
    intros
    casesm*cofix_a F 0
    rfl⟩

#print PFunctor.Approx.head_succ' /-
theorem head_succ' (n m : ℕ) (x : ∀ n, CofixA F n) (Hconsistent : AllAgree x) :
    head' (x (succ n)) = head' (x (succ m)) :=
  by
  suffices ∀ n, head' (x (succ n)) = head' (x 1) by simp [this]
  clear m n
  intro
  cases' h₀ : x (succ n) with _ i₀ f₀
  cases' h₁ : x 1 with _ i₁ f₁
  dsimp only [head']
  induction' n with n
  · rw [h₁] at h₀
    cases h₀
    trivial
  · have H := Hconsistent (succ n)
    cases' h₂ : x (succ n) with _ i₂ f₂
    rw [h₀, h₂] at H
    apply n_ih (truncate ∘ f₀)
    rw [h₂]
    cases' H with _ _ _ _ _ _ hagree
    congr
    funext j
    dsimp only [comp_app]
    rw [truncate_eq_of_agree]
    apply hagree
#align pfunctor.approx.head_succ' PFunctor.Approx.head_succ'
-/

end Approx

open Approx

#print PFunctor.MIntl /-
/-- Internal definition for `M`. It is needed to avoid name clashes
between `M.mk` and `M.cases_on` and the declarations generated for
the structure -/
structure MIntl where
  approx : ∀ n, CofixA F n
  consistent : AllAgree approx
#align pfunctor.M_intl PFunctor.MIntl
-/

#print PFunctor.M /-
/-- For polynomial functor `F`, `M F` is its final coalgebra -/
def M :=
  MIntl F
#align pfunctor.M PFunctor.M
-/

#print PFunctor.M.default_consistent /-
theorem M.default_consistent [Inhabited F.A] : ∀ n, Agree (default : CofixA F n) default
  | 0 => Agree.continu _ _
  | succ n => Agree.intro _ _ fun _ => M.default_consistent n
#align pfunctor.M.default_consistent PFunctor.M.default_consistent
-/

#print PFunctor.M.inhabited /-
instance M.inhabited [Inhabited F.A] : Inhabited (M F) :=
  ⟨{  approx := default
      consistent := M.default_consistent _ }⟩
#align pfunctor.M.inhabited PFunctor.M.inhabited
-/

#print PFunctor.MIntl.inhabited /-
instance MIntl.inhabited [Inhabited F.A] : Inhabited (MIntl F) :=
  show Inhabited (M F) by infer_instance
#align pfunctor.M_intl.inhabited PFunctor.MIntl.inhabited
-/

namespace M

#print PFunctor.M.ext' /-
theorem ext' (x y : M F) (H : ∀ i : ℕ, x.approx i = y.approx i) : x = y :=
  by
  cases x
  cases y
  congr with n
  apply H
#align pfunctor.M.ext' PFunctor.M.ext'
-/

variable {X : Type _}

variable (f : X → F.Obj X)

variable {F}

#print PFunctor.M.corec /-
/-- Corecursor for the M-type defined by `F`. -/
protected def corec (i : X) : M F where
  approx := sCorec f i
  consistent := P_corec _ _
#align pfunctor.M.corec PFunctor.M.corec
-/

variable {F}

#print PFunctor.M.head /-
/-- given a tree generated by `F`, `head` gives us the first piece of data
it contains -/
def head (x : M F) :=
  head' (x.1 1)
#align pfunctor.M.head PFunctor.M.head
-/

#print PFunctor.M.children /-
/-- return all the subtrees of the root of a tree `x : M F` -/
def children (x : M F) (i : F.B (head x)) : M F :=
  let H := fun n : ℕ => @head_succ' _ n 0 x.1 x.2
  { approx := fun n => children' (x.1 _) (cast (congr_arg _ <| by simp only [head, H] <;> rfl) i)
    consistent := by
      intro
      have P' := x.2 (succ n)
      apply agree_children _ _ _ P'
      trans i
      apply cast_hEq
      symm
      apply cast_hEq }
#align pfunctor.M.children PFunctor.M.children
-/

#print PFunctor.M.ichildren /-
/-- select a subtree using a `i : F.Idx` or return an arbitrary tree if
`i` designates no subtree of `x` -/
def ichildren [Inhabited (M F)] [DecidableEq F.A] (i : F.IdxCat) (x : M F) : M F :=
  if H' : i.1 = head x then children x (cast (congr_arg _ <| by simp only [head, H'] <;> rfl) i.2)
  else default
#align pfunctor.M.ichildren PFunctor.M.ichildren
-/

#print PFunctor.M.head_succ /-
theorem head_succ (n m : ℕ) (x : M F) : head' (x.approx (succ n)) = head' (x.approx (succ m)) :=
  head_succ' n m _ x.consistent
#align pfunctor.M.head_succ PFunctor.M.head_succ
-/

#print PFunctor.M.head_eq_head' /-
theorem head_eq_head' : ∀ (x : M F) (n : ℕ), head x = head' (x.approx <| n + 1)
  | ⟨x, h⟩, n => head_succ' _ _ _ h
#align pfunctor.M.head_eq_head' PFunctor.M.head_eq_head'
-/

#print PFunctor.M.head'_eq_head /-
theorem head'_eq_head : ∀ (x : M F) (n : ℕ), head' (x.approx <| n + 1) = head x
  | ⟨x, h⟩, n => head_succ' _ _ _ h
#align pfunctor.M.head'_eq_head PFunctor.M.head'_eq_head
-/

#print PFunctor.M.truncate_approx /-
theorem truncate_approx (x : M F) (n : ℕ) : truncate (x.approx <| n + 1) = x.approx n :=
  truncate_eq_of_agree _ _ (x.consistent _)
#align pfunctor.M.truncate_approx PFunctor.M.truncate_approx
-/

#print PFunctor.M.dest /-
/-- unfold an M-type -/
def dest : M F → F.Obj (M F)
  | x => ⟨head x, fun i => children x i⟩
#align pfunctor.M.dest PFunctor.M.dest
-/

namespace Approx

#print PFunctor.M.Approx.sMk /-
/-- generates the approximations needed for `M.mk` -/
protected def sMk (x : F.Obj <| M F) : ∀ n, CofixA F n
  | 0 => CofixA.continue
  | succ n => CofixA.intro x.1 fun i => (x.2 i).approx n
#align pfunctor.M.approx.s_mk PFunctor.M.Approx.sMk
-/

#print PFunctor.M.Approx.P_mk /-
protected theorem P_mk (x : F.Obj <| M F) : AllAgree (Approx.sMk x)
  | 0 => by constructor
  | succ n => by
    constructor
    introv
    apply (x.2 i).consistent
#align pfunctor.M.approx.P_mk PFunctor.M.Approx.P_mk
-/

end Approx

#print PFunctor.M.mk /-
/-- constructor for M-types -/
protected def mk (x : F.Obj <| M F) : M F
    where
  approx := Approx.sMk x
  consistent := Approx.P_mk x
#align pfunctor.M.mk PFunctor.M.mk
-/

#print PFunctor.M.Agree' /-
/-- `agree' n` relates two trees of type `M F` that
are the same up to dept `n` -/
inductive Agree' : ℕ → M F → M F → Prop
  | trivial (x y : M F) : agree' 0 x y
  |
  step {n : ℕ} {a} (x y : F.B a → M F) {x' y'} :
    x' = M.mk ⟨a, x⟩ → y' = M.mk ⟨a, y⟩ → (∀ i, agree' n (x i) (y i)) → agree' (succ n) x' y'
#align pfunctor.M.agree' PFunctor.M.Agree'
-/

#print PFunctor.M.dest_mk /-
@[simp]
theorem dest_mk (x : F.Obj <| M F) : dest (M.mk x) = x :=
  by
  funext i
  dsimp only [M.mk, dest]
  cases' x with x ch; congr with i
  cases h : ch i
  simp only [children, M.approx.s_mk, children', cast_eq]
  dsimp only [M.approx.s_mk, children']
  congr ; rw [h]
#align pfunctor.M.dest_mk PFunctor.M.dest_mk
-/

#print PFunctor.M.mk_dest /-
@[simp]
theorem mk_dest (x : M F) : M.mk (dest x) = x :=
  by
  apply ext'
  intro n
  dsimp only [M.mk]
  induction' n with n
  · apply Subsingleton.elim
  dsimp only [approx.s_mk, dest, head]
  cases' h : x.approx (succ n) with _ hd ch
  have h' : hd = head' (x.approx 1) :=
    by
    rw [← head_succ' n, h, head']
    apply x.consistent
  revert ch
  rw [h']
  intros
  congr
  · ext a
    dsimp only [children]
    generalize hh : cast _ a = a''
    rw [cast_eq_iff_heq] at hh
    revert a''
    rw [h]
    intros
    cases hh
    rfl
#align pfunctor.M.mk_dest PFunctor.M.mk_dest
-/

#print PFunctor.M.mk_inj /-
theorem mk_inj {x y : F.Obj <| M F} (h : M.mk x = M.mk y) : x = y := by rw [← dest_mk x, h, dest_mk]
#align pfunctor.M.mk_inj PFunctor.M.mk_inj
-/

#print PFunctor.M.cases /-
/-- destructor for M-types -/
protected def cases {r : M F → Sort w} (f : ∀ x : F.Obj <| M F, r (M.mk x)) (x : M F) : r x :=
  suffices r (M.mk (dest x)) by
    haveI := Classical.propDecidable
    haveI := Inhabited.mk x
    rw [← mk_dest x]
    exact this
  f _
#align pfunctor.M.cases PFunctor.M.cases
-/

#print PFunctor.M.casesOn /-
/-- destructor for M-types -/
protected def casesOn {r : M F → Sort w} (x : M F) (f : ∀ x : F.Obj <| M F, r (M.mk x)) : r x :=
  M.cases f x
#align pfunctor.M.cases_on PFunctor.M.casesOn
-/

#print PFunctor.M.casesOn' /-
/-- destructor for M-types, similar to `cases_on` but also
gives access directly to the root and subtrees on an M-type -/
protected def casesOn' {r : M F → Sort w} (x : M F) (f : ∀ a f, r (M.mk ⟨a, f⟩)) : r x :=
  M.casesOn x fun ⟨a, g⟩ => f a _
#align pfunctor.M.cases_on' PFunctor.M.casesOn'
-/

#print PFunctor.M.approx_mk /-
theorem approx_mk (a : F.A) (f : F.B a → M F) (i : ℕ) :
    (M.mk ⟨a, f⟩).approx (succ i) = CofixA.intro a fun j => (f j).approx i :=
  rfl
#align pfunctor.M.approx_mk PFunctor.M.approx_mk
-/

#print PFunctor.M.agree'_refl /-
@[simp]
theorem agree'_refl {n : ℕ} (x : M F) : Agree' n x x :=
  by
  induction n generalizing x <;> induction x using PFunctor.M.casesOn' <;> constructor <;> try rfl
  intros
  apply n_ih
#align pfunctor.M.agree'_refl PFunctor.M.agree'_refl
-/

#print PFunctor.M.agree_iff_agree' /-
theorem agree_iff_agree' {n : ℕ} (x y : M F) :
    Agree (x.approx n) (y.approx <| n + 1) ↔ Agree' n x y :=
  by
  constructor <;> intro h
  · induction n generalizing x y
    constructor
    · induction x using PFunctor.M.casesOn'
      induction y using PFunctor.M.casesOn'
      simp only [approx_mk] at h
      cases' h with _ _ _ _ _ _ hagree
      constructor <;> try rfl
      intro i
      apply n_ih
      apply hagree
  · induction n generalizing x y
    constructor
    · cases h
      induction x using PFunctor.M.casesOn'
      induction y using PFunctor.M.casesOn'
      simp only [approx_mk]
      have h_a_1 := mk_inj ‹M.mk ⟨x_a, x_f⟩ = M.mk ⟨h_a, h_x⟩›
      cases h_a_1
      replace h_a_2 := mk_inj ‹M.mk ⟨y_a, y_f⟩ = M.mk ⟨h_a, h_y⟩›
      cases h_a_2
      constructor
      intro i
      apply n_ih
      simp [*]
#align pfunctor.M.agree_iff_agree' PFunctor.M.agree_iff_agree'
-/

/- warning: pfunctor.M.cases_mk -> PFunctor.M.cases_mk is a dubious translation:
lean 3 declaration is
  forall {F : PFunctor.{u1}} {r : (PFunctor.M.{u1} F) -> Sort.{u2}} (x : PFunctor.Obj.{u1, u1} F (PFunctor.M.{u1} F)) (f : forall (x : PFunctor.Obj.{u1, u1} F (PFunctor.M.{u1} F)), r (PFunctor.M.mk.{u1} F x)), Eq.{u2} (r (PFunctor.M.mk.{u1} F x)) (PFunctor.M.cases.{u1, u2} F r f (PFunctor.M.mk.{u1} F x)) (f x)
but is expected to have type
  forall {F : PFunctor.{u2}} {r : (PFunctor.M.{u2} F) -> Sort.{u1}} (x : PFunctor.Obj.{u2, u2} F (PFunctor.M.{u2} F)) (f : forall (x : PFunctor.Obj.{u2, u2} F (PFunctor.M.{u2} F)), r (PFunctor.M.mk.{u2} F x)), Eq.{u1} (r (PFunctor.M.mk.{u2} F x)) (PFunctor.M.cases.{u2, u1} F r f (PFunctor.M.mk.{u2} F x)) (f x)
Case conversion may be inaccurate. Consider using '#align pfunctor.M.cases_mk PFunctor.M.cases_mkₓ'. -/
@[simp]
theorem cases_mk {r : M F → Sort _} (x : F.Obj <| M F) (f : ∀ x : F.Obj <| M F, r (M.mk x)) :
    PFunctor.M.cases f (M.mk x) = f x :=
  by
  dsimp only [M.mk, PFunctor.M.cases, dest, head, approx.s_mk, head']
  cases x; dsimp only [approx.s_mk]
  apply eq_of_hEq
  apply rec_heq_of_heq; congr with x
  dsimp only [children, approx.s_mk, children']
  cases h : x_snd x; dsimp only [head]
  congr with n; change (x_snd x).approx n = _; rw [h]
#align pfunctor.M.cases_mk PFunctor.M.cases_mk

/- warning: pfunctor.M.cases_on_mk -> PFunctor.M.casesOn_mk is a dubious translation:
lean 3 declaration is
  forall {F : PFunctor.{u1}} {r : (PFunctor.M.{u1} F) -> Sort.{u2}} (x : PFunctor.Obj.{u1, u1} F (PFunctor.M.{u1} F)) (f : forall (x : PFunctor.Obj.{u1, u1} F (PFunctor.M.{u1} F)), r (PFunctor.M.mk.{u1} F x)), Eq.{u2} (r (PFunctor.M.mk.{u1} F x)) (PFunctor.M.casesOn.{u1, u2} F r (PFunctor.M.mk.{u1} F x) f) (f x)
but is expected to have type
  forall {F : PFunctor.{u2}} {r : (PFunctor.M.{u2} F) -> Sort.{u1}} (x : PFunctor.Obj.{u2, u2} F (PFunctor.M.{u2} F)) (f : forall (x : PFunctor.Obj.{u2, u2} F (PFunctor.M.{u2} F)), r (PFunctor.M.mk.{u2} F x)), Eq.{u1} (r (PFunctor.M.mk.{u2} F x)) (PFunctor.M.casesOn.{u2, u1} F r (PFunctor.M.mk.{u2} F x) f) (f x)
Case conversion may be inaccurate. Consider using '#align pfunctor.M.cases_on_mk PFunctor.M.casesOn_mkₓ'. -/
@[simp]
theorem casesOn_mk {r : M F → Sort _} (x : F.Obj <| M F) (f : ∀ x : F.Obj <| M F, r (M.mk x)) :
    PFunctor.M.casesOn (M.mk x) f = f x :=
  cases_mk x f
#align pfunctor.M.cases_on_mk PFunctor.M.casesOn_mk

/- warning: pfunctor.M.cases_on_mk' -> PFunctor.M.casesOn_mk' is a dubious translation:
lean 3 declaration is
  forall {F : PFunctor.{u1}} {r : (PFunctor.M.{u1} F) -> Sort.{u2}} {a : PFunctor.A.{u1} F} (x : (PFunctor.B.{u1} F a) -> (PFunctor.M.{u1} F)) (f : forall (a : PFunctor.A.{u1} F) (f : (PFunctor.B.{u1} F a) -> (PFunctor.M.{u1} F)), r (PFunctor.M.mk.{u1} F (Sigma.mk.{u1, u1} (PFunctor.A.{u1} F) (fun (x : PFunctor.A.{u1} F) => (PFunctor.B.{u1} F x) -> (PFunctor.M.{u1} F)) a f))), Eq.{u2} (r (PFunctor.M.mk.{u1} F (Sigma.mk.{u1, u1} (PFunctor.A.{u1} F) (fun (x : PFunctor.A.{u1} F) => (PFunctor.B.{u1} F x) -> (PFunctor.M.{u1} F)) a x))) (PFunctor.M.casesOn'.{u1, u2} F r (PFunctor.M.mk.{u1} F (Sigma.mk.{u1, u1} (PFunctor.A.{u1} F) (fun (x : PFunctor.A.{u1} F) => (PFunctor.B.{u1} F x) -> (PFunctor.M.{u1} F)) a x)) f) (f a x)
but is expected to have type
  forall {F : PFunctor.{u2}} {r : (PFunctor.M.{u2} F) -> Sort.{u1}} {a : PFunctor.A.{u2} F} (x : (PFunctor.B.{u2} F a) -> (PFunctor.M.{u2} F)) (f : forall (a : PFunctor.A.{u2} F) (f : (PFunctor.B.{u2} F a) -> (PFunctor.M.{u2} F)), r (PFunctor.M.mk.{u2} F (Sigma.mk.{u2, u2} (PFunctor.A.{u2} F) (fun (x : PFunctor.A.{u2} F) => (PFunctor.B.{u2} F x) -> (PFunctor.M.{u2} F)) a f))), Eq.{u1} (r (PFunctor.M.mk.{u2} F (Sigma.mk.{u2, u2} (PFunctor.A.{u2} F) (fun (x : PFunctor.A.{u2} F) => (PFunctor.B.{u2} F x) -> (PFunctor.M.{u2} F)) a x))) (PFunctor.M.casesOn'.{u2, u1} F r (PFunctor.M.mk.{u2} F (Sigma.mk.{u2, u2} (PFunctor.A.{u2} F) (fun (x : PFunctor.A.{u2} F) => (PFunctor.B.{u2} F x) -> (PFunctor.M.{u2} F)) a x)) f) (f a x)
Case conversion may be inaccurate. Consider using '#align pfunctor.M.cases_on_mk' PFunctor.M.casesOn_mk'ₓ'. -/
@[simp]
theorem casesOn_mk' {r : M F → Sort _} {a} (x : F.B a → M F)
    (f : ∀ (a) (f : F.B a → M F), r (M.mk ⟨a, f⟩)) : PFunctor.M.casesOn' (M.mk ⟨a, x⟩) f = f a x :=
  cases_mk ⟨_, x⟩ _
#align pfunctor.M.cases_on_mk' PFunctor.M.casesOn_mk'

#print PFunctor.M.IsPath /-
/-- `is_path p x` tells us if `p` is a valid path through `x` -/
inductive IsPath : Path F → M F → Prop
  | nil (x : M F) : is_path [] x
  |
  cons (xs : Path F) {a} (x : M F) (f : F.B a → M F) (i : F.B a) :
    x = M.mk ⟨a, f⟩ → is_path xs (f i) → is_path (⟨a, i⟩ :: xs) x
#align pfunctor.M.is_path PFunctor.M.IsPath
-/

#print PFunctor.M.isPath_cons /-
theorem isPath_cons {xs : Path F} {a a'} {f : F.B a → M F} {i : F.B a'} :
    IsPath (⟨a', i⟩ :: xs) (M.mk ⟨a, f⟩) → a = a' :=
  by
  generalize h : M.mk ⟨a, f⟩ = x
  rintro (_ | ⟨_, _, _, _, rfl, _⟩)
  cases mk_inj h
  rfl
#align pfunctor.M.is_path_cons PFunctor.M.isPath_cons
-/

#print PFunctor.M.isPath_cons' /-
theorem isPath_cons' {xs : Path F} {a} {f : F.B a → M F} {i : F.B a} :
    IsPath (⟨a, i⟩ :: xs) (M.mk ⟨a, f⟩) → IsPath xs (f i) :=
  by
  generalize h : M.mk ⟨a, f⟩ = x
  rintro (_ | ⟨_, _, _, _, rfl, hp⟩)
  cases mk_inj h
  exact hp
#align pfunctor.M.is_path_cons' PFunctor.M.isPath_cons'
-/

#print PFunctor.M.isubtree /-
/-- follow a path through a value of `M F` and return the subtree
found at the end of the path if it is a valid path for that value and
return a default tree -/
def isubtree [DecidableEq F.A] [Inhabited (M F)] : Path F → M F → M F
  | [], x => x
  | ⟨a, i⟩ :: ps, x =>
    PFunctor.M.casesOn' x fun a' f =>
      (if h : a = a' then isubtree ps (f <| cast (by rw [h]) i) else default :
        (fun x => M F) (M.mk ⟨a', f⟩))
#align pfunctor.M.isubtree PFunctor.M.isubtree
-/

#print PFunctor.M.iselect /-
/-- similar to `isubtree` but returns the data at the end of the path instead
of the whole subtree -/
def iselect [DecidableEq F.A] [Inhabited (M F)] (ps : Path F) : M F → F.A := fun x : M F =>
  head <| isubtree ps x
#align pfunctor.M.iselect PFunctor.M.iselect
-/

#print PFunctor.M.iselect_eq_default /-
theorem iselect_eq_default [DecidableEq F.A] [Inhabited (M F)] (ps : Path F) (x : M F)
    (h : ¬IsPath ps x) : iselect ps x = head default :=
  by
  induction ps generalizing x
  · exfalso
    apply h
    constructor
  · cases' ps_hd with a i
    induction x using PFunctor.M.casesOn'
    simp only [iselect, isubtree] at ps_ih⊢
    by_cases h'' : a = x_a
    subst x_a
    · simp only [dif_pos, eq_self_iff_true, cases_on_mk']
      rw [ps_ih]
      intro h'
      apply h
      constructor <;> try rfl
      apply h'
    · simp [*]
#align pfunctor.M.iselect_eq_default PFunctor.M.iselect_eq_default
-/

#print PFunctor.M.head_mk /-
@[simp]
theorem head_mk (x : F.Obj (M F)) : head (M.mk x) = x.1 :=
  Eq.symm <|
    calc
      x.1 = (dest (M.mk x)).1 := by rw [dest_mk]
      _ = head (M.mk x) := by rfl

#align pfunctor.M.head_mk PFunctor.M.head_mk
-/

#print PFunctor.M.children_mk /-
theorem children_mk {a} (x : F.B a → M F) (i : F.B (head (M.mk ⟨a, x⟩))) :
    children (M.mk ⟨a, x⟩) i = x (cast (by rw [head_mk]) i) := by apply ext' <;> intro n <;> rfl
#align pfunctor.M.children_mk PFunctor.M.children_mk
-/

#print PFunctor.M.ichildren_mk /-
@[simp]
theorem ichildren_mk [DecidableEq F.A] [Inhabited (M F)] (x : F.Obj (M F)) (i : F.IdxCat) :
    ichildren i (M.mk x) = x.iget i :=
  by
  dsimp only [ichildren, PFunctor.Obj.iget]
  congr with h
  apply ext'
  dsimp only [children', M.mk, approx.s_mk]
  intros
  rfl
#align pfunctor.M.ichildren_mk PFunctor.M.ichildren_mk
-/

#print PFunctor.M.isubtree_cons /-
@[simp]
theorem isubtree_cons [DecidableEq F.A] [Inhabited (M F)] (ps : Path F) {a} (f : F.B a → M F)
    {i : F.B a} : isubtree (⟨_, i⟩ :: ps) (M.mk ⟨a, f⟩) = isubtree ps (f i) := by
  simp only [isubtree, ichildren_mk, PFunctor.Obj.iget, dif_pos, isubtree, M.cases_on_mk'] <;> rfl
#align pfunctor.M.isubtree_cons PFunctor.M.isubtree_cons
-/

#print PFunctor.M.iselect_nil /-
@[simp]
theorem iselect_nil [DecidableEq F.A] [Inhabited (M F)] {a} (f : F.B a → M F) :
    iselect nil (M.mk ⟨a, f⟩) = a := by rfl
#align pfunctor.M.iselect_nil PFunctor.M.iselect_nil
-/

#print PFunctor.M.iselect_cons /-
@[simp]
theorem iselect_cons [DecidableEq F.A] [Inhabited (M F)] (ps : Path F) {a} (f : F.B a → M F) {i} :
    iselect (⟨a, i⟩ :: ps) (M.mk ⟨a, f⟩) = iselect ps (f i) := by simp only [iselect, isubtree_cons]
#align pfunctor.M.iselect_cons PFunctor.M.iselect_cons
-/

#print PFunctor.M.corec_def /-
theorem corec_def {X} (f : X → F.Obj X) (x₀ : X) : M.corec f x₀ = M.mk (M.corec f <$> f x₀) :=
  by
  dsimp only [M.corec, M.mk]
  congr with n
  cases' n with n
  · dsimp only [s_corec, approx.s_mk]
    rfl
  · dsimp only [s_corec, approx.s_mk]
    cases h : f x₀
    dsimp only [(· <$> ·), PFunctor.map]
    congr
#align pfunctor.M.corec_def PFunctor.M.corec_def
-/

#print PFunctor.M.ext_aux /-
theorem ext_aux [Inhabited (M F)] [DecidableEq F.A] {n : ℕ} (x y z : M F) (hx : Agree' n z x)
    (hy : Agree' n z y) (hrec : ∀ ps : Path F, n = ps.length → iselect ps x = iselect ps y) :
    x.approx (n + 1) = y.approx (n + 1) :=
  by
  induction' n with n generalizing x y z
  · specialize hrec [] rfl
    induction x using PFunctor.M.casesOn'
    induction y using PFunctor.M.casesOn'
    simp only [iselect_nil] at hrec
    subst hrec
    simp only [approx_mk, true_and_iff, eq_self_iff_true, heq_iff_eq]
    apply Subsingleton.elim
  · cases hx
    cases hy
    induction x using PFunctor.M.casesOn'
    induction y using PFunctor.M.casesOn'
    subst z
    iterate 3 have := mk_inj ‹_›; repeat' cases this
    simp only [approx_mk, true_and_iff, eq_self_iff_true, heq_iff_eq]
    ext i
    apply n_ih
    · solve_by_elim
    · solve_by_elim
    introv h
    specialize hrec (⟨_, i⟩ :: ps) (congr_arg _ h)
    simp only [iselect_cons] at hrec
    exact hrec
#align pfunctor.M.ext_aux PFunctor.M.ext_aux
-/

open PFunctor.Approx

variable {F}

attribute [local instance] Classical.propDecidable

#print PFunctor.M.ext /-
theorem ext [Inhabited (M F)] (x y : M F) (H : ∀ ps : Path F, iselect ps x = iselect ps y) :
    x = y := by
  apply ext'; intro i
  induction' i with i
  · cases x.approx 0
    cases y.approx 0
    constructor
  · apply ext_aux x y x
    · rw [← agree_iff_agree']
      apply x.consistent
    · rw [← agree_iff_agree', i_ih]
      apply y.consistent
    introv H'
    dsimp only [iselect] at H
    cases H'
    apply H ps
#align pfunctor.M.ext PFunctor.M.ext
-/

section Bisim

variable (R : M F → M F → Prop)

-- mathport name: «expr ~ »
local infixl:50 " ~ " => R

#print PFunctor.M.IsBisimulation /-
/-- Bisimulation is the standard proof technique for equality between
infinite tree-like structures -/
structure IsBisimulation : Prop where
  headI : ∀ {a a'} {f f'}, M.mk ⟨a, f⟩ ~ M.mk ⟨a', f'⟩ → a = a'
  tail : ∀ {a} {f f' : F.B a → M F}, M.mk ⟨a, f⟩ ~ M.mk ⟨a, f'⟩ → ∀ i : F.B a, f i ~ f' i
#align pfunctor.M.is_bisimulation PFunctor.M.IsBisimulation
-/

#print PFunctor.M.nth_of_bisim /-
theorem nth_of_bisim [Inhabited (M F)] (bisim : IsBisimulation R) (s₁ s₂) (ps : Path F) :
    s₁ ~ s₂ →
      IsPath ps s₁ ∨ IsPath ps s₂ →
        iselect ps s₁ = iselect ps s₂ ∧
          ∃ (a : _)(f f' : F.B a → M F),
            isubtree ps s₁ = M.mk ⟨a, f⟩ ∧
              isubtree ps s₂ = M.mk ⟨a, f'⟩ ∧ ∀ i : F.B a, f i ~ f' i :=
  by
  intro h₀ hh
  induction' s₁ using PFunctor.M.casesOn' with a f
  induction' s₂ using PFunctor.M.casesOn' with a' f'
  obtain rfl : a = a' := bisim.head h₀
  induction' ps with i ps generalizing a f f'
  · exists rfl, a, f, f', rfl, rfl
    apply bisim.tail h₀
  cases' i with a' i
  obtain rfl : a = a' := by cases hh <;> cases is_path_cons hh <;> rfl
  dsimp only [iselect] at ps_ih⊢
  have h₁ := bisim.tail h₀ i
  induction' h : f i using PFunctor.M.casesOn' with a₀ f₀
  induction' h' : f' i using PFunctor.M.casesOn' with a₁ f₁
  simp only [h, h', isubtree_cons] at ps_ih⊢
  rw [h, h'] at h₁
  obtain rfl : a₀ = a₁ := bisim.head h₁
  apply ps_ih _ _ _ h₁
  rw [← h, ← h']
  apply or_of_or_of_imp_of_imp hh is_path_cons' is_path_cons'
#align pfunctor.M.nth_of_bisim PFunctor.M.nth_of_bisim
-/

#print PFunctor.M.eq_of_bisim /-
theorem eq_of_bisim [Nonempty (M F)] (bisim : IsBisimulation R) : ∀ s₁ s₂, s₁ ~ s₂ → s₁ = s₂ :=
  by
  inhabit M F
  introv Hr; apply ext
  introv
  by_cases h : is_path ps s₁ ∨ is_path ps s₂
  · have H := nth_of_bisim R bisim _ _ ps Hr h
    exact H.left
  · rw [not_or] at h
    cases' h with h₀ h₁
    simp only [iselect_eq_default, *, not_false_iff]
#align pfunctor.M.eq_of_bisim PFunctor.M.eq_of_bisim
-/

end Bisim

universe u' v'

#print PFunctor.M.corecOn /-
/-- corecursor for `M F` with swapped arguments -/
def corecOn {X : Type _} (x₀ : X) (f : X → F.Obj X) : M F :=
  M.corec f x₀
#align pfunctor.M.corec_on PFunctor.M.corecOn
-/

variable {P : PFunctor.{u}} {α : Type u}

#print PFunctor.M.dest_corec /-
theorem dest_corec (g : α → P.Obj α) (x : α) : M.dest (M.corec g x) = M.corec g <$> g x := by
  rw [corec_def, dest_mk]
#align pfunctor.M.dest_corec PFunctor.M.dest_corec
-/

#print PFunctor.M.bisim /-
theorem bisim (R : M P → M P → Prop)
    (h : ∀ x y, R x y → ∃ a f f', M.dest x = ⟨a, f⟩ ∧ M.dest y = ⟨a, f'⟩ ∧ ∀ i, R (f i) (f' i)) :
    ∀ x y, R x y → x = y := by
  introv h'
  haveI := Inhabited.mk x.head
  apply eq_of_bisim R _ _ _ h'; clear h' x y
  constructor <;> introv ih <;> rcases h _ _ ih with ⟨a'', g, g', h₀, h₁, h₂⟩ <;> clear h
  · replace h₀ := congr_arg Sigma.fst h₀
    replace h₁ := congr_arg Sigma.fst h₁
    simp only [dest_mk] at h₀ h₁
    rw [h₀, h₁]
  · simp only [dest_mk] at h₀ h₁
    cases h₀
    cases h₁
    apply h₂
#align pfunctor.M.bisim PFunctor.M.bisim
-/

/- warning: pfunctor.M.bisim' -> PFunctor.M.bisim' is a dubious translation:
lean 3 declaration is
  forall {P : PFunctor.{u1}} {α : Type.{u2}} (Q : α -> Prop) (u : α -> (PFunctor.M.{u1} P)) (v : α -> (PFunctor.M.{u1} P)), (forall (x : α), (Q x) -> (Exists.{succ u1} (PFunctor.A.{u1} P) (fun (a : PFunctor.A.{u1} P) => Exists.{succ u1} ((PFunctor.B.{u1} P a) -> (PFunctor.M.{u1} P)) (fun (f : (PFunctor.B.{u1} P a) -> (PFunctor.M.{u1} P)) => Exists.{succ u1} ((PFunctor.B.{u1} P a) -> (PFunctor.M.{u1} P)) (fun (f' : (PFunctor.B.{u1} P a) -> (PFunctor.M.{u1} P)) => And (Eq.{succ u1} (PFunctor.Obj.{u1, u1} P (PFunctor.M.{u1} P)) (PFunctor.M.dest.{u1} P (u x)) (Sigma.mk.{u1, u1} (PFunctor.A.{u1} P) (fun (x : PFunctor.A.{u1} P) => (PFunctor.B.{u1} P x) -> (PFunctor.M.{u1} P)) a f)) (And (Eq.{succ u1} (PFunctor.Obj.{u1, u1} P (PFunctor.M.{u1} P)) (PFunctor.M.dest.{u1} P (v x)) (Sigma.mk.{u1, u1} (PFunctor.A.{u1} P) (fun (x : PFunctor.A.{u1} P) => (PFunctor.B.{u1} P x) -> (PFunctor.M.{u1} P)) a f')) (forall (i : PFunctor.B.{u1} P a), Exists.{succ u2} α (fun (x' : α) => And (Q x') (And (Eq.{succ u1} (PFunctor.M.{u1} P) (f i) (u x')) (Eq.{succ u1} (PFunctor.M.{u1} P) (f' i) (v x'))))))))))) -> (forall (x : α), (Q x) -> (Eq.{succ u1} (PFunctor.M.{u1} P) (u x) (v x)))
but is expected to have type
  forall {P : PFunctor.{u2}} {α : Type.{u1}} (Q : α -> Prop) (u : α -> (PFunctor.M.{u2} P)) (v : α -> (PFunctor.M.{u2} P)), (forall (x : α), (Q x) -> (Exists.{succ u2} (PFunctor.A.{u2} P) (fun (a : PFunctor.A.{u2} P) => Exists.{succ u2} ((PFunctor.B.{u2} P a) -> (PFunctor.M.{u2} P)) (fun (f : (PFunctor.B.{u2} P a) -> (PFunctor.M.{u2} P)) => Exists.{succ u2} ((PFunctor.B.{u2} P a) -> (PFunctor.M.{u2} P)) (fun (f' : (PFunctor.B.{u2} P a) -> (PFunctor.M.{u2} P)) => And (Eq.{succ u2} (PFunctor.Obj.{u2, u2} P (PFunctor.M.{u2} P)) (PFunctor.M.dest.{u2} P (u x)) (Sigma.mk.{u2, u2} (PFunctor.A.{u2} P) (fun (x : PFunctor.A.{u2} P) => (PFunctor.B.{u2} P x) -> (PFunctor.M.{u2} P)) a f)) (And (Eq.{succ u2} (PFunctor.Obj.{u2, u2} P (PFunctor.M.{u2} P)) (PFunctor.M.dest.{u2} P (v x)) (Sigma.mk.{u2, u2} (PFunctor.A.{u2} P) (fun (x : PFunctor.A.{u2} P) => (PFunctor.B.{u2} P x) -> (PFunctor.M.{u2} P)) a f')) (forall (i : PFunctor.B.{u2} P a), Exists.{succ u1} α (fun (x' : α) => And (Q x') (And (Eq.{succ u2} (PFunctor.M.{u2} P) (f i) (u x')) (Eq.{succ u2} (PFunctor.M.{u2} P) (f' i) (v x'))))))))))) -> (forall (x : α), (Q x) -> (Eq.{succ u2} (PFunctor.M.{u2} P) (u x) (v x)))
Case conversion may be inaccurate. Consider using '#align pfunctor.M.bisim' PFunctor.M.bisim'ₓ'. -/
theorem bisim' {α : Type _} (Q : α → Prop) (u v : α → M P)
    (h :
      ∀ x,
        Q x →
          ∃ a f f',
            M.dest (u x) = ⟨a, f⟩ ∧
              M.dest (v x) = ⟨a, f'⟩ ∧ ∀ i, ∃ x', Q x' ∧ f i = u x' ∧ f' i = v x') :
    ∀ x, Q x → u x = v x := fun x Qx =>
  let R := fun w z : M P => ∃ x', Q x' ∧ w = u x' ∧ z = v x'
  @M.bisim P R
    (fun x y ⟨x', Qx', xeq, yeq⟩ =>
      let ⟨a, f, f', ux'eq, vx'eq, h'⟩ := h x' Qx'
      ⟨a, f, f', xeq.symm ▸ ux'eq, yeq.symm ▸ vx'eq, h'⟩)
    _ _ ⟨x, Qx, rfl, rfl⟩
#align pfunctor.M.bisim' PFunctor.M.bisim'

#print PFunctor.M.bisim_equiv /-
-- for the record, show M_bisim follows from _bisim'
theorem bisim_equiv (R : M P → M P → Prop)
    (h : ∀ x y, R x y → ∃ a f f', M.dest x = ⟨a, f⟩ ∧ M.dest y = ⟨a, f'⟩ ∧ ∀ i, R (f i) (f' i)) :
    ∀ x y, R x y → x = y := fun x y Rxy =>
  let Q : M P × M P → Prop := fun p => R p.fst p.snd
  bisim' Q Prod.fst Prod.snd
    (fun p Qp =>
      let ⟨a, f, f', hx, hy, h'⟩ := h p.fst p.snd Qp
      ⟨a, f, f', hx, hy, fun i => ⟨⟨f i, f' i⟩, h' i, rfl, rfl⟩⟩)
    ⟨x, y⟩ Rxy
#align pfunctor.M.bisim_equiv PFunctor.M.bisim_equiv
-/

#print PFunctor.M.corec_unique /-
theorem corec_unique (g : α → P.Obj α) (f : α → M P) (hyp : ∀ x, M.dest (f x) = f <$> g x) :
    f = M.corec g := by
  ext x
  apply bisim' (fun x => True) _ _ _ _ trivial
  clear x
  intro x _
  cases' gxeq : g x with a f'
  have h₀ : M.dest (f x) = ⟨a, f ∘ f'⟩ := by rw [hyp, gxeq, PFunctor.map_eq]
  have h₁ : M.dest (M.corec g x) = ⟨a, M.corec g ∘ f'⟩ := by rw [dest_corec, gxeq, PFunctor.map_eq]
  refine' ⟨_, _, _, h₀, h₁, _⟩
  intro i
  exact ⟨f' i, trivial, rfl, rfl⟩
#align pfunctor.M.corec_unique PFunctor.M.corec_unique
-/

#print PFunctor.M.corec₁ /-
/-- corecursor where the state of the computation can be sent downstream
in the form of a recursive call -/
def corec₁ {α : Type u} (F : ∀ X, (α → X) → α → P.Obj X) : α → M P :=
  M.corec (F _ id)
#align pfunctor.M.corec₁ PFunctor.M.corec₁
-/

#print PFunctor.M.corec' /-
/-- corecursor where it is possible to return a fully formed value at any point
of the computation -/
def corec' {α : Type u} (F : ∀ {X : Type u}, (α → X) → α → Sum (M P) (P.Obj X)) (x : α) : M P :=
  corec₁
    (fun X rec (a : Sum (M P) α) =>
      let y := a >>= F (rec ∘ Sum.inr)
      match y with
      | Sum.inr y => y
      | Sum.inl y => (rec ∘ Sum.inl) <$> M.dest y)
    (@Sum.inr (M P) _ x)
#align pfunctor.M.corec' PFunctor.M.corec'
-/

end M

end PFunctor


/-
Copyright (c) 2017 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro, Jeremy Avigad, Simon Hudon
-/
import data.part
import data.rel

/-!
# Partial functions

This file defines partial functions. Partial functions are like functions, except they can also be
"undefined" on some inputs. We define them as functions `α → part β`.

## Definitions

* `pfun α β`: Type of partial functions from `α` to `β`. Defined as `α → part β` and denoted
  `α →. β`.
* `pfun.dom`: Domain of a partial function. Set of values on which it is defined. Not to be confused
  with the domain of a function `α → β`, which is a type (`α` presently).
* `pfun.fn`: Evaluation of a partial function. Takes in an element and a proof it belongs to the
  partial function's `dom`.
* `pfun.as_subtype`: Returns a partial function as a function from its `dom`.
* `pfun.eval_opt`: Returns a partial function with a decidable `dom` as a function `a → option β`.
* `pfun.lift`: Turns a function into a partial function.
* `pfun.restrict`: Restriction of a partial function to a smaller `dom`.
* `pfun.res`: Turns a function into a partial function with a prescribed domain.
* `pfun.fix` : First return map of a partial function `f : α →. β ⊕ α`.
* `pfun.fix_induction`: A recursion principle for `pfun.fix`.

### Partial functions as relations

Partial functions can be considered as relations, so we specialize some `rel` definitions to `pfun`:
* `pfun.image`: Preimage of a set under a partial function.
* `pfun.ran`: Range of a partial function.
* `pfun.preimage`: Preimage of a set under a partial function.
* `pfun.core`: Core of a set under a partial function.
* `pfun.graph`: Graph of a partial function `a →. β`as a `set (α × β)`.
* `pfun.graph'`: Graph of a partial function `a →. β`as a `rel α β`.

### `pfun α` as a monad

Monad operations:
* `pfun.pure`: The monad `pure` function, the constant `x` function.
* `pfun.bind`: The monad `bind` function, pointwise `part.bind`
* `pfun.map`: The monad `map` function, pointwise `part.map`.
-/

/-- `pfun α β`, or `α →. β`, is the type of partial functions from
  `α` to `β`. It is defined as `α → part β`. -/
def pfun (α β : Type*) := α → part β

infixr ` →. `:25 := pfun

namespace pfun
variables {α β γ : Type*}

instance : inhabited (α →. β) := ⟨λ a, part.none⟩

/-- The domain of a partial function -/
def dom (f : α →. β) : set α := {a | (f a).dom}

theorem mem_dom (f : α →. β) (x : α) : x ∈ dom f ↔ ∃ y, y ∈ f x :=
by simp [dom, part.dom_iff_mem]

theorem dom_eq (f : α →. β) : dom f = {x | ∃ y, y ∈ f x} :=
set.ext (mem_dom f)

/-- Evaluate a partial function -/
def fn (f : α →. β) (x) (h : dom f x) : β := (f x).get h

/-- Evaluate a partial function to return an `option` -/
def eval_opt (f : α →. β) [D : decidable_pred (∈ dom f)] (x : α) : option β :=
@part.to_option _ _ (D x)

/-- Partial function extensionality -/
theorem ext' {f g : α →. β}
  (H1 : ∀ a, a ∈ dom f ↔ a ∈ dom g)
  (H2 : ∀ a p q, f.fn a p = g.fn a q) : f = g :=
funext $ λ a, part.ext' (H1 a) (H2 a)

theorem ext {f g : α →. β} (H : ∀ a b, b ∈ f a ↔ b ∈ g a) : f = g :=
funext $ λ a, part.ext (H a)

/-- Turns a partial function into a function out of its domain. -/
def as_subtype (f : α →. β) (s : f.dom) : β := f.fn s s.2

/-- The type of partial functions `α →. β` is equivalent to
the type of pairs `(p : α → Prop, f : subtype p → β)`. -/
def equiv_subtype : (α →. β) ≃ (Σ p : α → Prop, subtype p → β) :=
⟨λ f, ⟨λ a, (f a).dom, as_subtype f⟩,
 λ f x, ⟨f.1 x, λ h, f.2 ⟨x, h⟩⟩,
 λ f, funext $ λ a, part.eta _,
 λ ⟨p, f⟩, by dsimp; congr; funext a; cases a; refl⟩

theorem as_subtype_eq_of_mem {f : α →. β} {x : α} {y : β} (fxy : y ∈ f x) (domx : x ∈ f.dom) :
  f.as_subtype ⟨x, domx⟩ = y :=
part.mem_unique (part.get_mem _) fxy

/-- Turn a total function into a partial function. -/
protected def lift (f : α → β) : α →. β := λ a, part.some (f a)

instance : has_coe (α → β) (α →. β) := ⟨pfun.lift⟩

@[simp] theorem lift_eq_coe (f : α → β) : pfun.lift f = f := rfl

@[simp] theorem coe_val (f : α → β) (a : α) :
  (f : α →. β) a = part.some (f a) := rfl

/-- Graph of a partial function `f` as the set of pairs `(x, f x)` where `x` is in the domain of
`f`. -/
def graph (f : α →. β) : set (α × β) := {p | p.2 ∈ f p.1}

/-- Graph of a partial function as a relation. `x` and `y` are related iff `f x` is defined and
"equals" `y`. -/
def graph' (f : α →. β) : rel α β := λ x y, y ∈ f x

/-- The range of a partial function is the set of values
  `f x` where `x` is in the domain of `f`. -/
def ran (f : α →. β) : set β := {b | ∃ a, b ∈ f a}

/-- Restrict a partial function to a smaller domain. -/
def restrict (f : α →. β) {p : set α} (H : p ⊆ f.dom) : α →. β :=
λ x, (f x).restrict (x ∈ p) (@H x)

@[simp]
theorem mem_restrict {f : α →. β} {s : set α} (h : s ⊆ f.dom) (a : α) (b : β) :
  b ∈ f.restrict h a ↔ a ∈ s ∧ b ∈ f a :=
by simp [restrict]

/-- Turns a function into a partial function with a prescribed domain. -/
def res (f : α → β) (s : set α) : α →. β :=
(pfun.lift f).restrict s.subset_univ

theorem mem_res (f : α → β) (s : set α) (a : α) (b : β) :
  b ∈ res f s a ↔ (a ∈ s ∧ f a = b) :=
by simp [res, @eq_comm _ b]

theorem res_univ (f : α → β) : pfun.res f set.univ = f :=
rfl

theorem dom_iff_graph (f : α →. β) (x : α) : x ∈ f.dom ↔ ∃ y, (x, y) ∈ f.graph :=
part.dom_iff_mem

theorem lift_graph {f : α → β} {a b} : (a, b) ∈ (f : α →. β).graph ↔ f a = b :=
show (∃ (h : true), f a = b) ↔ f a = b, by simp

/-- The monad `pure` function, the total constant `x` function -/
protected def pure (x : β) : α →. β := λ _, part.some x

/-- The monad `bind` function, pointwise `part.bind` -/
def bind (f : α →. β) (g : β → α →. γ) : α →. γ :=
λ a, (f a).bind (λ b, g b a)

/-- The monad `map` function, pointwise `part.map` -/
def map (f : β → γ) (g : α →. β) : α →. γ :=
λ a, (g a).map f

instance : monad (pfun α) :=
{ pure := @pfun.pure _,
  bind := @pfun.bind _,
  map := @pfun.map _ }

instance : is_lawful_monad (pfun α) :=
{ bind_pure_comp_eq_map := λ β γ f x, funext $ λ a, part.bind_some_eq_map _ _,
  id_map := λ β f, by funext a; dsimp [functor.map, pfun.map]; cases f a; refl,
  pure_bind := λ β γ x f, funext $ λ a, part.bind_some.{u_1 u_2} _ (f x),
  bind_assoc := λ β γ δ f g k,
    funext $ λ a, (f a).bind_assoc (λ b, g b a) (λ b, k b a) }

theorem pure_defined (p : set α) (x : β) : p ⊆ (@pfun.pure α _ x).dom := p.subset_univ

theorem bind_defined {α β γ} (p : set α) {f : α →. β} {g : β → α →. γ}
  (H1 : p ⊆ f.dom) (H2 : ∀ x, p ⊆ (g x).dom) : p ⊆ (f >>= g).dom :=
λ a ha, (⟨H1 ha, H2 _ ha⟩ : (f >>= g).dom a)

/-- First return map. Transforms a partial function `f : α →. β ⊕ α` into the partial function
`α →. β` which sends `a : α` to the first value in `β` it hits by iterating `f`, if such a value
exists. By abusing notation to illustrate, either `f a` is in the `β` part of `β ⊕ α` (in which
case `f.fix a` returns `f a`), or it is undefined (in which case `f.fix a` is undefined as well), or
it is in the `α` part of `β ⊕ α` (in which case we repeat the procedure, so `f.fix a` will return
`f.fix (f a)`). -/
def fix (f : α →. β ⊕ α) : α →. β := λ a,
part.assert (acc (λ x y, sum.inr x ∈ f y) a) $ λ h,
@well_founded.fix_F _ (λ x y, sum.inr x ∈ f y) _
  (λ a IH, part.assert (f a).dom $ λ hf,
    by cases e : (f a).get hf with b a';
      [exact part.some b, exact IH _ ⟨hf, e⟩])
  a h

theorem dom_of_mem_fix {f : α →. β ⊕ α} {a : α} {b : β}
  (h : b ∈ f.fix a) : (f a).dom :=
let ⟨h₁, h₂⟩ := part.mem_assert_iff.1 h in
by rw well_founded.fix_F_eq at h₂; exact h₂.fst.fst

theorem mem_fix_iff {f : α →. β ⊕ α} {a : α} {b : β} :
  b ∈ f.fix a ↔ sum.inl b ∈ f a ∨ ∃ a', sum.inr a' ∈ f a ∧ b ∈ f.fix a' :=
⟨λ h, let ⟨h₁, h₂⟩ := part.mem_assert_iff.1 h in
  begin
    rw well_founded.fix_F_eq at h₂,
    simp at h₂,
    cases h₂ with h₂ h₃,
    cases e : (f a).get h₂ with b' a'; simp [e] at h₃,
    { subst b', refine or.inl ⟨h₂, e⟩ },
    { exact or.inr ⟨a', ⟨_, e⟩, part.mem_assert _ h₃⟩ }
  end,
λ h, begin
  simp [fix],
  rcases h with ⟨h₁, h₂⟩ | ⟨a', h, h₃⟩,
  { refine ⟨⟨_, λ y h', _⟩, _⟩,
    { injection part.mem_unique ⟨h₁, h₂⟩ h' },
    { rw well_founded.fix_F_eq, simp [h₁, h₂] } },
  { simp [fix] at h₃, cases h₃ with h₃ h₄,
    refine ⟨⟨_, λ y h', _⟩, _⟩,
    { injection part.mem_unique h h' with e,
      exact e ▸ h₃ },
    { cases h with h₁ h₂,
      rw well_founded.fix_F_eq, simp [h₁, h₂, h₄] } }
end⟩

/-- A recursion principle for `pfun.fix`. -/
@[elab_as_eliminator] def fix_induction
  {f : α →. β ⊕ α} {b : β} {C : α → Sort*} {a : α} (h : b ∈ f.fix a)
  (H : ∀ a, b ∈ f.fix a →
    (∀ a', b ∈ f.fix a' → sum.inr a' ∈ f a → C a') → C a) : C a :=
begin
  replace h := part.mem_assert_iff.1 h,
  have := h.snd, revert this,
  induction h.fst with a ha IH, intro h₂,
  refine H a (part.mem_assert_iff.2 ⟨⟨_, ha⟩, h₂⟩)
    (λ a' ha' fa', _),
  have := (part.mem_assert_iff.1 ha').snd,
  exact IH _ fa' ⟨ha _ fa', this⟩ this
end

end pfun

namespace pfun

variables {α β : Type*} (f : α →. β)

/-- Image of a set under a partial function. -/
def image (s : set α) : set β := f.graph'.image s

lemma image_def (s : set α) : f.image s = {y | ∃ x ∈ s, y ∈ f x} := rfl

lemma mem_image (y : β) (s : set α) : y ∈ f.image s ↔ ∃ x ∈ s, y ∈ f x :=
iff.rfl

lemma image_mono {s t : set α} (h : s ⊆ t) : f.image s ⊆ f.image t :=
rel.image_mono _ h

lemma image_inter (s t : set α) : f.image (s ∩ t) ⊆ f.image s ∩ f.image t :=
rel.image_inter _ s t

lemma image_union (s t : set α) : f.image (s ∪ t) = f.image s ∪ f.image t :=
rel.image_union _ s t

/-- Preimage of a set under a partial function. -/
def preimage (s : set β) : set α := rel.image (λ x y, x ∈ f y) s

lemma preimage_def (s : set β) : f.preimage s = {x | ∃ y ∈ s, y ∈ f x} := rfl

lemma mem_preimage (s : set β) (x : α) : x ∈ f.preimage s ↔ ∃ y ∈ s, y ∈ f x :=
iff.rfl

lemma preimage_subset_dom (s : set β) : f.preimage s ⊆ f.dom :=
λ x ⟨y, ys, fxy⟩, part.dom_iff_mem.mpr ⟨y, fxy⟩

lemma preimage_mono {s t : set β} (h : s ⊆ t) : f.preimage s ⊆ f.preimage t :=
rel.preimage_mono _ h

lemma preimage_inter (s t : set β) : f.preimage (s ∩ t) ⊆ f.preimage s ∩ f.preimage t :=
rel.preimage_inter _ s t

lemma preimage_union (s t : set β) : f.preimage (s ∪ t) = f.preimage s ∪ f.preimage t :=
rel.preimage_union _ s t

lemma preimage_univ : f.preimage set.univ = f.dom :=
by ext; simp [mem_preimage, mem_dom]

/-- Core of a set `s : set β` with respect to a partial function `f : α →. β`. Set of all `a : α`
such that `f a ∈ s`, if `f a` is defined. -/
def core (s : set β) : set α := f.graph'.core s

lemma core_def (s : set β) : f.core s = {x | ∀ y, y ∈ f x → y ∈ s} := rfl

lemma mem_core (x : α) (s : set β) : x ∈ f.core s ↔ (∀ y, y ∈ f x → y ∈ s) :=
iff.rfl

lemma compl_dom_subset_core (s : set β) : f.domᶜ ⊆ f.core s :=
λ x hx y fxy,
absurd ((mem_dom f x).mpr ⟨y, fxy⟩) hx

lemma core_mono {s t : set β} (h : s ⊆ t) : f.core s ⊆ f.core t :=
rel.core_mono _ h

lemma core_inter (s t : set β) : f.core (s ∩ t) = f.core s ∩ f.core t :=
rel.core_inter _ s t

lemma mem_core_res (f : α → β) (s : set α) (t : set β) (x : α) :
  x ∈ (res f s).core t ↔ x ∈ s → f x ∈ t :=
by simp [mem_core, mem_res]

section
open_locale classical

lemma core_res (f : α → β) (s : set α) (t : set β) : (res f s).core t = sᶜ ∪ f ⁻¹' t :=
by { ext, rw mem_core_res, by_cases h : x ∈ s; simp [h] }

end

lemma core_restrict (f : α → β) (s : set β) : (f : α →. β).core s = s.preimage f :=
by ext x; simp [core_def]

lemma preimage_subset_core (f : α →. β) (s : set β) : f.preimage s ⊆ f.core s :=
λ x ⟨y, ys, fxy⟩ y' fxy',
have y = y', from part.mem_unique fxy fxy',
this ▸ ys

lemma preimage_eq (f : α →. β) (s : set β) : f.preimage s = f.core s ∩ f.dom :=
set.eq_of_subset_of_subset
  (set.subset_inter (f.preimage_subset_core s) (f.preimage_subset_dom s))
  (λ x ⟨xcore, xdom⟩,
    let y := (f x).get xdom in
    have ys : y ∈ s, from xcore _ (part.get_mem _),
    show x ∈ f.preimage s, from  ⟨(f x).get xdom, ys, part.get_mem _⟩)

lemma core_eq (f : α →. β) (s : set β) : f.core s = f.preimage s ∪ f.domᶜ :=
by rw [preimage_eq, set.union_distrib_right, set.union_comm (dom f), set.compl_union_self,
        set.inter_univ, set.union_eq_self_of_subset_right (f.compl_dom_subset_core s)]

lemma preimage_as_subtype (f : α →. β) (s : set β) :
  f.as_subtype ⁻¹' s = subtype.val ⁻¹' f.preimage s :=
begin
  ext x,
  simp only [set.mem_preimage, set.mem_set_of_eq, pfun.as_subtype, pfun.mem_preimage],
  show f.fn (x.val) _ ∈ s ↔ ∃ y ∈ s, y ∈ f (x.val),
  exact iff.intro
    (λ h, ⟨_, h, part.get_mem _⟩)
    (λ ⟨y, ys, fxy⟩,
      have f.fn x.val x.property ∈ f x.val := part.get_mem _,
      part.mem_unique fxy this ▸ ys)
end

end pfun


/-
This example demonstrates a case where Lean4's tabled typeclass resolution may loop.
It also suggests a workaround, new instance binder semantics, new syntax support, and a new instance validation rule.
-/
#exit

class Field (K : Type) := (u : Unit)
class VectorSpace (K : Type) [Field K] (E : Type) := (u : Unit)
instance VectorSpaceSelf (K : Type) [Field K] : VectorSpace K K := {u:=()}
class CompleteSpace (α : Type) := (u : Unit)
def AlgebraicClosure (K : Type) [Field K] : Type := K

/-
Note that this instance is not a problem when `K` is known,
because it will only ever "unpack" AlgebraicClosures, not create new ones
However, if `K` is ever not known, it will create them ad infinitum!
-/
instance AlgebraicClosure.Field (K : Type) [Field K] : Field (AlgebraicClosure K) := {u:=()}

/-
Here is the "bad" instance one may be tempted to write:

<<
instance bad (K E : Type) [Field K] [VectorSpace K E] [CompleteSpace K] : CompleteSpace E := {u := ()}
>>

It is bad because typeclass resolution will try to find `Field ?K` before it knows what `?K` is,
which in conjunction with the instance `AlgebraicClosure.Field`, will cause resolution to diverge.

Here is the workaround, which is very ugly:

<<
instance veryUgly (K E : Type) {fK : Field K} [@VectorSpace K fK E] [CompleteSpace K] : CompleteSpace E := {u := ()}
>>

Here, `Field ?K` is not solved by typeclass resolution, and instead `VectorSpace ?K ?fK E` will be solved first instead.

With the Lean3 instance semantics, one could make this less ugly by writing
-/
instance ugly (K E : Type) {_ : Field K} [VectorSpace K E] [CompleteSpace K] : CompleteSpace E := {u := ()}

/-
This would work because the `Field K` instance would still be considered for typeclass resolution even though it was not in a `[]` binder.
However, the original plan for Lean4 was that one would only consider `[]` binders for typeclass resolution.
We suggest that we revert to the Lean3 protocol instead, and consider any local variable with class type as a candidate instance.

Finally, this instance could be made reasonable by allowing `{}` binders without names:
<<
instance reasonable (K E : Type) {Field K} [VectorSpace K E] [CompleteSpace K] : CompleteSpace E := {u := ()} -- should work in Lean4
>>
-/

axiom K : Type
instance K_Field : Field K := {u:=()}

#synth CompleteSpace K -- should fail quickly (and in particular, not run forever)

/-
The bad instance above could trigger a validation warning:

<<
instance bad (K E : Type) [Field K] [VectorSpace K E] [CompleteSpace K] : CompleteSpace E := {u := ()}
>>
-- Warning: argument #3 is a class that occurs in downstream arguments and not the return type.
-- You may want to replace [Field K] with {Field K} so typeclass resolution infers this instance after solving downstream instances.
-/

/-
The syntax `[Field K]` is ambiguous. It can be interpreted also as {Field K : _}. Note that we use this version all the time (e.g., {α β}).
-/


/-
This is the second homework assignment for UVa CS2101, Spring 2019.

If you are in Professor Sullivan's class, you are to complete problems 1 - 8.
If you are in Prof. Hocking's class, you are to complete problems 9 - 13.

The first eight problems require that you carefully read the updated class
notes on relations vs. functions and on properties of functions: from the
start of 2.4 through 2.4.4. For all of the remaining problems, you must
have read the rest of the chapter, on higher-order functions.

The collaboration policy for this assignment has two parts. First, you must
complete this work on your own. Second, please do not discuss your results
with anyone in the other professor's class, even after the deadline for the
homework has passed, as your assignment this week will be part of their
assignment next week.

To complete this homework, first make a copy of this file in the "work"
directory of your class repository. Do not edit this file directly in the
hw directory. Make a copy first. Then fill in answers as required, save
your changes, and submit your work by uploading the completed file on Collab.

Make a copy of this file in your work directory; complete the work using
that copy; then upload the resulting file, after saving it, through Collab
before the due date.
-/

/- [10 points]

1. Is the function, G, as defined in the reading, total? Explain.

Answer here:  G = ({1, 2, 3}, { (1, 10), (2, 20), (3, 30) }, ℕ)

Yes, it's defined for every value in its domain of definition.

-/

/- [10 points]

2. Give an example of a value in the domain of definition of the function, F,
as defined in the reading, that proves that F is strictly partial, i.e.,
for which F is not defined.

Answer here:  F = (ℕ, { (1, 10), (2, 20), (3, 30) }, ℕ ). F is partial. It's
not defined for 0 or any other value that's not 1, 2, 3.

-/

/- [10 points]

3. Give an example of a value in the codomain of F that proves that F is
not surjective.

Answer here: Any natural number other than 10, 20, 30.

-/

/- [10 points]

4. Is our example function, G, strictly partial? Explain.

Answer here: No, we already said it's total.

-/

/- [15 points]

5. Identify a value in the codomain of F that is not the image of any
value in its domain of definition.

Answer here: Any number that's not 10, 20, 30

-/

/- [15 points]

6. Translate our logical definition of injective into mathematically
precise English following the examples for other properties of functions
given in the reading.

Answer here: A function, f, is injective if the whenever two values map
to the same image they are the same value. We will accept any reasonable
version of this statement.

-/

/- [15 points]

7. Is the function, f(x) = log(x) over the real numbers, injective?
Is it surjective? Is it bijective? Explain each of your answers briefly.

Answer here: Yes it's injective (it passes the horizontal line test.) We
will take any reasonable explanation. Yes it's surjective, in that it covers
the whole co-domain.

-/

/- [15 points]

8. Is the relation, 3x^2 + 4y^2 = 4, single-valued? Explain your answers.

Answer here: No, it's an ellipse. Doesn't pass vertical line test.

-/

/-
Complete each of the following partial definitions in Lean by replacing
the underscore characters with code to define functions of the specified
types using lambda notation. We only care that you define some function
of each required type, not what particular function you define.

In preparation, note that if you hover your mouse over an underscore,
Lean will tell you what type of term you is needed to fill that hole.
The type that Lean requires appears after the "turnstile" symbol, |-,
in the message Lean will give you. Even more interestingly, if you
fill in a hole with a term of the right type that itself has one or
more remaining holes, Lean will tell you what types of terms are needed
to fill in those holes! You can thus fill a hole in an incremental manner,
refining a partial solution at each step until all holes are filled,
guided by the types that Lean tells you are needed for any given hole.
We recommend that you try developing your answers in this "top-down
structured" style of programming. That said, we will grade you only on
your answers and not on how you developed them.
-/

-- Rubric: We will accept your answer as long as Lean does. We give
-- examples of answers in this key. Other anwers are possible.

-- 9.
def hw2_1: ℕ → ℕ :=
    λ(x: ℕ),
        0

-- 10.
def hw2_2: ℕ → ℕ → ℕ :=
    λ n m, 0

-- 11.
def hw2_3: (ℕ → ℕ) → (ℕ → ℕ) :=
    λ f, f

-- 12.
def hw2_4: (ℕ → ℕ) → ((ℕ → ℕ) → ℕ) :=
    λ f,
        λ g, 0

-- 13.
def hw2_5: (ℕ → ℕ) → ((ℕ → ℕ) → (ℕ → ℕ)) :=
    λ f,
        λ g,
            f