import algebra.camera.basic

universes u v

@[ext] structure agree_struct (α : Type u) :=
(elts : finset α)
(nonempty : elts.nonempty)

instance agree_struct.has_mem {α : Type u} : has_mem α (agree_struct α) :=
⟨λ x a, x ∈ a.elts⟩

@[simp] lemma agree_struct.has_mem_iff {α : Type u} (x : α) (a : agree_struct α) :
  x ∈ a.elts ↔ x ∈ a := iff.rfl

@[simp] lemma agree_struct.mem_mk {α : Type u} (x : α) (elts : finset α) (nonempty : elts.nonempty) :
  x ∈ (⟨elts, nonempty⟩ : agree_struct α) ↔ x ∈ elts := iff.rfl

structure agree_struct.eq_at {α : Type u} [ofe α] (n : ℕ) (a b : agree_struct α) : Prop :=
(left : ∀ x ∈ a, ∃ y ∈ b, x =[n] y)
(right : ∀ y ∈ b, ∃ x ∈ a, x =[n] y)

lemma agree_struct.eq_at_reflexive {α : Type u} [ofe α] (n : ℕ) :
  reflexive (agree_struct.eq_at n : agree_struct α → agree_struct α → Prop) :=
begin
  intros a,
  split;
  { intros x hx,
    refine ⟨x, hx, _⟩,
    refl, },
end

@[refl] lemma agree_struct.eq_at_refl {α : Type u} [ofe α] {n : ℕ} (a : agree_struct α) :
  agree_struct.eq_at n a a := agree_struct.eq_at_reflexive n a

lemma agree_struct.eq_at_symmetric {α : Type u} [ofe α] (n : ℕ) :
  symmetric (agree_struct.eq_at n : agree_struct α → agree_struct α → Prop) :=
begin
  intros a b hab,
  split,
  { intros x hx,
    obtain ⟨y, hy, h⟩ := hab.right x hx,
    refine ⟨y, hy, _⟩,
    symmetry,
    assumption, },
  { intros x hx,
    obtain ⟨y, hy, h⟩ := hab.left x hx,
    refine ⟨y, hy, _⟩,
    symmetry,
    assumption, },
end

@[symm] lemma agree_struct.eq_at_symm {α : Type u} [ofe α] {n : ℕ} (a b : agree_struct α) :
  agree_struct.eq_at n a b → agree_struct.eq_at n b a := λ h, agree_struct.eq_at_symmetric n h

lemma agree_struct.eq_at_transitive {α : Type u} [ofe α] (n : ℕ) :
  transitive (agree_struct.eq_at n : agree_struct α → agree_struct α → Prop) :=
begin
  intros a b c hab hbc,
  split,
  { intros x hx,
    obtain ⟨y, hy₁, hy₂⟩ := hab.left x hx,
    obtain ⟨z, hz₁, hz₂⟩ := hbc.left y hy₁,
    refine ⟨z, hz₁, _⟩,
    transitivity y; assumption, },
  { intros x hx,
    obtain ⟨y, hy₁, hy₂⟩ := hbc.right x hx,
    obtain ⟨z, hz₁, hz₂⟩ := hab.right y hy₁,
    refine ⟨z, hz₁, _⟩,
    transitivity y; assumption, },
end

@[trans] lemma agree_struct.eq_at_trans {α : Type u} [ofe α] {n : ℕ} (a b c : agree_struct α) :
  agree_struct.eq_at n a b → agree_struct.eq_at n b c → agree_struct.eq_at n a c :=
λ h₁ h₂, agree_struct.eq_at_transitive n h₁ h₂

lemma agree_struct.eq_at_equivalence {α : Type u} [ofe α] (n : ℕ) :
  equivalence (agree_struct.eq_at n : agree_struct α → agree_struct α → Prop) :=
⟨agree_struct.eq_at_reflexive n, agree_struct.eq_at_symmetric n, agree_struct.eq_at_transitive n⟩

lemma agree_struct.eq_at_mono {α : Type u} [ofe α] :
  antitone (agree_struct.eq_at : ℕ → agree_struct α → agree_struct α → Prop) :=
begin
  intros m n hmn a b h,
  split,
  { intros x hx,
    obtain ⟨y, hy₁, hy₂⟩ := h.left x hx,
    refine ⟨y, hy₁, _⟩,
    exact eq_at_mono hmn hy₂, },
  { intros x hx,
    obtain ⟨y, hy₁, hy₂⟩ := h.right x hx,
    refine ⟨y, hy₁, _⟩,
    exact eq_at_mono hmn hy₂, },
end

lemma agree_struct.mem_of_forall_eq_at {α : Type u} [ofe α] (a b : agree_struct α) :
  (∀ (n : ℕ), agree_struct.eq_at n a b) → ∀ x ∈ a, x ∈ b :=
begin
  intros h x hx,
  have : ∀ n, ∃ y ∈ b, x =[n] y := λ n, (h n).left x hx,
  choose Y hY₁ hY₂ using this,
  set f : ℕ → b.elts := λ n, ⟨Y n, hY₁ n⟩,
  obtain ⟨⟨y, hy₁⟩, hy₂⟩ := finite.exists_infinite_fiber f,
  suffices : x = y,
  { rw this, exact hy₁, },
  rw set.infinite_coe_iff at hy₂,
  refine eq_at_infinite _ _ hy₂ _,
  intros n hn,
  simp only [set.mem_preimage, set.mem_singleton_iff, subtype.mk_eq_mk] at hn,
  rw ← hn,
  exact hY₂ n,
end

lemma agree_struct.eq_at_limit {α : Type u} [ofe α] (a b : agree_struct α) :
  (∀ (n : ℕ), agree_struct.eq_at n a b) → a = b :=
begin
  intros h,
  ext x,
  split,
  { exact agree_struct.mem_of_forall_eq_at _ _ h _, },
  { refine agree_struct.mem_of_forall_eq_at _ _ _ _,
    intro n,
    symmetry,
    exact h n, },
end

def agree_struct.rel {α : Type u} [ofe α] (a b : agree_struct α) : Prop :=
∀ n, agree_struct.eq_at n a b

lemma agree_struct.rel_reflexive {α : Type u} [ofe α] :
  reflexive (agree_struct.rel : agree_struct α → agree_struct α → Prop) :=
λ a n, agree_struct.eq_at_reflexive n a

@[refl] lemma agree_struct.rel_refl {α : Type u} [ofe α] (a : agree_struct α) :
  agree_struct.rel a a := agree_struct.rel_reflexive a

lemma agree_struct.rel_symmetric {α : Type u} [ofe α] :
  symmetric (agree_struct.rel : agree_struct α → agree_struct α → Prop) :=
λ a b hab n, agree_struct.eq_at_symmetric n (hab n)

@[symm] lemma agree_struct.rel_symm {α : Type u} [ofe α] (a b : agree_struct α) :
  agree_struct.rel a b → agree_struct.rel b a := λ h, agree_struct.rel_symmetric h

lemma agree_struct.rel_transitive {α : Type u} [ofe α] :
  transitive (agree_struct.rel : agree_struct α → agree_struct α → Prop) :=
λ a b c hab hbc n, agree_struct.eq_at_transitive n (hab n) (hbc n)

@[trans] lemma agree_struct.rel_trans {α : Type u} [ofe α] (a b c : agree_struct α) :
  agree_struct.rel a b → agree_struct.rel b c → agree_struct.rel a c :=
λ h₁ h₂, agree_struct.rel_transitive h₁ h₂

lemma agree_struct.rel_equivalence {α : Type u} [ofe α] :
  equivalence (agree_struct.rel : agree_struct α → agree_struct α → Prop) :=
⟨agree_struct.rel_reflexive, agree_struct.rel_symmetric, agree_struct.rel_transitive⟩

instance {α : Type u} [ofe α] : setoid (agree_struct α) :=
⟨agree_struct.rel, agree_struct.rel_equivalence⟩

def agree (α : Type u) [ofe α] : Type u := quotient (agree_struct.setoid : setoid (agree_struct α))

lemma agree_struct.eq_at_respects_rel {α : Type u} [ofe α] (n : ℕ) (a₁ a₂ b₁ b₂ : agree_struct α) :
  a₁ ≈ b₁ → a₂ ≈ b₂ → agree_struct.eq_at n a₁ a₂ = agree_struct.eq_at n b₁ b₂ :=
begin
  intros h₁ h₂,
  ext1,
  split; intro h,
  { transitivity a₁,
    { symmetry, exact h₁ n, },
    transitivity a₂,
    { exact h, },
    { exact h₂ n, }, },
  { transitivity b₁,
    { exact h₁ n, },
    transitivity b₂,
    { exact h, },
    { symmetry, exact h₂ n, }, },
end

def agree.eq_at {α : Type u} [ofe α] (n : ℕ) : agree α → agree α → Prop :=
quotient.lift₂ (agree_struct.eq_at n) (agree_struct.eq_at_respects_rel n)

private lemma agree.eq_at_reflexive {α : Type u} [ofe α] (n : ℕ) :
  reflexive (agree.eq_at n : agree α → agree α → Prop) :=
begin
  intro a, refine quotient.induction_on a _, clear a, intro a,
  simp only [agree.eq_at, quotient.lift₂_mk],
end

private lemma agree.eq_at_symmetric {α : Type u} [ofe α] (n : ℕ) :
  symmetric (agree.eq_at n : agree α → agree α → Prop) :=
begin
  intros a b, refine quotient.induction_on₂ a b _, clear a b, intros a b,
  simp only [agree.eq_at, quotient.lift₂_mk],
  intro h, symmetry, exact h,
end

private lemma agree.eq_at_transitive {α : Type u} [ofe α] (n : ℕ) :
  transitive (agree.eq_at n : agree α → agree α → Prop) :=
begin
  intros a b c, refine quotient.induction_on₃ a b c _, clear a b c, intros a b c,
  simp only [agree.eq_at, quotient.lift₂_mk],
  intros h₁ h₂, transitivity b; assumption,
end

private lemma agree.eq_at_mono {α : Type u} [ofe α] :
  antitone (agree.eq_at : ℕ → agree α → agree α → Prop) :=
begin
  intros m n hmn a b,
  refine quotient.induction_on₂ a b _, clear a b, intros a b,
  simp only [agree.eq_at, quotient.lift₂_mk],
  exact agree_struct.eq_at_mono hmn a b,
end

private lemma agree.eq_at_limit {α : Type u} [ofe α] (a b : agree α) :
  (∀ (n : ℕ), agree.eq_at n a b) → a = b :=
begin
  refine quotient.induction_on₂ a b _, clear a b, intros a b,
  intros h,
  refine quotient.sound _,
  intro n,
  rw agree_struct.eq_at_limit a b h,
end

instance agree.ofe (α : Type u) [ofe α] : ofe (agree α) := {
  eq_at := agree.eq_at,
  eq_at_reflexive := agree.eq_at_reflexive,
  eq_at_symmetric := agree.eq_at_symmetric,
  eq_at_transitive := agree.eq_at_transitive,
  eq_at_mono' := agree.eq_at_mono,
  eq_at_limit' := agree.eq_at_limit,
}

@[simp] lemma agree.eq_at_mk' {α : Type u} [ofe α] (n : ℕ) (a b : agree_struct α) :
  agree.eq_at n ⟦a⟧ ⟦b⟧ ↔ agree_struct.eq_at n a b := iff.rfl

@[simp] lemma agree.eq_at_mk {α : Type u} [ofe α] (n : ℕ) (a b : agree_struct α) :
  (@ofe.eq_at (agree α) _ n ⟦a⟧ ⟦b⟧) ↔ agree_struct.eq_at n a b := iff.rfl

instance agree_struct.comm_semigroup (α : Type u) [ofe α] [decidable_eq α] :
  comm_semigroup (agree_struct α) := {
  mul := λ a b, ⟨a.elts ∪ b.elts, begin
    rw [← finset.coe_nonempty, finset.coe_union, set.union_nonempty, finset.coe_nonempty],
    exact or.inl a.nonempty,
  end⟩,
  mul_assoc := begin
    intros a b c,
    ext x,
    simp only [finset.union_assoc],
  end,
  mul_comm := begin
    intros a b,
    ext x,
    simp only [has_mul.mul, finset.mem_union],
    exact or.comm,
  end,
}

@[simp] lemma agree_struct.mul_elts {α : Type u} [ofe α] [decidable_eq α]
  (a b : agree_struct α) : (a * b).elts = a.elts ∪ b.elts := rfl

@[simp] lemma agree_struct.mem_mul {α : Type u} [ofe α] [decidable_eq α]
  (x : α) (a b : agree_struct α) : x ∈ a * b ↔ x ∈ a ∨ x ∈ b :=
begin
  rw [← agree_struct.has_mem_iff, agree_struct.mul_elts, finset.mem_union],
  refl,
end

lemma agree_struct.eq_at_mul {α : Type u} [ofe α] [decidable_eq α]
  {n : ℕ} (a b c d : agree_struct α) :
  agree_struct.eq_at n a b → agree_struct.eq_at n c d → agree_struct.eq_at n (a * c) (b * d) :=
begin
  intros ha hb,
  split,
  { intros x hx,
    rw agree_struct.mem_mul at hx,
    cases hx,
    { obtain ⟨y, hy₁, hy₂⟩ := ha.left x hx,
      refine ⟨y, _, hy₂⟩,
      rw agree_struct.mem_mul,
      exact or.inl hy₁, },
    { obtain ⟨y, hy₁, hy₂⟩ := hb.left x hx,
      refine ⟨y, _, hy₂⟩,
      rw agree_struct.mem_mul,
      exact or.inr hy₁, }, },
  { intros x hx,
    rw agree_struct.mem_mul at hx,
    cases hx,
    { obtain ⟨y, hy₁, hy₂⟩ := ha.right x hx,
      refine ⟨y, _, hy₂⟩,
      rw agree_struct.mem_mul,
      exact or.inl hy₁, },
    { obtain ⟨y, hy₁, hy₂⟩ := hb.right x hx,
      refine ⟨y, _, hy₂⟩,
      rw agree_struct.mem_mul,
      exact or.inr hy₁, }, },
end

lemma agree_struct.mul_respects_rel {α : Type u} [ofe α] [decidable_eq α]
  (a₁ a₂ b₁ b₂ : agree_struct α) : a₁ ≈ b₁ → a₂ ≈ b₂ → ⟦a₁ * a₂⟧ = ⟦b₁ * b₂⟧ :=
λ ha hb, quotient.sound (λ n, agree_struct.eq_at_mul a₁ b₁ a₂ b₂ (ha n) (hb n))

instance agree.comm_semigroup (α : Type u) [ofe α] [decidable_eq α] : comm_semigroup (agree α) := {
  mul := quotient.lift₂ (λ a b, ⟦a * b⟧) agree_struct.mul_respects_rel,
  mul_assoc := begin
    intros a b c, refine quotient.induction_on₃ a b c _, clear a b c, intros a b c,
    refine quotient.sound _,
    rw mul_assoc,
    exact setoid.refl _,
  end,
  mul_comm := begin
    intros a b, refine quotient.induction_on₂ a b _, clear a b, intros a b,
    refine quotient.sound _,
    rw mul_comm,
    exact setoid.refl _,
  end,
}

@[simp] lemma agree_struct.mul_self {α : Type u} [ofe α] [decidable_eq α] (a : agree_struct α) :
  a * a = a :=
by ext; rw [agree_struct.mul_elts, finset.union_idempotent]

@[simp] lemma agree.mul_self {α : Type u} [ofe α] [decidable_eq α] (a : agree α) :
  a * a = a :=
begin
  refine quotient.induction_on a _, clear a, intro a,
  refine quotient.sound _,
  rw agree_struct.mul_self,
  exact setoid.refl _,
end

@[simp] lemma agree_struct.mul_mk {α : Type u} [ofe α] [decidable_eq α]
  (a b : agree_struct α) : @has_mul.mul (agree α) _ ⟦a⟧ ⟦b⟧ = ⟦a * b⟧ := rfl

def agree_struct.validn {α : Type u} [ofe α] (a : agree_struct α) : sprop :=
⟨λ n, ∀ x y ∈ a, x =[n] y, λ m n hmn h x hx y hy, eq_at_mono hmn (h x hx y hy)⟩

lemma agree_struct.validn_mul {α : Type u} [ofe α] [decidable_eq α] (a b : agree_struct α) :
  agree_struct.validn (a * b) ≤ agree_struct.validn a :=
begin
  intros n h x hx y hy,
  refine h x _ y _;
  rw agree_struct.mem_mul;
  exact or.inl ‹_›,
end

lemma agree_struct.validn_respects_rel {α : Type u} [ofe α] (a b : agree_struct α) :
  a ≈ b → a.validn = b.validn :=
begin
  intro hab,
  ext n,
  split,
  { intros h x hx y hy,
    obtain ⟨z, hz₁, hz₂⟩ := (hab n).right x hx,
    obtain ⟨w, hw₁, hw₂⟩ := (hab n).right y hy,
    have := h z hz₁ w hw₁,
    symmetry' at hz₂,
    transitivity, assumption, transitivity; assumption, },
  { intros h x hx y hy,
    obtain ⟨z, hz₁, hz₂⟩ := (hab n).left x hx,
    obtain ⟨w, hw₁, hw₂⟩ := (hab n).left y hy,
    have := h z hz₁ w hw₁,
    symmetry' at hw₂,
    transitivity, assumption, transitivity; assumption, },
end

def agree.validn {α : Type u} [ofe α] : agree α → sprop :=
quotient.lift agree_struct.validn agree_struct.validn_respects_rel

@[simp] lemma agree.validn_mk {α : Type u} [ofe α] (a : agree_struct α) :
  agree.validn ⟦a⟧ = a.validn := rfl

lemma agree.validn_is_nonexpansive {α : Type u} [ofe α] :
  is_nonexpansive (agree.validn : agree α → sprop) :=
begin
  intros n a b, refine quotient.induction_on₂ a b _, clear a b, intros a b,
  intros h m hmn,
  rw [agree.validn_mk, agree.validn_mk],
  rw agree.eq_at_mk at h,
  split,
  { intros hm x hx y hy,
    obtain ⟨z, hz₁, hz₂⟩ := h.right x hx,
    obtain ⟨w, hw₁, hw₂⟩ := h.right y hy,
    have hz₃ := eq_at_mono hmn hz₂,
    have hw₃ := eq_at_mono hmn hw₂,
    have := hm z hz₁ w hw₁,
    symmetry' at hz₃,
    transitivity, assumption, transitivity; assumption, },
  { intros hm x hx y hy,
    obtain ⟨z, hz₁, hz₂⟩ := h.left x hx,
    obtain ⟨w, hw₁, hw₂⟩ := h.left y hy,
    have hz₃ := eq_at_mono hmn hz₂,
    have hw₃ := eq_at_mono hmn hw₂,
    have := hm z hz₁ w hw₁,
    symmetry' at hw₃,
    transitivity, assumption, transitivity; assumption, },
end

instance agree_struct.decidable_exists_mem {α : Type u} [ofe α] [decidable_eq α] [decidable_eq_at α]
  {n : ℕ} {a : agree_struct α} {x : α} : decidable (∃ y ∈ a, x =[n] y) :=
begin
  refine decidable_of_decidable_of_iff _ _,
  exact (finset.filter (λ y, x =[n] y) a.elts).nonempty,
  { apply_instance, },
  split,
  { rintro ⟨y, hy⟩,
    simp only [finset.mem_filter, agree_struct.has_mem_iff] at hy,
    exact ⟨y, hy.1, hy.2⟩, },
  { rintro ⟨y, hy₁, hy₂⟩,
    refine ⟨y, _⟩,
    simp only [finset.mem_filter, agree_struct.has_mem_iff],
    exact ⟨hy₁, hy₂⟩, },
end

/-- Keeps those elements of `a` that have an element of `b` that it is `n`-equal to. -/
def agree_struct.filter_eq {α : Type u} [ofe α] [decidable_eq α] [decidable_eq_at α]
  (a b : agree_struct α) (n : ℕ) (h : ∃ x ∈ a, ∃ y ∈ b, x =[n] y) : agree_struct α :=
⟨finset.filter (λ x, ∃ y ∈ b, x =[n] y) a.elts, begin
  obtain ⟨x, hx, y, hy, h⟩ := h,
  refine ⟨x, _⟩,
  simp only [finset.mem_filter, agree_struct.has_mem_iff],
  exact ⟨hx, y, hy, h⟩,
end⟩

@[simp] lemma agree_struct.mem_filter_eq {α : Type u} [ofe α] [decidable_eq α] [decidable_eq_at α]
  (x : α) (a b : agree_struct α) (n : ℕ) (h : ∃ x ∈ a, ∃ y ∈ b, x =[n] y) :
  x ∈ a.filter_eq b n h ↔ x ∈ a ∧ ∃ y ∈ b, x =[n] y :=
by simp only [agree_struct.filter_eq, agree_struct.mem_mk,
  finset.mem_filter, agree_struct.has_mem_iff]

lemma agree_struct.exists_eq_at_of_mul_eq_at {α : Type u} [ofe α] [decidable_eq α] [decidable_eq_at α]
  {n : ℕ} {a b₁ b₂ : agree_struct α} (hb : agree_struct.eq_at n a (b₁ * b₂)) :
    ∃ x ∈ a, ∃ y ∈ b₁, x =[n] y :=
begin
  obtain ⟨y, hy⟩ := b₁.nonempty,
  obtain ⟨x, hx₁, hx₂⟩ := hb.right y _,
  refine ⟨x, hx₁, y, hy, hx₂⟩,
  rw agree_struct.mem_mul,
  exact or.inl hy,
end

lemma agree_struct.exists_eq_at_of_mul_eq_at' {α : Type u} [ofe α] [decidable_eq α] [decidable_eq_at α]
  {n : ℕ} {a b₁ b₂ : agree_struct α} (hb : agree_struct.eq_at n a (b₁ * b₂)) :
    ∃ x ∈ a, ∃ y ∈ b₂, x =[n] y :=
begin
  refine agree_struct.exists_eq_at_of_mul_eq_at _,
  exact b₁,
  rw mul_comm,
  exact hb,
end

def agree_struct.extend {α : Type u} [ofe α] [decidable_eq α] [decidable_eq_at α]
  {n : ℕ} {a b₁ b₂ : agree_struct α} (hb : agree_struct.eq_at n a (b₁ * b₂)) :
    agree_struct α × agree_struct α :=
⟨a.filter_eq b₁ n (agree_struct.exists_eq_at_of_mul_eq_at hb),
  a.filter_eq b₂ n (agree_struct.exists_eq_at_of_mul_eq_at' hb)⟩

lemma agree_struct.extend_mul_eq {α : Type u} [ofe α] [decidable_eq α] [decidable_eq_at α]
  {n : ℕ} {a b₁ b₂ : agree_struct α} (hb : agree_struct.eq_at n a (b₁ * b₂)) :
    a = (agree_struct.extend hb).1 * (agree_struct.extend hb).2 :=
begin
  unfold agree_struct.extend,
  ext x,
  simp only [agree_struct.has_mem_iff, agree_struct.mul_elts, finset.mem_union,
    agree_struct.mem_filter_eq, exists_prop],
  split,
  { intro hx,
    obtain ⟨y, hy₁, hy₂⟩ := hb.left x hx,
    rw agree_struct.mem_mul at hy₁,
    cases hy₁,
    exact or.inl ⟨hx, y, hy₁, hy₂⟩,
    exact or.inr ⟨hx, y, hy₁, hy₂⟩, },
  { rintro (hx | hx);
    exact hx.1, },
end

lemma agree_struct.extend_eq_at_left {α : Type u} [ofe α] [decidable_eq α] [decidable_eq_at α]
  {n : ℕ} {a b₁ b₂ : agree_struct α}
  (ha : agree_struct.validn a n) (hb : agree_struct.eq_at n a (b₁ * b₂)) :
    agree_struct.eq_at n (agree_struct.extend hb).1 b₁ :=
begin
  unfold agree_struct.extend,
  split,
  { intros x hx,
    rw agree_struct.mem_filter_eq at hx,
    obtain ⟨hx, y, hy₁, hy₂⟩ := hx,
    exact ⟨y, hy₁, hy₂⟩, },
  { intros x hx,
    obtain ⟨y, hy₁, hy₂⟩ := hb.right x _,
    refine ⟨y, _, hy₂⟩,
    rw agree_struct.mem_filter_eq,
    exact ⟨hy₁, x, hx, hy₂⟩,
    rw agree_struct.mem_mul,
    exact or.inl hx, },
end

lemma agree_struct.extend_eq_at_right {α : Type u} [ofe α] [decidable_eq α] [decidable_eq_at α]
  {n : ℕ} {a b₁ b₂ : agree_struct α}
  (ha : agree_struct.validn a n) (hb : agree_struct.eq_at n a (b₁ * b₂)) :
    agree_struct.eq_at n (agree_struct.extend hb).2 b₂ :=
begin
  unfold agree_struct.extend,
  split,
  { intros x hx,
    rw agree_struct.mem_filter_eq at hx,
    obtain ⟨hx, y, hy₁, hy₂⟩ := hx,
    exact ⟨y, hy₁, hy₂⟩, },
  { intros x hx,
    obtain ⟨y, hy₁, hy₂⟩ := hb.right x _,
    refine ⟨y, _, hy₂⟩,
    rw agree_struct.mem_filter_eq,
    exact ⟨hy₁, x, hx, hy₂⟩,
    rw agree_struct.mem_mul,
    exact or.inr hx, },
end

attribute [reducible, elab_as_eliminator]
protected def quotient.dlift {α : Sort u} [s : setoid α] {φ : quotient s → Sort v}
  (f : Π (a : α), φ ⟦a⟧) (c : ∀ a b, a ≈ b → f a == f b)
  (q : quotient s) : φ q :=
begin
  refine quotient.rec f _ q,
  intros a b h,
  have := c a b h,
  cc,
end

@[simp] lemma quotient.dlift_mk {α : Sort u} [s : setoid α] {φ : quotient s → Sort v}
  (f : Π (a : α), φ ⟦a⟧) (c : ∀ a b, a ≈ b → f a == f b) (q : α) :
  (quotient.dlift f c ⟦q⟧ : φ ⟦q⟧) = f q := rfl

attribute [reducible, elab_as_eliminator]
protected def quotient.dlift₂ {α β : Sort*} [s₁ : setoid α] [s₂ : setoid β]
  {φ : quotient s₁ → quotient s₂ → Sort*}
  (f : Π (a : α) (b : β), φ ⟦a⟧ ⟦b⟧) (c : ∀ a₁ a₂ b₁ b₂, a₁ ≈ b₁ → a₂ ≈ b₂ → f a₁ a₂ == f b₁ b₂)
  (q₁ : quotient s₁) (q₂ : quotient s₂) : φ q₁ q₂ :=
begin
  refine quotient.dlift (λ a, quotient.dlift (λ b, f a b) _ q₂) _ q₁,
  { intros b₁ b₂ hb,
    exact c a b₁ a b₂ (setoid.refl a) hb, },
  { intros b₁ b₂ hb,
    refine quotient.induction_on q₂ _, clear q₂, intro q₂,
    rw [quotient.dlift_mk, quotient.dlift_mk],
    exact c b₁ q₂ b₂ q₂ hb (setoid.refl q₂), },
end

@[simp] lemma quotient.dlift₂_mk {α β : Sort*} [s₁ : setoid α] [s₂ : setoid β]
  {φ : quotient s₁ → quotient s₂ → Sort u}
  (f : Π (a : α) (b : β), φ ⟦a⟧ ⟦b⟧) (c : ∀ a₁ a₂ b₁ b₂, a₁ ≈ b₁ → a₂ ≈ b₂ → f a₁ a₂ == f b₁ b₂)
  (q₁ : α) (q₂ : β) : (quotient.dlift₂ f c ⟦q₁⟧ ⟦q₂⟧ : φ ⟦q₁⟧ ⟦q₂⟧) = f q₁ q₂ := rfl

attribute [reducible, elab_as_eliminator]
protected def quotient.dlift₃ {α β γ : Sort*} [s₁ : setoid α] [s₂ : setoid β] [s₃ : setoid γ]
  {φ : quotient s₁ → quotient s₂ → quotient s₃ → Sort*}
  (f : Π (a : α) (b : β) (c : γ), φ ⟦a⟧ ⟦b⟧ ⟦c⟧)
  (c : ∀ a₁ a₂ a₃ b₁ b₂ b₃, a₁ ≈ b₁ → a₂ ≈ b₂ → a₃ ≈ b₃ → f a₁ a₂ a₃ == f b₁ b₂ b₃)
  (q₁ : quotient s₁) (q₂ : quotient s₂) (q₃ : quotient s₃) : φ q₁ q₂ q₃ :=
begin
  refine quotient.dlift (λ a, quotient.dlift₂ (λ b c, f a b c) _ q₂ q₃) _ q₁,
  { intros a₂ a₃ b₂ b₃ h₂ h₃,
    exact c a a₂ a₃ a b₂ b₃ (setoid.refl a) h₂ h₃, },
  { intros b₁ b₂ hb,
    refine quotient.induction_on₂ q₂ q₃ _, clear q₂ q₃, intros q₂ q₃,
    simp only [quotient.dlift₂_mk],
    exact c b₁ q₂ q₃ b₂ q₂ q₃ hb (setoid.refl q₂) (setoid.refl q₃), },
end

@[simp] lemma quotient.dlift₃_mk {α β γ : Sort*} [s₁ : setoid α] [s₂ : setoid β] [s₃ : setoid γ]
  {φ : quotient s₁ → quotient s₂ → quotient s₃ → Sort*}
  (f : Π (a : α) (b : β) (c : γ), φ ⟦a⟧ ⟦b⟧ ⟦c⟧)
  (c : ∀ a₁ a₂ a₃ b₁ b₂ b₃, a₁ ≈ b₁ → a₂ ≈ b₂ → a₃ ≈ b₃ → f a₁ a₂ a₃ == f b₁ b₂ b₃)
  (q₁ : α) (q₂ : β) (q₃ : γ) :
    (quotient.dlift₃ f c ⟦q₁⟧ ⟦q₂⟧ ⟦q₃⟧ : φ ⟦q₁⟧ ⟦q₂⟧ ⟦q₃⟧) = f q₁ q₂ q₃ := rfl

attribute [reducible, elab_as_eliminator]
protected def quotient.lift₃ {α β γ φ : Sort*} [s₁ : setoid α] [s₂ : setoid β] [s₃ : setoid γ]
  (f : α → β → γ → φ) (c : ∀ a₁ a₂ a₃ b₁ b₂ b₃, a₁ ≈ b₁ → a₂ ≈ b₂ → a₃ ≈ b₃ → f a₁ a₂ a₃ = f b₁ b₂ b₃)
  (q₁ : quotient s₁) (q₂ : quotient s₂) (q₃ : quotient s₃) : φ :=
begin
  refine quotient.lift (λ a₁, quotient.lift₂ (f a₁) _ q₂ q₃) _ q₁,
  { intros a₂ a₃ b₂ b₃ h₂ h₃,
    exact c a₁ a₂ a₃ a₁ b₂ b₃ (setoid.refl a₁) h₂ h₃, },
  { intros a b h,
    refine quotient.induction_on₂ q₂ q₃ _, clear q₂ q₃, intros q₂ q₃,
    exact c a q₂ q₃ b q₂ q₃ h (setoid.refl q₂) (setoid.refl q₃), },
end

lemma agree.filter_eq_exists_mem {α : Type u} {n m : ℕ} [ofe α] [decidable_eq α] [decidable_eq_at α]
  {a₁ a₂ b₁ b₂ : agree_struct α} (h₁ : a₁ ≈ b₁) (h₂ : a₂ ≈ b₂)
  (b : ∃ x ∈ a₁, ∃ y ∈ a₂, x =[n] y) (b' : ∃ x ∈ b₁, ∃ y ∈ b₂, x =[n] y) :
  ∀ x ∈ a₁.filter_eq a₂ n b, ∃ y ∈ b₁.filter_eq b₂ n b', x =[m] y :=
begin
  intros x hx,
  simp only [agree_struct.mem_filter_eq, exists_prop] at hx ⊢,
  obtain ⟨hx, z, hz₁, hz₂⟩ := hx,
  obtain ⟨y, hy₁, hy₂⟩ := (h₁ (max m n)).left x hx,
  rw eq_at_max at hy₂,
  obtain ⟨w, hw₁, hw₂⟩ := (h₂ n).left z hz₁,
  refine ⟨y, _, hy₂.1⟩,
  refine ⟨hy₁, _⟩,
  refine ⟨w, hw₁, _⟩,
  transitivity x, exact eq_at_symmetric n hy₂.2,
  transitivity; assumption,
end

lemma agree.filter_eq_exists_mem' {α : Type u} {n m : ℕ} [ofe α] [decidable_eq α] [decidable_eq_at α]
  {a₁ a₂ b₁ b₂ : agree_struct α} (h₁ : b₁ ≈ a₁) (h₂ : b₂ ≈ a₂)
  (b : ∃ x ∈ a₁, ∃ y ∈ a₂, x =[n] y) (b' : ∃ x ∈ b₁, ∃ y ∈ b₂, x =[n] y) :
  ∀ x ∈ a₁.filter_eq a₂ n b, ∃ y ∈ b₁.filter_eq b₂ n b', y =[m] x :=
begin
  intros,
  obtain ⟨y, hy₁, hy₂⟩ := agree.filter_eq_exists_mem (setoid.symm h₁) (setoid.symm h₂) b b' x ‹_›,
  refine ⟨y, hy₁, _⟩,
  symmetry,
  assumption,
end

def agree.extend {α : Type u} [ofe α] [decidable_eq α] [decidable_eq_at α]
  {n : ℕ} : Π {a b₁ b₂ : agree α}, agree.validn a n → a =[n] b₁ * b₂ → agree α × agree α :=
begin
  refine quotient.dlift₃ _ _,
  { intros a b c h₁ h₂,
    exact prod.map quotient.mk quotient.mk (agree_struct.extend h₂), },
  { intros a₁ a₂ a₃ b₁ b₂ b₃ h₁ h₂ h₃,
    ext,
    { rw quotient.sound h₁, },
    intros a a' haa',
    ext,
    { rw [quotient.sound h₁, quotient.sound h₂, quotient.sound h₃], },
    intros b b' hbb',
    simp only [prod_map, heq_iff_eq, prod.mk.inj_iff, quotient.eq],
    split; intro; split,
    { apply agree.filter_eq_exists_mem; assumption, },
    { apply agree.filter_eq_exists_mem'; assumption, },
    { apply agree.filter_eq_exists_mem; assumption, },
    { apply agree.filter_eq_exists_mem'; assumption, }, },
end

lemma agree.extend_mul_eq {α : Type u} [ofe α] [decidable_eq α] [decidable_eq_at α]
  {n : ℕ} {a b₁ b₂ : agree α} (ha : agree.validn a n) (hb : agree.eq_at n a (b₁ * b₂)) :
    a = (agree.extend ha hb).1 * (agree.extend ha hb).2 :=
begin
  revert ha hb,
  refine quotient.induction_on₃ a b₁ b₂ _, clear a b₁ b₂, intros a b₁ b₂,
  intros ha hb,
  refine quotient.sound _,
  rw ← agree_struct.extend_mul_eq hb,
  exact setoid.refl a,
end

lemma agree.extend_eq_at_left {α : Type u} [ofe α] [decidable_eq α] [decidable_eq_at α]
  {n : ℕ} {a b₁ b₂ : agree α} (ha : agree.validn a n) (hb : agree.eq_at n a (b₁ * b₂)) :
    agree.eq_at n (agree.extend ha hb).1 b₁ :=
begin
  revert ha hb,
  refine quotient.induction_on₃ a b₁ b₂ _, clear a b₁ b₂, intros a b₁ b₂,
  intros ha hb,
  exact agree_struct.extend_eq_at_left ha hb,
end

lemma agree.extend_eq_at_right {α : Type u} [ofe α] [decidable_eq α] [decidable_eq_at α]
  {n : ℕ} {a b₁ b₂ : agree α} (ha : agree.validn a n) (hb : agree.eq_at n a (b₁ * b₂)) :
    agree.eq_at n (agree.extend ha hb).2 b₂ :=
begin
  revert ha hb,
  refine quotient.induction_on₃ a b₁ b₂ _, clear a b₁ b₂, intros a b₁ b₂,
  intros ha hb,
  exact agree_struct.extend_eq_at_right ha hb,
end

lemma agree.mul_is_nonexpansive {α : Type u} [ofe α] [decidable_eq α] :
  is_nonexpansive (function.uncurry ((*) : agree α → agree α → agree α)) :=
begin
  rintros n ⟨a₁, a₂⟩ ⟨b₁, b₂⟩,
  refine quotient.induction_on₂ a₁ a₂ _, clear a₁ a₂, intros a₁ a₂,
  refine quotient.induction_on₂ b₁ b₂ _, clear b₁ b₂, intros b₁ b₂,
  simp only [prod.eq_at, agree.eq_at_mk, function.uncurry_apply_pair, agree_struct.mul_mk, and_imp],
  intros h₁ h₂,
  exact agree_struct.eq_at_mul a₁ b₁ a₂ b₂ h₁ h₂,
end

lemma agree.validn_mul {α : Type u} [ofe α] [decidable_eq α] (a b : agree α) :
  agree.validn (a * b) ≤ agree.validn a :=
begin
  refine quotient.induction_on₂ a b _, clear a b, intros a b,
  intros n h,
  simp only [agree_struct.mul_mk, agree.validn_mk] at h ⊢,
  exact agree_struct.validn_mul a b n h,
end

instance agree.camera (α : Type u) [ofe α] [decidable_eq α] [decidable_eq_at α] :
  camera (agree α) := {
  validn := ⟨agree.validn, agree.validn_is_nonexpansive⟩,
  core := ⟨some, option.some_is_nonexpansive⟩,
  extend := @agree.extend _ _ _ _,
  mul_is_nonexpansive := agree.mul_is_nonexpansive,
  extend_mul_eq := @agree.extend_mul_eq _ _ _ _,
  extend_eq_at_left := @agree.extend_eq_at_left _ _ _ _,
  extend_eq_at_right := @agree.extend_eq_at_right _ _ _ _,
  core_mul_self := begin
    intros a ca hca,
    cases hca,
    rw agree.mul_self,
  end,
  core_core := λ a ca hca, rfl,
  core_mono_some := λ a b ca hca h, ⟨b, rfl⟩,
  core_mono := λ a ca h₁ h₂ h₃,
    ⟨some h₃.some, by simp only [h₃.some_spec, nonexpansive_fun.coe_fn_mk, some_mul_some]⟩,
  validn_mul := agree.validn_mul,
  ..agree.ofe α,
  ..agree.comm_semigroup α,
}


import rigid_elements.valuation_subring_of_preadditive

variables {K : Type*} [field K] {T H : mul_subgroup K} (rp : rigid_pair T H)

open rigid_pair

-- Prop 2.12
lemma rigid_pair.preadditive_of_exists_UU (u : K)
  (hu : u ∈ rp.UU) (hu' : u ∉ T) : rp.preadditive :=
begin
  rw preadditive_iff,
  intros x y hx hy,
  by_cases hxz : -x = 0, { rw neg_eq_zero at hxz, simp [hxz, T.one_mem] },
  have H1 := rp.neg _ hx.1 (1 + x) (1 + y) hx.2 hy.2 hxz,
  have hxu : u⁻¹ * x ∈ rp.OO_m,
  { apply hu.2.2, assumption },
  have huy : u * y ∈ rp.OO_m,
  { apply hu.1.2, assumption },
  have z1 : - (x * u) ≠ 0,
  { simp only [ne.def, neg_eq_zero, mul_eq_zero, inv_eq_zero],
    push_neg, split, swap,
    { apply rp.UU_ne_zero_of_mem u hu },
    { simpa using hxz } },
  have H2 := rp.neg _ hxu.1 _ _ hxu.2 huy.2 _,
  cases H1; cases H2,
  { convert H1, ring },
  { convert H1, ring },
  { convert H2,
    field_simp [rp.UU_ne_zero_of_mem u hu], ring },
  { exfalso,
    have := T.mul_mem (T.inv_mem H1) H2,
    apply hu', convert this,
    have aux : ((-(u⁻¹ * x))⁻¹ * (1 + u⁻¹ * x) + (1 + u * y)) =
      u * ((-x)⁻¹ * (1 + x) + (1 + y)),
    field_simp [rp.UU_ne_zero_of_mem u hu], ring,
    rw [aux, ← mul_assoc, mul_comm _ u, mul_assoc, inv_mul_cancel, mul_one],
    exact T.ne_zero_of_mem H1 },
  simp only [ne.def, neg_eq_zero, mul_eq_zero, inv_eq_zero],
  push_neg, split, exact rp.UU_ne_zero_of_mem u hu, simpa using hxz,
end

-- Lemma 2.13
lemma rigid_pair.OO_p_mem_of_mem_nmem_nmem (u : K) :
  u ∈ H → u ∉ T → 1 - u⁻¹ ∉ T → u ∈ rp.OO_p :=
begin
  intros h1 h2 h3,
  by_cases hu : u - 1 = 0,
  { rw sub_eq_zero at hu, rw hu, apply rp.OO_p_one_mem },
  have : u - 1 ∈ H,
  { by_contra c, have := rp.pos _ c 1 1 T.one_mem T.one_mem hu,
  cases this, { apply h2, convert this, ring },
  apply h3,
  rw ← inv_inv (1 - u⁻¹), apply T.inv_mem,
  convert this, field_simp [H.ne_zero_of_mem h1] },
  refine ⟨h1, _⟩, intros x hx,
  have hux : u * x ∉ H,
  { intro c, apply hx.1, convert H.mul_mem (H.inv_mem h1) c,
    field_simp [H.ne_zero_of_mem h1], ring },
  have hux' : (u - 1) * x ∉ H,
  { intro c, apply hx.1, convert H.mul_mem (H.inv_mem this) c,
    field_simp [H.ne_zero_of_mem this], ring },
  by_cases huxz : u * x = 0, { rw huxz, apply rp.OO_m_zero_mem },
  have aux1 := rp.pos _ hux 1 1 T.one_mem T.one_mem huxz,
  simp only [mul_one, mul_assoc] at aux1,
  by_cases huxz' : (u - 1) * x = 0,
  { rw [sub_mul, one_mul, sub_eq_zero] at huxz', rw huxz', exact hx },
  have aux2 := rp.pos _ hux' (1 + x) 1 hx.2 T.one_mem huxz',
  cases aux1; cases aux2,
  { exact ⟨hux, aux1⟩ },
  { exact ⟨hux, aux1⟩ },
  { refine ⟨hux, _⟩, convert aux2 using 1, ring },
  exfalso, apply h3,
  have : (1 - u⁻¹) * (((u - 1) * x)⁻¹ * (1 + x) + 1) =
    (u * x)⁻¹ + 1,
  { field_simp [H.ne_zero_of_mem h1], ring },
  convert T.mul_mem aux1 (T.inv_mem aux2), rw ← this,
  rw [mul_assoc, mul_inv_cancel, mul_one],
  apply T.ne_zero_of_mem aux2
end .

-- Prop 2.14
lemma rigid_pair.preadditive_of_nmem_of_neg_not_rigid (a : K) :
  a ≠ 0 →
  a ∉ T →
  ¬ (T.rigid (-a)) → rp.preadditive :=
begin
  intros ha haT nrig,
  have haH : a ∈ H,
  { by_contra c,
    apply nrig,
    exact rp.neg _ c },
  dsimp [mul_subgroup.rigid] at nrig,
  push_neg at nrig,
  obtain ⟨s,t,hs,ht,ha',h1,h2⟩ := nrig,
  let z : K := s⁻¹ * t,
  have hz : z ∈ T := T.mul_mem (T.inv_mem hs) ht,
  replace h1 : (1 : K) - a * z ∉ T,
  { intros c, apply h1, convert T.mul_mem hs c, dsimp [z],
    field_simp [T.ne_zero_of_mem hs], ring },
  replace h2 : z - a⁻¹ ∉ T,
  { intros c, apply h2, convert T.mul_mem hs c, dsimp [z],
    field_simp [T.ne_zero_of_mem hs, H.ne_zero_of_mem haH], ring },
  let u := a * z,
  have huT : u ∉ T,
  { intros c, apply haT, dsimp [u,z] at c,
    convert T.mul_mem (T.mul_mem c hs) (T.inv_mem ht),
    field_simp [T.ne_zero_of_mem hs, T.ne_zero_of_mem ht] },
  have huH : u ∈ H,
  { dsimp [u,z],
    convert H.mul_mem haH (H.mul_mem (H.inv_mem _) _),
    exact rp.le hs, exact rp.le ht },
  have key : u ∈ rp.UU,
  { split,
    { apply rp.OO_p_mem_of_mem_nmem_nmem,
      assumption, assumption, dsimp [u], intros c, apply h2,
      convert T.mul_mem hz c,
      field_simp [H.ne_zero_of_mem haH, T.ne_zero_of_mem hz], ring },
    { apply rp.OO_p_mem_of_mem_nmem_nmem,
      exact H.inv_mem huH, intros c, apply huT, convert T.inv_mem c, rw inv_inv,
      rw inv_inv, exact h1 } },
  exact rp.preadditive_of_exists_UU u key huT,
end


/-
Copyright (c) 2018 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl
-/
import measure_theory.measure.giry_monad
import category_theory.concrete_category.unbundled_hom
import category_theory.monad.algebra
import topology.category.Top.basic

/-!
# The category of measurable spaces

Measurable spaces and measurable functions form a (concrete) category `Meas`.

## Main definitions

* `Measure : Meas ⥤ Meas`: the functor which sends a measurable space `X`
to the space of measures on `X`; it is a monad (the "Giry monad").

* `Borel : Top ⥤ Meas`: sends a topological space `X` to `X` equipped with the
`σ`-algebra of Borel sets (the `σ`-algebra generated by the open subsets of `X`).

## Tags

measurable space, giry monad, borel
-/

noncomputable theory

open category_theory measure_theory
open_locale ennreal
universes u v

/-- The category of measurable spaces and measurable functions. -/
def Meas : Type (u+1) := bundled measurable_space

namespace Meas

instance : has_coe_to_sort Meas Type* := bundled.has_coe_to_sort
instance (X : Meas) : measurable_space X := X.str

/-- Construct a bundled `Meas` from the underlying type and the typeclass. -/
def of (α : Type u) [measurable_space α] : Meas := ⟨α⟩

@[simp] lemma coe_of (X : Type u) [measurable_space X] : (of X : Type u) = X := rfl

instance unbundled_hom : unbundled_hom @measurable := ⟨@measurable_id, @measurable.comp⟩

attribute [derive [large_category, concrete_category]] Meas

instance : inhabited Meas := ⟨Meas.of empty⟩

/-- `Measure X` is the measurable space of measures over the measurable space `X`. It is the
weakest measurable space, s.t. λμ, μ s is measurable for all measurable sets `s` in `X`. An
important purpose is to assign a monadic structure on it, the Giry monad. In the Giry monad,
the pure values are the Dirac measure, and the bind operation maps to the integral:
`(μ >>= ν) s = ∫ x. (ν x) s dμ`.

In probability theory, the `Meas`-morphisms `X → Prob X` are (sub-)Markov kernels (here `Prob` is
the restriction of `Measure` to (sub-)probability space.)
-/
def Measure : Meas ⥤ Meas :=
{ obj      := λX, ⟨@measure_theory.measure X.1 X.2⟩,
  map      := λX Y f, ⟨measure.map (f : X → Y), measure.measurable_map f f.2⟩,
  map_id'  := assume ⟨α, I⟩, subtype.eq $ funext $ assume μ, @measure.map_id α I μ,
  map_comp':=
    assume X Y Z ⟨f, hf⟩ ⟨g, hg⟩, subtype.eq $ funext $ assume μ, (measure.map_map hg hf).symm }

/-- The Giry monad, i.e. the monadic structure associated with `Measure`. -/
def Giry : category_theory.monad Meas :=
{ to_functor := Measure,
  η' :=
  { app         := λX, ⟨@measure.dirac X.1 X.2, measure.measurable_dirac⟩,
    naturality' :=
      assume X Y ⟨f, hf⟩, subtype.eq $ funext $ assume a, (measure.map_dirac hf a).symm },
  μ' :=
  { app         := λX, ⟨@measure.join X.1 X.2, measure.measurable_join⟩,
    naturality' :=
      assume X Y ⟨f, hf⟩, subtype.eq $ funext $ assume μ, measure.join_map_map hf μ },
  assoc' := assume α, subtype.eq $ funext $ assume μ, @measure.join_map_join _ _ _,
  left_unit' := assume α, subtype.eq $ funext $ assume μ, @measure.join_dirac _ _ _,
  right_unit' := assume α, subtype.eq $ funext $ assume μ, @measure.join_map_dirac _ _ _ }

/-- An example for an algebra on `Measure`: the nonnegative Lebesgue integral is a hom, behaving
nicely under the monad operations. -/
def Integral : Giry.algebra :=
{ A      := Meas.of ℝ≥0∞ ,
  a      := ⟨λm:measure ℝ≥0∞, ∫⁻ x, x ∂m, measure.measurable_lintegral measurable_id ⟩,
  unit'  := subtype.eq $ funext $ assume r:ℝ≥0∞, lintegral_dirac' _ measurable_id,
  assoc' := subtype.eq $ funext $ assume μ : measure (measure ℝ≥0∞),
    show ∫⁻ x, x ∂ μ.join = ∫⁻ x, x ∂ (measure.map (λm:measure ℝ≥0∞, ∫⁻ x, x ∂m) μ),
    by rw [measure.lintegral_join, lintegral_map];
      apply_rules [measurable_id, measure.measurable_lintegral] }

end Meas

instance Top.has_forget_to_Meas : has_forget₂ Top.{u} Meas.{u} :=
bundled_hom.mk_has_forget₂
  borel
  (λ X Y f, ⟨f.1, f.2.borel_measurable⟩)
  (by intros; refl)

/-- The Borel functor, the canonical embedding of topological spaces into measurable spaces. -/
@[reducible] def Borel : Top.{u} ⥤ Meas.{u} := forget₂ Top.{u} Meas.{u}


/-
Copyright (c) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Gabriel Ebner, Simon Hudon, Scott Morrison

! This file was ported from Lean 3 source module tactic.transport
! leanprover-community/mathlib commit 1f10390872a75359a9a42cd6d7644cc5e45660c2
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Tactic.EquivRw

/-!
## The `transport` tactic

`transport` attempts to move an `s : S α` expression across an equivalence `e : α ≃ β` to solve
a goal of the form `S β`, by building the new object field by field, taking each field of `s`
and rewriting it along `e` using the `equiv_rw` tactic.

We try to ensure good definitional properties, so that, for example, when we transport a `monoid α`
to a `monoid β`, the new multiplication is definitionally `λ x y, e (e.symm a * e.symm b)`.
-/

namespace Tactic

open Tactic.Interactive

/- failed to parenthesize: unknown constant 'Lean.Meta._root_.Lean.Parser.Command.registerSimpAttr'
[PrettyPrinter.parenthesize.input] (Lean.Meta._root_.Lean.Parser.Command.registerSimpAttr
     [(Command.docComment
       "/--"
       "The simpset `transport_simps` is used by the tactic `transport`\nto simplify certain expressions involving application of equivalences,\nand trivial `eq.rec` or `ep.mpr` conversions.\nIt's probably best not to adjust it without understanding the algorithm used by `transport`. -/")]
     "register_simp_attr"
     `transport_simps)-/-- failed to format: unknown constant 'Lean.Meta._root_.Lean.Parser.Command.registerSimpAttr'
/--
    The simpset `transport_simps` is used by the tactic `transport`
    to simplify certain expressions involving application of equivalences,
    and trivial `eq.rec` or `ep.mpr` conversions.
    It's probably best not to adjust it without understanding the algorithm used by `transport`. -/
  register_simp_attr
  transport_simps

attribute [transport_simps]
  eq_rec_constant eq_mp_eq_cast cast_eq Equiv.toFun_as_coe Equiv.arrowCongr'_apply Equiv.symm_apply_apply Equiv.apply_eq_iff_eq_symm_apply

/- ./././Mathport/Syntax/Translate/Expr.lean:330:4: warning: unsupported (TODO): `[tacs] -/
/- ./././Mathport/Syntax/Translate/Expr.lean:330:4: warning: unsupported (TODO): `[tacs] -/
-- failed to format: unknown constant 'term.pseudo.antiquot'
/--
      Given `s : S α` for some structure `S` depending on a type `α`,
      and an equivalence `e : α ≃ β`,
      try to produce an `S β`,
      by transporting data and axioms across `e` using `equiv_rw`.
      -/
    @[ nolint unused_arguments ]
    unsafe
  def
    transport
    ( s e : expr ) : tactic Unit
    :=
      do
        let
            ( _ , α , β )
              ←
              infer_type e >>= relation_lhs_rhs
                <|>
                fail f! "second argument to `transport` was not an equivalence-type relation"
          seq'
            sorry
              (
                propagate_tags
                  (
                    try
                      do
                        let f ← get_current_field
                          mk_mapp f [ α , none ] >>= note f none
                          let b ← target >>= is_prop
                          if
                            ¬ b
                            then
                            simp_result do equiv_rw_hyp f e get_local f >>= exact
                            else
                            try
                              do
                                try unfold_projs_target
                                  sorry
                                  try
                                    <|
                                    under_binders
                                      <|
                                      to_expr ` `( $ ( e ) . symm . Injective ) >>= apply
                                  equiv_rw_hyp f e
                                  get_local f >>= exact
                    )
                )
#align tactic.transport tactic.transport

namespace Interactive

/- ./././Mathport/Syntax/Translate/Tactic/Mathlib/Core.lean:38:34: unsupported: setup_tactic_parser -/
/-- Given a goal `⊢ S β` for some type class `S`, and an equivalence `e : α ≃ β`.
`transport using e` will look for a hypothesis `s : S α`,
and attempt to close the goal by transporting `s` across the equivalence `e`.

```lean
example {α : Type} [ring α] {β : Type} (e : α ≃ β) : ring β :=
by transport using e.
```

You can specify the object to transport using `transport s using e`.

`transport` works by attempting to copy each of the operations and axiom fields of `s`,
rewriting them using `equiv_rw e` and defining a new structure using these rewritten fields.

If it fails to fill in all the new fields, `transport` will produce new subgoals.
It's probably best to think about which missing `simp` lemmas would have allowed `transport`
to finish, rather than solving these goals by hand.
(This may require looking at the implementation of `tranport` to understand its algorithm;
there are several examples of "transport-by-hand" at the end of `test/equiv_rw.lean`,
which `transport` is an abstraction of.)
-/
unsafe def transport (s : parse texpr ?) (e : parse <| tk "using" *> texpr) : itactic := do
  let s ←
    match s with
      | some s => to_expr s
      | none =>
        (do
            let t ← target
            let n := t.get_app_fn.const_name
            let ctx ← local_context
            ctx fun e => do
                let t ← infer_type e
                guard (t = n)
                return e) <|>
          fail "`transport` could not find an appropriate source object. Try `transport s using e`."
  let e ← to_expr e
  tactic.transport s e
#align tactic.interactive.transport tactic.interactive.transport

add_tactic_doc
  { Name := "transport"
    category := DocCategory.tactic
    declNames := [`tactic.interactive.transport]
    tags := ["rewriting", "equiv", "transport"] }

end Interactive

end Tactic


import galois.nat.simplify_eq

universe variable u

namespace list

variable { α : Type u}

theorem map_accumr₂_append1
  {α β γ φ : Type}
  (f : α → β → γ → γ × φ)
  (x : list α)
  (y : list β)
  (pr : length x = length y)
  (a : α)
  (b : β)
  (c : γ)
: map_accumr₂ f (x ++ [a]) (y ++ [b]) c =
  let r := f a b c in
  let z := map_accumr₂ f x y (r^.fst) in
  ⟨ z^.fst, z^.snd ++ [r^.snd]⟩ :=
begin
  revert y,
  induction x with xh xr ind,
  -- Base case with x = nil
  { intros y pr,
    cases y with yh yr,
    { simp [map_accumr₂] },
    { contradiction },
  },
  -- Inductive case with x = xh :: xr
  {
    intros y pr,
    cases y with yh yr,
    { contradiction },
    { simp [nat.succ_add] at pr,
      simp [map_accumr₂, ind yr pr]
    },
  }
end

end list


/-
Copyright (c) 2020 Bhavik Mehta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Bhavik Mehta
-/

import category_theory.sites.grothendieck

/-!
# Grothendieck pretopologies

Definition and lemmas about Grothendieck pretopologies.
A Grothendieck pretopology for a category `C` is a set of families of morphisms with fixed codomain,
satisfying certain closure conditions.

We show that a pretopology generates a genuine Grothendieck topology, and every topology has
a maximal pretopology which generates it.

The pretopology associated to a topological space is defined in `spaces.lean`.

## Tags

coverage, pretopology, site

## References

* [https://ncatlab.org/nlab/show/Grothendieck+pretopology][nlab]
* [S. MacLane, I. Moerdijk, *Sheaves in Geometry and Logic*][MM92]
* [https://stacks.math.columbia.edu/tag/00VG][Stacks]
-/

universes v u
noncomputable theory

namespace category_theory

open category_theory category limits presieve

variables {C : Type u} [category.{v} C] [has_pullbacks C]

variables (C)

/--
A (Grothendieck) pretopology on `C` consists of a collection of families of morphisms with a fixed
target `X` for every object `X` in `C`, called "coverings" of `X`, which satisfies the following
three axioms:
1. Every family consisting of a single isomorphism is a covering family.
2. The collection of covering families is stable under pullback.
3. Given a covering family, and a covering family on each domain of the former, the composition
   is a covering family.

In some sense, a pretopology can be seen as Grothendieck topology with weaker saturation conditions,
in that each covering is not necessarily downward closed.

See: https://ncatlab.org/nlab/show/Grothendieck+pretopology, or
https://stacks.math.columbia.edu/tag/00VH, or [MM92] Chapter III, Section 2, Definition 2.
Note that Stacks calls a category together with a pretopology a site, and [MM92] calls this
a basis for a topology.
-/
@[ext]
structure pretopology :=
(coverings : Π (X : C), set (presieve X))
(has_isos : ∀ ⦃X Y⦄ (f : Y ⟶ X) [is_iso f], presieve.singleton f ∈ coverings X)
(pullbacks : ∀ ⦃X Y⦄ (f : Y ⟶ X) S, S ∈ coverings X → pullback_arrows f S ∈ coverings Y)
(transitive : ∀ ⦃X : C⦄ (S : presieve X)
               (Ti : Π ⦃Y⦄ (f : Y ⟶ X), S f → presieve Y), S ∈ coverings X →
               (∀ ⦃Y⦄ f (H : S f), Ti f H ∈ coverings Y) → S.bind Ti ∈ coverings X)

namespace pretopology

instance : has_coe_to_fun (pretopology C) :=
⟨_, λ J, J.coverings⟩

instance : partial_order (pretopology C) :=
{ le := λ K₁ K₂, (K₁ : Π (X : C), set _) ≤ K₂,
  le_refl := λ K, le_refl _,
  le_trans := λ K₁ K₂ K₃ h₁₂ h₂₃, le_trans h₁₂ h₂₃,
  le_antisymm := λ K₁ K₂ h₁₂ h₂₁, pretopology.ext _ _ (le_antisymm h₁₂ h₂₁) }

instance : order_top (pretopology C) :=
{ top :=
  { coverings := λ _, set.univ,
    has_isos := λ _ _ _ _, set.mem_univ _,
    pullbacks := λ _ _ _ _ _, set.mem_univ _,
    transitive := λ _ _ _ _ _, set.mem_univ _ },
  le_top := λ K X S hS, set.mem_univ _,
  ..pretopology.partial_order C }

instance : inhabited (pretopology C) := ⟨⊤⟩

/--
A pretopology `K` can be completed to a Grothendieck topology `J` by declaring a sieve to be
`J`-covering if it contains a family in `K`.

See https://stacks.math.columbia.edu/tag/00ZC, or [MM92] Chapter III, Section 2, Equation (2).
-/
def to_grothendieck (K : pretopology C) : grothendieck_topology C :=
{ sieves := λ X S, ∃ R ∈ K X, R ≤ (S : presieve _),
  top_mem' := λ X, ⟨presieve.singleton (𝟙 _), K.has_isos _, λ _ _ _, ⟨⟩⟩,
  pullback_stable' := λ X Y S g,
  begin
    rintro ⟨R, hR, RS⟩,
    refine ⟨_, K.pullbacks g _ hR, _⟩,
    rw [← sieve.sets_iff_generate, sieve.pullback_arrows_comm],
    apply sieve.pullback_monotone,
    rwa sieve.gi_generate.gc,
  end,
  transitive' :=
  begin
    rintro X S ⟨R', hR', RS⟩ R t,
    choose t₁ t₂ t₃ using t,
    refine ⟨_, K.transitive _ _ hR' (λ _ f hf, t₂ (RS _ hf)), _⟩,
    rintro Y _ ⟨Z, g, f, hg, hf, rfl⟩,
    apply t₃ (RS _ hg) _ hf,
  end }

lemma mem_to_grothendieck (K : pretopology C) (X S) :
  S ∈ to_grothendieck C K X ↔ ∃ R ∈ K X, R ≤ (S : presieve X) :=
iff.rfl

/--
The largest pretopology generating the given Grothendieck topology.

See [MM92] Chapter III, Section 2, Equations (3,4).
-/
def of_grothendieck (J : grothendieck_topology C) : pretopology C :=
{ coverings := λ X R, sieve.generate R ∈ J X,
  has_isos := λ X Y f i, by exactI J.covering_of_eq_top (by simp),
  pullbacks := λ X Y f R hR,
  begin
    rw [set.mem_def, sieve.pullback_arrows_comm],
    apply J.pullback_stable f hR,
  end,
  transitive := λ X S Ti hS hTi,
  begin
    apply J.transitive hS,
    intros Y f,
    rintros ⟨Z, g, f, hf, rfl⟩,
    rw sieve.pullback_comp,
    apply J.pullback_stable g,
    apply J.superset_covering _ (hTi _ hf),
    rintro Y g ⟨W, h, g, hg, rfl⟩,
    exact ⟨_, h, _, ⟨_, _, _, hf, hg, rfl⟩, by simp⟩,
  end }

/-- We have a galois insertion from pretopologies to Grothendieck topologies. -/
def gi : galois_insertion (to_grothendieck C) (of_grothendieck C) :=
{ gc :=
  λ K J,
  begin
    split,
    { intros h X R hR,
      exact h _ ⟨_, hR, sieve.le_generate R⟩ },
    { rintro h X S ⟨R, hR, RS⟩,
      apply J.superset_covering _ (h _ hR),
      rwa sieve.gi_generate.gc }
  end,
  le_l_u := λ J X S hS, ⟨S, J.superset_covering S.le_generate hS, le_refl _⟩,
  choice := λ x hx, to_grothendieck C x,
  choice_eq := λ _ _, rfl }

/--
The trivial pretopology, in which the coverings are exactly singleton isomorphisms. This topology is
also known as the indiscrete, coarse, or chaotic topology.

See https://stacks.math.columbia.edu/tag/07GE
-/
def trivial : pretopology C :=
{ coverings := λ X S, ∃ Y (f : Y ⟶ X) (h : is_iso f), S = presieve.singleton f,
  has_isos := λ X Y f i, ⟨_, _, i, rfl⟩,
  pullbacks := λ X Y f S,
  begin
    rintro ⟨Z, g, i, rfl⟩,
    refine ⟨pullback g f, pullback.snd, _, _⟩,
    { resetI, refine ⟨⟨pullback.lift (f ≫ inv g) (𝟙 _) (by simp), ⟨_, by tidy⟩⟩⟩,
      apply pullback.hom_ext,
      { rw [assoc, pullback.lift_fst, ←pullback.condition_assoc],
        simp },
      { simp } },
    { apply pullback_singleton },
  end,
  transitive :=
  begin
    rintro X S Ti ⟨Z, g, i, rfl⟩ hS,
    rcases hS g (singleton_self g) with ⟨Y, f, i, hTi⟩,
    refine ⟨_, f ≫ g, _, _⟩,
    { resetI, apply_instance },
    ext W k,
    split,
    { rintro ⟨V, h, k, ⟨_⟩, hh, rfl⟩,
      rw hTi at hh,
      cases hh,
      apply singleton.mk },
    { rintro ⟨_⟩,
      refine bind_comp g presieve.singleton.mk _,
      rw hTi,
      apply presieve.singleton.mk }
  end }

instance : order_bot (pretopology C) :=
{ bot := trivial C,
  bot_le := λ K X R,
  begin
    rintro ⟨Y, f, hf, rfl⟩,
    exactI K.has_isos f,
  end,
  ..pretopology.partial_order C }

/-- The trivial pretopology induces the trivial grothendieck topology. -/
lemma to_grothendieck_bot : to_grothendieck C ⊥ = ⊥ :=
(gi C).gc.l_bot

end pretopology

end category_theory


import data.finset tactic.find data.fintype data.nat.basic data.pnat
universes u v
local infix ` ≺ ` :50 := has_well_founded.r

open well_founded

lemma acc.rec_3 {α : Sort u} [hw : has_well_founded α] {C : α → Sort v}
  (f : Π x, (∀ y, y ≺ x → acc (≺) y) → (Π y, y ≺ x → C y) → C x) (a : α) :
  @acc.rec α (≺) C f a (apply hw.wf a) = f a (λ y _, apply hw.wf y)
  (λ y hya, @acc.rec α (≺) C f y (apply hw.wf y)) :=
(show acc.intro a (λ y _, apply hw.wf y) = (apply hw.wf a), from rfl) ▸ rfl

class game (α : Type*) extends has_well_founded α :=
(start_position : α)
(side_to_move : α → bool)
(legal_moves : Π a, finset {b : α // b ≺ a ∧ side_to_move b = bnot (side_to_move a)})
(max_score : ℕ)
(not_boring : max_score > 1)
(final_score : Π {a}, legal_moves a = ∅ → fin max_score)

namespace game

open well_founded finset list
variables {α : Type*} [g : game α] [decidable_eq α]
include g

def is_legal_move (a b : α) := ∃ h : b ≺ a ∧ side_to_move b = bnot (side_to_move a),
(⟨b, h⟩ : {b : α // b ≺ a ∧ side_to_move b = bnot (side_to_move a)}) ∈ legal_moves a

lemma is_legal_move_of_mem {a : α} {b : {b : α // b ≺ a ∧ _}} : b ∈ legal_moves a → is_legal_move a b :=
let ⟨b1, b2⟩ := b in λ h, ⟨b2, h⟩

lemma max_score_pos : 0 < max_score α :=
nat.pos_of_ne_zero $ λ h0,
acc.rec_on (apply g.wf (start_position α)) $ λ a h₁ h₂, or.by_cases
(decidable.em (legal_moves a = ∅))
(λ h, (not_lt_of_ge (nat.zero_le _)) (show (final_score h).val < 0, from h0 ▸ (final_score h).2)) $
λ h, let ⟨⟨y, hy₁⟩, hy⟩ := exists_mem_of_ne_empty h in h₂ y hy₁.1

def best (s : bool) (sc₁ sc₂ : fin g.max_score) : fin g.max_score :=
bool.cases_on s ⟨min sc₁.1 sc₂.1, lt_of_le_of_lt (min_le_left _ _) sc₁.2⟩
⟨max sc₁.1 sc₂.1, max_lt sc₁.2 sc₂.2⟩

def better (s : bool) (sc₁ sc₂ : fin g.max_score) : Prop :=
bool.cases_on s (sc₁.1 ≤ sc₂.1) (sc₂.1 ≤ sc₁.1)

@[refl] lemma better.refl (s : bool) (sc : fin g.max_score) : better s sc sc :=
bool.cases_on s (le_refl _) (le_refl _)

lemma better.trans {s : bool} {sc₁ sc₂ sc₃ : fin g.max_score} : better s sc₁ sc₂ →
    better s sc₂ sc₃ → better s sc₁ sc₃ :=
bool.cases_on s le_trans (λ h₁ h₂, le_trans h₂ h₁)

lemma best_better (s : bool) (sc₁ sc₂ : fin g.max_score) : better s (best s sc₁ sc₂) sc₁:=
bool.cases_on s (min_le_left _ _) (le_max_left _ _)

lemma better_swap {s : bool} {sc₁ sc₂ : fin g.max_score} : better (bnot s) sc₁ sc₂ ↔ better s sc₂ sc₁ :=
bool.cases_on s iff.rfl iff.rfl

def worst (s : bool) (sc₁ : fin g.max_score) (sc₂ : fin g.max_score) := best (bnot s) sc₁ sc₂

def win (s : bool) : fin g.max_score := bool.cases_on s
⟨0, max_score_pos⟩ ⟨nat.pred g.max_score, nat.pred_lt (ne_of_lt max_score_pos).symm⟩

lemma win_better (s : bool) (sc : fin g.max_score) : better s (win s) sc :=
bool.cases_on s (nat.zero_le _) (nat.le_of_succ_le_succ $
show nat.succ sc.1 ≤ nat.succ (nat.pred (max_score α)),
  begin rw nat.succ_pred_eq_of_pos max_score_pos, exact sc.2, apply_instance, end)

lemma eq_win_of_better_win {s : bool} {sc : fin g.max_score} : better s sc (win s) → sc = win s :=
bool.cases_on s (λ h, fin.eq_of_veq $ le_antisymm h (win_better ff _))
(λ h, fin.eq_of_veq $ le_antisymm (win_better tt _) h)

def loss (s : bool) := @win α _ _ (bnot s)

lemma eq_loss_of_loss_better {s : bool} {sc : fin g.max_score} : better s (loss s) sc →
    sc = loss s :=
bool.cases_on s (λ h, fin.eq_of_veq $ (le_antisymm (win_better tt _) h))
(λ h, fin.eq_of_veq $ le_antisymm h (win_better ff _))

instance (s : bool) : is_commutative _ (@best α _ _ s) := ⟨λ ⟨a, _⟩ ⟨b, _⟩, fin.eq_of_veq $
bool.cases_on s (min_comm _ _) (max_comm _ _)⟩

instance (s : bool) : is_associative _ (@best α _ _ s) := ⟨λ ⟨a, _⟩ ⟨b, _⟩ ⟨c, _⟩,
fin.eq_of_veq $ bool.cases_on s (min_assoc a b c) (max_assoc a b c)⟩

def score (a : α) : fin g.max_score :=
acc.rec_on (apply g.wf a) $ λ a _ score,
if h : legal_moves a = ∅
then final_score h
else fold (best (side_to_move a))
  (loss (side_to_move a))
  (λ b : {b : α // b ≺ a ∧ side_to_move b = bnot (side_to_move a)}, score b.1 b.2.1)
  (legal_moves a)

lemma score_eq (a : α) : score a = dite (legal_moves a = ∅) (λ h, final_score h)
    (λ h, multiset.fold (best (side_to_move a)) (loss (side_to_move a))
    (multiset.map (λ b : {b : α // _}, score b.1) ((legal_moves a).1))) :=
by unfold score fold; rw acc.rec_3

lemma score_better_aux {a : fin g.max_score} {s : multiset (fin g.max_score)} (b : bool) :
    a ∈ s → better b (multiset.fold (best b) (loss b) s) a :=
multiset.induction_on s (λ h, absurd h (multiset.not_mem_zero _)) $ λ n s hi h,
or.by_cases (multiset.mem_cons.1 h) (λ h₁, by rw [multiset.fold_cons_left, h₁];
exact best_better _ _ _) (λ h₁, by rw [multiset.fold_cons_right];
exact better.trans (best_better _ _ _) (hi h₁))

lemma score_better {a b : α} (h : is_legal_move a b) : better (side_to_move a) (score a) (score b) :=
let ⟨hb₁, hb₂⟩ := h in
by rw [score_eq a, dif_neg (ne_empty_of_mem hb₂)];
  exact score_better_aux _ (multiset.mem_map.2 ⟨⟨b, hb₁⟩, hb₂, rfl⟩)

lemma win_of_winning_move {a b : α} : score b = win (side_to_move a) →
    is_legal_move a b → score a = win (side_to_move a) :=
λ h₁ h₂, eq_win_of_better_win (h₁ ▸ score_better h₂)

lemma losing_move_of_loss {a b : α} :  is_legal_move a b → score a = loss (side_to_move a) →
    score b = loss (side_to_move a) :=
λ h₁ h₂, eq_loss_of_loss_better (h₂ ▸ (score_better h₁))

lemma win_ne_loss (s : bool) : @win α _ _ s ≠ loss s :=
bool.cases_on s (fin.ne_of_vne $ ne_of_lt $ nat.lt_pred_iff.2 $ not_boring α)
(fin.ne_of_vne (ne_of_lt $ nat.lt_pred_iff.2 $ not_boring α).symm)

end game
open game well_founded fintype list finset
def nim := ℕ × bool
#print forall_eq
instance : game nim :=
{ to_has_well_founded := ⟨_, measure_wf prod.fst⟩,
  start_position := ⟨21, tt⟩,
  side_to_move   := prod.snd,
  legal_moves    := λ n, if h : n.1 > 0
    then {⟨⟨n.1 - 1, bnot n.2⟩, ⟨nat.sub_lt h dec_trivial, rfl⟩⟩,
          ⟨⟨n.1 - 2, bnot n.2⟩, ⟨nat.sub_lt h dec_trivial, rfl⟩⟩,
          ⟨⟨n.1 - 3, bnot n.2⟩, ⟨nat.sub_lt h dec_trivial, rfl⟩⟩}
    else ∅,
  max_score := 2,
  not_boring := dec_trivial,
  final_score := λ a h, if a.snd = ff then ⟨1, dec_trivial⟩
      else ⟨0, dec_trivial⟩ }

namespace nim

lemma hgf : score (start_position nim) = ⟨1, dec_trivial⟩ := rfl

lemma legal_moves_eq_empty_iff (n : nim) : legal_moves n = ∅ ↔ n.1 = 0 :=
⟨λ (h : dite (n.1 > 0)
    (λ h, ({⟨⟨n.1 - 1, bnot n.2⟩, ⟨nat.sub_lt h dec_trivial, rfl⟩⟩,
            ⟨⟨n.1 - 2, bnot n.2⟩, ⟨nat.sub_lt h dec_trivial, rfl⟩⟩,
            ⟨⟨n.1 - 3, bnot n.2⟩, ⟨nat.sub_lt h dec_trivial, rfl⟩⟩}
            : finset {b : nim //b ≺ n ∧ side_to_move b = bnot (side_to_move n)}))
    (λ h, ∅) = ∅), by_contradiction $ λ h₁,
by simpa [dif_pos (nat.pos_of_ne_zero h₁)] using h,
λ h, or.by_cases (decidable.em (n.2 = tt))
(λ h₁, by rw (show n = ⟨0, tt⟩, from prod.eq_iff_fst_eq_snd_eq.2 ⟨h, h₁⟩); refl)
(λ h₁, by rw (show n = ⟨0, ff⟩, from prod.eq_iff_fst_eq_snd_eq.2
  ⟨h, (iff_of_eq $ eq_ff_eq_not_eq_tt n.2).1 h₁⟩); refl)⟩

lemma score_nim (n : nim) : score n = loss (side_to_move n) ↔ 4 ∣ n.1 :=
acc.rec_on (apply nim.game.wf n) $ λ n ht hi,
⟨λ h, or.by_cases (decidable.em (legal_moves n = ∅))
  (λ h₁, by rw legal_moves_eq_empty_iff at h₁; rw h₁; exact dec_trivial)
  (λ h₁, let ⟨y, hy⟩ := exists_mem_of_ne_empty h₁ in
  begin
    have := (hi y.1 y.2.1),
    unfold side_to_move at this,
    have h₂ : y.1.2 = bnot (side_to_move n) := y.2.2,
    have h₃ : score y.1 = loss (side_to_move n) := losing_move_of_loss (is_legal_move_of_mem hy) h,
    rw [h₂, loss, bnot_bnot, h₃, eq_comm] at this,
    simp [win_ne_loss] at this,
    have : y.1.1 > 0 := nat.pos_of_ne_zero (λ h, by rw h at this; exact absurd this dec_trivial),

  end)
, sorry⟩

end nim

def nac := {l : list (fin 9) // nodup l}

lemma list_fin_length (n : ℕ) (l : {l : list (fin n) // nodup l}) : length l.1 ≤ n :=
begin
  suffices : length (l.1) ≤ fintype.card (fin n),
    rwa fintype.card_fin at this,
  rw [← multiset.coe_card, ← finset.card_def ⟨(↑l.1 : multiset (fin n)), multiset.coe_nodup.1 l.2⟩],
  exact card_le_of_subset (subset_univ _),
end

local notation `O`  := (⟨0, dec_trivial⟩ : fin 3)
local notation `X`  := (⟨1, dec_trivial⟩ : fin 3)
local notation `E`  := (⟨2, dec_trivial⟩ : fin 3)
local notation `pX` := tt
local notation `pO` := ff

instance : has_well_founded nac :=
⟨_, measure_wf (λ p, 9 - length p.1)⟩

def legal_moves' (p : list (fin 9)) : finset (fin 9) :=
list.rec_on p univ (λ n p lp, (finset.erase lp n))

lemma legal_moves'_not_mem : ∀ {p : list (fin 9)} {n : fin 9}, n ∈ legal_moves' p → n ∉ p
| nil      n h := not_mem_nil _
| (m :: p) n h := not_mem_cons_of_ne_of_not_mem (ne_of_mem_erase h) $
legal_moves'_not_mem (finset.mem_of_mem_erase h)

def legal_moves1 (p : nac) : finset {q : nac // q ≺ p} :=
⟨multiset.pmap (λ n h, ⟨⟨list.cons n p.1, nodup_cons_of_nodup h p.2⟩,
(nat.sub_lt_sub_left_iff (list_fin_length 9 ⟨n :: p.1, nodup_cons_of_nodup h p.2⟩)).2
(nat.lt_succ_self _)⟩) (legal_moves' p.1).1 (λ n h, legal_moves'_not_mem h),
multiset.nodup_pmap (by intros; simp * at *) (legal_moves' p.1).2⟩

def is_line (p : nac) :

instance : game nac :=
{ start_position := ⟨nil, nodup_nil⟩,
  legal_moves    := }

end game


/-
Copyright (c) 2020 Adam Topaz. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Bhavik Mehta, Adam Topaz
-/

import category_theory.concrete_category.basic
import category_theory.full_subcategory
import category_theory.skeletal
import category_theory.elementwise
import data.fintype.card

/-!
# The category of finite types.

We define the category of finite types, denoted `Fintype` as
(bundled) types with a `fintype` instance.

We also define `Fintype.skeleton`, the standard skeleton of `Fintype` whose objects are `fin n`
for `n : ℕ`. We prove that the obvious inclusion functor `Fintype.skeleton ⥤ Fintype` is an
equivalence of categories in `Fintype.skeleton.equivalence`.
We prove that `Fintype.skeleton` is a skeleton of `Fintype` in `Fintype.is_skeleton`.
-/

open_locale classical
open category_theory

/-- The category of finite types. -/
def Fintype := bundled fintype

namespace Fintype

instance : has_coe_to_sort Fintype Type* := bundled.has_coe_to_sort

/-- Construct a bundled `Fintype` from the underlying type and typeclass. -/
def of (X : Type*) [fintype X] : Fintype := bundled.of X
instance : inhabited Fintype := ⟨⟨pempty⟩⟩
instance {X : Fintype} : fintype X := X.2

instance : category Fintype := induced_category.category bundled.α

/-- The fully faithful embedding of `Fintype` into the category of types. -/
@[derive [full, faithful], simps]
def incl : Fintype ⥤ Type* := induced_functor _

instance concrete_category_Fintype : concrete_category Fintype := ⟨incl⟩

@[simp] lemma id_apply (X : Fintype) (x : X) : (𝟙 X : X → X) x = x := rfl
@[simp] lemma comp_apply {X Y Z : Fintype} (f : X ⟶ Y) (g : Y ⟶ Z) (x : X) :
  (f ≫ g) x = g (f x) := rfl

/-- Equivalences between finite types are the same as isomorphisms in `Fintype`. -/
-- See `equiv_equiv_iso` in the root namespace for the analogue in `Type`.
@[simps]
def equiv_equiv_iso {A B : Fintype} : (A ≃ B) ≃ (A ≅ B) :=
{ to_fun := λ e,
  { hom := e,
    inv := e.symm, },
  inv_fun := λ i,
  { to_fun := i.hom,
    inv_fun := i.inv,
    left_inv := iso.hom_inv_id_apply i,
    right_inv := iso.inv_hom_id_apply i, },
  left_inv := by tidy,
  right_inv := by tidy, }

universe u
/--
The "standard" skeleton for `Fintype`. This is the full subcategory of `Fintype` spanned by objects
of the form `ulift (fin n)` for `n : ℕ`. We parameterize the objects of `Fintype.skeleton`
directly as `ulift ℕ`, as the type `ulift (fin m) ≃ ulift (fin n)` is
nonempty if and only if `n = m`. Specifying universes, `skeleton : Type u` is a small
skeletal category equivalent to `Fintype.{u}`.
-/
def skeleton : Type u := ulift ℕ

namespace skeleton

/-- Given any natural number `n`, this creates the associated object of `Fintype.skeleton`. -/
def mk : ℕ → skeleton := ulift.up

instance : inhabited skeleton := ⟨mk 0⟩

/-- Given any object of `Fintype.skeleton`, this returns the associated natural number. -/
def len : skeleton → ℕ := ulift.down

@[ext]
lemma ext (X Y : skeleton) : X.len = Y.len → X = Y := ulift.ext _ _

instance : small_category skeleton.{u} :=
{ hom := λ X Y, ulift.{u} (fin X.len) → ulift.{u} (fin Y.len),
  id := λ _, id,
  comp := λ _ _ _ f g, g ∘ f }

lemma is_skeletal : skeletal skeleton.{u} := λ X Y ⟨h⟩, ext _ _ $ fin.equiv_iff_eq.mp $
  nonempty.intro $
{ to_fun := λ x, (h.hom ⟨x⟩).down,
  inv_fun := λ x, (h.inv ⟨x⟩).down,
  left_inv := begin
    intro a,
    change ulift.down _ = _,
    rw ulift.up_down,
    change ((h.hom ≫ h.inv) _).down = _,
    simpa,
  end,
  right_inv := begin
    intro a,
    change ulift.down _ = _,
    rw ulift.up_down,
    change ((h.inv ≫ h.hom) _).down = _,
    simpa,
  end }

/-- The canonical fully faithful embedding of `Fintype.skeleton` into `Fintype`. -/
def incl : skeleton.{u} ⥤ Fintype.{u} :=
{ obj := λ X, Fintype.of (ulift (fin X.len)),
  map := λ _ _ f, f }

instance : full incl := { preimage := λ _ _ f, f }
instance : faithful incl := {}
instance : ess_surj incl :=
ess_surj.mk $ λ X, let F := fintype.equiv_fin X in ⟨mk (fintype.card X), nonempty.intro
  { hom := F.symm ∘ ulift.down,
    inv := ulift.up ∘ F }⟩

noncomputable instance : is_equivalence incl :=
equivalence.of_fully_faithfully_ess_surj _

/-- The equivalence between `Fintype.skeleton` and `Fintype`. -/
noncomputable def equivalence : skeleton ≌ Fintype := incl.as_equivalence

@[simp] lemma incl_mk_nat_card (n : ℕ) : fintype.card (incl.obj (mk n)) = n :=
begin
  convert finset.card_fin n,
  apply fintype.of_equiv_card,
end

end skeleton

/-- `Fintype.skeleton` is a skeleton of `Fintype`. -/
noncomputable def is_skeleton : is_skeleton_of Fintype skeleton skeleton.incl :=
{ skel := skeleton.is_skeletal,
  eqv := by apply_instance }

end Fintype


/-
Copyright (c) 2020 Markus Himmel. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Markus Himmel
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.category_theory.comma
import Mathlib.PostPort

universes v u l u₁ u₂ v₁ v₂

namespace Mathlib

/-!
# The category of arrows

The category of arrows, with morphisms commutative squares.
We set this up as a specialization of the comma category `comma L R`,
where `L` and `R` are both the identity functor.

We also define the typeclass `has_lift`, representing a choice of a lift
of a commutative square (that is, a diagonal morphism making the two triangles commute).

## Tags

comma, arrow
-/

namespace category_theory

/-- The arrow category of `T` has as objects all morphisms in `T` and as morphisms commutative
     squares in `T`. -/
def arrow (T : Type u) [category T] :=
  comma 𝟭 𝟭

-- Satisfying the inhabited linter

protected instance arrow.inhabited (T : Type u) [category T] [Inhabited T] : Inhabited (arrow T) :=
  { default := (fun (this : comma 𝟭 𝟭) => this) Inhabited.default }

namespace arrow

@[simp] theorem id_left {T : Type u} [category T] (f : arrow T) : comma_morphism.left 𝟙 = 𝟙 :=
  rfl

@[simp] theorem id_right {T : Type u} [category T] (f : arrow T) : comma_morphism.right 𝟙 = 𝟙 :=
  rfl

/-- An object in the arrow category is simply a morphism in `T`. -/
@[simp] theorem mk_left {T : Type u} [category T] {X : T} {Y : T} (f : X ⟶ Y) : comma.left (mk f) = X :=
  Eq.refl (comma.left (mk f))

/-- A morphism in the arrow category is a commutative square connecting two objects of the arrow
    category. -/
def hom_mk {T : Type u} [category T] {f : arrow T} {g : arrow T} {u : comma.left f ⟶ comma.left g} {v : comma.right f ⟶ comma.right g} (w : u ≫ comma.hom g = comma.hom f ≫ v) : f ⟶ g :=
  comma_morphism.mk

/-- We can also build a morphism in the arrow category out of any commutative square in `T`. -/
@[simp] theorem hom_mk'_right {T : Type u} [category T] {X : T} {Y : T} {f : X ⟶ Y} {P : T} {Q : T} {g : P ⟶ Q} {u : X ⟶ P} {v : Y ⟶ Q} (w : u ≫ g = f ≫ v) : comma_morphism.right (hom_mk' w) = v :=
  Eq.refl (comma_morphism.right (hom_mk' w))

@[simp] theorem w_assoc {T : Type u} [category T] {f : arrow T} {g : arrow T} (sq : f ⟶ g) {X' : autoParam T
  (Lean.Syntax.ident Lean.SourceInfo.none (String.toSubstring "Mathlib.obviously")
    (Lean.Name.mkStr (Lean.Name.mkStr Lean.Name.anonymous "Mathlib") "obviously") [])} (f' : functor.obj 𝟭 (comma.right g) ⟶ X') : comma_morphism.left sq ≫ comma.hom g ≫ f' = comma.hom f ≫ comma_morphism.right sq ≫ f' := sorry

/-- A lift of a commutative square is a diagonal morphism making the two triangles commute. -/
structure lift_struct {T : Type u} [category T] {f : arrow T} {g : arrow T} (sq : f ⟶ g)
where
  lift : comma.right f ⟶ comma.left g
  fac_left : comma.hom f ≫ lift = comma_morphism.left sq
  fac_right : lift ≫ comma.hom g = comma_morphism.right sq

protected instance lift_struct_inhabited {T : Type u} [category T] {X : T} : Inhabited (lift_struct 𝟙) :=
  { default := lift_struct.mk 𝟙 sorry sorry }

/-- `has_lift sq` says that there is some `lift_struct sq`, i.e., that it is possible to find a
    diagonal morphism making the two triangles commute. -/
class has_lift {T : Type u} [category T] {f : arrow T} {g : arrow T} (sq : f ⟶ g)
  mk' ::
where (exists_lift : Nonempty (lift_struct sq))

theorem has_lift.mk {T : Type u} [category T] {f : arrow T} {g : arrow T} {sq : f ⟶ g} (s : lift_struct sq) : has_lift sq :=
  has_lift.mk' (Nonempty.intro s)

@[simp] theorem lift_struct.fac_right_assoc {T : Type u} [category T] {f : arrow T} {g : arrow T} {sq : f ⟶ g} (c : lift_struct sq) {X' : autoParam T
  (Lean.Syntax.ident Lean.SourceInfo.none (String.toSubstring "Mathlib.obviously")
    (Lean.Name.mkStr (Lean.Name.mkStr Lean.Name.anonymous "Mathlib") "obviously") [])} (f' : functor.obj 𝟭 (comma.right g) ⟶ X') : lift_struct.lift c ≫ comma.hom g ≫ f' = comma_morphism.right sq ≫ f' := sorry

/-- Given `has_lift sq`, obtain a lift. -/
def has_lift.struct {T : Type u} [category T] {f : arrow T} {g : arrow T} (sq : f ⟶ g) [has_lift sq] : lift_struct sq :=
  Classical.choice has_lift.exists_lift

/-- If there is a lift of a commutative square `sq`, we can access it by saying `lift sq`. -/
def lift {T : Type u} [category T] {f : arrow T} {g : arrow T} (sq : f ⟶ g) [has_lift sq] : comma.right f ⟶ comma.left g :=
  lift_struct.lift (has_lift.struct sq)

theorem lift.fac_left {T : Type u} [category T] {f : arrow T} {g : arrow T} (sq : f ⟶ g) [has_lift sq] : comma.hom f ≫ lift sq = comma_morphism.left sq := sorry

theorem lift.fac_right {T : Type u} [category T] {f : arrow T} {g : arrow T} (sq : f ⟶ g) [has_lift sq] : lift sq ≫ comma.hom g = comma_morphism.right sq := sorry

@[simp] theorem lift_mk'_left {T : Type u} [category T] {X : T} {Y : T} {P : T} {Q : T} {f : X ⟶ Y} {g : P ⟶ Q} {u : X ⟶ P} {v : Y ⟶ Q} (h : u ≫ g = f ≫ v) [has_lift (hom_mk' h)] : f ≫ lift (hom_mk' h) = u := sorry

@[simp] theorem lift_mk'_right_assoc {T : Type u} [category T] {X : T} {Y : T} {P : T} {Q : T} {f : X ⟶ Y} {g : P ⟶ Q} {u : X ⟶ P} {v : Y ⟶ Q} (h : u ≫ g = f ≫ v) [has_lift (hom_mk' h)] {X' : autoParam T
  (Lean.Syntax.ident Lean.SourceInfo.none (String.toSubstring "Mathlib.obviously")
    (Lean.Name.mkStr (Lean.Name.mkStr Lean.Name.anonymous "Mathlib") "obviously") [])} (f' : Q ⟶ X') : lift (hom_mk' h) ≫ g ≫ f' = v ≫ f' := sorry

protected instance subsingleton_lift_struct_of_epi {T : Type u} [category T] {f : arrow T} {g : arrow T} (sq : f ⟶ g) [epi (comma.hom f)] : subsingleton (lift_struct sq) :=
  subsingleton.intro
    fun (a b : lift_struct sq) =>
      lift_struct.ext a b
        (iff.mp (cancel_epi (comma.hom f))
          (eq.mpr
            (id
              (Eq.trans
                ((fun (a a_1 : functor.obj 𝟭 (comma.left f) ⟶ comma.left g) (e_1 : a = a_1)
                    (ᾰ ᾰ_1 : functor.obj 𝟭 (comma.left f) ⟶ comma.left g) (e_2 : ᾰ = ᾰ_1) => congr (congr_arg Eq e_1) e_2)
                  (comma.hom f ≫ lift_struct.lift a) (comma_morphism.left sq) (lift_struct.fac_left a)
                  (comma.hom f ≫ lift_struct.lift b) (comma_morphism.left sq) (lift_struct.fac_left b))
                (propext (eq_self_iff_true (comma_morphism.left sq)))))
            trivial))

protected instance subsingleton_lift_struct_of_mono {T : Type u} [category T] {f : arrow T} {g : arrow T} (sq : f ⟶ g) [mono (comma.hom g)] : subsingleton (lift_struct sq) :=
  subsingleton.intro
    fun (a b : lift_struct sq) =>
      lift_struct.ext a b
        (iff.mp (cancel_mono (comma.hom g))
          (eq.mpr
            (id
              (Eq.trans
                ((fun (a a_1 : comma.right f ⟶ functor.obj 𝟭 (comma.right g)) (e_1 : a = a_1)
                    (ᾰ ᾰ_1 : comma.right f ⟶ functor.obj 𝟭 (comma.right g)) (e_2 : ᾰ = ᾰ_1) =>
                    congr (congr_arg Eq e_1) e_2)
                  (lift_struct.lift a ≫ comma.hom g) (comma_morphism.right sq) (lift_struct.fac_right a)
                  (lift_struct.lift b ≫ comma.hom g) (comma_morphism.right sq) (lift_struct.fac_right b))
                (propext (eq_self_iff_true (comma_morphism.right sq)))))
            trivial))

end arrow

namespace functor

/-- A functor `C ⥤ D` induces a functor between the corresponding arrow categories. -/
@[simp] theorem map_arrow_map_right {C : Type u₁} [category C] {D : Type u₂} [category D] (F : C ⥤ D) (a : arrow C) (b : arrow C) (f : a ⟶ b) : comma_morphism.right (map (map_arrow F) f) = map F (comma_morphism.right f) :=
  Eq.refl (comma_morphism.right (map (map_arrow F) f))


/-
Copyright (c) 2021 Johan Commelin. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johan Commelin, Riccardo Brasca
-/
import analysis.normed.group.hom
import category_theory.limits.shapes.zero_morphisms
import category_theory.concrete_category.bundled_hom
import category_theory.elementwise

/-!
# The category of seminormed groups

We define `SemiNormedGroup`, the category of seminormed groups and normed group homs between them,
as well as `SemiNormedGroup₁`, the subcategory of norm non-increasing morphisms.
-/

noncomputable theory

universes u

open category_theory

/-- The category of seminormed abelian groups and bounded group homomorphisms. -/
def SemiNormedGroup : Type (u+1) := bundled seminormed_add_comm_group

namespace SemiNormedGroup

instance bundled_hom : bundled_hom @normed_add_group_hom :=
⟨@normed_add_group_hom.to_fun, @normed_add_group_hom.id, @normed_add_group_hom.comp,
  @normed_add_group_hom.coe_inj⟩

attribute [derive [large_category, concrete_category]] SemiNormedGroup

instance : has_coe_to_sort SemiNormedGroup (Type u) := bundled.has_coe_to_sort

/-- Construct a bundled `SemiNormedGroup` from the underlying type and typeclass. -/
def of (M : Type u) [seminormed_add_comm_group M] : SemiNormedGroup := bundled.of M

instance (M : SemiNormedGroup) : seminormed_add_comm_group M := M.str

@[simp] lemma coe_of (V : Type u) [seminormed_add_comm_group V] :
  (SemiNormedGroup.of V : Type u) = V := rfl
@[simp] lemma coe_id (V : SemiNormedGroup) : ⇑(𝟙 V) = id := rfl
@[simp] lemma coe_comp {M N K : SemiNormedGroup} (f : M ⟶ N) (g : N ⟶ K) :
  ((f ≫ g) : M → K) = g ∘ f := rfl

instance : inhabited SemiNormedGroup := ⟨of punit⟩

instance of_unique (V : Type u) [seminormed_add_comm_group V] [i : unique V] :
  unique (SemiNormedGroup.of V) := i

instance : limits.has_zero_morphisms.{u (u+1)} SemiNormedGroup := {}

@[simp] lemma zero_apply {V W : SemiNormedGroup} (x : V) : (0 : V ⟶ W) x = 0 := rfl

lemma is_zero_of_subsingleton (V : SemiNormedGroup) [subsingleton V] :
  limits.is_zero V :=
begin
  refine ⟨λ X, ⟨⟨⟨0⟩, λ f, _⟩⟩, λ X, ⟨⟨⟨0⟩, λ f, _⟩⟩⟩,
  { ext, have : x = 0 := subsingleton.elim _ _, simp only [this, map_zero], },
  { ext, apply subsingleton.elim }
end

instance has_zero_object : limits.has_zero_object SemiNormedGroup.{u} :=
⟨⟨of punit, is_zero_of_subsingleton _⟩⟩

lemma iso_isometry_of_norm_noninc {V W : SemiNormedGroup} (i : V ≅ W)
  (h1 : i.hom.norm_noninc) (h2 : i.inv.norm_noninc) :
  isometry i.hom :=
begin
  apply add_monoid_hom_class.isometry_of_norm,
  intro v,
  apply le_antisymm (h1 v),
  calc ‖v‖ = ‖i.inv (i.hom v)‖ : by rw [iso.hom_inv_id_apply]
  ... ≤ ‖i.hom v‖ : h2 _,
end

end SemiNormedGroup

/--
`SemiNormedGroup₁` is a type synonym for `SemiNormedGroup`,
which we shall equip with the category structure consisting only of the norm non-increasing maps.
-/
def SemiNormedGroup₁ : Type (u+1) := bundled seminormed_add_comm_group

namespace SemiNormedGroup₁

instance : has_coe_to_sort SemiNormedGroup₁ (Type u) := bundled.has_coe_to_sort

instance : large_category.{u} SemiNormedGroup₁ :=
{ hom := λ X Y, { f : normed_add_group_hom X Y // f.norm_noninc },
  id := λ X, ⟨normed_add_group_hom.id X, normed_add_group_hom.norm_noninc.id⟩,
  comp := λ X Y Z f g,
    ⟨(g : normed_add_group_hom Y Z).comp (f : normed_add_group_hom X Y), g.2.comp f.2⟩ }

@[ext] lemma hom_ext {M N : SemiNormedGroup₁} (f g : M ⟶ N) (w : (f : M → N) = (g : M → N)) :
  f = g :=
subtype.eq (normed_add_group_hom.ext (congr_fun w))

instance : concrete_category.{u} SemiNormedGroup₁ :=
{ forget :=
  { obj := λ X, X,
    map := λ X Y f, f, },
  forget_faithful := {} }

/-- Construct a bundled `SemiNormedGroup₁` from the underlying type and typeclass. -/
def of (M : Type u) [seminormed_add_comm_group M] : SemiNormedGroup₁ := bundled.of M

instance (M : SemiNormedGroup₁) : seminormed_add_comm_group M := M.str

/-- Promote a morphism in `SemiNormedGroup` to a morphism in `SemiNormedGroup₁`. -/
def mk_hom {M N : SemiNormedGroup} (f : M ⟶ N) (i : f.norm_noninc) :
  SemiNormedGroup₁.of M ⟶ SemiNormedGroup₁.of N :=
⟨f, i⟩

@[simp] lemma mk_hom_apply {M N : SemiNormedGroup} (f : M ⟶ N) (i : f.norm_noninc) (x) :
  mk_hom f i x = f x := rfl

/-- Promote an isomorphism in `SemiNormedGroup` to an isomorphism in `SemiNormedGroup₁`. -/
@[simps]
def mk_iso {M N : SemiNormedGroup} (f : M ≅ N) (i : f.hom.norm_noninc) (i' : f.inv.norm_noninc) :
  SemiNormedGroup₁.of M ≅ SemiNormedGroup₁.of N :=
{ hom := mk_hom f.hom i,
  inv := mk_hom f.inv i',
  hom_inv_id' := by { apply subtype.eq, exact f.hom_inv_id, },
  inv_hom_id' := by { apply subtype.eq, exact f.inv_hom_id, }, }

instance : has_forget₂ SemiNormedGroup₁ SemiNormedGroup :=
{ forget₂ :=
  { obj := λ X, X,
    map := λ X Y f, f.1, }, }

@[simp] lemma coe_of (V : Type u) [seminormed_add_comm_group V] :
  (SemiNormedGroup₁.of V : Type u) = V := rfl
@[simp] lemma coe_id (V : SemiNormedGroup₁) : ⇑(𝟙 V) = id := rfl
@[simp] lemma coe_comp {M N K : SemiNormedGroup₁} (f : M ⟶ N) (g : N ⟶ K) :
  ((f ≫ g) : M → K) = g ∘ f := rfl
-- If `coe_fn_coe_base` fires before `coe_comp`, `coe_comp'` puts us back in normal form.
@[simp] lemma coe_comp' {M N K : SemiNormedGroup₁} (f : M ⟶ N) (g : N ⟶ K) :
  ((f ≫ g) : normed_add_group_hom M K) = (↑g : normed_add_group_hom N K).comp ↑f := rfl

instance : inhabited SemiNormedGroup₁ := ⟨of punit⟩

instance of_unique (V : Type u) [seminormed_add_comm_group V] [i : unique V] :
  unique (SemiNormedGroup₁.of V) := i

instance : limits.has_zero_morphisms.{u (u+1)} SemiNormedGroup₁ :=
{ has_zero := λ X Y, { zero := ⟨0, normed_add_group_hom.norm_noninc.zero⟩, },
  comp_zero' := λ X Y f Z, by { ext, refl, },
  zero_comp' := λ X Y Z f, by { ext, simp [coe_fn_coe_base'] } }

@[simp] lemma zero_apply {V W : SemiNormedGroup₁} (x : V) : (0 : V ⟶ W) x = 0 := rfl

lemma is_zero_of_subsingleton (V : SemiNormedGroup₁) [subsingleton V] :
  limits.is_zero V :=
begin
  refine ⟨λ X, ⟨⟨⟨0⟩, λ f, _⟩⟩, λ X, ⟨⟨⟨0⟩, λ f, _⟩⟩⟩,
  { ext, have : x = 0 := subsingleton.elim _ _, simp only [this, map_zero],
    exact map_zero f.1 },
  { ext, apply subsingleton.elim }
end

instance has_zero_object : limits.has_zero_object SemiNormedGroup₁.{u} :=
⟨⟨of punit, is_zero_of_subsingleton _⟩⟩

lemma iso_isometry {V W : SemiNormedGroup₁} (i : V ≅ W) :
  isometry i.hom :=
begin
  change isometry (i.hom : V →+ W),
  refine add_monoid_hom_class.isometry_of_norm i.hom _,
  intro v,
  apply le_antisymm (i.hom.2 v),
  calc ‖v‖ = ‖i.inv (i.hom v)‖ : by rw [iso.hom_inv_id_apply]
      ... ≤ ‖i.hom v‖ : i.inv.2 _,
end

end SemiNormedGroup₁


/-
Copyright (c) 2022 Yaël Dillies. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yaël Dillies

! This file was ported from Lean 3 source module data.set.sigma
! leanprover-community/mathlib commit 2258b40dacd2942571c8ce136215350c702dc78f
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Data.Set.Image

/-!
# Sets in sigma types

This file defines `Set.sigma`, the indexed sum of sets.
-/

namespace Set

variable {ι ι' : Type _} {α β : ι → Type _} {s s₁ s₂ : Set ι} {t t₁ t₂ : ∀ i, Set (α i)}
  {u : Set (Σ i, α i)} {x : Σ i, α i} {i j : ι} {a : α i}

@[simp]
theorem range_sigmaMk (i : ι) : range (Sigma.mk i : α i → Sigma α) = Sigma.fst ⁻¹' {i} := by
  apply Subset.antisymm
  · rintro _ ⟨b, rfl⟩
    simp
  · rintro ⟨x, y⟩ (rfl | _)
    exact mem_range_self y
#align set.range_sigma_mk Set.range_sigmaMk

theorem preimage_image_sigmaMk_of_ne (h : i ≠ j) (s : Set (α j)) :
    Sigma.mk i ⁻¹' (Sigma.mk j '' s) = ∅ := by
  ext x
  simp [h.symm]
#align set.preimage_image_sigma_mk_of_ne Set.preimage_image_sigmaMk_of_ne

theorem image_sigmaMk_preimage_sigmaMap_subset {β : ι' → Type _} (f : ι → ι')
    (g : ∀ i, α i → β (f i)) (i : ι) (s : Set (β (f i))) :
    Sigma.mk i '' (g i ⁻¹' s) ⊆ Sigma.map f g ⁻¹' (Sigma.mk (f i) '' s) :=
  image_subset_iff.2 fun x hx ↦ ⟨g i x, hx, rfl⟩
#align set.image_sigma_mk_preimage_sigma_map_subset Set.image_sigmaMk_preimage_sigmaMap_subset

theorem image_sigmaMk_preimage_sigmaMap {β : ι' → Type _} {f : ι → ι'} (hf : Function.Injective f)
    (g : ∀ i, α i → β (f i)) (i : ι) (s : Set (β (f i))) :
    Sigma.mk i '' (g i ⁻¹' s) = Sigma.map f g ⁻¹' (Sigma.mk (f i) '' s) := by
  refine' (image_sigmaMk_preimage_sigmaMap_subset f g i s).antisymm _
  rintro ⟨j, x⟩ ⟨y, hys, hxy⟩
  simp only [hf.eq_iff, Sigma.map, Sigma.ext_iff] at hxy
  rcases hxy with ⟨rfl, hxy⟩; rw [heq_iff_eq] at hxy; subst y
  exact ⟨x, hys, rfl⟩
#align set.image_sigma_mk_preimage_sigma_map Set.image_sigmaMk_preimage_sigmaMap

/-- Indexed sum of sets. `s.sigma t` is the set of dependent pairs `⟨i, a⟩` such that `i ∈ s` and
`a ∈ t i`.-/
protected def Sigma (s : Set ι) (t : ∀ i, Set (α i)) : Set (Σi, α i) :=
  { x | x.1 ∈ s ∧ x.2 ∈ t x.1 }
#align set.sigma Set.Sigma

@[simp]
theorem mem_sigma_iff : x ∈ s.Sigma t ↔ x.1 ∈ s ∧ x.2 ∈ t x.1 :=
  Iff.rfl
#align set.mem_sigma_iff Set.mem_sigma_iff

theorem mk_sigma_iff : (⟨i, a⟩ : Σ i, α i) ∈ s.Sigma t ↔ i ∈ s ∧ a ∈ t i :=
  Iff.rfl
#align set.mk_sigma_iff Set.mk_sigma_iff

theorem mk_mem_sigma (hi : i ∈ s) (ha : a ∈ t i) : (⟨i, a⟩ : Σi, α i) ∈ s.Sigma t :=
  ⟨hi, ha⟩
#align set.mk_mem_sigma Set.mk_mem_sigma

theorem sigma_mono (hs : s₁ ⊆ s₂) (ht : ∀ i, t₁ i ⊆ t₂ i) : s₁.Sigma t₁ ⊆ s₂.Sigma t₂ := fun _ hx ↦
  ⟨hs hx.1, ht _ hx.2⟩
#align set.sigma_mono Set.sigma_mono

theorem sigma_subset_iff : s.Sigma t ⊆ u ↔ ∀ ⦃i⦄, i ∈ s → ∀ ⦃a⦄, a ∈ t i → (⟨i, a⟩ : Σi, α i) ∈ u :=
  ⟨fun h _ hi _ ha ↦ h <| mk_mem_sigma hi ha, fun h _ ha ↦ h ha.1 ha.2⟩
#align set.sigma_subset_iff Set.sigma_subset_iff

theorem forall_sigma_iff {p : (Σi, α i) → Prop} :
    (∀ x ∈ s.Sigma t, p x) ↔ ∀ ⦃i⦄, i ∈ s → ∀ ⦃a⦄, a ∈ t i → p ⟨i, a⟩ :=
  sigma_subset_iff
#align set.forall_sigma_iff Set.forall_sigma_iff

theorem exists_sigma_iff {p : (Σi, α i) → Prop} :
    (∃ x ∈ s.Sigma t, p x) ↔ ∃ i ∈ s, ∃ a ∈ t i, p ⟨i, a⟩ :=
  ⟨fun ⟨⟨i, a⟩, ha, h⟩ ↦ ⟨i, ha.1, a, ha.2, h⟩, fun ⟨i, hi, a, ha, h⟩ ↦ ⟨⟨i, a⟩, ⟨hi, ha⟩, h⟩⟩
#align set.exists_sigma_iff Set.exists_sigma_iff

@[simp]
theorem sigma_empty : (s.Sigma fun i ↦ (∅ : Set (α i))) = ∅ :=
  ext fun _ ↦ and_false_iff _
#align set.sigma_empty Set.sigma_empty

@[simp]
theorem empty_sigma : (∅ : Set ι).Sigma t = ∅ :=
  ext fun _ ↦ false_and_iff _
#align set.empty_sigma Set.empty_sigma

theorem univ_sigma_univ : ((@univ ι).Sigma fun _ ↦ @univ (α i)) = univ :=
  ext fun _ ↦ true_and_iff _
#align set.univ_sigma_univ Set.univ_sigma_univ

@[simp]
theorem sigma_univ : s.Sigma (fun _ ↦ univ : ∀ i, Set (α i)) = Sigma.fst ⁻¹' s :=
  ext fun _ ↦ and_true_iff _
#align set.sigma_univ Set.sigma_univ

@[simp]
theorem singleton_sigma : ({i} : Set ι).Sigma t = Sigma.mk i '' t i :=
  ext fun x ↦ by
    constructor
    · obtain ⟨j, a⟩ := x
      rintro ⟨rfl : j = i, ha⟩
      exact mem_image_of_mem _ ha
    · rintro ⟨b, hb, rfl⟩
      exact ⟨rfl, hb⟩
#align set.singleton_sigma Set.singleton_sigma

@[simp]
theorem sigma_singleton {a : ∀ i, α i} :
    (s.Sigma fun i ↦ ({a i} : Set (α i))) = (fun i ↦ Sigma.mk i <| a i) '' s := by
  ext ⟨x, y⟩
  simp [and_left_comm, eq_comm]
#align set.sigma_singleton Set.sigma_singleton

theorem singleton_sigma_singleton {a : ∀ i, α i} :
    (({i} : Set ι).Sigma fun i ↦ ({a i} : Set (α i))) = {⟨i, a i⟩} := by
  rw [sigma_singleton, image_singleton]
#align set.singleton_sigma_singleton Set.singleton_sigma_singleton

@[simp]
theorem union_sigma : (s₁ ∪ s₂).Sigma t = s₁.Sigma t ∪ s₂.Sigma t :=
  ext fun _ ↦ or_and_right
#align set.union_sigma Set.union_sigma

@[simp]
theorem sigma_union : (s.Sigma fun i ↦ t₁ i ∪ t₂ i) = s.Sigma t₁ ∪ s.Sigma t₂ :=
  ext fun _ ↦ and_or_left
#align set.sigma_union Set.sigma_union

theorem sigma_inter_sigma : s₁.Sigma t₁ ∩ s₂.Sigma t₂ = (s₁ ∩ s₂).Sigma fun i ↦ t₁ i ∩ t₂ i := by
  ext ⟨x, y⟩
  simp [and_assoc, and_left_comm]
#align set.sigma_inter_sigma Set.sigma_inter_sigma

theorem insert_sigma : (insert i s).Sigma t = Sigma.mk i '' t i ∪ s.Sigma t := by
  rw [insert_eq, union_sigma, singleton_sigma]
  exact a
#align set.insert_sigma Set.insert_sigma

theorem sigma_insert {a : ∀ i, α i} :
    (s.Sigma fun i ↦ insert (a i) (t i)) = (fun i ↦ ⟨i, a i⟩) '' s ∪ s.Sigma t := by
  simp_rw [insert_eq, sigma_union, sigma_singleton]
#align set.sigma_insert Set.sigma_insert

theorem sigma_preimage_eq {f : ι' → ι} {g : ∀ i, β i → α i} :
    ((f ⁻¹' s).Sigma fun i ↦ g (f i) ⁻¹' t (f i)) =
      (fun p : Σi, β (f i) ↦ Sigma.mk _ (g _ p.2)) ⁻¹' s.Sigma t :=
  rfl
#align set.sigma_preimage_eq Set.sigma_preimage_eq

theorem sigma_preimage_left {f : ι' → ι} :
    ((f ⁻¹' s).Sigma fun i ↦ t (f i)) = (fun p : Σi, α (f i) ↦ Sigma.mk _ p.2) ⁻¹' s.Sigma t :=
  rfl
#align set.sigma_preimage_left Set.sigma_preimage_left

theorem sigma_preimage_right {g : ∀ i, β i → α i} :
    (s.Sigma fun i ↦ g i ⁻¹' t i) = (fun p : Σi, β i ↦ Sigma.mk p.1 (g _ p.2)) ⁻¹' s.Sigma t :=
  rfl
#align set.sigma_preimage_right Set.sigma_preimage_right

theorem preimage_sigmaMap_sigma {α' : ι' → Type _} (f : ι → ι') (g : ∀ i, α i → α' (f i))
    (s : Set ι') (t : ∀ i, Set (α' i)) :
    Sigma.map f g ⁻¹' s.Sigma t = (f ⁻¹' s).Sigma fun i ↦ g i ⁻¹' t (f i) :=
  rfl
#align set.preimage_sigma_map_sigma Set.preimage_sigmaMap_sigma

@[simp]
theorem mk_preimage_sigma (hi : i ∈ s) : Sigma.mk i ⁻¹' s.Sigma t = t i :=
  ext fun _ ↦ and_iff_right hi
#align set.mk_preimage_sigma Set.mk_preimage_sigma

@[simp]
theorem mk_preimage_sigma_eq_empty (hi : i ∉ s) : Sigma.mk i ⁻¹' s.Sigma t = ∅ :=
  ext fun _ ↦ iff_of_false (hi ∘ And.left) id
#align set.mk_preimage_sigma_eq_empty Set.mk_preimage_sigma_eq_empty

theorem mk_preimage_sigma_eq_if [DecidablePred (· ∈ s)] :
    Sigma.mk i ⁻¹' s.Sigma t = if i ∈ s then t i else ∅ := by split_ifs <;> simp [*]
#align set.mk_preimage_sigma_eq_if Set.mk_preimage_sigma_eq_if

theorem mk_preimage_sigma_fn_eq_if {β : Type _} [DecidablePred (· ∈ s)] (g : β → α i) :
    (fun b ↦ Sigma.mk i (g b)) ⁻¹' s.Sigma t = if i ∈ s then g ⁻¹' t i else ∅ :=
  ext fun _ ↦ by split_ifs <;> simp [*]
#align set.mk_preimage_sigma_fn_eq_if Set.mk_preimage_sigma_fn_eq_if

protected theorem Nonempty.sigma :
    s.Nonempty → (∀ i, (t i).Nonempty) → (s.Sigma t : Set _).Nonempty := fun ⟨i, hi⟩ h ↦
  let ⟨a, ha⟩ := h i
  ⟨⟨i, a⟩, hi, ha⟩
#align set.nonempty.sigma Set.Nonempty.sigma

theorem Nonempty.sigma_fst : (s.Sigma t : Set _).Nonempty → s.Nonempty := fun ⟨x, hx⟩ ↦ ⟨x.1, hx.1⟩
#align set.nonempty.sigma_fst Set.Nonempty.sigma_fst

theorem Nonempty.sigma_snd : (s.Sigma t : Set _).Nonempty → ∃ i ∈ s, (t i).Nonempty :=
  fun ⟨x, hx⟩ ↦ ⟨x.1, hx.1, x.2, hx.2⟩
#align set.nonempty.sigma_snd Set.Nonempty.sigma_snd

theorem sigma_nonempty_iff : (s.Sigma t : Set _).Nonempty ↔ ∃ i ∈ s, (t i).Nonempty :=
  ⟨Nonempty.sigma_snd, fun ⟨i, hi, a, ha⟩ ↦ ⟨⟨i, a⟩, hi, ha⟩⟩
#align set.sigma_nonempty_iff Set.sigma_nonempty_iff

theorem sigma_eq_empty_iff : s.Sigma t = ∅ ↔ ∀ i ∈ s, t i = ∅ :=
  not_nonempty_iff_eq_empty.symm.trans <|
    sigma_nonempty_iff.not.trans <| by
      simp only [not_nonempty_iff_eq_empty, not_and, not_exists]
#align set.sigma_eq_empty_iff Set.sigma_eq_empty_iff

theorem image_sigmaMk_subset_sigma_left {a : ∀ i, α i} (ha : ∀ i, a i ∈ t i) :
    (fun i ↦ Sigma.mk i (a i)) '' s ⊆ s.Sigma t :=
  image_subset_iff.2 fun _ hi ↦ ⟨hi, ha _⟩
#align set.image_sigma_mk_subset_sigma_left Set.image_sigmaMk_subset_sigma_left

theorem image_sigmaMk_subset_sigma_right (hi : i ∈ s) : Sigma.mk i '' t i ⊆ s.Sigma t :=
  image_subset_iff.2 fun _ ↦ And.intro hi
#align set.image_sigma_mk_subset_sigma_right Set.image_sigmaMk_subset_sigma_right

theorem sigma_subset_preimage_fst (s : Set ι) (t : ∀ i, Set (α i)) : s.Sigma t ⊆ Sigma.fst ⁻¹' s :=
  fun _ ↦ And.left
#align set.sigma_subset_preimage_fst Set.sigma_subset_preimage_fst

theorem fst_image_sigma_subset (s : Set ι) (t : ∀ i, Set (α i)) : Sigma.fst '' s.Sigma t ⊆ s :=
  image_subset_iff.2 fun _ ↦ And.left
#align set.fst_image_sigma_subset Set.fst_image_sigma_subset

theorem fst_image_sigma (s : Set ι) (ht : ∀ i, (t i).Nonempty) : Sigma.fst '' s.Sigma t = s :=
  (fst_image_sigma_subset _ _).antisymm fun i hi ↦
    let ⟨a, ha⟩ := ht i
    ⟨⟨i, a⟩, ⟨hi, ha⟩, rfl⟩
#align set.fst_image_sigma Set.fst_image_sigma

theorem sigma_diff_sigma : s₁.Sigma t₁ \ s₂.Sigma t₂ = s₁.Sigma (t₁ \ t₂) ∪ (s₁ \ s₂).Sigma t₁ :=
  ext fun x ↦ by
    by_cases h₁ : x.1 ∈ s₁ <;> by_cases h₂ : x.2 ∈ t₁ x.1 <;> simp [*, ← imp_iff_or_not]
#align set.sigma_diff_sigma Set.sigma_diff_sigma

end Set


/-
Copyright (c) 2022 Devon Tuma. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Devon Tuma
-/
import computational_monads.oracle_comp

/-!
# Running Compuations With No Oracles

This file defines a function `run_comp` for "running" an `oracle_comp` that doesn't have access to
any oracles, where `empty_spec` is used to represent the lack of available oracles.
In this case the `oracle_comp.query` constructor can't be called, and so we can eliminate this
case and perform the natural reduction on other computations.

TODO: Should be possible to generalize this to use `random_gen`, allowing greater flexibility.
-/

namespace oracle_comp

open oracle_spec

/-- Run a computation with `[]ₒ` as the oracles, using `empty.elim` in the `query` case. -/
def run_comp : Π {α : Type}, oracle_comp []ₒ α → α
| _ (pure' α a) := a
| _ (bind' α β oa ob) := let a : α := run_comp oa in run_comp (ob a)
| _ (query i t) := empty.elim i

variables {α β : Type} (oa : oracle_comp []ₒ α) (ob : α → oracle_comp []ₒ β) (a : α) (b : β)

@[simp] lemma run_comp_return : run_comp (return a) = a := rfl

@[simp] lemma run_comp_bind : run_comp (oa >>= ob) = run_comp (ob $ run_comp oa) := rfl

lemma run_comp_query (i : []ₒ.ι) (t : []ₒ.domain i) (u : []ₒ.range i) : run_comp (query i t) = u :=
empty.elim i

example : run_comp
(do { x ← return 1,
      y ← return (x + 1),
      z ← return (x * y + y * x),
      return (y + y = z) }) = true := -- Check that `2 + 2 = 4`
by simp only [run_comp_bind, run_comp_return, one_mul, mul_one, eq_self_iff_true]

end oracle_comp


def f : (xs : List Nat) → Nat → xs ≠ [] → Nat
  | [], _, _ => _
  | [a,b], _, _ => _
  | _, _, _ => _

set_option pp.inaccessibleNames true in
def f' : (xs : List Nat) → Nat → xs ≠ [] → Nat
  | [], _, _ => _ -- TODO: figure out why hyp `Ne (α := List Nat) x✝² []` needs α
  | [a,b], _, _ => _
  | _, _, _ =>  _

theorem ex1 : p ∨ q → q ∨ p := by
  intro h
  cases h
  trace_state
  apply Or.inr
  assumption
  apply Or.inl
  assumption
  done

theorem ex2 : {p : Prop} → [Decidable p] → p → decide p = true
  | _, isTrue  _, _   => _
  | _, isFalse h₁, h₂ => absurd h₂ h₁

theorem ex3 : ∀ {c d : Char}, c = d → c.val = d.val
  | _, _, rfl => _


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

Transferring `traversable` instances using isomorphisms.
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.equiv.basic
import Mathlib.control.traversable.lemmas
import Mathlib.PostPort

universes u

namespace Mathlib

namespace equiv

/-- Given a functor `t`, a function `t' : Type u → Type u`, and
equivalences `t α ≃ t' α` for all `α`, then every function `α → β` can
be mapped to a function `t' α → t' β` functorially (see
`equiv.functor`). -/
protected def map {t : Type u → Type u} {t' : Type u → Type u} (eqv : (α : Type u) → t α ≃ t' α)
    [Functor t] {α : Type u} {β : Type u} (f : α → β) (x : t' α) : t' β :=
  coe_fn (eqv β) (f <$> coe_fn (equiv.symm (eqv α)) x)

/-- The function `equiv.map` transfers the functoriality of `t` to
`t'` using the equivalences `eqv`.  -/
protected def functor {t : Type u → Type u} {t' : Type u → Type u} (eqv : (α : Type u) → t α ≃ t' α)
    [Functor t] : Functor t' :=
  { map := equiv.map eqv, mapConst := fun (α β : Type u) => equiv.map eqv ∘ function.const β }

protected theorem id_map {t : Type u → Type u} {t' : Type u → Type u}
    (eqv : (α : Type u) → t α ≃ t' α) [Functor t] [is_lawful_functor t] {α : Type u} (x : t' α) :
    equiv.map eqv id x = x :=
  sorry

protected theorem comp_map {t : Type u → Type u} {t' : Type u → Type u}
    (eqv : (α : Type u) → t α ≃ t' α) [Functor t] [is_lawful_functor t] {α : Type u} {β : Type u}
    {γ : Type u} (g : α → β) (h : β → γ) (x : t' α) :
    equiv.map eqv (h ∘ g) x = equiv.map eqv h (equiv.map eqv g x) :=
  sorry

protected theorem is_lawful_functor {t : Type u → Type u} {t' : Type u → Type u}
    (eqv : (α : Type u) → t α ≃ t' α) [Functor t] [is_lawful_functor t] : is_lawful_functor t' :=
  is_lawful_functor.mk (equiv.id_map eqv) (equiv.comp_map eqv)

protected theorem is_lawful_functor' {t : Type u → Type u} {t' : Type u → Type u}
    (eqv : (α : Type u) → t α ≃ t' α) [Functor t] [is_lawful_functor t] [F : Functor t']
    (h₀ : ∀ {α β : Type u} (f : α → β), Functor.map f = equiv.map eqv f)
    (h₁ :
      ∀ {α β : Type u} (f : β),
        Functor.mapConst f = function.comp (equiv.map eqv) (function.const α) f) :
    is_lawful_functor t' :=
  sorry

/-- Like `equiv.map`, a function `t' : Type u → Type u` can be given
the structure of a traversable functor using a traversable functor
`t'` and equivalences `t α ≃ t' α` for all α.  See `equiv.traversable`. -/
protected def traverse {t : Type u → Type u} {t' : Type u → Type u}
    (eqv : (α : Type u) → t α ≃ t' α) [traversable t] {m : Type u → Type u} [Applicative m]
    {α : Type u} {β : Type u} (f : α → m β) (x : t' α) : m (t' β) :=
  ⇑(eqv β) <$> traverse f (coe_fn (equiv.symm (eqv α)) x)

/-- The function `equiv.tranverse` transfers a traversable functor
instance across the equivalences `eqv`. -/
protected def traversable {t : Type u → Type u} {t' : Type u → Type u}
    (eqv : (α : Type u) → t α ≃ t' α) [traversable t] : traversable t' :=
  traversable.mk (equiv.traverse eqv)

protected theorem id_traverse {t : Type u → Type u} {t' : Type u → Type u}
    (eqv : (α : Type u) → t α ≃ t' α) [traversable t] [is_lawful_traversable t] {α : Type u}
    (x : t' α) : equiv.traverse eqv id.mk x = x :=
  sorry

protected theorem traverse_eq_map_id {t : Type u → Type u} {t' : Type u → Type u}
    (eqv : (α : Type u) → t α ≃ t' α) [traversable t] [is_lawful_traversable t] {α : Type u}
    {β : Type u} (f : α → β) (x : t' α) :
    equiv.traverse eqv (id.mk ∘ f) x = id.mk (equiv.map eqv f x) :=
  sorry

protected theorem comp_traverse {t : Type u → Type u} {t' : Type u → Type u}
    (eqv : (α : Type u) → t α ≃ t' α) [traversable t] [is_lawful_traversable t]
    {F : Type u → Type u} {G : Type u → Type u} [Applicative F] [Applicative G]
    [is_lawful_applicative F] [is_lawful_applicative G] {α : Type u} {β : Type u} {γ : Type u}
    (f : β → F γ) (g : α → G β) (x : t' α) :
    equiv.traverse eqv (functor.comp.mk ∘ Functor.map f ∘ g) x =
        functor.comp.mk (equiv.traverse eqv f <$> equiv.traverse eqv g x) :=
  sorry

protected theorem naturality {t : Type u → Type u} {t' : Type u → Type u}
    (eqv : (α : Type u) → t α ≃ t' α) [traversable t] [is_lawful_traversable t]
    {F : Type u → Type u} {G : Type u → Type u} [Applicative F] [Applicative G]
    [is_lawful_applicative F] [is_lawful_applicative G] (η : applicative_transformation F G)
    {α : Type u} {β : Type u} (f : α → F β) (x : t' α) :
    coe_fn η (t' β) (equiv.traverse eqv f x) = equiv.traverse eqv (coe_fn η β ∘ f) x :=
  sorry

/-- The fact that `t` is a lawful traversable functor carries over the
equivalences to `t'`, with the traversable functor structure given by
`equiv.traversable`. -/
protected def is_lawful_traversable {t : Type u → Type u} {t' : Type u → Type u}
    (eqv : (α : Type u) → t α ≃ t' α) [traversable t] [is_lawful_traversable t] :
    is_lawful_traversable t' :=
  is_lawful_traversable.mk (equiv.id_traverse eqv) (equiv.comp_traverse eqv)
    (equiv.traverse_eq_map_id eqv) (equiv.naturality eqv)

/-- If the `traversable t'` instance has the properties that `map`,
`map_const`, and `traverse` are equal to the ones that come from
carrying the traversable functor structure from `t` over the
equivalences, then the the fact `t` is a lawful traversable functor
carries over as well. -/
protected def is_lawful_traversable' {t : Type u → Type u} {t' : Type u → Type u}
    (eqv : (α : Type u) → t α ≃ t' α) [traversable t] [is_lawful_traversable t] [traversable t']
    (h₀ : ∀ {α β : Type u} (f : α → β), Functor.map f = equiv.map eqv f)
    (h₁ :
      ∀ {α β : Type u} (f : β),
        Functor.mapConst f = function.comp (equiv.map eqv) (function.const α) f)
    (h₂ :
      ∀ {F : Type u → Type u} [_inst_7 : Applicative F] [_inst_8 : is_lawful_applicative F]
        {α β : Type u} (f : α → F β), traverse f = equiv.traverse eqv f) :
    is_lawful_traversable t' :=
  is_lawful_traversable.mk sorry sorry sorry sorry

end Mathlib