/-
Copyright (c) 2019 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import topology.opens
import category_theory.category.preorder
import category_theory.eq_to_hom
import topology.category.Top.epi_mono

/-!
# The category of open sets in a topological space.

We define `to_Top : opens X ⥤ Top` and
`map (f : X ⟶ Y) : opens Y ⥤ opens X`, given by taking preimages of open sets.

Unfortunately `opens` isn't (usefully) a functor `Top ⥤ Cat`.
(One can in fact define such a functor,
but using it results in unresolvable `eq.rec` terms in goals.)

Really it's a 2-functor from (spaces, continuous functions, equalities)
to (categories, functors, natural isomorphisms).
We don't attempt to set up the full theory here, but do provide the natural isomorphisms
`map_id : map (𝟙 X) ≅ 𝟭 (opens X)` and
`map_comp : map (f ≫ g) ≅ map g ⋙ map f`.

Beyond that, there's a collection of simp lemmas for working with these constructions.
-/

open category_theory
open topological_space
open opposite

universe u

namespace topological_space.opens

variables {X Y Z : Top.{u}}

/-!
Since `opens X` has a partial order, it automatically receives a `category` instance.
Unfortunately, because we do not allow morphisms in `Prop`,
the morphisms `U ⟶ V` are not just proofs `U ≤ V`, but rather
`ulift (plift (U ≤ V))`.
-/

instance opens_hom_has_coe_to_fun {U V : opens X} : has_coe_to_fun (U ⟶ V) (λ f, U → V) :=
⟨λ f x, ⟨x, f.le x.2⟩⟩

/-!
We now construct as morphisms various inclusions of open sets.
-/
-- This is tedious, but necessary because we decided not to allow Prop as morphisms in a category...

/--
The inclusion `U ⊓ V ⟶ U` as a morphism in the category of open sets.
-/
def inf_le_left (U V : opens X) : U ⊓ V ⟶ U := inf_le_left.hom

/--
The inclusion `U ⊓ V ⟶ V` as a morphism in the category of open sets.
-/
def inf_le_right (U V : opens X) : U ⊓ V ⟶ V := inf_le_right.hom

/--
The inclusion `U i ⟶ supr U` as a morphism in the category of open sets.
-/
def le_supr {ι : Type*} (U : ι → opens X) (i : ι) : U i ⟶ supr U := (le_supr U i).hom

/--
The inclusion `⊥ ⟶ U` as a morphism in the category of open sets.
-/
def bot_le (U : opens X) : ⊥ ⟶ U := bot_le.hom

/--
The inclusion `U ⟶ ⊤` as a morphism in the category of open sets.
-/
def le_top (U : opens X) : U ⟶ ⊤ := le_top.hom

-- We do not mark this as a simp lemma because it breaks open `x`.
-- Nevertheless, it is useful in `sheaf_of_functions`.
lemma inf_le_left_apply (U V : opens X) (x) :
  (inf_le_left U V) x = ⟨x.1, (@_root_.inf_le_left _ _ U V : _ ≤ _) x.2⟩ :=
rfl

@[simp]
lemma inf_le_left_apply_mk (U V : opens X) (x) (m) :
  (inf_le_left U V) ⟨x, m⟩ = ⟨x, (@_root_.inf_le_left _ _ U V : _ ≤ _) m⟩ :=
rfl

@[simp]
lemma le_supr_apply_mk {ι : Type*} (U : ι → opens X) (i : ι) (x) (m) :
  (le_supr U i) ⟨x, m⟩ = ⟨x, (_root_.le_supr U i : _) m⟩ :=
rfl

/--
The functor from open sets in `X` to `Top`,
realising each open set as a topological space itself.
-/
def to_Top (X : Top.{u}) : opens X ⥤ Top :=
{ obj := λ U, ⟨U.val, infer_instance⟩,
  map := λ U V i, ⟨λ x, ⟨x.1, i.le x.2⟩,
    (embedding.continuous_iff embedding_subtype_coe).2 continuous_induced_dom⟩ }

@[simp]
lemma to_Top_map (X : Top.{u}) {U V : opens X} {f : U ⟶ V} {x} {h} :
  ((to_Top X).map f) ⟨x, h⟩ = ⟨x, f.le h⟩ :=
rfl

/--
The inclusion map from an open subset to the whole space, as a morphism in `Top`.
-/
@[simps]
def inclusion {X : Top.{u}} (U : opens X) : (to_Top X).obj U ⟶ X :=
{ to_fun := _,
  continuous_to_fun := continuous_subtype_coe }

lemma open_embedding {X : Top.{u}} (U : opens X) : open_embedding (inclusion U) :=
is_open.open_embedding_subtype_coe U.2

/--
The inclusion of the top open subset (i.e. the whole space) is an isomorphism.
-/
def inclusion_top_iso (X : Top.{u}) : (to_Top X).obj ⊤ ≅ X :=
{ hom := inclusion ⊤,
  inv := ⟨λ x, ⟨x, trivial⟩, continuous_def.2 $ λ U ⟨S, hS, hSU⟩, hSU ▸ hS⟩ }

/-- `opens.map f` gives the functor from open sets in Y to open set in X,
    given by taking preimages under f. -/
def map (f : X ⟶ Y) : opens Y ⥤ opens X :=
{ obj := λ U, ⟨ f ⁻¹' U.val, U.property.preimage f.continuous ⟩,
  map := λ U V i, ⟨ ⟨ λ x h, i.le h ⟩ ⟩ }.

@[simp] lemma map_obj (f : X ⟶ Y) (U) (p) :
  (map f).obj ⟨U, p⟩ = ⟨f ⁻¹' U, p.preimage f.continuous⟩ := rfl

@[simp] lemma map_id_obj (U : opens X) : (map (𝟙 X)).obj U = U :=
let ⟨_,_⟩ := U in rfl

@[simp] lemma map_id_obj' (U) (p) : (map (𝟙 X)).obj ⟨U, p⟩ = ⟨U, p⟩ :=
rfl

@[simp] lemma map_id_obj_unop (U : (opens X)ᵒᵖ) : (map (𝟙 X)).obj (unop U) = unop U :=
let ⟨_,_⟩ := U.unop in rfl
@[simp]

/--
The inclusion `U ⟶ (map f).obj ⊤` as a morphism in the category of open sets.
-/
def le_map_top (f : X ⟶ Y) (U : opens X) : U ⟶ (map f).obj ⊤ :=
le_top U

@[simp] lemma map_comp_obj (f : X ⟶ Y) (g : Y ⟶ Z) (U) :
  (map (f ≫ g)).obj U = (map f).obj ((map g).obj U) :=
rfl

@[simp] lemma map_comp_obj' (f : X ⟶ Y) (g : Y ⟶ Z) (U) (p) :
  (map (f ≫ g)).obj ⟨U, p⟩ = (map f).obj ((map g).obj ⟨U, p⟩) :=
rfl

@[simp] lemma map_comp_map (f : X ⟶ Y) (g : Y ⟶ Z) {U V} (i : U ⟶ V) :
  (map (f ≫ g)).map i = (map f).map ((map g).map i) :=
rfl

@[simp] lemma map_comp_obj_unop (f : X ⟶ Y) (g : Y ⟶ Z) (U) :
  (map (f ≫ g)).obj (unop U) = (map f).obj ((map g).obj (unop U)) :=
rfl

@[simp] lemma op_map_comp_obj (f : X ⟶ Y) (g : Y ⟶ Z) (U) :
  (map (f ≫ g)).op.obj U = (map f).op.obj ((map g).op.obj U) :=
rfl

lemma map_supr (f : X ⟶ Y) {ι : Type*} (U : ι → opens Y) :
  (map f).obj (supr U) = supr ((map f).obj ∘ U) :=
begin
  apply subtype.eq, rw [supr_def, supr_def, map_obj],
  dsimp, rw set.preimage_Union, refl,
end

section
variable (X)

/--
The functor `opens X ⥤ opens X` given by taking preimages under the identity function
is naturally isomorphic to the identity functor.
-/
@[simps]
def map_id : map (𝟙 X) ≅ 𝟭 (opens X) :=
{ hom := { app := λ U, eq_to_hom (map_id_obj U) },
  inv := { app := λ U, eq_to_hom (map_id_obj U).symm } }

lemma map_id_eq : map (𝟙 X) = 𝟭 (opens X) :=
by { unfold map, congr, ext, refl, ext }

end

/--
The natural isomorphism between taking preimages under `f ≫ g`, and the composite
of taking preimages under `g`, then preimages under `f`.
-/
@[simps]
def map_comp (f : X ⟶ Y) (g : Y ⟶ Z) : map (f ≫ g) ≅ map g ⋙ map f :=
{ hom := { app := λ U, eq_to_hom (map_comp_obj f g U) },
  inv := { app := λ U, eq_to_hom (map_comp_obj f g U).symm } }

lemma map_comp_eq (f : X ⟶ Y) (g : Y ⟶ Z) : map (f ≫ g) = map g ⋙ map f :=
rfl

/--
If two continuous maps `f g : X ⟶ Y` are equal,
then the functors `opens Y ⥤ opens X` they induce are isomorphic.
-/
-- We could make `f g` implicit here, but it's nice to be able to see when
-- they are the identity (often!)
def map_iso (f g : X ⟶ Y) (h : f = g) : map f ≅ map g :=
nat_iso.of_components (λ U, eq_to_iso (congr_fun (congr_arg functor.obj (congr_arg map h)) U) )
  (by obviously)

lemma map_eq (f g : X ⟶ Y) (h : f = g) : map f = map g :=
by { unfold map, congr, ext, rw h, rw h, assumption' }

@[simp] lemma map_iso_refl (f : X ⟶ Y) (h) : map_iso f f h = iso.refl (map _) := rfl

@[simp] lemma map_iso_hom_app (f g : X ⟶ Y) (h : f = g) (U : opens Y) :
  (map_iso f g h).hom.app U = eq_to_hom (congr_fun (congr_arg functor.obj (congr_arg map h)) U) :=
rfl

@[simp] lemma map_iso_inv_app (f g : X ⟶ Y) (h : f = g) (U : opens Y) :
  (map_iso f g h).inv.app U =
     eq_to_hom (congr_fun (congr_arg functor.obj (congr_arg map h.symm)) U) :=
rfl

/-- A homeomorphism of spaces gives an equivalence of categories of open sets. -/
@[simps] def map_map_iso {X Y : Top.{u}} (H : X ≅ Y) : opens Y ≌ opens X :=
{ functor := map H.hom,
  inverse := map H.inv,
  unit_iso := nat_iso.of_components (λ U, eq_to_iso (by simp [map, set.preimage_preimage]))
    (by { intros _ _ _, simp }),
  counit_iso := nat_iso.of_components (λ U, eq_to_iso (by simp [map, set.preimage_preimage]))
    (by { intros _ _ _, simp }) }

end topological_space.opens

/--
An open map `f : X ⟶ Y` induces a functor `opens X ⥤ opens Y`.
-/
@[simps]
def is_open_map.functor {X Y : Top} {f : X ⟶ Y} (hf : is_open_map f) :
  opens X ⥤ opens Y :=
{ obj := λ U, ⟨f '' U, hf U U.2⟩,
  map := λ U V h, ⟨⟨set.image_subset _ h.down.down⟩⟩ }

/--
An open map `f : X ⟶ Y` induces an adjunction between `opens X` and `opens Y`.
-/
def is_open_map.adjunction {X Y : Top} {f : X ⟶ Y} (hf : is_open_map f) :
  adjunction hf.functor (topological_space.opens.map f) :=
adjunction.mk_of_unit_counit
{ unit := { app := λ U, hom_of_le $ λ x hxU, ⟨x, hxU, rfl⟩ },
  counit := { app := λ V, hom_of_le $ λ y ⟨x, hfxV, hxy⟩, hxy ▸ hfxV } }

instance is_open_map.functor_full_of_mono {X Y : Top} {f : X ⟶ Y} (hf : is_open_map f)
  [H : mono f] : full hf.functor :=
{ preimage := λ U V i, hom_of_le (λ x hx, by
  { obtain ⟨y, hy, eq⟩ := i.le ⟨x, hx, rfl⟩, exact (Top.mono_iff_injective f).mp H eq ▸ hy }) }

instance is_open_map.functor_faithful {X Y : Top} {f : X ⟶ Y} (hf : is_open_map f) :
  faithful hf.functor := {}

namespace topological_space.opens
open topological_space

lemma inclusion_top_functor (X : Top) :
  (@opens.open_embedding X ⊤).is_open_map.functor =
  map (inclusion_top_iso X).inv :=
begin
  apply functor.hext, intro, abstract obj_eq { ext,
  exact ⟨ λ ⟨⟨_,_⟩,h,rfl⟩, h, λ h, ⟨⟨x,trivial⟩,h,rfl⟩ ⟩ },
  intros, apply subsingleton.helim, congr' 1,
  iterate 2 {apply inclusion_top_functor.obj_eq},
end

end topological_space.opens


/-
Copyright (c) 2020 Simon Hudon. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Simon Hudon
-/
import data.list.sigma
import data.int.range
import data.finsupp.defs
import data.finsupp.to_dfinsupp
import tactic.pretty_cases
import testing.slim_check.sampleable
import testing.slim_check.testable

/-!
## `slim_check`: generators for functions

This file defines `sampleable` instances for `α → β` functions and
`ℤ → ℤ` injective functions.

Functions are generated by creating a list of pairs and one more value
using the list as a lookup table and resorting to the additional value
when a value is not found in the table.

Injective functions are generated by creating a list of numbers and
a permutation of that list. The permutation insures that every input
is mapped to a unique output. When an input is not found in the list
the input itself is used as an output.

Injective functions `f : α → α` could be generated easily instead of
`ℤ → ℤ` by generating a `list α`, removing duplicates and creating a
permutations. One has to be careful when generating the domain to make
if vast enough that, when generating arguments to apply `f` to,
they argument should be likely to lie in the domain of `f`. This is
the reason that injective functions `f : ℤ → ℤ` are generated by
fixing the domain to the range `[-2*size .. -2*size]`, with `size`
the size parameter of the `gen` monad.

Much of the machinery provided in this file is applicable to generate
injective functions of type `α → α` and new instances should be easy
to define.

Other classes of functions such as monotone functions can generated using
similar techniques. For monotone functions, generating two lists, sorting them
and matching them should suffice, with appropriate default values.
Some care must be taken for shrinking such functions to make sure
their defining property is invariant through shrinking. Injective
functions are an example of how complicated it can get.
-/

universes u v w
variables {α : Type u} {β : Type v} {γ : Sort w}

namespace slim_check

/-- Data structure specifying a total function using a list of pairs
and a default value returned when the input is not in the domain of
the partial function.

`with_default f y` encodes `x ↦ f x` when `x ∈ f` and `x ↦ y`
otherwise.

We use `Σ` to encode mappings instead of `×` because we
rely on the association list API defined in `data.list.sigma`.
 -/
inductive total_function (α : Type u) (β : Type v) : Type (max u v)
| with_default : list (Σ _ : α, β) → β → total_function

instance total_function.inhabited [inhabited β] : inhabited (total_function α β) :=
⟨ total_function.with_default ∅ default ⟩

namespace total_function

/-- Apply a total function to an argument. -/
def apply [decidable_eq α] : total_function α β → α → β
| (total_function.with_default m y) x := (m.lookup x).get_or_else y

/--
Implementation of `has_repr (total_function α β)`.

Creates a string for a given `finmap` and output, `x₀ ↦ y₀, .. xₙ ↦ yₙ`
for each of the entries. The brackets are provided by the calling function.
-/
def repr_aux [has_repr α] [has_repr β] (m : list (Σ _ : α, β)) : string :=
string.join $ list.qsort (λ x y, x < y)
  (m.map $ λ x, sformat!"{repr $ sigma.fst x} ↦ {repr $ sigma.snd x}, ")

/--
Produce a string for a given `total_function`.
The output is of the form `[x₀ ↦ f x₀, .. xₙ ↦ f xₙ, _ ↦ y]`.
-/
protected def repr [has_repr α] [has_repr β] : total_function α β → string
| (total_function.with_default m y) := sformat!"[{repr_aux m}_ ↦ {has_repr.repr y}]"

instance (α : Type u) (β : Type v) [has_repr α] [has_repr β] : has_repr (total_function α β) :=
⟨ total_function.repr ⟩

/-- Create a `finmap` from a list of pairs. -/
def list.to_finmap' (xs : list (α × β)) : list (Σ _ : α, β) :=
xs.map prod.to_sigma

section

variables [sampleable α] [sampleable β]

/-- Redefine `sizeof` to follow the structure of `sampleable` instances. -/
def total.sizeof : total_function α β → ℕ
| ⟨m, x⟩ := 1 + @sizeof _ sampleable.wf m + sizeof x

@[priority 2000]
instance : has_sizeof (total_function α β) :=
⟨ total.sizeof ⟩

variables [decidable_eq α]

/-- Shrink a total function by shrinking the lists that represent it. -/
protected def shrink : shrink_fn (total_function α β)
| ⟨m, x⟩ := (sampleable.shrink (m, x)).map $ λ ⟨⟨m', x'⟩, h⟩, ⟨⟨list.dedupkeys m', x'⟩,
            lt_of_le_of_lt
              (by unfold_wf; refine @list.sizeof_dedupkeys _ _ _ (@sampleable.wf _ _) _) h ⟩

variables [has_repr α] [has_repr β]

instance pi.sampleable_ext : sampleable_ext (α → β) :=
{ proxy_repr := total_function α β,
  interp := total_function.apply,
  sample := do
  { xs ← (sampleable.sample (list (α × β)) : gen ((list (α × β)))),
    ⟨x⟩ ← (uliftable.up $ sample β : gen (ulift.{max u v} β)),
    pure $ total_function.with_default (list.to_finmap' xs) x },
  shrink := total_function.shrink }

end

section finsupp

variables [has_zero β]
/-- Map a total_function to one whose default value is zero so that it represents a finsupp. -/
@[simp]
def zero_default : total_function α β → total_function α β
| (with_default A y) := with_default A 0

variables [decidable_eq α] [decidable_eq β]
/-- The support of a zero default `total_function`. -/
@[simp]
def zero_default_supp : total_function α β → finset α
| (with_default A y) :=
  list.to_finset $ (A.dedupkeys.filter (λ ab, sigma.snd ab ≠ 0)).map sigma.fst

/-- Create a finitely supported function from a total function by taking the default value to
zero. -/
def apply_finsupp (tf : total_function α β) : α →₀ β :=
{ support := zero_default_supp tf,
  to_fun := tf.zero_default.apply,
  mem_support_to_fun := begin
    intro a,
    rcases tf with ⟨A, y⟩,
    simp only [apply, zero_default_supp, list.mem_map, list.mem_filter, exists_and_distrib_right,
      list.mem_to_finset, exists_eq_right, sigma.exists, ne.def, zero_default],
    split,
    { rintro ⟨od, hval, hod⟩,
      have := list.mem_lookup (list.nodupkeys_dedupkeys A) hval,
      rw (_ : list.lookup a A = od),
      { simpa, },
      { simpa [list.lookup_dedupkeys, with_top.some_eq_coe], }, },
    { intro h,
      use (A.lookup a).get_or_else (0 : β),
      rw ← list.lookup_dedupkeys at h ⊢,
      simp only [h, ←list.mem_lookup_iff A.nodupkeys_dedupkeys,
        and_true, not_false_iff, option.mem_def],
      cases list.lookup a A.dedupkeys,
      { simpa using h, },
      { simp, }, }
  end }

variables [sampleable α] [sampleable β]
instance finsupp.sampleable_ext [has_repr α] [has_repr β] : sampleable_ext (α →₀ β) :=
{ proxy_repr := total_function α β,
  interp := total_function.apply_finsupp,
  sample := (do
    xs ← (sampleable.sample (list (α × β)) : gen (list (α × β))),
    ⟨x⟩ ← (uliftable.up $ sample β : gen (ulift.{max u v} β)),
    pure $ total_function.with_default (list.to_finmap' xs) x),
  shrink := total_function.shrink }

-- TODO: support a non-constant codomain type
instance dfinsupp.sampleable_ext [has_repr α] [has_repr β] : sampleable_ext (Π₀ a : α, β) :=
{ proxy_repr := total_function α β,
  interp := finsupp.to_dfinsupp ∘ total_function.apply_finsupp,
  sample := (do
    xs ← (sampleable.sample (list (α × β)) : gen (list (α × β))),
    ⟨x⟩ ← (uliftable.up $ sample β : gen (ulift.{max u v} β)),
    pure $ total_function.with_default (list.to_finmap' xs) x),
  shrink := total_function.shrink }

end finsupp

section sampleable_ext
open sampleable_ext

@[priority 2000]
instance pi_pred.sampleable_ext [sampleable_ext (α → bool)] :
  sampleable_ext.{u+1} (α → Prop) :=
{ proxy_repr := proxy_repr (α → bool),
  interp := λ m x, interp (α → bool) m x,
  sample := sample (α → bool),
  shrink := shrink }

@[priority 2000]
instance pi_uncurry.sampleable_ext
  [sampleable_ext (α × β → γ)] : sampleable_ext.{imax (u+1) (v+1) w} (α → β → γ) :=
{ proxy_repr := proxy_repr (α × β → γ),
  interp := λ m x y, interp (α × β → γ) m (x, y),
  sample := sample (α × β → γ),
  shrink := shrink }

end sampleable_ext

end total_function

/--
Data structure specifying a total function using a list of pairs
and a default value returned when the input is not in the domain of
the partial function.

`map_to_self f` encodes `x ↦ f x` when `x ∈ f` and `x ↦ x`,
i.e. `x` to itself, otherwise.

We use `Σ` to encode mappings instead of `×` because we
rely on the association list API defined in `data.list.sigma`.
-/
inductive injective_function (α : Type u) : Type u
| map_to_self (xs : list (Σ _ : α, α)) :
    xs.map sigma.fst ~ xs.map sigma.snd → list.nodup (xs.map sigma.snd) → injective_function

instance : inhabited (injective_function α) :=
⟨ ⟨ [], list.perm.nil, list.nodup_nil ⟩ ⟩

namespace injective_function

/-- Apply a total function to an argument. -/
def apply [decidable_eq α] : injective_function α → α → α
| (injective_function.map_to_self m _ _) x := (m.lookup x).get_or_else x

/--
Produce a string for a given `total_function`.
The output is of the form `[x₀ ↦ f x₀, .. xₙ ↦ f xₙ, x ↦ x]`.
Unlike for `total_function`, the default value is not a constant
but the identity function.
-/
protected def repr [has_repr α] : injective_function α → string
| (injective_function.map_to_self m _ _) := sformat!"[{total_function.repr_aux m}x ↦ x]"

instance (α : Type u) [has_repr α] : has_repr (injective_function α) :=
⟨ injective_function.repr ⟩

/-- Interpret a list of pairs as a total function, defaulting to
the identity function when no entries are found for a given function -/
def list.apply_id [decidable_eq α] (xs : list (α × α)) (x : α) : α :=
((xs.map prod.to_sigma).lookup x).get_or_else x

@[simp]
lemma list.apply_id_cons [decidable_eq α] (xs : list (α × α)) (x y z : α) :
  list.apply_id ((y, z) :: xs) x = if y = x then z else list.apply_id xs x :=
by simp only [list.apply_id, list.lookup, eq_rec_constant, prod.to_sigma, list.map]; split_ifs; refl

open function _root_.list _root_.prod (to_sigma)
open _root_.nat

lemma list.apply_id_zip_eq [decidable_eq α] {xs ys : list α} (h₀ : list.nodup xs)
  (h₁ : xs.length = ys.length) (x y : α) (i : ℕ)
  (h₂ : xs.nth i = some x) :
  list.apply_id.{u} (xs.zip ys) x = y ↔ ys.nth i = some y :=
begin
  induction xs generalizing ys i,
  case list.nil : ys i h₁ h₂
  { cases h₂ },
  case list.cons : x' xs xs_ih ys i h₁ h₂
  { cases i,
    { injection h₂ with h₀ h₁, subst h₀,
      cases ys,
      { cases h₁ },
      { simp only [list.apply_id, to_sigma, option.get_or_else_some, nth, lookup_cons_eq,
                   zip_cons_cons, list.map], } },
    { cases ys,
      { cases h₁ },
      { cases h₀ with _ _ h₀ h₁,
        simp only [nth, zip_cons_cons, list.apply_id_cons] at h₂ ⊢,
        rw if_neg,
        { apply xs_ih; solve_by_elim [succ.inj] },
        { apply h₀, apply nth_mem h₂ } } } }
end

lemma apply_id_mem_iff [decidable_eq α] {xs ys : list α} (h₀ : list.nodup xs)
  (h₁ : xs ~ ys)
  (x : α) :
  list.apply_id.{u} (xs.zip ys) x ∈ ys ↔ x ∈ xs :=
begin
  simp only [list.apply_id],
  cases h₃ : (lookup x (map prod.to_sigma (xs.zip ys))),
  { dsimp [option.get_or_else],
    rw h₁.mem_iff },
  { have h₂ : ys.nodup := h₁.nodup_iff.1 h₀,
    replace h₁ : xs.length = ys.length := h₁.length_eq,
    dsimp,
    induction xs generalizing ys,
    case list.nil : ys h₃ h₂ h₁
    { contradiction },
    case list.cons : x' xs xs_ih ys h₃ h₂ h₁
    { cases ys with y ys,
      { cases h₃ },
      dsimp [lookup] at h₃, split_ifs at h₃,
      { subst x', subst val,
        simp only [mem_cons_iff, true_or, eq_self_iff_true], },
      { cases h₀ with _ _ h₀ h₅,
        cases h₂ with _ _ h₂ h₄,
        have h₆ := nat.succ.inj h₁,
        specialize @xs_ih h₅ ys h₃ h₄ h₆,
        simp only [ne.symm h, xs_ih, mem_cons_iff, false_or],
        suffices : val ∈ ys, tauto!,
        erw [← option.mem_def, mem_lookup_iff] at h₃,
        simp only [to_sigma, mem_map, heq_iff_eq, prod.exists] at h₃,
        rcases h₃ with ⟨a, b, h₃, h₄, h₅⟩,
        subst a, subst b,
        apply (mem_zip h₃).2,
        simp only [nodupkeys, keys, comp, prod.fst_to_sigma, map_map],
        rwa map_fst_zip _ _ (le_of_eq h₆) } } }
end

lemma list.apply_id_eq_self [decidable_eq α] {xs ys : list α} (x : α) :
  x ∉ xs → list.apply_id.{u} (xs.zip ys) x = x :=
begin
  intro h,
  dsimp [list.apply_id],
  rw lookup_eq_none.2, refl,
  simp only [keys, not_exists, to_sigma, exists_and_distrib_right, exists_eq_right, mem_map,
             comp_app, map_map, prod.exists],
  intros y hy,
  exact h (mem_zip hy).1,
end

lemma apply_id_injective [decidable_eq α] {xs ys : list α} (h₀ : list.nodup xs)
  (h₁ : xs ~ ys) : injective.{u+1 u+1} (list.apply_id (xs.zip ys)) :=
begin
  intros x y h,
  by_cases hx : x ∈ xs;
    by_cases hy : y ∈ xs,
  { rw mem_iff_nth at hx hy,
    cases hx with i hx,
    cases hy with j hy,
    suffices : some x = some y,
    { injection this },
    have h₂ := h₁.length_eq,
    rw [list.apply_id_zip_eq h₀ h₂ _ _ _ hx] at h,
    rw [← hx, ← hy], congr,
    apply nth_injective _ (h₁.nodup_iff.1 h₀),
    { symmetry, rw h,
      rw ← list.apply_id_zip_eq; assumption },
    { rw ← h₁.length_eq,
      rw nth_eq_some at hx,
      cases hx with hx hx',
      exact hx } },
  { rw ← apply_id_mem_iff h₀ h₁ at hx hy,
    rw h at hx,
    contradiction, },
  { rw ← apply_id_mem_iff h₀ h₁ at hx hy,
    rw h at hx,
    contradiction, },
  { rwa [list.apply_id_eq_self, list.apply_id_eq_self] at h; assumption },
end

open total_function (list.to_finmap')
open sampleable

/--
Remove a slice of length `m` at index `n` in a list and a permutation, maintaining the property
that it is a permutation.
-/
def perm.slice [decidable_eq α] (n m : ℕ) :
  (Σ' xs ys : list α, xs ~ ys ∧ ys.nodup) → (Σ' xs ys : list α, xs ~ ys ∧ ys.nodup)
| ⟨xs, ys, h, h'⟩ :=
  let xs' := list.slice n m xs in
  have h₀ : xs' ~ ys.inter xs',
    from perm.slice_inter _ _ h h',
  ⟨xs', ys.inter xs', h₀, h'.inter _⟩

/--
A lazy list, in decreasing order, of sizes that should be
sliced off a list of length `n`
-/
def slice_sizes : ℕ → lazy_list ℕ+
| n :=
if h : 0 < n then
  have n / 2 < n, from div_lt_self h dec_trivial,
  lazy_list.cons ⟨_, h⟩ (slice_sizes $ n / 2)
else lazy_list.nil

/--
Shrink a permutation of a list, slicing a segment in the middle.

The sizes of the slice being removed start at `n` (with `n` the length
of the list) and then `n / 2`, then `n / 4`, etc down to 1. The slices
will be taken at index `0`, `n / k`, `2n / k`, `3n / k`, etc.
-/
protected def shrink_perm {α : Type} [decidable_eq α] [has_sizeof α] :
  shrink_fn (Σ' xs ys : list α, xs ~ ys ∧ ys.nodup)
| xs := do
  let k := xs.1.length,
  n ← slice_sizes k,
  i ← lazy_list.of_list $ list.fin_range $ k / n,
  have ↑i * ↑n < xs.1.length,
    from nat.lt_of_div_lt_div
      (lt_of_le_of_lt (by simp only [nat.mul_div_cancel, gt_iff_lt, fin.val_eq_coe, pnat.pos]) i.2),
  pure ⟨perm.slice (i*n) n xs,
    by rcases xs with ⟨a,b,c,d⟩; dsimp [sizeof_lt]; unfold_wf; simp only [perm.slice];
       unfold_wf; apply list.sizeof_slice_lt _ _ n.2 _ this⟩

instance [has_sizeof α] : has_sizeof (injective_function α) :=
⟨ λ ⟨xs,_,_⟩, sizeof (xs.map sigma.fst) ⟩

/--
Shrink an injective function slicing a segment in the middle of the domain and removing
the corresponding elements in the codomain, hence maintaining the property that
one is a permutation of the other.
-/
protected def shrink {α : Type} [has_sizeof α] [decidable_eq α] : shrink_fn (injective_function α)
| ⟨xs, h₀, h₁⟩ := do
  ⟨⟨xs', ys', h₀, h₁⟩, h₂⟩ ← injective_function.shrink_perm ⟨_, _, h₀, h₁⟩,
  have h₃ : xs'.length ≤ ys'.length, from le_of_eq (perm.length_eq h₀),
  have h₄ : ys'.length ≤ xs'.length, from le_of_eq (perm.length_eq h₀.symm),
  pure ⟨⟨(list.zip xs' ys').map prod.to_sigma,
    by simp only [comp, map_fst_zip, map_snd_zip, *, prod.fst_to_sigma, prod.snd_to_sigma, map_map],
    by simp only [comp, map_snd_zip, *, prod.snd_to_sigma, map_map] ⟩,
    by revert h₂; dsimp [sizeof_lt]; unfold_wf;
       simp only [has_sizeof._match_1, map_map, comp, map_fst_zip, *, prod.fst_to_sigma];
       unfold_wf; intro h₂; convert h₂ ⟩

/-- Create an injective function from one list and a permutation of that list. -/
protected def mk (xs ys : list α) (h : xs ~ ys) (h' : ys.nodup) : injective_function α :=
have h₀ : xs.length ≤ ys.length, from le_of_eq h.length_eq,
have h₁ : ys.length ≤ xs.length, from le_of_eq h.length_eq.symm,
injective_function.map_to_self (list.to_finmap' (xs.zip ys))
  (by { simp only [list.to_finmap', comp, map_fst_zip, map_snd_zip, *,
                   prod.fst_to_sigma, prod.snd_to_sigma, map_map] })
  (by { simp only [list.to_finmap', comp, map_snd_zip, *, prod.snd_to_sigma, map_map] })

protected lemma injective [decidable_eq α] (f : injective_function α) :
  injective (apply f) :=
begin
  cases f with xs hperm hnodup,
  generalize h₀ : map sigma.fst xs = xs₀,
  generalize h₁ : xs.map (@id ((Σ _ : α, α) → α) $ @sigma.snd α (λ _ : α, α)) = xs₁,
  dsimp [id] at h₁,
  have hxs : xs = total_function.list.to_finmap' (xs₀.zip xs₁),
  { rw [← h₀, ← h₁, list.to_finmap'], clear h₀ h₁ xs₀ xs₁ hperm hnodup,
    induction xs,
    case list.nil
    { simp only [zip_nil_right, map_nil] },
    case list.cons : xs_hd xs_tl xs_ih
    { simp only [true_and, to_sigma, eq_self_iff_true, sigma.eta, zip_cons_cons, list.map],
      exact xs_ih }, },
  revert hperm hnodup,
  rw hxs, intros,
  apply apply_id_injective,
  { rwa [← h₀, hxs, hperm.nodup_iff], },
  { rwa [← hxs, h₀, h₁] at hperm, },
end

instance pi_injective.sampleable_ext : sampleable_ext { f : ℤ → ℤ // function.injective f } :=
{ proxy_repr := injective_function ℤ,
  interp := λ f, ⟨ apply f, f.injective ⟩,
  sample := gen.sized $ λ sz, do
  { let xs' := int.range (-(2*sz+2)) (2*sz + 2),
    ys ← gen.permutation_of xs',
    have Hinj : injective (λ (r : ℕ), -(2*sz + 2 : ℤ) + ↑r),
      from λ x y h, int.coe_nat_inj (add_right_injective _ h),
    let r : injective_function ℤ :=
      injective_function.mk.{0} xs' ys.1 ys.2 (ys.2.nodup_iff.1 $ (nodup_range _).map Hinj) in
    pure r },
  shrink := @injective_function.shrink ℤ _ _ }

end injective_function

open function

instance injective.testable (f : α → β)
  [I : testable (named_binder "x" $
    ∀ x : α, named_binder "y" $ ∀ y : α, named_binder "H" $ f x = f y → x = y)] :
  testable (injective f) := I

instance monotone.testable [preorder α] [preorder β] (f : α → β)
  [I : testable (named_binder "x" $
    ∀ x : α, named_binder "y" $ ∀ y : α, named_binder "H" $ x ≤ y → f x ≤ f y)] :
  testable (monotone f) := I

instance antitone.testable [preorder α] [preorder β] (f : α → β)
  [I : testable (named_binder "x" $
    ∀ x : α, named_binder "y" $ ∀ y : α, named_binder "H" $ x ≤ y → f y ≤ f x)] :
  testable (antitone f) := I

end slim_check


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

/-!
# The Kleisli construction on the Type category

Define the Kleisli category for (control) monads.
`category_theory/monad/kleisli` defines the general version for a monad on `C`, and demonstrates
the equivalence between the two.

## TODO

Generalise this to work with category_theory.monad
-/

universes u v

namespace category_theory

/-- The Kleisli category on the (type-)monad `m`. Note that the monad is not assumed to be lawful
yet. -/
@[nolint unused_arguments]
def Kleisli (m : Type u → Type v) := Type u

/-- Construct an object of the Kleisli category from a type. -/
def Kleisli.mk (m) (α : Type u) : Kleisli m := α

instance Kleisli.category_struct {m} [monad.{u v} m] : category_struct (Kleisli m) :=
{ hom := λ α β, α → m β,
  id := λ α x, pure x,
  comp := λ X Y Z f g, f >=> g }

instance Kleisli.category {m} [monad.{u v} m] [is_lawful_monad m] : category (Kleisli m) :=
by refine { id_comp' := _, comp_id' := _, assoc' := _ };
   intros; ext; unfold_projs; simp only [(>=>)] with functor_norm

@[simp] lemma Kleisli.id_def {m} [monad m] (α : Kleisli m) :
  𝟙 α = @pure m _ α := rfl

lemma Kleisli.comp_def {m} [monad m] (α β γ : Kleisli m)
  (xs : α ⟶ β) (ys : β ⟶ γ) (a : α) :
  (xs ≫ ys) a = xs a >>= ys := rfl

instance : inhabited (Kleisli id) := ⟨punit⟩
instance {α : Type u} [inhabited α] : inhabited (Kleisli.mk id α) := ⟨(default α : _)⟩
end category_theory


/- Inversion lemmas for the wellformedness predicate -/

import IIT.Wellformedness

open Lean
open Elab
open Command
open Meta
open Array

namespace IIT

end IIT

#check Nat.le

inductive contains0: List Nat → Prop where
| in_hd : ∀ l, contains0 (0 :: l)
| in_tl : ∀ l b, contains0 l → contains0 (b :: l)

example : ∀ l : List Nat, contains0 (1 :: l) → contains0 l := by
  intros l H
  cases H
  assumption

inductive Le : Nat → Nat → Prop where
| Le0 : ∀ n, Le 0 n
| LeS : ∀ n m, Le n m → Le (Nat.succ n) (Nat.succ m)

example (P : Nat → Nat → Prop) (Q : ∀ n m, Le n m → P n m) (n m : Nat) (H : Le (Nat.succ n) m) : P n m := by
  cases H
  apply Q
  cases H


import Mathlib.Tactic.Basic

/-!
## Summary of New Lean Constructs

**Commands**

| name | description |
|------|-------------|
| `set_option` | changes or activates tracing, syntax output, etc. |

**Attribute**

| name | description |
|------|-------------|
| `attribute simp` | adds a lemma to the simp set |

**Proof Commands**

| name | description |
|------|-------------|
| `by` | applies a single tactic |

**Tactics**

| name | description |
|------|-------------|
| `apply`      | matches the goal’s target with the lemma’s conclusion and replaces the goal with the lemma’s hypotheses |
| `assumption` | proves the goal using a hypothesis |
| `cc`         | propagates equalities up to to associativity and commutativity |
| `clear`      | removes a variable or hypothesis from the goal |
| `exact`      | proves the goal using the specified lemma |
| `induction’` | performs structural induction on a variable of an inductive type |
| `intro(s)`   | moves ∀-quantified variables into the goal’s hypotheses |
| `refl`       | proves l = r where l and r are equal up to computation |
| `rename`     | renames a variable or hypothesis |
| `rewrite`    | applies the given rewrite rule once |
| `simp`       | applies a set of preregistered rewrite rules exhaustively |
| `sorry`      | stands for a missing proof or definition |

**Tactic Combinator**

| name | description |
|------|-------------|
| `{ . . . }` | focuses on the first subgoal; needs to prove that goal |
-/


import semantics.consistency syntax.soundness

local attribute [instance] classical.prop_decidable

open  Kproof

/-

In this file we prove completeness (found near the end of the file) for
K modal logic.

The classic proof goes like this utilizes a canonical model for K. In other words,
a modal model where the worlds are sets of formulas such that whenever there is
a set Γ that is consistent, there also a exists a world for it. Furthermore,
the accesibility relation and valuation function are defined such that truth
in a world and membership in one of the worlds are the same thing.

The big helper functions needed are to prove Lindenbaum's lemma, which states
that a set of formulas Γ is complete iff for every formula A, we have at least
one of A ∈ Γ or ¬A ∈ Γ. This is proved in consistency.#check

Another helper function that is important is the Truth lemma, such that whenever
a world in the canonical model satisfies a formula, that formula is in the
world itself (because recall the worlds are sets of formulas).

-/

namespace canonical

def canonical (Γ : ctx) [hax : sem_cons Γ] : frame :=
{
  W := {xΓ : ctx // max_ax_consist Γ xΓ},
  W_inhabited :=
  begin
    have h1 := max_ax_exists Γ hax,
    choose Γ h1 using h1,
    exact subtype.inhabited h1,
  end,
  R := λ xΓ yΔ, ∀ A : form, □A ∈ xΓ.val → A ∈ yΔ.val
}

def val_canonical (Γ : ctx) [hax : sem_cons Γ] : nat → (canonical Γ).W → Prop :=
  λ n, λ xΓ : (canonical Γ).W, (p n) ∈ xΓ.val

lemma existence (Γ : ctx) (hax : sem_cons Γ) (xΓ : (canonical Γ).W) :
  ∀ A, ◇A ∈ xΓ.val ↔ ∃ yΔ : (canonical Γ).W, A ∈ yΔ.val ∧ (canonical Γ).R xΓ yΔ :=
begin
intro A, split,
intro h1,
let Γbox : ctx := {B : form | □B ∈ xΓ.val},
have h1 : ax_consist Γ (Γbox ∪ {A}),
{by_contradiction h2, simp at h2,
have h3 := five Γ Γbox A h2,
cases h3 with L h3, cases h3 with h3 h4,
have h5 := cut fin_conj_boxn (mp kdist (nec h4)),
have h6 := mini_cons,
have h7 : ∀ B ∈ (list.map □ L), B ∈ xΓ.1,
intros B h8, simp at *, cases h8 with a h8,
cases h8 with h8l h8r,
subst h8r, exact h3 a h8l,
specialize h6 xΓ.2 h7 h5,
have h8 := (six Γ xΓ.1 (max_imp_ax xΓ.2)).mp xΓ.2 (¬A).box,
cases h8 with h8l h8r, simp at *,
exact absurd h1 (h8r h6)
},
have h2 := lindenbaum Γ (Γbox ∪ {A}) h1,
cases h2 with Δ h2, cases h2 with h2 h3,
let xΔ : (canonical Γ).W := ⟨Δ, h2⟩,
existsi (xΔ : (canonical Γ).W),
have h5 := set.union_subset_iff.mp h3,
cases h5, split, simp at h5_right, exact h5_right,
have h3 : ∀ A : form, □A ∈ xΓ.val → A ∈ xΔ.val,
intros B h4, apply h5_left, exact h4,
exact h3,
simp at *,
intros yΔ h1 h2,
by_contradiction h3,
have h4 := (max_notiff Γ xΓ.1 xΓ.2 (◇A)).mp h3,
have h5 := (max_dn Γ xΓ.1 xΓ.2 (□¬A)).mpr h4,
have h6 := (max_notiff Γ yΔ.1 yΔ.2 A).mpr (h2 (¬A) h5),
exact absurd h1 h6
end

lemma truth (Γ : ctx) (hax : sem_cons Γ) (xΓ : (canonical Γ).W) :
  ∀ A, true_at_world (canonical Γ) (val_canonical Γ) xΓ A ↔ (A ∈ xΓ.val) :=
begin
intro A, induction A with n A B ih_A ih_B
A B ih_A ih_B A ih_A generalizing xΓ,
split, intro h1, exact false.elim h1,
intro h1,
have h2 := xΓ.2,
cases h2,
specialize h2_left [⊥],
simp at *,
exact absurd not_contra (h2_left h1),
repeat {rw true_at_world, rw val_canonical},
split, intro h1, cases h1 with h1 h2,
exact max_conj_1 xΓ.2 (and.intro ((ih_A xΓ).mp h1) ((ih_B xΓ).mp h2)),
intro h1, split,
apply (ih_A xΓ).mpr, exact max_conj_2 xΓ.2 h1,
apply (ih_B xΓ).mpr, exact max_conj_3 xΓ.2 h1,
split,
intro h1,
apply max_imp_1 xΓ.2,
intro h2,
exact (ih_B xΓ).mp (h1 ((ih_A xΓ).mpr h2)),
intros h1 h2,
apply (ih_B xΓ).mpr,
exact max_imp_2 xΓ.2 h1 ((ih_A xΓ).mp h2),
split, intros h1,
by_contradiction h2,
have h4 := (existence Γ hax xΓ (¬A)).mp,
have h5 := max_boxdn Γ xΓ.1 xΓ.2 A ((max_notiff Γ xΓ.1 xΓ.2 A.box).mp h2),
cases h4 h5 with xΔ h4, cases h4 with h4 h6,
have h7 := max_notiff Γ xΔ.1 xΔ.2 A,
cases h7 with h7l h7r,
exact absurd ((ih_A xΔ).mp (h1 xΔ h6)) (h7r h4),
intros h1 xΔ h2,
apply (ih_A xΔ).mpr, exact h2 A h1,
end

lemma comphelper (Γ : ctx) (A : form) (hax : sem_cons Γ) :
  ¬  Kproof Γ A → ax_consist Γ {¬A} :=
begin
intro h1, intros L h2,
rw fin_ax_consist, induction L,
by_contradiction h3,
exact absurd (mp dne h3) (nprfalse Γ hax),
have h4 : (∀ B ∈ L_hd::L_tl, B = ¬A) →  Kproof Γ (¬fin_conj (L_hd::L_tl)) →  Kproof Γ A,
from fin_conj_repeat hax,
simp at *,
cases h2 with h2 h3,
intro h6, apply h1, apply h4 h2,
exact h3,
exact h6
end

theorem forcesΓ (Γ : ctx) (hax : sem_cons Γ) :
  ctx_true_in_model (canonical Γ) (val_canonical Γ) Γ :=
begin
intros A xΓ h1,
have h2 : ∀ B ∈ list.nil, B ∈ xΓ.val,
{intros B h3, have h4 := list.ne_nil_of_length_pos (list.length_pos_of_mem h3),
simp at *, exact false.elim h4},
exact (truth Γ hax xΓ A).mpr (mini_cons xΓ.2 h2 (mp pl1 (ax h1)))
end

theorem completeness (Γ : ctx) (hax : sem_cons Γ) (A : form) :
  entails Γ A →  Kproof Γ A :=
begin
rw ←not_imp_not,
intro h1,
have h2 := comphelper Γ A hax h1,
have h3 := lindenbaum Γ {¬A} h2,
simp at *,
cases h3 with Γ' h3, cases h3 with h3 h4,
rw entails,
push_neg,
let f := canonical, use f Γ,
let v := val_canonical, use v Γ,
let xΓ' : (f Γ).W := ⟨Γ', h3⟩,
split,
exact forcesΓ Γ hax,
use xΓ',
have h5 := truth Γ hax xΓ' ¬A,
cases h5 with h5 h6,
have h7 := not_forces_imp (f Γ) (v Γ) xΓ' A,
cases h7 with h7 h8, apply h8, apply h6, exact h4
end

end canonical


import data.real.cau_seq
import ring_theory.unique_factorization_domain

open is_absolute_value
open_locale classical

theorem ext_hom_primes {α} [comm_monoid_with_zero α] [wf_dvd_monoid α]
  {β} [monoid_with_zero β]
  (φ₁ φ₂: monoid_with_zero_hom α β)
  (h_units: ∀ u: units α, φ₁ u = φ₂ u)
  (h_irreducibles: ∀ a: α, irreducible a → φ₁ a = φ₂ a):
    φ₁ = φ₂ :=
begin
  ext x,
  exact wf_dvd_monoid.induction_on_irreducible x
    (by rw [φ₁.map_zero, φ₂.map_zero])
    (by { rintros _ ⟨ u, rfl ⟩, exact h_units u, })
    (by {
      intros a i ha hi hφa,
      simp only [monoid_with_zero_hom.map_mul, monoid_with_zero_hom.to_fun_eq_coe],
      rw h_irreducibles i hi,
      rw hφa,
    }),
end


import tactic
import .direction
import .list2d
import .boolset2d
import .listdec

structure sokostate :=
(boxes : bset2d)
(storekeeper : ℕ × ℕ)

def sokostate.move (avail : bset2d) (d : direction) (s : sokostate)
  : sokostate :=
  let sk2 := d.shift s.storekeeper in
  if (sk2 ∉ avail) then s else
  if (sk2 ∉ s.boxes) then {
    boxes := s.boxes,
    storekeeper := sk2,
  }
  else
    let box2 := (d.shift sk2) in
    if box2 ∉ avail ∨ box2 ∈ s.boxes then s else {
      boxes := (s.boxes.remove sk2).add box2,
      storekeeper := sk2,
    }

structure sokostate.valid (avail : bset2d) (s : sokostate) : Prop :=
(boxes_avail : s.boxes ⊆ avail)
(sk_avail : s.storekeeper ∈ avail)
(sk_not_box : s.storekeeper ∉ s.boxes)

instance {avail : bset2d} {s : sokostate} : decidable (s.valid avail)
  :=
if Hb : s.boxes ⊆ avail then
  if Hska : s.storekeeper ∈ avail then
    if Hskb : s.storekeeper ∉ s.boxes then
      is_true ⟨Hb, Hska, Hskb⟩
    else is_false (λ H, Hskb H.sk_not_box)
  else is_false (λ H, Hska H.sk_avail)
else is_false (λ H, Hb H.boxes_avail)

inductive sokostate.reachable (avail : bset2d) (s2 : sokostate) : sokostate → Prop
| triv : sokostate.reachable s2
| move {s1 : sokostate} (d : direction) (H : sokostate.reachable (sokostate.move avail d s1))
  : sokostate.reachable s1

theorem sokostate.move_keep_valid {avail : bset2d} {s : sokostate} {d : direction}
  : s.valid avail → (s.move avail d).valid avail  :=
begin
  intro Hv,
  unfold sokostate.move, generalize E : d.shift s.storekeeper = sk2,
  by_cases Cska : sk2 ∈ avail, simp [Cska],
  by_cases Cskb: sk2 ∈ s.boxes, simp [Cskb],
  by_cases Cba : d.shift sk2 ∈ avail, simp [Cba],
  by_cases Cbb : d.shift sk2 ∈ s.boxes, simp [Cbb], exact Hv,
  { simp [Cbb], -- pushing a box
    split, simp, assume xy H,
    cases bset2d.of_mem_add H with Heq Hin,
    { rw Heq, exact Cba, },
    { exact Hv.boxes_avail xy (bset2d.mem_of_mem_remove Hin), },
    exact Cska,
    simp, apply bset2d.nmem_add_of_neq_nmem,
    { assume Heq, rw Heq at Cskb, exact Cbb Cskb, },
    { exact bset2d.nmem_remove, },
  }, { -- invalid push
    simp [Cba], exact Hv,
  }, { -- move a storekeeper
    simp [Cskb], split, exact Hv.boxes_avail,
    exact Cska,
    exact Cskb,
  }, { -- invalid move (to a wall)
    simp [Cska], exact Hv
  }
end

theorem sokostate.move_keep_box_count {avail : bset2d} {s : sokostate} {d : direction}
  : (s.move avail d).boxes.count = s.boxes.count
 :=
begin
  unfold sokostate.move, generalize E : d.shift s.storekeeper = sk2,
  by_cases Cska : sk2 ∈ avail, simp [Cska],
  by_cases Cskb: sk2 ∈ s.boxes, simp [Cskb],
  by_cases Cba : d.shift sk2 ∈ avail, simp [Cba],
  by_cases Cbb : d.shift sk2 ∈ s.boxes, simp [Cbb], {
    simp [Cbb],
    rw bset2d.count_add (bset2d.nmem_remove_of_nmem Cbb),
    exact bset2d.count_remove Cskb,
  },
  { simp [Cba]}, { simp [Cskb] }, { simp [Cska] },
end

theorem sokostate.reachable_keep_box_count {avail : bset2d} {s2 s : sokostate}
: reachable avail s2 s → s2.boxes.count = s.boxes.count
:=
begin
  assume H, induction H with s1 d H IH, refl,
  rw IH, exact sokostate.move_keep_box_count,
end

structure boxes_only :=
(boxes : bset2d)

def boxes_only.mem (s : sokostate) (bs : boxes_only)
  := s.boxes ⊆ bs.boxes ∧ bs.boxes ⊆ s.boxes
instance : has_mem sokostate boxes_only := ⟨boxes_only.mem⟩
lemma boxes_only.mem.unfold {s : sokostate} {bs : boxes_only}
  : s ∈ bs = (s.boxes ⊆ bs.boxes ∧ bs.boxes ⊆ s.boxes) := rfl

instance boxes_only.mem.decidable
  (s : sokostate) (bs : boxes_only) : decidable (s ∈ bs)
:= begin
  unfold has_mem.mem, unfold boxes_only.mem, apply_instance,
end


import tactic
import .stlc

def type_check : context -> tm -> option ty
| gamma (tm.var x) := gamma x
| gamma (tm.abs x T t) := do
  T' <- type_check (partial_map.update x T gamma) t,
  return (ty.arrow T T')
| gamma (tm.app t₁ t₂) := do
  (ty.arrow T T') <- type_check gamma t₁ | failure,
  T₂ <- type_check gamma t₂,
  if T = T₂ then return T' else failure
| _ (tm.const _) := return ty.nat
| gamma (tm.prd t) := do
  ty.nat <- type_check gamma t | failure,
  return ty.nat
| gamma (tm.scc t) := do
  ty.nat <- type_check gamma t | failure,
  return ty.nat
| gamma (tm.mlt t₁ t₂) := do
  ty.nat <- type_check gamma t₁ | failure,
  ty.nat <- type_check gamma t₂ | failure,
  return ty.nat
| gamma (tm.iszro t) := do
  ty.nat <- type_check gamma t | failure,
  return ty.bool
| _ tm.tru := return ty.bool
| _ tm.fls := return ty.bool
| gamma (tm.tst t t₁ t₂) := do
  ty.bool <- type_check gamma t | failure,
  T <- type_check gamma t₁,
  T' <- type_check gamma t₂,
  if T = T' then return T else failure
| gamma (tm.let_ x t₁ t₂) := do
  T₁ <- type_check gamma t₁,
  T₂ <- type_check (partial_map.update x T₁ gamma) t₂,
  return T₂
| gamma (tm.pair t₁ t₂) := do
  T₁ <- type_check gamma t₁,
  T₂ <- type_check gamma t₂,
  return (ty.prod T₁ T₂)
| gamma (tm.fst t) := do
  (ty.prod T₁ _) <- type_check gamma t | failure,
  return T₁
| gamma (tm.snd t) := do
  (ty.prod _ T₂) <- type_check gamma t | failure,
  return T₂
| _ tm.unit := return ty.unit
| gamma (tm.inl T₂ t) := do
  T₁ <- type_check gamma t,
  return (ty.sum T₁ T₂)
| gamma (tm.inr T₁ t) := do
  T₂ <- type_check gamma t,
  return (ty.sum T₁ T₂)
| gamma (tm.scase t x t₁ y t₂) := do
  (ty.sum T₁ T₂) <- type_check gamma t | failure,
  T <- type_check (partial_map.update x T₁ gamma) t₁,
  T' <- type_check (partial_map.update y T₂ gamma) t₂,
  if T = T' then return T else failure
| _ (tm.nil T) := return (ty.list T)
| gamma (tm.cons t₁ t₂) := do
  T <- type_check gamma t₁,
  (ty.list T') <- type_check gamma t₂ | failure,
  if T = T' then return (ty.list T) else failure
| gamma (tm.lcase t t₁ y z t₂) := do
  (ty.list T) <- type_check gamma t | failure,
  T' <- type_check gamma t₁,
  T'' <- type_check (partial_map.update z (ty.list T) $
                     partial_map.update y T gamma)
                    t₂,
  if T' = T'' then return T' else failure
| gamma (tm.fix t) := do
  (ty.arrow T T') <- type_check gamma t | failure,
  if T = T' then return T else failure

theorem type_checking_sound {t} :
  ∀{gamma T}, type_check gamma t = some T -> has_type gamma t T :=
begin
  induction t,
    repeat { intros _ _ h, simp [type_check, return, pure] at h },
    case tm.var: { apply has_type.t_var, assumption },
    case tm.abs: _ _ _ ih {
      rcases h with ⟨_, h', h''⟩,
      rewrite <-h'',
      exact has_type.t_abs (ih h'),
    },
    case tm.app: t₁ t₂ ih₁ ih₂ {
      rcases h with ⟨T', h', h''⟩,
      cases e₁ : type_check gamma t₁,
        { cases eq.trans (symm e₁) h', },
        { cases e₂ : type_check gamma t₂,
            case option.none: { cases T'; rewrite e₂ at h''; cases h'' },
            case option.some: {
              cases T',
                case ty.arrow: T₁' T₂ {
                  simp [type_check, return, pure] at h'',
                  rcases h'' with ⟨T₁, he₂, he₂'⟩,
                  by_cases ht : T₁' = T₁,
                    { simp [ht] at he₂',
                      rewrite <-he₂',
                      rewrite <-ht at he₂,
                      exact has_type.t_app (ih₁ h') (ih₂ he₂) },
                    { simp [ht] at he₂', cases he₂' },
                },
                repeat { cases h'' },
            } },
    },
    case tm.const: { rewrite <-h, exact has_type.t_const },
    case tm.prd: _ ih {
      rcases h with ⟨T', h', h''⟩,
      cases T',
        case ty.nat: {
          simp [type_check, return, pure] at h'',
          rewrite <-h'',
          exact has_type.t_prd (ih h'),
        },
        repeat { cases h'' },
    },
    case tm.scc: _ ih {
      rcases h with ⟨T', h', h''⟩,
      cases T',
        case ty.nat: {
          simp [type_check, return, pure] at h'',
          rewrite <-h'',
          exact has_type.t_scc (ih h'),
        },
        repeat { cases h'' },
    },
    case tm.mlt: t₁ t₂ ih₁ ih₂ {
      rcases h with ⟨T₁, h', h''⟩,
      cases e₁ : type_check gamma t₁,
        { cases eq.trans (symm e₁) h', },
        { cases e₂ : type_check gamma t₂,
          case option.none: { cases T₁; rewrite e₂ at h''; cases h'' },
          case option.some: {
            cases T₁,
            case ty.nat: {
              simp [type_check, return, pure] at h'',
              rcases h'' with ⟨T₂, he₂, he₂'⟩,
              cases T₂,
                case ty.nat: {
                  simp [type_check, return, pure] at he₂',
                  rewrite <-he₂',
                  exact has_type.t_mlt (ih₁ h') (ih₂ he₂),
                },
                repeat { cases he₂' },
            },
            repeat { cases h'' },
          } },
    },
    case tm.iszro: _ ih {
      rcases h with ⟨T', h', h''⟩,
      cases T',
        case ty.nat: {
          simp [type_check, return, pure] at h'',
          rewrite <-h'',
          exact has_type.t_iszro (ih h'),
        },
        repeat { cases h'' },
    },
    case tm.tru: { rewrite <-h, exact has_type.t_tru },
    case tm.fls: { rewrite <-h, exact has_type.t_fls },
    case tm.tst: t t₁ t₂ ih ih₁ ih₂ {
      rcases h with ⟨T, h', h''⟩,
      cases T,
        case ty.bool: {
          simp [type_check, return, pure] at h'',
          rcases h'' with ⟨T₁, h₁, T₂, h₂, ht⟩,
          by_cases ht' : T₁ = T₂,
            { simp [ht'] at ht,
              rewrite <-ht,
              rewrite ht' at h₁,
              exact has_type.t_tst (ih h') (ih₁ h₁) (ih₂ h₂) },
            { simp [ht'] at ht, cases ht },
        },
        repeat { cases h'' },
    },
    case tm.let_: _ _ _ ih₁ ih₂ {
      rcases h with ⟨_, h', h''⟩,
      exact has_type.t_let (ih₁ h') (ih₂ h''),
    },
    case tm.pair: _ _ ih₁ ih₂ {
      rcases h with ⟨_, h₁, _, h₂, h''⟩,
      rewrite <-h'',
      exact has_type.t_pair (ih₁ h₁) (ih₂ h₂),
    },
    case tm.fst: _ ih {
      rcases h with ⟨T', h', h''⟩,
      cases T',
        case ty.prod: T₁ T₂ {
          simp [type_check, return, pure] at h'',
          rewrite <-h'',
          exact has_type.t_fst (ih h'),
        },
        repeat { cases h'' },
    },
    case tm.snd: _ ih {
      rcases h with ⟨T', h', h''⟩,
        cases T',
          case ty.prod: T₁ T₂ {
            simp [type_check, return, pure] at h'',
            rewrite <-h'',
            exact has_type.t_snd (ih h'),
          },
          repeat { cases h'' },
    },
    case tm.unit: { rewrite <-h, exact has_type.t_unit },
    case tm.inl: _ _ ih {
      rcases h with ⟨_, h', h''⟩,
      rewrite <-h'',
      exact has_type.t_inl (ih h'),
    },
    case tm.inr: _ _ ih {
      rcases h with ⟨_, h', h''⟩,
      rewrite <-h'',
      exact has_type.t_inr (ih h'),
    },
    case tm.scase: _ _ _ _ _ ih ih₁ ih₂ {
      rcases h with ⟨T, h, h'⟩,
      cases T,
        case ty.sum: T₁ T₂ {
          simp [type_check] at h',
          rcases h' with ⟨T₁, h₁, T₂, h₂, h''⟩,
          by_cases ht : T₁ = T₂,
            { simp [ht, return, pure] at h'',
              rewrite ht at h₁,
              rewrite h'' at h₁ h₂,
              exact has_type.t_scase (ih h) (ih₁ h₁) (ih₂ h₂) },
            { simp [ht] at h'', cases h'' },
        },
        repeat { cases h' },
    },
    case tm.nil: { rewrite <-h, exact has_type.t_nil },
    case tm.cons: _ _ ih₁ ih₂ {
      rcases h with ⟨T₁, h₁, T₂, h₂, h'⟩,
      cases T₂,
        case ty.list: T₁' {
          simp [type_check, return, pure] at h',
          by_cases ht : T₁ = T₁',
            { simp [ht] at h',
              rewrite <-h',
              rewrite ht at h₁,
              exact has_type.t_cons (ih₁ h₁) (ih₂ h₂) },
            { simp [ht] at h', cases h' },
        },
        repeat { cases h' },
    },
    case tm.lcase: _ _ _ _ _ ih ih₁ ih₂ {
      rcases h with ⟨T, h, h'⟩,
      cases T,
        case ty.list: T' {
          simp [type_check, return, pure] at h',
          rcases h' with ⟨T₁, h₁, T₂, h₂, h''⟩,
          by_cases ht : T₁ = T₂,
            { simp [ht] at h'',
              rewrite ht at h₁,
              rewrite <-h'',
              exact has_type.t_lcase (ih h) (ih₁ h₁) (ih₂ h₂) },
            { simp [ht] at h'', cases h'' },
        },
        repeat { cases h' },
    },
    case tm.fix: _ ih {
      rcases h with ⟨T', h', h''⟩,
      cases T',
        case ty.arrow: T₁ T₂ {
          simp [type_check, return, pure] at h'',
          by_cases ht : T₁ = T₂,
            { simp [ht] at h'',
              rewrite ht at h',
              rewrite <-h'',
              exact has_type.t_fix (ih h') },
            { simp [ht] at h'', cases h'' },
        },
        repeat { cases h'' },
    },
end

theorem type_checking_complete {gamma t T} (ht : has_type gamma t T) :
  type_check gamma t = some T :=
by { induction ht; simp [*, type_check, return, pure] }


/-
Copyright (c) 2017 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura

! This file was ported from Lean 3 source module init.data.bool.lemmas
! leanprover-community/mathlib commit 9af482290ef68e8aaa5ead01aa7b09b7be7019fd
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
prelude
import Leanbin.Init.Data.Bool.Basic
import Leanbin.Init.Meta.Default

attribute [simp] cond or and not xor

#print Bool.cond_self /-
@[simp]
theorem Bool.cond_self.{u} {α : Type u} (b : Bool) (a : α) : cond b a a = a := by cases b <;> simp
#align cond_a_a Bool.cond_self
-/

#print Bool.and_self /-
@[simp]
theorem Bool.and_self (b : Bool) : (b && b) = b := by cases b <;> simp
#align band_self Bool.and_self
-/

#print Bool.and_true /-
@[simp]
theorem Bool.and_true (b : Bool) : (b && true) = b := by cases b <;> simp
#align band_tt Bool.and_true
-/

#print Bool.and_false /-
@[simp]
theorem Bool.and_false (b : Bool) : (b && false) = false := by cases b <;> simp
#align band_ff Bool.and_false
-/

#print Bool.true_and /-
@[simp]
theorem Bool.true_and (b : Bool) : (true && b) = b := by cases b <;> simp
#align tt_band Bool.true_and
-/

#print Bool.false_and /-
@[simp]
theorem Bool.false_and (b : Bool) : (false && b) = false := by cases b <;> simp
#align ff_band Bool.false_and
-/

#print Bool.or_self /-
@[simp]
theorem Bool.or_self (b : Bool) : (b || b) = b := by cases b <;> simp
#align bor_self Bool.or_self
-/

#print Bool.or_true /-
@[simp]
theorem Bool.or_true (b : Bool) : (b || true) = true := by cases b <;> simp
#align bor_tt Bool.or_true
-/

#print Bool.or_false /-
@[simp]
theorem Bool.or_false (b : Bool) : (b || false) = b := by cases b <;> simp
#align bor_ff Bool.or_false
-/

#print Bool.true_or /-
@[simp]
theorem Bool.true_or (b : Bool) : (true || b) = true := by cases b <;> simp
#align tt_bor Bool.true_or
-/

#print Bool.false_or /-
@[simp]
theorem Bool.false_or (b : Bool) : (false || b) = b := by cases b <;> simp
#align ff_bor Bool.false_or
-/

#print Bool.xor_self /-
@[simp]
theorem Bool.xor_self (b : Bool) : xor b b = false := by cases b <;> simp
#align bxor_self Bool.xor_self
-/

#print Bool.xor_true /-
@[simp]
theorem Bool.xor_true (b : Bool) : xor b true = not b := by cases b <;> simp
#align bxor_tt Bool.xor_true
-/

#print Bool.xor_false /-
theorem Bool.xor_false (b : Bool) : xor b false = b := by cases b <;> simp
#align bxor_ff Bool.xor_false
-/

#print Bool.true_xor /-
@[simp]
theorem Bool.true_xor (b : Bool) : xor true b = not b := by cases b <;> simp
#align tt_bxor Bool.true_xor
-/

#print Bool.false_xor /-
theorem Bool.false_xor (b : Bool) : xor false b = b := by cases b <;> simp
#align ff_bxor Bool.false_xor
-/

#print Bool.not_not /-
@[simp]
theorem Bool.not_not (b : Bool) : not (not b) = b := by cases b <;> simp
#align bnot_bnot Bool.not_not
-/

#print Bool.true_eq_false_eq_False /-
theorem Bool.true_eq_false_eq_False : ¬true = false := by contradiction
#align tt_eq_ff_eq_false Bool.true_eq_false_eq_False
-/

#print Bool.false_eq_true_eq_False /-
theorem Bool.false_eq_true_eq_False : ¬false = true := by contradiction
#align ff_eq_tt_eq_false Bool.false_eq_true_eq_False
-/

#print Bool.eq_false_eq_not_eq_true /-
@[simp]
theorem Bool.eq_false_eq_not_eq_true (b : Bool) : (¬b = true) = (b = false) := by cases b <;> simp
#align eq_ff_eq_not_eq_tt Bool.eq_false_eq_not_eq_true
-/

@[simp]
theorem eq_true_eq_not_eq_false (b : Bool) : (¬b = false) = (b = true) := by cases b <;> simp
#align eq_tt_eq_not_eq_ff eq_true_eq_not_eq_false

#print Bool.eq_false_of_not_eq_true /-
theorem Bool.eq_false_of_not_eq_true {b : Bool} : ¬b = true → b = false :=
  Eq.mp (Bool.eq_false_eq_not_eq_true b)
#align eq_ff_of_not_eq_tt Bool.eq_false_of_not_eq_true
-/

#print Bool.eq_true_of_not_eq_false /-
theorem Bool.eq_true_of_not_eq_false {b : Bool} : ¬b = false → b = true :=
  Eq.mp (eq_true_eq_not_eq_false b)
#align eq_tt_of_not_eq_ff Bool.eq_true_of_not_eq_false
-/

#print Bool.and_eq_true_eq_eq_true_and_eq_true /-
@[simp]
theorem Bool.and_eq_true_eq_eq_true_and_eq_true (a b : Bool) :
    ((a && b) = true) = (a = true ∧ b = true) := by cases a <;> cases b <;> simp
#align band_eq_true_eq_eq_tt_and_eq_tt Bool.and_eq_true_eq_eq_true_and_eq_true
-/

#print Bool.or_eq_true_eq_eq_true_or_eq_true /-
@[simp]
theorem Bool.or_eq_true_eq_eq_true_or_eq_true (a b : Bool) :
    ((a || b) = true) = (a = true ∨ b = true) := by cases a <;> cases b <;> simp
#align bor_eq_true_eq_eq_tt_or_eq_tt Bool.or_eq_true_eq_eq_true_or_eq_true
-/

#print Bool.not_eq_true_eq_eq_false /-
@[simp]
theorem Bool.not_eq_true_eq_eq_false (a : Bool) : (not a = true) = (a = false) := by
  cases a <;> simp
#align bnot_eq_true_eq_eq_ff Bool.not_eq_true_eq_eq_false
-/

#print Bool.and_eq_false_eq_eq_false_or_eq_false /-
@[simp]
theorem Bool.and_eq_false_eq_eq_false_or_eq_false (a b : Bool) :
    ((a && b) = false) = (a = false ∨ b = false) := by cases a <;> cases b <;> simp
#align band_eq_false_eq_eq_ff_or_eq_ff Bool.and_eq_false_eq_eq_false_or_eq_false
-/

#print Bool.or_eq_false_eq_eq_false_and_eq_false /-
@[simp]
theorem Bool.or_eq_false_eq_eq_false_and_eq_false (a b : Bool) :
    ((a || b) = false) = (a = false ∧ b = false) := by cases a <;> cases b <;> simp
#align bor_eq_false_eq_eq_ff_and_eq_ff Bool.or_eq_false_eq_eq_false_and_eq_false
-/

#print Bool.not_eq_false_eq_eq_true /-
@[simp]
theorem Bool.not_eq_false_eq_eq_true (a : Bool) : (not a = false) = (a = true) := by
  cases a <;> simp
#align bnot_eq_ff_eq_eq_tt Bool.not_eq_false_eq_eq_true
-/

#print Bool.coe_false /-
@[simp]
theorem Bool.coe_false : ↑false = False :=
  show (false = true) = False by simp
#align coe_ff Bool.coe_false
-/

#print Bool.coe_true /-
@[simp]
theorem Bool.coe_true : ↑true = True :=
  show (true = true) = True by simp
#align coe_tt Bool.coe_true
-/

#print Bool.coe_sort_false /-
@[simp]
theorem Bool.coe_sort_false : ↥false = False :=
  show (false = true) = False by simp
#align coe_sort_ff Bool.coe_sort_false
-/

#print Bool.coe_sort_true /-
@[simp]
theorem Bool.coe_sort_true : ↥true = True :=
  show (true = true) = True by simp
#align coe_sort_tt Bool.coe_sort_true
-/

#print Bool.decide_iff /-
@[simp]
theorem Bool.decide_iff (p : Prop) [d : Decidable p] : decide p = true ↔ p :=
  match d with
  | is_true hp => ⟨fun h => hp, fun _ => rfl⟩
  | is_false hnp => ⟨fun h => Bool.noConfusion h, fun hp => absurd hp hnp⟩
#align to_bool_iff Bool.decide_iff
-/

#print Bool.decide_true /-
theorem Bool.decide_true {p : Prop} [Decidable p] : p → decide p :=
  (Bool.decide_iff p).2
#align to_bool_true Bool.decide_true
-/

/- warning: to_bool_tt clashes with to_bool_true -> Bool.decide_true
Case conversion may be inaccurate. Consider using '#align to_bool_tt Bool.decide_trueₓ'. -/
#print Bool.decide_true /-
theorem Bool.decide_true {p : Prop} [Decidable p] : p → decide p = true :=
  Bool.decide_true
#align to_bool_tt Bool.decide_true
-/

#print Bool.of_decide_true /-
theorem Bool.of_decide_true {p : Prop} [Decidable p] : decide p → p :=
  (Bool.decide_iff p).1
#align of_to_bool_true Bool.of_decide_true
-/

#print Bool.bool_iff_false /-
theorem Bool.bool_iff_false {b : Bool} : ¬b ↔ b = false := by cases b <;> exact by decide
#align bool_iff_false Bool.bool_iff_false
-/

#print Bool.bool_eq_false /-
theorem Bool.bool_eq_false {b : Bool} : ¬b → b = false :=
  Bool.bool_iff_false.1
#align bool_eq_false Bool.bool_eq_false
-/

#print Bool.decide_false_iff /-
@[simp]
theorem Bool.decide_false_iff (p : Prop) [Decidable p] : decide p = false ↔ ¬p :=
  Bool.bool_iff_false.symm.trans (not_congr (Bool.decide_iff _))
#align to_bool_ff_iff Bool.decide_false_iff
-/

#print Bool.decide_false /-
theorem Bool.decide_false {p : Prop} [Decidable p] : ¬p → decide p = false :=
  (Bool.decide_false_iff p).2
#align to_bool_ff Bool.decide_false
-/

#print Bool.of_decide_false /-
theorem Bool.of_decide_false {p : Prop} [Decidable p] : decide p = false → ¬p :=
  (Bool.decide_false_iff p).1
#align of_to_bool_ff Bool.of_decide_false
-/

#print Bool.decide_congr /-
theorem Bool.decide_congr {p q : Prop} [Decidable p] [Decidable q] (h : p ↔ q) :
    decide p = decide q := by
  induction' h' : to_bool q with
  exact Bool.decide_false (mt h.1 <| Bool.of_decide_false h')
  exact Bool.decide_true (h.2 <| Bool.of_decide_true h')
#align to_bool_congr Bool.decide_congr
-/

#print Bool.or_coe_iff /-
@[simp]
theorem Bool.or_coe_iff (a b : Bool) : a || b ↔ a ∨ b := by cases a <;> cases b <;> exact by decide
#align bor_coe_iff Bool.or_coe_iff
-/

#print Bool.and_coe_iff /-
@[simp]
theorem Bool.and_coe_iff (a b : Bool) : a && b ↔ a ∧ b := by cases a <;> cases b <;> exact by decide
#align band_coe_iff Bool.and_coe_iff
-/

#print Bool.xor_coe_iff /-
@[simp]
theorem Bool.xor_coe_iff (a b : Bool) : xor a b ↔ Xor' a b := by
  cases a <;> cases b <;> exact by decide
#align bxor_coe_iff Bool.xor_coe_iff
-/

#print Bool.ite_eq_true_distrib /-
@[simp]
theorem Bool.ite_eq_true_distrib (c : Prop) [Decidable c] (a b : Bool) :
    ((if c then a else b) = true) = if c then a = true else b = true := by by_cases c <;> simp [*]
#align ite_eq_tt_distrib Bool.ite_eq_true_distrib
-/

#print Bool.ite_eq_false_distrib /-
@[simp]
theorem Bool.ite_eq_false_distrib (c : Prop) [Decidable c] (a b : Bool) :
    ((if c then a else b) = false) = if c then a = false else b = false := by
  by_cases c <;> simp [*]
#align ite_eq_ff_distrib Bool.ite_eq_false_distrib
-/


/-
Copyright (c) 2018 Reid Barton. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Reid Barton, Scott Morrison
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.category_theory.opposites
import Mathlib.PostPort

universes u₁ v₁ v₂ u₂

namespace Mathlib

namespace category_theory

/--
An equality `X = Y` gives us a morphism `X ⟶ Y`.

It is typically better to use this, rather than rewriting by the equality then using `𝟙 _`
which usually leads to dependent type theory hell.
-/
def eq_to_hom {C : Type u₁} [category C] {X : C} {Y : C} (p : X = Y) : X ⟶ Y := eq.mpr sorry 𝟙

@[simp] theorem eq_to_hom_refl {C : Type u₁} [category C] (X : C) (p : X = X) : eq_to_hom p = 𝟙 :=
  rfl

@[simp] theorem eq_to_hom_trans {C : Type u₁} [category C] {X : C} {Y : C} {Z : C} (p : X = Y)
    (q : Y = Z) : eq_to_hom p ≫ eq_to_hom q = eq_to_hom (Eq.trans p q) :=
  sorry

/--
An equality `X = Y` gives us a morphism `X ⟶ Y`.

It is typically better to use this, rather than rewriting by the equality then using `iso.refl _`
which usually leads to dependent type theory hell.
-/
def eq_to_iso {C : Type u₁} [category C] {X : C} {Y : C} (p : X = Y) : X ≅ Y :=
  iso.mk (eq_to_hom p) (eq_to_hom (Eq.symm p))

@[simp] theorem eq_to_iso.hom {C : Type u₁} [category C] {X : C} {Y : C} (p : X = Y) :
    iso.hom (eq_to_iso p) = eq_to_hom p :=
  rfl

@[simp] theorem eq_to_iso.inv {C : Type u₁} [category C] {X : C} {Y : C} (p : X = Y) :
    iso.inv (eq_to_iso p) = eq_to_hom (Eq.symm p) :=
  rfl

@[simp] theorem eq_to_iso_refl {C : Type u₁} [category C] {X : C} (p : X = X) :
    eq_to_iso p = iso.refl X :=
  rfl

@[simp] theorem eq_to_iso_trans {C : Type u₁} [category C] {X : C} {Y : C} {Z : C} (p : X = Y)
    (q : Y = Z) : eq_to_iso p ≪≫ eq_to_iso q = eq_to_iso (Eq.trans p q) :=
  sorry

@[simp] theorem eq_to_hom_op {C : Type u₁} [category C] {X : C} {Y : C} (h : X = Y) :
    has_hom.hom.op (eq_to_hom h) = eq_to_hom (congr_arg opposite.op (Eq.symm h)) :=
  sorry

@[simp] theorem eq_to_hom_unop {C : Type u₁} [category C] {X : Cᵒᵖ} {Y : Cᵒᵖ} (h : X = Y) :
    has_hom.hom.unop (eq_to_hom h) = eq_to_hom (congr_arg opposite.unop (Eq.symm h)) :=
  sorry

protected instance eq_to_hom.is_iso {C : Type u₁} [category C] {X : C} {Y : C} (h : X = Y) :
    is_iso (eq_to_hom h) :=
  is_iso.mk (iso.inv (eq_to_iso h))

@[simp] theorem inv_eq_to_hom {C : Type u₁} [category C] {X : C} {Y : C} (h : X = Y) :
    inv (eq_to_hom h) = eq_to_hom (Eq.symm h) :=
  rfl

namespace functor

/-- Proving equality between functors. This isn't an extensionality lemma,
  because usually you don't really want to do this. -/
theorem ext {C : Type u₁} [category C] {D : Type u₂} [category D] {F : C ⥤ D} {G : C ⥤ D}
    (h_obj : ∀ (X : C), obj F X = obj G X)
    (h_map :
      ∀ (X Y : C) (f : X ⟶ Y),
        map F f = eq_to_hom (h_obj X) ≫ map G f ≫ eq_to_hom (Eq.symm (h_obj Y))) :
    F = G :=
  sorry

/-- Proving equality between functors using heterogeneous equality. -/
theorem hext {C : Type u₁} [category C] {D : Type u₂} [category D] {F : C ⥤ D} {G : C ⥤ D}
    (h_obj : ∀ (X : C), obj F X = obj G X) (h_map : ∀ (X Y : C) (f : X ⟶ Y), map F f == map G f) :
    F = G :=
  sorry

-- Using equalities between functors.

theorem congr_obj {C : Type u₁} [category C] {D : Type u₂} [category D] {F : C ⥤ D} {G : C ⥤ D}
    (h : F = G) (X : C) : obj F X = obj G X :=
  Eq._oldrec (Eq.refl (obj F X)) h

theorem congr_hom {C : Type u₁} [category C] {D : Type u₂} [category D] {F : C ⥤ D} {G : C ⥤ D}
    (h : F = G) {X : C} {Y : C} (f : X ⟶ Y) :
    map F f = eq_to_hom (congr_obj h X) ≫ map G f ≫ eq_to_hom (Eq.symm (congr_obj h Y)) :=
  sorry

end functor

@[simp] theorem eq_to_hom_map {C : Type u₁} [category C] {D : Type u₂} [category D] (F : C ⥤ D)
    {X : C} {Y : C} (p : X = Y) :
    functor.map F (eq_to_hom p) = eq_to_hom (congr_arg (functor.obj F) p) :=
  sorry

@[simp] theorem eq_to_iso_map {C : Type u₁} [category C] {D : Type u₂} [category D] (F : C ⥤ D)
    {X : C} {Y : C} (p : X = Y) :
    functor.map_iso F (eq_to_iso p) = eq_to_iso (congr_arg (functor.obj F) p) :=
  sorry

@[simp] theorem eq_to_hom_app {C : Type u₁} [category C] {D : Type u₂} [category D] {F : C ⥤ D}
    {G : C ⥤ D} (h : F = G) (X : C) :
    nat_trans.app (eq_to_hom h) X = eq_to_hom (functor.congr_obj h X) :=
  eq.drec (Eq.refl (nat_trans.app (eq_to_hom (Eq.refl F)) X)) h

theorem nat_trans.congr {C : Type u₁} [category C] {D : Type u₂} [category D] {F : C ⥤ D}
    {G : C ⥤ D} (α : F ⟶ G) {X : C} {Y : C} (h : X = Y) :
    nat_trans.app α X =
        functor.map F (eq_to_hom h) ≫ nat_trans.app α Y ≫ functor.map G (eq_to_hom (Eq.symm h)) :=
  sorry

end Mathlib


/-
Copyright (c) 2018 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl, Callum Sutton, Yury Kudryashov
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.algebra.group.hom
import Mathlib.algebra.group.type_tags
import Mathlib.algebra.group.units_hom
import Mathlib.PostPort

universes u_8 u_9 l u_3 u_4 u_1 u_5 u_2 u_6 u_7

namespace Mathlib

/-!
# Multiplicative and additive equivs

In this file we define two extensions of `equiv` called `add_equiv` and `mul_equiv`, which are
datatypes representing isomorphisms of `add_monoid`s/`add_group`s and `monoid`s/`group`s.

## Notations

The extended equivs all have coercions to functions, and the coercions are the canonical
notation when treating the isomorphisms as maps.

## Implementation notes

The fields for `mul_equiv`, `add_equiv` now avoid the unbundled `is_mul_hom` and `is_add_hom`, as
these are deprecated.

## Tags

equiv, mul_equiv, add_equiv
-/

/-- add_equiv α β is the type of an equiv α ≃ β which preserves addition. -/
structure add_equiv (A : Type u_8) (B : Type u_9) [Add A] [Add B]
extends add_hom A B, A ≃ B
where

/-- The `equiv` underlying an `add_equiv`. -/
/-- The `add_hom` underlying a `add_equiv`. -/
/-- `mul_equiv α β` is the type of an equiv `α ≃ β` which preserves multiplication. -/
structure mul_equiv (M : Type u_8) (N : Type u_9) [Mul M] [Mul N]
extends mul_hom M N, M ≃ N
where

infixl:25 " ≃* " => Mathlib.mul_equiv

infixl:25 " ≃+ " => Mathlib.add_equiv

/-- The `equiv` underlying a `mul_equiv`. -/
/-- The `mul_hom` underlying a `mul_equiv`. -/
namespace mul_equiv

protected instance has_coe_to_fun {M : Type u_3} {N : Type u_4} [Mul M] [Mul N] : has_coe_to_fun (M ≃* N) :=
  has_coe_to_fun.mk (fun (x : M ≃* N) => M → N) to_fun

@[simp] theorem Mathlib.add_equiv.to_fun_apply {M : Type u_3} {N : Type u_4} [Add M] [Add N] {f : M ≃+ N} {m : M} : add_equiv.to_fun f m = coe_fn f m :=
  rfl

@[simp] theorem Mathlib.add_equiv.to_equiv_apply {M : Type u_3} {N : Type u_4} [Add M] [Add N] {f : M ≃+ N} {m : M} : coe_fn (add_equiv.to_equiv f) m = coe_fn f m :=
  rfl

/-- A multiplicative isomorphism preserves multiplication (canonical form). -/
@[simp] theorem map_mul {M : Type u_3} {N : Type u_4} [Mul M] [Mul N] (f : M ≃* N) (x : M) (y : M) : coe_fn f (x * y) = coe_fn f x * coe_fn f y :=
  map_mul' f

/-- Makes a multiplicative isomorphism from a bijection which preserves multiplication. -/
def mk' {M : Type u_3} {N : Type u_4} [Mul M] [Mul N] (f : M ≃ N) (h : ∀ (x y : M), coe_fn f (x * y) = coe_fn f x * coe_fn f y) : M ≃* N :=
  mk (equiv.to_fun f) (equiv.inv_fun f) (equiv.left_inv f) (equiv.right_inv f) h

protected theorem Mathlib.add_equiv.bijective {M : Type u_3} {N : Type u_4} [Add M] [Add N] (e : M ≃+ N) : function.bijective ⇑e :=
  equiv.bijective (add_equiv.to_equiv e)

protected theorem Mathlib.add_equiv.injective {M : Type u_3} {N : Type u_4} [Add M] [Add N] (e : M ≃+ N) : function.injective ⇑e :=
  equiv.injective (add_equiv.to_equiv e)

protected theorem Mathlib.add_equiv.surjective {M : Type u_3} {N : Type u_4} [Add M] [Add N] (e : M ≃+ N) : function.surjective ⇑e :=
  equiv.surjective (add_equiv.to_equiv e)

/-- The identity map is a multiplicative isomorphism. -/
def refl (M : Type u_1) [Mul M] : M ≃* M :=
  mk (equiv.to_fun (equiv.refl M)) (equiv.inv_fun (equiv.refl M)) sorry sorry sorry

protected instance inhabited {M : Type u_3} [Mul M] : Inhabited (M ≃* M) :=
  { default := refl M }

/-- The inverse of an isomorphism is an isomorphism. -/
def Mathlib.add_equiv.symm {M : Type u_3} {N : Type u_4} [Add M] [Add N] (h : M ≃+ N) : N ≃+ M :=
  add_equiv.mk (equiv.to_fun (equiv.symm (add_equiv.to_equiv h))) (equiv.inv_fun (equiv.symm (add_equiv.to_equiv h)))
    sorry sorry sorry

/-- See Note [custom simps projection] -/
-- we don't hyperlink the note in the additive version, since that breaks syntax highlighting

-- in the whole file.

def simps.inv_fun {M : Type u_3} {N : Type u_4} [Mul M] [Mul N] (e : M ≃* N) : N → M :=
  ⇑(symm e)

@[simp] theorem Mathlib.add_equiv.to_equiv_symm {M : Type u_3} {N : Type u_4} [Add M] [Add N] (f : M ≃+ N) : add_equiv.to_equiv (add_equiv.symm f) = equiv.symm (add_equiv.to_equiv f) :=
  rfl

@[simp] theorem Mathlib.add_equiv.coe_mk {M : Type u_3} {N : Type u_4} [Add M] [Add N] (f : M → N) (g : N → M) (h₁ : function.left_inverse g f) (h₂ : function.right_inverse g f) (h₃ : ∀ (x y : M), f (x + y) = f x + f y) : ⇑(add_equiv.mk f g h₁ h₂ h₃) = f :=
  rfl

@[simp] theorem Mathlib.add_equiv.coe_symm_mk {M : Type u_3} {N : Type u_4} [Add M] [Add N] (f : M → N) (g : N → M) (h₁ : function.left_inverse g f) (h₂ : function.right_inverse g f) (h₃ : ∀ (x y : M), f (x + y) = f x + f y) : ⇑(add_equiv.symm (add_equiv.mk f g h₁ h₂ h₃)) = g :=
  rfl

/-- Transitivity of multiplication-preserving isomorphisms -/
def Mathlib.add_equiv.trans {M : Type u_3} {N : Type u_4} {P : Type u_5} [Add M] [Add N] [Add P] (h1 : M ≃+ N) (h2 : N ≃+ P) : M ≃+ P :=
  add_equiv.mk (equiv.to_fun (equiv.trans (add_equiv.to_equiv h1) (add_equiv.to_equiv h2)))
    (equiv.inv_fun (equiv.trans (add_equiv.to_equiv h1) (add_equiv.to_equiv h2))) sorry sorry sorry

/-- e.right_inv in canonical form -/
@[simp] theorem apply_symm_apply {M : Type u_3} {N : Type u_4} [Mul M] [Mul N] (e : M ≃* N) (y : N) : coe_fn e (coe_fn (symm e) y) = y :=
  equiv.apply_symm_apply (to_equiv e)

/-- e.left_inv in canonical form -/
@[simp] theorem Mathlib.add_equiv.symm_apply_apply {M : Type u_3} {N : Type u_4} [Add M] [Add N] (e : M ≃+ N) (x : M) : coe_fn (add_equiv.symm e) (coe_fn e x) = x :=
  equiv.symm_apply_apply (add_equiv.to_equiv e)

@[simp] theorem Mathlib.add_equiv.refl_apply {M : Type u_3} [Add M] (m : M) : coe_fn (add_equiv.refl M) m = m :=
  rfl

@[simp] theorem Mathlib.add_equiv.trans_apply {M : Type u_3} {N : Type u_4} {P : Type u_5} [Add M] [Add N] [Add P] (e₁ : M ≃+ N) (e₂ : N ≃+ P) (m : M) : coe_fn (add_equiv.trans e₁ e₂) m = coe_fn e₂ (coe_fn e₁ m) :=
  rfl

@[simp] theorem Mathlib.add_equiv.apply_eq_iff_eq {M : Type u_3} {N : Type u_4} [Add M] [Add N] (e : M ≃+ N) {x : M} {y : M} : coe_fn e x = coe_fn e y ↔ x = y :=
  function.injective.eq_iff (add_equiv.injective e)

theorem Mathlib.add_equiv.apply_eq_iff_symm_apply {M : Type u_3} {N : Type u_4} [Add M] [Add N] (e : M ≃+ N) {x : M} {y : N} : coe_fn e x = y ↔ x = coe_fn (add_equiv.symm e) y :=
  equiv.apply_eq_iff_eq_symm_apply (add_equiv.to_equiv e)

theorem symm_apply_eq {M : Type u_3} {N : Type u_4} [Mul M] [Mul N] (e : M ≃* N) {x : N} {y : M} : coe_fn (symm e) x = y ↔ x = coe_fn e y :=
  equiv.symm_apply_eq (to_equiv e)

theorem eq_symm_apply {M : Type u_3} {N : Type u_4} [Mul M] [Mul N] (e : M ≃* N) {x : N} {y : M} : y = coe_fn (symm e) x ↔ coe_fn e y = x :=
  equiv.eq_symm_apply (to_equiv e)

/-- a multiplicative equiv of monoids sends 1 to 1 (and is hence a monoid isomorphism) -/
@[simp] theorem Mathlib.add_equiv.map_zero {M : Type u_1} {N : Type u_2} [add_monoid M] [add_monoid N] (h : M ≃+ N) : coe_fn h 0 = 0 := sorry

@[simp] theorem Mathlib.add_equiv.map_eq_zero_iff {M : Type u_1} {N : Type u_2} [add_monoid M] [add_monoid N] (h : M ≃+ N) {x : M} : coe_fn h x = 0 ↔ x = 0 :=
  add_equiv.map_zero h ▸ equiv.apply_eq_iff_eq (add_equiv.to_equiv h)

theorem map_ne_one_iff {M : Type u_1} {N : Type u_2} [monoid M] [monoid N] (h : M ≃* N) {x : M} : coe_fn h x ≠ 1 ↔ x ≠ 1 :=
  { mp := mt (iff.mpr (map_eq_one_iff h)), mpr := mt (iff.mp (map_eq_one_iff h)) }

/-- A bijective `monoid` homomorphism is an isomorphism -/
def Mathlib.add_equiv.of_bijective {M : Type u_1} {N : Type u_2} [add_monoid M] [add_monoid N] (f : M →+ N) (hf : function.bijective ⇑f) : M ≃+ N :=
  add_equiv.mk (equiv.to_fun (equiv.of_bijective (⇑f) hf)) (equiv.inv_fun (equiv.of_bijective (⇑f) hf)) sorry sorry
    (add_monoid_hom.map_add' f)

/--
Extract the forward direction of a multiplicative equivalence
as a multiplication-preserving function.
-/
def Mathlib.add_equiv.to_add_monoid_hom {M : Type u_1} {N : Type u_2} [add_monoid M] [add_monoid N] (h : M ≃+ N) : M →+ N :=
  add_monoid_hom.mk (add_equiv.to_fun h) (add_equiv.map_zero h) sorry

@[simp] theorem coe_to_monoid_hom {M : Type u_1} {N : Type u_2} [monoid M] [monoid N] (e : M ≃* N) : ⇑(to_monoid_hom e) = ⇑e :=
  rfl

theorem Mathlib.add_equiv.to_add_monoid_hom_apply {M : Type u_1} {N : Type u_2} [add_monoid M] [add_monoid N] (e : M ≃+ N) (x : M) : coe_fn (add_equiv.to_add_monoid_hom e) x = coe_fn e x :=
  rfl

/-- A multiplicative equivalence of groups preserves inversion. -/
@[simp] theorem map_inv {G : Type u_6} {H : Type u_7} [group G] [group H] (h : G ≃* H) (x : G) : coe_fn h (x⁻¹) = (coe_fn h x⁻¹) :=
  monoid_hom.map_inv (to_monoid_hom h) x

/-- Two multiplicative isomorphisms agree if they are defined by the
    same underlying function. -/
theorem ext {M : Type u_3} {N : Type u_4} [Mul M] [Mul N] {f : M ≃* N} {g : M ≃* N} (h : ∀ (x : M), coe_fn f x = coe_fn g x) : f = g := sorry

protected theorem congr_arg {M : Type u_3} {N : Type u_4} [Mul M] [Mul N] {f : M ≃* N} {x : M} {x' : M} : x = x' → coe_fn f x = coe_fn f x' := sorry

protected theorem congr_fun {M : Type u_3} {N : Type u_4} [Mul M] [Mul N] {f : M ≃* N} {g : M ≃* N} (h : f = g) (x : M) : coe_fn f x = coe_fn g x :=
  h ▸ rfl

theorem ext_iff {M : Type u_3} {N : Type u_4} [Mul M] [Mul N] {f : M ≃* N} {g : M ≃* N} : f = g ↔ ∀ (x : M), coe_fn f x = coe_fn g x :=
  { mp := fun (h : f = g) (x : M) => h ▸ rfl, mpr := ext }

theorem Mathlib.add_equiv.to_add_monoid_hom_injective {M : Type u_1} {N : Type u_2} [add_monoid M] [add_monoid N] : function.injective add_equiv.to_add_monoid_hom :=
  fun (f g : M ≃+ N) (h : add_equiv.to_add_monoid_hom f = add_equiv.to_add_monoid_hom g) =>
    add_equiv.ext (iff.mp add_monoid_hom.ext_iff h)

end mul_equiv

-- We don't use `to_additive` to generate definition because it fails to tell Lean about

-- equational lemmas

/-- Given a pair of additive monoid homomorphisms `f`, `g` such that `g.comp f = id` and
`f.comp g = id`, returns an additive equivalence with `to_fun = f` and `inv_fun = g`.  This
constructor is useful if the underlying type(s) have specialized `ext` lemmas for additive
monoid homomorphisms. -/
def add_monoid_hom.to_add_equiv {M : Type u_3} {N : Type u_4} [add_monoid M] [add_monoid N] (f : M →+ N) (g : N →+ M) (h₁ : add_monoid_hom.comp g f = add_monoid_hom.id M) (h₂ : add_monoid_hom.comp f g = add_monoid_hom.id N) : M ≃+ N :=
  add_equiv.mk ⇑f ⇑g sorry sorry (add_monoid_hom.map_add f)

/-- Given a pair of monoid homomorphisms `f`, `g` such that `g.comp f = id` and `f.comp g = id`,
returns an multiplicative equivalence with `to_fun = f` and `inv_fun = g`.  This constructor is
useful if the underlying type(s) have specialized `ext` lemmas for monoid homomorphisms. -/
def monoid_hom.to_mul_equiv {M : Type u_3} {N : Type u_4} [monoid M] [monoid N] (f : M →* N) (g : N →* M) (h₁ : monoid_hom.comp g f = monoid_hom.id M) (h₂ : monoid_hom.comp f g = monoid_hom.id N) : M ≃* N :=
  mul_equiv.mk ⇑f ⇑g sorry sorry (monoid_hom.map_mul f)

@[simp] theorem monoid_hom.coe_to_mul_equiv {M : Type u_3} {N : Type u_4} [monoid M] [monoid N] (f : M →* N) (g : N →* M) (h₁ : monoid_hom.comp g f = monoid_hom.id M) (h₂ : monoid_hom.comp f g = monoid_hom.id N) : ⇑(monoid_hom.to_mul_equiv f g h₁ h₂) = ⇑f :=
  rfl

/-- An additive equivalence of additive groups preserves subtraction. -/
theorem add_equiv.map_sub {A : Type u_1} {B : Type u_2} [add_group A] [add_group B] (h : A ≃+ B) (x : A) (y : A) : coe_fn h (x - y) = coe_fn h x - coe_fn h y :=
  add_monoid_hom.map_sub (add_equiv.to_add_monoid_hom h) x y

protected instance add_equiv.inhabited {M : Type u_1} [Add M] : Inhabited (M ≃+ M) :=
  { default := add_equiv.refl M }

/-- A group is isomorphic to its group of units. -/
def to_add_units {G : Type u_1} [add_group G] : G ≃+ add_units G :=
  add_equiv.mk (fun (x : G) => add_units.mk x (-x) (add_neg_self x) (neg_add_self x)) coe sorry sorry sorry

namespace units

/-- A multiplicative equivalence of monoids defines a multiplicative equivalence
of their groups of units. -/
def map_equiv {M : Type u_3} {N : Type u_4} [monoid M] [monoid N] (h : M ≃* N) : units M ≃* units N :=
  mul_equiv.mk (monoid_hom.to_fun (map (mul_equiv.to_monoid_hom h))) ⇑(map (mul_equiv.to_monoid_hom (mul_equiv.symm h)))
    sorry sorry sorry

/-- Left multiplication by a unit of a monoid is a permutation of the underlying type. -/
def mul_left {M : Type u_3} [monoid M] (u : units M) : equiv.perm M :=
  equiv.mk (fun (x : M) => ↑u * x) (fun (x : M) => ↑(u⁻¹) * x) (inv_mul_cancel_left u) (mul_inv_cancel_left u)

@[simp] theorem coe_mul_left {M : Type u_3} [monoid M] (u : units M) : ⇑(mul_left u) = Mul.mul ↑u :=
  rfl

@[simp] theorem Mathlib.add_units.add_left_symm {M : Type u_3} [add_monoid M] (u : add_units M) : equiv.symm (add_units.add_left u) = add_units.add_left (-u) :=
  equiv.ext fun (x : M) => rfl

/-- Right multiplication by a unit of a monoid is a permutation of the underlying type. -/
def mul_right {M : Type u_3} [monoid M] (u : units M) : equiv.perm M :=
  equiv.mk (fun (x : M) => x * ↑u) (fun (x : M) => x * ↑(u⁻¹)) sorry sorry

@[simp] theorem Mathlib.add_units.coe_add_right {M : Type u_3} [add_monoid M] (u : add_units M) : ⇑(add_units.add_right u) = fun (x : M) => x + ↑u :=
  rfl

@[simp] theorem Mathlib.add_units.add_right_symm {M : Type u_3} [add_monoid M] (u : add_units M) : equiv.symm (add_units.add_right u) = add_units.add_right (-u) :=
  equiv.ext fun (x : M) => rfl

end units

namespace equiv

/-- Left multiplication in a `group` is a permutation of the underlying type. -/
protected def add_left {G : Type u_6} [add_group G] (a : G) : perm G :=
  add_units.add_left (coe_fn to_add_units a)

@[simp] theorem coe_add_left {G : Type u_6} [add_group G] (a : G) : ⇑(equiv.add_left a) = Add.add a :=
  rfl

/-- extra simp lemma that `dsimp` can use. `simp` will never use this. -/
@[simp] theorem add_left_symm_apply {G : Type u_6} [add_group G] (a : G) : ⇑(equiv.symm (equiv.add_left a)) = Add.add (-a) :=
  rfl

@[simp] theorem mul_left_symm {G : Type u_6} [group G] (a : G) : equiv.symm (equiv.mul_left a) = equiv.mul_left (a⁻¹) :=
  ext fun (x : G) => rfl

/-- Right multiplication in a `group` is a permutation of the underlying type. -/
protected def add_right {G : Type u_6} [add_group G] (a : G) : perm G :=
  add_units.add_right (coe_fn to_add_units a)

@[simp] theorem coe_mul_right {G : Type u_6} [group G] (a : G) : ⇑(equiv.mul_right a) = fun (x : G) => x * a :=
  rfl

@[simp] theorem mul_right_symm {G : Type u_6} [group G] (a : G) : equiv.symm (equiv.mul_right a) = equiv.mul_right (a⁻¹) :=
  ext fun (x : G) => rfl

/-- extra simp lemma that `dsimp` can use. `simp` will never use this.  -/
@[simp] theorem add_right_symm_apply {G : Type u_6} [add_group G] (a : G) : ⇑(equiv.symm (equiv.add_right a)) = fun (x : G) => x + -a :=
  rfl

/-- Inversion on a `group` is a permutation of the underlying type. -/
protected def neg (G : Type u_6) [add_group G] : perm G :=
  mk (fun (a : G) => -a) (fun (a : G) => -a) sorry sorry

@[simp] theorem coe_inv {G : Type u_6} [group G] : ⇑(equiv.inv G) = has_inv.inv :=
  rfl

@[simp] theorem neg_symm {G : Type u_6} [add_group G] : equiv.symm (equiv.neg G) = equiv.neg G :=
  rfl

end equiv

/-- Reinterpret `G ≃+ H` as `multiplicative G ≃* multiplicative H`. -/
def add_equiv.to_multiplicative {G : Type u_6} {H : Type u_7} [add_monoid G] [add_monoid H] : G ≃+ H ≃ (multiplicative G ≃* multiplicative H) :=
  equiv.mk
    (fun (f : G ≃+ H) =>
      mul_equiv.mk ⇑(coe_fn add_monoid_hom.to_multiplicative (add_equiv.to_add_monoid_hom f))
        ⇑(coe_fn add_monoid_hom.to_multiplicative (add_equiv.to_add_monoid_hom (add_equiv.symm f))) sorry sorry sorry)
    (fun (f : multiplicative G ≃* multiplicative H) =>
      add_equiv.mk ⇑(mul_equiv.to_monoid_hom f) ⇑(mul_equiv.to_monoid_hom (mul_equiv.symm f)) sorry sorry sorry)
    sorry sorry

/-- Reinterpret `G ≃* H` as `additive G ≃+ additive H`. -/
def mul_equiv.to_additive {G : Type u_6} {H : Type u_7} [monoid G] [monoid H] : G ≃* H ≃ (additive G ≃+ additive H) :=
  equiv.mk
    (fun (f : G ≃* H) =>
      add_equiv.mk ⇑(coe_fn monoid_hom.to_additive (mul_equiv.to_monoid_hom f))
        ⇑(coe_fn monoid_hom.to_additive (mul_equiv.to_monoid_hom (mul_equiv.symm f))) sorry sorry sorry)
    (fun (f : additive G ≃+ additive H) =>
      mul_equiv.mk ⇑(add_equiv.to_add_monoid_hom f) ⇑(add_equiv.to_add_monoid_hom (add_equiv.symm f)) sorry sorry sorry)
    sorry sorry

/-- Reinterpret `additive G ≃+ H` as `G ≃* multiplicative H`. -/
def add_equiv.to_multiplicative' {G : Type u_6} {H : Type u_7} [monoid G] [add_monoid H] : additive G ≃+ H ≃ (G ≃* multiplicative H) :=
  equiv.mk
    (fun (f : additive G ≃+ H) =>
      mul_equiv.mk ⇑(coe_fn add_monoid_hom.to_multiplicative' (add_equiv.to_add_monoid_hom f))
        ⇑(coe_fn add_monoid_hom.to_multiplicative'' (add_equiv.to_add_monoid_hom (add_equiv.symm f))) sorry sorry sorry)
    (fun (f : G ≃* multiplicative H) =>
      add_equiv.mk ⇑(mul_equiv.to_monoid_hom f) ⇑(mul_equiv.to_monoid_hom (mul_equiv.symm f)) sorry sorry sorry)
    sorry sorry

/-- Reinterpret `G ≃* multiplicative H` as `additive G ≃+ H` as. -/
def mul_equiv.to_additive' {G : Type u_6} {H : Type u_7} [monoid G] [add_monoid H] : G ≃* multiplicative H ≃ (additive G ≃+ H) :=
  equiv.symm add_equiv.to_multiplicative'

/-- Reinterpret `G ≃+ additive H` as `multiplicative G ≃* H`. -/
def add_equiv.to_multiplicative'' {G : Type u_6} {H : Type u_7} [add_monoid G] [monoid H] : G ≃+ additive H ≃ (multiplicative G ≃* H) :=
  equiv.mk
    (fun (f : G ≃+ additive H) =>
      mul_equiv.mk ⇑(coe_fn add_monoid_hom.to_multiplicative'' (add_equiv.to_add_monoid_hom f))
        ⇑(coe_fn add_monoid_hom.to_multiplicative' (add_equiv.to_add_monoid_hom (add_equiv.symm f))) sorry sorry sorry)
    (fun (f : multiplicative G ≃* H) =>
      add_equiv.mk ⇑(mul_equiv.to_monoid_hom f) ⇑(mul_equiv.to_monoid_hom (mul_equiv.symm f)) sorry sorry sorry)
    sorry sorry

/-- Reinterpret `multiplicative G ≃* H` as `G ≃+ additive H` as. -/
def mul_equiv.to_additive'' {G : Type u_6} {H : Type u_7} [add_monoid G] [monoid H] : multiplicative G ≃* H ≃ (G ≃+ additive H) :=
  equiv.symm add_equiv.to_multiplicative''


/-
Copyright (c) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison, Andrew Yang
-/
import category_theory.monoidal.functor

/-!
# Endofunctors as a monoidal category.

We give the monoidal category structure on `C ⥤ C`,
and show that when `C` itself is monoidal, it embeds via a monoidal functor into `C ⥤ C`.

## TODO

Can we use this to show coherence results, e.g. a cheap proof that `λ_ (𝟙_ C) = ρ_ (𝟙_ C)`?
I suspect this is harder than is usually made out.
-/

universes v u

namespace category_theory

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

/--
The category of endofunctors of any category is a monoidal category,
with tensor product given by composition of functors
(and horizontal composition of natural transformations).
-/
def endofunctor_monoidal_category : monoidal_category (C ⥤ C) :=
{ tensor_obj   := λ F G, F ⋙ G,
  tensor_hom   := λ F G F' G' α β, α ◫ β,
  tensor_unit  := 𝟭 C,
  associator   := λ F G H, functor.associator F G H,
  left_unitor  := λ F, functor.left_unitor F,
  right_unitor := λ F, functor.right_unitor F, }.

open category_theory.monoidal_category

local attribute [instance] endofunctor_monoidal_category
local attribute [reducible] endofunctor_monoidal_category

/--
Tensoring on the right gives a monoidal functor from `C` into endofunctors of `C`.
-/
@[simps]
def tensoring_right_monoidal [monoidal_category.{v} C] : monoidal_functor C (C ⥤ C) :=
{ ε := (right_unitor_nat_iso C).inv,
  μ := λ X Y,
  { app := λ Z, (α_ Z X Y).hom,
    naturality' := λ Z Z' f, by { dsimp, rw associator_naturality, simp, } },
  μ_natural' := λ X Y X' Y' f g, by { ext Z, dsimp,
    simp only [←id_tensor_comp_tensor_id g f, id_tensor_comp, ←tensor_id, category.assoc,
      associator_naturality, associator_naturality_assoc], },
  associativity' := λ X Y Z, by { ext W, dsimp, simp [pentagon], },
  left_unitality' := λ X, by { ext Y, dsimp, rw [category.id_comp, triangle, ←tensor_comp], simp, },
  right_unitality' := λ X,
  begin
    ext Y, dsimp,
    rw [tensor_id, category.comp_id, right_unitor_tensor_inv, category.assoc, iso.inv_hom_id_assoc,
      ←id_tensor_comp, iso.inv_hom_id, tensor_id],
  end,
  ε_is_iso := by apply_instance,
  μ_is_iso := λ X Y,
    -- We could avoid needing to do this explicitly by
    -- constructing a partially applied analogue of `associator_nat_iso`.
  ⟨⟨{ app := λ Z, (α_ Z X Y).inv,
      naturality' := λ Z Z' f, by { dsimp, rw ←associator_inv_naturality, simp, } },
    by tidy⟩⟩,
  ..tensoring_right C }.

variable {C}
variables {M : Type*} [category M] [monoidal_category M] (F : monoidal_functor M (C ⥤ C))

@[simp, reassoc]
lemma μ_hom_inv_app (i j : M) (X : C) :
  (F.μ i j).app X ≫ (F.μ_iso i j).inv.app X = 𝟙 _ := (F.μ_iso i j).hom_inv_id_app X

@[simp, reassoc]
lemma μ_inv_hom_app (i j : M) (X : C) :
   (F.μ_iso i j).inv.app X ≫ (F.μ i j).app X = 𝟙 _ := (F.μ_iso i j).inv_hom_id_app X

@[simp, reassoc]
lemma ε_hom_inv_app (X : C) :
  F.ε.app X ≫ F.ε_iso.inv.app X = 𝟙 _ := F.ε_iso.hom_inv_id_app X

@[simp, reassoc]
lemma ε_inv_hom_app (X : C) :
  F.ε_iso.inv.app X ≫ F.ε.app X = 𝟙 _ := F.ε_iso.inv_hom_id_app X

@[simp, reassoc]
lemma ε_naturality {X Y : C} (f : X ⟶ Y) :
  F.ε.app X ≫ (F.obj (𝟙_M)).map f = f ≫ F.ε.app Y := (F.ε.naturality f).symm

@[simp, reassoc]
lemma ε_inv_naturality {X Y : C} (f : X ⟶ Y) :
  (F.obj (𝟙_M)).map f ≫ F.ε_iso.inv.app Y = F.ε_iso.inv.app X ≫ f :=
F.ε_iso.inv.naturality f

@[simp, reassoc]
lemma μ_naturality {m n : M} {X Y : C} (f : X ⟶ Y) :
  (F.obj n).map ((F.obj m).map f) ≫ (F.μ m n).app Y = (F.μ m n).app X ≫ (F.obj _).map f :=
(F.to_lax_monoidal_functor.μ m n).naturality f

-- This is a simp lemma in the reverse direction via `nat_trans.naturality`.
@[reassoc]
lemma μ_inv_naturality {m n : M} {X Y : C} (f : X ⟶ Y) :
  (F.μ_iso m n).inv.app X ≫ (F.obj n).map ((F.obj m).map f) =
    (F.obj _).map f ≫ (F.μ_iso m n).inv.app Y :=
((F.μ_iso m n).inv.naturality f).symm

-- This is not a simp lemma since it could be proved by the lemmas later.
@[reassoc]
lemma μ_naturality₂ {m n m' n' : M} (f : m ⟶ m') (g : n ⟶ n') (X : C) :
  (F.map g).app ((F.obj m).obj X) ≫ (F.obj n').map ((F.map f).app X) ≫ (F.μ m' n').app X =
    (F.μ m n).app X ≫ (F.map (f ⊗ g)).app X :=
begin
  have := congr_app (F.to_lax_monoidal_functor.μ_natural f g) X,
  dsimp at this,
  simpa using this,
end

@[simp, reassoc]
lemma μ_naturalityₗ {m n m' : M} (f : m ⟶ m') (X : C) :
  (F.obj n).map ((F.map f).app X) ≫ (F.μ m' n).app X =
    (F.μ m n).app X ≫ (F.map (f ⊗ 𝟙 n)).app X :=
begin
  rw ← μ_naturality₂ F f (𝟙 n) X,
  simp,
end

@[simp, reassoc]
lemma μ_naturalityᵣ {m n n' : M} (g : n ⟶ n') (X : C) :
  (F.map g).app ((F.obj m).obj X) ≫ (F.μ m n').app X =
    (F.μ m n).app X ≫ (F.map (𝟙 m ⊗ g)).app X :=
begin
  rw ← μ_naturality₂ F (𝟙 m) g X,
  simp,
end

@[simp, reassoc]
lemma μ_inv_naturalityₗ {m n m' : M} (f : m ⟶ m') (X : C) :
  (F.μ_iso m n).inv.app X ≫ (F.obj n).map ((F.map f).app X) =
    (F.map (f ⊗ 𝟙 n)).app X ≫ (F.μ_iso m' n).inv.app X :=
begin
  rw [← is_iso.comp_inv_eq, category.assoc, ← is_iso.eq_inv_comp],
  simp,
end

@[simp, reassoc]
lemma μ_inv_naturalityᵣ {m n n' : M} (g : n ⟶ n') (X : C) :
  (F.μ_iso m n).inv.app X ≫ (F.map g).app ((F.obj m).obj X) =
    (F.map (𝟙 m ⊗ g)).app X ≫ (F.μ_iso m n').inv.app X :=
begin
  rw [← is_iso.comp_inv_eq, category.assoc, ← is_iso.eq_inv_comp],
  simp,
end

@[reassoc]
lemma left_unitality_app (n : M) (X : C) :
  (F.obj n).map (F.ε.app X) ≫ (F.μ (𝟙_M) n).app X
    ≫ (F.map (λ_ n).hom).app X = 𝟙 _ :=
begin
  have := congr_app (F.to_lax_monoidal_functor.left_unitality n) X,
  dsimp at this,
  simpa using this.symm,
end

@[reassoc, simp]
lemma obj_ε_app (n : M) (X : C) :
  (F.obj n).map (F.ε.app X) =
    (F.map (λ_ n).inv).app X ≫ (F.μ_iso (𝟙_M) n).inv.app X :=
begin
  refine eq.trans _ (category.id_comp _),
  rw [← category.assoc, ← is_iso.comp_inv_eq, ← is_iso.comp_inv_eq, category.assoc],
  convert left_unitality_app F n X,
  { simp },
  { ext, simpa }
end

@[reassoc, simp]

@[reassoc]
lemma right_unitality_app (n : M) (X : C) :
  F.ε.app ((F.obj n).obj X) ≫ (F.μ n (𝟙_M)).app X ≫ (F.map (ρ_ n).hom).app X = 𝟙 _ :=
begin
  have := congr_app (F.to_lax_monoidal_functor.right_unitality n) X,
  dsimp at this,
  simpa using this.symm,
end

@[simp]
lemma ε_app_obj (n : M) (X : C) :
  F.ε.app ((F.obj n).obj X) =
    (F.map (ρ_ n).inv).app X ≫ (F.μ_iso n (𝟙_M)).inv.app X :=
begin
  refine eq.trans _ (category.id_comp _),
  rw [← category.assoc, ← is_iso.comp_inv_eq, ← is_iso.comp_inv_eq, category.assoc],
  convert right_unitality_app F n X,
  { simp },
  { ext, simpa }
end

@[simp]
lemma ε_inv_app_obj (n : M) (X : C) :
  F.ε_iso.inv.app ((F.obj n).obj X) =
    (F.μ n (𝟙_M)).app X ≫ (F.map (ρ_ n).hom).app X :=
begin
  rw [← cancel_mono (F.ε.app ((F.obj n).obj X)), ε_inv_hom_app],
  simpa
end

@[reassoc]
lemma associativity_app (m₁ m₂ m₃: M) (X : C) :
  (F.obj m₃).map ((F.μ m₁ m₂).app X) ≫ (F.μ (m₁ ⊗ m₂) m₃).app X ≫
    (F.map (α_ m₁ m₂ m₃).hom).app X =
  (F.μ m₂ m₃).app ((F.obj m₁).obj X) ≫ (F.μ m₁ (m₂ ⊗ m₃)).app X :=
begin
  have := congr_app (F.to_lax_monoidal_functor.associativity m₁ m₂ m₃) X,
  dsimp at this,
  simpa using this,
end

@[reassoc, simp]
lemma obj_μ_app (m₁ m₂ m₃ : M) (X : C) :
  (F.obj m₃).map ((F.μ m₁ m₂).app X) =
  (F.μ m₂ m₃).app ((F.obj m₁).obj X) ≫ (F.μ m₁ (m₂ ⊗ m₃)).app X ≫
    (F.map (α_ m₁ m₂ m₃).inv).app X ≫ (F.μ_iso (m₁ ⊗ m₂) m₃).inv.app X :=
begin
  rw [← associativity_app_assoc],
  dsimp,
  simp,
  dsimp,
  simp,
end

@[reassoc, simp]
lemma obj_μ_inv_app (m₁ m₂ m₃ : M) (X : C) :
  (F.obj m₃).map ((F.μ_iso m₁ m₂).inv.app X) =
  (F.μ (m₁ ⊗ m₂) m₃).app X ≫ (F.map (α_ m₁ m₂ m₃).hom).app X ≫
  (F.μ_iso m₁ (m₂ ⊗ m₃)).inv.app X ≫
  (F.μ_iso m₂ m₃).inv.app ((F.obj m₁).obj X) :=
begin
  rw ← is_iso.inv_eq_inv,
  convert obj_μ_app F m₁ m₂ m₃ X using 1,
  { ext, rw ← functor.map_comp, simp },
  { simp only [monoidal_functor.μ_iso_hom, category.assoc, nat_iso.inv_inv_app, is_iso.inv_comp],
    congr,
    { ext, simp },
    { ext, simpa } }
end

@[simp, reassoc]
lemma obj_zero_map_μ_app {m : M} {X Y : C} (f : X ⟶ (F.obj m).obj Y) :
  (F.obj (𝟙_M)).map f ≫ (F.μ m (𝟙_M)).app _ =
    F.ε_iso.inv.app _ ≫ f ≫ (F.map (ρ_ m).inv).app _ :=
begin
  rw [← is_iso.inv_comp_eq, ← is_iso.comp_inv_eq],
  simp,
end

@[simp]
lemma obj_μ_zero_app (m₁ m₂ : M) (X : C) :
  (F.obj m₂).map ((F.μ m₁ (𝟙_M)).app X) =
  (F.μ (𝟙_M) m₂).app ((F.obj m₁).obj X) ≫ (F.map (λ_ m₂).hom).app ((F.obj m₁).obj X) ≫
    (F.obj m₂).map ((F.map (ρ_ m₁).inv).app X) :=
begin
  rw [← obj_ε_inv_app_assoc, ← functor.map_comp],
  congr, simp,
end

/-- If `m ⊗ n ≅ 𝟙_M`, then `F.obj m` is a left inverse of `F.obj n`. -/
@[simps] noncomputable
def unit_of_tensor_iso_unit (m n : M) (h : m ⊗ n ≅ 𝟙_M) : F.obj m ⋙ F.obj n ≅ 𝟭 C :=
F.μ_iso m n ≪≫ F.to_functor.map_iso h ≪≫ F.ε_iso.symm

/-- If `m ⊗ n ≅ 𝟙_M` and `n ⊗ m ≅ 𝟙_M` (subject to some commuting constraints),
  then `F.obj m` and `F.obj n` forms a self-equivalence of `C`. -/
@[simps] noncomputable
def equiv_of_tensor_iso_unit (m n : M) (h₁ : m ⊗ n ≅ 𝟙_M) (h₂ : n ⊗ m ≅ 𝟙_M)
  (H : (h₁.hom ⊗ 𝟙 m) ≫ (λ_ m).hom = (α_ m n m).hom ≫ (𝟙 m ⊗ h₂.hom) ≫ (ρ_ m).hom) : C ≌ C :=
{ functor := F.obj m,
  inverse := F.obj n,
  unit_iso := (unit_of_tensor_iso_unit F m n h₁).symm,
  counit_iso := unit_of_tensor_iso_unit F n m h₂,
  functor_unit_iso_comp' :=
  begin
    intro X,
    dsimp,
    simp only [μ_naturalityᵣ_assoc, μ_naturalityₗ_assoc, ε_inv_app_obj, category.assoc,
      obj_μ_inv_app, functor.map_comp, μ_inv_hom_app_assoc, obj_ε_app,
      unit_of_tensor_iso_unit_inv_app],
    simp [← nat_trans.comp_app, ← F.to_functor.map_comp, ← H, - functor.map_comp]
  end }

end category_theory


/-
Copyright (c) 2021 Bhavik Mehta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Bhavik Mehta
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.category_theory.over
import Mathlib.category_theory.limits.preserves.basic
import Mathlib.category_theory.limits.creates
import Mathlib.category_theory.limits.shapes.binary_products
import Mathlib.category_theory.monad.algebra
import Mathlib.PostPort

universes u v

namespace Mathlib

/-!
# Algebras for the coproduct monad

The functor `Y ↦ X ⨿ Y` forms a monad, whose category of monads is equivalent to the under category
of `X`. Similarly, `Y ↦ X ⨯ Y` forms a comonad, whose category of comonads is equivalent to the
over category of `X`.

## TODO

Show that `over.forget X : over X ⥤ C` is a comonadic left adjoint and `under.forget : under X ⥤ C`
is a monadic right adjoint.
-/

namespace category_theory

/-- `X ⨯ -` has a comonad structure. This is sometimes called the writer comonad. -/
protected instance obj.comonad {C : Type u} [category C] (X : C) [limits.has_binary_products C] :
    comonad (functor.obj limits.prod.functor X) :=
  comonad.mk (nat_trans.mk fun (Y : C) => limits.prod.snd)
    (nat_trans.mk fun (Y : C) => limits.prod.lift limits.prod.fst 𝟙)

/--
The forward direction of the equivalence from coalgebras for the product comonad to the over
category.
-/
def coalgebra_to_over {C : Type u} [category C] (X : C) [limits.has_binary_products C] :
    comonad.coalgebra (functor.obj limits.prod.functor X) ⥤ over X :=
  functor.mk
    (fun (A : comonad.coalgebra (functor.obj limits.prod.functor X)) =>
      over.mk (comonad.coalgebra.a A ≫ limits.prod.fst))
    fun (A₁ A₂ : comonad.coalgebra (functor.obj limits.prod.functor X)) (f : A₁ ⟶ A₂) =>
      over.hom_mk (comonad.coalgebra.hom.f f)

/--
The backward direction of the equivalence from coalgebras for the product comonad to the over
category.
-/
@[simp] theorem over_to_coalgebra_map_f {C : Type u} [category C] (X : C)
    [limits.has_binary_products C] (f₁ : over X) (f₂ : over X) (g : f₁ ⟶ f₂) :
    comonad.coalgebra.hom.f (functor.map (over_to_coalgebra X) g) = comma_morphism.left g :=
  Eq.refl (comonad.coalgebra.hom.f (functor.map (over_to_coalgebra X) g))

/-- The equivalence from coalgebras for the product comonad to the over category. -/
def coalgebra_equiv_over {C : Type u} [category C] (X : C) [limits.has_binary_products C] :
    comonad.coalgebra (functor.obj limits.prod.functor X) ≌ over X :=
  equivalence.mk' (coalgebra_to_over X) (over_to_coalgebra X)
    (nat_iso.of_components
      (fun (A : comonad.coalgebra (functor.obj limits.prod.functor X)) =>
        comonad.coalgebra.iso_mk (iso.refl (comonad.coalgebra.A (functor.obj 𝟭 A))) sorry)
      sorry)
    (nat_iso.of_components
      (fun (f : over X) =>
        over.iso_mk
          (iso.refl (comma.left (functor.obj (over_to_coalgebra X ⋙ coalgebra_to_over X) f))))
      sorry)

/-- `X ⨿ -` has a monad structure. This is sometimes called the either monad. -/
@[simp] theorem obj.monad_μ_app {C : Type u} [category C] (X : C) [limits.has_binary_coproducts C]
    (Y : C) : nat_trans.app μ_ Y = limits.coprod.desc limits.coprod.inl 𝟙 :=
  Eq.refl (nat_trans.app μ_ Y)

/--
The forward direction of the equivalence from algebras for the coproduct monad to the under
category.
-/
def algebra_to_under {C : Type u} [category C] (X : C) [limits.has_binary_coproducts C] :
    monad.algebra (functor.obj limits.coprod.functor X) ⥤ under X :=
  functor.mk
    (fun (A : monad.algebra (functor.obj limits.coprod.functor X)) =>
      under.mk (limits.coprod.inl ≫ monad.algebra.a A))
    fun (A₁ A₂ : monad.algebra (functor.obj limits.coprod.functor X)) (f : A₁ ⟶ A₂) =>
      under.hom_mk (monad.algebra.hom.f f)

/--
The backward direction of the equivalence from algebras for the coproduct monad to the under
category.
-/
@[simp] theorem under_to_algebra_obj_A {C : Type u} [category C] (X : C)
    [limits.has_binary_coproducts C] (f : under X) :
    monad.algebra.A (functor.obj (under_to_algebra X) f) = comma.right f :=
  Eq.refl (monad.algebra.A (functor.obj (under_to_algebra X) f))

/--
The equivalence from algebras for the coproduct monad to the under category.
-/
@[simp] theorem algebra_equiv_under_unit_iso {C : Type u} [category C] (X : C)
    [limits.has_binary_coproducts C] :
    equivalence.unit_iso (algebra_equiv_under X) =
        nat_iso.of_components
          (fun (A : monad.algebra (functor.obj limits.coprod.functor X)) =>
            monad.algebra.iso_mk (iso.refl (monad.algebra.A (functor.obj 𝟭 A)))
              (algebra_equiv_under._proof_1 X A))
          (algebra_equiv_under._proof_2 X) :=
  Eq.refl (equivalence.unit_iso (algebra_equiv_under X))

end Mathlib


/-
Copyright (c) 2016 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Leonardo de Moura

! This file was ported from Lean 3 source module smt.array
! leanprover-community/mathlib commit 52d4189805e76b608b4f891254894fdea185c930
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/

namespace Smt

universe u v

def Array (α : Type u) (β : Type v) :=
  α → β
#align smt.array Smt.Array

variable {α : Type u} {β : Type v}

open Tactic

def select (a : Array α β) (i : α) : β :=
  a i
#align smt.select Smt.select

theorem arrayext (a₁ a₂ : Array α β) : (∀ i, select a₁ i = select a₂ i) → a₁ = a₂ :=
  funext
#align smt.arrayext Smt.arrayext

variable [DecidableEq α]

def store (a : Array α β) (i : α) (v : β) : Array α β := fun j => if j = i then v else select a j
#align smt.store Smt.store

@[simp]
theorem select_store (a : Array α β) (i : α) (v : β) : select (store a i v) i = v := by
  unfold Smt.store Smt.select <;> rw [if_pos] <;> rfl
#align smt.select_store Smt.select_store

@[simp]
theorem select_store_ne (a : Array α β) (i j : α) (v : β) :
    j ≠ i → select (store a i v) j = select a j := by
  intros <;> unfold Smt.store Smt.select <;> rw [if_neg] <;> assumption
#align smt.select_store_ne Smt.select_store_ne

end Smt