/-
Copyright (c) 2023 Christopher Hoskin. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Christopher Hoskin

! This file was ported from Lean 3 source module topology.order.lower_topology
! leanprover-community/mathlib commit 34ee86e6a59d911a8e4f89b68793ee7577ae79c7
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Topology.Homeomorph
import Mathbin.Topology.Order.Lattice
import Mathbin.Order.Hom.CompleteLattice

/-!
# Lower topology

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

This file introduces the lower topology on a preorder as the topology generated by the complements
of the closed intervals to infinity.

## Main statements

- `lower_topology.t0_space` - the lower topology on a partial order is T₀
- `is_topological_basis.is_topological_basis` - the complements of the upper closures of finite
  subsets form a basis for the lower topology
- `lower_topology.to_has_continuous_inf` - the inf map is continuous with respect to the lower
  topology

## Implementation notes

A type synonym `with_lower_topology` is introduced and for a preorder `α`, `with_lower_topology α`
is made an instance of `topological_space` by the topology generated by the complements of the
closed intervals to infinity.

We define a mixin class `lower_topology` for the class of types which are both a preorder and a
topology and where the topology is generated by the complements of the closed intervals to infinity.
It is shown that `with_lower_topology α` is an instance of `lower_topology`.

## Motivation

The lower topology is used with the `Scott` topology to define the Lawson topology. The restriction
of the lower topology to the spectrum of a complete lattice coincides with the hull-kernel topology.

## References

* [Gierz et al, *A Compendium of Continuous Lattices*][GierzEtAl1980]

## Tags

lower topology, preorder
-/

variable (α β : Type _)

open Set TopologicalSpace

#print WithLowerTopology /-
/-- Type synonym for a preorder equipped with the lower topology
-/
def WithLowerTopology :=
  α
#align with_lower_topology WithLowerTopology
-/

variable {α β}

namespace WithLowerTopology

#print WithLowerTopology.toLower /-
/-- `to_lower` is the identity function to the `with_lower_topology` of a type.  -/
@[match_pattern]
def toLower : α ≃ WithLowerTopology α :=
  Equiv.refl _
#align with_lower_topology.to_lower WithLowerTopology.toLower
-/

#print WithLowerTopology.ofLower /-
/-- `of_lower` is the identity function from the `with_lower_topology` of a type.  -/
@[match_pattern]
def ofLower : WithLowerTopology α ≃ α :=
  Equiv.refl _
#align with_lower_topology.of_lower WithLowerTopology.ofLower
-/

#print WithLowerTopology.to_withLowerTopology_symm_eq /-
@[simp]
theorem to_withLowerTopology_symm_eq : (@toLower α).symm = ofLower :=
  rfl
#align with_lower_topology.to_with_lower_topology_symm_eq WithLowerTopology.to_withLowerTopology_symm_eq
-/

#print WithLowerTopology.of_withLowerTopology_symm_eq /-
@[simp]
theorem of_withLowerTopology_symm_eq : (@ofLower α).symm = toLower :=
  rfl
#align with_lower_topology.of_with_lower_topology_symm_eq WithLowerTopology.of_withLowerTopology_symm_eq
-/

#print WithLowerTopology.toLower_ofLower /-
@[simp]
theorem toLower_ofLower (a : WithLowerTopology α) : toLower (ofLower a) = a :=
  rfl
#align with_lower_topology.to_lower_of_lower WithLowerTopology.toLower_ofLower
-/

#print WithLowerTopology.ofLower_toLower /-
@[simp]
theorem ofLower_toLower (a : α) : ofLower (toLower a) = a :=
  rfl
#align with_lower_topology.of_lower_to_lower WithLowerTopology.ofLower_toLower
-/

#print WithLowerTopology.toLower_inj /-
@[simp]
theorem toLower_inj {a b : α} : toLower a = toLower b ↔ a = b :=
  Iff.rfl
#align with_lower_topology.to_lower_inj WithLowerTopology.toLower_inj
-/

#print WithLowerTopology.ofLower_inj /-
@[simp]
theorem ofLower_inj {a b : WithLowerTopology α} : ofLower a = ofLower b ↔ a = b :=
  Iff.rfl
#align with_lower_topology.of_lower_inj WithLowerTopology.ofLower_inj
-/

#print WithLowerTopology.rec /-
/-- A recursor for `with_lower_topology`. Use as `induction x using with_lower_topology.rec`. -/
protected def rec {β : WithLowerTopology α → Sort _} (h : ∀ a, β (toLower a)) : ∀ a, β a := fun a =>
  h (ofLower a)
#align with_lower_topology.rec WithLowerTopology.rec
-/

instance [Nonempty α] : Nonempty (WithLowerTopology α) :=
  ‹Nonempty α›

instance [Inhabited α] : Inhabited (WithLowerTopology α) :=
  ‹Inhabited α›

variable [Preorder α]

instance : Preorder (WithLowerTopology α) :=
  ‹Preorder α›

instance : TopologicalSpace (WithLowerTopology α) :=
  generateFrom { s | ∃ a, Ici aᶜ = s }

#print WithLowerTopology.isOpen_preimage_ofLower /-
theorem isOpen_preimage_ofLower (S : Set α) :
    IsOpen (WithLowerTopology.ofLower ⁻¹' S) ↔
      (generateFrom { s : Set α | ∃ a : α, Ici aᶜ = s }).IsOpen S :=
  Iff.rfl
#align with_lower_topology.is_open_preimage_of_lower WithLowerTopology.isOpen_preimage_ofLower
-/

/- warning: with_lower_topology.is_open_def -> WithLowerTopology.isOpen_def is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} [_inst_1 : Preorder.{u1} α] (T : Set.{u1} (WithLowerTopology.{u1} α)), Iff (IsOpen.{u1} (WithLowerTopology.{u1} α) (WithLowerTopology.topologicalSpace.{u1} α _inst_1) T) (TopologicalSpace.IsOpen.{u1} α (TopologicalSpace.generateFrom.{u1} α (setOf.{u1} (Set.{u1} α) (fun (s : Set.{u1} α) => Exists.{succ u1} α (fun (a : α) => Eq.{succ u1} (Set.{u1} α) (HasCompl.compl.{u1} (Set.{u1} α) (BooleanAlgebra.toHasCompl.{u1} (Set.{u1} α) (Set.booleanAlgebra.{u1} α)) (Set.Ici.{u1} α _inst_1 a)) s)))) (Set.preimage.{u1, u1} α (WithLowerTopology.{u1} α) (coeFn.{succ u1, succ u1} (Equiv.{succ u1, succ u1} α (WithLowerTopology.{u1} α)) (fun (_x : Equiv.{succ u1, succ u1} α (WithLowerTopology.{u1} α)) => α -> (WithLowerTopology.{u1} α)) (Equiv.hasCoeToFun.{succ u1, succ u1} α (WithLowerTopology.{u1} α)) (WithLowerTopology.toLower.{u1} α)) T))
but is expected to have type
  forall {α : Type.{u1}} [_inst_1 : Preorder.{u1} α] (T : Set.{u1} (WithLowerTopology.{u1} α)), Iff (IsOpen.{u1} (WithLowerTopology.{u1} α) (WithLowerTopology.instTopologicalSpaceWithLowerTopology.{u1} α _inst_1) T) (TopologicalSpace.IsOpen.{u1} α (TopologicalSpace.generateFrom.{u1} α (setOf.{u1} (Set.{u1} α) (fun (s : Set.{u1} α) => Exists.{succ u1} α (fun (a : α) => Eq.{succ u1} (Set.{u1} α) (HasCompl.compl.{u1} (Set.{u1} α) (BooleanAlgebra.toHasCompl.{u1} (Set.{u1} α) (Set.instBooleanAlgebraSet.{u1} α)) (Set.Ici.{u1} α _inst_1 a)) s)))) (Set.preimage.{u1, u1} α (WithLowerTopology.{u1} α) (FunLike.coe.{succ u1, succ u1, succ u1} (Equiv.{succ u1, succ u1} α (WithLowerTopology.{u1} α)) α (fun (_x : α) => (fun (x._@.Mathlib.Logic.Equiv.Defs._hyg.808 : α) => WithLowerTopology.{u1} α) _x) (Equiv.instFunLikeEquiv.{succ u1, succ u1} α (WithLowerTopology.{u1} α)) (WithLowerTopology.toLower.{u1} α)) T))
Case conversion may be inaccurate. Consider using '#align with_lower_topology.is_open_def WithLowerTopology.isOpen_defₓ'. -/
theorem isOpen_def (T : Set (WithLowerTopology α)) :
    IsOpen T ↔
      (generateFrom { s : Set α | ∃ a : α, Ici aᶜ = s }).IsOpen (WithLowerTopology.toLower ⁻¹' T) :=
  Iff.rfl
#align with_lower_topology.is_open_def WithLowerTopology.isOpen_def

end WithLowerTopology

#print LowerTopology /-
/- ./././Mathport/Syntax/Translate/Command.lean:388:30: infer kinds are unsupported in Lean 4: #[`topology_eq_lowerTopology] [] -/
/--
The lower topology is the topology generated by the complements of the closed intervals to infinity.
-/
class LowerTopology (α : Type _) [t : TopologicalSpace α] [Preorder α] : Prop where
  topology_eq_lowerTopology : t = generateFrom { s | ∃ a, Ici aᶜ = s }
#align lower_topology LowerTopology
-/

instance [Preorder α] : LowerTopology (WithLowerTopology α) :=
  ⟨rfl⟩

namespace LowerTopology

#print LowerTopology.lowerBasis /-
/-- The complements of the upper closures of finite sets are a collection of lower sets
which form a basis for the lower topology. -/
def lowerBasis (α : Type _) [Preorder α] :=
  { s : Set α | ∃ t : Set α, t.Finite ∧ (upperClosure t : Set α)ᶜ = s }
#align lower_topology.lower_basis LowerTopology.lowerBasis
-/

section Preorder

variable [Preorder α] [TopologicalSpace α] [LowerTopology α] {s : Set α}

/- warning: lower_topology.with_lower_topology_homeomorph -> LowerTopology.withLowerTopologyHomeomorph is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} [_inst_1 : Preorder.{u1} α] [_inst_2 : TopologicalSpace.{u1} α] [_inst_3 : LowerTopology.{u1} α _inst_2 _inst_1], Homeomorph.{u1, u1} (WithLowerTopology.{u1} α) α (WithLowerTopology.topologicalSpace.{u1} α _inst_1) _inst_2
but is expected to have type
  forall {α : Type.{u1}} [_inst_1 : Preorder.{u1} α] [_inst_2 : TopologicalSpace.{u1} α] [_inst_3 : LowerTopology.{u1} α _inst_2 _inst_1], Homeomorph.{u1, u1} (WithLowerTopology.{u1} α) α (WithLowerTopology.instTopologicalSpaceWithLowerTopology.{u1} α _inst_1) _inst_2
Case conversion may be inaccurate. Consider using '#align lower_topology.with_lower_topology_homeomorph LowerTopology.withLowerTopologyHomeomorphₓ'. -/
/-- If `α` is equipped with the lower topology, then it is homeomorphic to `with_lower_topology α`.
-/
def withLowerTopologyHomeomorph : WithLowerTopology α ≃ₜ α :=
  {
    WithLowerTopology.ofLower with
    continuous_toFun := by
      convert continuous_id
      apply topology_eq_lower_topology
    continuous_invFun := by
      convert← continuous_id
      apply topology_eq_lower_topology }
#align lower_topology.with_lower_topology_homeomorph LowerTopology.withLowerTopologyHomeomorph

/- warning: lower_topology.is_open_iff_generate_Ici_compl -> LowerTopology.isOpen_iff_generate_Ici_compl is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} [_inst_1 : Preorder.{u1} α] [_inst_2 : TopologicalSpace.{u1} α] [_inst_3 : LowerTopology.{u1} α _inst_2 _inst_1] {s : Set.{u1} α}, Iff (IsOpen.{u1} α _inst_2 s) (TopologicalSpace.GenerateOpen.{u1} α (setOf.{u1} (Set.{u1} α) (fun (t : Set.{u1} α) => Exists.{succ u1} α (fun (a : α) => Eq.{succ u1} (Set.{u1} α) (HasCompl.compl.{u1} (Set.{u1} α) (BooleanAlgebra.toHasCompl.{u1} (Set.{u1} α) (Set.booleanAlgebra.{u1} α)) (Set.Ici.{u1} α _inst_1 a)) t))) s)
but is expected to have type
  forall {α : Type.{u1}} [_inst_1 : Preorder.{u1} α] [_inst_2 : TopologicalSpace.{u1} α] [_inst_3 : LowerTopology.{u1} α _inst_2 _inst_1] {s : Set.{u1} α}, Iff (IsOpen.{u1} α _inst_2 s) (TopologicalSpace.GenerateOpen.{u1} α (setOf.{u1} (Set.{u1} α) (fun (t : Set.{u1} α) => Exists.{succ u1} α (fun (a : α) => Eq.{succ u1} (Set.{u1} α) (HasCompl.compl.{u1} (Set.{u1} α) (BooleanAlgebra.toHasCompl.{u1} (Set.{u1} α) (Set.instBooleanAlgebraSet.{u1} α)) (Set.Ici.{u1} α _inst_1 a)) t))) s)
Case conversion may be inaccurate. Consider using '#align lower_topology.is_open_iff_generate_Ici_compl LowerTopology.isOpen_iff_generate_Ici_complₓ'. -/
theorem isOpen_iff_generate_Ici_compl : IsOpen s ↔ GenerateOpen { t | ∃ a, Ici aᶜ = t } s := by
  rw [topology_eq_lower_topology α] <;> rfl
#align lower_topology.is_open_iff_generate_Ici_compl LowerTopology.isOpen_iff_generate_Ici_compl

#print LowerTopology.isClosed_Ici /-
/-- Left-closed right-infinite intervals [a, ∞) are closed in the lower topology. -/
theorem isClosed_Ici (a : α) : IsClosed (Ici a) :=
  isOpen_compl_iff.1 <| isOpen_iff_generate_Ici_compl.2 <| GenerateOpen.basic _ ⟨a, rfl⟩
#align lower_topology.is_closed_Ici LowerTopology.isClosed_Ici
-/

#print LowerTopology.isClosed_upperClosure /-
/-- The upper closure of a finite set is closed in the lower topology. -/
theorem isClosed_upperClosure (h : s.Finite) : IsClosed (upperClosure s : Set α) :=
  by
  simp only [← UpperSet.infᵢ_Ici, UpperSet.coe_infᵢ]
  exact isClosed_bunionᵢ h fun a h₁ => isClosed_Ici a
#align lower_topology.is_closed_upper_closure LowerTopology.isClosed_upperClosure
-/

#print LowerTopology.isLowerSet_of_isOpen /-
/-- Every set open in the lower topology is a lower set. -/
theorem isLowerSet_of_isOpen (h : IsOpen s) : IsLowerSet s :=
  by
  rw [is_open_iff_generate_Ici_compl] at h
  induction h
  case basic u h => obtain ⟨a, rfl⟩ := h; exact (isUpperSet_Ici a).compl
  case univ => exact isLowerSet_univ
  case inter u v hu1 hv1 hu2 hv2 => exact hu2.inter hv2
  case sUnion _ _ ih => exact isLowerSet_unionₛ ih
#align lower_topology.is_lower_set_of_is_open LowerTopology.isLowerSet_of_isOpen
-/

#print LowerTopology.isUpperSet_of_isClosed /-
theorem isUpperSet_of_isClosed (h : IsClosed s) : IsUpperSet s :=
  isLowerSet_compl.1 <| isLowerSet_of_isOpen h.isOpen_compl
#align lower_topology.is_upper_set_of_is_closed LowerTopology.isUpperSet_of_isClosed
-/

#print LowerTopology.closure_singleton /-
/--
The closure of a singleton `{a}` in the lower topology is the left-closed right-infinite interval
[a, ∞).
-/
@[simp]
theorem closure_singleton (a : α) : closure {a} = Ici a :=
  subset_antisymm ((closure_minimal fun b h => h.ge) <| isClosed_Ici a) <|
    (isUpperSet_of_isClosed isClosed_closure).Ici_subset <| subset_closure rfl
#align lower_topology.closure_singleton LowerTopology.closure_singleton
-/

#print LowerTopology.isTopologicalBasis /-
protected theorem isTopologicalBasis : IsTopologicalBasis (lowerBasis α) :=
  by
  convert is_topological_basis_of_subbasis (topology_eq_lower_topology α)
  simp_rw [lower_basis, coe_upperClosure, compl_Union]
  ext s
  constructor
  · rintro ⟨F, hF, rfl⟩
    refine' ⟨(fun a => Ici aᶜ) '' F, ⟨hF.image _, image_subset_iff.2 fun _ _ => ⟨_, rfl⟩⟩, _⟩
    rw [sInter_image]
  · rintro ⟨F, ⟨hF, hs⟩, rfl⟩
    haveI := hF.to_subtype
    rw [subset_def, Subtype.forall'] at hs
    choose f hf using hs
    exact ⟨_, finite_range f, by simp_rw [bInter_range, hf, sInter_eq_Inter]⟩
#align lower_topology.is_topological_basis LowerTopology.isTopologicalBasis
-/

end Preorder

section PartialOrder

variable [PartialOrder α] [TopologicalSpace α] [LowerTopology α]

-- see Note [lower instance priority]
/-- The lower topology on a partial order is T₀.
-/
instance (priority := 90) : T0Space α :=
  (t0Space_iff_inseparable α).2 fun x y h =>
    Ici_injective <| by simpa only [inseparable_iff_closure_eq, closure_singleton] using h

end PartialOrder

end LowerTopology

instance [Preorder α] [TopologicalSpace α] [LowerTopology α] [OrderBot α] [Preorder β]
    [TopologicalSpace β] [LowerTopology β] [OrderBot β] : LowerTopology (α × β)
    where topology_eq_lowerTopology :=
    by
    refine' le_antisymm (le_generateFrom _) _
    · rintro _ ⟨x, rfl⟩
      exact ((LowerTopology.isClosed_Ici _).Prod <| LowerTopology.isClosed_Ici _).isOpen_compl
    rw [(lower_topology.is_topological_basis.prod LowerTopology.isTopologicalBasis).eq_generateFrom,
      le_generate_from_iff_subset_is_open, image2_subset_iff]
    rintro _ ⟨s, hs, rfl⟩ _ ⟨t, ht, rfl⟩
    dsimp
    simp_rw [coe_upperClosure, compl_Union, prod_eq, preimage_Inter, preimage_compl]
    -- Note: `refine` doesn't work here because it tries using `prod.topological_space`.
    apply (isOpen_binterᵢ hs fun a _ => _).inter (isOpen_binterᵢ ht fun b _ => _)
    · exact generate_open.basic _ ⟨(a, ⊥), by simp [Ici_prod_eq, prod_univ]⟩
    · exact generate_open.basic _ ⟨(⊥, b), by simp [Ici_prod_eq, univ_prod]⟩
    all_goals infer_instance

section CompleteLattice

variable [CompleteLattice α] [CompleteLattice β] [TopologicalSpace α] [LowerTopology α]
  [TopologicalSpace β] [LowerTopology β]

/- warning: Inf_hom.continuous -> InfₛHom.continuous is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {β : Type.{u2}} [_inst_1 : CompleteLattice.{u1} α] [_inst_2 : CompleteLattice.{u2} β] [_inst_3 : TopologicalSpace.{u1} α] [_inst_4 : LowerTopology.{u1} α _inst_3 (PartialOrder.toPreorder.{u1} α (CompleteSemilatticeInf.toPartialOrder.{u1} α (CompleteLattice.toCompleteSemilatticeInf.{u1} α _inst_1)))] [_inst_5 : TopologicalSpace.{u2} β] [_inst_6 : LowerTopology.{u2} β _inst_5 (PartialOrder.toPreorder.{u2} β (CompleteSemilatticeInf.toPartialOrder.{u2} β (CompleteLattice.toCompleteSemilatticeInf.{u2} β _inst_2)))] (f : InfₛHom.{u1, u2} α β (ConditionallyCompleteLattice.toHasInf.{u1} α (CompleteLattice.toConditionallyCompleteLattice.{u1} α _inst_1)) (ConditionallyCompleteLattice.toHasInf.{u2} β (CompleteLattice.toConditionallyCompleteLattice.{u2} β _inst_2))), Continuous.{u1, u2} α β _inst_3 _inst_5 (coeFn.{max (succ u1) (succ u2), max (succ u1) (succ u2)} (InfₛHom.{u1, u2} α β (ConditionallyCompleteLattice.toHasInf.{u1} α (CompleteLattice.toConditionallyCompleteLattice.{u1} α _inst_1)) (ConditionallyCompleteLattice.toHasInf.{u2} β (CompleteLattice.toConditionallyCompleteLattice.{u2} β _inst_2))) (fun (_x : InfₛHom.{u1, u2} α β (ConditionallyCompleteLattice.toHasInf.{u1} α (CompleteLattice.toConditionallyCompleteLattice.{u1} α _inst_1)) (ConditionallyCompleteLattice.toHasInf.{u2} β (CompleteLattice.toConditionallyCompleteLattice.{u2} β _inst_2))) => α -> β) (InfₛHom.hasCoeToFun.{u1, u2} α β (ConditionallyCompleteLattice.toHasInf.{u1} α (CompleteLattice.toConditionallyCompleteLattice.{u1} α _inst_1)) (ConditionallyCompleteLattice.toHasInf.{u2} β (CompleteLattice.toConditionallyCompleteLattice.{u2} β _inst_2))) f)
but is expected to have type
  forall {α : Type.{u2}} {β : Type.{u1}} [_inst_1 : CompleteLattice.{u2} α] [_inst_2 : CompleteLattice.{u1} β] [_inst_3 : TopologicalSpace.{u2} α] [_inst_4 : LowerTopology.{u2} α _inst_3 (PartialOrder.toPreorder.{u2} α (CompleteSemilatticeInf.toPartialOrder.{u2} α (CompleteLattice.toCompleteSemilatticeInf.{u2} α _inst_1)))] [_inst_5 : TopologicalSpace.{u1} β] [_inst_6 : LowerTopology.{u1} β _inst_5 (PartialOrder.toPreorder.{u1} β (CompleteSemilatticeInf.toPartialOrder.{u1} β (CompleteLattice.toCompleteSemilatticeInf.{u1} β _inst_2)))] (f : InfₛHom.{u2, u1} α β (ConditionallyCompleteLattice.toInfSet.{u2} α (CompleteLattice.toConditionallyCompleteLattice.{u2} α _inst_1)) (ConditionallyCompleteLattice.toInfSet.{u1} β (CompleteLattice.toConditionallyCompleteLattice.{u1} β _inst_2))), Continuous.{u2, u1} α β _inst_3 _inst_5 (FunLike.coe.{max (succ u2) (succ u1), succ u2, succ u1} (InfₛHom.{u2, u1} α β (ConditionallyCompleteLattice.toInfSet.{u2} α (CompleteLattice.toConditionallyCompleteLattice.{u2} α _inst_1)) (ConditionallyCompleteLattice.toInfSet.{u1} β (CompleteLattice.toConditionallyCompleteLattice.{u1} β _inst_2))) α (fun (_x : α) => (fun (x._@.Mathlib.Order.Hom.CompleteLattice._hyg.374 : α) => β) _x) (InfₛHomClass.toFunLike.{max u2 u1, u2, u1} (InfₛHom.{u2, u1} α β (ConditionallyCompleteLattice.toInfSet.{u2} α (CompleteLattice.toConditionallyCompleteLattice.{u2} α _inst_1)) (ConditionallyCompleteLattice.toInfSet.{u1} β (CompleteLattice.toConditionallyCompleteLattice.{u1} β _inst_2))) α β (ConditionallyCompleteLattice.toInfSet.{u2} α (CompleteLattice.toConditionallyCompleteLattice.{u2} α _inst_1)) (ConditionallyCompleteLattice.toInfSet.{u1} β (CompleteLattice.toConditionallyCompleteLattice.{u1} β _inst_2)) (InfₛHom.instInfₛHomClassInfₛHom.{u2, u1} α β (ConditionallyCompleteLattice.toInfSet.{u2} α (CompleteLattice.toConditionallyCompleteLattice.{u2} α _inst_1)) (ConditionallyCompleteLattice.toInfSet.{u1} β (CompleteLattice.toConditionallyCompleteLattice.{u1} β _inst_2)))) f)
Case conversion may be inaccurate. Consider using '#align Inf_hom.continuous InfₛHom.continuousₓ'. -/
theorem InfₛHom.continuous (f : InfₛHom α β) : Continuous f :=
  by
  convert continuous_generateFrom _
  · exact LowerTopology.topology_eq_lowerTopology β
  rintro _ ⟨b, rfl⟩
  rw [preimage_compl, isOpen_compl_iff]
  convert LowerTopology.isClosed_Ici (Inf <| f ⁻¹' Ici b)
  refine' subset_antisymm (fun a => infₛ_le) fun a ha => le_trans _ <| OrderHomClass.mono f ha
  simp [map_Inf]
#align Inf_hom.continuous InfₛHom.continuous

/- warning: lower_topology.to_has_continuous_inf -> LowerTopology.continuousInf is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} [_inst_1 : CompleteLattice.{u1} α] [_inst_3 : TopologicalSpace.{u1} α] [_inst_4 : LowerTopology.{u1} α _inst_3 (PartialOrder.toPreorder.{u1} α (CompleteSemilatticeInf.toPartialOrder.{u1} α (CompleteLattice.toCompleteSemilatticeInf.{u1} α _inst_1)))], ContinuousInf.{u1} α _inst_3 (SemilatticeInf.toHasInf.{u1} α (Lattice.toSemilatticeInf.{u1} α (ConditionallyCompleteLattice.toLattice.{u1} α (CompleteLattice.toConditionallyCompleteLattice.{u1} α _inst_1))))
but is expected to have type
  forall {α : Type.{u1}} [_inst_1 : CompleteLattice.{u1} α] [_inst_3 : TopologicalSpace.{u1} α] [_inst_4 : LowerTopology.{u1} α _inst_3 (PartialOrder.toPreorder.{u1} α (CompleteSemilatticeInf.toPartialOrder.{u1} α (CompleteLattice.toCompleteSemilatticeInf.{u1} α _inst_1)))], ContinuousInf.{u1} α _inst_3 (Lattice.toInf.{u1} α (ConditionallyCompleteLattice.toLattice.{u1} α (CompleteLattice.toConditionallyCompleteLattice.{u1} α _inst_1)))
Case conversion may be inaccurate. Consider using '#align lower_topology.to_has_continuous_inf LowerTopology.continuousInfₓ'. -/
-- see Note [lower instance priority]
instance (priority := 90) LowerTopology.continuousInf : ContinuousInf α :=
  ⟨(infInfₛHom : InfₛHom (α × α) α).Continuous⟩
#align lower_topology.to_has_continuous_inf LowerTopology.continuousInf

end CompleteLattice


import algebra.homology.functor

import for_mathlib.simplicial.complex

import polyhedral_lattice.cosimplicial
import polyhedral_lattice.Hom
import pseudo_normed_group.system_of_complexes
import system_of_complexes.rescale
import normed_spectral

import thm95.modify_complex
import thm95.polyhedral_iso

/-!
# The double complex that is the protagonist in the proof of Theorem 9.5
-/

noncomputable theory

open_locale nnreal big_operators
open category_theory opposite simplex_category

universe variables u v

namespace thm95

variables (BD : breen_deligne.data) (κ : ℕ → ℝ≥0) [BD.suitable κ]
variables (r r' : ℝ≥0) [fact (0 < r)] [fact (0 < r')] [fact (r < r')] [fact (r' ≤ 1)]
variables (V : SemiNormedGroup.{v}) [normed_with_aut r V]
variables (Λ : PolyhedralLattice.{u}) (M : ProFiltPseuNormGrpWithTinv.{u} r')
variables (N : ℕ) [fact (0 < N)]

section

open PolyhedralLattice

def Cech_nerve : cosimplicial_object.augmented (ProFiltPseuNormGrpWithTinv.{u} r')ᵒᵖ :=
(cosimplicial_object.augmented.whiskering_obj _ _ (Hom.{u u} M).right_op).obj
  (augmented_cosimplicial.{u} Λ N)

def Cech_augmentation_map : ((Cech_nerve r' Λ M N).right.obj (mk 0)).unop ⟶ (Hom M).obj (op Λ) :=
(Hom M).map (cosimplicial_augmentation_map Λ N).op

lemma Cech_nerve_hom_zero :
  (Cech_nerve.{u} r' Λ M N).hom.app (mk 0) = (Cech_augmentation_map.{u} r' Λ M N).op :=
begin
  dsimp only [Cech_nerve, Cech_augmentation_map, cosimplicial_object.augmented.whiskering_obj],
  simp only [whisker_right_app, category.id_comp, functor.right_op_map, nat_trans.comp_app,
    functor.const_comp_inv_app],
  congr' 2,
  dsimp only [augmented_cosimplicial, augmented_Cech_conerve],
  rw cosimplicial_object.augment_hom_zero,
  refl
end

lemma _root_.PolyhedralLattice.Cech_augmentation_map_eq_Hom_sum :
  (Λ.Hom_cosimplicial_zero_iso N r' M ↑N rfl).inv ≫ (thm95.Cech_augmentation_map r' Λ M N) =
  (Hom_sum Λ N r' M) :=
begin
  dsimp only [thm95.Cech_augmentation_map, Hom_cosimplicial_zero_iso,
    Hom_cosimplicial_zero_iso_aux_rfl, Hom_cosimplicial_zero_iso'],
  rw [iso.refl_trans, iso.refl_trans],
  dsimp only [iso.trans_inv, functor.map_iso_hom, functor.map_iso_inv, iso.symm_inv, op_comp],
  simp only [category.assoc, ← (Hom M).map_comp, augmentation_eq_diagonal, iso.op_hom, ← op_comp],
  dsimp only [Hom_rescale_iso, Hom_finsupp_iso],
  ext f l : 2,
  exact finsupp_sum_diagonal_embedding Λ N r' M f l,
end

def cosimplicial_system_of_complexes : cosimplicial_object.augmented system_of_complexes :=
(cosimplicial_object.augmented.whiskering_obj.{u} _ _ (BD.system κ r V r')).obj
  (Cech_nerve r' Λ M N)

lemma cosimplicial_system_of_complexes_hom_zero :
  (cosimplicial_system_of_complexes BD κ r r' V Λ M N).hom.app (mk 0) =
  (BD.system κ r V r').map (Cech_augmentation_map.{u} r' Λ M N).op :=
begin
  ext : 2, dsimp [cosimplicial_system_of_complexes],
  rw [category.id_comp, Cech_nerve_hom_zero]
end

@[simps X d]
def double_complex_aux : cochain_complex system_of_complexes ℕ :=
(cosimplicial_system_of_complexes BD κ r r' V Λ M N).to_cocomplex
.

@[simps obj map]
def double_complex' : system_of_double_complexes :=
(double_complex_aux BD κ r r' V Λ M N).as_functor

end

section

open polyhedral_lattice
open PolyhedralLattice (of cosimplicial)
open_locale nat

-- we now have a `cochain_complex` of `system_of_complexes`
-- so we need to reorganize the data, to get a `system_of_double_complexes`
-- this is what `.as_functor` does, in the definition `double_complex` below
-- but before we do this, we need to rescale the norms in all the rows,
-- so that the vertical differentials become norm-nonincreasing

set_option pp.universes true

@[simps X d]
def double_complex_aux_rescaled : cochain_complex system_of_complexes ℕ :=
@homological_complex.modify _ _ _ _ _ _ _ _
(double_complex_aux BD κ r r' V Λ M N )
  system_of_complexes.rescale_functor
  system_of_complexes.rescale_nat_trans
  (system_of_complexes.rescale_functor.additive)

@[simps obj map]
def double_complex : system_of_double_complexes :=
(double_complex_aux_rescaled BD κ r r' V Λ M N).as_functor

lemma double_complex.row_zero :
  (double_complex BD κ r r' V Λ M N).row 0 =
  (BD.system κ r V r').obj (op $ Hom Λ M) := rfl

lemma double_complex.row_one :
  (double_complex BD κ r r' V Λ M N).row 1 =
  (BD.system κ r V r').obj (op $ Hom ((cosimplicial Λ N).obj (mk 0)) M) := rfl

lemma double_complex.row_map_zero_one :
  (double_complex BD κ r r' V Λ M N).row_map 0 1 =
  (BD.system κ r V r').map (Cech_augmentation_map r' Λ M N).op :=
begin
  ext c i : 4,
  dsimp only [system_of_double_complexes.row_map_app_f, system_of_double_complexes.d,
    double_complex, homological_complex.as_functor_obj,
    double_complex_aux_rescaled, homological_complex.modify,
    system_of_complexes.rescale_nat_trans, nat_trans.id_app,
    system_of_complexes.rescale_functor, functor.id_map, double_complex_aux, op_unop],
  erw [category.comp_id, ← Cech_nerve_hom_zero],
  simp only [dite_eq_ite, breen_deligne.data.system_map, if_true, eq_self_iff_true,
    cosimplicial_object.augmented.to_cocomplex_d_2, eq_to_hom_refl, category.comp_id],
  dsimp only [cosimplicial_object.augmented.to_cocomplex_d,
    cosimplicial_system_of_complexes, cosimplicial_object.augmented.whiskering_obj],
  simp only [breen_deligne.data.system_map, whisker_right_app, category.id_comp,
    nat_trans.comp_app, functor.const_comp_inv_app],
  refl
end

lemma double_complex.row (m : ℕ) :
  (double_complex BD κ r r' V Λ M N).row (m+2) =
  (system_of_complexes.rescale_functor (m+2)).obj
    ((BD.system κ r V r').obj (op $ Hom ((cosimplicial Λ N).obj (mk (m+1))) M)) := rfl

end

end thm95

namespace thm95

variables (BD : breen_deligne.data)
variables (r r' : ℝ≥0) [fact (0 < r)] [fact (0 < r')] [fact (r < r')] [fact (r' ≤ 1)]
variables (V : SemiNormedGroup.{v}) [normed_with_aut r V]
variables (κ : ℕ → ℝ≥0) [BD.very_suitable r r' κ]
variables (Λ : PolyhedralLattice.{u}) (M : ProFiltPseuNormGrpWithTinv.{u} r')
variables (N : ℕ) [fact (0 < N)]

variables {r r' V κ Λ M N}

lemma double_complex.row_admissible :
  ∀ m, ((double_complex BD κ r r' V Λ M N).row m).admissible
| 0     := BD.system_admissible
| 1     := BD.system_admissible
| (m+2) := system_of_complexes.rescale_admissible _ _ BD.system_admissible

lemma double_complex.d_one_norm_noninc (c : ℝ≥0) (q : ℕ) :
  (@system_of_double_complexes.d (double_complex BD κ r r' V Λ M N) c 1 2 q).norm_noninc :=
begin
  apply normed_add_group_hom.norm_noninc.norm_noninc_iff_norm_le_one.2,
  refine normed_add_group_hom.norm_comp_le_of_le' 2 _ 1 _ (SemiNormedGroup.norm_to_rescale_le _ _) _,
  { norm_num },
  have : (2 : ℝ) = ∑ i : fin 2, 1,
  { simp only [finset.card_fin, mul_one, nat.cast_bit0, finset.sum_const, nsmul_eq_mul, nat.cast_one] },
  dsimp [system_of_complexes.rescale_functor, double_complex_aux,
    cosimplicial_object.augmented.to_cocomplex_d],
  erw [category.comp_id, if_pos rfl],
  dsimp [cosimplicial_object.coboundary],
  simp only [← nat_trans.app_hom_apply, add_monoid_hom.map_sum, add_monoid_hom.map_zsmul,
    ← homological_complex.hom.f_add_monoid_hom_apply, this],
  apply norm_sum_le_of_le,
  rintro i -,
  refine le_trans (norm_zsmul_le _ _) _,
  rw [← int.norm_cast_real, int.cast_pow, norm_pow, int.cast_neg, int.cast_one, norm_neg, norm_one,
    one_pow, one_mul],
  apply normed_add_group_hom.norm_noninc.norm_noninc_iff_norm_le_one.1,
  apply breen_deligne.data.complex.map_norm_noninc
end
.

lemma double_complex.d_two_norm_noninc (c : ℝ≥0) (p q : ℕ) :
  (@system_of_double_complexes.d (double_complex BD κ r r' V Λ M N) c (p+2) (p+3) q).norm_noninc :=
begin
  apply normed_add_group_hom.norm_noninc.norm_noninc_iff_norm_le_one.2,
  refine normed_add_group_hom.norm_comp_le_of_le' (p+3:ℕ) _ 1 _ (SemiNormedGroup.norm_scale_le _ _ _) _,
  { simp only [add_zero, nat.add_def, ← nat.cast_succ],
    norm_cast,
    rw [mul_comm, ← mul_div_assoc, eq_comm, ← nat.cast_mul, nat.factorial_succ], apply div_self,
    norm_num [nat.factorial_ne_zero] },
  apply SemiNormedGroup.norm_rescale_map_le,
  have : ((p+3:ℕ) : ℝ) = ∑ i : fin (p+3), 1,
  { simp only [finset.card_fin, mul_one, finset.sum_const, nsmul_eq_mul, nat.cast_id,
      nat.cast_bit1, nat.cast_add, nat.cast_one] },
  dsimp [system_of_complexes.rescale_functor, double_complex_aux,
    cosimplicial_object.augmented.to_cocomplex_d],
  erw [category.comp_id, if_pos rfl],
  dsimp [cosimplicial_object.coboundary],
  simp only [← nat_trans.app_hom_apply, add_monoid_hom.map_sum, add_monoid_hom.map_zsmul,
    ← homological_complex.hom.f_add_monoid_hom_apply, this],
  apply norm_sum_le_of_le,
  rintro i -,
  refine le_trans (norm_zsmul_le _ _) _,
  rw [← int.norm_cast_real, int.cast_pow, norm_pow, int.cast_neg, int.cast_one, norm_neg, norm_one,
    one_pow, one_mul],
  apply normed_add_group_hom.norm_noninc.norm_noninc_iff_norm_le_one.1,
  apply breen_deligne.data.complex.map_norm_noninc
end

lemma double_complex.d_norm_noninc (c : ℝ≥0) (q : ℕ) :
  ∀ p, (@system_of_double_complexes.d (double_complex BD κ r r' V Λ M N) c p (p+1) q).norm_noninc
| 0     := breen_deligne.data.complex.map_norm_noninc _ _ _ _ _ _ _ _
| 1     := double_complex.d_one_norm_noninc _ _ _
| (p+2) := double_complex.d_two_norm_noninc _ _ _ _

-- see above: currently we can only prove this for the columns
lemma double_complex_admissible :
  (double_complex BD κ r r' V Λ M N).admissible :=
system_of_double_complexes.admissible.mk' (double_complex.row_admissible _)
  (by { rintro _ _ _ _ rfl, apply double_complex.d_norm_noninc })

end thm95


import pq_to_group
import minimal_sub_pq_gen_group
import group_theory.semidirect_product

universes u1 u2

section pq_like_semidirect_product

variables {Q1 : Type u1} {Q2 : Type u2} [power_quandle Q1] [power_quandle Q2]

variables {φ : pq_group Q2 →* mul_aut (pq_group Q1)}

variables {hφ : ∀ x : Q2, ∀ y : Q1, ∃ z : Q1, ((φ (of x)) (of y)) = of z}

def semidirect_product_gen : set (pq_group Q1 ⋊[φ] pq_group Q2) := λ x, (∃ q : Q1, x = semidirect_product.inl (of q)) ∨ (∃ q : Q2, x = semidirect_product.inr (of q))

def lhs_to_pq_gen_set_semidirect : pq_group Q1 →* pq_group (free_gen_group_sub_pq (@semidirect_product_gen _ _ _ _ φ)) :=
begin
  fapply pq_morph_to_L_morph_adj,
  {
    intro q,
    apply of,
    fconstructor,
    exact semidirect_product.inl (of q),
    apply gen_in_free_group_sub_pq_carrier,
    left,
    use q,
  },
  {
    split,
    {
      intros a b,
      rw rhd_of_eq_of_rhd,
      apply congr_arg,
      ext1,
      simp only [subtype.coe_mk],
      rw ←rhd_of_eq_of_rhd,
      rw rhd_def_group,
      simp only [monoid_hom.map_mul, monoid_hom.map_mul_inv],
      rw ←rhd_def_group,
      refl,
    },
    {
      intros a n,
      rw ←of_pow_eq_pow_of,
      apply congr_arg,
      ext1,
      simp only [subtype.coe_mk],
      rw of_pow_eq_pow_of,
      rw monoid_hom.map_gpow,
      refl,
    },
  }
end

def rhs_to_pq_gen_set_semidirect : pq_group Q2 →* pq_group (free_gen_group_sub_pq (@semidirect_product_gen _ _ _ _ φ)) :=
begin
  fapply pq_morph_to_L_morph_adj,
  {
    intro q,
    apply of,
    fconstructor,
    exact semidirect_product.inr (of q),
    apply gen_in_free_group_sub_pq_carrier,
    right,
    use q,
  },
  {
    split,
    {
      intros a b,
      rw rhd_of_eq_of_rhd,
      apply congr_arg,
      ext1,
      simp only [subtype.coe_mk],
      rw ←rhd_of_eq_of_rhd,
      rw rhd_def_group,
      simp only [monoid_hom.map_mul, monoid_hom.map_mul_inv],
      rw ←rhd_def_group,
      refl,
    },
    {
      intros a n,
      rw ←of_pow_eq_pow_of,
      apply congr_arg,
      ext1,
      simp only [subtype.coe_mk],
      rw of_pow_eq_pow_of,
      rw monoid_hom.map_gpow,
      refl,
    },
  }
end

variables {G : Type*} [group G]

lemma subtype_rhd_def (a b : G) (gen : set G) {ha : a ∈ (↑(free_gen_group_sub_pq gen) : set G)} {hb : b ∈ (↑(free_gen_group_sub_pq gen) : set G)} : (⟨a, ha⟩ : free_gen_group_sub_pq gen) ▷ ⟨b, hb⟩ = ⟨a ▷ b, sub_power_quandle.closed_rhd (free_gen_group_sub_pq gen) a b ha hb⟩ :=
begin
  refl,
end

include hφ

def semidirect_to_pq_gen_set_semidirect : pq_group Q1 ⋊[φ] pq_group Q2 →* pq_group (free_gen_group_sub_pq (@semidirect_product_gen _ _ _ _ φ)) :=
begin
  fapply semidirect_product.lift,
  {
    apply lhs_to_pq_gen_set_semidirect,
  },
  {
    apply rhs_to_pq_gen_set_semidirect,
  },
  {
    intro x,
    ext1 y,
    simp only [mul_equiv.coe_to_monoid_hom, mul_aut.conj_apply, function.comp_app, monoid_hom.coe_comp],
    revert y,
    induction x,
    {
      rw quot_mk_helper,
      induction x,
      {
        intro y,
        rw incl_unit_eq_unit,
        simp only [one_inv, mul_aut.one_apply, mul_one, one_mul, monoid_hom.map_one],
      },
      {
        intro y,
        rw ←of_def,
        rw ←rhd_def_group,
        unfold rhs_to_pq_gen_set_semidirect,
        rw pq_morph_to_L_morph_adj_comm_of,

        induction y,
        {
          rw quot_mk_helper,
          induction y,
          {
            rw incl_unit_eq_unit,
            simp only [mul_equiv.map_one, monoid_hom.map_one],
            rw rhd_def_group,
            simp only [mul_one, mul_right_inv],
          },
          {
            rw ←of_def,
            unfold lhs_to_pq_gen_set_semidirect,
            rw pq_morph_to_L_morph_adj_comm_of,
            rw rhd_of_eq_of_rhd,
            rw subtype_rhd_def,
            simp_rw rhd_def_group,
            cases hφ x y with z hz,
            rw hz,
            rw pq_morph_to_L_morph_adj_comm_of,
            apply congr_arg,
            ext1,
            simp only [subtype.coe_mk],
            rw ←hz,
            rw semidirect_product.inl_aut (of x) (of y),
            simp only [monoid_hom.map_inv],
          },
          {
            rw ←mul_def,
            simp only [monoid_hom.map_mul, mul_equiv.map_mul],
            rw rhd_mul,
            rw y_ih_a,
            rw y_ih_b,
          },
          {
            rw ←inv_def,
            simp only [monoid_hom.map_inv, mul_equiv.map_inv],
            rw rhd_inv,
            rw y_ih,
          },
        },
        {refl,},
      },
      {
        intro y,
        rw ←mul_def,
        rw ←rhd_def_group,
        simp only [monoid_hom.map_mul, mul_aut.mul_apply],
        rw mul_rhd,
        --rw ←rhd_def at x_ih_a x_ih_b,
        specialize x_ih_b y,
        rw ←rhd_def_group at x_ih_b,
        rw ←x_ih_b,
        simp_rw ←rhd_def_group at x_ih_a,
        rw ←x_ih_a,
      },
      {
        intro y,
        specialize x_ih ((φ ⟦x_a⟧⁻¹) y),
        simp only [mul_aut.apply_inv_self, monoid_hom.map_inv] at x_ih,
        rw ←inv_def,
        simp only [inv_inv, monoid_hom.map_inv],
        rw x_ih,
        group,
      },
    },
    {
      intro y,
      refl,
    },
  },
end

def semidirect_product_pq_like : pq_group Q1 ⋊[φ] pq_group Q2 ≃* pq_group (free_gen_group_sub_pq (@semidirect_product_gen _ _ _ _ φ)) :=
{ to_fun := @semidirect_to_pq_gen_set_semidirect _ _ _ _ φ hφ,
  inv_fun := gen_set_counit semidirect_product_gen,
  left_inv := begin
    intro x,
    cases x with x1 x2,
    simp only [semidirect_product.mk_eq_inl_mul_inr, monoid_hom.map_mul],
    unfold semidirect_to_pq_gen_set_semidirect,
    rw semidirect_product.lift_inl,
    rw semidirect_product.lift_inr,
    apply congr_arg2,
    {
      clear x2,
      induction x1,
      {
        rw quot_mk_helper,
        induction x1,
        {
          rw incl_unit_eq_unit,
          simp only [monoid_hom.map_one],
        },
        {
          rw ←of_def,
          refl,
        },
        {
          rw ←mul_def,
          simp only [monoid_hom.map_mul],
          rw x1_ih_a,
          rw x1_ih_b,
        },
        {
          rw ←inv_def,
          simp only [inv_inj, monoid_hom.map_inv],
          assumption,
        },
      },
      {refl,},
    },
    {
      clear x1,
      induction x2,
      {
        rw quot_mk_helper,
        induction x2,
        {
          rw incl_unit_eq_unit,
          simp only [monoid_hom.map_one],
        },
        {
          rw ←of_def,
          refl,
        },
        {
          rw ←mul_def,
          simp only [monoid_hom.map_mul],
          rw x2_ih_a,
          rw x2_ih_b,
        },
        {
          rw ←inv_def,
          simp only [inv_inj, monoid_hom.map_inv],
          assumption,
        },
      },
      {refl,},
    },
  end,
  right_inv := begin
    intro x,
    induction x,
    {
      rw quot_mk_helper,
      induction x,
      {
        rw incl_unit_eq_unit,
        simp only [monoid_hom.map_one],
      },
      {
        rw ←of_def,
        unfold gen_set_counit,
        rw pq_morph_to_L_morph_adj_comm_of,
        cases x with x hx,
        simp only,
        induction hx,
        {
          cases hx_hx with hy hy,
          {
            cases hy with y hy,
            simp_rw hy,
            unfold semidirect_to_pq_gen_set_semidirect,
            rw semidirect_product.lift_inl,
            unfold lhs_to_pq_gen_set_semidirect,
            rw pq_morph_to_L_morph_adj_comm_of,
            refl,
          },
          {
            cases hy with y hy,
            simp_rw hy,
            unfold semidirect_to_pq_gen_set_semidirect,
            rw semidirect_product.lift_inr,
            unfold rhs_to_pq_gen_set_semidirect,
            rw pq_morph_to_L_morph_adj_comm_of,
            refl,
          },
        },
        {
          simp only [monoid_hom.map_mul, monoid_hom.map_mul_inv],
          simp_rw ←rhd_def_group,
          rw hx_ih_hx,
          rw hx_ih_hy,
          rw rhd_of_eq_of_rhd,
          apply congr_arg,
          refl,
        },
        {
          rw monoid_hom.map_gpow,
          rw hx_ih,
          rw ←of_pow_eq_pow_of,
          apply congr_arg,
          refl,
        },
        {
          rw monoid_hom.map_one,
          rw ←of_one,
          refl,
        },
      },
      {
        rw ←mul_def,
        simp only [monoid_hom.map_mul],
        rw x_ih_a,
        rw x_ih_b,
      },
      {
        rw ←inv_def,
        simp only [inv_inj, monoid_hom.map_inv],
        assumption,
      },
    },
    {refl,},
  end,
  map_mul' := begin
    intros x y,
    simp only [monoid_hom.map_mul],
  end }

end pq_like_semidirect_product


import to_product
open category_theory
open opposite
open category_theory.limits
open category_theory.category
open Product_stuff
universes v u
variables {C : Type u}
variables [𝒞 : category.{v} C]
variables  [has_binary_products.{v} C][has_terminal.{v} C]
include 𝒞

namespace Yoneda
def Yo (R : C)(A :C) := (yoneda.obj A).obj (op R)
def Yo_ (R : C) {A B : C}(φ : A ⟶ B) := ((yoneda.map φ).app (op R) : Yo R A ⟶ Yo R B)
notation R`⟦`:33 A`⟧`:21 := Yo R A
notation  R`<`:100 φ`>`   := Yo_ R φ

lemma apply_to_composition {R : C}{Z K :C}(f :  R ⟶ Z)(g : Z ⟶ K) :
     R < g > f = f ≫ g := rfl
lemma composition_to_apply {R : C}{Z K :C}(f :  R ⟶ Z)(g : Z ⟶ K) :
   f ≫ g  =   (R < g > f)  := rfl
lemma id (R : C)(A : C) : R < 𝟙 A > = 𝟙 (R⟦ A⟧ ) := begin
     funext,
     exact comp_id g,
     -- have T : ((yoneda.map (𝟙 A)).app (op R)) g = (g ≫ (𝟙 A)),
end

def Yoneda_preserve_product (Y : C)(A B : C) :
     Y ⟦ A ⨯ B ⟧  ≅ Y ⟦ A ⟧  ⨯ Y⟦ B ⟧   :=
{ hom := (Y< π1 > | Y <π2>),
  inv := λ g : (Y ⟶ A) ⨯ (Y ⟶ B),
    ( (π1 : (Y ⟶ A) ⨯ (Y ⟶ B) ⟶ (Y ⟶ A)) g |  (π2 : (Y ⟶ A) ⨯ (Y ⟶ B) ⟶ (Y ⟶ B)) g  )
      ,  --- g ≫ π1
  hom_inv_id' := begin
     funext g,
     rw types_comp_apply,
     apply prod.hom_ext,
     rw prod.lift_fst,
     rw ←  types_comp_apply (Y < π1> | Y < π2>)  π1 g,
     rw prod.lift_fst,
     exact rfl,
     -- rw apply_to_composition,
     -- rw types_id,
     tidy,
  end,
   inv_hom_id' := begin
    apply prod.hom_ext,
    rw assoc,
    rw prod.lift_fst,funext ζ ,
    rw types_comp_apply,rw apply_to_composition,
    rw prod.lift_fst,
    exact rfl,
    rw assoc,
    rw prod.lift_snd,funext ζ,
     rw types_comp_apply,
    rw apply_to_composition,
    rw prod.lift_snd,
    exact rfl,
  end
}

-- def Yoneda_preserve_product (Y : C)(A B : C) :
--      Y ⟦ A ⨯ B ⟧  ≅ Y ⟦ A ⟧  ⨯ Y⟦ B ⟧   :=
-- { hom := prod.lift
--     (λ f, f ≫ π1)
--     (λ f, f ≫ π2),
--   inv := λ f : (Y ⟶ A) ⨯ (Y ⟶ B),
--     (prod.lift
--       ((@category_theory.limits.prod.fst _ _ (Y ⟶ A) (Y ⟶ B) _ : ((Y ⟶ A) ⨯ (Y ⟶ B)) → (Y ⟶ A)) f)
--       ((@category_theory.limits.prod.snd _ _ (Y ⟶ A) _ _ : ((Y ⟶ A) ⨯ (Y ⟶ B)) → (Y ⟶ B)) f : Y ⟶ B)),
--   hom_inv_id' := begin
--     ext f,
--     cases j,   --- HERE
--     { simp, refl},
--     { simp, refl}
--   end,
--   inv_hom_id' := begin
--     apply prod.hom_ext,
--     { rw assoc, rw prod.lift_fst, obviously},
--     { rw assoc, rw prod.lift_snd, obviously}
--   end
-- }
--- Here it just sugar

lemma composition (R : C) {X Y Z : C} (f : X ⟶ Y) (g : Y ⟶ Z) :
          R < f ≫ g > =  R< f > ≫ R < g >
 :=  begin
     funext ζ,
     rw apply_to_composition,
     rw types_comp_apply,
     iterate 2 {rw apply_to_composition},
     exact eq.symm  ( assoc ζ f  g),
 end
def convertion {R : C}{A : C}(g : R⟦ A⟧ ) : R ⟶ A := g

def Preserve.product_up_to_iso (R : C)(A B : C) : R⟦A ⨯ B⟧  ≅ R⟦A⟧  ⨯ R⟦B⟧ := Yoneda_preserve_product R A B
lemma Preserve.product.hom (R : C)(A B : C) :
     (Preserve.product_up_to_iso R A B).hom =  (R < π1  > | R < π2 > ) := rfl

lemma Preserve.prod_morphism (R : C)(A B : C)(X :C)(f : X ⟶ A)(g : X ⟶ B) :
      R < (f | g) > ≫ (R < π1  > | R < π2 >) =  (R < f > | R < g >) :=  -- the  ≫  is  :/
     begin
          rw prod.left_composition,
          iterate 2 {rw [← composition]},
          rw prod.lift_fst,
          rw prod.lift_snd,
     end

lemma  Preserve.otimes_morphism (R : C){ X Y Z K :C}(f : X ⟶ Y )(g : Z ⟶ K) :
 (R < π1 > | R < π2 >)  ≫ ( R < f > ⊗ R < g > ) =  R < (f ⊗ g) >  ≫ (R < π1 > |R < π2 >)    :=
  begin
     rw prod.prod_comp_otimes,
     rw prod.otimes_is_prod,
     rw prod.left_composition,
     rw ← composition,
     rw ← composition,
     slice_rhs 2 3 {
          rw ← composition,
          rw prod.lift_snd,
     },
     slice_rhs 1 1 {
          rw ← composition,
          rw prod.lift_fst,
     },
end
lemma prod_apply {R :C}{A Y Z : C }(ζ : R ⟦ A ⟧)  (f : A ⟶ Y)(g : A ⟶ Y) :
     ( R< (f | g) >) ζ = (R < f > ζ | R < g > ζ ) :=
          begin
               rw apply_to_composition,
               rw prod.left_composition,
               iterate 2 {rw apply_to_composition},
          end
lemma otimes_apply {R :C}{A1 A2 Y Z : C }(ζ1 : R ⟦ A1 ⟧)(ζ2 : R⟦ A2 ⟧ )
 (f1 : A1 ⟶ Y)(f2 : A2 ⟶ Z) :
          R < (f1 ⊗ f2 ) > (ζ1 | ζ2) = ( R < f1 > ζ1 | R < f2 > ζ2 ) :=
 begin
     rw apply_to_composition,
     rw prod.prod_comp_otimes,
     exact rfl,
 end
 end Yoneda


import data.multiset

@[reducible] noncomputable def multiset.to_list {α : Type*} (s : multiset α) := classical.some (quotient.exists_rep s)

@[simp] lemma multiset.to_list_zero {α : Type*} : (multiset.to_list 0 : list α) = [] :=
  (multiset.coe_eq_zero _).1 (classical.some_spec (quotient.exists_rep multiset.zero))

lemma multiset.coe_to_list {α : Type*} (s : multiset α) : (s.to_list : multiset α) = s :=
classical.some_spec (quotient.exists_rep _)

lemma multiset.mem_to_list {α : Type*} (a : α) (s : multiset α) : a ∈ s.to_list ↔ a ∈ s :=
by rw [←multiset.mem_coe, multiset.coe_to_list]

/-
@[simp] lemma multiset.to_list_cons {α : Type*} (a : α) (as : list α) :
  (multiset.to_list (a :: as) : list α) = [] := sorry
-/

lemma multiset.prod_eq_zero {α : Type*} [comm_semiring α] {s : multiset α} (h : (0 : α) ∈ s) :
  multiset.prod s = 0 :=
begin
  rcases multiset.exists_cons_of_mem h with ⟨s', hs'⟩,
  simp [hs', multiset.prod_cons]
end


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

import category_theory.adjunction.basic
import category_theory.yoneda
import category_theory.opposites

/-!
# Opposite adjunctions

This file contains constructions to relate adjunctions of functors to adjunctions of their
opposites.
These constructions are used to show uniqueness of adjoints (up to natural isomorphism).

## Tags
adjunction, opposite, uniqueness
-/

open category_theory

universes v₁ v₂ u₁ u₂ -- morphism levels before object levels. See note [category_theory universes].

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

namespace adjunction

/-- If `G.op` is adjoint to `F.op` then `F` is adjoint to `G`. -/
@[simps] def adjoint_of_op_adjoint_op (F : C ⥤ D) (G : D ⥤ C) (h : G.op ⊣ F.op) : F ⊣ G :=
adjunction.mk_of_hom_equiv
{ hom_equiv := λ X Y,
  ((h.hom_equiv (opposite.op Y) (opposite.op X)).trans (op_equiv _ _)).symm.trans (op_equiv _ _) }

/-- If `G` is adjoint to `F.op` then `F` is adjoint to `G.unop`. -/
def adjoint_unop_of_adjoint_op (F : C ⥤ D) (G : Dᵒᵖ ⥤ Cᵒᵖ) (h : G ⊣ F.op) : F ⊣ G.unop :=
adjoint_of_op_adjoint_op F G.unop (h.of_nat_iso_left G.op_unop_iso.symm)

/-- If `G.op` is adjoint to `F` then `F.unop` is adjoint to `G`. -/
def unop_adjoint_of_op_adjoint (F : Cᵒᵖ ⥤ Dᵒᵖ) (G : D ⥤ C) (h : G.op ⊣ F) : F.unop ⊣ G :=
adjoint_of_op_adjoint_op _ _ (h.of_nat_iso_right F.op_unop_iso.symm)

/-- If `G` is adjoint to `F` then `F.unop` is adjoint to `G.unop`. -/
def unop_adjoint_unop_of_adjoint (F : Cᵒᵖ ⥤ Dᵒᵖ) (G : Dᵒᵖ ⥤ Cᵒᵖ) (h : G ⊣ F) : F.unop ⊣ G.unop :=
adjoint_unop_of_adjoint_op F.unop G (h.of_nat_iso_right F.op_unop_iso.symm)

/-- If `G` is adjoint to `F` then `F.op` is adjoint to `G.op`. -/
@[simps] def op_adjoint_op_of_adjoint (F : C ⥤ D) (G : D ⥤ C) (h : G ⊣ F) : F.op ⊣ G.op :=
adjunction.mk_of_hom_equiv
{ hom_equiv := λ X Y,
  (op_equiv _ Y).trans ((h.hom_equiv _ _).symm.trans (op_equiv X (opposite.op _)).symm) }

/-- If `G` is adjoint to `F.unop` then `F` is adjoint to `G.op`. -/
def adjoint_op_of_adjoint_unop (F : Cᵒᵖ ⥤ Dᵒᵖ) (G : D ⥤ C) (h : G ⊣ F.unop) : F ⊣ G.op :=
(op_adjoint_op_of_adjoint F.unop _ h).of_nat_iso_left F.op_unop_iso

/-- If `G.unop` is adjoint to `F` then `F.op` is adjoint to `G`. -/
def op_adjoint_of_unop_adjoint (F : C ⥤ D) (G : Dᵒᵖ ⥤ Cᵒᵖ) (h : G.unop ⊣ F) : F.op ⊣ G :=
(op_adjoint_op_of_adjoint _ G.unop h).of_nat_iso_right G.op_unop_iso

/-- If `G.unop` is adjoint to `F.unop` then `F` is adjoint to `G`. -/
def adjoint_of_unop_adjoint_unop (F : Cᵒᵖ ⥤ Dᵒᵖ) (G : Dᵒᵖ ⥤ Cᵒᵖ) (h : G.unop ⊣ F.unop) : F ⊣ G :=
(adjoint_op_of_adjoint_unop _ _ h).of_nat_iso_right G.op_unop_iso

/--
If `F` and `F'` are both adjoint to `G`, there is a natural isomorphism
`F.op ⋙ coyoneda ≅ F'.op ⋙ coyoneda`.
We use this in combination with `fully_faithful_cancel_right` to show left adjoints are unique.
-/
def left_adjoints_coyoneda_equiv {F F' : C ⥤ D} {G : D ⥤ C}
  (adj1 : F ⊣ G) (adj2 : F' ⊣ G):
  F.op ⋙ coyoneda ≅ F'.op ⋙ coyoneda :=
nat_iso.of_components
  (λ X, nat_iso.of_components
    (λ Y, ((adj1.hom_equiv X.unop Y).trans (adj2.hom_equiv X.unop Y).symm).to_iso)
    (by tidy))
  (by tidy)

/-- If `F` and `F'` are both left adjoint to `G`, then they are naturally isomorphic. -/
def left_adjoint_uniq {F F' : C ⥤ D} {G : D ⥤ C}
  (adj1 : F ⊣ G) (adj2 : F' ⊣ G) : F ≅ F' :=
nat_iso.remove_op (fully_faithful_cancel_right _ (left_adjoints_coyoneda_equiv adj2 adj1))

@[simp]
lemma hom_equiv_left_adjoint_uniq_hom_app {F F' : C ⥤ D} {G : D ⥤ C}
  (adj1 : F ⊣ G) (adj2 : F' ⊣ G) (x : C) :
  adj1.hom_equiv _ _ ((left_adjoint_uniq adj1 adj2).hom.app x) = adj2.unit.app x :=
begin
  apply (adj1.hom_equiv _ _).symm.injective,
  apply quiver.hom.op_inj,
  apply coyoneda.map_injective,
  swap, apply_instance,
  ext f y,
  simpa [left_adjoint_uniq, left_adjoints_coyoneda_equiv]
end

@[simp, reassoc]
lemma unit_left_adjoint_uniq_hom {F F' : C ⥤ D} {G : D ⥤ C} (adj1 : F ⊣ G) (adj2 : F' ⊣ G) :
  adj1.unit ≫ whisker_right (left_adjoint_uniq adj1 adj2).hom G = adj2.unit :=
begin
  ext x,
  rw [nat_trans.comp_app, ← hom_equiv_left_adjoint_uniq_hom_app adj1 adj2],
  simp [-hom_equiv_left_adjoint_uniq_hom_app, ←G.map_comp]
end

@[simp, reassoc]
lemma unit_left_adjoint_uniq_hom_app {F F' : C ⥤ D} {G : D ⥤ C}
  (adj1 : F ⊣ G) (adj2 : F' ⊣ G) (x : C) :
  adj1.unit.app x ≫ G.map ((left_adjoint_uniq adj1 adj2).hom.app x) = adj2.unit.app x :=
by { rw ← unit_left_adjoint_uniq_hom adj1 adj2, refl }

@[simp, reassoc]
lemma left_adjoint_uniq_hom_counit {F F' : C ⥤ D} {G : D ⥤ C} (adj1 : F ⊣ G) (adj2 : F' ⊣ G) :
  whisker_left G (left_adjoint_uniq adj1 adj2).hom ≫ adj2.counit = adj1.counit :=
begin
  ext x,
  apply quiver.hom.op_inj,
  apply coyoneda.map_injective,
  swap, apply_instance,
  ext y f,
  have : F.map (adj2.unit.app (G.obj x)) ≫ adj1.counit.app (F'.obj (G.obj x)) ≫
    adj2.counit.app x ≫ f = adj1.counit.app x ≫ f,
  { erw [← adj1.counit.naturality, ← F.map_comp_assoc], simpa },
  simpa [left_adjoint_uniq, left_adjoints_coyoneda_equiv] using this
end

@[simp, reassoc]
lemma left_adjoint_uniq_hom_app_counit {F F' : C ⥤ D} {G : D ⥤ C}
  (adj1 : F ⊣ G) (adj2 : F' ⊣ G) (x : D) :
  (left_adjoint_uniq adj1 adj2).hom.app (G.obj x) ≫ adj2.counit.app x = adj1.counit.app x :=
by { rw ← left_adjoint_uniq_hom_counit adj1 adj2, refl }

@[simp]
lemma left_adjoint_uniq_inv_app {F F' : C ⥤ D} {G : D ⥤ C}
  (adj1 : F ⊣ G) (adj2 : F' ⊣ G) (x : C) :
  (left_adjoint_uniq adj1 adj2).inv.app x = (left_adjoint_uniq adj2 adj1).hom.app x := rfl

@[simp, reassoc]
lemma left_adjoint_uniq_trans {F F' F'' : C ⥤ D} {G : D ⥤ C}
  (adj1 : F ⊣ G) (adj2 : F' ⊣ G) (adj3 : F'' ⊣ G) :
  (left_adjoint_uniq adj1 adj2).hom ≫ (left_adjoint_uniq adj2 adj3).hom =
    (left_adjoint_uniq adj1 adj3).hom :=
begin
  ext,
  apply quiver.hom.op_inj,
  apply coyoneda.map_injective,
  swap, apply_instance,
  ext,
  simp [left_adjoints_coyoneda_equiv, left_adjoint_uniq]
end

@[simp, reassoc]
lemma left_adjoint_uniq_trans_app {F F' F'' : C ⥤ D} {G : D ⥤ C}
  (adj1 : F ⊣ G) (adj2 : F' ⊣ G) (adj3 : F'' ⊣ G) (x : C) :
  (left_adjoint_uniq adj1 adj2).hom.app x ≫ (left_adjoint_uniq adj2 adj3).hom.app x =
    (left_adjoint_uniq adj1 adj3).hom.app x :=
by { rw ← left_adjoint_uniq_trans adj1 adj2 adj3, refl }

@[simp]
lemma left_adjoint_uniq_refl {F : C ⥤ D} {G : D ⥤ C} (adj1 : F ⊣ G) :
  (left_adjoint_uniq adj1 adj1).hom = 𝟙 _ :=
begin
  ext,
  apply quiver.hom.op_inj,
  apply coyoneda.map_injective,
  swap, apply_instance,
  ext,
  simp [left_adjoints_coyoneda_equiv, left_adjoint_uniq]
end

/-- If `G` and `G'` are both right adjoint to `F`, then they are naturally isomorphic. -/
def right_adjoint_uniq {F : C ⥤ D} {G G' : D ⥤ C}
  (adj1 : F ⊣ G) (adj2 : F ⊣ G') : G ≅ G' :=
nat_iso.remove_op
  (left_adjoint_uniq (op_adjoint_op_of_adjoint _ F adj2) (op_adjoint_op_of_adjoint _ _ adj1))

@[simp]
lemma hom_equiv_symm_right_adjoint_uniq_hom_app {F : C ⥤ D} {G G' : D ⥤ C}
  (adj1 : F ⊣ G) (adj2 : F ⊣ G') (x : D) :
  (adj2.hom_equiv _ _).symm ((right_adjoint_uniq adj1 adj2).hom.app x) = adj1.counit.app x :=
begin
  apply quiver.hom.op_inj,
  convert hom_equiv_left_adjoint_uniq_hom_app
    (op_adjoint_op_of_adjoint _ F adj2) (op_adjoint_op_of_adjoint _ _ adj1) (opposite.op x),
  simpa
end

@[simp, reassoc]
lemma unit_right_adjoint_uniq_hom_app {F : C ⥤ D} {G G' : D ⥤ C}
  (adj1 : F ⊣ G) (adj2 : F ⊣ G') (x : C) :
  adj1.unit.app x ≫ (right_adjoint_uniq adj1 adj2).hom.app (F.obj x) = adj2.unit.app x :=
begin
  apply quiver.hom.op_inj,
  convert left_adjoint_uniq_hom_app_counit
    (op_adjoint_op_of_adjoint _ _ adj2) (op_adjoint_op_of_adjoint _ _ adj1) (opposite.op x),
  all_goals { simpa }
end

@[simp, reassoc]
lemma unit_right_adjoint_uniq_hom {F : C ⥤ D} {G G' : D ⥤ C} (adj1 : F ⊣ G) (adj2 : F ⊣ G') :
  adj1.unit ≫ whisker_left F (right_adjoint_uniq adj1 adj2).hom = adj2.unit :=
by { ext x, simp }

@[simp, reassoc]
lemma right_adjoint_uniq_hom_app_counit {F : C ⥤ D} {G G' : D ⥤ C}
  (adj1 : F ⊣ G) (adj2 : F ⊣ G') (x : D) :
  F.map ((right_adjoint_uniq adj1 adj2).hom.app x) ≫ adj2.counit.app x = adj1.counit.app x :=
begin
  apply quiver.hom.op_inj,
  convert unit_left_adjoint_uniq_hom_app
    (op_adjoint_op_of_adjoint _ _ adj2) (op_adjoint_op_of_adjoint _ _ adj1) (opposite.op x),
  all_goals { simpa }
end

@[simp, reassoc]
lemma right_adjoint_uniq_hom_counit {F : C ⥤ D} {G G' : D ⥤ C} (adj1 : F ⊣ G) (adj2 : F ⊣ G') :
  whisker_right (right_adjoint_uniq adj1 adj2).hom F ≫ adj2.counit = adj1.counit :=
by { ext, simp }

@[simp]
lemma right_adjoint_uniq_inv_app {F : C ⥤ D} {G G' : D ⥤ C}
  (adj1 : F ⊣ G) (adj2 : F ⊣ G') (x : D) :
  (right_adjoint_uniq adj1 adj2).inv.app x = (right_adjoint_uniq adj2 adj1).hom.app x := rfl

@[simp, reassoc]
lemma right_adjoint_uniq_trans_app {F : C ⥤ D} {G G' G'' : D ⥤ C}
  (adj1 : F ⊣ G) (adj2 : F ⊣ G') (adj3 : F ⊣ G'') (x : D) :
  (right_adjoint_uniq adj1 adj2).hom.app x ≫ (right_adjoint_uniq adj2 adj3).hom.app x =
    (right_adjoint_uniq adj1 adj3).hom.app x :=
begin
  apply quiver.hom.op_inj,
  exact left_adjoint_uniq_trans_app (op_adjoint_op_of_adjoint _ _ adj3)
    (op_adjoint_op_of_adjoint _ _ adj2) (op_adjoint_op_of_adjoint _ _ adj1) (opposite.op x)
end

@[simp, reassoc]
lemma right_adjoint_uniq_trans {F : C ⥤ D} {G G' G'' : D ⥤ C}
  (adj1 : F ⊣ G) (adj2 : F ⊣ G') (adj3 : F ⊣ G'') :
  (right_adjoint_uniq adj1 adj2).hom ≫ (right_adjoint_uniq adj2 adj3).hom =
    (right_adjoint_uniq adj1 adj3).hom :=
by { ext, simp }

@[simp]
lemma right_adjoint_uniq_refl {F : C ⥤ D} {G : D ⥤ C} (adj1 : F ⊣ G) :
  (right_adjoint_uniq adj1 adj1).hom = 𝟙 _ :=
by { delta right_adjoint_uniq, simp }

/--
Given two adjunctions, if the left adjoints are naturally isomorphic, then so are the right
adjoints.
-/
def nat_iso_of_left_adjoint_nat_iso {F F' : C ⥤ D} {G G' : D ⥤ C}
  (adj1 : F ⊣ G) (adj2 : F' ⊣ G') (l : F ≅ F') :
  G ≅ G' :=
right_adjoint_uniq adj1 (adj2.of_nat_iso_left l.symm)

/--
Given two adjunctions, if the right adjoints are naturally isomorphic, then so are the left
adjoints.
-/
def nat_iso_of_right_adjoint_nat_iso {F F' : C ⥤ D} {G G' : D ⥤ C}
  (adj1 : F ⊣ G) (adj2 : F' ⊣ G') (r : G ≅ G') :
  F ≅ F' :=
left_adjoint_uniq adj1 (adj2.of_nat_iso_right r.symm)

end adjunction


/-
Copyright (c) 2021 Eric Wieser. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Eric Wieser
-/
import data.real.sqrt
import data.zsqrtd.basic

/-!
# Image of `zsqrtd` in `ℝ`

This file defines `zsqrtd.to_real` and related lemmas.
It is in a separate file to avoid pulling in all of `data.real` into `data.zsqrtd`.
-/

namespace zsqrtd

/-- The image of `zsqrtd` in `ℝ`, using `real.sqrt` which takes the positive root of `d`.

If the negative root is desired, use `to_real h a.conj`. -/
@[simps]
noncomputable def to_real {d : ℤ} (h : 0 ≤ d) : ℤ√d →+* ℝ :=
lift ⟨real.sqrt d, real.mul_self_sqrt (int.cast_nonneg.mpr h)⟩

lemma to_real_injective {d : ℤ} (h0d : 0 ≤ d) (hd : ∀ n : ℤ, d ≠ n*n) :
  function.injective (to_real h0d) :=
lift_injective _ hd

end zsqrtd


theorem test (p : Nat × Nat) : (match p with | (a, b) => a = b) → (p.1 = p.2) := by
  intro (h : (match p with | (a, b) => a = b))
  exact h


import init.data.set

section ImportFromSet
  theorem mem_insert_of_mem {α : Type*} {x : α} {s : set α} (y : α) : x ∈ s → x ∈ insert y s := or.inr
  theorem mem_insert {α : Type*} (x : α) (s : set α) : x ∈ insert x s := or.inl rfl
  theorem insert_subset_insert {α : Type* } { s t : set α } { a : α } (h : s ⊆ t) : insert a s ⊆ insert a t := λ x, or.imp_right (@h _)
end ImportFromSet

-- language --
inductive message (σ : ℕ) : Type
  | null : fin σ -> message

inductive program (σ : ℕ) : Type
  | atomp : program -> program
  | secv : program -> program -> program
  | star : program -> program

inductive form (σ : ℕ) : Type
  | atom : fin σ -> form
  | botm : form
  | impl : form -> form -> form
  | k : form -> form
  | b : form -> form
  | pdl : program σ -> form -> form

section Notations
  prefix `#` := form.atom
  notation `⊥` := form.botm
  infix `⊃` := form.impl
  notation `~`:40 p := form.impl p ⊥
  notation p `&` q := ~(p ⊃ (~q))
  notation p `or` q := ~((~p) & (~q))
  notation `K`:80 p := form.k p
  notation `B`:80 p := form.b p
  notation `[` α `]`:80 p := form.pdl α p
  notation `[` α `][` β `]`:80 p := program.secv α β p
  notation α `*`:80 := program.star α
  --notation α `;` β := program.secv α β
end Notations

@[reducible]
def ctx (σ : nat) : Type := set (form σ)

@[reducible]
def constCtx (σ : nat) : Type := set (message σ)

/-
  Proof system
-/

open form
open message
open program

section ProofSystem
  inductive Proof { σ : ℕ } : ctx σ → constCtx σ → form σ → Prop
  -- Propositional logic
  | ax { Λ } { ℂ : constCtx σ } { p : form σ } (h : p ∈ Λ) : Proof Λ ℂ p
  | pl1 { Λ } { ℂ : constCtx σ } { p q : form σ } : Proof Λ ℂ (p ⊃ (q ⊃ p))
  | pl2 { Λ } { ℂ : constCtx σ } { p q r : form σ } : Proof Λ ℂ ((p ⊃ (q ⊃ r)) ⊃ ((p ⊃ q) ⊃ (p ⊃ r)))
  | pl3 { Λ } { ℂ : constCtx σ } { p q } : Proof Λ ℂ (((~p) ⊃ ~q) ⊃ (((~p) ⊃ q) ⊃ p))
  -- S5
  | kk { Λ } { ℂ : constCtx σ } { p q } : Proof Λ ℂ ((K (p ⊃ q)) ⊃ ((K p) ⊃ (K q)))
  | t { Λ } { ℂ : constCtx σ } { p } : Proof Λ ℂ ((K p) ⊃ p)
  | s4 { Λ } { ℂ : constCtx σ } { p } : Proof Λ ℂ ((K p) ⊃ (K (K p)))
  -- KD
  | bk { Λ } { ℂ : constCtx σ } { p q } : Proof Λ ℂ ((B (p ⊃ q)) ⊃ ((B p) ⊃ (B q)))
  | dox { Λ } { ℂ : constCtx σ } { p } : Proof Λ ℂ ((B p) ⊃ (~(B (~p))))
  | kb { Λ } { ℂ : constCtx σ }{ p } : Proof Λ ℂ ((K p) ⊃ (B p))
  -- PDL
  | pdlk { Λ } { ℂ : constCtx σ } { p q } (α : program σ) : Proof Λ ℂ (([α](p ⊃ q)) ⊃ (([α]p)  ⊃ ([α]q)))
  -- PDL*
  | pdlstar₁ { Λ } { ℂ : constCtx σ } { φ : form σ } { α : program σ } : Proof Λ ℂ ((φ & [α.secv α*]φ) ⊃ ([α*]φ))
  | pdlstar₂ { Λ } { ℂ : constCtx σ } { φ : form σ } { α : program σ } : Proof Λ ℂ ((φ & [α*](φ ⊃ [α]φ)) ⊃ ([α*]φ))
  -- Deductive rules
  | mp { Λ } { ℂ : constCtx σ } { p q } (hpq: Proof Λ ℂ (p ⊃ q)) (hp : Proof Λ ℂ p) : Proof Λ ℂ q
  | knec { Λ } { ℂ : constCtx σ } { p } (h : Proof ∅ ℂ p) : Proof Λ ℂ (K p)
  | bnec { Λ } { ℂ : constCtx σ } { p } (h : Proof ∅ ℂ p) : Proof Λ ℂ (B p)
  | gen { Λ } { ℂ : constCtx σ } { p } (α : program σ) (h : Proof ∅ ℂ p) : Proof Λ ℂ ([α]p)

end ProofSystem

notation Λ `-` ℂ ` ⊢κ ` p := Proof Λ ℂ p
notation Λ `-` ℂ ` ⊬κ ` p := Proof Λ ℂ p -> false

section SyntaxLemmas
  open Proof

  variable { σ : nat }
  lemma idd { p : form σ } { ℂ : constCtx σ } { Γ : ctx σ } :
    Γ-ℂ ⊢κ p ⊃ p := mp (mp (@pl2 σ Γ ℂ p (p ⊃ p) p) pl1) pl1

  theorem deduction { Γ : ctx σ } { ℂ : constCtx σ } { p q : form σ } :
    ((set.insert p Γ)-ℂ ⊢κ q) -> (Γ-ℂ ⊢κ p ⊃ q) :=
  begin
    generalize eq : (set.insert p Γ) = Γ',
    intro h,
    induction h;
    subst eq,
    { repeat { cases h_h },
      exact idd,
      {
        exact mp pl1 (ax h_h)
      }
    },
    { exact mp pl1 pl1 },
    { exact mp pl1 pl2 },
    { exact mp pl1 pl3 },
    { exact mp pl1 kk  },
    { exact mp pl1 t },
    { exact mp pl1 s4 },
    { exact mp pl1 bk },
    { exact mp pl1 dox },
    { exact mp pl1 kb },
    { exact mp
      pl1
      (@pdlk σ Γ h_ℂ h_p h_q h_α)
    },
    { exact mp
      pl1
      (@pdlstar₁ σ Γ h_ℂ h_φ h_α)
    },
    { exact mp
      pl1
      (@pdlstar₂ σ Γ h_ℂ h_φ h_α) },
    { apply mp,
      { exact (mp pl2 (h_ih_hpq rfl)) },
      { exact h_ih_hp rfl }
    },
    { exact mp pl1 (knec h_h) },
    { exact mp pl1 (bnec h_h) },
    { exact mp
      pl1
      (@gen σ Γ h_ℂ h_p h_α h_h)
    }
  end

  lemma sub_weak {Γ Δ : ctx σ} {ℂ : constCtx σ } {p : form σ} :
    (Δ-ℂ ⊢κ p) → (Δ ⊆ Γ) → (Γ-ℂ ⊢κ p) :=
    begin
      intros h s,
      induction h,
      { apply ax, exact s h_h },
      { exact pl1 },
      { exact pl2 },
      { exact pl3 },
      { exact kk },
      { exact t },
      { exact s4 },
      { exact bk },
      { exact dox },
      { exact kb },
      { exact @pdlk σ Γ h_ℂ h_p h_q h_α },
      { exact @pdlstar₁ σ Γ h_ℂ h_φ h_α },
      { exact @pdlstar₂ σ Γ h_ℂ h_φ h_α },
      { apply mp,
        { exact h_ih_hpq s },
        { exact h_ih_hp s}
      },
      { exact knec h_h },
      { exact bnec h_h },
      { exact @gen σ Γ h_ℂ h_p h_α h_h}
    end

    lemma weak { Γ : ctx σ } { ℂ : constCtx σ } { p q : form σ } :
      (Γ-ℂ ⊢κ p) -> ((set.insert q Γ)-ℂ ⊢κ p) :=
    begin
      intro h,
      induction h,
      { apply ax, exact (mem_insert_of_mem _ h_h) },
      { exact pl1 },
      { exact pl2 },
      { exact pl3 },
      { exact kk },
      { exact t },
      { exact s4 },
      { exact bk },
      { exact dox },
      { exact kb },
      { exact pdlk h_α  },
      { exact pdlstar₁ },
      { exact pdlstar₂ },
      { apply mp,
        { exact h_ih_hpq },
        { exact h_ih_hp }
      },
      { exact knec h_h },
      { exact bnec h_h },
      { exact gen h_α h_h}
    end

    lemma subctx_ax {Γ Δ : ctx σ} {ℂ : constCtx σ} {p : form σ} :
      Δ ⊆ Γ → (Δ-ℂ ⊢κ p) → (Γ-ℂ ⊢κ p) :=
    begin
      intros s h,
      induction h,
      { apply ax (s h_h) },
      { exact pl1 },
      { exact pl2 },
      { exact pl3 },
      { exact kk },
      { exact t },
      { exact s4 },
      { exact bk },
      { exact dox },
      { exact kb },
      { exact pdlk h_α  },
      { exact pdlstar₁ },
      { exact pdlstar₂ },
      { apply mp,
        { exact h_ih_hpq s },
        { exact h_ih_hp s }
      },
      { exact knec h_h },
      { exact bnec h_h },
      { exact gen h_α h_h}
    end

    lemma subctx_contr {Γ Δ : ctx σ} {ℂ : constCtx σ } {p : form σ}:
      Δ ⊆ Γ → ((Γ ∪ Δ)-ℂ ⊢κ p) → (Γ-ℂ ⊢κ p) :=
    begin
      generalize eq : Γ ∪ Δ = Γ',
      intros s h,
      induction h; subst eq,
      { cases h_h,
        { exact ax h_h },
        { exact ax (s h_h) } },
      { exact pl1 },
      { exact pl2 },
      { exact pl3 },
      { exact kk },
      { exact t },
      { exact s4 },
      { exact bk },
      { exact dox },
      { exact kb },
      { exact pdlk h_α  },
      { exact pdlstar₁ },
      { exact pdlstar₂ },
      { apply mp,
        { exact h_ih_hpq rfl },
        { exact h_ih_hp rfl }
      },
      { exact knec h_h },
      { exact bnec h_h },
      { exact gen h_α h_h}
    end

    lemma cut { Γ : ctx σ } { ℂ : constCtx σ } {p q r : form σ} :
      (Γ-ℂ ⊢κ  p ⊃ q) -> (Γ-ℂ ⊢κ  q ⊃ r) -> (Γ-ℂ ⊢κ  p ⊃ r) :=
      λ hpq hqr, mp (mp pl2 (mp pl1 hqr)) hpq

    lemma pr {Γ : ctx σ} { ℂ : constCtx σ }  {p : form σ} :
      (set.insert p Γ)-ℂ ⊢κ p :=
    by apply ax; apply or.intro_left; simp

    lemma pr1 { Γ : ctx σ } { ℂ : constCtx σ }  {p q : form σ} :
      (set.insert q (set.insert p Γ))-ℂ ⊢κ p :=
    by apply ax; apply or.intro_right; apply or.intro_left; simp

    lemma pr2 { Γ : ctx σ } { ℂ : constCtx σ }{p q : form σ} :
      (set.insert q (set.insert p Γ))-ℂ ⊢κ q :=
    by apply ax; apply or.intro_left; simp

    lemma contrap { Γ : ctx σ } { ℂ : constCtx σ } {p q : form σ}:
      Γ-ℂ ⊢κ  ((~q) ⊃ (~p)) ⊃ (p ⊃ q) :=
      deduction (deduction (mp (mp pl3 pr1) (mp pl1 pr2) ))

    lemma dne { Γ : ctx σ } { ℂ : constCtx σ } { p : form σ } :
      Γ-ℂ ⊢κ (~~p) ⊃ p :=
      have h : Γ-ℂ ⊢κ (~~p) ⊃ ((~p) ⊃ (~p)) := mp pl1 idd,
      mp (mp pl2 (cut pl1 pl3)) h

    lemma dni { Γ : ctx σ } { ℂ : constCtx σ } { p : form σ } :
      Γ-ℂ ⊢κ p ⊃ (~~p) :=
      mp contrap dne

    lemma not_impl {Γ : ctx σ} { ℂ : constCtx σ } {p q : form σ} :
      Γ-ℂ ⊢κ (p ⊃ q) ⊃ ((~q) ⊃ (~p)) :=
    begin
      repeat { apply deduction },
      apply mp,
      { exact pr1 },
        apply mp,
        { apply ax,
          apply mem_insert_of_mem,
          apply mem_insert_of_mem,
          apply mem_insert },
        { exact pr2 }
    end

    lemma not_impl_to_and {p q : form σ} {Γ : ctx σ}  { ℂ : constCtx σ } :
      Γ-ℂ ⊢κ (~(p ⊃ q)) ⊃ (p & (~q)) :=
    begin
      repeat {apply deduction},
      apply (mp pr1),
      { apply deduction,
        apply mp,
        { apply dne },
        { exact (mp pr1 pr2) } },
    end

    lemma and_not_to_not_impl {p q : form σ} {Γ : ctx σ}  { ℂ : constCtx σ } :
      Γ-ℂ ⊢κ (p & (~q)) ⊃ ~(p ⊃ q) :=
    begin
      repeat {apply deduction},
      apply mp,
      { apply pr1 },
      { apply cut,
        { apply pr2 },
        { apply dni }
      }
    end

    lemma conv_deduction {Γ : ctx σ} { ℂ : constCtx σ } {p q : form σ} :
      (Γ-ℂ ⊢κ p ⊃ q) -> ((set.insert p Γ)-ℂ ⊢κ q) := λ h, mp (weak h) pr

    lemma ex_falso {Γ : ctx σ} {p : form σ} { ℂ : constCtx σ } :
      (Γ-ℂ ⊢κ  ⊥) → (Γ-ℂ ⊢κ p) :=
    begin
      intro h,
      apply mp,
      { exact dne },
      { apply mp,
        { exact pl1 },
        { exact h } }
    end

end SyntaxLemmas

@[reducible]
def world (σ : nat) := ctx σ

variable { σ : nat }

structure Model :=
  (worlds : set (world σ))
  (Rk : world σ -> world σ -> bool)
  (Rb : world σ -> world σ -> bool)
  (Rp : world σ -> world σ -> bool)
  (val : fin σ -> world σ -> bool)
  (pdlval : program σ -> set ((world σ) × (world σ)))
  (krefl : ∀ w ∈ worlds, Rk w w = tt)
  (ksymm : ∀ w ∈ worlds, ∀ v ∈ worlds, Rk w v = tt -> Rk v w = tt)
  (ktrans : ∀ w ∈ worlds, ∀ v ∈ worlds, ∀ u ∈ worlds, Rk w v = tt -> Rk v u = tt -> Rk w u = tt)
  (bserial : ∀ w ∈ worlds, ∃ v ∈ worlds, Rb w v = tt)
  (ksubsetb : ∀ w ∈ worlds, ∀ v ∈ worlds, Rk w v = tt -> Rb w v = tt)

open classical

local attribute [instance] prop_decidable

def big_union {α : Type*} {β : Type*} (s : set α) (f : α → set β) : set β := { b | ∃ a ∈ s, b ∈ f a }

def kleene_star {β : Type*} (a : set β) : ℕ → set β
| 0 := ∅
| (n+1) := a ∪ big_union (kleene_star n) (λ s, set.insert s a)

def compose { X Y Z : Type* } (R : set (X × Y)) (S : set (Y × Z)) : set (X × Z) :=
  set_of (λ ac, ∃ b, (ac.1, b) ∈ R ∧ (b, ac.2) ∈ S)

def mK {σ : nat} (M : @Model σ) : program σ -> set ((world σ) × (world σ))
| (@atomp σ a) := M.pdlval a
| (@secv σ α β) := compose (M.pdlval α) (M.pdlval β)
| (@star σ α) := kleene_star (M.pdlval α) 3

open program

noncomputable def forces_form (M : @Model σ) : form σ -> world σ -> bool
  | (@atom σ p)  := λ w, M.val p w
  | (@botm σ) := λ w, ff
  | (@impl σ p q) := λ w, bnot (forces_form p w) || (forces_form q w)
  | (@k σ p) := λ w,
      if (∀ v ∈ M.worlds, w ∈ M.worlds -> M.Rk w v = tt -> forces_form p v = tt)
        then tt
      else ff
  | (@b σ p) := λ w,
      if (∀ v ∈ M.worlds, w ∈ M.worlds -> M.Rb w v = tt -> forces_form p v = tt)
        then tt
      else ff
  | (@pdl σ α p) := λ w,
      if (∀ v ∈ M.worlds, w ∈ M.worlds -> ((v,w) ∈ (@mK σ M α)) -> forces_form p v = tt)
        then tt
      else ff

notation w `⊩` `⦃` M `⦄` p := forces_form M p w

noncomputable def forces_ctx (M : @Model σ) (Γ : ctx σ) : world σ -> bool :=
  λ w, if (∀ p, p ∈ Γ -> forces_form M p w = tt) then tt else ff

notation w `⊩` `⦃` M `⦄ ` p := forces_ctx M p w

inductive sem_csq (Γ : ctx σ) (ℂ : constCtx σ) (p : form σ) : Prop
  | is_true (m : ∀ (M : @Model σ) (w ∈ M.worlds), ((w ⊩⦃M⦄ Γ) = tt) → (w ⊩⦃M⦄ p) = tt) : sem_csq

notation Λ `-` ℂ ` ⊧κ ` p := sem_csq Λ ℂ p

lemma neg_tt_iff_ff { M : @Model σ } { w : world σ } { p : form σ } :
  (w ⊩ ⦃M⦄ ~p) = tt ↔ ¬(w ⊩ ⦃M⦄ p) :=
  begin
    unfold forces_form,
    have h := forces_form M p w,
    induction h,
    simp,
    simp
  end

lemma neg_ff_iff_tt { M : @Model σ }  {w : world σ} {p : form σ} :
  ¬(w ⊩⦃M⦄ ~p) ↔ (w ⊩⦃M⦄ p) = tt :=
  begin
    unfold forces_form,
    induction (forces_form M p w),
    simp,
    simp
  end

lemma impl_iff_implies { M : @Model σ }  {w : world σ} {p q : form σ} :
  (w ⊩⦃M⦄ (p ⊃ q)) = tt ↔ ((w ⊩⦃M⦄ p) → (w ⊩⦃M⦄ q)) :=
  begin
    unfold forces_form,
    have h := forces_form M p w,
    induction h,
    repeat {
      have h₁ := forces_form M q w,
      induction h₁,
      simp
    }
  end

@[simp]
lemma impl_tt_iff_ff_or_tt {M : @Model σ} {w : world σ} {p q : form σ} :
  (w ⊩⦃M⦄ p ⊃ q) = tt ↔ ¬(w ⊩⦃M⦄ p) ∨ (w ⊩⦃M⦄ q) = tt :=
  begin
    unfold forces_form,
    have h := forces_form M p w,
    induction h,
    { have h₁ := forces_form M q w,
      induction h₁,
      { simp  },
      { simp }
    },
    { have h₁ := forces_form M q w,
      induction h₁,
      { simp  },
      { simp }
    }
  end

lemma ff_or_tt_and_tt_implies_tt_right {M : @Model σ} {w : world σ} {p q : form σ} :
  (¬(w ⊩⦃M⦄ p) ∨ (w ⊩⦃M⦄ q) = tt) → (w ⊩⦃M⦄ p) = tt → (w ⊩⦃M⦄ q) = tt :=
  begin
    unfold forces_form,
    have h := forces_form M p w,
    induction h,
    {
      have h₁ := forces_form M q w,
      induction h₁,
      { simp },
      { simp }
    },
    {
      have h₂ := forces_form M q w,
      induction h₂,
      { simp },
      { simp }
    }
  end
-- by simp; induction (forces_form M p w); repeat {induction (forces_form M q w), simp, simp}

lemma bot_is_insatisf (w : world σ) :
  ¬ ∃ (M : @Model σ), (w ⊩ ⦃M⦄ (@botm σ)) = tt :=
  begin
    intro h,
    cases h,
    exact (bool.no_confusion h_h)
  end

lemma forall_wrld_tt_nec_tt { M : @Model σ } {w : world σ} {p : form σ} :
  (∀ v ∈ M.worlds, w ∈ M.worlds -> M.Rk w v -> (v ⊩ ⦃M⦄ p) = tt) -> (w ⊩⦃M⦄ K p) = tt :=
  begin
    intro h,
    unfold forces_form,
    induction (prop_decidable _),
    { simp, contradiction },
    { simp, assumption }
  end

lemma is_true_pl1 { M : @Model σ } { w : world σ } { p q : form σ } :
  (w ⊩ ⦃M⦄ (p ⊃ (q ⊃ p))) = tt :=
  begin
    apply impl_iff_implies.2,
    intro h,
    unfold forces_form,
    simp [*],
  end

lemma is_true_pl2 { M : @Model σ } { w : world σ } { p q r : form σ } :
  (w ⊩⦃M⦄ ((p ⊃ (q ⊃ r)) ⊃ ((p ⊃ q) ⊃ (p ⊃ r)))) = tt :=
  begin
    apply impl_iff_implies.2,
    intro h₁, apply impl_iff_implies.2,
    intro h₂, apply impl_iff_implies.2,
    intro h₃, apply impl_iff_implies.1 ((impl_iff_implies.1 h₁) h₃),
    apply impl_iff_implies.1 h₂, assumption
  end

lemma is_true_pl3 { M : @Model σ } { w : world σ } { p q : form σ } :
  (w ⊩⦃M⦄ ((~p) ⊃ ~q) ⊃ (((~p) ⊃ q) ⊃ p)) = tt :=
  begin
    unfold forces_form,
    induction (forces_form M p w),
    repeat { induction (forces_form M q w), repeat {simp} },
  end

lemma nec_impl_to_nec_to_nec {M : @Model σ} {w : world σ} {p q : form σ} :
  (w ⊩⦃M⦄ (K(p ⊃ q))) = tt → (w ⊩⦃M⦄ (K p)) = tt → (w ⊩⦃M⦄ (K q)) = tt :=
begin
  unfold forces_form,
  simp at *,
  intros hlpq hlp v wmem vmem rwv,
  specialize hlpq v,
  specialize hlp v,
  have h₁ := ((hlpq wmem) vmem) rwv,
  have h₂ := (((hlp) wmem) vmem) rwv,
  simp [*] at *
end

lemma bnec_impl_to_bnec_to_bnec {M : @Model σ} {w : world σ} {p q : form σ} :
  (w ⊩⦃M⦄ (B(p ⊃ q))) = tt → (w ⊩⦃M⦄ (B p)) = tt → (w ⊩⦃M⦄ (B q)) = tt :=
begin
  unfold forces_form,
  simp at *,
  intros hlpq hlp v wmem vmem rwv,
  specialize hlpq v,
  specialize hlp v,
  have h₁ := ((hlpq wmem) vmem) rwv,
  have h₂ := (((hlp) wmem) vmem) rwv,
  simp [*] at *
end

lemma pdlnec_impl_to_pdlnec_to_pdlnec {M : @Model σ} {w : world σ} {p q : form σ} {α : program σ} :
  (w ⊩⦃M⦄ ([α](p ⊃ q))) = tt → (w ⊩⦃M⦄ ([α] p)) = tt → (w ⊩⦃M⦄ ([α] q)) = tt :=
begin
  unfold forces_form,
  simp at *,
  intros hlpq hlp v wmem vmem rwv,
  specialize hlpq v,
  specialize hlp v,
  have h₁ := ((hlpq wmem) vmem) rwv,
  have h₂ := (((hlp) wmem) vmem) rwv,
  simp [*] at *
end

lemma nec_nec_to_nec_impl {M : @Model σ } {w : world σ} {p q : form σ} :
  (w ⊩⦃M⦄ (K p)) = tt → (w ⊩⦃M⦄ (K q)) = tt → (w ⊩⦃M⦄ K (p ⊃ q)) = tt  :=
begin
  unfold forces_form,
  simp at *,
  intros hp hq v wmem vmem rwv,
  specialize hp v,
  specialize hq v,
  have h₁ := ((hp wmem) vmem) rwv,
  have h₂ := ((hq wmem) vmem) rwv,
  simp [*]
end

@[simp]
lemma nec_impl_to_nec_impl_nec {M : @Model σ} {w : world σ} {p q : form σ} :
  (w ⊩⦃M⦄ K (p ⊃ q)) = tt → (¬(w ⊩⦃M⦄ K p) ∨ (w ⊩⦃M⦄ K q) = tt) :=
begin
  intro h₀,
  cases prop_decidable ((w ⊩⦃M⦄ K p) = tt),
  simp at h, left,
  simp at *, assumption,
  right, apply nec_impl_to_nec_to_nec h₀ h
end

@[simp]
lemma bnec_impl_to_bnec_impl_bnec {M : @Model σ} {w : world σ} {p q : form σ} :
  (w ⊩⦃M⦄ B (p ⊃ q)) = tt → (¬(w ⊩⦃M⦄ B p) ∨ (w ⊩⦃M⦄ B q) = tt) :=
begin
  intro h₀,
  cases prop_decidable ((w ⊩⦃M⦄ B p) = tt),
  simp at h, left,
  simp at *, assumption,
  right, apply bnec_impl_to_bnec_to_bnec h₀ h
end

@[simp]
lemma pdlnec_impl_to_pdlnec_impl_pdlnec {M : @Model σ} {w : world σ} {p q : form σ} {α : program σ} :
  (w ⊩⦃M⦄ ([α] (p ⊃ q))) = tt → (¬(w ⊩⦃M⦄ ([α] p)) ∨ (w ⊩⦃M⦄ ([α] q)) = tt) :=
begin
  intro h₀,
  cases prop_decidable ((w ⊩⦃M⦄ ([α] p)) = tt),
  simp at h, left,
  simp at *, assumption,
  right, apply pdlnec_impl_to_pdlnec_to_pdlnec h₀ h
end

lemma is_true_k { M : @Model σ } {w : world σ} {p q : form σ} :
  (w ⊩⦃M⦄ ((K(p ⊃ q)) ⊃ ((K p) ⊃ K q))) = tt :=
    impl_iff_implies.2 (λ h, impl_tt_iff_ff_or_tt.2 (nec_impl_to_nec_impl_nec h))

lemma is_true_bk { M : @Model σ } { w : world σ } { p q : form σ } :
  (w ⊩⦃M⦄ ((B(p ⊃ q)) ⊃ ((B p) ⊃ B q))) = tt :=
    impl_iff_implies.2 (λ h, impl_tt_iff_ff_or_tt.2 (bnec_impl_to_bnec_impl_bnec h))

lemma is_true_pdlk { M : @Model σ } { w : world σ } { p q : form σ } { α : program σ } :
  (w ⊩⦃M⦄ (([α](p ⊃ q)) ⊃ (([α] p) ⊃ ([α] q)))) = tt :=
    impl_iff_implies.2 (λ h, impl_tt_iff_ff_or_tt.2 (pdlnec_impl_to_pdlnec_impl_pdlnec h))

lemma nec_to_tt {M : @Model σ } {w : world σ} {wm : w ∈ M.worlds} {p : form σ} :
  (w ⊩⦃M⦄ K p) = tt → (w ⊩⦃M⦄ p) = tt :=
begin
  unfold forces_form, simp at *,
  intro f, apply f, repeat {assumption},
  apply M.krefl, assumption
end

lemma is_true_t {M : @Model σ } {w : world σ} {w ∈ M.worlds} {p : form σ} :
  (w ⊩⦃M⦄ (K p) ⊃ p) = tt :=
by apply impl_iff_implies.2; apply nec_to_tt; repeat {assumption}

lemma np_or_q_is_p_imp_q { p q : Prop } : (¬p ∨ q) ↔ (p → q) :=
begin
  split,
  {
    intros h₁ h₂,
    cases h₁ with hnp hq,
    { exfalso, apply hnp, exact h₂,},
    { exact hq, }
  },
  {
    intros h₁,
    by_cases hp : p,
    { right, exact h₁ hp, },
    { left, exact hp, }
  }
end

lemma is_true_dox { M : @Model σ } { w : world σ } {w ∈ M.worlds} {p : form σ } :
  (w ⊩ ⦃M⦄ ((B p) ⊃ ~B(~p))) = tt :=
  begin
    unfold forces_form,
    simp,
    rw [np_or_q_is_p_imp_q],
    intros h_h,
    have serial := M.bserial,
    specialize serial w,
    have h₂ := (serial H),
    cases h₂ with h₂e h₂b,
    cases h₂b with h₂be h₂bb,
    specialize h_h h₂e,
    have h₁ := ((h_h h₂be) H) h₂bb,
    clear h_h,
    intro h_c,
    specialize h_c h₂e,
    have h₂ := ((h_c h₂be) H) h₂bb,
    clear h_c h₂be h₂bb,
    simp [*] at *,
  end

lemma pl2_nd { p q r : Prop } : (p → q) → (p → r) → (p → (q → r)) :=
  λ h₁ : p → q,
  λ h₂ : p → r,
  λ h₃ : p,
  λ h₄ : q,
  show r, from h₂ h₃

lemma is_true_kb { M : @Model σ } { w : world σ } { w ∈ M.worlds } { p : form σ } :
  (w ⊩ ⦃M⦄ ((K p) ⊃ (B p))) = tt :=
  begin
    unfold forces_form,
    simp,
    rw [np_or_q_is_p_imp_q],
    intros h_h,
    have subset := Model.ksubsetb,
    specialize subset M w,
    intros v vmem wmem wRbv,
    have h₁ := subset H,
    clear subset,
    specialize h₁ v,
    specialize h_h v,
    have h₂ := h₁ vmem,
    have h₃ := (h_h vmem) wmem,
    clear h₁ h_h,
    have h₄ := pl2_nd h₂ h₃,
  end

lemma is_true_pdlstar₁ { M : @Model σ } { w : world σ } { w ∈ M.worlds } { p : form σ } { α : program σ } :
  (w ⊩ ⦃M⦄ (((p & [α.secv α*]p) ⊃ ([α*]p)))) = tt :=
  begin
    unfold forces_form,
    simp [*],
  end

lemma is_true_pdlstar₂{ M : @Model σ } { w : world σ } { w ∈ M.worlds } { p : form σ } { α : program σ } :
  (w ⊩ ⦃M⦄ (((p & [α*](p ⊃ [α]p)) ⊃ ([α*]p)))) = tt :=
  begin
    unfold forces_form,
    simp [*],
  end

lemma nec_to_nec_of_nec {M : @Model σ } {w : world σ} {p : form σ} :
  (w ⊩⦃M⦄ K p) = tt → (w ⊩⦃M⦄ K (K p)) = tt :=
begin
  unfold forces_form, simp at *,
  intros f v wmem vmem rwv u vmem' umem rvu,
  apply f, repeat {assumption},
  refine M.ktrans _ _ _ _ _ _ rwv rvu,
  repeat {assumption}
end

lemma is_true_s4 { M : @Model σ } {w : world σ} {p : form σ} :
  (w ⊩⦃M⦄ ((K p) ⊃ (K (K p)))) = tt :=
by apply impl_iff_implies.2; apply nec_to_nec_of_nec

lemma ctx_tt_iff_mem_tt {Γ : ctx σ} {M : @Model σ} {w : world σ} :
  (w ⊩⦃M⦄ Γ) = tt ↔ (∀ p, p ∈ Γ → (w ⊩⦃M⦄ p) = tt) :=
begin
  unfold forces_ctx,
  induction (classical.prop_decidable _),
  { apply iff.intro,
    simp, intro h₁,
    intro φ,
    specialize h₁ φ,
    { exact h₁ },
    { contradiction }
  },
  { simp }
end

lemma mem_tt_to_ctx_tt (Γ : ctx σ) {M : @Model σ } {w : world σ} :
  (∀ (p : form σ) (h : p ∈ Γ), (w ⊩⦃M⦄ p) = tt) → (w ⊩⦃M⦄ Γ) = tt :=
ctx_tt_iff_mem_tt.2

lemma ctx_tt_to_mem_tt {Γ : ctx σ} {M : @Model σ} {w : world σ} {p : form σ} :
  (w ⊩⦃M⦄ Γ) = tt → p ∈ Γ → (w ⊩⦃M⦄ p) = tt :=
by intro; apply ctx_tt_iff_mem_tt.1; assumption

lemma empty_ctx_tt {M : @Model σ} {w : world σ} :
  (w ⊩⦃M⦄ ∅) = tt :=
begin
  apply ctx_tt_iff_mem_tt.2,
  intros, exfalso, assumption
end

lemma cons_ctx_tt_iff_and {Γ : ctx σ} {M : @Model σ } {w : world σ} {p : form σ} :
  (w ⊩⦃M⦄ (set.insert p Γ)) = tt ↔ (w ⊩⦃M⦄ Γ) = tt ∧ (w ⊩⦃M⦄ p) = tt :=
begin
  unfold forces_ctx,
  induction (classical.prop_decidable (∀ p, p ∈ Γ → forces_form M p w = tt)),
  { simp, apply iff.intro,
    { intro h', exfalso,
      apply h, intros q qmem, apply h',
      apply mem_insert_of_mem, assumption },
    { intros h' q qmem,
      cases h', cases qmem,
      rw qmem, assumption,
      apply h'_left, assumption } },

  { simp, apply iff.intro,
    { intro h', split,
      { assumption },
      { apply h', apply mem_insert } },
    { intros h' q qmem,
      cases h', cases qmem,
      rw qmem, assumption,
      apply h'_left, assumption } },
end

lemma cons_ctx_tt_to_ctx_tt {Γ : ctx σ} {M : @Model σ } {w : world σ} {p : form σ} :
  (w ⊩⦃M⦄ (set.insert p Γ)) = tt → (w ⊩ ⦃M⦄ Γ) = tt :=
by intro h; apply and.elim_left; apply cons_ctx_tt_iff_and.1 h

lemma ctx_tt_cons_tt_to_cons_ctx_tt {Γ : ctx σ} {M : @Model σ } {w : world σ} {p : form σ} :
  (w ⊩⦃M⦄ Γ) = tt → (w ⊩⦃M⦄ p) → (w ⊩⦃M⦄ (set.insert p Γ)) :=
by intros hg hp; apply cons_ctx_tt_iff_and.2; split; assumption; assumption

lemma ctx_tt_to_subctx_tt {Γ Δ : ctx σ} {M : @Model σ } {w : world σ} :
  (w ⊩⦃M⦄ Γ) → Δ ⊆ Γ → (w ⊩⦃M⦄ Δ) :=
begin
  intros h s,
  apply ctx_tt_iff_mem_tt.2,
  intros p pmem,
  apply ctx_tt_iff_mem_tt.1 h,
  apply s, exact pmem
end

lemma sem_deduction {Γ : ctx σ} { ℂ : constCtx σ } {p q : form σ} :
  ((set.insert p Γ)-ℂ ⊧κ  q) → (Γ-ℂ ⊧κ p ⊃ q) :=
begin
  intro h, cases h,
  apply sem_csq.is_true,
  intros M w wmem ant,
  apply impl_iff_implies.2,
  { intro hp, apply h, assumption,
    apply ctx_tt_cons_tt_to_cons_ctx_tt,
    repeat {assumption} }
end

theorem soundness { Γ : ctx σ } { ℂ : constCtx σ } { p : form σ } :
  (Γ-ℂ ⊢κ p) -> (Γ-ℂ ⊧κ p) :=
begin
  intro h,
  induction h,
  {
    apply sem_csq.is_true,
    intros,
    apply ctx_tt_to_mem_tt,
    repeat {assumption}
  },
  {
    apply sem_csq.is_true,
    intros M w wmem ctt,
    apply is_true_pl1
  },
  {
    apply sem_csq.is_true,
    intros M w wmem ctt,
    apply is_true_pl2
  },
  {
    apply sem_csq.is_true,
    intros M w wmem ctt,
    apply is_true_pl3
  },
  {
    apply sem_csq.is_true,
    intros M w wmem ctt,
    apply is_true_k
  },
  {
    apply sem_csq.is_true,
    intros M w wmem ctt,
    apply is_true_t,
    repeat { assumption }
  },
  {
    apply sem_csq.is_true,
    intros M w wmem ctt,
    apply is_true_s4
  },
  {
    apply sem_csq.is_true,
    intros M w wmem ctt,
    apply is_true_bk
  },
  {
    apply sem_csq.is_true,
    intros M w wmem ctt,
    apply is_true_dox,
    repeat { assumption }
  },
  {
    apply sem_csq.is_true,
    intros M w wmem ctt,
    apply is_true_kb,
    repeat { assumption }
  },
  {
    apply sem_csq.is_true,
    intros M w wmem ctt,
    apply is_true_pdlk
  },
  {
    apply sem_csq.is_true,
    intros M w wmem ctt,
    apply is_true_pdlstar₁,
    repeat { assumption }
  },
  {
    apply sem_csq.is_true,
    intros M w wmem ctt,
    apply is_true_pdlstar₂,
    repeat { assumption }
  },
  {
    apply sem_csq.is_true,
    induction h_ih_hpq,
    induction h_ih_hp,
    intros M w wmem ctt,
    revert h_ih_hpq,
    unfold forces_form, simp,
    intro hpq,
    cases (hpq M w wmem ctt),
    { simp [*] at * },
    {
      exact h
    }
  },
  {
    apply sem_csq.is_true,
    intros M w wmem ctt,
    unfold forces_form,
    simp,
    induction h_ih,
    intros v vmem wmem rwv,
    apply h_ih, assumption,
    apply empty_ctx_tt
  },
  {
    apply sem_csq.is_true,
    intros M w wmem ctt,
    unfold forces_form,
    simp,
    induction h_ih,
    intros v vmem wmem rwv,
    apply h_ih, assumption,
    apply empty_ctx_tt
  },
  {
    apply sem_csq.is_true,
    intros M w wmem ctt,
    unfold forces_form,
    simp,
    induction h_ih,
    intros v vmem wmem rwv,
    apply h_ih, assumption,
    apply empty_ctx_tt
  }
end

local attribute [priority 0] prop_decidable

open Proof

def is_consist { ℂ : constCtx σ } (Γ : ctx σ) := (Γ-ℂ ⊬κ ⊥)

lemma consist_not_of_not_prf { ℂ : constCtx σ } { Γ : ctx σ } { p : form σ } { α : program σ }:
  (Γ-ℂ ⊬κ p) -> @is_consist σ ℂ (set.insert (~p) Γ) :=
  λ hnp hc, hnp (mp dne
  (deduction hc))

lemma not_prf_of_consist_not {Γ : ctx σ} { ℂ : constCtx σ } {p : form σ} :
  @is_consist σ ℂ (set.insert (~p) Γ) → (Γ-ℂ ⊬κ p) :=
  λ h c, h (conv_deduction (mp dni c))

lemma consist_of_not_prf {Γ : ctx σ} { ℂ : constCtx σ } {p : form σ} :
  (Γ-ℂ ⊢κ p) → @is_consist σ ℂ Γ := λ nhp nc, nhp (ex_falso nc)

lemma inconsist_to_neg_consist {Γ : ctx σ} { ℂ : constCtx σ } {p : form σ} :
  @is_consist σ ℂ Γ → ¬@is_consist σ ℂ (set.insert p Γ) → @is_consist σ ℂ (set.insert (~p) Γ) :=
begin
  intros c nc hp, apply c, apply mp,
    apply deduction, apply by_contradiction nc,
    apply mp dne, exact (deduction hp),
end

lemma inconsist_of_neg_to_consist {Γ : ctx σ} { ℂ : constCtx σ }  {p : form σ} :
  @is_consist σ ℂ Γ → ¬@is_consist σ ℂ (set.insert (~p) Γ) → @is_consist σ ℂ (set.insert p Γ) :=
begin
  intros c nc hp, apply c, apply mp,
  { apply deduction (by_contradiction nc) },
  { exact deduction hp },
end

lemma consist_fst {Γ : ctx σ} { ℂ : constCtx σ }  {p : form σ} :
  @is_consist σ ℂ (set.insert p Γ) → @is_consist σ ℂ Γ :=
λ hc hn, hc (weak hn)

lemma consist_ext {Γ : ctx σ} { ℂ : constCtx σ } {p : form σ} :
  @is_consist σ ℂ Γ → (Γ-ℂ ⊬κ ~p) → @is_consist σ ℂ (set.insert p Γ) :=
by intros c np hn; apply np (deduction hn)

lemma inconsist_ext_to_inconsist {Γ : ctx σ} { ℂ : constCtx σ }  {p : form σ} :
    ((¬ @is_consist σ ℂ (set.insert p Γ)) ∧ ¬ @is_consist σ ℂ(set.insert (~p) Γ)) → ¬ @is_consist σ ℂ (Γ) :=
begin
  intros h nc, cases h,
  have h₁ : ((set.insert p Γ)-ℂ ⊢κ ⊥) := by_contradiction h_left,
  have h₂ : ((set.insert (~p) Γ)-ℂ ⊢κ ⊥) := by_contradiction h_right,
  apply nc, apply mp (deduction h₁),
    apply mp dne (deduction h₂)
end

lemma consist_to_consist_ext {Γ : ctx σ} { ℂ : constCtx σ } {p : form σ} :
    @is_consist σ ℂ (Γ) → (@is_consist σ ℂ (set.insert p Γ) ∨ @is_consist σ ℂ (set.insert (~p) Γ)) :=
begin
  intro c, apply classical.by_contradiction, intro h,
  apply absurd c, apply inconsist_ext_to_inconsist,
  apply (decidable.not_or_iff_and_not _ _).1, apply h,
  repeat {apply (prop_decidable _)}
end

lemma pos_consist_mem {Γ : ctx σ} { ℂ : constCtx σ } {p : form σ} :
  p ∈ Γ → @is_consist σ ℂ (Γ) → (~p) ∉ Γ :=
λ hp hc hnp, hc (mp (ax hnp) (ax hp))

lemma neg_consist_mem {Γ : ctx σ} { ℂ : constCtx σ } {p : form σ} :
  (~p) ∈ Γ → @is_consist σ ℂ (Γ) → p ∉ Γ :=
λ hnp hc hp, hc (mp (ax hnp) (ax hp))

lemma pos_inconsist_ext {Γ : ctx σ} { ℂ : constCtx σ } {p : form σ} (c : @is_consist σ ℂ Γ) :
  p ∈ Γ → ¬ @is_consist σ ℂ (set.insert p Γ) → (~p) ∈ Γ :=
begin
  intros hp hn,
  exfalso, apply c,
  apply mp, apply deduction (by_contradiction hn),
  apply ax hp
end

lemma neg_inconsist_ext {Γ : ctx σ} { ℂ : constCtx σ } {p : form σ} (c : @is_consist σ ℂ Γ) :
  (~p) ∈ Γ → ¬ @is_consist σ ℂ (set.insert (~p) Γ) → p ∈ Γ :=
begin
  intros hp hn,
  exfalso, apply c,
  apply mp, apply deduction (by_contradiction hn),
  apply ax hp
end

/- context extensions of subcontexts -/

lemma sub_preserves_consist {Γ Δ : ctx σ} { ℂ : constCtx σ } :
  @is_consist σ ℂ Γ → @is_consist σ ℂ Δ → Δ ⊆ Γ → @is_consist σ ℂ (Γ ∪ Δ) :=
by intros c1 c2 s nc; apply c1; exact (subctx_contr s nc)

lemma subctx_inherits_consist {Γ Δ : ctx σ} { ℂ : constCtx σ } {p : form σ} :
  @is_consist σ ℂ Γ → @is_consist σ ℂ Δ → Γ ⊆ Δ → @is_consist σ ℂ (set.insert p Δ) → @is_consist σ ℂ (set.insert p Γ) :=
by intros c1 c2 s c nc; apply c; apply conv_deduction; apply subctx_ax s (deduction nc)

lemma inconsist_sub {Γ Δ : ctx σ} {p : form σ} { ℂ : constCtx σ } (c : @is_consist σ ℂ Γ) :
  ¬ @is_consist σ ℂ (set.insert p Δ) → Δ ⊆ Γ → ¬ @is_consist σ ℂ (set.insert p Γ) :=
begin
  unfold is_consist, intros h s c, apply c,
  apply subctx_ax, apply insert_subset_insert s,
  apply classical.by_contradiction h
end

lemma tt_to_const {Γ : ctx σ} { ℂ : constCtx σ } {M : @Model σ } {w ∈ M.worlds} :
  (w ⊩⦃M⦄ Γ) = tt → @is_consist σ ℂ Γ :=
begin
  intros h hin,
  cases (soundness hin),
  apply bot_is_insatisf,
  apply exists.intro,
  refine (m M w _ h),
  repeat {assumption},
end


import category_theory.basic

universes v₁ v₂ v₃ v₄ v u₁ u₂ u₃ u₄ u

namespace category

open classical

instance functor_category (C : Type u₁) (D : Type u₂) [category.{v₁} C] [category.{v₂} D]
  : category (C +→ D) :=
{
  Mor := λ F₁ F₂, F₁ →ₙ F₂,
  idₘ := idₙ,
  comp := λ F₁ F₂ F₃ φ₁ φ₂, φ₁ ∘ₙ φ₂,
  comp_assoc :=
    begin
      intros F₁ F₂ F₃ F₄ φ₁ φ₂ φ₃,
      apply natural_trans_equality,
      apply funext,
      intro,
      simp,
      rw comp_assoc,
    end,
  id_comp_left :=
    begin
      intros F₁ F₂ φ,
      apply natural_trans_equality,
      apply funext,
      intro,
      rw natural_trans_comp_map,
      simp,
      rw id_comp_left,
    end,
  id_comp_right :=
    begin
      intros F₁ F₂ φ,
      apply natural_trans_equality,
      apply funext,
      intro,
      rw natural_trans_comp_map,
      simp,
      rw id_comp_right,
    end,
}

@[simp]
theorem functor_cat_comp {C : Type u₁} {D : Type u₂} [category.{v₁} C] [category.{v₂} D]
  {F₁ F₂ F₃ : C +→ D} (φ₁ : Mor F₂ F₃) (φ₂ : Mor F₁ F₂) : φ₁ ∘ₘ φ₂ = φ₁ ∘ₙ φ₂ := rfl

instance Type_Cat : category (Type u) :=
{
  Mor := λ A B : Type u, A → B,
  comp := λ A₁ A₂ A₃ f₁ f₂, f₁ ∘ f₂,
  idₘ := λ A, id,
  comp_assoc :=
    begin
      intros A B C D f₁ f₂ f₃,
      apply funext,
      intro,
      refl,
    end,
  id_comp_left :=
    begin
      intros A B f,
      apply funext,
      intro,
      refl,
    end,
  id_comp_right :=
    begin
      intros A B f,
      apply funext,
      intro,
      refl,
    end,
}

theorem set_comp_app : ∀ {A₁ A₂ A₃ : Type u} (f₁ : Mor A₂ A₃) (f₂ : Mor A₁ A₂) (s : A₁),
  ((f₁ ∘ₘ f₂) : A₁ → A₃) s =  f₁ ( f₂ s) := λ _ _ _ _ _ _, rfl

structure opposite (C : Type u) :=
  (val : C)

def op {C : Type u} : C → opposite C := λ c, {val := c}

theorem op_val (C : Type u) : ∀ c : C, (op c).val = c := λ _,rfl

@[simp]
theorem opposite_equality (C : Type u)
  : ∀ c₁ c₂ : opposite C , c₁.val = c₂.val ↔ c₁ = c₂ :=
begin
  intros c₁ c₂,
  split,
  cases c₁,
  cases c₂,
  simp,
  intro,
  assumption,
  intro h,
  rw h,
end

instance opposite_nonempty (C : Type u) [nC :nonempty C] : nonempty (opposite C) :=
begin
  split,
  split,
  apply choice,
  assumption,
end

instance opposite_categoy (C : Type u) [category.{v} C]: category.{v} (opposite C) :=
{
  Mor := λ A B, Mor B.val A.val,
  idₘ := λ A, idₘ A.val,
  comp := λ A B C f₁ f₂, f₂ ∘ₘ f₁,
  comp_assoc :=
    begin
      intros A₁ A₂ A₃ A₄ f₁ f₂ f₃,
      rw comp_assoc,
    end,
  id_comp_left :=
    begin
      intros A B f,
      rw id_comp_right,
    end,
  id_comp_right :=
    begin
      intros A B f,
      rw id_comp_left,
    end,
}

def op_functor {C : Type u₁} {D : Type u₂} [SC:category.{v₁} C] [SD:category.{v₂} D] (F : C +→ D)
  : (opposite C) +→ (opposite D) :=
{
  map := λ oC₁, op (F.map oC₁.val),
  fmap := λ oC₁ oC₂ f, F.fmap f,
  fmap_prevs_comp :=
    begin
      intros oC₁ oC₂ oC₃ f₁ f₂,
      apply F.fmap_prevs_comp,
    end,
  fmap_prevs_id :=
    begin
      intro oC,
      cases oC with c,
      have hrw : op c = {val := c} := rfl,
      rw ← hrw,
      simp [idₘ],
      rw F.fmap_prevs_id,
      refl,
    end,
}

instance product_category (C : Type u₁) (D : Type u₂) [category.{v₁} C] [category.{v₂} D]
  : category.{max v₁ v₂} (C × D) :=
{
  Mor := λ p₁ p₂, (Mor p₁.1 p₂.1) × (Mor p₁.2 p₂.2),
  idₘ := λ p, ⟨idₘ p.1, idₘ p.2⟩,
  comp := λ _ _ _ pf₁ pf₂, ⟨pf₁.1 ∘ₘ pf₂.1, pf₁.2 ∘ₘ pf₂.2⟩,
  comp_assoc :=
    begin
      intros p₁ p₂ p₃ p₄ pf₁ pf₂ pf₃,
      simp [comp_assoc],
    end,
  id_comp_right :=
    begin
      intros p₁ p₁ pf,
      simp [id_comp_right],
    end,
  id_comp_left :=
    begin
      intros p₁ p₂ pf,
      simp [id_comp_left],
    end,
}

theorem prod_cat_id {C : Type u₁} {D : Type u₂} [category.{v₁} C] [category.{v₂} D]
  : ∀ A : C × D, idₘ A = ⟨idₘ A.1, idₘ A.2⟩ := λ _, rfl

theorem prod_cat_comp {C : Type u₁} {D : Type u₂} [category.{v₁} C] [category.{v₂} D]
  {A₁ A₂ A₃ : C × D} (pf₁ : Mor A₂ A₃) (pf₂ : Mor A₁ A₂)
  : pf₁ ∘ₘ pf₂ = ⟨pf₁.1 ∘ₘ pf₂.1, pf₁.2 ∘ₘ pf₂.2⟩ := rfl

def product_functor {C₁: Type u₁} {D₁ : Type u₂} {C₂ : Type u₃} {D₂ : Type u₄} [category.{v₁} C₁]
  [category.{v₂} D₁] [category.{v₃} C₂] [category.{v₄} D₂]
  (F : C₁ +→ C₂) (G : D₁ +→ D₂) : (C₁ × D₁) +→ (C₂ × D₂) :=
{
  map := λ O, ⟨F.map O.1, G.map O.2⟩,
  fmap := λ _ _ pf, ⟨F.fmap pf.1, G.fmap pf.2⟩,
  fmap_prevs_id :=
    begin
      intro,
      simp [prod_cat_id, functor.fmap_prevs_id],
    end,
  fmap_prevs_comp :=
    begin
      intros A₁ A₂ A₃ pf₁ pf₂,
      simp [prod_cat_comp, functor.fmap_prevs_comp],
    end,
}

end category


/-
Copyright (c) 2022 Arthur Paulino. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Arthur Paulino, Gabriel Ebner
-/
import Std.Tactic.Simpa
import Std.Tactic.ShowTerm

set_option linter.missingDocs false

example {P : Prop} (p : P) : P := by simpa

example {P : Prop} (p : False) : P := by simp at p

def foo (n : α) := [n]

section unnecessarySimpa

-- TODO: check that these lint in the test harness
example : foo n = [n] := by
  simpa only [foo]

example (h : foo n ≠ [n]) : False := by
  simpa [foo] using h

end unnecessarySimpa

example (p : Nat → Prop) (h : p (a + b)) : p (b + a) := by
  have : a + b = b + a := Nat.add_comm _ _
  simpa [this] using h

def Injective (f : α → β) : Prop := ∀ ⦃a₁ a₂⦄, f a₁ = f a₂ → a₁ = a₂

namespace div_left_inj_issue

class Inv (α : Type u) where
  inv : α → α

class Group (α) extends Mul α, Div α, Inv α

variable [Group G]

axiom div_eq_mul_inv (a b : G) : a / b = a * Inv.inv b

axiom mul_left_injective (a : G) : Injective (· * a)

theorem div_left_injective (b : G) : Injective fun a => a / b := by
  simpa only [div_eq_mul_inv] using fun a a' h => mul_left_injective (Inv.inv b) h

end div_left_inj_issue

namespace Prod

theorem mk.inj_iff {a₁ a₂ : α} {b₁ b₂ : β} : (a₁, b₁) = (a₂, b₂) ↔ a₁ = a₂ ∧ b₁ = b₂ :=
  Iff.of_eq (mk.injEq _ _ _ _)

theorem mk.inj_left {α β : Type _} (a : α) : Injective (Prod.mk a : β → α × β) := by
  intro b₁ b₂ h
  simpa only [true_and, Prod.mk.inj_iff, eq_self] using h

end Prod

theorem implicit_lambda (h : ∀ {x : Nat}, a = x) : a = 2 := by
  simpa using h

theorem implicit_lambda2 (h : a = 2) : ∀ {x : Nat}, a = 2 := by
  simpa using h

theorem no_implicit_lambda (h : ∀ {x : Nat}, a = x) : ∀ {x : Nat}, a = x := by
  simpa using @h

theorem thm : (a : Int) ≤ b - c ↔ a + b ≤ c := sorry

theorem thm2 : (b : Int) - c ≤ (a - b) - (a - c) := sorry

example : (b - c : Int) + (a - b) + a ≤ c := by
  simpa only [thm] using thm2

example : (b - c : Int) + (a - b) + a ≤ c := by
  simpa only [thm] using @thm2


/-
Copyright (c) 2021 Eric Wieser. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Eric Wieser
-/
import algebra.module.pi

/-!
# Bundled hom instances for module and multiplicative actions

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

This file defines instances for module, mul_action and related structures on bundled `_hom` types.

These are analogous to the instances in `algebra.module.pi`, but for bundled instead of unbundled
functions.
-/

variables {R S A B : Type*}

namespace add_monoid_hom

section
variables [monoid R] [monoid S] [add_monoid A] [add_comm_monoid B]
variables [distrib_mul_action R B] [distrib_mul_action S B]

instance : distrib_mul_action R (A →+ B) :=
{ smul := λ r f,
  { to_fun := r • f,
    map_zero' := by simp,
    map_add' := λ x y, by simp [smul_add] },
  one_smul := λ f, by simp,
  mul_smul := λ r s f, by simp [mul_smul],
  smul_add := λ r f g, ext $ λ x, by simp [smul_add],
  smul_zero := λ r, ext $ λ x, by simp [smul_zero] }

@[simp] lemma coe_smul (r : R) (f : A →+ B) : ⇑(r • f) = r • f := rfl
lemma smul_apply (r : R) (f : A →+ B) (x : A) : (r • f) x = r • f x := rfl

instance [smul_comm_class R S B] : smul_comm_class R S (A →+ B) :=
⟨λ a b f, ext $ λ x, smul_comm _ _ _⟩

instance [has_smul R S] [is_scalar_tower R S B] : is_scalar_tower R S (A →+ B) :=
⟨λ a b f, ext $ λ x, smul_assoc _ _ _⟩

instance [distrib_mul_action Rᵐᵒᵖ B] [is_central_scalar R B] : is_central_scalar R (A →+ B) :=
⟨λ a b, ext $ λ x, op_smul_eq_smul _ _⟩

end

instance [semiring R] [add_monoid A] [add_comm_monoid B] [module R B] :
  module R (A →+ B) :=
{ add_smul := λ r s x, ext $ λ y, by simp [add_smul],
  zero_smul := λ x, ext $ λ y, by simp [zero_smul],
  ..add_monoid_hom.distrib_mul_action }

end add_monoid_hom