/-
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., {α β}).
-/


import datatypes -- blackboard

namespace polya

section aux

meta def mk_neg : expr → expr
| `((-%%lhs) * %%rhs) := `(%%lhs * %%rhs : ℚ)
| `(%%lhs * %%rhs) := `((-%%lhs) * %%rhs : ℚ)
| a := `((-1 : ℚ)*%%a)

meta def get_sum_components : expr → list expr
| `(%%lhs + %%rhs) := rhs::(get_sum_components lhs)
| `(%%lhs - %%rhs) := mk_neg rhs::(get_sum_components lhs)
| a := [a]

meta def get_prod_components : expr → list expr
| `(%%lhs * %%rhs) := rhs::(get_prod_components lhs)
| a := [a]

meta def is_sum (e : expr) : bool :=
e.is_app_of ``has_add.add || e.is_app_of ``has_sub.sub

meta def is_prod (e : expr) : bool :=
e.is_app_of ``has_mul.mul || e.is_app_of ``rat.pow

open tactic
meta def get_comps_of_mul (e : expr) : tactic (expr × ℚ) := match e with
| `(%%lhs * %%rhs) := (do c ← eval_expr ℚ lhs, return (rhs, c)) <|> return (e, 1)
| `(%%num / %%denom) := (do c ← eval_expr ℚ denom, return (num, 1/c)) <|> return (e, 1)
| f := return (f, 1)
end

meta def get_comps_of_exp (e : expr) : tactic (expr × ℤ) := match e with
| `(rat.pow %%base %%exp) := (do z ← eval_expr ℤ exp, return (base, z)) <|> return (e, 1)
| f := return (f, 1)
end

end aux

open native

/-meta mutual inductive sterm, term
with sterm : Type
| scaled : ℚ → term → sterm
with term : Type
| add_term : list sterm → term
| mul_term : list (term × ℤ) → term
| atom : expr → term-/
meta inductive term : Type
| add_term : rb_map term ℚ → term
| mul_term : rb_map term ℤ → term
| atom : expr → term

meta structure sterm :=
(coeff : ℚ) (body : term)

namespace term

meta mutual def cmp, list_cmp
with cmp : term → term → ordering
| (add_term m) (add_term n) := list_cmp m.keys n.keys
| (add_term _) _ := ordering.gt
| _ (add_term _) := ordering.lt
| (mul_term m) (mul_term n) := list_cmp m.keys n.keys
| (mul_term _) (atom _) := ordering.gt
| (atom _) (mul_term _) := ordering.lt
| (atom e1) (atom e2) := cmp_using has_lt.lt e1 e2
with list_cmp : list term → list term → ordering
| [] [] := ordering.eq
| [] _  := ordering.lt
| _  [] := ordering.gt
| (x::xs) (y::ys) := let c := cmp x y in if c = ordering.eq then list_cmp xs ys else c

meta def lt (x y : term) := cmp x y = ordering.lt

meta instance : has_lt term := ⟨lt⟩
meta instance : decidable_rel lt := λ x y, by delta lt; apply_instance

meta def add_term_empty : term :=
add_term mk_rb_map

meta def mul_term_empty : term :=
mul_term mk_rb_map
end term

private meta def add_term_coeff_pair (map : rb_map term ℚ) (st : term × ℚ) : rb_map term ℚ :=
match map.find st.1 with
| none := map.insert st.1 st.2
| some c := map.insert st.1 (st.2 + c)
end

private meta def add_term_coeff_pair_list (map : rb_map term ℚ) (l : list (term × ℚ)) : rb_map term ℚ :=
l.foldl add_term_coeff_pair map

private meta def add_sterm (map : rb_map term ℚ) (st : sterm) : rb_map term ℚ :=
add_term_coeff_pair map (st.body, st.coeff)

meta def add_term_of_sterm_list (l : list sterm) : term :=
term.add_term $ l.foldl add_sterm mk_rb_map

private meta def pow_term_exp (map : rb_map term ℤ) (pr : term × ℤ) : rb_map term ℤ :=
match map.find pr.1 with
| none := map.insert pr.1 pr.2
| some c := map.insert pr.1 (pr.2 + c)
end

private meta def pow_term_exp_list (map : rb_map term ℤ) (l : list (term × ℤ)) : rb_map term ℤ :=
l.foldl pow_term_exp map

meta def mul_term_of_term_exp_list (l : list (term × ℤ)) : term :=
term.mul_term $ l.foldl pow_term_exp mk_rb_map

meta def term.is_zero : term → bool
| (term.add_term m) := m.size = 0
| _ := ff

meta def sterm.is_zero (st : sterm) : bool :=
st.body.is_zero || (st.coeff = 0)

meta def term.scale (q : ℚ) (t : term) : sterm :=
⟨q, t⟩

meta def sterm.scale (q : ℚ) (st : sterm) : sterm :=
{ st with coeff := st.coeff * q }

meta def sterm.of_pair (pr : term × ℚ) : sterm :=
⟨pr.2, pr.1⟩

open tactic

private meta def expr.to_term_aux (tst : expr → tactic sterm) : expr → tactic term | e :=
if is_sum e then
  let scs := get_sum_components e in
  add_term_of_sterm_list <$> scs.mmap tst
else if is_prod e then
  let scs := get_prod_components e in
  do scs' ← scs.mmap get_comps_of_exp,
     mul_term_of_term_exp_list <$> scs'.mmap (λ pr, do tm ← expr.to_term_aux pr.1, return (tm, pr.2))
else return $ term.atom e

private meta def split_num_nonnum_prod_comps : list expr → list expr × list expr
| [] := ([], [])
| (e::l) :=
   let (t1, t2) := split_num_nonnum_prod_comps l in
   if expr.is_numeral e then (e::t1, t2) else (t1, e::t2)

private meta def fold_op_app_aux (op : pexpr) : expr → list expr → tactic expr
| h [] := return h
| h (h'::t) := do h'' ← to_expr ``(%%op %%h %%h'), fold_op_app_aux h'' t

private meta def fold_op_app (op : pexpr) (dflt : expr) : list expr → tactic expr
| [] := return dflt
| (h::t) := fold_op_app_aux op h t

meta def expr.to_sterm : expr → tactic sterm | e :=
if expr.is_numeral e then
  do q ← eval_expr ℚ e,
     return ⟨q, (term.atom `(1 : ℚ))⟩
else if is_prod e then
 let scs := get_prod_components e,
     (numcs, nnumcs) := split_num_nonnum_prod_comps scs in
 do  numcs' ← numcs.mmap (eval_expr ℚ),
 let q := numcs'.foldl (*) 1,
     sterm.mk q <$> ((fold_op_app ``((*)) `(1 : ℚ) nnumcs) >>= expr.to_term_aux expr.to_sterm)
else sterm.mk 1 <$> expr.to_term_aux expr.to_sterm e

/-match e with
| `(%%c*%%t) :=
  if expr.is_numeral c then
    do q ← eval_expr ℚ c,
       sterm.scale q <$> expr.to_sterm t
  else sterm.mk 1 <$> expr.to_term_aux expr.to_sterm e
| t := sterm.mk 1 <$> expr.to_term_aux expr.to_sterm t
end       -/

meta def expr.to_term : expr → tactic term := expr.to_term_aux expr.to_sterm

private meta def term.to_expr_aux (ste : sterm → tactic expr) : term → tactic expr
| (term.add_term l) :=
 if l.size = 0 then return `(0 : ℚ) else
 do l' ← l.to_list.mmap (λ pr, ste (sterm.of_pair pr)),
     fold_op_app ``((+)) `(0 : ℚ) l'
| (term.mul_term l) :=
  if l.size = 0 then return `(1 : ℚ) else
  do l' ← l.to_list.mmap (λ pr, do e' ← term.to_expr_aux pr.1, return (e', pr.2)),
  let l'' := l'.map (λ pr, `(rat.pow %%(pr.1) %%(pr.2.reflect))),
     fold_op_app ``((*)) `(1 : ℚ) l''
| (term.atom e) := return e

meta def sterm.to_expr : sterm → tactic expr
| ⟨c, t⟩ :=
  if t.is_zero || (c = 0) then return `(0 : ℚ) else
  do t' ← term.to_expr_aux sterm.to_expr t,
     return `(%%(c.reflect)*%%t' : ℚ)

meta def term.to_expr : term → tactic expr := term.to_expr_aux sterm.to_expr

meta def term.to_tactic_format (e : term) : tactic format :=
do ex ← e.to_expr,
   tactic_format_expr ex

meta def sterm.to_tactic_format (e : sterm) : tactic format :=
do ex ← e.to_expr,
   tactic_format_expr ex

meta instance term.has_to_tactic_format : has_to_tactic_format term :=
⟨term.to_tactic_format⟩

meta instance sterm.has_to_tactic_format : has_to_tactic_format sterm :=
⟨sterm.to_tactic_format⟩

section canonize

private meta def coeff_and_terms_of_sterm_z_list : list (sterm × ℤ) → ℚ × list (term × ℤ)
| [] := (1, [])
| ((⟨c, tm⟩, z)::t) :=
   let (q, l) := coeff_and_terms_of_sterm_z_list  t in
  (q * rat.pow c z, (tm, z)::l)

/-private meta def coeff_and_terms_of_sterm_z_list : ℚ → list (term × ℤ) → list (sterm × ℤ) → ℚ × list (term × ℤ)
| acc l [] := (acc, l)
| acc l ((sterm.scaled c tm, z)::t) := (tm, z)::coeff_and_terms_of_sterm_z_list (acc*rat.pow c z) t-/

-- only applies to add_term
private meta def term.leading_coeff : term → ℚ
| (term.add_term l) :=
  match l.to_list with
  | [] := 1
  | ((_, c)::t) := c
  end
| _ := 1

-- only applies to add_term
private meta def term.scale_coeffs (c : ℚ) : term → term
| (term.add_term l) := term.add_term $ l.map (λ c', c*c')
| a := a

-- doesn't flatten
private meta def term.canonize_aux (stc : sterm → tactic sterm) : term → tactic sterm
| (term.add_term l) :=
  do l' ← add_term_of_sterm_list <$> l.to_list.mmap (λ pr, stc (sterm.of_pair pr)),
     let c := term.leading_coeff l',
     return ⟨c, term.scale_coeffs (1/c) l'⟩
/-  do l' : list (sterm × expr) ← l.to_list.mmap (λ st, do st' ← stc (sterm.of_pair st), e ← st'.to_expr, return (st', e)),
  let l' := (l'.qsort (λ pr1 pr2 : sterm × expr, pr2.2.lt pr1.2)).map prod.fst,
  match l' with
  | [] := return $ sterm.mk 1 term.add_term_empty
  | [st] := return st
  | (⟨c, tm⟩)::t :=
    if c = 1 then return $ sterm.mk 1 (add_term_of_sterm_list l')
    else return $ sterm.mk c (add_term_of_sterm_list (l'.map (sterm.scale (1/c))))
  end-/
| (term.mul_term l) :=
  do l' ←  l.to_list.mmap (λ pr, do t' ← term.canonize_aux pr.1, return (t', pr.2)),
     let (q, l'') := coeff_and_terms_of_sterm_z_list l',
     return ⟨q, mul_term_of_term_exp_list l''⟩
 /- do l' ← l.to_list.mmap (λ pr, do t' ← term.canonize_aux pr.1, e ← t'.to_expr, return ((t', pr.2), e)),
    let l' := (l'.qsort (λ pr1 pr2 : (sterm × ℤ) × expr, pr2.2.lt pr1.2)),
    let l' := l'.map prod.fst,
    let (q, l'') := coeff_and_terms_of_sterm_z_list l',
    return $ sterm.mk q (mul_term_of_term_exp_list l'')-/
| (term.atom e) := return $ sterm.mk 1 (term.atom e)

-- doesn't flatten
private meta def sterm.canonize_aux : sterm → tactic sterm
| ⟨c, t⟩ :=
  do sterm.mk c' t' ← term.canonize_aux sterm.canonize_aux t,
  return $ sterm.mk (c*c') t'

/-private meta def flatten_sum_list : list (term × ℚ) → list (term × ℚ)
| [] := []
| ((term.add_term tm, c)::t) :=
  (tm.to_list.map (λ pr : term × ℚ, (pr.1, pr.2*c))).append (flatten_sum_list t)
| (h::t) := h::flatten_sum_list t

private meta def flatten_prod_list : list (term × ℤ) → list (term × ℤ)
| [] := []
| ((term.mul_term l, z)::t) := (l.to_list.map (λ pr : term × ℤ, (pr.1, pr.2*z))).append (flatten_prod_list t)
| (h::t) := h::flatten_prod_list t-/

private meta def scale_list {α} [has_mul α] (l : list (term × α)) (q : α) : list (term × α) :=
l.map (λ pr, {pr with snd := pr.snd * q})

private meta def flatten_sum_term_aux (t : term) (coeff : ℚ) (map : rb_map term ℚ) : rb_map term ℚ :=
match t with
| term.add_term l := add_term_coeff_pair_list map (scale_list l.to_list coeff)
| _ := map.insert t coeff
end

private meta def flatten_sum_term (map : rb_map term ℚ) : rb_map term ℚ :=
map.fold mk_rb_map flatten_sum_term_aux

private meta def flatten_mul_term_aux (t : term) (exp : ℤ) (map : rb_map term ℤ) : rb_map term ℤ :=
match t with
| term.mul_term l := pow_term_exp_list map (scale_list l.to_list exp)
| _ := map.insert t exp
end

private meta def flatten_mul_term (map : rb_map term ℤ) : rb_map term ℤ :=
map.fold mk_rb_map flatten_mul_term_aux

private meta def term.flatten : term → term
| (term.add_term l) := term.add_term $ flatten_sum_term l --$ rb_map.of_list (flatten_sum_list l.to_list)
| (term.mul_term l) := term.mul_term $ flatten_mul_term l --$ rb_map.of_list (flatten_prod_list l.to_list)
| a := a

private meta def sterm.flatten : sterm → sterm
| (sterm.mk c t) := sterm.mk c (term.flatten t)

meta def sterm.canonize : sterm → tactic sterm :=
sterm.canonize_aux ∘ sterm.flatten

meta def term.canonize (t : term) : tactic sterm :=
term.canonize_aux sterm.canonize (term.flatten t)

meta def expr.canonize (e : expr) : tactic sterm :=
match e with
| `(0 : ℚ) := return $ sterm.mk 0 (term.add_term_empty)
| _ := expr.to_sterm e >>= sterm.canonize
end

meta def expr.canonize_to_expr (e : expr) : tactic expr :=
match e with
| `(0 : ℚ) := return e
| _ := expr.to_sterm e >>= sterm.canonize >>= sterm.to_expr
end

theorem canonized_inequality {P : Prop} (h : P) (canP : Prop) : canP := sorry

meta def prove_inequality (lhs rhs pf : expr) (op : gen_comp) : tactic expr :=
do sterm.mk clhs tlhs ← expr.canonize lhs,
   --trace "tlhs", trace tlhs,
   srhs ← expr.canonize rhs,
   --trace "srhs", trace srhs,
   elhs ← tlhs.to_expr,
   if clhs = 0 then
     do erhs ← srhs.to_expr,
        tp ← op.reverse.to_function erhs elhs,
        mk_app ``canonized_inequality [pf, tp]
   else
     do erhs ← (srhs.scale (1/clhs)).to_expr,
        tp ← ((if clhs < 0 then gen_comp.reverse else id) op).to_function elhs erhs, --to_expr ``(%%op %%elhs %%erhs),
        mk_app ``canonized_inequality [pf, tp]

meta def canonize_hyp (e : expr) : tactic expr :=
do tp ← infer_type e, match tp with
/-| `(0 > %%e) := do ce ← expr.canonize e,
  mk_app ``canonized_inequality [e, `(0 > %%ce)]
| `(0 ≥ %%e) := do ce ← expr.canonize e,
  mk_app ``canonized_inequality [e, `(0 ≥ %%ce)]
| `(0 < %%e) := do ce ← expr.canonize e,
  mk_app ``canonized_inequality [e, `(0 < %%ce)]
| `(0 ≤ %%e) := do ce ← expr.canonize e,
  mk_app ``canonized_inequality [e, `(0 ≤ %%ce)]
| `(%%e > 0) := do ce ← expr.canonize e,
  mk_app ``canonized_inequality [e, `(%%ce > 0)]
| `(%%e ≥ 0) := do ce ← expr.canonize e,
  mk_app ``canonized_inequality [e, `(%%ce ≥ 0)]
| `(%%e < 0) := do ce ← expr.canonize e,
  mk_app ``canonized_inequality [e, `(%%ce < 0)]
| `(%%e ≤ 0) := do ce ← expr.canonize e,
  mk_app ``canonized_inequality [e, `(%%ce ≤ 0)]-/
| `(%%lhs ≤ %%rhs) := prove_inequality lhs rhs e gen_comp.le
| `(%%lhs < %%rhs) := prove_inequality lhs rhs e gen_comp.lt
| `(%%lhs ≥ %%rhs) := prove_inequality lhs rhs e gen_comp.ge
| `(%%lhs > %%rhs) := prove_inequality lhs rhs e gen_comp.gt
| `(%%lhs = %%rhs) := prove_inequality lhs rhs e gen_comp.eq
| `(%%lhs ≠ %%rhs) := prove_inequality lhs rhs e gen_comp.ne
| _ := /-trace e >>-/ do s ← to_string <$> pp e, fail $ "didn't recognize " ++ s
end

end canonize
end polya