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


import language
import data.nat.parity

namespace first_order

section prf

variables {L : language} {n m : ℕ}

inductive Prf (A : Type) [has_coe A (formula L)] : list (formula L) → formula L → Prop
| Axiom : ∀ {Γ : list (formula L)} (a : A) φ, a = φ → Prf Γ φ
| Assumption : ∀ {Γ : list (formula L)} n φ, Γ.nth n = some φ → Prf Γ φ
| Bot_elim : ∀ {Γ : list (formula L)} φ, Prf Γ F → Prf Γ φ
| Not_elim : ∀ {Γ : list (formula L)} φ ψ, Prf Γ ∼φ → Prf Γ φ → Prf Γ ψ
| By_contradiction : ∀ {Γ : list (formula L)} φ, Prf (∼φ::Γ) F → Prf Γ φ
| Or_intro_left : ∀ {Γ : list (formula L)} φ ψ, Prf Γ φ → Prf Γ (φ or ψ)
| Or_intro_right : ∀ {Γ : list (formula L)} φ ψ, Prf Γ ψ → Prf Γ (φ or ψ)
| Or_elim : ∀ {Γ : list (formula L)} φ ψ χ, Prf Γ (φ or ψ) → Prf (φ::Γ) χ → Prf (ψ::Γ) χ → Prf Γ χ
| All_intro : ∀ {Γ : list (formula L)} φ n m, var_not_free_in_axioms_context m A Γ →
    Prf Γ (replace_formula_with n (term.var m) φ) → Prf Γ (formula.all n φ)
| All_elim : ∀ {Γ : list (formula L)} n t φ ψ, Prf Γ (formula.all n φ) →
    substitutable_for t n φ → Prf ((replace_formula_with n t φ) :: Γ) ψ → Prf Γ ψ
| Cut : ∀ {Γ : list (formula L)} φ ψ, Prf Γ φ → Prf (φ::Γ) ψ → Prf Γ ψ

open Prf

notation A ` ∣ ` Γ` ⊢ `φ := Prf A Γ φ

variables {p p₁ p₂ q q₁ q₂ r s φ : formula L}

variables {Γ γ : list (formula L)} {P Q : list (formula L)} {A : Type} [has_coe A (formula L)]

-- Weakening
lemma nth_append_some : ∀ {A : Type} {l1 l2 : list A} n x, l1.nth n = some x → (l1 ++ l2).nth n = some x
| A (y :: l1) l2 0 x h := h
| A (y :: l1) l2 (n+1) x h := @nth_append_some A l1 l2 n x h

lemma nth_cons_some : ∀ {A : Type} {l1 l2 : list A},
  (∀ n x, l1.nth n = some x → ∃ m, l2.nth m = some x) -> ∀ y,
  (∀ n x, (y :: l1).nth n = some x → ∃ m, (y :: l2).nth m = some x) :=
  begin
    intros, cases n, { existsi 0, assumption },
    { simp at *, cases (ᾰ _ _ ᾰ_1),
        existsi w.succ, assumption },
  end

lemma nth_append_r : ∀ {A : Type} {l1 l2 : list A} n, (l1 ++ l2).nth (n + l1.length) = l2.nth n := begin
  intros A l1 l2 n,
  induction l1,
  simp,
  simp,
  rw ← add_assoc,
  rw ← add_comm,
  rw nat.one_add,
  simp,
  apply l1_ih,
end

def weakening : (forall n x, γ.nth n = some x -> ∃ m, Γ.nth m = some x) →
  (A∣γ ⊢ p) → (A∣Γ ⊢ p) := begin
    intros h γp, revert Γ h,
    induction γp, all_goals { intros Γ h },
      sorry,
      { cases (h _ _ γp_ᾰ), apply Assumption, assumption, },
      apply Bot_elim, apply γp_ih, assumption,
      apply Not_elim,
        { apply γp_ih_ᾰ, assumption },
        { apply γp_ih_ᾰ_1, assumption },
      apply By_contradiction, apply γp_ih, apply nth_cons_some, assumption,
      apply Or_intro_left, apply γp_ih, assumption,
      apply Or_intro_right, apply γp_ih, assumption,
      apply Or_elim,
        { apply γp_ih_ᾰ, assumption },
        { apply γp_ih_ᾰ_1, apply nth_cons_some, assumption },
        { apply γp_ih_ᾰ_2, apply nth_cons_some, assumption },
      admit,
      admit,
      apply Cut,
        { apply γp_ih_ᾰ, assumption },
        { apply γp_ih_ᾰ_1, apply nth_cons_some, assumption },
  end

def weakening_append : (A∣γ ⊢ p) → (A∣(γ ++ Γ) ⊢ p) := begin
    apply weakening,
    intros, existsi n,
    apply nth_append_some, assumption,
  end

-- Converting natural deduction rules into sequent calculus rules
def R_ : (A∣[p] ⊢ q) → ((A∣Γ ⊢ p) → (A∣Γ ⊢ q)) := begin
    intros pq Γp,
    apply Cut,
    apply Γp,
    apply weakening _ pq,
    intros n φ pn_eq_φ,
    cases n, simp at pn_eq_φ,
    existsi 0, simp, assumption,
    contradiction,
  end

variables (h : formula L) (l : list (formula L))

def To_Right_Rule_List : (A∣(h::l) ⊢ q) → ∀ Γ : (list (formula L)), (A∣Γ ⊢ h) → (A∣(l ++ Γ) ⊢ q) := begin
    intros h1 Γ h2,
    apply Cut,
    apply weakening _ h2,
    intros n1 h3 h4,
    existsi (n1 + l.length),
    rw nth_append_r,
    apply h4,
    apply weakening,
    intros n2 h5 h6,
    apply nth_cons_some,
    intros n3 h7 h8,
    existsi n3,
    apply nth_append_some,
    apply h8,
    apply h6,
    apply h1,
  end

def L_ : (A∣[p] ⊢ q) → (A∣Γ ⊢ p) → (A∣(q::Γ) ⊢ r) → (A∣Γ ⊢ r) := begin
    intros h1 h2 h3,
    apply Cut,
    apply R_,
    apply h1,
    apply h2,
    apply h3,
  end

def L_R_ : ((A∣Γ ⊢ p) → (A∣Γ ⊢ q)) → (A∣Γ ⊢ p) → (A∣(q::Γ) ⊢ r) → (A∣Γ ⊢ r) := begin
  intros h1 h2 h3,
  apply Cut,
  apply h1,
  apply h2,
  apply h3,
end

def Proves_impl : (A∣(p::Γ) ⊢ q) → (A∣Γ ⊢ (p ⇒ q)) := begin
  intro h, simp,
  apply By_contradiction,
  apply Not_elim,
  apply Assumption 0, refl,
  apply Cut p,
  apply By_contradiction,
  apply Not_elim,
  apply Assumption 1, refl,
  apply Or_intro_left,
  apply Assumption 0, refl,
  apply Or_intro_right,
  apply weakening _ h,
  intros n φ h1,
  cases n,
  existsi 0,
  simp at *,
  apply h1,
  existsi n.succ.succ,
  simp at *,
  apply h1,
end

def R_Not_ : ((A∣Γ ⊢ p) → (A∣Γ ⊢ q)) → ((A∣Γ ⊢ ∼p) → (A∣Γ ⊢ ∼q)) := sorry

def R_Eq_Not_ : ((A∣Γ ⊢ p) ↔ (A∣Γ ⊢ q)) → ((A∣Γ ⊢ ∼p) ↔ (A∣Γ ⊢ ∼q)) := sorry

def R_Left_Or_ : ((A∣Γ ⊢ p) → (A∣Γ ⊢ q)) → ((A∣Γ ⊢ (p or r)) → (A∣Γ ⊢ (q or r))) := sorry

def R_Eq_Left_Or_ : ((A∣Γ ⊢ p) ↔ (A∣Γ ⊢ q)) → ((A∣Γ ⊢ (p or r)) ↔ (A∣Γ ⊢ (q or r))) := sorry

def R_Right_Or_ : ((A∣Γ ⊢ p) → (A∣Γ ⊢ q)) → ((A∣Γ ⊢ (r or p)) → (A∣Γ ⊢ (r or q))) := sorry

def R_Eq_Right_Or_ : ((A∣Γ ⊢ p) ↔ (A∣Γ ⊢ q)) → ((A∣Γ ⊢ (r or p)) ↔ (A∣Γ ⊢ (r or q))) := sorry

def R_Or_ : ((A∣Γ ⊢ p₁) → (A∣Γ ⊢ q₁)) → ((A∣Γ ⊢ p₂) → (A∣Γ ⊢ q₂)) → ((A∣Γ ⊢ (p₁ or p₂)) → ((A∣Γ ⊢ (q₁ or q₂)))) := sorry

def R_Eq_Or_ : ((A∣Γ ⊢ p₁) ↔ (A∣Γ ⊢ q₁)) → ((A∣Γ ⊢ p₂) ↔ (A∣Γ ⊢ q₂)) → ((A∣Γ ⊢ (p₁ or p₂)) ↔ ((A∣Γ ⊢ (q₁ or q₂)))) := sorry

def R_Left_And_ : ((A∣Γ ⊢ p) → (A∣Γ ⊢ q)) → ((A∣Γ ⊢ (p and r)) → (A∣Γ ⊢ (q and r))) := sorry

def R_Eq_Left_And_ : ((A∣Γ ⊢ p) ↔ (A∣Γ ⊢ q)) → ((A∣Γ ⊢ (p and r)) ↔ (A∣Γ ⊢ (q and r))) := sorry

def R_Right_And_ : ((A∣Γ ⊢ p) → (A∣Γ ⊢ q)) → ((A∣Γ ⊢ (r and p)) → (A∣Γ ⊢ (r and q))) := sorry

def R_And_ : ((A∣Γ ⊢ p₁) → (A∣Γ ⊢ q₁)) → ((A∣Γ ⊢ p₂) → (A∣Γ ⊢ q₂)) → ((A∣Γ ⊢ (p₁ and p₂)) → ((A∣Γ ⊢ (q₁ and q₂)))) := sorry

def R_Eq_And_ : ((A∣Γ ⊢ p₁) ↔ (A∣Γ ⊢ q₁)) → ((A∣Γ ⊢ p₂) ↔ (A∣Γ ⊢ q₂)) → ((A∣Γ ⊢ (p₁ and p₂)) ↔ ((A∣Γ ⊢ (q₁ and q₂)))) := sorry

def R_All_ : ((A∣Γ ⊢ p) → (A∣Γ ⊢ q)) → ((A∣Γ ⊢ (all n p)) → (A∣Γ ⊢ (all n q))) := sorry

def R_Eq_All_ : ((A∣Γ ⊢ p) ↔ (A∣Γ ⊢ q)) → ((A∣Γ ⊢ (all n p)) ↔ (A∣Γ ⊢ (all n q))) := sorry

def R_Ex_ : ((A∣Γ ⊢ p) → (A∣Γ ⊢ q)) → ((A∣Γ ⊢ (exi n p)) → (A∣Γ ⊢ (exi n q))) := sorry

def R_Eq_Ex_ : ((A∣Γ ⊢ p) ↔ (A∣Γ ⊢ q)) → ((A∣Γ ⊢ (exi n p)) ↔ (A∣Γ ⊢ (exi n q))) := sorry

-- Basic intro and elim ND rules
def Not_intro : (A∣[(p ⇒ F)] ⊢ ∼p) := begin
    apply Or_elim,
    apply Assumption 0, refl,
    apply Assumption 0, refl,
    apply Bot_elim,
    apply Assumption 0, refl,
  end

def Not_impl : A∣[∼p] ⊢ (p ⇒ F) := begin
  apply Or_intro_left,
  apply Assumption 0, refl,
end

def Impl_not : A∣[(p ⇒ F)] ⊢ ∼p := begin
  apply Or_elim,
  apply Assumption 0, refl,
  apply Assumption 0, refl,
  apply R_ Not_intro,
  apply Assumption 1, refl,
end

def Double_negation_elim : A∣[∼∼p] ⊢ p := begin
    apply (By_contradiction p),
    apply Not_elim,
    apply Assumption 1, refl,
    apply Assumption 0, refl,
  end

def Double_negation_intro : A∣[p] ⊢ ∼∼p := begin
    apply R_ Not_intro,
    apply Proves_impl,
    apply Not_elim,
    apply Assumption 0, refl,
    apply Assumption 1, refl,
  end

def Top_intro : A∣Γ ⊢ T := begin
  apply By_contradiction,
  apply R_ Double_negation_elim,
  apply Assumption 0, refl,
end

def Absurd : (A∣Γ ⊢ p) → (A∣Γ ⊢ ∼p) → (A∣Γ ⊢ q) := sorry

def Impl_elim_ : A∣[p, p ⇒ q] ⊢ q := begin
    apply Or_elim,
    apply Assumption 1, refl,
    apply Not_elim,
    apply Assumption 0, refl,
    apply Assumption 1, refl,
    apply Assumption 0, refl,
  end

def Impl_elim : (A∣Γ ⊢ p) → ((A∣Γ ⊢ (p ⇒ q)) → ((A∣Γ ⊢ q))) := begin
    intros h1 h2,
    apply Cut,
    apply h2,
    apply To_Right_Rule_List _ _ Impl_elim_,
    assumption,
  end

def And_intro : (A∣[p, q] ⊢ (p and q)) := begin
    apply R_ Not_intro,
    apply Proves_impl,
    apply Or_elim,
    apply Assumption 0, refl,
    apply Not_elim,
    apply Assumption 0, refl,
    apply Assumption 2, refl,
    apply Not_elim,
    apply Assumption 0, refl,
    apply Assumption 3, refl,
  end

def And_intro_R : (A∣Γ ⊢ p) → (A∣Γ ⊢ q) → (A∣Γ ⊢ (p and q)) := begin
    intros h1 h2,
    apply Cut,
    apply h2,
    apply To_Right_Rule_List _ _ And_intro,
    apply h1,
  end

def And_elim_left : A∣[(p and q)] ⊢ p := begin
      apply By_contradiction,
      apply Not_elim,
      apply Assumption 1, refl,
      apply Or_intro_left,
      apply Assumption 0, refl,
    end

def And_elim_right : A∣[(p and q)] ⊢ q := begin
      apply By_contradiction,
      apply Not_elim,
      apply Assumption 1, refl,
      apply Or_intro_right,
      apply Assumption 0, refl,
    end

def NonContradiction : A∣[(p and ∼p)] ⊢ F := begin
    apply Not_elim,
    apply And_elim_right,
    apply And_elim_left,
  end

-- DeMorgan laws
def DeMorganNotAnd : A∣[∼(p and q)] ⊢ (∼p or ∼q) := begin
    apply By_contradiction,
    apply Not_elim,
    apply Assumption 1, refl,
    apply Assumption 0, refl,
  end

def DeMorganNotOr : A∣[∼(p or q)] ⊢ (∼p and ∼q) := begin
    apply R_ Not_intro,
    apply Proves_impl,
    apply Not_elim,
    apply Assumption 1, refl,
    apply Or_elim,
    apply Assumption 0, refl,
    apply Or_intro_left,
    apply R_ Double_negation_elim,
    apply Assumption 0, refl,
    apply Or_intro_right,
    apply R_ Double_negation_elim,
    apply Assumption 0, refl,
  end

def ExcludedMiddle : A∣[p] ⊢ (q or ∼q) := begin
  apply By_contradiction,
  apply L_ DeMorganNotOr,
  apply Assumption 0, refl,
  apply L_ And_elim_left,
  apply Assumption 0, refl,
  apply Not_elim,
  apply Assumption 2, refl,
  apply Or_intro_right,
  apply Assumption 0, refl,
end

def DeMorganOr : A∣[(∼p or ∼q)] ⊢ ∼(p and q) := begin
    apply R_ Not_intro,
    apply Proves_impl,
    apply Or_elim,
    apply Assumption 1, refl,
    apply Not_elim,
    apply Assumption 0, refl,
    apply L_ And_elim_left,
    apply Assumption 1, refl,
    apply Not_elim,
    apply Assumption 1, refl,
    apply Assumption 0, refl,
    apply L_ And_elim_right,
    apply Assumption 1, refl,
    apply Not_elim,
    apply Assumption 1, refl,
    apply Assumption 0, refl,
  end

def DeMorganAnd : A∣[(∼p and ∼q)] ⊢ ∼(p or q) := begin
  apply By_contradiction,
  apply L_ Double_negation_elim,
  apply Assumption 0, refl,
  apply Or_elim,
  apply Assumption 0, refl,
  apply L_ And_elim_left,
  apply Assumption 3, refl,
  apply Not_elim,
  apply Assumption 0, refl,
  apply Assumption 1, refl,
  apply L_ And_elim_right,
  apply Assumption 3, refl,
  apply Not_elim,
  apply Assumption 0, refl,
  apply Assumption 1, refl,
end

-- Distribution of and and or
-- TODO: Right now there are 8 distribution rules, is there any way to simplify this?
def DistributionAndOrInLeft : A∣[(r and (p or q))] ⊢ ((r and p) or (r and q)) := begin
    apply L_ And_elim_right,
    apply Assumption 0, refl,
    apply L_ And_elim_left,
    apply Assumption 1, refl,
    apply Or_elim,
    apply Assumption 1, refl,
    apply Or_intro_left,
    apply And_intro_R,
    apply Assumption 1, refl,
    apply Assumption 0, refl,
    apply Or_intro_right,
    apply And_intro_R,
    apply Assumption 1, refl,
    apply Assumption 0, refl,
  end

def DistributionAndOrInRight : A∣[((p or q) and r)] ⊢ ((p and r) or (q and r)) := begin
  apply L_ And_elim_left,
  apply Assumption 0, refl,
  apply L_ And_elim_right,
  apply Assumption 1, refl,
  apply Or_elim,
  apply Assumption 1, refl,
  apply Or_intro_left,
  apply And_intro_R,
  apply Assumption 0, refl,
  apply Assumption 1, refl,
  apply Or_intro_right,
  apply And_intro_R,
  apply Assumption 0, refl,
  apply Assumption 1, refl,
end

def DistributionAndOrOutLeft : A∣[((r and p) or (r and q))] ⊢ (r and (p or q)) := begin
  apply And_intro_R,
  apply Or_elim,
  apply Assumption 0, refl,
  any_goals { by {
    apply L_ And_elim_left,
    repeat { apply Assumption 0, refl, }
  } },
  apply Or_elim,
  apply Assumption 0, refl,
  any_goals { by {
    apply L_ And_elim_right,
    apply Assumption 0, refl,
    { apply Or_intro_left, apply Assumption 0, refl }
      <|>
    { apply Or_intro_right, apply Assumption 0, refl }
  } },
end

def DistributionAndOrOutRight : A∣[((p and r) or (q and r))] ⊢ ((p or q) and r) := begin
  apply And_intro_R,
  apply Or_elim,
  apply Assumption 0, refl,
  any_goals {
    apply L_ And_elim_left,
    apply Assumption 0, refl,
    { apply Or_intro_left, apply Assumption 0, refl }
      <|>
    { apply Or_intro_right, apply Assumption 0, refl }
  },
  apply Or_elim,
  apply Assumption 0, refl,
  all_goals {
    apply L_ And_elim_right,
    repeat { apply Assumption 0, refl },
  },
end

def DistributionOrAndInLeft : A∣[(r or (p and q))] ⊢ ((r or p) and (r or q)) := begin
    apply Or_elim,
    apply Assumption 0, refl,
    apply And_intro_R,
    apply Or_intro_left,
    apply Assumption 0, refl,
    apply Or_intro_left,
    apply Assumption 0, refl,
    apply And_intro_R,
    apply L_ And_elim_left,
    apply Assumption 0, refl,
    apply Or_intro_right,
    apply Assumption 0, refl,
    apply L_ And_elim_right,
    apply Assumption 0, refl,
    apply Or_intro_right,
    apply Assumption 0, refl,
  end

def DistributionOrAndOutRight : A∣[((p or r) and (q or r))] ⊢ ((p and q) or r) := begin
  apply L_ And_elim_left,
  apply Assumption 0, refl,
  apply L_ And_elim_right,
  apply Assumption 1, refl,
  apply Or_elim,
  apply Assumption 0, refl,
  apply Or_elim,
  apply Assumption 2, refl,
  apply Or_intro_left,
  apply And_intro_R,
  apply Assumption 0, refl,
  apply Assumption 1, refl,
  all_goals {
    apply Or_intro_right,
    apply Assumption 0, refl
  },
end

def DistributionOrAndOutLeft : A∣[((r or p) and (r or q))] ⊢ (r or (p and q)) := begin
  apply L_ And_elim_left,
  apply Assumption 0, refl,
  apply L_ And_elim_right,
  apply Assumption 1, refl,
  apply Or_elim,
  apply Assumption 0, refl,
  apply Or_intro_left,
  apply Assumption 0, refl,
  apply Or_elim,
  apply Assumption 2, refl,
  apply Or_intro_left,
  apply Assumption 0, refl,
  apply Or_intro_right,
  apply And_intro_R,
  apply Assumption 0, refl,
  apply Assumption 1, refl,
end

def DistributionOrAndInRight : A∣[((p or q) and r)] ⊢ ((p and r) or (q and r)) := begin
  apply L_ And_elim_left,
  apply Assumption 0, refl,
  apply L_ And_elim_right,
  apply Assumption 1, refl,
  apply Or_elim,
  apply Assumption 1, refl,
  apply Or_intro_left,
  apply And_intro_R,
  apply Assumption 0, refl,
  apply Assumption 1, refl,
  apply Or_intro_right,
  apply And_intro_R,
  apply Assumption 0, refl,
  apply Assumption 1, refl,
end

-- Commutativity rules
def Or_comm : A∣[(p or q)] ⊢ (q or p) := begin
  apply Or_elim,
  apply Assumption 0, refl,
  apply Or_intro_right,
  apply Assumption 0, refl,
  apply Or_intro_left,
  apply Assumption 0, refl,
end

def And_comm_ : A∣[(p and q)] ⊢ (q and p) := begin
  apply And_intro_R,
  apply L_ And_elim_right,
  apply Assumption 0, refl,
  apply Assumption 0, refl,
  apply L_ And_elim_left,
  apply Assumption 0, refl,
  apply Assumption 0, refl,
end

def AndProves : ((A∣Γ ⊢ p)) ∧ ((A∣Γ ⊢ q)) → ((A∣Γ ⊢ (p and q))) := begin
    intros h,
    apply And_intro_R,
    apply and.elim_left h,
    apply and.elim_right h,
  end

def Contrapose : A∣[(p ⇒ q)] ⊢ (∼q ⇒ ∼p) := begin
  simp,
  apply Or_elim,
  apply Assumption 0, refl,
  apply Or_intro_right,
  apply Assumption 0, refl,
  apply Proves_impl,
  apply Not_elim,
  apply Assumption 0, refl,
  apply Assumption 1, refl,
end

def Ex_intro (n : ℕ) (t : term L) (φ : formula L) :
    (A∣Γ ⊢ (replace_formula_with n t φ)) → (A∣Γ ⊢ (exi n φ)) := sorry

-- | All_intro : ∀ {Γ : list (formula L)} φ n m, var_not_free_in_axioms_context m A Γ →
--     Prf Γ (replace_formula_with n (term.var m) φ) → Prf Γ (formula.all n φ)

def Ex_elim (n : ℕ) (t : term L) (φ : formula L) (ψ : formula L) : substitutable_for t n φ →
    (A∣Γ ⊢ (exi n φ)) → (A∣(replace_formula_with n t φ)::Γ ⊢ ψ) → (A∣Γ ⊢ ψ) := sorry

def Ex_rename (n m : ℕ) (φ : formula L) : (A∣Γ ⊢ (exi n φ)) → (A∣Γ ⊢ (exi m φ)) := sorry

def All_To_Ex : A∣[(all n p)] ⊢ ∼(exi n ∼p) := begin
  apply R_ Double_negation_intro,
  apply R_All_ (R_ Double_negation_intro),
  apply Assumption 0, refl,
end

def Ex_To_All : A∣[∼(exi n ∼p)] ⊢ (all n p) := begin
  apply R_All_ (R_ Double_negation_elim),
  apply R_ Double_negation_elim,
  apply Assumption 0, refl,
end

def NotAll : A∣[∼(all n p)] ⊢ (exi n ∼p) := begin
  apply R_Not_ (R_All_ (R_ Double_negation_intro)),
  apply Assumption 0, refl,
end

def AllNot : A∣[(all n ∼p)] ⊢ ∼(exi n p) := begin
  apply R_ Double_negation_intro,
  apply Assumption 0, refl,
end

def NotEx : A∣[∼(exi n p)] ⊢ (all n ∼p) := begin
  apply L_ Double_negation_elim,
  apply Assumption 0, refl,
  apply Assumption 0, refl,
end

def ExNot : A∣[(exi n ∼p)] ⊢ ∼(all n p) := begin
  apply L_R_ (R_Not_ (R_All_ (R_ Double_negation_elim))),
  apply Assumption 0, refl,
  apply Assumption 0, refl,
end

def NotFreeAll : ((@var_not_free_in_axioms L n A _) ∧ ¬(free n p)) → (A∣[p] ⊢ (all n p)) := begin
  intro h,
  apply All_intro,
  split, apply h.left,
  intro m, cases m, simp, apply h.right,
  simp,
  rw replace_formula_with_idem,
  apply Assumption 0, refl,
end

def AddAll : ¬(free n p) → ((A∣Γ ⊢ p) → (A∣Γ ⊢ (all n p))) := sorry

def RemoveAll : (A∣Γ ⊢ (all n p)) → (A∣Γ ⊢ p) := sorry

def AddEx : (A∣Γ ⊢ p) → (A∣Γ ⊢ (exi n p)) := sorry

def RemoveEx : ¬(free n p) → ((A∣Γ ⊢ (exi n p)) → (A∣Γ ⊢ p)) := sorry

def AllOrOut : (@var_not_free_in_axioms L n A _) → A∣[((all n p) or (all n q))] ⊢ (all n (p or q)) := begin
  intro h,
  apply All_intro _ _ n,
  split, assumption,
  intro m, cases m, simp, simp,
  rw replace_formula_with_idem,
  apply Or_elim, apply Assumption 0, refl,
  all_goals {
    apply All_elim n (v n),
    apply Assumption 0, refl,
    apply substitutable_for_idem,
    rw replace_formula_with_idem,
    { apply Or_intro_left, apply Assumption 0, refl }
      <|>
    { apply Or_intro_right, apply Assumption 0, refl }
  },
end

def AllAndIn : (@var_not_free_in_axioms L n A _) → A∣[all n (p and q)] ⊢ ((all n p) and (all n q)) := begin
  intro h,
  apply AndProves, split,
  all_goals {
    apply All_intro _ _ n,
    split, assumption,
    intro m, cases m, simp, simp,
    apply All_elim n (v n),
      apply Assumption 0, refl,
      apply substitutable_for_idem,
      rw replace_formula_with_idem,
      rw replace_formula_with_idem,
      { apply R_ And_elim_right, apply Assumption 0, refl }
        <|>
      { apply R_ And_elim_left, apply Assumption 0, refl, },
  }
end

def AllAndOut : (@var_not_free_in_axioms L n A _) → A∣[((all n p) and (all n q))] ⊢ (all n (p and q)) := begin
  intro h,
  apply All_intro _ _ n,
  split, assumption,
  intro m, cases m, simp, simp,
  rw replace_formula_with_idem,
  apply And_intro_R,
  {
    apply L_ And_elim_left,
    apply Assumption 0,
    refl,
    apply All_elim n (v n),
      apply Assumption 0, refl,
      apply substitutable_for_idem,
      rw replace_formula_with_idem,
      apply Assumption 0, refl,
  },
  {
    apply L_ And_elim_right,
    apply Assumption 0,
    refl,
    apply All_elim n (v n),
      apply Assumption 0, refl,
      apply substitutable_for_idem,
      rw replace_formula_with_idem,
      apply Assumption 0, refl,
  }
end

def ExOrIn : (@var_not_free_in_axioms L n A _) → A∣[(exi n (p or q))] ⊢ ((exi n p) or (exi n q)) := begin
  intro h,
  apply R_ DeMorganNotAnd,
  apply R_Not_ (R_ (AllAndIn h)),
  apply R_Not_ (R_All_ (R_ DeMorganNotOr)),
  apply Assumption 0, refl,
end

def ExOrOut : (@var_not_free_in_axioms L n A _) → A∣[((exi n p) or (exi n q))] ⊢ (exi n (p or q)) := begin
  intro h,
  apply R_Not_ (R_All_ (R_ DeMorganAnd)),
  apply R_Not_ (R_ (AllAndOut h)),
  apply R_ DeMorganOr,
  apply Assumption 0, refl,
end

def ExAndOut : (@var_not_free_in_axioms L n A _) → A∣[((exi n p) and (exi n q))] ⊢ (exi n (p and q))  := begin
  intro h,
  apply R_Not_ (R_All_ (R_ DeMorganOr)),
  apply R_Not_ (R_ (AllOrOut h)),
  apply R_ DeMorganAnd,
  apply Assumption 0, refl,
end

def SwapAll : (@var_not_free_in_axioms L n A _) → (@var_not_free_in_axioms L m A _) →
    A∣[(all n (all m p))] ⊢ (all m (all n p)) := begin
  intros h₁ h₂,
  apply All_intro _ _ m,
    split, assumption,
    intro m, cases m, simp, simp,
    rw replace_formula_with_idem,
  apply All_intro _ _ n, simp,
    split, assumption,
    intro m, cases m, simp, simp,
    rw replace_formula_with_idem,
  apply All_elim n (v n),
    apply Assumption 0, refl,
    apply substitutable_for_idem,
    rw replace_formula_with_idem,
  apply All_elim m (v m),
    apply Assumption 0, refl,
    apply substitutable_for_idem,
    rw replace_formula_with_idem,
  apply Assumption 0, refl,
end

def SwapEx : (@var_not_free_in_axioms L n A _) → (@var_not_free_in_axioms L m A _) →
    A∣[(exi n (exi m p))] ⊢ (exi m (exi n p)) := begin
  intros h₁ h₂,
  apply R_Not_ (R_All_ (R_ Double_negation_intro)),
  apply L_R_ (R_Not_ (R_All_ (R_ Double_negation_elim))),
  apply Assumption 0, refl,
  apply R_Not_ (R_ (SwapAll h₁ h₂)),
  apply Assumption 0, refl,
end

-- def SwapAllEx_R : ((A∣Γ ⊢ ∼(all n (exi m ∼p))) → ((A∣Γ ⊢ (exi m (all n p))) := sorry

-- def SwapExAll_R : ((A∣Γ ⊢ ∼(exi n (all m ∼p))) → ((A∣Γ ⊢ (all m (exi n p))) := sorry

end prf

end first_order


import .basic

namespace polya.field

open nterm

--@[derive decidable_eq]
structure cterm (γ : Type) [const_space γ] : Type :=
(term : nterm γ)
(coeff : γ)
(pr : coeff ≠ 0)

namespace cterm
variables {α : Type} [discrete_field α]
variables {γ : Type} [const_space γ]
variables [morph γ α] {ρ : dict α}

instance : inhabited (cterm γ) := ⟨⟨nterm.const 0, 1, by simp⟩⟩

def to_nterm (x : cterm γ) : nterm γ :=
x.term * x.coeff

def eval (ρ : dict α) (x : cterm γ) : α :=
nterm.eval ρ x.term * ↑x.coeff

@[simp]
def eval_to_nterm {x : cterm γ} :
 nterm.eval ρ x.to_nterm = cterm.eval ρ x :=
begin
  simp [to_nterm, nterm.eval, cterm.eval]
end

theorem eval_to_nterm' :
  nterm.eval ρ ∘ @cterm.to_nterm γ _ = cterm.eval ρ :=
begin
  unfold function.comp,
  simp [eval_to_nterm]
end

--TODO
theorem eval_def {x : nterm γ} {c : γ} {hc : c ≠ 0} :
  cterm.eval ρ ⟨x, c, hc⟩ = nterm.eval ρ x * ↑c :=
rfl

theorem eval_add {x : nterm γ} {a b : γ}
  {ha : a ≠ 0} {hb : b ≠ 0} {hc : a + b ≠ 0} :
  cterm.eval ρ ⟨x, a + b, hc⟩ = cterm.eval ρ ⟨x, a, ha⟩ + cterm.eval ρ ⟨x, b, hb⟩ :=
begin
  simp [eval_def, morph.morph_add, mul_add],
end

def mul (x : cterm γ) (a : γ) (ha : a ≠ 0) : cterm γ :=
⟨x.term, x.coeff * a, by simp [ha, x.pr]⟩

theorem eval_mul {x : cterm γ} {a : γ} {ha : a ≠ 0} :
  cterm.eval ρ (x.mul a ha) = cterm.eval ρ x * ↑a :=
begin
  simp [cterm.eval, morph.morph_mul, mul], ring
end

theorem eval_mul' {a : γ} {ha : a ≠ 0} :
  cterm.eval ρ ∘ (λ x : cterm γ, x.mul a ha) =
    λ x, cterm.eval ρ x * (a : α) :=
begin
  unfold function.comp,
  simp [eval_mul]
end

theorem eval_sum_mul {xs : list (cterm γ)} {a : γ} {ha : a ≠ 0} :
  list.sum (list.map (cterm.eval ρ) xs) * ↑a
    = list.sum (list.map (λ x : cterm γ, cterm.eval ρ (x.mul a ha)) xs) :=
begin
  induction xs with x xs ih,
  { simp },
  { repeat {rw [list.map_cons, list.sum_cons]},
    rw [eval_mul, add_mul, ih] }
end

def smerge : list (cterm γ) → list (cterm γ) → list (cterm γ)
| (x::xs) (y::ys) :=
  if x.term = y.term then
    let c := x.coeff + y.coeff in
    if hc : c = 0 then smerge xs ys
    else ⟨x.term, c, hc⟩ :: smerge xs ys
  else if x.term < y.term then
    x :: smerge xs (y::ys)
  else
    y :: smerge (x::xs) ys
| xs [] := xs
| [] ys := ys

lemma smerge_nil_left {ys : list (cterm γ)} :
  smerge [] ys = ys :=
begin
  induction ys with y ys ih,
  { unfold smerge },
  { unfold smerge }
end

lemma smerge_nil_right {xs : list (cterm γ)} :
  smerge xs [] = xs :=
begin
  induction xs with x xs ih,
  { unfold smerge },
  { unfold smerge }
end

lemma smerge_def1 {x y : cterm γ} {xs ys : list (cterm γ)} :
  x.term = y.term → x.coeff + y.coeff = 0 →
  smerge (x::xs) (y::ys) = smerge xs ys :=
by intros h1 h2; simp [smerge, h1, h2]
lemma smerge_def2 {x y : cterm γ} {xs ys : list (cterm γ)} :
  x.term = y.term → Π (hc : x.coeff + y.coeff ≠ 0),
  smerge (x::xs) (y::ys) = ⟨x.term, x.coeff + y.coeff, hc⟩ :: smerge xs ys :=
by intros h1 h2; simp [smerge, h1, h2]
lemma smerge_def3 {x y : cterm γ} {xs ys : list (cterm γ)} :
  x.term ≠ y.term → x.term < y.term →
  smerge (x::xs) (y::ys) = x :: smerge xs (y :: ys) :=
by intros h1 h2; simp [smerge, h1, h2]
lemma smerge_def4 {x y : cterm γ} {xs ys : list (cterm γ)} :
  x.term ≠ y.term → ¬ x.term < y.term →
  smerge (x::xs) (y::ys) = y :: smerge (x::xs) ys :=
by intros h1 h2; simp [smerge, h1, h2]

theorem eval_smerge (xs ys : list (cterm γ)) :
  list.sum (list.map (cterm.eval ρ) (smerge xs ys))
  = list.sum (list.map (cterm.eval ρ) xs)
    + list.sum (list.map (cterm.eval ρ) ys) :=
begin
  revert ys,
  induction xs with x xs ihx,
  { intro ys, simp [smerge_nil_left] },
  { intro ys, induction ys with y ys ihy,
    { simp [smerge_nil_right] },
    { by_cases h1 : x.term = y.term,
      { by_cases h2 : x.coeff + y.coeff = 0,
        { have : eval ρ x = - eval ρ y,
          by {
            rw add_eq_zero_iff_eq_neg at h2,
            unfold cterm.eval, rw [h1, h2, morph.morph_neg],
            ring },
          rw [smerge_def1 h1 h2, ihx],
          repeat {rw [list.map_cons, list.sum_cons]},
          rw this, ring },
        { rw smerge_def2 h1 h2,
          cases x with x n, cases y with y m,
          simp only [] at h1, rw h1 at *,
          repeat {rw [list.map_cons, list.sum_cons]},
          rw [eval_add, ihx ys], { simp },
          repeat {assumption }}},
      { by_cases h2 : x.term < y.term,
        { rw smerge_def3 h1 h2,
          repeat {rw [list.map_cons, list.sum_cons]},
          rw [ihx (y::ys), list.map_cons, list.sum_cons],
          ring},
        { rw smerge_def4 h1 h2,
          repeat {rw [list.map_cons, list.sum_cons]},
          rw [ihy, list.map_cons, list.sum_cons],
          ring}}}}
end

end cterm

structure sterm (γ : Type) [const_space γ] : Type :=
(terms : list (cterm γ))

namespace sterm
variables {α : Type} [discrete_field α]
variables {γ : Type} [const_space γ]
variables [morph γ α] {ρ : dict α}

def of_const (a : γ) : sterm γ :=
if ha : a = 0 then { terms := [] }
else { terms := [⟨1, a, ha⟩] }

def singleton (x : nterm γ) : sterm γ :=
{ terms := [⟨x, 1, by simp⟩] }

def eval (ρ : dict α) (S : sterm γ) : α :=
list.sum (S.terms.map (cterm.eval ρ))

theorem eval_of_const (a : γ) :
  sterm.eval ρ (of_const a) = ↑a :=
begin
  by_cases ha : a = 0;
  simp [of_const, sterm.eval, cterm.eval, ha]
end

theorem eval_singleton (x : nterm γ) :
  sterm.eval ρ (singleton x) = nterm.eval ρ x :=
begin
  by_cases hx : nterm.eval ρ x = 0,
  repeat {simp [singleton, sterm.eval, cterm.eval, hx]}
end

--mul
def add (S T : sterm γ) : sterm γ :=
{ terms := cterm.smerge S.terms T.terms, }

--pow
def mul (S : sterm γ) (a : γ) : sterm γ :=
if ha : a = 0 then { terms := [] }
else { terms := S.terms.map (λ x, cterm.mul x a ha), }

instance : has_add (sterm γ) := ⟨add⟩

theorem add_terms {S T : sterm γ} :
  (S + T).terms = cterm.smerge S.terms T.terms :=
by simp [has_add.add, add]

theorem eval_add {S T : sterm γ} :
  sterm.eval ρ (S + T) = sterm.eval ρ S + sterm.eval ρ T :=
begin
  unfold sterm.eval,
  rw [add_terms, cterm.eval_smerge]
end

theorem eval_mul {S : sterm γ} {a : γ} :
  sterm.eval ρ (S.mul a) = sterm.eval ρ S * ↑a :=
begin
  by_cases ha : a = 0,
  { simp [mul, eval, ha] },
  { unfold sterm.eval, unfold mul,
    rw cterm.eval_sum_mul,
     { simp [ha] },
     { exact ha }}
end

def to_nterm (S : sterm γ) : nterm γ :=
match S.terms with
| [] := 0
| [x] := x.to_nterm
| (x0::xs) :=
    have h0 : x0.coeff⁻¹ ≠ 0, by simp [x0.pr],
    ( nterm.sum (xs.map (λ x, (x.mul x0.coeff⁻¹ h0).to_nterm))
      + x0.term * 1 ) * x0.coeff
end

theorem eval_to_nterm {S : sterm γ} :
  sterm.eval ρ S = nterm.eval ρ S.to_nterm :=
begin
  cases S with xs,
  cases xs with x0 xs,
  { simp [eval, to_nterm] },
  cases xs with x1 xs,
  { simp [eval, to_nterm] },

  unfold eval, unfold to_nterm,
  rw [nterm.eval_mul, nterm.eval_add, nterm.eval_sum, nterm.eval_const],
  rw [← list.map_map cterm.to_nterm,
    list.map_map _ cterm.to_nterm,
    cterm.eval_to_nterm', list.map_map,
    ← cterm.eval_sum_mul],
  rw [add_mul, mul_assoc, ← morph.morph_mul, inv_mul_cancel,
    morph.morph_one', mul_one],
  swap, by simp [x0.pr],
  rw [list.map_cons, list.sum_cons],
  rw [nterm.eval_mul, nterm.eval_one, mul_one],
  unfold cterm.eval, apply add_comm
end

def of_nterm : nterm γ → sterm γ
| (nterm.add x y) := of_nterm x + of_nterm y
| (nterm.mul x (nterm.const a)) := (of_nterm x).mul a
| (nterm.const a) := of_const a
| x := singleton x

theorem eval_of_nterm {x : nterm γ} :
  sterm.eval ρ (of_nterm x) = nterm.eval ρ x :=
begin
  induction x with i c x y ihx ihy x y ihx ihy x n ihx,
  { simp [of_nterm, eval_singleton] },
  { simp [of_nterm, eval_of_const, nterm.eval] },
  { simp [of_nterm, eval_add, nterm.eval, ihx, ihy] },
  { cases y; try {simp [of_nterm, eval_singleton]},
    simp [eval_mul, nterm.eval, ihx] },
  { simp [of_nterm, eval_singleton] }
end

end sterm

end polya.field


/-
Copyright (c) 2019 Simon Hudon. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Simon Hudon
-/
import logic.equiv.defs
import tactic.basic

/-!
# Monad

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

## Attributes

 * ext
 * functor_norm
 * monad_norm

## Implementation Details

Set of rewrite rules and automation for monads in general and
`reader_t`, `state_t`, `except_t` and `option_t` in particular.

The rewrite rules for monads are carefully chosen so that `simp with
functor_norm` will not introduce monadic vocabulary in a context where
applicatives would do just fine but will handle monadic notation
already present in an expression.

In a context where monadic reasoning is desired `simp with monad_norm`
will translate functor and applicative notation into monad notation
and use regular `functor_norm` rules as well.

## Tags

functor, applicative, monad, simp

-/

mk_simp_attribute monad_norm none with functor_norm

attribute [ext] reader_t.ext state_t.ext except_t.ext option_t.ext
attribute [functor_norm]   bind_assoc pure_bind bind_pure
attribute [monad_norm] seq_eq_bind_map
universes u v

@[monad_norm]
lemma map_eq_bind_pure_comp
  (m : Type u → Type v) [monad m] [is_lawful_monad m] {α β : Type u} (f : α → β) (x : m α) :
  f <$> x = x >>= pure ∘ f := by rw bind_pure_comp_eq_map

/-- run a `state_t` program and discard the final state -/
def state_t.eval {m : Type u → Type v} [functor m] {σ α} (cmd : state_t σ m α) (s : σ) : m α :=
prod.fst <$> cmd.run s

universes u₀ u₁ v₀ v₁

/-- reduce the equivalence between two state monads to the equivalence between
their respective function spaces -/
def state_t.equiv {m₁ : Type u₀ → Type v₀} {m₂ : Type u₁ → Type v₁}
  {α₁ σ₁ : Type u₀} {α₂ σ₂ : Type u₁} (F : (σ₁ → m₁ (α₁ × σ₁)) ≃ (σ₂ → m₂ (α₂ × σ₂))) :
  state_t σ₁ m₁ α₁ ≃ state_t σ₂ m₂ α₂ :=
{ to_fun := λ ⟨f⟩, ⟨F f⟩,
  inv_fun := λ ⟨f⟩, ⟨F.symm f⟩,
  left_inv := λ ⟨f⟩, congr_arg state_t.mk $ F.left_inv _,
  right_inv := λ ⟨f⟩, congr_arg state_t.mk $ F.right_inv _ }

/-- reduce the equivalence between two reader monads to the equivalence between
their respective function spaces -/
def reader_t.equiv {m₁ : Type u₀ → Type v₀} {m₂ : Type u₁ → Type v₁}
  {α₁ ρ₁ : Type u₀} {α₂ ρ₂ : Type u₁} (F : (ρ₁ → m₁ α₁) ≃ (ρ₂ → m₂ α₂)) :
  reader_t ρ₁ m₁ α₁ ≃ reader_t ρ₂ m₂ α₂ :=
{ to_fun := λ ⟨f⟩, ⟨F f⟩,
  inv_fun := λ ⟨f⟩, ⟨F.symm f⟩,
  left_inv := λ ⟨f⟩, congr_arg reader_t.mk $ F.left_inv _,
  right_inv := λ ⟨f⟩, congr_arg reader_t.mk $ F.right_inv _ }


/-
Copyright (c) 2020 Markus Himmel. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Markus Himmel, Scott Morrison
-/
import algebra.category.Module.epi_mono
import algebra.module.projective
import category_theory.preadditive.projective
import linear_algebra.finsupp_vector_space

/-!
# The category of `R`-modules has enough projectives.
-/

universes v u

open category_theory
open category_theory.limits
open linear_map

open_locale Module

/-- The categorical notion of projective object agrees with the explicit module-theoretic notion. -/
theorem is_projective.iff_projective {R : Type u} [ring R]
  {P : Type (max u v)} [add_comm_group P] [module R P] :
  module.projective R P ↔ projective (Module.of R P) :=
begin
  refine ⟨λ h, _, λ h, _⟩,
  { letI : module.projective R ↥(Module.of R P) := h,
    exact ⟨λ E X f e epi, module.projective_lifting_property _ _
      ((Module.epi_iff_surjective _).mp epi)⟩ },
  { refine module.projective_of_lifting_property _,
    introsI E X mE mX sE sX f g s,
    haveI : epi ↟f := (Module.epi_iff_surjective ↟f).mpr s,
    letI : projective (Module.of R P) := h,
    exact ⟨projective.factor_thru ↟g ↟f, projective.factor_thru_comp ↟g ↟f⟩ }
end

namespace Module
variables {R : Type u} [ring R] {M : Module.{max u v} R}

/-- Modules that have a basis are projective. -/
-- We transport the corresponding result from `module.projective`.
lemma projective_of_free {ι : Type*} (b : basis ι R M) : projective M :=
projective.of_iso (Module.of_self_iso _)
  ((is_projective.iff_projective).mp (module.projective_of_basis b))

/-- The category of modules has enough projectives, since every module is a quotient of a free
    module. -/
instance Module_enough_projectives : enough_projectives (Module.{max u v} R) :=
{ presentation :=
  λ M,
  ⟨{ P := Module.of R (M →₀ R),
    projective := projective_of_free finsupp.basis_single_one,
    f := finsupp.basis_single_one.constr ℕ id,
    epi := (epi_iff_range_eq_top _).mpr
      (range_eq_top.2 (λ m, ⟨finsupp.single m (1 : R), by simp [basis.constr]⟩)) }⟩, }

end Module


import Mt.Thread.Traced
import Mt.System.Basic
import Mt.Utils.List

namespace Mt.System.Traced

open Utils

variable {spec : Spec}
local instance : IsReservation spec.Reservation :=spec.is_reservation

def sum_reservations (l : List (Traced.TracedThread spec)) : spec.Reservation :=
  l.foldl (λ env_r thread => env_r + thread.reservation) spec.is_reservation.empty

private def sum_reservations' (start) (l : List (Traced.TracedThread spec)) :=
  l.foldl (λ env_r thread => env_r + thread.reservation) start

protected theorem sum_reservations.helper (head : Traced.TracedThread spec) (l) :
  sum_reservations (head :: l) = head.reservation + sum_reservations l :=by
  have : ∀ l : List (Traced.TracedThread spec),
    sum_reservations l = sum_reservations' IsReservation.empty l :=fun _ => rfl
  simp only [this] ; clear this
  simp only [add, IsReservation.empty_add]
  rw [assoc]
where
  add (r) (head : Traced.TracedThread spec) (tail)
    : sum_reservations' r (head::tail) = sum_reservations' (r + head.reservation) tail :=by
    simp only [sum_reservations', List.foldl]

  assoc (r : spec.Reservation) (l)
    : sum_reservations' r l = r + sum_reservations' IsReservation.empty l :=by
    revert r
    induction l
    . intro r
      show r = r + IsReservation.empty
      rw [IsReservation.toIsCommutative.comm, IsReservation.empty_add]
    . rename_i head tail IH
      intro r
      simp only [add]
      rw [IH, IsReservation.toIsAssociative.assoc, IsReservation.empty_add]
      rw [IH head.reservation]

protected theorem decompose_reservation (l : List (Traced.TracedThread spec)) (idx : Fin l.length) t :
  t = l.get idx →
  sum_reservations l = sum_reservations (l.eraseIdx idx.val) + t.reservation :=by
  intro t_def ; rw [t_def]  ; clear t_def
  revert idx

  induction l
  . intro idx
    have : idx.val < 0 :=idx.isLt
    contradiction
  . intro idx
    rename_i thread threads IH
    cases h : idx.val
    . have : idx = Fin.mk 0 (by simp_arith) :=Fin.eq_of_val_eq h
      simp only [this, List.get, List.eraseIdx, sum_reservations.helper]
      exact IsReservation.toIsCommutative.comm _ _
    . rename_i n
      have idx_ok : n + 1 < (thread :: threads).length :=calc
        n + 1 = idx.val :=h.symm
        _ < _ :=idx.isLt
      have : idx = Fin.mk (n + 1) idx_ok :=Fin.eq_of_val_eq h
      simp only [this, List.get, List.eraseIdx, sum_reservations.helper]
      clear this h idx
      rw [IsReservation.toIsAssociative.assoc]
      apply congrArg (thread.reservation + .)
      exact IH <| Fin.mk n (Nat.le_of_succ_le_succ idx_ok)

end Mt.System.Traced


import category_theory.category
import category_theory.functor
import set_category.category_set
import coalgebra.Coalgebra
import set_category.colimits.Sum
import help_functions
import coalgebra.subcoalgebra

import tactic.tidy

universes u

namespace coalgebra_sum
open category_theory
     set
     coalgebra
     classical
     help_functions
     subcoalgebra
     Sum

local notation f ` ⊚ `:80 g:80 := category_struct.comp g f

variables   {A B C: Type u}
            {F : Type u ⥤ Type u}
            (𝔸 : Coalgebra F)
            (Β : Coalgebra F)

open sum

def α_sum
    : (𝔸 ⊕ Β) → F.obj (𝔸 ⊕ Β)
    | (inl a) := ((F.map inl) ∘ 𝔸.α) a
    | (inr b) := ((F.map inr) ∘ Β.α) b

def sum_of_coalgebras
            : Coalgebra F  :=
            ⟨(𝔸 ⊕ Β) ,  (α_sum 𝔸 Β)⟩

lemma inl_is_homomorphism :
    @is_coalgebra_homomorphism F 𝔸 (sum_of_coalgebras 𝔸 Β) inl
    := by {dsimp at *, refl}

lemma inr_is_homomorphism :
    @is_coalgebra_homomorphism F Β (sum_of_coalgebras 𝔸 Β) inr
    := by {dsimp at *, refl}

infix ` ⊞ ` :20 := sum_of_coalgebras

theorem set_sum_is_coalgebra_sum :
    let e₁ : 𝔸 → (𝔸 ⊕ Β) := inl in
    let e₂ : Β → (𝔸 ⊕ Β) := inr in
    let h_e₁ : 𝔸 ⟶ (𝔸 ⊞ Β) := ⟨e₁ ,  inl_is_homomorphism 𝔸 Β⟩ in
    let h_e₂ : Β ⟶ (𝔸 ⊞ Β) := ⟨e₂ ,  inr_is_homomorphism 𝔸 Β⟩ in
            is_sum (𝔸 ⊞ Β) h_e₁ h_e₂
        :=
    begin
        intros e₁ e₂ h_e₁ h_e₂ ℚ ϕ₁ ϕ₂,

        let σ : 𝔸 ⊕ Β ⟶ ℚ :=
            some (disjoint_union_is_sum ℚ ϕ₁ ϕ₂),

        let γ := ℚ.α,
        let α :=  (𝔸 ⊞ Β).α,

        let hom_inl :
            α ∘ inl = (F.map inl) ∘ 𝔸.α :=
                inl_is_homomorphism 𝔸 Β,
        let hom_inr :
            α ∘ inr = (F.map inr) ∘ Β.α
                := inr_is_homomorphism 𝔸 Β,

        let hom_ϕ₁ : γ ∘ ϕ₁.val =  (F.map ϕ₁.val) ∘ 𝔸.α := ϕ₁.property,
        let hom_ϕ₂ : γ ∘ ϕ₂.val =  (F.map ϕ₂.val) ∘ Β.α := ϕ₂.property,

        have h0 : _ :=
            some_spec (disjoint_union_is_sum ℚ ϕ₁ ϕ₂),

        have h1 : ϕ₁.val = σ ∘ inl ∧ ϕ₂.val = σ ∘ inr:=
            and.left h0,

        have h2 : γ ∘ σ ∘ inl = (F.map σ) ∘ α ∘ inl :=
            calc
             γ ∘ (σ ∘ inl) = γ ∘ ϕ₁.val                    : by rw [and.left h1]
                ...      = (F.map ϕ₁.val) ∘ 𝔸.α               : by rw [hom_ϕ₁]
                ...      = (F.map (σ ∘ inl)) ∘ 𝔸.α        : by rw [and.left h1]
                ...      = (F.map (σ ⊚ inl)) ∘ 𝔸.α        : by simp
                ...  = ((F.map σ) ⊚ (F.map inl)) ∘ 𝔸.α    : by rw ← functor.map_comp
                ...      = (F.map σ) ∘ (F.map inl) ∘ 𝔸.α   : by simp
                ...      = (F.map σ) ∘ α ∘ inl             : by rw [hom_inl],
        have h3 : γ ∘ σ ∘ inr = (F.map σ) ∘ α ∘ inr :=
            calc γ ∘ (σ ∘ inr) = γ ∘ ϕ₂.val                      : by rw [and.right h1]
                     ...      = (F.map ϕ₂.val) ∘ Β.α             : by rw [hom_ϕ₂]
                     ...      = (F.map (σ ∘ inr)) ∘ Β.α          : by rw [and.right h1]
                     ...      = (F.map (σ ⊚ inr)) ∘ Β.α        : by simp
                     ...  = ((F.map σ) ⊚ (F.map inr)) ∘ Β.α    : by rw ← functor.map_comp
                     ...      = (F.map σ) ∘ (F.map inr) ∘ Β.α   : by simp
                     ...      = (F.map σ) ∘ α ∘ inr             : by rw [hom_inr],
        have h4 : ∀ ab : 𝔸 ⊕ Β, (γ ∘ σ) ab = ((F.map σ) ∘ α) ab :=
                begin
                    intro ab,
                    induction ab,
                    case inl :  {
                                    show (γ ∘ σ ∘ inl) ab = ((F.map σ) ∘ α ∘ inl) ab,
                                    by rw h2
                                },
                    case inr :  {
                                    show (γ ∘ σ ∘ inr) ab = ((F.map σ) ∘ α ∘ inr) ab,
                                    by rw h3
                                },
                end,

        have h5 : @is_coalgebra_homomorphism F
                (𝔸 ⊞ Β) ℚ σ
                  := funext h4,

        let ex_uni :
            ∃! s , ϕ₁.val = s ∘ inl ∧ ϕ₂.val = s ∘ inr :=
            disjoint_union_is_sum ℚ ϕ₁ ϕ₂,

        let ex :
            ∃ s ,
                (ϕ₁.val = s ∘ inl ∧ ϕ₂.val = s ∘ inr)
                ∧ @is_coalgebra_homomorphism F
                    (𝔸 ⊞ Β) ℚ s :=
                        exists.intro σ
                        (and.intro h1 h5),
        let s := some ex,
        have spec_s : (ϕ₁.val = s ∘ inl ∧ ϕ₂.val = s ∘ inr) ∧
                    @is_coalgebra_homomorphism F (𝔸 ⊞ Β) ℚ s
            := some_spec ex,
        use s,
        exact spec_s.2,
        split,
        exact ⟨eq_in_set.1 spec_s.1.1,
            eq_in_set.1 spec_s.1.2⟩,
        let s₁ := some ex_uni,
        have spec_s₁ : _ := some_spec ex_uni,
        have s₁_s : s₁ = s := eq.symm (spec_s₁.2 s spec_s.1),
        intros s₂ spec_s₂,

        have s₂_s₁ : s₂.val = s₁ :=  spec_s₁.2 s₂
            ⟨eq_in_set.2 spec_s₂.1, eq_in_set.2 spec_s₂.2⟩,

        have s₂_s : s₂.val = s := by simp [s₁_s, s₂_s₁],

        exact eq_in_set.1 s₂_s

    end

noncomputable theorem subcoalgebra_union_is_coalgebra
    {U₁ U₂ : set 𝔸}
    (S₁ : SubCoalgebra U₁)
    (S₂ : SubCoalgebra U₂)
    : SubCoalgebra (U₁ ∪ U₂) :=
    begin

        let S : Coalgebra F := ⟨U₁ , S₁.α⟩ ⊞ ⟨U₂ , S₂.α⟩,

        have ex := set_sum_is_coalgebra_sum ⟨U₁ , S₁.α⟩ ⟨U₂ , S₂.α⟩ 𝔸
                     ⟨ (U₁↪ 𝔸), S₁.h⟩  ⟨(U₂ ↪ 𝔸) , S₂.h⟩,

        let ϕ : S ⟶ 𝔸 := some ex,

        have spec : (((U₁↪ 𝔸) = ϕ ∘ inl ∧ (U₂ ↪ 𝔸) = ϕ ∘ inr))
            := ⟨ eq_in_set.2 (some_spec ex).1.1,
                 eq_in_set.2 (some_spec ex).1.2 ⟩ ,

        have all : ∀ a : 𝔸 , a ∈ (range ϕ) ↔ a ∈ (U₁ ∪ U₂) :=
            λ a,
            iff.intro
            begin
                assume ar : a ∈ range ϕ,
                cases (mem_range.1 ar) with s ϕs_a,
                induction s,
                case inl :
                    begin
                        have h01 : (ϕ ∘ inl) s ∈ U₁ :=
                            spec.1 ▸ s.property,
                        have h02 : a ∈ U₁ := ϕs_a ▸ h01,
                        by simp [h02],
                    end,
                case inr :
                    begin
                        have h01 : (ϕ ∘ inr) s ∈ U₂ :=
                            spec.2 ▸ s.property,
                        have h02 : a ∈ U₂ :=  (ϕs_a ▸ h01),
                        by simp [h02],
                    end,
            end
            begin
                assume auu : a ∈ U₁ ∨ a ∈ U₂,
                apply or.elim auu,
                assume au1: a ∈ U₁,
                have h01 : a = (ϕ ∘ inl) ⟨a , au1⟩  :=
                    spec.1 ▸ rfl,
                exact exists.intro (inl ⟨a , au1⟩) (eq.symm (h01)),
                assume au2: a ∈ U₂,
                have h01 : a = (ϕ ∘ inr) ⟨a , au2⟩  :=
                    spec.2 ▸ rfl,
                exact exists.intro (inr ⟨a , au2⟩) (eq.symm h01)
            end,

        rw ←(eq_sets.1 all),
        exact range_is_subCoalgebra ϕ,

    end

-- def pw (U V : set 𝔸)
--     [∀ x , decidable (x ∈ U ∩ V)]
--         (w : U ∩ V)
--     :U → U ∩ V := λ u , if uUV : u.val ∈ U ∩ V
--                     then ⟨u.val , uUV⟩
--                     else ⟨w.val , w.property⟩

-- def qw (U V : set 𝔸)
--     [∀ x , decidable (x ∈ V)]
--         (w : U ∩ V)
--     :𝔸 → V := λ a , if aV : a ∈ V
--                     then ⟨a , aV⟩
--                     else ⟨w.val , and.right w.property⟩

theorem subcoalgebra_intersection_is_coalgebra
    {U V : set 𝔸}
    (S₁ : SubCoalgebra U)
    (S₂ : SubCoalgebra V)
    [∀ x : 𝔸 , decidable (x ∈ U ∩ V)]
    [∀ x : 𝔸 , decidable (x ∈ V)]
    : openset (U ∩ V) :=
    begin
        let I : set 𝔸 := U ∩ V,
        cases classical.em (nonempty (I)) with n_emp emp,

        let w : ↥I := choice n_emp ,

        let incV : I → V := set.inclusion (by simp),
        let incU : I → U := set.inclusion (by simp),

        let p_w :U → U ∩ V := λ u , if uUV : u.val ∈ U ∩ V
                    then ⟨u.val , uUV⟩
                    else ⟨w.val , w.property⟩,
        let q_w :𝔸 → V := λ a , if aV : a ∈ V
                    then ⟨a , aV⟩
                    else ⟨w.val , and.right w.property⟩,

        have h1 : ∀ u:U ,
            (incV ∘ p_w) u = (q_w ∘ (U ↪ 𝔸)) u :=
            assume u,
            @by_cases (u.val ∈ I)  ((incV ∘ p_w) u = (q_w ∘ (U ↪ 𝔸)) u)
                begin
                    intro uI,
                    have pwu_u : p_w u = ⟨u.val , uI⟩:=
                        by simp [p_w , rfl, uI],
                    have qwu_u: (q_w) u.val =
                                    (⟨u.val , uI.2⟩ : V)  :=
                        by simp [q_w, rfl, uI.2],
                    calc (incV ∘ p_w) u
                                = incV  ⟨u.val , uI⟩  : by rw ←pwu_u
                            ... = (⟨u.val , uI.2⟩: V) : rfl
                            ... = q_w u.val          : by rw ←qwu_u
                end
                begin
                    intro uNI,
                    have pwu_w : p_w u = w := by simp [p_w , uNI, rfl],
                    have qwu_u: q_w u.val =
                                    (⟨w.val , (w.property).2⟩ : V)  :=
                        begin
                            simp[q_w],
                            split_ifs,
                            exact absurd (and.intro u.property h) uNI,
                            exact rfl
                        end,
                    calc incV (p_w u)
                                = incV w                      : by rw pwu_w
                            ... = (⟨w.val , w.property.2⟩: V)  : rfl
                            ... = q_w u.val                   : by rw ←qwu_u

                end
            ,
        have h11 : incV ∘ p_w = q_w ∘ (U ↪ 𝔸) :=
            funext h1,

        have h22 : q_w  ∘ (V ↪ 𝔸) = id :=
            funext (by {dsimp at *,  simp [q_w]}),

        let γ := (F.map p_w) ∘ S₁.α ∘ incU,

        have hom_eq : (F.map (I ↪ 𝔸)) ∘ γ = 𝔸.α ∘ (I ↪ 𝔸) :=
            calc (F.map ((V ↪ 𝔸) ⊚ incV)) ∘ (F.map p_w) ∘ S₁.α ∘ incU
                    = ((F.map (V ↪ 𝔸)) ⊚ (F.map incV)) ∘ (F.map p_w) ∘ S₁.α ∘ incU : by rw functor.map_comp
                ... = (F.map (V ↪ 𝔸)) ∘ ((F.map incV) ⊚ (F.map p_w)) ∘ S₁.α ∘ incU : rfl
                ... = (F.map (V ↪ 𝔸)) ∘ (F.map (incV ⊚ p_w)) ∘ S₁.α ∘ incU : by rw ←functor.map_comp
                ... = (F.map (V ↪ 𝔸)) ∘ (F.map (incV ∘ p_w)) ∘ S₁.α ∘ incU : rfl
                ... = (F.map (V ↪ 𝔸)) ∘ (F.map (q_w ∘ (U ↪ 𝔸))) ∘ S₁.α ∘ incU : by rw ←h11
                ... = (F.map (V ↪ 𝔸)) ∘ (F.map (q_w ⊚ (U ↪ 𝔸))) ∘ S₁.α ∘ incU : rfl
                ... = (F.map (V ↪ 𝔸)) ∘ ((F.map q_w) ⊚ ((F.map (U ↪ 𝔸)))) ∘ S₁.α ∘ incU : by rw functor.map_comp
                ... = (F.map (V ↪ 𝔸)) ∘ (F.map q_w) ∘ ((F.map (U ↪ 𝔸)) ∘ S₁.α) ∘ incU : rfl
                ... = (F.map (V ↪ 𝔸)) ∘ (F.map q_w) ∘ 𝔸.α ∘ (U ↪ 𝔸) ∘ incU : by rw  eq.symm S₁.h
                ... = (F.map (V ↪ 𝔸)) ∘ (F.map q_w) ∘ (𝔸.α ∘ (V ↪ 𝔸)) ∘ incV : rfl
                ... = (F.map (V ↪ 𝔸)) ∘ (F.map q_w) ∘ (F.map (V ↪ 𝔸)) ∘ S₂.α ∘ incV : by rw ← (eq.symm S₂.h)
                ... = (F.map (V ↪ 𝔸)) ∘ ((F.map q_w) ⊚ (F.map (V ↪ 𝔸))) ∘ S₂.α ∘ incV : rfl
                ... = (F.map (V ↪ 𝔸)) ∘ (F.map (q_w ⊚ (V ↪ 𝔸))) ∘ S₂.α ∘ incV : by rw ←functor.map_comp
                ... = (F.map (V ↪ 𝔸)) ∘ (F.map (q_w ∘ (V ↪ 𝔸))) ∘ S₂.α ∘ incV : rfl
                ... = (F.map (V ↪ 𝔸)) ∘ (F.map id) ∘ S₂.α ∘ incV : by rw h22
                ... = (F.map (V ↪ 𝔸)) ∘ (F.map (𝟙 V)) ∘ S₂.α ∘ incV : rfl
                ... = (F.map (V ↪ 𝔸)) ∘ (𝟙 (F.obj V)) ∘ S₂.α ∘ incV : by rw functor.map_id'
                ... = ((F.map (V ↪ 𝔸)) ∘ S₂.α) ∘ incV : rfl
                ... = 𝔸.α ∘ (V ↪ 𝔸) ∘ incV : by rw eq.symm S₂.h,

        exact exists.intro γ (eq.symm hom_eq),

        exact empty_openset emp
    end

end coalgebra_sum