/-
Copyright (c) 2019 Johan Commelin. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johan Commelin, Floris van Doorn
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.algebra.module.basic
import Mathlib.data.set.finite
import Mathlib.group_theory.submonoid.basic
import Mathlib.PostPort

universes u_1 u_2 u_3 u_4

namespace Mathlib

/-!
# Pointwise addition, multiplication, and scalar multiplication of sets.

This file defines pointwise algebraic operations on sets.
* For a type `α` with multiplication, multiplication is defined on `set α` by taking
  `s * t` to be the set of all `x * y` where `x ∈ s` and `y ∈ t`. Similarly for addition.
* For `α` a semigroup, `set α` is a semigroup.
* If `α` is a (commutative) monoid, we define an alias `set_semiring α` for `set α`, which then
  becomes a (commutative) semiring with union as addition and pointwise multiplication as
  multiplication.
* For a type `β` with scalar multiplication by another type `α`, this
  file defines a scalar multiplication of `set β` by `set α` and a separate scalar
  multiplication of `set β` by `α`.
* We also define pointwise multiplication on `finset`.

Appropriate definitions and results are also transported to the additive theory via `to_additive`.

## Implementation notes
* The following expressions are considered in simp-normal form in a group:
  `(λ h, h * g) ⁻¹' s`, `(λ h, g * h) ⁻¹' s`, `(λ h, h * g⁻¹) ⁻¹' s`, `(λ h, g⁻¹ * h) ⁻¹' s`,
  `s * t`, `s⁻¹`, `(1 : set _)` (and similarly for additive variants).
  Expressions equal to one of these will be simplified.

## Tags

set multiplication, set addition, pointwise addition, pointwise multiplication

-/

namespace set

/-! ### Properties about 1 -/

protected instance has_one {α : Type u_1} [HasOne α] : HasOne (set α) :=
  { one := singleton 1 }

theorem singleton_one {α : Type u_1} [HasOne α] : singleton 1 = 1 :=
  rfl

@[simp] theorem mem_zero {α : Type u_1} {a : α} [HasZero α] : a ∈ 0 ↔ a = 0 :=
  iff.rfl

theorem one_mem_one {α : Type u_1} [HasOne α] : 1 ∈ 1 :=
  Eq.refl 1

@[simp] theorem zero_subset {α : Type u_1} {s : set α} [HasZero α] : 0 ⊆ s ↔ 0 ∈ s :=
  singleton_subset_iff

theorem zero_nonempty {α : Type u_1} [HasZero α] : set.nonempty 0 :=
  Exists.intro 0 rfl

@[simp] theorem image_zero {α : Type u_1} {β : Type u_2} [HasZero α] {f : α → β} : f '' 0 = singleton (f 0) :=
  image_singleton

/-! ### Properties about multiplication -/

protected instance has_add {α : Type u_1} [Add α] : Add (set α) :=
  { add := image2 Add.add }

@[simp] theorem image2_mul {α : Type u_1} {s : set α} {t : set α} [Mul α] : image2 Mul.mul s t = s * t :=
  rfl

theorem mem_add {α : Type u_1} {s : set α} {t : set α} {a : α} [Add α] : a ∈ s + t ↔ ∃ (x : α), ∃ (y : α), x ∈ s ∧ y ∈ t ∧ x + y = a :=
  iff.rfl

theorem mul_mem_mul {α : Type u_1} {s : set α} {t : set α} {a : α} {b : α} [Mul α] (ha : a ∈ s) (hb : b ∈ t) : a * b ∈ s * t :=
  mem_image2_of_mem ha hb

theorem add_image_prod {α : Type u_1} {s : set α} {t : set α} [Add α] : (fun (x : α × α) => prod.fst x + prod.snd x) '' set.prod s t = s + t :=
  image_prod Add.add

@[simp] theorem image_mul_left {α : Type u_1} {t : set α} {a : α} [group α] : (fun (b : α) => a * b) '' t = (fun (b : α) => a⁻¹ * b) ⁻¹' t := sorry

@[simp] theorem image_add_right {α : Type u_1} {t : set α} {b : α} [add_group α] : (fun (a : α) => a + b) '' t = (fun (a : α) => a + -b) ⁻¹' t := sorry

theorem image_add_left' {α : Type u_1} {t : set α} {a : α} [add_group α] : (fun (b : α) => -a + b) '' t = (fun (b : α) => a + b) ⁻¹' t := sorry

theorem image_mul_right' {α : Type u_1} {t : set α} {b : α} [group α] : (fun (a : α) => a * (b⁻¹)) '' t = (fun (a : α) => a * b) ⁻¹' t := sorry

@[simp] theorem preimage_add_left_singleton {α : Type u_1} {a : α} {b : α} [add_group α] : Add.add a ⁻¹' singleton b = singleton (-a + b) :=
  eq.mpr (id (Eq._oldrec (Eq.refl (Add.add a ⁻¹' singleton b = singleton (-a + b))) (Eq.symm image_add_left')))
    (eq.mpr (id (Eq._oldrec (Eq.refl ((fun (b : α) => -a + b) '' singleton b = singleton (-a + b))) image_singleton))
      (Eq.refl (singleton (-a + b))))

@[simp] theorem preimage_mul_right_singleton {α : Type u_1} {a : α} {b : α} [group α] : (fun (_x : α) => _x * a) ⁻¹' singleton b = singleton (b * (a⁻¹)) := sorry

@[simp] theorem preimage_add_left_zero {α : Type u_1} {a : α} [add_group α] : (fun (b : α) => a + b) ⁻¹' 0 = singleton (-a) := sorry

@[simp] theorem preimage_mul_right_one {α : Type u_1} {b : α} [group α] : (fun (a : α) => a * b) ⁻¹' 1 = singleton (b⁻¹) := sorry

theorem preimage_add_left_zero' {α : Type u_1} {a : α} [add_group α] : (fun (b : α) => -a + b) ⁻¹' 0 = singleton a := sorry

theorem preimage_add_right_zero' {α : Type u_1} {b : α} [add_group α] : (fun (a : α) => a + -b) ⁻¹' 0 = singleton b := sorry

@[simp] theorem mul_singleton {α : Type u_1} {s : set α} {b : α} [Mul α] : s * singleton b = (fun (a : α) => a * b) '' s :=
  image2_singleton_right

@[simp] theorem singleton_add {α : Type u_1} {t : set α} {a : α} [Add α] : singleton a + t = (fun (b : α) => a + b) '' t :=
  image2_singleton_left

@[simp] theorem singleton_add_singleton {α : Type u_1} {a : α} {b : α} [Add α] : singleton a + singleton b = singleton (a + b) :=
  image2_singleton

protected instance semigroup {α : Type u_1} [semigroup α] : semigroup (set α) :=
  semigroup.mk Mul.mul sorry

protected instance monoid {α : Type u_1} [monoid α] : monoid (set α) :=
  monoid.mk semigroup.mul sorry 1 sorry sorry

protected theorem mul_comm {α : Type u_1} {s : set α} {t : set α} [comm_semigroup α] : s * t = t * s := sorry

protected instance add_comm_monoid {α : Type u_1} [add_comm_monoid α] : add_comm_monoid (set α) :=
  add_comm_monoid.mk add_monoid.add sorry add_monoid.zero sorry sorry sorry

theorem singleton.is_mul_hom {α : Type u_1} [Mul α] : is_mul_hom singleton :=
  is_mul_hom.mk fun (a b : α) => Eq.symm singleton_mul_singleton

@[simp] theorem empty_add {α : Type u_1} {s : set α} [Add α] : ∅ + s = ∅ :=
  image2_empty_left

@[simp] theorem mul_empty {α : Type u_1} {s : set α} [Mul α] : s * ∅ = ∅ :=
  image2_empty_right

theorem add_subset_add {α : Type u_1} {s₁ : set α} {s₂ : set α} {t₁ : set α} {t₂ : set α} [Add α] (h₁ : s₁ ⊆ t₁) (h₂ : s₂ ⊆ t₂) : s₁ + s₂ ⊆ t₁ + t₂ :=
  image2_subset h₁ h₂

theorem union_add {α : Type u_1} {s : set α} {t : set α} {u : set α} [Add α] : s ∪ t + u = s + u ∪ (t + u) :=
  image2_union_left

theorem mul_union {α : Type u_1} {s : set α} {t : set α} {u : set α} [Mul α] : s * (t ∪ u) = s * t ∪ s * u :=
  image2_union_right

theorem Union_mul_left_image {α : Type u_1} {s : set α} {t : set α} [Mul α] : (Union fun (a : α) => Union fun (H : a ∈ s) => (fun (x : α) => a * x) '' t) = s * t :=
  Union_image_left fun (a x : α) => a * x

theorem Union_mul_right_image {α : Type u_1} {s : set α} {t : set α} [Mul α] : (Union fun (a : α) => Union fun (H : a ∈ t) => (fun (x : α) => x * a) '' s) = s * t :=
  Union_image_right fun (x a : α) => x * a

@[simp] theorem univ_mul_univ {α : Type u_1} [monoid α] : univ * univ = univ := sorry

/-- `singleton` is a monoid hom. -/
def singleton_add_hom {α : Type u_1} [add_monoid α] : α →+ set α :=
  add_monoid_hom.mk singleton sorry sorry

theorem nonempty.add {α : Type u_1} {s : set α} {t : set α} [Add α] : set.nonempty s → set.nonempty t → set.nonempty (s + t) :=
  nonempty.image2

theorem finite.mul {α : Type u_1} {s : set α} {t : set α} [Mul α] (hs : finite s) (ht : finite t) : finite (s * t) :=
  finite.image2 (fun (a b : α) => a * b) hs ht

/-- multiplication preserves finiteness -/
def fintype_mul {α : Type u_1} [Mul α] [DecidableEq α] (s : set α) (t : set α) [hs : fintype ↥s] [ht : fintype ↥t] : fintype ↥(s * t) :=
  set.fintype_image2 (fun (a b : α) => a * b) s t

theorem bdd_above_add {α : Type u_1} [ordered_add_comm_monoid α] {A : set α} {B : set α} : bdd_above A → bdd_above B → bdd_above (A + B) := sorry

/-! ### Properties about inversion -/

protected instance has_inv {α : Type u_1} [has_inv α] : has_inv (set α) :=
  has_inv.mk (preimage has_inv.inv)

@[simp] theorem mem_inv {α : Type u_1} {s : set α} {a : α} [has_inv α] : a ∈ (s⁻¹) ↔ a⁻¹ ∈ s :=
  iff.rfl

theorem inv_mem_inv {α : Type u_1} {s : set α} {a : α} [group α] : a⁻¹ ∈ (s⁻¹) ↔ a ∈ s := sorry

@[simp] theorem inv_preimage {α : Type u_1} {s : set α} [has_inv α] : has_inv.inv ⁻¹' s = (s⁻¹) :=
  rfl

@[simp] theorem image_inv {α : Type u_1} {s : set α} [group α] : has_inv.inv '' s = (s⁻¹) := sorry

@[simp] theorem inter_neg {α : Type u_1} {s : set α} {t : set α} [Neg α] : -(s ∩ t) = -s ∩ -t :=
  preimage_inter

@[simp] theorem union_neg {α : Type u_1} {s : set α} {t : set α} [Neg α] : -(s ∪ t) = -s ∪ -t :=
  preimage_union

@[simp] theorem compl_inv {α : Type u_1} {s : set α} [has_inv α] : sᶜ⁻¹ = (s⁻¹ᶜ) :=
  preimage_compl

@[simp] protected theorem inv_inv {α : Type u_1} {s : set α} [group α] : s⁻¹⁻¹ = s := sorry

@[simp] protected theorem univ_inv {α : Type u_1} [group α] : univ⁻¹ = univ :=
  preimage_univ

@[simp] theorem neg_subset_neg {α : Type u_1} [add_group α] {s : set α} {t : set α} : -s ⊆ -t ↔ s ⊆ t :=
  function.surjective.preimage_subset_preimage_iff (equiv.surjective (equiv.neg α))

theorem neg_subset {α : Type u_1} [add_group α] {s : set α} {t : set α} : -s ⊆ t ↔ s ⊆ -t :=
  eq.mpr (id (Eq._oldrec (Eq.refl (-s ⊆ t ↔ s ⊆ -t)) (Eq.symm (propext neg_subset_neg))))
    (eq.mpr (id (Eq._oldrec (Eq.refl ( --s ⊆ -t ↔ s ⊆ -t)) set.neg_neg)) (iff.refl (s ⊆ -t)))

/-! ### Properties about scalar multiplication -/

/-- Scaling a set: multiplying every element by a scalar. -/
protected instance has_scalar_set {α : Type u_1} {β : Type u_2} [has_scalar α β] : has_scalar α (set β) :=
  has_scalar.mk fun (a : α) => image (has_scalar.smul a)

@[simp] theorem image_smul {α : Type u_1} {β : Type u_2} {a : α} [has_scalar α β] {t : set β} : (fun (x : β) => a • x) '' t = a • t :=
  rfl

theorem mem_smul_set {α : Type u_1} {β : Type u_2} {a : α} {x : β} [has_scalar α β] {t : set β} : x ∈ a • t ↔ ∃ (y : β), y ∈ t ∧ a • y = x :=
  iff.rfl

theorem smul_mem_smul_set {α : Type u_1} {β : Type u_2} {a : α} {y : β} [has_scalar α β] {t : set β} (hy : y ∈ t) : a • y ∈ a • t :=
  Exists.intro y { left := hy, right := rfl }

theorem smul_set_union {α : Type u_1} {β : Type u_2} {a : α} [has_scalar α β] {s : set β} {t : set β} : a • (s ∪ t) = a • s ∪ a • t := sorry

@[simp] theorem smul_set_empty {α : Type u_1} {β : Type u_2} [has_scalar α β] (a : α) : a • ∅ = ∅ :=
  eq.mpr (id (Eq._oldrec (Eq.refl (a • ∅ = ∅)) (Eq.symm image_smul)))
    (eq.mpr (id (Eq._oldrec (Eq.refl ((fun (x : β) => a • x) '' ∅ = ∅)) (image_empty fun (x : β) => a • x))) (Eq.refl ∅))

theorem smul_set_mono {α : Type u_1} {β : Type u_2} {a : α} [has_scalar α β] {s : set β} {t : set β} (h : s ⊆ t) : a • s ⊆ a • t := sorry

/-- Pointwise scalar multiplication by a set of scalars. -/
protected instance has_scalar {α : Type u_1} {β : Type u_2} [has_scalar α β] : has_scalar (set α) (set β) :=
  has_scalar.mk (image2 has_scalar.smul)

@[simp] theorem image2_smul {α : Type u_1} {β : Type u_2} {s : set α} [has_scalar α β] {t : set β} : image2 has_scalar.smul s t = s • t :=
  rfl

theorem mem_smul {α : Type u_1} {β : Type u_2} {s : set α} {x : β} [has_scalar α β] {t : set β} : x ∈ s • t ↔ ∃ (a : α), ∃ (y : β), a ∈ s ∧ y ∈ t ∧ a • y = x :=
  iff.rfl

theorem image_smul_prod {α : Type u_1} {β : Type u_2} {s : set α} [has_scalar α β] {t : set β} : (fun (x : α × β) => prod.fst x • prod.snd x) '' set.prod s t = s • t :=
  image_prod has_scalar.smul

theorem range_smul_range {α : Type u_1} {β : Type u_2} [has_scalar α β] {ι : Type u_3} {κ : Type u_4} (b : ι → α) (c : κ → β) : range b • range c = range fun (p : ι × κ) => b (prod.fst p) • c (prod.snd p) := sorry

theorem singleton_smul {α : Type u_1} {β : Type u_2} {a : α} [has_scalar α β] {t : set β} : singleton a • t = a • t :=
  image2_singleton_left

/-! ### `set α` as a `(∪,*)`-semiring -/

/-- An alias for `set α`, which has a semiring structure given by `∪` as "addition" and pointwise
  multiplication `*` as "multiplication". -/
def set_semiring (α : Type u_1) :=
  set α

/-- The identitiy function `set α → set_semiring α`. -/
/-- The identitiy function `set_semiring α → set α`. -/
protected def up {α : Type u_1} (s : set α) : set_semiring α :=
  s

protected def set_semiring.down {α : Type u_1} (s : set_semiring α) : set α :=
  s

@[simp] protected theorem down_up {α : Type u_1} {s : set α} : set_semiring.down (set.up s) = s :=
  rfl

@[simp] protected theorem up_down {α : Type u_1} {s : set_semiring α} : set.up (set_semiring.down s) = s :=
  rfl

protected instance set_semiring.semiring {α : Type u_1} [monoid α] : semiring (set_semiring α) :=
  semiring.mk (fun (s t : set_semiring α) => s ∪ t) union_assoc ∅ empty_union union_empty union_comm monoid.mul sorry
    monoid.one sorry sorry sorry sorry sorry sorry

protected instance set_semiring.comm_semiring {α : Type u_1} [comm_monoid α] : comm_semiring (set_semiring α) :=
  comm_semiring.mk semiring.add sorry semiring.zero sorry sorry sorry comm_monoid.mul sorry comm_monoid.one sorry sorry
    sorry sorry sorry sorry sorry

/-- A multiplicative action of a monoid on a type β gives also a
 multiplicative action on the subsets of β. -/
protected instance mul_action_set {α : Type u_1} {β : Type u_2} [monoid α] [mul_action α β] : mul_action α (set β) :=
  mul_action.mk sorry sorry

theorem image_add {α : Type u_1} {β : Type u_2} {s : set α} {t : set α} [Add α] [Add β] (m : α → β) [is_add_hom m] : m '' (s + t) = m '' s + m '' t := sorry

theorem preimage_mul_preimage_subset {α : Type u_1} {β : Type u_2} [Mul α] [Mul β] (m : α → β) [is_mul_hom m] {s : set β} {t : set β} : m ⁻¹' s * m ⁻¹' t ⊆ m ⁻¹' (s * t) := sorry

/-- The image of a set under function is a ring homomorphism
with respect to the pointwise operations on sets. -/
def image_hom {α : Type u_1} {β : Type u_2} [monoid α] [monoid β] (f : α →* β) : set_semiring α →+* set_semiring β :=
  ring_hom.mk (image ⇑f) sorry sorry sorry sorry

end set

/-- A nonempty set in a semimodule is scaled by zero to the singleton
containing 0 in the semimodule. -/
theorem zero_smul_set {α : Type u_1} {β : Type u_2} [semiring α] [add_comm_monoid β] [semimodule α β] {s : set β} (h : set.nonempty s) : 0 • s = 0 := sorry

theorem mem_inv_smul_set_iff {α : Type u_1} {β : Type u_2} [field α] [mul_action α β] {a : α} (ha : a ≠ 0) (A : set β) (x : β) : x ∈ a⁻¹ • A ↔ a • x ∈ A := sorry

theorem mem_smul_set_iff_inv_smul_mem {α : Type u_1} {β : Type u_2} [field α] [mul_action α β] {a : α} (ha : a ≠ 0) (A : set β) (x : β) : x ∈ a • A ↔ a⁻¹ • x ∈ A :=
  eq.mpr
    (id (Eq._oldrec (Eq.refl (x ∈ a • A ↔ a⁻¹ • x ∈ A)) (Eq.symm (propext (mem_inv_smul_set_iff (inv_ne_zero ha) A x)))))
    (eq.mpr (id (Eq._oldrec (Eq.refl (x ∈ a • A ↔ x ∈ a⁻¹⁻¹ • A)) (inv_inv' a))) (iff.refl (x ∈ a • A)))

namespace finset

/-- The pointwise product of two finite sets `s` and `t`:
  `st = s ⬝ t = s * t = { x * y | x ∈ s, y ∈ t }`. -/
protected instance has_add {α : Type u_1} [DecidableEq α] [Add α] : Add (finset α) :=
  { add := fun (s t : finset α) => image (fun (p : α × α) => prod.fst p + prod.snd p) (finset.product s t) }

theorem mul_def {α : Type u_1} [DecidableEq α] [Mul α] {s : finset α} {t : finset α} : s * t = image (fun (p : α × α) => prod.fst p * prod.snd p) (finset.product s t) :=
  rfl

theorem mem_add {α : Type u_1} [DecidableEq α] [Add α] {s : finset α} {t : finset α} {x : α} : x ∈ s + t ↔ ∃ (y : α), ∃ (z : α), y ∈ s ∧ z ∈ t ∧ y + z = x := sorry

@[simp] theorem coe_add {α : Type u_1} [DecidableEq α] [Add α] {s : finset α} {t : finset α} : ↑(s + t) = ↑s + ↑t := sorry

theorem mul_mem_mul {α : Type u_1} [DecidableEq α] [Mul α] {s : finset α} {t : finset α} {x : α} {y : α} (hx : x ∈ s) (hy : y ∈ t) : x * y ∈ s * t :=
  eq.mpr (id (propext mem_mul)) (Exists.intro x (Exists.intro y { left := hx, right := { left := hy, right := rfl } }))

theorem add_card_le {α : Type u_1} [DecidableEq α] [Add α] {s : finset α} {t : finset α} : card (s + t) ≤ card s * card t := sorry

theorem mul_card_le {α : Type u_1} [DecidableEq α] [Mul α] {s : finset α} {t : finset α} : card (s * t) ≤ card s * card t := sorry

/-- A finite set `U` contained in the product of two sets `S * S'` is also contained in the product
of two finite sets `T * T' ⊆ S * S'`. -/
theorem subset_add {M : Type u_1} [add_monoid M] {S : set M} {S' : set M} {U : finset M} (f : ↑U ⊆ S + S') : ∃ (T : finset M), ∃ (T' : finset M), ↑T ⊆ S ∧ ↑T' ⊆ S' ∧ U ⊆ T + T' := sorry

end finset

/-! Some lemmas about pointwise multiplication and submonoids. Ideally we put these in
  `group_theory.submonoid.basic`, but currently we cannot because that file is imported by this. -/

namespace submonoid

theorem mul_subset {M : Type u_1} [monoid M] {s : set M} {t : set M} {S : submonoid M} (hs : s ⊆ ↑S) (ht : t ⊆ ↑S) : s * t ⊆ ↑S := sorry

theorem mul_subset_closure {M : Type u_1} [monoid M] {s : set M} {t : set M} {u : set M} (hs : s ⊆ u) (ht : t ⊆ u) : s * t ⊆ ↑(closure u) :=
  mul_subset (set.subset.trans hs subset_closure) (set.subset.trans ht subset_closure)

theorem Mathlib.add_submonoid.coe_add_self_eq {M : Type u_1} [add_monoid M] (s : add_submonoid M) : ↑s + ↑s = ↑s := sorry


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

/-!
# Traversing collections

This file proves basic properties of traversable and applicative functors and defines
`pure_transformation F`, the natural applicative transformation from the identity functor to `F`.

## References

Inspired by [The Essence of the Iterator Pattern][gibbons2009].
-/

universes u

open is_lawful_traversable
open function (hiding comp)
open functor

attribute [functor_norm] is_lawful_traversable.naturality
attribute [simp] is_lawful_traversable.id_traverse

namespace traversable

variable {t : Type u → Type u}
variables [traversable t] [is_lawful_traversable t]
variables F G : Type u → Type u

variables [applicative F] [is_lawful_applicative F]
variables [applicative G] [is_lawful_applicative G]
variables {α β γ : Type u}
variables g : α → F β
variables h : β → G γ
variables f : β → γ

/-- The natural applicative transformation from the identity functor
to `F`, defined by `pure : Π {α}, α → F α`. -/
def pure_transformation : applicative_transformation id F :=
{ app := @pure F _,
  preserves_pure' := λ α x, rfl,
  preserves_seq' := λ α β f x, by { simp only [map_pure, seq_pure], refl } }

@[simp] theorem pure_transformation_apply {α} (x : id α) : pure_transformation F x = pure x := rfl

variables {F G} (x : t β)

lemma map_eq_traverse_id : map f = @traverse t _ _ _ _ _ (id.mk ∘ f) :=
funext $ λ y, (traverse_eq_map_id f y).symm

theorem map_traverse (x : t α) : map f <$> traverse g x = traverse (map f ∘ g) x :=
begin
  rw @map_eq_traverse_id t _ _ _ _ f,
  refine (comp_traverse (id.mk ∘ f) g x).symm.trans _,
  congr, apply comp.applicative_comp_id
end

theorem traverse_map (f : β → F γ) (g : α → β) (x : t α) :
  traverse f (g <$> x) = traverse (f ∘ g) x :=
begin
  rw @map_eq_traverse_id t _ _ _ _ g,
  refine (comp_traverse f (id.mk ∘ g) x).symm.trans _,
  congr, apply comp.applicative_id_comp
end

lemma pure_traverse (x : t α) : traverse pure x = (pure x : F (t α)) :=
by have : traverse pure x = pure (traverse id.mk x) :=
     (naturality (pure_transformation F) id.mk x).symm;
   rwa id_traverse at this

lemma id_sequence (x : t α) : sequence (id.mk <$> x) = id.mk x :=
by simp [sequence, traverse_map, id_traverse]; refl

lemma comp_sequence (x : t (F (G α))) :
  sequence (comp.mk <$> x) = comp.mk (sequence <$> sequence x) :=
by simp [sequence, traverse_map]; rw ← comp_traverse; simp [map_id]

lemma naturality' (η : applicative_transformation F G) (x : t (F α)) :
  η (sequence x) = sequence (@η _ <$> x) :=
by simp [sequence, naturality, traverse_map]

@[functor_norm]
lemma traverse_id : traverse id.mk = (id.mk : t α → id (t α)) :=
by { ext, exact id_traverse _ }

@[functor_norm]
lemma traverse_comp (g : α → F β) (h : β → G γ) :
  traverse (comp.mk ∘ map h ∘ g) =
  (comp.mk ∘ map (traverse h) ∘ traverse g : t α → comp F G (t γ)) :=
by { ext, exact comp_traverse _ _ _ }

lemma traverse_eq_map_id' (f : β → γ) : traverse (id.mk ∘ f) = id.mk ∘ (map f : t β → t γ) :=
by { ext, exact traverse_eq_map_id _ _ }

-- @[functor_norm]
lemma traverse_map' (g : α → β) (h : β → G γ) :
  traverse (h ∘ g) = (traverse h ∘ map g : t α → G (t γ)) :=
by { ext, rw [comp_app, traverse_map] }

lemma map_traverse' (g : α → G β) (h : β → γ) :
  traverse (map h ∘ g) = (map (map h) ∘ traverse g : t α → G (t γ)) :=
by { ext, rw [comp_app, map_traverse] }

lemma naturality_pf (η : applicative_transformation F G) (f : α → F β) :
  traverse (@η _ ∘ f) = @η _ ∘ (traverse f : t α → F (t β)) :=
by { ext, rw [comp_app, naturality] }

end traversable


/-
Copyright (c) 2022 Markus Himmel. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Markus Himmel
-/
import category_theory.limits.preserves.finite

/-!
# Bundled exact functors

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

We say that a functor `F` is left exact if it preserves finite limits, it is right exact if it
preserves finite colimits, and it is exact if it is both left exact and right exact.

In this file, we define the categories of bundled left exact, right exact and exact functors.

-/

universes v₁ v₂ u₁ u₂

open category_theory.limits

namespace category_theory
variables {C : Type u₁} [category.{v₁} C] {D : Type u₂} [category.{v₂} D]

section
variables (C) (D)

/-- Bundled left-exact functors. -/
@[derive category, nolint has_nonempty_instance]
def LeftExactFunctor :=
full_subcategory (λ F : C ⥤ D, nonempty (preserves_finite_limits F))

infixr ` ⥤ₗ `:26 := LeftExactFunctor

/-- A left exact functor is in particular a functor. -/
@[derive full, derive faithful]
def LeftExactFunctor.forget : (C ⥤ₗ D) ⥤ (C ⥤ D) :=
full_subcategory_inclusion _

/-- Bundled right-exact functors. -/
@[derive category, nolint has_nonempty_instance]
def RightExactFunctor :=
full_subcategory (λ F : C ⥤ D, nonempty (preserves_finite_colimits F))

infixr ` ⥤ᵣ `:26 := RightExactFunctor

/-- A right exact functor is in particular a functor. -/
@[derive full, derive faithful]
def RightExactFunctor.forget : (C ⥤ᵣ D) ⥤ (C ⥤ D) :=
full_subcategory_inclusion _

/-- Bundled exact functors. -/
@[derive category, nolint has_nonempty_instance]
def ExactFunctor := full_subcategory
  (λ F : C ⥤ D, nonempty (preserves_finite_limits F) ∧ nonempty (preserves_finite_colimits F))

infixr ` ⥤ₑ `:26 := ExactFunctor

/-- An exact functor is in particular a functor. -/
@[derive full, derive faithful]
def ExactFunctor.forget : (C ⥤ₑ D) ⥤ (C ⥤ D) :=
full_subcategory_inclusion _

/-- Turn an exact functor into a left exact functor. -/
@[derive full, derive faithful]
def LeftExactFunctor.of_exact : (C ⥤ₑ D) ⥤ (C ⥤ₗ D) :=
full_subcategory.map (λ X, and.left)

/-- Turn an exact functor into a left exact functor. -/
@[derive full, derive faithful]
def RightExactFunctor.of_exact : (C ⥤ₑ D) ⥤ (C ⥤ᵣ D) :=
full_subcategory.map (λ X, and.right)

variables {C D}

@[simp] lemma LeftExactFunctor.of_exact_obj (F : C ⥤ₑ D) :
  (LeftExactFunctor.of_exact C D).obj F = ⟨F.1, F.2.1⟩ := rfl
@[simp] lemma RightExactFunctor.of_exact_obj (F : C ⥤ₑ D) :
  (RightExactFunctor.of_exact C D).obj F = ⟨F.1, F.2.2⟩ := rfl

@[simp] lemma LeftExactFunctor.of_exact_map {F G : C ⥤ₑ D} (α : F ⟶ G) :
  (LeftExactFunctor.of_exact C D).map α = α := rfl
@[simp] lemma RightExactFunctor.of_exact_map {F G : C ⥤ₑ D} (α : F ⟶ G) :
  (RightExactFunctor.of_exact C D).map α = α := rfl

@[simp]

@[simp] lemma LeftExactFunctor.forget_map {F G : C ⥤ₗ D} (α : F ⟶ G) :
  (LeftExactFunctor.forget C D).map α = α := rfl
@[simp] lemma RightExactFunctor.forget_map {F G : C ⥤ᵣ D} (α : F ⟶ G) :
  (RightExactFunctor.forget C D).map α = α := rfl
@[simp] lemma ExactFunctor.forget_map {F G : C ⥤ₑ D} (α : F ⟶ G) :
  (ExactFunctor.forget C D).map α = α := rfl

/-- Turn a left exact functor into an object of the category `LeftExactFunctor C D`. -/
def LeftExactFunctor.of (F : C ⥤ D) [preserves_finite_limits F] : C ⥤ₗ D := ⟨F, ⟨infer_instance⟩⟩
/-- Turn a right exact functor into an object of the category `RightExactFunctor C D`. -/
def RightExactFunctor.of (F : C ⥤ D) [preserves_finite_colimits F] : C ⥤ᵣ D :=
⟨F, ⟨infer_instance⟩⟩
/-- Turn an exact functor into an object of the category `ExactFunctor C D`. -/
def ExactFunctor.of (F : C ⥤ D) [preserves_finite_limits F] [preserves_finite_colimits F] :
  C ⥤ₑ D := ⟨F, ⟨⟨infer_instance⟩, ⟨infer_instance⟩⟩⟩

@[simp] lemma LeftExactFunctor.of_fst (F : C ⥤ D) [preserves_finite_limits F] :
  (LeftExactFunctor.of F).obj = F := rfl
@[simp] lemma RightExactFunctor.of_fst (F : C ⥤ D) [preserves_finite_colimits F] :
  (RightExactFunctor.of F).obj = F := rfl
@[simp] lemma ExactFunctor.of_fst (F : C ⥤ D) [preserves_finite_limits F]
  [preserves_finite_colimits F] : (ExactFunctor.of F).obj = F := rfl

lemma LeftExactFunctor.forget_obj_of (F : C ⥤ D) [preserves_finite_limits F] :
  (LeftExactFunctor.forget C D).obj (LeftExactFunctor.of F) = F := rfl
lemma RightExactFunctor.forget_obj_of (F : C ⥤ D) [preserves_finite_colimits F] :
  (RightExactFunctor.forget C D).obj (RightExactFunctor.of F) = F := rfl
lemma ExactFunctor.forget_obj_of (F : C ⥤ D) [preserves_finite_limits F]
  [preserves_finite_colimits F] : (ExactFunctor.forget C D).obj (ExactFunctor.of F) = F := rfl

noncomputable instance (F : C ⥤ₗ D) : preserves_finite_limits F.obj := F.property.some
noncomputable instance (F : C ⥤ᵣ D) : preserves_finite_colimits F.obj := F.property.some
noncomputable instance (F : C ⥤ₑ D) : preserves_finite_limits F.obj := F.property.1.some
noncomputable instance (F : C ⥤ₑ D) : preserves_finite_colimits F.obj := F.property.2.some

end

end category_theory


def is_smooth {α β} (f : α → β) : Prop := sorry

class IsSmooth {α β} (f : α → β) : Prop where
  (proof : is_smooth f)

instance identity : IsSmooth fun a : α => a := sorry
instance const (b : β) : IsSmooth fun a : α => b := sorry
instance swap (f : α → β → γ) [∀ a, IsSmooth (f a)] : IsSmooth (λ b a => f a b) := sorry
instance parm (f : α → β → γ) [IsSmooth f] (b : β) : IsSmooth (λ a => f a b) := sorry
instance comp (f : β → γ) (g : α → β) [IsSmooth f] [IsSmooth g] : IsSmooth (fun a => f (g a)) := sorry
instance diag (f : β → δ → γ) (g : α → β) (h : α → δ) [IsSmooth f] [∀ b, IsSmooth (f b)] [IsSmooth g] [IsSmooth h] : IsSmooth (λ a => f (g a) (h a)) := sorry

example (f : β → δ → γ) [IsSmooth f] (g : α → β) [IsSmooth g] (d : δ) : IsSmooth (λ a => f (g a) d) := by infer_instance
example (f : β → δ → γ) [IsSmooth f] (g : α → β) [IsSmooth g] : IsSmooth (λ a d => f (g a) d) := by infer_instance
example (f : β → δ → γ) [IsSmooth f] (g : α → β) [IsSmooth g] (h : α → α) [IsSmooth h] (d : δ) : IsSmooth (λ a => f (g (h a)) d) := by infer_instance
example (f : α → β → γ) [∀ a, IsSmooth (f a)] : IsSmooth (λ b a => f a b) := by infer_instance
example (f : α → β → γ → δ) [∀ a b, IsSmooth (f a b)] : IsSmooth (λ c b a => f a b c) := by infer_instance
example (f : α → β → γ → δ) [∀ a b, IsSmooth (f a b)] : IsSmooth (λ c a b => f a b c) := by infer_instance
example (f : α → β → γ → δ → ε) [∀ a b c, IsSmooth (f a b c)] : IsSmooth (λ d a b c => f a b c d) := by infer_instance
example (f : α → β → γ) [IsSmooth f] (b : β) : IsSmooth (λ a => f a b) := by infer_instance
example (f : α → β → γ → δ) [IsSmooth f] (b : β) (c : γ) : IsSmooth (λ a => f a b c) := by infer_instance
example (f : α → β → γ → δ) [IsSmooth f] (b : β) : IsSmooth (λ a c => f a b c) := by infer_instance
example (f : α → β → γ → δ) [IsSmooth f] (c : γ) : IsSmooth (λ a b => f a b c) := by infer_instance
example (f : α → β → γ → δ) (b : β) [IsSmooth (λ a => f a b)] : IsSmooth (λ a c => f a b c) := by infer_instance
example (f : α → β → γ) (g : δ → ε → α) (h : δ → ε → β) [IsSmooth f] [∀ a, IsSmooth (f a)] [IsSmooth g] [IsSmooth h] : IsSmooth (λ x y => f (g x y) (h x y)) := by infer_instance
example (f : β → δ → γ) (g : α → β) [IsSmooth f] [∀ b, IsSmooth (f b)] [IsSmooth g] (a : α): IsSmooth (λ (h : α → δ) => f (g a) (h a)) := by infer_instance
example (f : β → δ → γ) (h : α → δ) [IsSmooth f] : IsSmooth (λ (g : α → β) a => f (g a) (h a)) := by infer_instance
example (f : β → δ → γ) [IsSmooth f] (d : δ) : IsSmooth (λ (g : α → β) a => f (g a) d) := by infer_instance
example (f : β → γ) (g : β → β) [IsSmooth f] [IsSmooth g] : IsSmooth (fun x => f (g (g x))) := by infer_instance
example (f : α → β → γ) [∀ a, IsSmooth (f a)] : IsSmooth (λ b a => f a b) := by infer_instance
example (f : α → β → γ → δ) [∀ a b, IsSmooth (f a b)] : IsSmooth (λ c a b => f a b c) := by infer_instance
example (f : α → β → γ → δ → ε) [∀ a b c, IsSmooth (f a b c)] : IsSmooth (λ d a b c => f a b c d) := by infer_instance
example (f : β → δ → γ) [IsSmooth f] (g : α → β) [IsSmooth g] (d : δ) : IsSmooth (λ a => f (g a) d) := by infer_instance
example (f : β → δ → γ) [IsSmooth f] (g : α → β) [IsSmooth g] : IsSmooth (λ a d => f (g a) d) := by infer_instance
example (f : δ → β → γ) [∀ d, IsSmooth (f d)] (g : α → β) [IsSmooth g] : IsSmooth (λ a d => (f d (g a))) := by infer_instance

-- Recall Function.comp is not reducible anymore
instance (f : β → γ) (g : α → β) [IsSmooth f] [IsSmooth g] : IsSmooth (f ∘ g) := by
  delta Function.comp
  infer_instance

example (f : β → γ) (g : α → β) [IsSmooth f] [IsSmooth g] : IsSmooth (f ∘ g) := by infer_instance

example (f : β → γ) [IsSmooth f] : IsSmooth λ (g : α → β) => (f ∘ g) := by
  delta Function.comp
  infer_instance


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

! This file was ported from Lean 3 source module tactic.linarith.datatypes
! leanprover-community/mathlib commit 2558b3b31d33969bb3ef330982ff131533eebfdd
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Tactic.Linarith.Lemmas
import Mathbin.Tactic.Ring

/-!
# Datatypes for `linarith`

Some of the data structures here are used in multiple parts of the tactic.
We split them into their own file.

This file also contains a few convenient auxiliary functions.
-/

initialize
  registerTraceClass.1 `linarith

open Native

namespace Linarith

/-- A shorthand for tracing when the `trace.linarith` option is set to true. -/
unsafe def linarith_trace {α} [has_to_tactic_format α] (s : α) : tactic Unit :=
  tactic.when_tracing `linarith (tactic.trace s)
#align linarith.linarith_trace linarith.linarith_trace

/-- A shorthand for tracing the types of a list of proof terms
when the `trace.linarith` option is set to true.
-/
unsafe def linarith_trace_proofs (s : String := "") (l : List expr) : tactic Unit :=
  tactic.when_tracing `linarith do
    tactic.trace s
    l tactic.infer_type >>= tactic.trace
#align linarith.linarith_trace_proofs linarith.linarith_trace_proofs

/-! ### Linear expressions -/

#print Linarith.Linexp /-
/-- A linear expression is a list of pairs of variable indices and coefficients,
representing the sum of the products of each coefficient with its corresponding variable.

Some functions on `linexp` assume that `n : ℕ` occurs at most once as the first element of a pair,
and that the list is sorted in decreasing order of the first argument.
This is not enforced by the type but the operations here preserve it.
-/
@[reducible]
def Linexp : Type :=
  List (ℕ × ℤ)
#align linarith.linexp Linarith.Linexp
-/

namespace Linexp

/-- Add two `linexp`s together componentwise.
Preserves sorting and uniqueness of the first argument.
-/
unsafe def add : Linexp → Linexp → Linexp
  | [], a => a
  | a, [] => a
  | a@(n1, z1) :: t1, b@(n2, z2) :: t2 =>
    if n1 < n2 then b :: add (a :: t1) t2
    else
      if n2 < n1 then a :: add t1 (b :: t2)
      else
        let sum := z1 + z2
        if Sum = 0 then add t1 t2 else (n1, Sum) :: add t1 t2
#align linarith.linexp.add linarith.linexp.add

#print Linarith.Linexp.scale /-
/-- `l.scale c` scales the values in `l` by `c` without modifying the order or keys. -/
def scale (c : ℤ) (l : Linexp) : Linexp :=
  if c = 0 then [] else if c = 1 then l else l.map fun ⟨n, z⟩ => (n, z * c)
#align linarith.linexp.scale Linarith.Linexp.scale
-/

#print Linarith.Linexp.get /-
/-- `l.get n` returns the value in `l` associated with key `n`, if it exists, and `none` otherwise.
This function assumes that `l` is sorted in decreasing order of the first argument,
that is, it will return `none` as soon as it finds a key smaller than `n`.
-/
def get (n : ℕ) : Linexp → Option ℤ
  | [] => none
  | (a, b) :: t => if a < n then none else if a = n then some b else get t
#align linarith.linexp.get Linarith.Linexp.get
-/

#print Linarith.Linexp.contains /-
/-- `l.contains n` is true iff `n` is the first element of a pair in `l`.
-/
def contains (n : ℕ) : Linexp → Bool :=
  Option.isSome ∘ get n
#align linarith.linexp.contains Linarith.Linexp.contains
-/

#print Linarith.Linexp.zfind /-
/-- `l.zfind n` returns the value associated with key `n` if there is one, and 0 otherwise.
-/
def zfind (n : ℕ) (l : Linexp) : ℤ :=
  match l.get n with
  | none => 0
  | some v => v
#align linarith.linexp.zfind Linarith.Linexp.zfind
-/

#print Linarith.Linexp.vars /-
/-- `l.vars` returns the list of variables that occur in `l`. -/
def vars (l : Linexp) : List ℕ :=
  l.map Prod.fst
#align linarith.linexp.vars Linarith.Linexp.vars
-/

#print Linarith.Linexp.cmp /-
/-- Defines a lex ordering on `linexp`. This function is performance critical.
-/
def cmp : Linexp → Linexp → Ordering
  | [], [] => Ordering.eq
  | [], _ => Ordering.lt
  | _, [] => Ordering.gt
  | (n1, z1) :: t1, (n2, z2) :: t2 =>
    if n1 < n2 then Ordering.lt
    else
      if n2 < n1 then Ordering.gt
      else if z1 < z2 then Ordering.lt else if z2 < z1 then Ordering.gt else cmp t1 t2
#align linarith.linexp.cmp Linarith.Linexp.cmp
-/

end Linexp

/-! ### Inequalities -/

#print Linarith.Ineq /-
/-- The three-element type `ineq` is used to represent the strength of a comparison between
terms. -/
inductive Ineq : Type
  | Eq
  | le
  | lt
  deriving DecidableEq, Inhabited
#align linarith.ineq Linarith.Ineq
-/

namespace Ineq

#print Linarith.Ineq.max /-
/-- `max R1 R2` computes the strength of the sum of two inequalities. If `t1 R1 0` and `t2 R2 0`,
then `t1 + t2 (max R1 R2) 0`.
-/
def max : Ineq → Ineq → Ineq
  | lt, a => lt
  | a, lt => lt
  | le, a => le
  | a, le => le
  | Eq, Eq => eq
#align linarith.ineq.max Linarith.Ineq.max
-/

#print Linarith.Ineq.cmp /-
/-- `ineq` is ordered `eq < le < lt`. -/
def cmp : Ineq → Ineq → Ordering
  | Eq, Eq => Ordering.eq
  | Eq, _ => Ordering.lt
  | le, le => Ordering.eq
  | le, lt => Ordering.lt
  | lt, lt => Ordering.eq
  | _, _ => Ordering.gt
#align linarith.ineq.cmp Linarith.Ineq.cmp
-/

#print Linarith.Ineq.toString /-
/-- Prints an `ineq` as the corresponding infix symbol. -/
def toString : Ineq → String
  | Eq => "="
  | le => "≤"
  | lt => "<"
#align linarith.ineq.to_string Linarith.Ineq.toString
-/

/-- Finds the name of a multiplicative lemma corresponding to an inequality strength. -/
unsafe def to_const_mul_nm : Ineq → Name
  | lt => `` mul_neg
  | le => `` mul_nonpos
  | Eq => `` mul_eq
#align linarith.ineq.to_const_mul_nm linarith.ineq.to_const_mul_nm

instance : ToString Ineq :=
  ⟨Ineq.toString⟩

unsafe instance : has_to_format Ineq :=
  ⟨fun i => Ineq.toString i⟩

end Ineq

/-! ### Comparisons with 0 -/

#print Linarith.Comp /-
/-- The main datatype for FM elimination.
Variables are represented by natural numbers, each of which has an integer coefficient.
Index 0 is reserved for constants, i.e. `coeffs.find 0` is the coefficient of 1.
The represented term is `coeffs.sum (λ ⟨k, v⟩, v * Var[k])`.
str determines the strength of the comparison -- is it < 0, ≤ 0, or = 0?
-/
structure Comp : Type where
  str : Ineq
  coeffs : Linexp
  deriving Inhabited
#align linarith.comp Linarith.Comp
-/

#print Linarith.Comp.vars /-
/-- `c.vars` returns the list of variables that appear in the linear expression contained in `c`. -/
def Comp.vars : Comp → List ℕ :=
  Linexp.vars ∘ Comp.coeffs
#align linarith.comp.vars Linarith.Comp.vars
-/

#print Linarith.Comp.coeffOf /-
/-- `comp.coeff_of c a` projects the coefficient of variable `a` out of `c`. -/
def Comp.coeffOf (c : Comp) (a : ℕ) : ℤ :=
  c.coeffs.zfind a
#align linarith.comp.coeff_of Linarith.Comp.coeffOf
-/

#print Linarith.Comp.scale /-
/-- `comp.scale c n` scales the coefficients of `c` by `n`. -/
def Comp.scale (c : Comp) (n : ℕ) : Comp :=
  { c with coeffs := c.coeffs.scale n }
#align linarith.comp.scale Linarith.Comp.scale
-/

/-- `comp.add c1 c2` adds the expressions represented by `c1` and `c2`.
The coefficient of variable `a` in `c1.add c2`
is the sum of the coefficients of `a` in `c1` and `c2`.
 -/
unsafe def comp.add (c1 c2 : Comp) : Comp :=
  ⟨c1.str.max c2.str, c1.coeffs.add c2.coeffs⟩
#align linarith.comp.add linarith.comp.add

/-- `comp` has a lex order. First the `ineq`s are compared, then the `coeff`s. -/
unsafe def comp.cmp : Comp → Comp → Ordering
  | ⟨str1, coeffs1⟩, ⟨str2, coeffs2⟩ =>
    match str1.cmp str2 with
    | Ordering.lt => Ordering.lt
    | Ordering.gt => Ordering.gt
    | Ordering.eq => coeffs1.cmp coeffs2
#align linarith.comp.cmp linarith.comp.cmp

/-- A `comp` represents a contradiction if its expression has no coefficients and its strength is <,
that is, it represents the fact `0 < 0`.
 -/
unsafe def comp.is_contr (c : Comp) : Bool :=
  c.coeffs.Empty ∧ c.str = Ineq.lt
#align linarith.comp.is_contr linarith.comp.is_contr

unsafe instance comp.to_format : has_to_format Comp :=
  ⟨fun p => to_fmt p.coeffs ++ toString p.str ++ "0"⟩
#align linarith.comp.to_format linarith.comp.to_format

/-! ### Parsing into linear form -/

/-! ### Control -/

/-- A preprocessor transforms a proof of a proposition into a proof of a different propositon.
The return type is `list expr`, since some preprocessing steps may create multiple new hypotheses,
and some may remove a hypothesis from the list.
A "no-op" preprocessor should return its input as a singleton list.
-/
unsafe structure preprocessor : Type where
  Name : String
  transform : expr → tactic (List expr)
#align linarith.preprocessor linarith.preprocessor

/-- Some preprocessors need to examine the full list of hypotheses instead of working item by item.
As with `preprocessor`, the input to a `global_preprocessor` is replaced by, not added to, its
output.
-/
unsafe structure global_preprocessor : Type where
  Name : String
  transform : List expr → tactic (List expr)
#align linarith.global_preprocessor linarith.global_preprocessor

/-- Some preprocessors perform branching case splits. A `branch` is used to track one of these case
splits. The first component, an `expr`, is the goal corresponding to this branch of the split,
given as a metavariable. The `list expr` component is the list of hypotheses for `linarith`
in this branch. Every `expr` in this list should be type correct in the context of the associated
goal.
-/
unsafe def branch : Type :=
  expr × List expr
#align linarith.branch linarith.branch

/-- Some preprocessors perform branching case splits.
A `global_branching_preprocessor` produces a list of branches to run.
Each branch is independent, so hypotheses that appear in multiple branches should be duplicated.
The preprocessor is responsible for making sure that each branch contains the correct goal
metavariable.
-/
unsafe structure global_branching_preprocessor : Type where
  Name : String
  transform : List expr → tactic (List branch)
#align linarith.global_branching_preprocessor linarith.global_branching_preprocessor

/-- A `preprocessor` lifts to a `global_preprocessor` by folding it over the input list.
-/
unsafe def preprocessor.globalize (pp : preprocessor) : global_preprocessor
    where
  Name := pp.Name
  transform :=
    List.foldlM
      (fun ret e => do
        let l' ← pp.transform e
        return (l' ++ ret))
      []
#align linarith.preprocessor.globalize linarith.preprocessor.globalize

/-- A `global_preprocessor` lifts to a `global_branching_preprocessor` by producing only one branch.
-/
unsafe def global_preprocessor.branching (pp : global_preprocessor) : global_branching_preprocessor
    where
  Name := pp.Name
  transform l := do
    let g ← tactic.get_goal
    singleton <$> Prod.mk g <$> pp l
#align linarith.global_preprocessor.branching linarith.global_preprocessor.branching

/-- `process pp l` runs `pp.transform` on `l` and returns the result,
tracing the result if `trace.linarith` is on.
-/
unsafe def global_branching_preprocessor.process (pp : global_branching_preprocessor)
    (l : List expr) : tactic (List branch) := do
  let l ← pp.transform l
  when (l > 1) <| linarith_trace f! "Preprocessing: {pp} has branched, with branches:"
  l fun l => tactic.set_goals [l.1] >> linarith_trace_proofs (toString f! "Preprocessing: {pp}") l.2
  return l
#align linarith.global_branching_preprocessor.process linarith.global_branching_preprocessor.process

unsafe instance preprocessor_to_gb_preprocessor : Coe preprocessor global_branching_preprocessor :=
  ⟨global_preprocessor.branching ∘ preprocessor.globalize⟩
#align linarith.preprocessor_to_gb_preprocessor linarith.preprocessor_to_gb_preprocessor

unsafe instance global_preprocessor_to_gb_preprocessor :
    Coe global_preprocessor global_branching_preprocessor :=
  ⟨global_preprocessor.branching⟩
#align linarith.global_preprocessor_to_gb_preprocessor linarith.global_preprocessor_to_gb_preprocessor

/--
A `certificate_oracle` is a function `produce_certificate : list comp → ℕ → tactic (rb_map ℕ ℕ)`.
`produce_certificate hyps max_var` tries to derive a contradiction from the comparisons in `hyps`
by eliminating all variables ≤ `max_var`.
If successful, it returns a map `coeff : ℕ → ℕ` as a certificate.
This map represents that we can find a contradiction by taking the sum  `∑ (coeff i) * hyps[i]`.

The default `certificate_oracle` used by `linarith` is
`linarith.fourier_motzkin.produce_certificate`.
-/
unsafe def certificate_oracle : Type :=
  List Comp → ℕ → tactic (rb_map ℕ ℕ)
#align linarith.certificate_oracle linarith.certificate_oracle

/- ./././Mathport/Syntax/Translate/Expr.lean:330:4: warning: unsupported (TODO): `[tacs] -/
/-- A configuration object for `linarith`. -/
unsafe structure linarith_config : Type where
  discharger : tactic Unit := sorry
  restrict_type : Option Type := none
  restrict_type_reflect : reflected _ restrict_type := by infer_instance
  exfalso : Bool := true
  Transparency : Tactic.Transparency := reducible
  split_hypotheses : Bool := true
  split_ne : Bool := false
  preprocessors : Option (List global_branching_preprocessor) := none
  oracle : Option certificate_oracle := none
#align linarith.linarith_config linarith.linarith_config

/- ./././Mathport/Syntax/Translate/Expr.lean:330:4: warning: unsupported (TODO): `[tacs] -/
/-- `cfg.update_reducibility reduce_semi` will change the transparency setting of `cfg` to
`semireducible` if `reduce_semi` is true. In this case, it also sets the discharger to `ring!`,
since this is typically needed when using stronger unification.
-/
unsafe def linarith_config.update_reducibility (cfg : linarith_config) (reduce_semi : Bool) :
    linarith_config :=
  if reduce_semi then
    { cfg with
      Transparency := semireducible
      discharger := sorry }
  else cfg
#align linarith.linarith_config.update_reducibility linarith.linarith_config.update_reducibility

/-!
### Auxiliary functions

These functions are used by multiple modules, so we put them here for accessibility.
-/

open Tactic

-- failed to format: unknown constant 'term.pseudo.antiquot'
/--
      `get_rel_sides e` returns the left and right hand sides of `e` if `e` is a comparison,
      and fails otherwise.
      This function is more naturally in the `option` monad, but it is convenient to put in `tactic`
      for compositionality.
       -/
    unsafe
  def
    get_rel_sides
    : expr → tactic ( expr × expr )
    | q( $ ( a ) < $ ( b ) ) => return ( a , b )
      | q( $ ( a ) ≤ $ ( b ) ) => return ( a , b )
      | q( $ ( a ) = $ ( b ) ) => return ( a , b )
      | q( $ ( a ) ≥ $ ( b ) ) => return ( a , b )
      | q( $ ( a ) > $ ( b ) ) => return ( a , b )
      | _ => tactic.failed
#align linarith.get_rel_sides linarith.get_rel_sides

-- failed to format: unknown constant 'term.pseudo.antiquot'
/--
      `parse_into_comp_and_expr e` checks if `e` is of the form `t < 0`, `t ≤ 0`, or `t = 0`.
      If it is, it returns the comparison along with `t`.
       -/
    unsafe
  def
    parse_into_comp_and_expr
    : expr → Option ( Ineq × expr )
    | q( $ ( e ) < 0 ) => ( Ineq.lt , e )
      | q( $ ( e ) ≤ 0 ) => ( Ineq.le , e )
      | q( $ ( e ) = 0 ) => ( Ineq.eq , e )
      | _ => none
#align linarith.parse_into_comp_and_expr linarith.parse_into_comp_and_expr

/- ./././Mathport/Syntax/Translate/Expr.lean:330:4: warning: unsupported (TODO): `[tacs] -/
-- failed to format: unknown constant 'term.pseudo.antiquot'
/--
      `mk_single_comp_zero_pf c h` assumes that `h` is a proof of `t R 0`.
      It produces a pair `(R', h')`, where `h'` is a proof of `c*t R' 0`.
      Typically `R` and `R'` will be the same, except when `c = 0`, in which case `R'` is `=`.
      If `c = 1`, `h'` is the same as `h` -- specifically, it does *not* change the type to `1*t R 0`.
      -/
    unsafe
  def
    mk_single_comp_zero_pf
    ( c : ℕ ) ( h : expr ) : tactic ( Ineq × expr )
    :=
      do
        let tp ← infer_type h
          let some ( iq , e ) ← return <| parse_into_comp_and_expr tp
          if
            c = 0
            then
            do let e' ← mk_app ` ` MulZeroClass.zero_mul [ e ] return ( ineq.eq , e' )
            else
            if
              c = 1
              then
              return ( iq , h )
              else
              do
                let tp ← Prod.snd <$> ( infer_type h >>= get_rel_sides ) >>= infer_type
                  let c ← tp c
                  let cpos ← to_expr ` `( $ ( c ) > 0 )
                  let ( _ , ex ) ← solve_aux cpos sorry
                  let e' ← mk_app iq [ h , ex ]
                  return ( iq , e' )
#align linarith.mk_single_comp_zero_pf linarith.mk_single_comp_zero_pf

end Linarith


import mathlib.combinatorics.simple_graph.basic
import combinatorics.simple_graph.subgraph
import mathlib.logic.relation

attribute [protected] simple_graph.subgraph.mem_edge_set

open function

variables {α β γ V : Type*} {G H : simple_graph V}

namespace simple_graph
namespace subgraph

instance (G : simple_graph V) (H : subgraph G) [decidable_rel H.adj] : decidable_rel H.coe.adj :=
λ a b, ‹decidable_rel H.adj› _ _

@[simp] lemma map_id {G : simple_graph α} (G' : G.subgraph) : G'.map hom.id = G' := by ext; simp

@[simp] lemma map_comp {G : simple_graph α} {H : simple_graph β} {I : simple_graph γ}
  (G' : G.subgraph) (f : G →g H) (g : H →g I) :
  G'.map (g.comp f) = (G'.map f).map g :=
by ext; simp [subgraph.map]

@[simp] lemma edge_set_map {G : simple_graph α} {H : simple_graph β} (f : G →g H)
  (G' : G.subgraph) : (G'.map f).edge_set = sym2.map f '' G'.edge_set :=
begin
  ext e,
  induction e using sym2.ind with a b,
  simp only [mem_edge_set, sym2.exists, relation.map, and_or_distrib_left, exists_or_distrib,
    map_adj, set.mem_image, sym2.map_pair_eq, quotient.eq, sym2.rel_iff],
  refine (or_iff_left_of_imp _).symm,
  rintro ⟨a, b, hab, rfl, rfl⟩,
  exact ⟨b, a, hab.symm, rfl, rfl⟩,
end

@[simp] lemma edge_set_coe {G' : G.subgraph} : G'.coe.edge_set = sym2.map coe ⁻¹' G'.edge_set :=
by { ext e, induction e using sym2.ind with a b, simp }

lemma image_coe_edge_set_coe (G' : G.subgraph) : sym2.map coe '' G'.coe.edge_set = G'.edge_set :=
begin
  rw [edge_set_coe, set.image_preimage_eq_iff],
  rintro e he,
  induction e using sym2.ind with a b,
  rw subgraph.mem_edge_set at he,
  exact ⟨⟦(⟨a, edge_vert _ he⟩, ⟨b, edge_vert _ he.symm⟩)⟧, sym2.map_pair_eq _ _ _⟩,
end

lemma spanning_coe_le (G' : G.subgraph) : G'.spanning_coe ≤ G := λ a b, G'.3

/-- The subgraph of `H` corresponding to a smaller graph `H`. -/
@[simps] def of_le (h : H ≤ G) : G.subgraph :=
{ verts := set.univ,
  adj := H.adj,
  adj_sub := h,
  edge_vert := λ _ _ _, set.mem_univ _,
  symm := H.symm }

/-- The graph isomorphism between the top element of `G.subgraph` and `G`. -/
@[simps] def top_iso : (⊤ : G.subgraph).coe ≃g G :=
{ to_fun := coe,
  inv_fun := λ a, ⟨a, set.mem_univ _⟩,
  left_inv := λ _, subtype.eta _ _,
  right_inv := λ _, rfl,
  map_rel_iff' := λ _ _, iff.rfl }

/-- The isomorphism between a subgraph and its isomorphism under an injective map. -/
@[simps]
noncomputable def iso_map {H : simple_graph β} (f : G →g H) (hf : injective f) (G' : G.subgraph) :
  G'.coe ≃g (G'.map f).coe :=
{ map_rel_iff' := λ a b, by simp [hf],
  ..equiv.set.image f G'.verts hf }

open_locale classical

noncomputable instance [fintype V] : fintype G.subgraph :=
fintype.of_equiv
  {H : set V × (V → V → Prop) // H.2 ≤ G.adj ∧ (∀ a b, H.2 a b → a ∈ H.1) ∧ symmetric H.2}
  { to_fun := λ H, ⟨H.1.1, H.1.2, H.2.1, H.2.2.1, H.2.2.2⟩,
    inv_fun := λ H, ⟨⟨H.1, H.2⟩, λ _ _, H.3, λ _ _, H.4, H.5⟩,
    left_inv := λ _, by ext; refl,
    right_inv := λ _, by ext; refl }

instance [finite V] : finite G.subgraph := by { casesI nonempty_fintype V, apply_instance }

end subgraph
end simple_graph


import category_theory.base
import category_theory.isomorphism

open category_theory
open category_theory.category
local notation f ` ∘ `:80 g:80 := g ≫ f

universes v u

namespace category_theory

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

class wide_subcategory (D : Π {a b : C}, (a ⟶ b) → Prop) : Prop :=
(mem_id {} : ∀ (a : C), D (𝟙 a))
(mem_comp {} : ∀ {a b c : C} {f : a ⟶ b} {g : b ⟶ c}, D f → D g → D (g ∘ f))
export wide_subcategory (mem_id mem_comp)

class replete_wide_subcategory D extends wide_subcategory.{v} C D : Prop :=
(mem_iso {} : ∀ {a b : C} (i : iso a b), D i.hom)
export replete_wide_subcategory (mem_iso)

variables {C}
-- mem_id is redundant when we have mem_iso.
lemma replete_wide_subcategory.mk' {D : Π ⦃a b : C⦄, (a ⟶ b) → Prop}
  (mem_iso : ∀ {a b : C} (i : iso a b), D i.hom)
  (mem_comp : ∀ {a b c : C} {f : a ⟶ b} {g : b ⟶ c}, D f → D g → D (g ∘ f)) :
  replete_wide_subcategory.{v} C D :=
{ mem_id := λ a, mem_iso (iso.refl a),
  mem_comp := @mem_comp,
  mem_iso := @mem_iso }

variables {D : Π ⦃a b : C⦄, (a ⟶ b) → Prop} [replete_wide_subcategory.{v} C D]

lemma mem_of_mem_comp_left {a b c : C} {f : a ⟶ b} (i : iso b c)
  (h : D (i.hom ∘ f)) : D f :=
by convert mem_comp h (mem_iso i.symm); simp

lemma mem_of_mem_comp_right {a b c : C} {f : b ⟶ c} (i : iso a b)
  (h : D (f ∘ i.hom)) : D f :=
by convert mem_comp (mem_iso i.symm) h; simp

lemma mem_iff_mem_of_isomorphic {a b a' b' : C} {f : a ⟶ b} {f' : a' ⟶ b'}
  (i : iso a a') (j : iso b b')
  (e : j.hom ∘ f = f' ∘ i.hom) : D f ↔ D f' :=
iff.intro
  (assume h, have D (j.hom ∘ f), from mem_comp h (mem_iso j),
    by rw e at this; exact mem_of_mem_comp_right i this)
  (assume h, have D (f' ∘ i.hom), from mem_comp (mem_iso i) h,
    by rw ←e at this; exact mem_of_mem_comp_left j this)

end category_theory


import algebra.punit_instances
import topology.algebra.group

import pseudo_normed_group.basic

import hacks_and_tricks.type_pow
import facts

/-!

# profinitely_filtered_pseudo_normed_group

The definition of a profinitely_filtered_pseudo_normed_group, and an API for this
definition.

-/
open pseudo_normed_group
open_locale nnreal big_operators

local attribute [instance] type_pow

-- move this
lemma int.induction_nonneg_or_nonpos {P : ℤ → Prop} (n : ℤ)
  (h₁ : ∀ n : ℕ, P n) (h₂ : ∀ n : ℕ, P (-n)) : P n :=
begin
  rcases le_or_lt 0 n with hn|hn,
  { lift n to ℕ using hn, exact h₁ n },
  { lift (-n) to ℕ using neg_nonneg.mpr hn.le with k hk, simpa only [hk, neg_neg] using h₂ k },
end

/-- A *complete Hausdorff filtered pseudo-normed topological group* is
* an abelian group `M` with an increasing filtration `filtration M c, c : ℝ≥0` such that
* `filtration M c` is a compact Hausdorff (or T2) space
* `M` is pseudo-normed, so `0 ∈ filtration M c`, `-(filtration M c) = filtration M c`,
  and `x₁ ∈ filtration M c₁, x₂ ∈ filtration M c₂ → (x₁ + x₂) ∈ filtration M (c₁ + c₂)`
* (bounded) addition and negation are continuous.

Morphisms are continuous and bounded homomorphisms. -/
class comphaus_filtered_pseudo_normed_group (M : Type*)
  extends pseudo_normed_group M :=
[topology : ∀ c, topological_space (filtration c)]
[t2 : ∀ c, t2_space (filtration c)]
--[td : ∀ c, totally_disconnected_space (filtration c)]
[compact : ∀ c, compact_space (filtration c)]
(continuous_add' : ∀ (c₁ c₂),
  continuous (add' : filtration c₁ × filtration c₂ → filtration (c₁ + c₂)))
(continuous_neg' : ∀ c, continuous (neg' : filtration c → filtration c))
(continuous_cast_le : ∀ (c₁ c₂) [h : fact (c₁ ≤ c₂)],
  continuous (cast_le : filtration c₁ → filtration c₂))

/-- A *profinitely filtered pseudo-normed topological group* is a *complete Hausdorff filtered
pseudo-normed topological group* with the additional requirement that
* `filtration M c` is a profinite set. -/
class profinitely_filtered_pseudo_normed_group (M : Type*)
  extends comphaus_filtered_pseudo_normed_group M :=
[td : ∀ c, totally_disconnected_space (filtration c)]

namespace comphaus_filtered_pseudo_normed_group

variables {M M₁ M₂ M₃ : Type*}
variables [comphaus_filtered_pseudo_normed_group M]
variables [comphaus_filtered_pseudo_normed_group M₁]
variables [comphaus_filtered_pseudo_normed_group M₂]
variables [comphaus_filtered_pseudo_normed_group M₃]

instance (c : ℝ≥0) : topological_space (filtration M c) := topology c
instance (c : ℝ≥0) : t2_space (filtration M c) := t2 c
--instance (c : ℝ≥0) : totally_disconnected_space (filtration M c) := td c
instance (c : ℝ≥0) : compact_space (filtration M c) := compact c

lemma is_closed_map_cast_le (c₁ c₂) [h : fact (c₁ ≤ c₂)] :
  is_closed_map (@pseudo_normed_group.cast_le M _ _ _ h) :=
(continuous_cast_le c₁ c₂).is_closed_map

lemma closed_embedding_cast_le (c₁ c₂) [h : fact (c₁ ≤ c₂)] :
  closed_embedding (@pseudo_normed_group.cast_le M _ _ _ h) :=
closed_embedding_of_continuous_injective_closed
  (continuous_cast_le c₁ c₂) (injective_cast_le c₁ c₂) (is_closed_map_cast_le c₁ c₂)

lemma embedding_cast_le (c₁ c₂) [h : fact (c₁ ≤ c₂)] :
  embedding (@pseudo_normed_group.cast_le M _ _ _ h) :=
(closed_embedding_cast_le c₁ c₂).to_embedding

lemma continuous_add {X : Type*} [topological_space X] (c₁ c₂ : ℝ≥0)
  (f : X → filtration M c₁) (hf : continuous f)
  (g : X → filtration M c₂) (hg : continuous g) :
  continuous (λ x, ⟨f x + g x, add_mem_filtration (f x).2 (g x).2⟩ : X → filtration M (c₁ + c₂)) :=
begin
  have : continuous (λ x, (f x, g x)) := hf.prod_mk hg,
  exact (continuous_add' c₁ c₂).comp this,
end

lemma continuous_neg {X : Type*} [topological_space X] (c : ℝ≥0)
  (f : X → filtration M c) (hf : continuous f) :
  continuous (λ x, ⟨-f x, neg_mem_filtration (f x).2⟩ : X → filtration M c) :=
(continuous_neg' c).comp hf

lemma continuous_nsmul {X : Type*} [topological_space X] (n : ℕ) (c : ℝ≥0)
  (f : X → filtration M c) (hf : continuous f) :
  continuous (λ x, ⟨n • f x, nat_smul_mem_filtration n _ _ (f x).2⟩ : X → filtration M (n * c)) :=
begin
  induction n with n ih,
  { simp only [zero_smul],
    exact @continuous_const _ {x // x ∈ filtration M (↑0 * c)} _ _ ⟨0, zero_mem_filtration _⟩, },
  { simp only [nat.succ_eq_add_one, succ_nsmul'],
    haveI aux1 : fact (↑n * c ≤ n • c) := ⟨by simp only [le_refl, nsmul_eq_mul]⟩,
    haveI aux2 : fact (n • c + c ≤ ↑n.succ * c) := ⟨by simp [le_refl, nsmul_eq_mul, add_mul]⟩,
    exact (continuous_cast_le (n • c + c) ((n.succ) * c)).comp (continuous_add (n • c) c _
      ((continuous_cast_le _ _).comp ih) _ hf), }
end

lemma continuous_zsmul {X : Type*} [topological_space X] (n : ℤ) (c : ℝ≥0)
  (f : X → filtration M c) (hf : continuous f) :
  continuous (λ x, ⟨n • f x, int_smul_mem_filtration n _ _ (f x).2⟩ :
     X → filtration M (n.nat_abs * c)) :=
begin
  induction n using int.induction_nonneg_or_nonpos,
  { simp only [coe_nat_zsmul], exact continuous_nsmul n c f hf },
  { simp only [neg_smul],
    haveI : fact (↑n * c ≤ (-n : ℤ).nat_abs * c) :=
      ⟨by simp only [int.nat_abs_of_nat, int.nat_abs_neg]⟩,
    convert continuous_neg _ _ ((continuous_cast_le (n * c) ((-n : ℤ).nat_abs * c)).comp
      (continuous_nsmul n c f hf)) using 1,
    ext x,
    simp only [coe_cast_le, coe_nat_zsmul, subtype.coe_mk], }
end

end comphaus_filtered_pseudo_normed_group

namespace profinitely_filtered_pseudo_normed_group

variables {M : Type*} [profinitely_filtered_pseudo_normed_group M]

instance (c : ℝ≥0) : totally_disconnected_space (filtration M c) := td c

end profinitely_filtered_pseudo_normed_group

section
set_option old_structure_cmd true

/-- A `comphaus_filtered_pseudo_normed_group_hom` is a morphism between compact hausdorff
  filtered pseudo-normed groups. It is an additive group homomorphism which is bounded
  in the sense that there exist some constant `B` such that the filtrand at level `c`
  for the source is mapped into the filtrand at level `B*c` in the target. -/
structure comphaus_filtered_pseudo_normed_group_hom (M₁ M₂ : Type*)
  [comphaus_filtered_pseudo_normed_group M₁]
  [comphaus_filtered_pseudo_normed_group M₂]
  extends M₁ →+ M₂ :=
(bound' : ∃ C, ∀ c x, x ∈ filtration M₁ c → to_fun x ∈ filtration M₂ (C * c))
(continuous' : ∀ ⦃c₁ c₂⦄ (f₀ : filtration M₁ c₁ → filtration M₂ c₂)
  (h : ∀ x, to_fun ↑x = f₀ x), continuous f₀)

/-- A `strict_comphaus_filtered_pseudo_normed_group_hom` is a strict morphism between compact
  hausdorff filtered pseudo-normed groups. It is an additive group homomorphism which is bounded
  in the strict sense that the filtrand at level `c` for the source is mapped into the filtrand
  at level `c` in the target. -/
structure strict_comphaus_filtered_pseudo_normed_group_hom (M₁ M₂ : Type*)
  [comphaus_filtered_pseudo_normed_group M₁]
  [comphaus_filtered_pseudo_normed_group M₂]
  extends M₁ →+ M₂ :=
(strict' : ∀ c x, x ∈ filtration M₁ c → to_fun x ∈ filtration M₂ c)
(continuous' : ∀ c, continuous (pseudo_normed_group.level to_fun strict' c))

end

attribute [nolint doc_blame] comphaus_filtered_pseudo_normed_group_hom.mk
  comphaus_filtered_pseudo_normed_group_hom.to_add_monoid_hom

namespace comphaus_filtered_pseudo_normed_group_hom

open comphaus_filtered_pseudo_normed_group

variables {M M₁ M₂ M₃ : Type*}
variables [comphaus_filtered_pseudo_normed_group M]
variables [comphaus_filtered_pseudo_normed_group M₁]
variables [comphaus_filtered_pseudo_normed_group M₂]
variables [comphaus_filtered_pseudo_normed_group M₃]
variables (f g : comphaus_filtered_pseudo_normed_group_hom M₁ M₂)

instance : has_coe_to_fun (comphaus_filtered_pseudo_normed_group_hom M₁ M₂) (λ _, M₁ → M₂):=
⟨comphaus_filtered_pseudo_normed_group_hom.to_fun⟩

@[simp] lemma coe_mk (f) (h₁) (h₂) (h₃) (h₄) :
  ⇑(⟨f, h₁, h₂, h₃, h₄⟩ : comphaus_filtered_pseudo_normed_group_hom M₁ M₂) = f :=
rfl

@[simp] lemma mk_to_monoid_hom (f) (h₁) (h₂) (h₃) (h₄) :
  (⟨f, h₁, h₂, h₃, h₄⟩ :
    comphaus_filtered_pseudo_normed_group_hom M₁ M₂).to_add_monoid_hom =
    ⟨f, h₁, h₂⟩ := rfl

@[simp] lemma coe_to_add_monoid_hom : ⇑f.to_add_monoid_hom = f := rfl

@[simp] lemma map_zero : f 0 = 0 := f.to_add_monoid_hom.map_zero

@[simp] lemma map_add (x y) : f (x + y) = f x + f y := f.to_add_monoid_hom.map_add _ _

@[simp] lemma map_sum {ι : Type*} (x : ι → M₁) (s : finset ι) :
  f (∑ i in s, x i) = ∑ i in s, f (x i) :=
f.to_add_monoid_hom.map_sum _ _

@[simp] lemma map_sub (x y) : f (x - y) = f x - f y := f.to_add_monoid_hom.map_sub _ _

@[simp] lemma map_neg (x) : f (-x) = -(f x) := f.to_add_monoid_hom.map_neg _

@[simp] lemma map_zsmul (x) (n : ℤ) : f (n • x) = n • (f x) := f.to_add_monoid_hom.map_zsmul _ _

/-- Make a profinitely filtered pseudo-normed group hom
from a group hom and a proof that it is bounded and continuous. -/
def mk_of_bound (f : M₁ →+ M₂) (C : ℝ≥0)
  (hC : ∀ c, ∃ (H : ∀ x, x ∈ filtration M₁ c → f x ∈ filtration M₂ (C * c)),
    @continuous (filtration M₁ c) (filtration M₂ (C * c)) _ _ (λ x, ⟨f x, H x x.2⟩)) :
  comphaus_filtered_pseudo_normed_group_hom M₁ M₂ :=
{ bound' := ⟨C, λ c, (hC c).some⟩,
  continuous' := λ c₁ c₂ f₀ hf₀,
  begin
    obtain ⟨_, H⟩ := hC c₁,
    haveI : fact ((C * c₁) ≤ max (C * c₁) c₂) := ⟨le_max_left _ _⟩,
    haveI : fact (c₂ ≤ max (C * c₁) c₂) := ⟨le_max_right _ _⟩,
    rw (embedding_cast_le c₂ (max (C * c₁) c₂)).continuous_iff,
    rw (embedding_cast_le (C * c₁) (max (C * c₁) c₂)).continuous_iff at H,
    convert H using 1,
    ext, dsimp, rw ← hf₀, refl
  end,
  .. f }

  /-- Make a profinitely filtered pseudo-normed group hom
from a group hom and a proof that it is bounded and continuous. -/
def mk_of_strict (f : M₁ →+ M₂)
  (h : ∀ c, ∃ (H : ∀ x, x ∈ filtration M₁ c → f x ∈ filtration M₂ c),
    @continuous (filtration M₁ c) (filtration M₂ c) _ _ (λ x, ⟨f x, H x x.2⟩)) :
  comphaus_filtered_pseudo_normed_group_hom M₁ M₂ :=
mk_of_bound f 1 $ λ c,
begin
  obtain ⟨w, H⟩ := h c,
  refine ⟨_, _⟩,
  { simpa only [one_mul] },
  { rwa (embedding_cast_le (1 * c) c).continuous_iff, }
end

/-- Make a profinitely filtered pseudo-normed group hom
from a group hom and a proof that it is bounded and continuous. -/
noncomputable
def mk' (f : M₁ →+ M₂) (h : ∃ C, ∀ c, ∃ (H : ∀ x, x ∈ filtration M₁ c → f x ∈ filtration M₂ (C * c)),
    @continuous (filtration M₁ c) (filtration M₂ (C * c)) _ _ (λ x, ⟨f x, H x x.2⟩)) :
  comphaus_filtered_pseudo_normed_group_hom M₁ M₂ :=
mk_of_bound f h.some h.some_spec

@[simp] lemma coe_mk_of_bound (f : M₁ →+ M₂) (C) (h) : ⇑(mk_of_bound f C h) = f := rfl

@[simp] lemma coe_mk' (f : M₁ →+ M₂) (h) : ⇑(mk' f h) = f := rfl

def strict : Prop := ∀ ⦃c x⦄, x ∈ filtration M₁ c → f x ∈ filtration M₂ c

/-- If `f : comphaus_filtered_pseudo_normed_group_hom M₁ M₂` and `r : ℝ≥0` then
  `f.bound_by r` is the statement that `f` maps the `c`th filtrand of `M₁` into the `r*c`th
  filtrand of `M₂`. -/
def bound_by (C : ℝ≥0) : Prop := ∀ ⦃c x⦄, x ∈ filtration M₁ c → f x ∈ filtration M₂ (C * c)

lemma strict_iff_bound_by_one : f.strict ↔ f.bound_by 1 :=
by simp only [strict, bound_by, one_mul]

variables {f}

lemma bound_by.mono {C₁} (hf : f.bound_by C₁) (C₂ : ℝ≥0) (H : C₁ ≤ C₂) : f.bound_by C₂ :=
λ c x hx, filtration_mono (mul_le_mul' H le_rfl) (hf hx)

lemma strict.bound_by_one (hf : f.strict) : f.bound_by 1 :=
f.strict_iff_bound_by_one.1 hf

lemma bound_by.strict (hf : f.bound_by 1) : f.strict :=
f.strict_iff_bound_by_one.2 hf

variables (f)

lemma bound : ∃ C, f.bound_by C := f.bound'

lemma mk_of_bound_bound_by (f : M₁ →+ M₂) (C) (h) : (mk_of_bound f C h).bound_by C :=
λ c, (h c).some

lemma mk_of_strict_strict (f : M₁ →+ M₂) (h) : (mk_of_strict f h).strict :=
λ c, (h c).some

protected lemma continuous ⦃c₁ c₂⦄ (f₀ : filtration M₁ c₁ → filtration M₂ c₂) (h : ∀ x, f ↑x = f₀ x) :
  continuous f₀ := f.continuous' f₀ h

-- /-- `f.level c` is the function `filtration M₁ c → filtration M₂ c`
-- induced by a `profinitely_filtered_pseudo_normed_group_hom M₁ M₂`. -/
-- @[simps] def level (c : ℝ≥0) (x : filtration M₁ c) : filtration M₂ c := ⟨f x, f.strict x.2⟩

-- lemma level_continuous (c : ℝ≥0) : continuous (f.level c) := f.continuous' c

variables {f g}

@[ext] theorem ext (H : ∀ x, f x = g x) : f = g :=
by cases f; cases g; congr'; exact funext H

instance : has_zero (comphaus_filtered_pseudo_normed_group_hom M₁ M₂) :=
⟨mk_of_bound (0 : M₁ →+ M₂) 0 (λ c, ⟨λ _ _, zero_mem_filtration _, @continuous_const _ _ _ _ 0⟩)⟩

instance : inhabited (comphaus_filtered_pseudo_normed_group_hom M₁ M₂) := ⟨0⟩

lemma zero_bound_by_zero : (0 : comphaus_filtered_pseudo_normed_group_hom M₁ M₂).bound_by 0 :=
mk_of_bound_bound_by _ _ _

lemma coe_inj ⦃f g : comphaus_filtered_pseudo_normed_group_hom M₁ M₂⦄ (h : (f : M₁ → M₂) = g) :
  f = g :=
by cases f; cases g; cases h; refl

/-- The identity function as `profinitely_filtered_pseudo_normed_group_hom`. -/
@[simps] def id : comphaus_filtered_pseudo_normed_group_hom M M :=
mk_of_bound (add_monoid_hom.id _) 1 $
begin
  refine λ c, ⟨_, _⟩,
  { intros, rwa one_mul },
  haveI : fact (1 * c ≤ c) := by { rw one_mul, exact ⟨le_rfl⟩ },
  rw (embedding_cast_le (1 * c) c).continuous_iff,
  convert continuous_id, ext, refl
end

/-- The composition of `profinitely_filtered_pseudo_normed_group_hom`s. -/
@[simps] noncomputable def comp
  (g : comphaus_filtered_pseudo_normed_group_hom M₂ M₃)
  (f : comphaus_filtered_pseudo_normed_group_hom M₁ M₂) :
  comphaus_filtered_pseudo_normed_group_hom M₁ M₃ :=
mk' (g.to_add_monoid_hom.comp f.to_add_monoid_hom) $
begin
  obtain ⟨Cf, hCf⟩ := f.bound,
  obtain ⟨Cg, hCg⟩ := g.bound,
  refine ⟨Cg * Cf, λ c, ⟨_, _⟩⟩,
  { intros x hx, rw mul_assoc, exact hCg (hCf hx) },
  let f₀ : filtration M₁ c → filtration M₂ (Cf * c) := λ x, ⟨f x, hCf x.2⟩,
  have hf₀ : continuous f₀ := f.continuous _ (λ x, rfl),
  let g₀ : filtration M₂ (Cf * c) → filtration M₃ (Cg * (Cf * c)) := λ x, ⟨g x, hCg x.2⟩,
  have hg₀ : continuous g₀ := g.continuous _ (λ x, rfl),
  haveI : fact (Cg * Cf * c ≤ Cg * (Cf * c)) := by { rw mul_assoc, exact ⟨le_rfl⟩ },
  rw (embedding_cast_le (Cg * Cf * c) (Cg * (Cf * c))).continuous_iff,
  exact hg₀.comp hf₀
end

lemma bound_by.id : (id : comphaus_filtered_pseudo_normed_group_hom M M).bound_by 1 :=
begin
  intros c x hx,
  rwa one_mul,
end

lemma bound_by.comp {f' : comphaus_filtered_pseudo_normed_group_hom M₂ M₃} {C₁ C₂ : ℝ≥0}
  (hf : f.bound_by C₁) (hf' : f'.bound_by C₂) : (f'.comp f).bound_by (C₂ * C₁) :=
begin
  intros c x hx,
  rw mul_assoc,
  exact hf' (hf hx),
end

end comphaus_filtered_pseudo_normed_group_hom

namespace strict_comphaus_filtered_pseudo_normed_group_hom

open comphaus_filtered_pseudo_normed_group

variables {M M₁ M₂ M₃ : Type*}
variables [comphaus_filtered_pseudo_normed_group M]
variables [comphaus_filtered_pseudo_normed_group M₁]
variables [comphaus_filtered_pseudo_normed_group M₂]
variables [comphaus_filtered_pseudo_normed_group M₃]
variables (f g : strict_comphaus_filtered_pseudo_normed_group_hom M₁ M₂)

instance : has_coe_to_fun (strict_comphaus_filtered_pseudo_normed_group_hom M₁ M₂) (λ _, M₁ → M₂) :=
⟨strict_comphaus_filtered_pseudo_normed_group_hom.to_fun⟩

@[simp] lemma coe_mk (f) (h₁) (h₂) (h₃) (h₄) :
  ⇑(⟨f, h₁, h₂, h₃, h₄⟩ : strict_comphaus_filtered_pseudo_normed_group_hom M₁ M₂) = f :=
rfl

@[simp] lemma mk_to_monoid_hom (f) (h₁) (h₂) (h₃) (h₄) :
  (⟨f, h₁, h₂, h₃, h₄⟩ :
    strict_comphaus_filtered_pseudo_normed_group_hom M₁ M₂).to_add_monoid_hom =
    ⟨f, h₁, h₂⟩ := rfl

@[simp] lemma coe_to_add_monoid_hom : ⇑f.to_add_monoid_hom = f := rfl

@[simp] lemma map_zero : f 0 = 0 := f.to_add_monoid_hom.map_zero

@[simp] lemma map_add (x y) : f (x + y) = f x + f y := f.to_add_monoid_hom.map_add _ _

@[simp] lemma map_sum {ι : Type*} (x : ι → M₁) (s : finset ι) :
  f (∑ i in s, x i) = ∑ i in s, f (x i) :=
f.to_add_monoid_hom.map_sum _ _

@[simp] lemma map_sub (x y) : f (x - y) = f x - f y := f.to_add_monoid_hom.map_sub _ _

@[simp] lemma map_neg (x) : f (-x) = -(f x) := f.to_add_monoid_hom.map_neg _

@[simp] lemma map_zsmul (x) (n : ℤ) : f (n • x) = n • (f x) := f.to_add_monoid_hom.map_zsmul _ _

/-- Make a strict comphaus filtered pseudo-normed group hom
from a group hom and a proof that it is bounded and continuous. -/
def mk' (f : M₁ →+ M₂)
  (h : ∀ c, ∃ (H : ∀ x, x ∈ filtration M₁ c → f x ∈ filtration M₂ c),
      @continuous (filtration M₁ c) (filtration M₂ c) _ _ (λ x, ⟨f x, H x x.2⟩)) :
  strict_comphaus_filtered_pseudo_normed_group_hom M₁ M₂ :=
{ strict' := λ c x hh, (h c).some x hh,
  continuous' := λ c, (h c).some_spec,
  ..f }

@[simp] lemma coe_mk' (f : M₁ →+ M₂) (h) : ⇑(mk' f h) = f := rfl

lemma strict ⦃c x⦄ : x ∈ filtration M₁ c → f x ∈ filtration M₂ c := f.strict' c x

def level {c} : filtration M₁ c → filtration M₂ c := pseudo_normed_group.level f f.strict c

protected lemma level_continuous (c) : continuous (pseudo_normed_group.level f f.strict c) :=
  f.continuous' _

@[simp] protected lemma level_cast_le' {c₁ c₂} (h : c₁ ≤ c₂) (x : filtration M₁ c₁) :
  (f.level (cast_le' h x)) = cast_le' h (f.level x) := rfl

@[simp] protected lemma level_zero {c} : f.level (0 : filtration M₁ c) = 0 :=
begin
  ext,
  dsimp,
  rw ← f.map_zero,
  refl,
end

@[simp] protected lemma level_neg {c} (x : filtration M₁ c) : f.level (-x) = - (f.level x) :=
begin
  ext,
  dsimp,
  erw ← f.map_neg,
  refl,
end

@[simp] protected lemma level_add {c₁ c₂} (x : filtration M₁ c₁ × filtration M₁ c₂) :
  f.level (add' x) = add' ⟨f.level x.1, f.level x.2⟩ :=
begin
  ext,
  dsimp,
  erw ← f.map_add,
  refl,
end

@[simp] lemma coe_level {c} (x : filtration M₁ c) : (f.level x : M₂) = f x := rfl

variables {f g}

@[ext] theorem ext (H : ∀ x, f x = g x) : f = g :=
by cases f; cases g; congr'; exact funext H

instance : has_zero (strict_comphaus_filtered_pseudo_normed_group_hom M₁ M₂) :=
{ zero :=
  { strict' := λ c x h, pseudo_normed_group.zero_mem_filtration _,
    continuous' := λ c, begin
      let e : filtration M₁ c → filtration M₂ c := λ x,
        ⟨0, pseudo_normed_group.zero_mem_filtration _⟩,
      exact (continuous_const : continuous e),
    end,
    ..(0 : M₁ →+ M₂) } }

instance : inhabited (strict_comphaus_filtered_pseudo_normed_group_hom M₁ M₂) := ⟨0⟩

lemma coe_inj ⦃f g : strict_comphaus_filtered_pseudo_normed_group_hom M₁ M₂⦄
  (h : (f : M₁ → M₂) = g) : f = g :=
by cases f; cases g; cases h; refl

/-- The identity function as `profinitely_filtered_pseudo_normed_group_hom`. -/
@[simps] def id : strict_comphaus_filtered_pseudo_normed_group_hom M M :=
{ strict' := λ c x h, h,
  continuous' := λ c, begin
    convert continuous_id,
    ext, refl,
  end,
  ..(add_monoid_hom.id M) }

/-- The composition of `profinitely_filtered_pseudo_normed_group_hom`s. -/
@[simps] def comp
  (g : strict_comphaus_filtered_pseudo_normed_group_hom M₂ M₃)
  (f : strict_comphaus_filtered_pseudo_normed_group_hom M₁ M₂) :
  strict_comphaus_filtered_pseudo_normed_group_hom M₁ M₃ :=
{ strict' := λ c x h, g.strict $ f.strict h,
  continuous' := λ c, (g.level_continuous c).comp (f.level_continuous c),
  ..(g.to_add_monoid_hom.comp f.to_add_monoid_hom) }

/-- If `f` is a strict morphism between compact hausdorff filtered pseudo-normed groups
  then `f.to_chfpsng_hom` is the corresponding morphism where we forget strictness.  -/
@[simps]
def to_chfpsng_hom (f : strict_comphaus_filtered_pseudo_normed_group_hom M₁ M₂) :
  comphaus_filtered_pseudo_normed_group_hom M₁ M₂ :=
comphaus_filtered_pseudo_normed_group_hom.mk_of_strict f.to_add_monoid_hom $
λ c, ⟨λ x h, f.strict h, f.level_continuous _⟩

lemma to_chfpsng_hom.bound_by_one (f : strict_comphaus_filtered_pseudo_normed_group_hom M₁ M₂) :
  (to_chfpsng_hom f).bound_by 1 := λ c m hmc,
begin
  rw [one_mul],
  exact f.strict hmc,
end

end strict_comphaus_filtered_pseudo_normed_group_hom

namespace comphaus_filtered_pseudo_normed_group_hom

variables {M₁ M₂ : Type*}
variables [comphaus_filtered_pseudo_normed_group M₁]
variables [comphaus_filtered_pseudo_normed_group M₂]

def strict.to_schfpsng_hom {f : comphaus_filtered_pseudo_normed_group_hom M₁ M₂}
  (h : f.strict) :
  strict_comphaus_filtered_pseudo_normed_group_hom M₁ M₂ :=
{ strict' := h,
  continuous' := λ c, f.continuous _ (λ x, rfl),
  ..f.to_add_monoid_hom }

end comphaus_filtered_pseudo_normed_group_hom

namespace punit

instance : profinitely_filtered_pseudo_normed_group punit :=
{ filtration := λ _, set.univ,
  filtration_mono := λ _ _ _, set.subset_univ _,
  zero_mem_filtration := λ _, set.mem_univ _,
  neg_mem_filtration := λ _ _ _, set.mem_univ _,
  add_mem_filtration := λ _ _ _ _ _ _, set.mem_univ _,
  continuous_add' := λ _ _,  continuous_of_discrete_topology,
  continuous_neg' := λ _, continuous_of_discrete_topology,
  continuous_cast_le := λ _ _ _, continuous_of_discrete_topology }

end punit

section continuity

variables {M M₁ M₂ M₃ : Type*}

namespace pseudo_normed_group

/-- Helper function for pseudo-normed groups.
`pow_incl` is the natural inclusion function `(filtration M c)^n → M^n`.
Note that `(filtration M c)^n` is not the same type as `filtration (M^n) c`,
although they are naturally equivalent. -/
def pow_incl {n : ℕ} {c : ℝ≥0} [pseudo_normed_group M] :
  (filtration M c : Type*)^n → M^n :=
λ x j, x j

lemma pow_incl_injective {n : ℕ} {c : ℝ≥0} [pseudo_normed_group M] :
  function.injective (@pow_incl M n c _) :=
λ x y h, funext $ λ j, subtype.coe_injective $ congr_fun h j

@[simp] lemma pow_incl_apply {n : ℕ} {c : ℝ≥0} [pseudo_normed_group M]
  (x : (filtration M c : Type*)^n) (j : fin n) :
  pow_incl x j = x j := rfl

end pseudo_normed_group

open pseudo_normed_group comphaus_filtered_pseudo_normed_group

variables [comphaus_filtered_pseudo_normed_group M]
variables [comphaus_filtered_pseudo_normed_group M₁]
variables [comphaus_filtered_pseudo_normed_group M₂]
variables [comphaus_filtered_pseudo_normed_group M₃]

/-- A function `f : M₁ → M₂` between profinitely filtered pseudo-normed groups
is continuous if it is continuous when restricted to the filtration sets.

Implementation detail: to avoid diamonds of topologies on `filtration M c`
we avoid `topological_space M`.
We therefore give a hands on definition of continuity. -/
def pfpng_ctu (f : M₁ → M₂) : Prop :=
∀ ⦃c₁ c₂⦄ (f₀ : filtration M₁ c₁ → filtration M₂ c₂)
  (h : ∀ x, f ↑x = f₀ x), continuous f₀

section pfpng_ctu

lemma pfpng_ctu_const (y : M₂) : pfpng_ctu (λ x : M₁, y) :=
begin
  intros c₁ c₂ f₀ h,
  suffices : f₀ = λ x, f₀ ⟨0, zero_mem_filtration _⟩,
  { rw this, exact continuous_const },
  ext1 x,
  apply subtype.coe_injective,
  rw [← h, ← h]
end

lemma pfpng_ctu.neg {f : M₁ → M₂} (hf : pfpng_ctu f) :
  pfpng_ctu (-f) :=
begin
  intros c₁ c₂ f₀ h,
  let g := neg' ∘ f₀,
  have hg : f₀ = neg' ∘ g, { ext, simp [neg_neg] },
  rw hg,
  refine (continuous_neg' c₂).comp (hf g _),
  intro x,
  specialize h x,
  simp only [g, ← h, neg_neg, pi.neg_apply, neg'_eq]
end

lemma pfpng_ctu.add {f g : M₁ → M₂} (hf : pfpng_ctu f) (hg : pfpng_ctu g)
  (H : ∀ c₁, ∃ c₂, ∀ x : filtration M₁ c₁, f x ∈ filtration M₂ c₂) :
  pfpng_ctu (f + g) :=
begin
  intros c₁ c₂ fg₀ hfg₀,
  obtain ⟨cf, hcf⟩ := H c₁,
  let f₀ : filtration M₁ c₁ → filtration M₂ cf := λ x, ⟨f x, hcf x⟩,
  have hf₀ : ∀ x, f ↑x = f₀ x := λ x, rfl,
  have f₀_ctu : continuous f₀ := hf f₀ hf₀,
  let cg := cf + c₂,
  haveI : fact (c₂ ≤ cf + cg) :=
    ⟨calc c₂ ≤ cf + c₂        : self_le_add_left _ _
         ... ≤ cf + (cf + c₂) : self_le_add_left _ _⟩,
  have hcg : ∀ x : filtration M₁ c₁, g x ∈ filtration M₂ cg,
  { intros x,
    have : g x = -(f x) + (f + g) x,
    { simp only [pi.add_apply, neg_add_cancel_left] },
    rw this,
    refine add_mem_filtration (neg_mem_filtration $ hcf x) _,
    rw hfg₀,
    exact (fg₀ x).2 },
  let g₀ : filtration M₁ c₁ → filtration M₂ cg := λ x, ⟨g x, hcg x⟩,
  have hg₀ : ∀ x, g ↑x = g₀ x := λ x, rfl,
  have g₀_ctu : continuous g₀ := hg g₀ hg₀,
  have aux := (f₀_ctu.prod_mk g₀_ctu),
  rw (embedding_cast_le c₂ (cf + cg)).continuous_iff,
  convert (continuous_add' cf cg).comp aux using 1,
  ext, dsimp, rw [← hfg₀, pi.add_apply]
end

lemma pfpng_ctu.sub {f g : M₁ → M₂} (hf : pfpng_ctu f) (hg : pfpng_ctu g)
  (H : ∀ c₁, ∃ c₂, ∀ x : filtration M₁ c₁, f x ∈ filtration M₂ c₂) :
  pfpng_ctu (f - g) :=
by { rw [sub_eq_add_neg], exact hf.add (hg.neg) H }

variables (M)

lemma pfpng_ctu_id : pfpng_ctu (@id M) :=
begin
  intros c₁ c₂ f₀ h,
  haveI : fact (c₁ ≤ max c₁ c₂) := ⟨le_max_left _ _⟩,
  haveI : fact (c₂ ≤ max c₁ c₂) := ⟨le_max_right _ _⟩,
  have : @cast_le M _ c₂ (max c₁ c₂) _ ∘ f₀ = cast_le, { ext, dsimp, rw ← h, refl },
  rw [(embedding_cast_le c₂ (max c₁ c₂)).continuous_iff, this],
  exact (embedding_cast_le _ _).continuous
end

lemma pfpng_ctu_smul_nat : ∀ (n : ℕ), pfpng_ctu (λ x : M, n • x)
| 0     := by { simp only [zero_smul], exact pfpng_ctu_const 0 }
| (n+1) := by { simp only [add_smul, one_smul, add_comm],
                exact (pfpng_ctu_id M).add (pfpng_ctu_smul_nat n) (λ c, ⟨c, λ x, x.2⟩) }

lemma pfpng_ctu_smul_int : ∀ (n : ℤ), pfpng_ctu (λ x : M, n • x)
| (n:ℕ)  := by simpa only [coe_nat_zsmul] using pfpng_ctu_smul_nat M n
| -[1+n] := by simpa only [zsmul_neg_succ_of_nat] using (pfpng_ctu_smul_nat M (n + 1)).neg

end pfpng_ctu

end continuity

namespace comphaus_filtered_pseudo_normed_group_hom

variables {M M₁ M₂ : Type*}
variables [comphaus_filtered_pseudo_normed_group M]
variables [comphaus_filtered_pseudo_normed_group M₁]
variables [comphaus_filtered_pseudo_normed_group M₂]

@[simps]
def copy (f : comphaus_filtered_pseudo_normed_group_hom M₁ M₂) (g : M₁ → M₂) (h : g = f) :
  comphaus_filtered_pseudo_normed_group_hom M₁ M₂ :=
{ to_fun := g,
  bound' := by { cases h, exact f.bound },
  continuous' := by { cases h, exact f.continuous' },
  .. f.to_add_monoid_hom.copy g h }

def add (f g : comphaus_filtered_pseudo_normed_group_hom M₁ M₂) :
  comphaus_filtered_pseudo_normed_group_hom M₁ M₂ :=
{ to_fun := f + g,
  bound' :=
  begin
    obtain ⟨Cf, hCf⟩ := f.bound,
    obtain ⟨Cg, hCg⟩ := g.bound,
    refine ⟨Cf + Cg, λ c x hx, _⟩,
    rw add_mul,
    apply add_mem_filtration (hCf hx) (hCg hx),
  end,
  continuous' :=
  begin
    apply pfpng_ctu.add f.continuous g.continuous,
    obtain ⟨Cf, hCf⟩ := f.bound,
    intro c₁,
    refine ⟨Cf * c₁, λ x, hCf x.2⟩,
  end,
  .. f.to_add_monoid_hom + g.to_add_monoid_hom }

def neg (f : comphaus_filtered_pseudo_normed_group_hom M₁ M₂) :
  comphaus_filtered_pseudo_normed_group_hom M₁ M₂ :=
{ to_fun := -f,
  bound' :=
  begin
    obtain ⟨Cf, hCf⟩ := f.bound,
    refine ⟨Cf, λ c x hx, _⟩,
    apply neg_mem_filtration (hCf hx),
  end,
  continuous' := pfpng_ctu.neg f.continuous,
  .. -f.to_add_monoid_hom }

def sub (f g : comphaus_filtered_pseudo_normed_group_hom M₁ M₂) :
  comphaus_filtered_pseudo_normed_group_hom M₁ M₂ :=
(f.add g.neg).copy (f - g) (sub_eq_add_neg _ _)

def nsmul' : Π (n : ℕ) (f : comphaus_filtered_pseudo_normed_group_hom M₁ M₂),
  comphaus_filtered_pseudo_normed_group_hom M₁ M₂
| 0     f := 0
| (n+1) f := f.add (nsmul' n f)

def nsmul (n : ℕ) (f : comphaus_filtered_pseudo_normed_group_hom M₁ M₂) :
  comphaus_filtered_pseudo_normed_group_hom M₁ M₂ :=
(f.nsmul' n).copy (n • f)
begin
  induction n with n ih,
  { rw zero_smul, refl },
  { rw [succ_nsmul, ih], refl },
end

def zsmul' : Π (n : ℤ) (f : comphaus_filtered_pseudo_normed_group_hom M₁ M₂),
  comphaus_filtered_pseudo_normed_group_hom M₁ M₂
| (n:ℕ)  f := f.nsmul n
| -[1+n] f := (f.nsmul (n.succ)).neg

def zsmul (n : ℤ) (f : comphaus_filtered_pseudo_normed_group_hom M₁ M₂) :
  comphaus_filtered_pseudo_normed_group_hom M₁ M₂ :=
(f.zsmul' n).copy (n • f)
begin
  cases n,
  { rw of_nat_zsmul, refl },
  { rw zsmul_neg_succ_of_nat, refl },
end

instance : has_add (comphaus_filtered_pseudo_normed_group_hom M₁ M₂) := ⟨add⟩
instance : has_neg (comphaus_filtered_pseudo_normed_group_hom M₁ M₂) := ⟨neg⟩
instance : has_sub (comphaus_filtered_pseudo_normed_group_hom M₁ M₂) := ⟨sub⟩
instance has_nsmul : has_smul ℕ (comphaus_filtered_pseudo_normed_group_hom M₁ M₂) := ⟨nsmul⟩
instance has_zsmul : has_smul ℤ (comphaus_filtered_pseudo_normed_group_hom M₁ M₂) := ⟨zsmul⟩

instance : add_comm_group (comphaus_filtered_pseudo_normed_group_hom M₁ M₂) :=
function.injective.add_comm_group
  comphaus_filtered_pseudo_normed_group_hom.to_add_monoid_hom
  (λ f g h, by { ext, rw add_monoid_hom.ext_iff at h, exact h x })
  rfl (λ _ _, rfl) (λ _, rfl) (λ _ _, rfl) (λ _ _, rfl) (λ _ _, rfl)

@[simps]
def to_add_monoid_hom_hom : (comphaus_filtered_pseudo_normed_group_hom M₁ M₂) →+ (M₁ →+ M₂) :=
{ to_fun := to_add_monoid_hom,
  map_zero' := rfl,
  map_add' := λ _ _, rfl }

lemma to_add_monoid_hom_hom_injective : function.injective (@to_add_monoid_hom_hom M₁ M₂ _ _) :=
λ f g h, by { ext x, exact add_monoid_hom.congr_fun h x }

lemma bound_by.add {f g : comphaus_filtered_pseudo_normed_group_hom M₁ M₂} {Cf Cg : ℝ≥0}
  (hf : f.bound_by Cf) (hg : g.bound_by Cg) :
  (f + g).bound_by (Cf + Cg) :=
λ c x hx, by { rw add_mul, exact add_mem_filtration (hf hx) (hg hx) }

lemma bound_by.sub {f g : comphaus_filtered_pseudo_normed_group_hom M₁ M₂} {Cf Cg : ℝ≥0}
  (hf : f.bound_by Cf) (hg : g.bound_by Cg) :
  (f - g).bound_by (Cf + Cg) :=
λ c x hx, by { rw add_mul, exact sub_mem_filtration (hf hx) (hg hx) }

lemma bound_by.neg {f : comphaus_filtered_pseudo_normed_group_hom M₁ M₂} {Cf : ℝ≥0}
  (hf : f.bound_by Cf) : (-f).bound_by Cf :=
λ c x hx, neg_mem_filtration (hf hx)

lemma bound_by.nsmul {f : comphaus_filtered_pseudo_normed_group_hom M₁ M₂} {Cf : ℝ≥0}
  (hf : f.bound_by Cf) (n : ℕ) : (n • f).bound_by (n * Cf) :=
λ c x hx, filtration_mono (mul_assoc _ _ _).ge (nat_smul_mem_filtration n _ _ (hf hx))

lemma bound_by.zsmul {f : comphaus_filtered_pseudo_normed_group_hom M₁ M₂} {Cf : ℝ≥0}
  (hf : f.bound_by Cf) (n : ℤ) : (n • f).bound_by (n.nat_abs * Cf) :=
λ c x hx, filtration_mono (mul_assoc _ _ _).ge (int_smul_mem_filtration n _ _ (hf hx))

@[simp] lemma add_apply (f g : comphaus_filtered_pseudo_normed_group_hom M₁ M₂) (x : M₁) :
  (f + g) x = f x + g x := rfl

@[simp] lemma sub_apply (f g : comphaus_filtered_pseudo_normed_group_hom M₁ M₂) (x : M₁) :
  (f - g) x = f x - g x := rfl

@[simp] lemma sum_apply {ι : Type*} (s : finset ι)
  (f : ι → comphaus_filtered_pseudo_normed_group_hom M₁ M₂) (x : M₁) :
  (∑ i in s, f i) x = ∑ i in s, (f i x) :=
begin
  classical, apply finset.induction_on s,
  { simp only [finset.sum_empty], refl },
  { intros i s his IH,
    simp only [finset.sum_insert his, add_apply, IH] }
end

lemma sum_bound_by {ι : Type*} (s : finset ι)
  (f : ι → comphaus_filtered_pseudo_normed_group_hom M₁ M₂)
  (C : ι → ℝ≥0) (hf : ∀ i ∈ s, (f i).bound_by (C i)) :
  (∑ i in s, f i).bound_by (∑ i in s, C i) :=
begin
  classical, revert hf, apply finset.induction_on s,
  { intro, simp only [finset.sum_empty], exact zero_bound_by_zero },
  { intros i s his IH hf,
    simp only [finset.sum_insert his],
    apply (hf _ (s.mem_insert_self i)).add (IH $ λ j hj, hf _ $ finset.mem_insert_of_mem hj) }
end

@[simp] lemma nsmul_apply {M N : Type*}
  [comphaus_filtered_pseudo_normed_group M] [comphaus_filtered_pseudo_normed_group N]
  (n : ℕ) (f : comphaus_filtered_pseudo_normed_group_hom M N) (x : M) :
  (n • f) x = n • (f x) := rfl

@[simp] lemma zero_apply (M N : Type*)
  [comphaus_filtered_pseudo_normed_group M] [comphaus_filtered_pseudo_normed_group N]
  (x : M) :
  (0 : comphaus_filtered_pseudo_normed_group_hom M N) x = 0 := rfl

end comphaus_filtered_pseudo_normed_group_hom

namespace comphaus_filtered_pseudo_normed_group

/-! ## Products -/

section pi

variables {ι : Type*} (M : ι → Type*) [Π i, comphaus_filtered_pseudo_normed_group (M i)]

instance pi_topology (c : ℝ≥0) : topological_space (filtration (Π i, M i) c) :=
topological_space.induced (filtration_pi_equiv M c) $ infer_instance

@[simps apply symm_apply]
def filtration_pi_homeo (c : ℝ≥0) :
  filtration (Π i, M i) c ≃ₜ Π i, filtration (M i) c :=
{ to_fun := λ x i, ⟨x.1 i, x.2 i⟩,
  inv_fun := λ x, ⟨λ i, x i, λ i, (x i).2⟩,
  left_inv := by { rintro ⟨x, hx⟩, refl },
  right_inv := by { intro x, ext, refl },
  continuous_to_fun :=
    begin
      rw continuous_def,
      intros U hU,
      rw is_open_induced_iff,
      refine ⟨U, hU, _⟩,
      refl,
    end,
  continuous_inv_fun :=
    begin
      rw continuous_def,
      rintros s ⟨t, ht, s_eq⟩,
      simpa [← s_eq] using continuous_def.1 _ t ht,
      { rw [filtration_pi_equiv, continuous_def],
        intros U hU,
        simp only [*, equiv.coe_fn_mk, set.preimage_id',
        subtype.coe_eta, subtype.coe_mk] },
    end
    }

instance pi_t2 (c : ℝ≥0) : t2_space (filtration (Π i, M i) c) :=
begin
  have : t2_space (Π i, filtration (M i) c) := infer_instance,
  apply @embedding.t2_space _ _ _ _ this (filtration_pi_homeo M c) (filtration_pi_homeo M c).embedding,
end

/-
instance pi_td (c : ℝ≥0) : totally_disconnected_space (filtration (Π i, M i) c) :=
begin
  obtain ⟨H⟩ : totally_disconnected_space (Π i, filtration (M i) c) := infer_instance,
  rw [← homeomorph.range_coe (filtration_pi_homeo M c), ← set.image_univ] at H,
  exact ⟨embedding.is_totally_disconnected (filtration_pi_homeo M c).embedding H⟩,
end
-/

instance pi_compact (c : ℝ≥0) : compact_space (filtration (Π i, M i) c) :=
begin
  obtain ⟨H⟩ : compact_space (Π i, filtration (M i) c) := infer_instance,
  rw [← (homeomorph.compact_image (filtration_pi_homeo M c).symm), set.image_univ,
    homeomorph.range_coe] at H,
  exact ⟨H⟩,
end

def prod_pi_homeo_pi_prod [Π i, comphaus_filtered_pseudo_normed_group (M i)]
(c₁ c₂ : ℝ≥0) :
 filtration (Π i, M i) c₁ × filtration (Π i, M i) c₂ ≃ₜ Π i, (filtration (M i) c₁ × filtration (M i) c₂) :=
{ to_fun := λ x i, ⟨⟨x.1.1 i, x.1.2 i⟩, ⟨x.2.1 i, x.2.2 i⟩⟩,
  inv_fun := λ x, ⟨⟨λ i, (x i).1.1, λ i, (x i).1.2⟩, ⟨λ i, (x i).2.1, λ i, (x i).2.2⟩⟩,
  left_inv := by {rintro ⟨x, hx⟩, simp only [subtype.coe_eta, subtype.val_eq_coe]},
  right_inv := by { intro x, ext; refl},
  continuous_to_fun :=
  begin
      apply continuous_pi,
      intro i,
      apply continuous.prod_mk,
      have h₁ := (homeomorph.comp_continuous_iff (filtration_pi_homeo M c₁)).mpr continuous_fst,
      exact (continuous_apply i).comp h₁,
      have h₂ := (homeomorph.comp_continuous_iff (filtration_pi_homeo M c₂)).mpr continuous_snd,
      exact (continuous_apply i).comp h₂,
    end,
  continuous_inv_fun :=
    begin
      apply continuous.prod_mk,
      let f₁ : (Π i, (filtration (M i) c₁) × (filtration (M i) c₂)) → (filtration (Π i, M i) c₁)
        := λ x, ⟨λ (i : ι), (x i).fst.val, λ i, (x i).fst.prop⟩,
      have : continuous ((filtration_pi_homeo M c₁) ∘ f₁),
      { apply continuous_pi,
        intro i,
        dsimp [filtration_pi_homeo, f₁],
        simp only [subtype.coe_eta],
        exact continuous_fst.comp (continuous_apply i), },
      exact (homeomorph.comp_continuous_iff (filtration_pi_homeo M c₁)).mp this,
      let f₂ : (Π i, (filtration (M i) c₁) × (filtration (M i) c₂)) → (filtration (Π i, M i) c₂)
        := λ x, ⟨λ (i : ι), (x i).snd.val, λ i, (x i).snd.prop⟩,
      have : continuous ((filtration_pi_homeo M c₂) ∘ f₂),
      { apply continuous_pi,
        intro i,
        dsimp [filtration_pi_homeo, f₂],
        simp only [subtype.coe_eta],
        exact continuous_snd.comp (continuous_apply i), },
      exact (homeomorph.comp_continuous_iff (filtration_pi_homeo M c₂)).mp this,
    end,}

instance pi : comphaus_filtered_pseudo_normed_group (Π i, M i) :=
{ continuous_add' :=
    begin
      intros c₁ c₂,
      rw [← homeomorph.comp_continuous_iff (filtration_pi_homeo M (c₁ + c₂)),
        ← homeomorph.comp_continuous_iff' (prod_pi_homeo_pi_prod M c₁ c₂).symm],
      apply continuous_pi,
      intro i,
      exact (continuous_add' c₁ c₂).comp (continuous_apply i),
    end,
  continuous_neg' :=
    begin
      intro c,
      rw [← homeomorph.comp_continuous_iff (filtration_pi_homeo M c),
        ← homeomorph.comp_continuous_iff' (filtration_pi_homeo M c).symm],
      apply continuous_pi,
      intro i,
      exact (continuous_neg' c).comp (continuous_apply i),
    end,
  continuous_cast_le :=
    begin
      intros c₁ c₂ h,
      rw [← homeomorph.comp_continuous_iff (filtration_pi_homeo M c₂),
        ← homeomorph.comp_continuous_iff' (filtration_pi_homeo M c₁).symm],
      apply continuous_pi,
      intro i,
      have := @continuous_cast_le _ _ _ _ h,
      exact this.comp (continuous_apply i),
    end,
  .. pseudo_normed_group.pi M }

variables {M}

@[simps]
def pi_proj (i : ι) : comphaus_filtered_pseudo_normed_group_hom (Π i, M i) (M i) :=
comphaus_filtered_pseudo_normed_group_hom.mk_of_bound (pi.eval_add_monoid_hom M i) 1 $
begin
  refine λ c, ⟨λ x hx, by { rw one_mul, exact hx i }, _⟩,
  have := ((continuous_apply i).comp (filtration_pi_homeo M c).continuous),
  haveI : fact (c ≤ 1 * c) := by { rw one_mul, exact ⟨le_rfl⟩ },
  rw (embedding_cast_le c (1 * c)).continuous_iff at this,
  convert this using 0,
end

lemma pi_proj_bound_by (i : ι) : (@pi_proj _ M _ i).bound_by 1 :=
comphaus_filtered_pseudo_normed_group_hom.mk_of_bound_bound_by _ _ _

/-- Universal property of the product of profinitely filtered pseudo-normed groups -/
@[simps {fully_applied := ff}]
def pi_lift {N : Type*} [comphaus_filtered_pseudo_normed_group N]
  (f : Π i, comphaus_filtered_pseudo_normed_group_hom N (M i))
  (hf : ∃ C, ∀ i, (f i).bound_by C) :
  comphaus_filtered_pseudo_normed_group_hom N (Π i, M i) :=
{ to_fun := add_monoid_hom.mk_to_pi (λ i, (f i).to_add_monoid_hom),
  bound' := by { obtain ⟨C, hC⟩ := hf, refine ⟨C, λ c x hx i, hC i hx⟩ },
  continuous' :=
  begin
    intros c₁ c₂ f₀ hf₀,
    rw continuous_induced_rng,
    apply continuous_pi,
    intro i,
    let g := function.eval i ∘ filtration_pi_homeo M c₂ ∘ f₀,
    refine (f i).continuous g (λ x, _),
    specialize hf₀ x, rw function.funext_iff at hf₀,
    exact hf₀ i
  end,
  .. add_monoid_hom.mk_to_pi (λ i, (f i).to_add_monoid_hom) }

noncomputable def pi_map {N : ι → Type*} [Π i, comphaus_filtered_pseudo_normed_group (N i)]
  (f : Π i, comphaus_filtered_pseudo_normed_group_hom (M i) (N i))
  (hf : ∃ C, ∀ i, (f i).bound_by C) :
  comphaus_filtered_pseudo_normed_group_hom (Π i, M i) (Π i, N i) :=
pi_lift (λ i, (f i).comp (pi_proj i))
begin
  obtain ⟨C, hC⟩ := hf,
  refine ⟨C, λ i c x hx, hC i _⟩,
  have := pi_proj_bound_by i hx,
  rwa one_mul at this,
end

end pi

end comphaus_filtered_pseudo_normed_group

namespace profinitely_filtered_pseudo_normed_group

/-! ## Products -/

section pi

open comphaus_filtered_pseudo_normed_group

variables {ι : Type*} (M : ι → Type*) [Π i, profinitely_filtered_pseudo_normed_group (M i)]

instance pi_td (c : ℝ≥0) : totally_disconnected_space (filtration (Π i, M i) c) :=
begin
  obtain ⟨H⟩ : totally_disconnected_space (Π i, filtration (M i) c) := infer_instance,
  rw [← homeomorph.range_coe (filtration_pi_homeo M c), ← set.image_univ] at H,
  exact ⟨embedding.is_totally_disconnected (filtration_pi_homeo M c).embedding H⟩,
end

instance pi : profinitely_filtered_pseudo_normed_group (Π i, M i) :=
{ ..(infer_instance : comphaus_filtered_pseudo_normed_group _) }

end pi

end profinitely_filtered_pseudo_normed_group


import PL.pl provability consistency

universe u

namespace pl
open_locale logic_symbol aclogic
open logic formula
variables {A : Type u}

inductive proof : Theory A → formula A → Type u
| mdp : ∀ {T p q}, proof T (p ⟶ q) → proof T p → proof T q
| by_axiom : ∀ {T p}, p ∈ T → proof T p
| verum : ∀ {T}, proof T ⊤
| imply₁ : ∀ {T p q}, proof T (p ⟶ q ⟶ p)
| imply₂ : ∀ {T p q r}, proof T ((p ⟶ q ⟶ r) ⟶ (p ⟶ q) ⟶ p ⟶ r)
| contraposition : ∀ {T p q}, proof T ((∼p ⟶ ∼q) ⟶ q ⟶ p)

def provable (T : Theory A) (p : formula A) : Prop := nonempty (proof T p)

instance : axiomatic_classical_logic' (formula A) :=
{ turnstile := provable,
  classical := λ T,
  { modus_ponens := λ p q ⟨bpq⟩ ⟨bp⟩, ⟨bpq.mdp bp⟩,
    imply₁ := λ p q, ⟨proof.imply₁⟩,
    imply₂ := λ p q r, ⟨proof.imply₂⟩,
    contraposition := λ p q, ⟨proof.contraposition⟩,
    provable_top := ⟨proof.verum⟩,
    bot_eq := by refl,
    and_def := λ p q, rfl,
    or_def := λ p q, rfl },
  by_axiom := λ T p mem, ⟨proof.by_axiom mem⟩ }

open axiomatic_classical_logic' axiomatic_classical_logic

@[elab_as_eliminator]
theorem rec'_on {T : Theory A} {C : formula A → Prop} {p : formula A} (b : T ⊢ p)
  (mdp : ∀ {p q : formula A} (b₁ : T ⊢ p ⟶ q) (b₂ : T ⊢ p), C (p ⟶ q) → C p → C q)
  (by_axiom : ∀ {p : formula A} (mem : p ∈ T), C p)
  (p0 : C ⊤)
  (p1 : ∀ {p q : formula A}, C (p ⟶ q ⟶ p))
  (p2 : ∀ {p q r : formula A}, C ((p ⟶ q ⟶ r) ⟶ (p ⟶ q) ⟶ p ⟶ r))
  (p3 : ∀ {p q : formula A}, C ((∼p ⟶ ∼q) ⟶ q ⟶ p)) :
  C p :=
begin
  rcases b with ⟨b⟩,
  induction b,
  case mdp : T p q bpq bp IHpq IHp { exact mdp ⟨bpq⟩ ⟨bp⟩ (IHpq @mdp @by_axiom) (IHp @mdp @by_axiom) },
  case by_axiom : T p hp { exact by_axiom hp },
  case verum : { exact p0 },
  case imply₁ : { exact p1 },
  case imply₂ : { exact p2 },
  case contraposition { exact p3 }
end

namespace proof
variables {T : Theory A}

def weakening {p} (h : proof T p) {U} (ss : T ⊆ U) : proof U p :=
begin
  induction h,
  case mdp : T p q bpq bp IHpq IHp { exact (IHpq ss).mdp (IHp ss) },
  case by_axiom : T p hp { exact proof.by_axiom (ss hp) },
  case verum : { exact proof.verum },
  case imply₁ : { exact proof.imply₁ },
  case imply₂ : { exact proof.imply₂ },
  case contraposition { exact proof.contraposition }
end

end proof

namespace provable
variables {T : Theory A}

lemma weakening {U} {p} (ss : T ⊆ U) (h : T ⊢ p): U ⊢ p :=
by rcases h; exact ⟨h.weakening ss⟩

def deduction' {p q} (h : insert q T ⊢ p) : T ⊢ q ⟶ p :=
begin
  apply rec'_on h,
  { intros p r _ _ h₁ h₂, exact modus_ponens_hyp h₁ h₂ },
  { rintros p (rfl | hp), { simp }, { exact hyp_right (by_axiom hp) q } },
  { simp },
  { simp },
  { simp },
  { simp }
end

instance : axiomatic_classical_logic (formula A) :=
{ deduction' := λ T p q, deduction',
  weakening := λ T U p, weakening }

theorem proof_conjunction {T : Theory A} {p} :
  T ⊢ p → ∃ P : list (formula A), (∀ p, p ∈ P → T p) ∧ ∅ ⊢ P.conjunction ⟶ p := λ h,
begin
  apply rec'_on h,
  { rintros p q b₁ b₂ ⟨P₁, IH₁, b0₁⟩ ⟨P₂, IH₂, b0₂⟩, refine ⟨P₁ ++ P₂, _, _⟩,
    { simp, rintros r (hr | hr), exact IH₁ r hr, exact IH₂ r hr },
    { have : ∅+{(P₁ ++ P₂).conjunction} ⊢ P₂.conjunction, from deduction.mpr (list_conjunction_weakening (by simp)),
      have lmm₁ : ∅+{(P₁ ++ P₂).conjunction} ⊢ p,
        from (show _ ⊢ P₂.conjunction ⟶ p, from weakening_insert b0₂ _) ⨀ this,
      have : ∅+{(P₁ ++ P₂).conjunction} ⊢ P₁.conjunction, from deduction.mpr (list_conjunction_weakening (by simp)),
      have lmm₂ : ∅+{(P₁ ++ P₂).conjunction} ⊢ p ⟶ q,
      from (show _ ⊢ P₁.conjunction ⟶ p ⟶ q, from weakening_insert b0₁ _) ⨀ this,
      refine deduction.mp (lmm₂ ⨀ lmm₁) } },
  { rintros p hp, refine ⟨[p], by simpa using hp, by simp⟩ },
  { refine ⟨[], by simp, by simp⟩ },
  { intros, refine ⟨[], by simp, by simp⟩ },
  { intros, refine ⟨[], by simp, by simp⟩ },
  { intros, refine ⟨[], by simp, by simp⟩ }
end

instance : Theory.has_finite_character (formula A) :=
Theory.finite_character_of_finite_provable (formula A) (λ T p, proof_conjunction)

def homomorphism {F : Type*} [has_logic_symbol F] [axiomatic_classical_logic F] (f : formula A →ₗ F) {p} :
  T ⊢ p → f '' T ⊢ f p :=
begin
  intros b,
  apply rec'_on b,
  { simp, intros p q h₁ h₂ IH₁ IH₂, exact IH₁ ⨀ IH₂ },
  { intros p hp, exact by_axiom (set.mem_image_of_mem f hp) },
  { simp },
  { simp },
  { simp },
  { simp }
end

end provable

end pl


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

! This file was ported from Lean 3 source module data.nat.cast.with_top
! leanprover-community/mathlib commit 448144f7ae193a8990cb7473c9e9a01990f64ac7
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Algebra.Order.Monoid.WithTop
import Mathbin.Data.Nat.Basic

/-!
# Lemma about the coercion `ℕ → with_bot ℕ`.

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

An orphaned lemma about casting from `ℕ` to `with_bot ℕ`,
exiled here to minimize imports to `data.rat.order` for porting purposes.
-/

#print Nat.cast_withTop /-
theorem Nat.cast_withTop (n : ℕ) : @coe ℕ (WithTop ℕ) (@coeToLift _ _ Nat.castCoe) n = n :=
  rfl
#align nat.cast_with_top Nat.cast_withTop
-/

#print Nat.cast_withBot /-
theorem Nat.cast_withBot (n : ℕ) : @coe ℕ (WithBot ℕ) (@coeToLift _ _ Nat.castCoe) n = n :=
  rfl
#align nat.cast_with_bot Nat.cast_withBot
-/


theorem eq_iff_true_of_subsingleton [Subsingleton α] (x y : α) : x = y ↔ True :=
  ⟨fun _ => ⟨⟩, fun _ => (Subsingleton.elim ..)⟩

attribute [simp] eq_iff_true_of_subsingleton in
example : True := trivial

structure Func' (α : Sort _) (β : Sort _) :=
(toFun    : α → β)

def r : Func' α α := ⟨id⟩

@[simp] theorem r_toFun {α : Sort u_1} (a : α) : Func'.toFun r a = id a := rfl

example (x y : α) (h : x = y) : r.toFun x = y := by simp <;> rw [h]

theorem noissue (x y : α) (h : x = y) : r.toFun x = y := by simp <;> rw [h]


import category_theory.limits.shapes.pullbacks

namespace category_theory

open limits

noncomputable theory

variables {C : Type*} [category C] {X Y Z : C} (f : X ⟶ Y) (g : Y ⟶ Z) [has_pullback (f ≫ g) g]

def pullback.lift_comp :=
pullback.lift (𝟙 _) f (category.id_comp $ f ≫ g)

@[simp, reassoc]
lemma pullback.lift_comp_fst : pullback.lift_comp f g ≫ pullback.fst = 𝟙 _ :=
pullback.lift_fst _ _ _

lemma pullback.lift_comp_snd : pullback.lift_comp f g ≫ pullback.snd = f :=
pullback.lift_snd _ _ _

instance : is_split_mono (pullback.lift_comp f g) :=
⟨⟨⟨_, pullback.lift_comp_fst f g⟩⟩⟩

local attribute [instance] has_pullback_of_right_iso

lemma pullback.fst_lift_comp_has_pullback_aux :
  has_pullback (f ≫ g) (𝟙 Y ≫ g) :=
by rwa category.id_comp

local attribute [instance] pullback.fst_lift_comp_has_pullback_aux

lemma pullback.fst_lift_comp :
  pullback.fst ≫ pullback.lift_comp f g =
    pullback.map_desc f (𝟙 _) g ≫ (pullback.congr_hom rfl (category.id_comp _)).hom :=
begin
  apply pullback.hom_ext; simp only [pullback.congr_hom_hom, pullback.lift_fst,
    pullback.lift_snd, category.assoc, category.comp_id, pullback.condition, pullback.lift_comp],
end

def pullback.lift_comp_iso_map_desc :
  arrow.mk (pullback.lift_comp f g) ≅ arrow.mk (pullback.map_desc f (𝟙 _) g) :=
(arrow.iso_mk' _ _ (as_iso pullback.fst : _) (pullback.congr_hom rfl (category.id_comp _))
  (pullback.fst_lift_comp f g)).symm

end category_theory