/-
Copyright (c) 2022 Yaël Dillies. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yaël Dillies
-/
import data.finset.lattice
import order.hom.bounded
import order.symm_diff

/-!
# Lattice homomorphisms

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

This file defines (bounded) lattice homomorphisms.

We use the `fun_like` design, so each type of morphisms has a companion typeclass which is meant to
be satisfied by itself and all stricter types.

## Types of morphisms

* `sup_hom`: Maps which preserve `⊔`.
* `inf_hom`: Maps which preserve `⊓`.
* `sup_bot_hom`: Finitary supremum homomorphisms. Maps which preserve `⊔` and `⊥`.
* `inf_top_hom`: Finitary infimum homomorphisms. Maps which preserve `⊓` and `⊤`.
* `lattice_hom`: Lattice homomorphisms. Maps which preserve `⊔` and `⊓`.
* `bounded_lattice_hom`: Bounded lattice homomorphisms. Maps which preserve `⊤`, `⊥`, `⊔` and `⊓`.

## Typeclasses

* `sup_hom_class`
* `inf_hom_class`
* `sup_bot_hom_class`
* `inf_top_hom_class`
* `lattice_hom_class`
* `bounded_lattice_hom_class`

## TODO

Do we need more intersections between `bot_hom`, `top_hom` and lattice homomorphisms?
-/

open function order_dual

variables {F ι α β γ δ : Type*}

/-- The type of `⊔`-preserving functions from `α` to `β`. -/
structure sup_hom (α β : Type*) [has_sup α] [has_sup β] :=
(to_fun   : α → β)
(map_sup' (a b : α) : to_fun (a ⊔ b) = to_fun a ⊔ to_fun b)

/-- The type of `⊓`-preserving functions from `α` to `β`. -/
structure inf_hom (α β : Type*) [has_inf α] [has_inf β] :=
(to_fun   : α → β)
(map_inf' (a b : α) : to_fun (a ⊓ b) = to_fun a ⊓ to_fun b)

/-- The type of finitary supremum-preserving homomorphisms from `α` to `β`. -/
structure sup_bot_hom (α β : Type*) [has_sup α] [has_sup β] [has_bot α] [has_bot β]
  extends sup_hom α β :=
(map_bot' : to_fun ⊥ = ⊥)

/-- The type of finitary infimum-preserving homomorphisms from `α` to `β`. -/
structure inf_top_hom (α β : Type*) [has_inf α] [has_inf β] [has_top α] [has_top β]
  extends inf_hom α β :=
(map_top' : to_fun ⊤ = ⊤)

/-- The type of lattice homomorphisms from `α` to `β`. -/
structure lattice_hom (α β : Type*) [lattice α] [lattice β] extends sup_hom α β :=
(map_inf' (a b : α) : to_fun (a ⊓ b) = to_fun a ⊓ to_fun b)

/-- The type of bounded lattice homomorphisms from `α` to `β`. -/
structure bounded_lattice_hom (α β : Type*) [lattice α] [lattice β] [bounded_order α]
  [bounded_order β]
  extends lattice_hom α β :=
(map_top' : to_fun ⊤ = ⊤)
(map_bot' : to_fun ⊥ = ⊥)

section
set_option old_structure_cmd true

/-- `sup_hom_class F α β` states that `F` is a type of `⊔`-preserving morphisms.

You should extend this class when you extend `sup_hom`. -/
class sup_hom_class (F : Type*) (α β : out_param $ Type*) [has_sup α] [has_sup β]
  extends fun_like F α (λ _, β) :=
(map_sup (f : F) (a b : α) : f (a ⊔ b) = f a ⊔ f b)

/-- `inf_hom_class F α β` states that `F` is a type of `⊓`-preserving morphisms.

You should extend this class when you extend `inf_hom`. -/
class inf_hom_class (F : Type*) (α β : out_param $ Type*) [has_inf α] [has_inf β]
  extends fun_like F α (λ _, β) :=
(map_inf (f : F) (a b : α) : f (a ⊓ b) = f a ⊓ f b)

/-- `sup_bot_hom_class F α β` states that `F` is a type of finitary supremum-preserving morphisms.

You should extend this class when you extend `sup_bot_hom`. -/
class sup_bot_hom_class (F : Type*) (α β : out_param $ Type*) [has_sup α] [has_sup β] [has_bot α]
  [has_bot β] extends sup_hom_class F α β :=
(map_bot (f : F) : f ⊥ = ⊥)

/-- `inf_top_hom_class F α β` states that `F` is a type of finitary infimum-preserving morphisms.

You should extend this class when you extend `sup_bot_hom`. -/
class inf_top_hom_class (F : Type*) (α β : out_param $ Type*) [has_inf α]
  [has_inf β] [has_top α] [has_top β] extends inf_hom_class F α β :=
(map_top (f : F) : f ⊤ = ⊤)

/-- `lattice_hom_class F α β` states that `F` is a type of lattice morphisms.

You should extend this class when you extend `lattice_hom`. -/
class lattice_hom_class (F : Type*) (α β : out_param $ Type*) [lattice α] [lattice β]
  extends sup_hom_class F α β :=
(map_inf (f : F) (a b : α) : f (a ⊓ b) = f a ⊓ f b)

/-- `bounded_lattice_hom_class F α β` states that `F` is a type of bounded lattice morphisms.

You should extend this class when you extend `bounded_lattice_hom`. -/
class bounded_lattice_hom_class (F : Type*) (α β : out_param $ Type*) [lattice α] [lattice β]
  [bounded_order α] [bounded_order β]
  extends lattice_hom_class F α β :=
(map_top (f : F) : f ⊤ = ⊤)
(map_bot (f : F) : f ⊥ = ⊥)

end

export sup_hom_class (map_sup)
export inf_hom_class (map_inf)

attribute [simp] map_top map_bot map_sup map_inf

@[priority 100] -- See note [lower instance priority]
instance sup_hom_class.to_order_hom_class [semilattice_sup α] [semilattice_sup β]
  [sup_hom_class F α β] :
  order_hom_class F α β :=
{ map_rel := λ f a b h, by rw [←sup_eq_right, ←map_sup, sup_eq_right.2 h],
  ..‹sup_hom_class F α β› }

@[priority 100] -- See note [lower instance priority]
instance inf_hom_class.to_order_hom_class [semilattice_inf α] [semilattice_inf β]
  [inf_hom_class F α β] : order_hom_class F α β :=
{ map_rel := λ f a b h, by rw [←inf_eq_left, ←map_inf, inf_eq_left.2 h]
  ..‹inf_hom_class F α β› }

@[priority 100] -- See note [lower instance priority]
instance sup_bot_hom_class.to_bot_hom_class [has_sup α] [has_sup β] [has_bot α] [has_bot β]
  [sup_bot_hom_class F α β] :
  bot_hom_class F α β :=
{ .. ‹sup_bot_hom_class F α β› }

@[priority 100] -- See note [lower instance priority]
instance inf_top_hom_class.to_top_hom_class [has_inf α] [has_inf β] [has_top α] [has_top β]
  [inf_top_hom_class F α β] :
  top_hom_class F α β :=
{ .. ‹inf_top_hom_class F α β› }

@[priority 100] -- See note [lower instance priority]
instance lattice_hom_class.to_inf_hom_class [lattice α] [lattice β] [lattice_hom_class F α β] :
  inf_hom_class F α β :=
{ .. ‹lattice_hom_class F α β› }

@[priority 100] -- See note [lower instance priority]
instance bounded_lattice_hom_class.to_sup_bot_hom_class [lattice α] [lattice β]
  [bounded_order α] [bounded_order β] [bounded_lattice_hom_class F α β] :
  sup_bot_hom_class F α β :=
{ .. ‹bounded_lattice_hom_class F α β› }

@[priority 100] -- See note [lower instance priority]
instance bounded_lattice_hom_class.to_inf_top_hom_class [lattice α] [lattice β]
  [bounded_order α] [bounded_order β] [bounded_lattice_hom_class F α β] :
  inf_top_hom_class F α β :=
{ .. ‹bounded_lattice_hom_class F α β› }

@[priority 100] -- See note [lower instance priority]
instance bounded_lattice_hom_class.to_bounded_order_hom_class [lattice α] [lattice β]
  [bounded_order α] [bounded_order β] [bounded_lattice_hom_class F α β] :
  bounded_order_hom_class F α β :=
{ .. show order_hom_class F α β, from infer_instance,
  .. ‹bounded_lattice_hom_class F α β› }

@[priority 100] -- See note [lower instance priority]
instance order_iso_class.to_sup_hom_class [semilattice_sup α] [semilattice_sup β]
  [order_iso_class F α β] :
  sup_hom_class F α β :=
{ map_sup := λ f a b, eq_of_forall_ge_iff $ λ c, by simp only [←le_map_inv_iff, sup_le_iff],
  .. show order_hom_class F α β, from infer_instance }

@[priority 100] -- See note [lower instance priority]
instance order_iso_class.to_inf_hom_class [semilattice_inf α] [semilattice_inf β]
  [order_iso_class F α β] :
  inf_hom_class F α β :=
{ map_inf := λ f a b, eq_of_forall_le_iff $ λ c, by simp only [←map_inv_le_iff, le_inf_iff],
  .. show order_hom_class F α β, from infer_instance }

@[priority 100] -- See note [lower instance priority]
instance order_iso_class.to_sup_bot_hom_class [semilattice_sup α] [order_bot α] [semilattice_sup β]
  [order_bot β] [order_iso_class F α β] :
  sup_bot_hom_class F α β :=
{ ..order_iso_class.to_sup_hom_class, ..order_iso_class.to_bot_hom_class }

@[priority 100] -- See note [lower instance priority]
instance order_iso_class.to_inf_top_hom_class [semilattice_inf α] [order_top α] [semilattice_inf β]
  [order_top β] [order_iso_class F α β] :
  inf_top_hom_class F α β :=
{ ..order_iso_class.to_inf_hom_class, ..order_iso_class.to_top_hom_class }

@[priority 100] -- See note [lower instance priority]
instance order_iso_class.to_lattice_hom_class [lattice α] [lattice β] [order_iso_class F α β] :
  lattice_hom_class F α β :=
{ ..order_iso_class.to_sup_hom_class, ..order_iso_class.to_inf_hom_class }

@[priority 100] -- See note [lower instance priority]
instance order_iso_class.to_bounded_lattice_hom_class [lattice α] [lattice β] [bounded_order α]
  [bounded_order β] [order_iso_class F α β] :
  bounded_lattice_hom_class F α β :=
{ ..order_iso_class.to_lattice_hom_class, ..order_iso_class.to_bounded_order_hom_class }

@[simp] lemma map_finset_sup [semilattice_sup α] [order_bot α] [semilattice_sup β] [order_bot β]
  [sup_bot_hom_class F α β] (f : F) (s : finset ι) (g : ι → α) :
  f (s.sup g) = s.sup (f ∘ g) :=
finset.cons_induction_on s (map_bot f) $ λ i s _ h,
  by rw [finset.sup_cons, finset.sup_cons, map_sup, h]

@[simp] lemma map_finset_inf [semilattice_inf α] [order_top α] [semilattice_inf β] [order_top β]
  [inf_top_hom_class F α β] (f : F) (s : finset ι) (g : ι → α) :
  f (s.inf g) = s.inf (f ∘ g) :=
finset.cons_induction_on s (map_top f) $ λ i s _ h,
  by rw [finset.inf_cons, finset.inf_cons, map_inf, h]

section bounded_lattice
variables [lattice α] [bounded_order α] [lattice β] [bounded_order β]
  [bounded_lattice_hom_class F α β] (f : F) {a b : α}
include β

lemma disjoint.map (h : disjoint a b) : disjoint (f a) (f b) :=
by rw [disjoint_iff, ←map_inf, h.eq_bot, map_bot]

lemma codisjoint.map (h : codisjoint a b) : codisjoint (f a) (f b) :=
by rw [codisjoint_iff, ←map_sup, h.eq_top, map_top]

lemma is_compl.map (h : is_compl a b) : is_compl (f a) (f b) := ⟨h.1.map _, h.2.map _⟩

end bounded_lattice

section boolean_algebra
variables [boolean_algebra α] [boolean_algebra β] [bounded_lattice_hom_class F α β] (f : F)
include β

/-- Special case of `map_compl` for boolean algebras. -/
lemma map_compl' (a : α) : f aᶜ = (f a)ᶜ := (is_compl_compl.map _).compl_eq.symm

/-- Special case of `map_sdiff` for boolean algebras. -/
lemma map_sdiff' (a b : α) : f (a \ b) = f a \ f b :=
by rw [sdiff_eq, sdiff_eq, map_inf, map_compl']

/-- Special case of `map_symm_diff` for boolean algebras. -/
lemma map_symm_diff' (a b : α) : f (a ∆ b) = f a ∆ f b :=
by rw [symm_diff, symm_diff, map_sup, map_sdiff', map_sdiff']

end boolean_algebra

instance [has_sup α] [has_sup β] [sup_hom_class F α β] : has_coe_t F (sup_hom α β) :=
⟨λ f, ⟨f, map_sup f⟩⟩

instance [has_inf α] [has_inf β] [inf_hom_class F α β] : has_coe_t F (inf_hom α β) :=
⟨λ f, ⟨f, map_inf f⟩⟩

instance [has_sup α] [has_sup β] [has_bot α] [has_bot β] [sup_bot_hom_class F α β] :
  has_coe_t F (sup_bot_hom α β) :=
⟨λ f, ⟨f, map_bot f⟩⟩

instance [has_inf α] [has_inf β] [has_top α] [has_top β] [inf_top_hom_class F α β] :
  has_coe_t F (inf_top_hom α β) :=
⟨λ f, ⟨f, map_top f⟩⟩

instance [lattice α] [lattice β] [lattice_hom_class F α β] : has_coe_t F (lattice_hom α β) :=
⟨λ f, { to_fun := f, map_sup' := map_sup f, map_inf' := map_inf f }⟩

instance [lattice α] [lattice β] [bounded_order α] [bounded_order β]
  [bounded_lattice_hom_class F α β] : has_coe_t F (bounded_lattice_hom α β) :=
⟨λ f, { to_fun := f, map_top' := map_top f, map_bot' := map_bot f, ..(f : lattice_hom α β) }⟩

/-! ### Supremum homomorphisms -/

namespace sup_hom
variables [has_sup α]

section has_sup
variables [has_sup β] [has_sup γ] [has_sup δ]

instance : sup_hom_class (sup_hom α β) α β :=
{ coe := sup_hom.to_fun,
  coe_injective' := λ f g h, by cases f; cases g; congr',
  map_sup := sup_hom.map_sup' }

/-- Helper instance for when there's too many metavariables to apply `fun_like.has_coe_to_fun`
directly. -/
instance : has_coe_to_fun (sup_hom α β) (λ _, α → β) := ⟨λ f, f.to_fun⟩

@[simp] lemma to_fun_eq_coe {f : sup_hom α β} : f.to_fun = (f : α → β) := rfl

@[ext] lemma ext {f g : sup_hom α β} (h : ∀ a, f a = g a) : f = g := fun_like.ext f g h

/-- Copy of a `sup_hom` with a new `to_fun` equal to the old one. Useful to fix definitional
equalities. -/
protected def copy (f : sup_hom α β) (f' : α → β) (h : f' = f) : sup_hom α β :=
{ to_fun := f',
  map_sup' := h.symm ▸ f.map_sup' }

@[simp] lemma coe_copy (f : sup_hom α β) (f' : α → β) (h : f' = f) : ⇑(f.copy f' h) = f' := rfl

variables (α)

/-- `id` as a `sup_hom`. -/
protected def id : sup_hom α α := ⟨id, λ a b, rfl⟩

instance : inhabited (sup_hom α α) := ⟨sup_hom.id α⟩

@[simp] lemma coe_id : ⇑(sup_hom.id α) = id := rfl

variables {α}

@[simp] lemma id_apply (a : α) : sup_hom.id α a = a := rfl

/-- Composition of `sup_hom`s as a `sup_hom`. -/
def comp (f : sup_hom β γ) (g : sup_hom α β) : sup_hom α γ :=
{ to_fun := f ∘ g,
  map_sup' := λ a b, by rw [comp_apply, map_sup, map_sup] }

@[simp] lemma coe_comp (f : sup_hom β γ) (g : sup_hom α β) : (f.comp g : α → γ) = f ∘ g := rfl
@[simp] lemma comp_apply (f : sup_hom β γ) (g : sup_hom α β) (a : α) :
  (f.comp g) a = f (g a) := rfl
@[simp] lemma comp_assoc (f : sup_hom γ δ) (g : sup_hom β γ) (h : sup_hom α β) :
  (f.comp g).comp h = f.comp (g.comp h) := rfl
@[simp] lemma comp_id (f : sup_hom α β) : f.comp (sup_hom.id α) = f := sup_hom.ext $ λ a, rfl
@[simp] lemma id_comp (f : sup_hom α β) : (sup_hom.id β).comp f = f := sup_hom.ext $ λ a, rfl

lemma cancel_right {g₁ g₂ : sup_hom β γ} {f : sup_hom α β} (hf : surjective f) :
  g₁.comp f = g₂.comp f ↔ g₁ = g₂ :=
⟨λ h, sup_hom.ext $ hf.forall.2 $ fun_like.ext_iff.1 h, congr_arg _⟩

lemma cancel_left {g : sup_hom β γ} {f₁ f₂ : sup_hom α β} (hg : injective g) :
  g.comp f₁ = g.comp f₂ ↔ f₁ = f₂ :=
⟨λ h, sup_hom.ext $ λ a, hg $
  by rw [←sup_hom.comp_apply, h, sup_hom.comp_apply], congr_arg _⟩

end has_sup

variables (α) [semilattice_sup β]

/-- The constant function as a `sup_hom`. -/
def const (b : β) : sup_hom α β := ⟨λ _, b, λ _ _, sup_idem.symm⟩

@[simp] lemma coe_const (b : β) : ⇑(const α b) = function.const α b := rfl
@[simp] lemma const_apply (b : β) (a : α) : const α b a = b := rfl

variables {α}

instance : has_sup (sup_hom α β) :=
⟨λ f g, ⟨f ⊔ g, λ a b, by { rw [pi.sup_apply, map_sup, map_sup], exact sup_sup_sup_comm _ _ _ _ }⟩⟩

instance : semilattice_sup (sup_hom α β) := fun_like.coe_injective.semilattice_sup _ $ λ f g, rfl

instance [has_bot β] : has_bot (sup_hom α β) := ⟨sup_hom.const α ⊥⟩
instance [has_top β] : has_top (sup_hom α β) := ⟨sup_hom.const α ⊤⟩

instance [order_bot β] : order_bot (sup_hom α β) :=
order_bot.lift (coe_fn : _ → α → β) (λ _ _, id) rfl

instance [order_top β] : order_top (sup_hom α β) :=
order_top.lift (coe_fn : _ → α → β) (λ _ _, id) rfl

instance [bounded_order β] : bounded_order (sup_hom α β) :=
bounded_order.lift (coe_fn : _ → α → β) (λ _ _, id) rfl rfl

@[simp] lemma coe_sup (f g : sup_hom α β) : ⇑(f ⊔ g) = f ⊔ g := rfl
@[simp] lemma coe_bot [has_bot β] : ⇑(⊥ : sup_hom α β) = ⊥ := rfl
@[simp] lemma coe_top [has_top β] : ⇑(⊤ : sup_hom α β) = ⊤ := rfl
@[simp] lemma sup_apply (f g : sup_hom α β) (a : α) : (f ⊔ g) a = f a ⊔ g a := rfl
@[simp] lemma bot_apply [has_bot β] (a : α) : (⊥ : sup_hom α β) a = ⊥ := rfl
@[simp] lemma top_apply [has_top β] (a : α) : (⊤ : sup_hom α β) a = ⊤ := rfl

end sup_hom

/-! ### Infimum homomorphisms -/

namespace inf_hom
variables [has_inf α]

section has_inf
variables [has_inf β] [has_inf γ] [has_inf δ]

instance : inf_hom_class (inf_hom α β) α β :=
{ coe := inf_hom.to_fun,
  coe_injective' := λ f g h, by cases f; cases g; congr',
  map_inf := inf_hom.map_inf' }

/-- Helper instance for when there's too many metavariables to apply `fun_like.has_coe_to_fun`
directly. -/
instance : has_coe_to_fun (inf_hom α β) (λ _, α → β) := ⟨λ f, f.to_fun⟩

@[simp] lemma to_fun_eq_coe {f : inf_hom α β} : f.to_fun = (f : α → β) := rfl

@[ext] lemma ext {f g : inf_hom α β} (h : ∀ a, f a = g a) : f = g := fun_like.ext f g h

/-- Copy of an `inf_hom` with a new `to_fun` equal to the old one. Useful to fix definitional
equalities. -/
protected def copy (f : inf_hom α β) (f' : α → β) (h : f' = f) : inf_hom α β :=
{ to_fun := f',
  map_inf' := h.symm ▸ f.map_inf' }

@[simp] lemma coe_copy (f : inf_hom α β) (f' : α → β) (h : f' = f) : ⇑(f.copy f' h) = f' := rfl
lemma copy_eq (f : inf_hom α β) (f' : α → β) (h : f' = f) : f.copy f' h = f := fun_like.ext' h

variables (α)

/-- `id` as an `inf_hom`. -/
protected def id : inf_hom α α := ⟨id, λ a b, rfl⟩

instance : inhabited (inf_hom α α) := ⟨inf_hom.id α⟩

@[simp] lemma coe_id : ⇑(inf_hom.id α) = id := rfl

variables {α}

@[simp] lemma id_apply (a : α) : inf_hom.id α a = a := rfl

/-- Composition of `inf_hom`s as an `inf_hom`. -/
def comp (f : inf_hom β γ) (g : inf_hom α β) : inf_hom α γ :=
{ to_fun := f ∘ g,
  map_inf' := λ a b, by rw [comp_apply, map_inf, map_inf] }

@[simp] lemma coe_comp (f : inf_hom β γ) (g : inf_hom α β) : (f.comp g : α → γ) = f ∘ g := rfl
@[simp] lemma comp_apply (f : inf_hom β γ) (g : inf_hom α β) (a : α) :
  (f.comp g) a = f (g a) := rfl
@[simp] lemma comp_assoc (f : inf_hom γ δ) (g : inf_hom β γ) (h : inf_hom α β) :
  (f.comp g).comp h = f.comp (g.comp h) := rfl
@[simp] lemma comp_id (f : inf_hom α β) : f.comp (inf_hom.id α) = f := inf_hom.ext $ λ a, rfl
@[simp] lemma id_comp (f : inf_hom α β) : (inf_hom.id β).comp f = f := inf_hom.ext $ λ a, rfl

lemma cancel_right {g₁ g₂ : inf_hom β γ} {f : inf_hom α β} (hf : surjective f) :
  g₁.comp f = g₂.comp f ↔ g₁ = g₂ :=
⟨λ h, inf_hom.ext $ hf.forall.2 $ fun_like.ext_iff.1 h, congr_arg _⟩

lemma cancel_left {g : inf_hom β γ} {f₁ f₂ : inf_hom α β} (hg : injective g) :
  g.comp f₁ = g.comp f₂ ↔ f₁ = f₂ :=
⟨λ h, inf_hom.ext $ λ a, hg $
  by rw [←inf_hom.comp_apply, h, inf_hom.comp_apply], congr_arg _⟩

end has_inf

variables (α) [semilattice_inf β]

/-- The constant function as an `inf_hom`. -/
def const (b : β) : inf_hom α β := ⟨λ _, b, λ _ _, inf_idem.symm⟩

@[simp] lemma coe_const (b : β) : ⇑(const α b) = function.const α b := rfl
@[simp] lemma const_apply (b : β) (a : α) : const α b a = b := rfl

variables {α}

instance : has_inf (inf_hom α β) :=
⟨λ f g, ⟨f ⊓ g, λ a b, by { rw [pi.inf_apply, map_inf, map_inf], exact inf_inf_inf_comm _ _ _ _ }⟩⟩

instance : semilattice_inf (inf_hom α β) := fun_like.coe_injective.semilattice_inf _ $ λ f g, rfl

instance [has_bot β] : has_bot (inf_hom α β) := ⟨inf_hom.const α ⊥⟩
instance [has_top β] : has_top (inf_hom α β) := ⟨inf_hom.const α ⊤⟩

instance [order_bot β] : order_bot (inf_hom α β) :=
order_bot.lift (coe_fn : _ → α → β) (λ _ _, id) rfl

instance [order_top β] : order_top (inf_hom α β) :=
order_top.lift (coe_fn : _ → α → β) (λ _ _, id) rfl

instance [bounded_order β] : bounded_order (inf_hom α β) :=
bounded_order.lift (coe_fn : _ → α → β) (λ _ _, id) rfl rfl

@[simp] lemma coe_inf (f g : inf_hom α β) : ⇑(f ⊓ g) = f ⊓ g := rfl
@[simp] lemma coe_bot [has_bot β] : ⇑(⊥ : inf_hom α β) = ⊥ := rfl
@[simp] lemma coe_top [has_top β] : ⇑(⊤ : inf_hom α β) = ⊤ := rfl
@[simp] lemma inf_apply (f g : inf_hom α β) (a : α) : (f ⊓ g) a = f a ⊓ g a := rfl
@[simp] lemma bot_apply [has_bot β] (a : α) : (⊥ : inf_hom α β) a = ⊥ := rfl
@[simp] lemma top_apply [has_top β] (a : α) : (⊤ : inf_hom α β) a = ⊤ := rfl

end inf_hom

/-! ### Finitary supremum homomorphisms -/

namespace sup_bot_hom
variables [has_sup α] [has_bot α]

section has_sup
variables [has_sup β] [has_bot β] [has_sup γ] [has_bot γ] [has_sup δ] [has_bot δ]

/-- Reinterpret a `sup_bot_hom` as a `bot_hom`. -/
def to_bot_hom (f : sup_bot_hom α β) : bot_hom α β := { ..f }

instance : sup_bot_hom_class (sup_bot_hom α β) α β :=
{ coe :=  λ f, f.to_fun,
  coe_injective' := λ f g h, by { obtain ⟨⟨_, _⟩, _⟩ := f, obtain ⟨⟨_, _⟩, _⟩ := g, congr' },
  map_sup := λ f, f.map_sup',
  map_bot := λ f, f.map_bot' }

/-- Helper instance for when there's too many metavariables to apply `fun_like.has_coe_to_fun`
directly. -/
instance : has_coe_to_fun (sup_bot_hom α β) (λ _, α → β) := fun_like.has_coe_to_fun

@[simp] lemma to_fun_eq_coe {f : sup_bot_hom α β} : f.to_fun = (f : α → β) := rfl

@[ext] lemma ext {f g : sup_bot_hom α β} (h : ∀ a, f a = g a) : f = g := fun_like.ext f g h

/-- Copy of a `sup_bot_hom` with a new `to_fun` equal to the old one. Useful to fix definitional
equalities. -/
protected def copy (f : sup_bot_hom α β) (f' : α → β) (h : f' = f) : sup_bot_hom α β :=
{ to_sup_hom := f.to_sup_hom.copy f' h, ..f.to_bot_hom.copy f' h }

@[simp] lemma coe_copy (f : sup_bot_hom α β) (f' : α → β) (h : f' = f) : ⇑(f.copy f' h) = f' := rfl
lemma copy_eq (f : sup_bot_hom α β) (f' : α → β) (h : f' = f) : f.copy f' h = f := fun_like.ext' h

variables (α)

/-- `id` as a `sup_bot_hom`. -/
@[simps] protected def id : sup_bot_hom α α := ⟨sup_hom.id α, rfl⟩

instance : inhabited (sup_bot_hom α α) := ⟨sup_bot_hom.id α⟩

@[simp] lemma coe_id : ⇑(sup_bot_hom.id α) = id := rfl

variables {α}

@[simp] lemma id_apply (a : α) : sup_bot_hom.id α a = a := rfl

/-- Composition of `sup_bot_hom`s as a `sup_bot_hom`. -/
def comp (f : sup_bot_hom β γ) (g : sup_bot_hom α β) : sup_bot_hom α γ :=
{ ..f.to_sup_hom.comp g.to_sup_hom, ..f.to_bot_hom.comp g.to_bot_hom }

@[simp] lemma coe_comp (f : sup_bot_hom β γ) (g : sup_bot_hom α β) : (f.comp g : α → γ) = f ∘ g :=
rfl
@[simp] lemma comp_apply (f : sup_bot_hom β γ) (g : sup_bot_hom α β) (a : α) :
  (f.comp g) a = f (g a) := rfl
@[simp] lemma comp_assoc (f : sup_bot_hom γ δ) (g : sup_bot_hom β γ) (h : sup_bot_hom α β) :
  (f.comp g).comp h = f.comp (g.comp h) := rfl
@[simp] lemma comp_id (f : sup_bot_hom α β) : f.comp (sup_bot_hom.id α) = f := ext $ λ a, rfl
@[simp] lemma id_comp (f : sup_bot_hom α β) : (sup_bot_hom.id β).comp f = f := ext $ λ a, rfl

lemma cancel_right {g₁ g₂ : sup_bot_hom β γ} {f : sup_bot_hom α β} (hf : surjective f) :
  g₁.comp f = g₂.comp f ↔ g₁ = g₂ :=
⟨λ h, ext $ hf.forall.2 $ fun_like.ext_iff.1 h, congr_arg _⟩

lemma cancel_left {g : sup_bot_hom β γ} {f₁ f₂ : sup_bot_hom α β} (hg : injective g) :
  g.comp f₁ = g.comp f₂ ↔ f₁ = f₂ :=
⟨λ h, sup_bot_hom.ext $ λ a, hg $
  by rw [←comp_apply, h, comp_apply], congr_arg _⟩

end has_sup

variables [semilattice_sup β] [order_bot β]

instance : has_sup (sup_bot_hom α β) :=
⟨λ f g, { to_sup_hom := f.to_sup_hom ⊔ g.to_sup_hom, ..f.to_bot_hom ⊔ g.to_bot_hom }⟩

instance : semilattice_sup (sup_bot_hom α β) :=
fun_like.coe_injective.semilattice_sup _ $ λ f g, rfl

instance : order_bot (sup_bot_hom α β) := { bot := ⟨⊥, rfl⟩, bot_le := λ f, bot_le }

@[simp] lemma coe_sup (f g : sup_bot_hom α β) : ⇑(f ⊔ g) = f ⊔ g := rfl
@[simp] lemma coe_bot : ⇑(⊥ : sup_bot_hom α β) = ⊥ := rfl
@[simp] lemma sup_apply (f g : sup_bot_hom α β) (a : α) : (f ⊔ g) a = f a ⊔ g a := rfl
@[simp] lemma bot_apply (a : α) : (⊥ : sup_bot_hom α β) a = ⊥ := rfl

end sup_bot_hom

/-! ### Finitary infimum homomorphisms -/

namespace inf_top_hom
variables [has_inf α] [has_top α]

section has_inf
variables [has_inf β] [has_top β] [has_inf γ] [has_top γ] [has_inf δ] [has_top δ]

/-- Reinterpret an `inf_top_hom` as a `top_hom`. -/
def to_top_hom (f : inf_top_hom α β) : top_hom α β := { ..f }

instance : inf_top_hom_class (inf_top_hom α β) α β :=
{ coe :=  λ f, f.to_fun,
  coe_injective' := λ f g h, by { obtain ⟨⟨_, _⟩, _⟩ := f, obtain ⟨⟨_, _⟩, _⟩ := g, congr' },
  map_inf := λ f, f.map_inf',
  map_top := λ f, f.map_top' }

/-- Helper instance for when there's too many metavariables to apply `fun_like.has_coe_to_fun`
directly. -/
instance : has_coe_to_fun (inf_top_hom α β) (λ _, α → β) := fun_like.has_coe_to_fun

@[simp] lemma to_fun_eq_coe {f : inf_top_hom α β} : f.to_fun = (f : α → β) := rfl

@[ext] lemma ext {f g : inf_top_hom α β} (h : ∀ a, f a = g a) : f = g := fun_like.ext f g h

/-- Copy of an `inf_top_hom` with a new `to_fun` equal to the old one. Useful to fix definitional
equalities. -/
protected def copy (f : inf_top_hom α β) (f' : α → β) (h : f' = f) : inf_top_hom α β :=
{ to_inf_hom := f.to_inf_hom.copy f' h, ..f.to_top_hom.copy f' h }

@[simp] lemma coe_copy (f : inf_top_hom α β) (f' : α → β) (h : f' = f) : ⇑(f.copy f' h) = f' := rfl
lemma copy_eq (f : inf_top_hom α β) (f' : α → β) (h : f' = f) : f.copy f' h = f := fun_like.ext' h

variables (α)

/-- `id` as an `inf_top_hom`. -/
@[simps] protected def id : inf_top_hom α α := ⟨inf_hom.id α, rfl⟩

instance : inhabited (inf_top_hom α α) := ⟨inf_top_hom.id α⟩

@[simp] lemma coe_id : ⇑(inf_top_hom.id α) = id := rfl

variables {α}

@[simp] lemma id_apply (a : α) : inf_top_hom.id α a = a := rfl

/-- Composition of `inf_top_hom`s as an `inf_top_hom`. -/
def comp (f : inf_top_hom β γ) (g : inf_top_hom α β) : inf_top_hom α γ :=
{ ..f.to_inf_hom.comp g.to_inf_hom, ..f.to_top_hom.comp g.to_top_hom }

@[simp] lemma coe_comp (f : inf_top_hom β γ) (g : inf_top_hom α β) : (f.comp g : α → γ) = f ∘ g :=
rfl
@[simp] lemma comp_apply (f : inf_top_hom β γ) (g : inf_top_hom α β) (a : α) :
  (f.comp g) a = f (g a) := rfl
@[simp] lemma comp_assoc (f : inf_top_hom γ δ) (g : inf_top_hom β γ) (h : inf_top_hom α β) :
  (f.comp g).comp h = f.comp (g.comp h) := rfl
@[simp] lemma comp_id (f : inf_top_hom α β) : f.comp (inf_top_hom.id α) = f := ext $ λ a, rfl
@[simp] lemma id_comp (f : inf_top_hom α β) : (inf_top_hom.id β).comp f = f := ext $ λ a, rfl

lemma cancel_right {g₁ g₂ : inf_top_hom β γ} {f : inf_top_hom α β} (hf : surjective f) :
  g₁.comp f = g₂.comp f ↔ g₁ = g₂ :=
⟨λ h, ext $ hf.forall.2 $ fun_like.ext_iff.1 h, congr_arg _⟩

lemma cancel_left {g : inf_top_hom β γ} {f₁ f₂ : inf_top_hom α β} (hg : injective g) :
  g.comp f₁ = g.comp f₂ ↔ f₁ = f₂ :=
⟨λ h, inf_top_hom.ext $ λ a, hg $
  by rw [←comp_apply, h, comp_apply], congr_arg _⟩

end has_inf

variables [semilattice_inf β] [order_top β]

instance : has_inf (inf_top_hom α β) :=
⟨λ f g, { to_inf_hom := f.to_inf_hom ⊓ g.to_inf_hom, ..f.to_top_hom ⊓ g.to_top_hom }⟩

instance : semilattice_inf (inf_top_hom α β) :=
fun_like.coe_injective.semilattice_inf _ $ λ f g, rfl

instance : order_top (inf_top_hom α β) := { top := ⟨⊤, rfl⟩, le_top := λ f, le_top }

@[simp] lemma coe_inf (f g : inf_top_hom α β) : ⇑(f ⊓ g) = f ⊓ g := rfl
@[simp] lemma coe_top : ⇑(⊤ : inf_top_hom α β) = ⊤ := rfl
@[simp] lemma inf_apply (f g : inf_top_hom α β) (a : α) : (f ⊓ g) a = f a ⊓ g a := rfl
@[simp] lemma top_apply (a : α) : (⊤ : inf_top_hom α β) a = ⊤ := rfl

end inf_top_hom

/-! ### Lattice homomorphisms -/

namespace lattice_hom
variables [lattice α] [lattice β] [lattice γ] [lattice δ]

/-- Reinterpret a `lattice_hom` as an `inf_hom`. -/
def to_inf_hom (f : lattice_hom α β) : inf_hom α β := { ..f }

instance : lattice_hom_class (lattice_hom α β) α β :=
{ coe := λ f, f.to_fun,
  coe_injective' := λ f g h, by obtain ⟨⟨_, _⟩, _⟩ := f; obtain ⟨⟨_, _⟩, _⟩ := g; congr',
  map_sup := λ f, f.map_sup',
  map_inf := λ f, f.map_inf' }

/-- Helper instance for when there's too many metavariables to apply `fun_like.has_coe_to_fun`
directly. -/
instance : has_coe_to_fun (lattice_hom α β) (λ _, α → β) := ⟨λ f, f.to_fun⟩

@[simp] lemma to_fun_eq_coe {f : lattice_hom α β} : f.to_fun = (f : α → β) := rfl

@[ext] lemma ext {f g : lattice_hom α β} (h : ∀ a, f a = g a) : f = g := fun_like.ext f g h

/-- Copy of a `lattice_hom` with a new `to_fun` equal to the old one. Useful to fix definitional
equalities. -/
protected def copy (f : lattice_hom α β) (f' : α → β) (h : f' = f) : lattice_hom α β :=
{ .. f.to_sup_hom.copy f' h, .. f.to_inf_hom.copy f' h }

@[simp] lemma coe_copy (f : lattice_hom α β) (f' : α → β) (h : f' = f) : ⇑(f.copy f' h) = f' := rfl
lemma copy_eq (f : lattice_hom α β) (f' : α → β) (h : f' = f) : f.copy f' h = f := fun_like.ext' h

variables (α)

/-- `id` as a `lattice_hom`. -/
protected def id : lattice_hom α α :=
{ to_fun := id,
  map_sup' := λ _ _, rfl,
  map_inf' := λ _ _, rfl }

instance : inhabited (lattice_hom α α) := ⟨lattice_hom.id α⟩

@[simp] lemma coe_id : ⇑(lattice_hom.id α) = id := rfl

variables {α}

@[simp] lemma id_apply (a : α) : lattice_hom.id α a = a := rfl

/-- Composition of `lattice_hom`s as a `lattice_hom`. -/
def comp (f : lattice_hom β γ) (g : lattice_hom α β) : lattice_hom α γ :=
{ ..f.to_sup_hom.comp g.to_sup_hom, ..f.to_inf_hom.comp g.to_inf_hom }

@[simp] lemma coe_comp (f : lattice_hom β γ) (g : lattice_hom α β) : (f.comp g : α → γ) = f ∘ g :=
rfl
@[simp] lemma comp_apply (f : lattice_hom β γ) (g : lattice_hom α β) (a : α) :
  (f.comp g) a = f (g a) := rfl
@[simp] lemma coe_comp_sup_hom (f : lattice_hom β γ) (g : lattice_hom α β) :
  (f.comp g : sup_hom α γ) = (f : sup_hom β γ).comp g := rfl
@[simp] lemma coe_comp_inf_hom (f : lattice_hom β γ) (g : lattice_hom α β) :
  (f.comp g : inf_hom α γ) = (f : inf_hom β γ).comp g := rfl
@[simp] lemma comp_assoc (f : lattice_hom γ δ) (g : lattice_hom β γ) (h : lattice_hom α β) :
  (f.comp g).comp h = f.comp (g.comp h) := rfl
@[simp] lemma comp_id (f : lattice_hom α β) : f.comp (lattice_hom.id α) = f :=
lattice_hom.ext $ λ a, rfl
@[simp] lemma id_comp (f : lattice_hom α β) : (lattice_hom.id β).comp f = f :=
lattice_hom.ext $ λ a, rfl

lemma cancel_right {g₁ g₂ : lattice_hom β γ} {f : lattice_hom α β} (hf : surjective f) :
  g₁.comp f = g₂.comp f ↔ g₁ = g₂ :=
⟨λ h, lattice_hom.ext $ hf.forall.2 $ fun_like.ext_iff.1 h, congr_arg _⟩

lemma cancel_left {g : lattice_hom β γ} {f₁ f₂ : lattice_hom α β} (hg : injective g) :
  g.comp f₁ = g.comp f₂ ↔ f₁ = f₂ :=
⟨λ h, lattice_hom.ext $ λ a, hg $
  by rw [←lattice_hom.comp_apply, h, lattice_hom.comp_apply], congr_arg _⟩

end lattice_hom

namespace order_hom_class
variables (α β) [linear_order α] [lattice β] [order_hom_class F α β]

/-- An order homomorphism from a linear order is a lattice homomorphism. -/
@[reducible] def to_lattice_hom_class : lattice_hom_class F α β :=
{ map_sup := λ f a b, begin
    obtain h | h := le_total a b,
    { rw [sup_eq_right.2 h, sup_eq_right.2 (order_hom_class.mono f h : f a ≤ f b)] },
    { rw [sup_eq_left.2 h, sup_eq_left.2 (order_hom_class.mono f h : f b ≤ f a)] }
  end,
  map_inf := λ f a b, begin
    obtain h | h := le_total a b,
    { rw [inf_eq_left.2 h, inf_eq_left.2 (order_hom_class.mono f h : f a ≤ f b)] },
    { rw [inf_eq_right.2 h, inf_eq_right.2 (order_hom_class.mono f h : f b ≤ f a)] }
  end,
  .. ‹order_hom_class F α β› }

/-- Reinterpret an order homomorphism to a linear order as a `lattice_hom`. -/
def to_lattice_hom (f : F) : lattice_hom α β :=
by { haveI : lattice_hom_class F α β := order_hom_class.to_lattice_hom_class α β, exact f }

@[simp] lemma coe_to_lattice_hom (f : F) : ⇑(to_lattice_hom α β f) = f := rfl
@[simp] lemma to_lattice_hom_apply (f : F) (a : α) : to_lattice_hom α β f a = f a := rfl

end order_hom_class

/-! ### Bounded lattice homomorphisms -/

namespace bounded_lattice_hom
variables [lattice α] [lattice β] [lattice γ] [lattice δ] [bounded_order α] [bounded_order β]
  [bounded_order γ] [bounded_order δ]

/-- Reinterpret a `bounded_lattice_hom` as a `sup_bot_hom`. -/
def to_sup_bot_hom (f : bounded_lattice_hom α β) : sup_bot_hom α β := { ..f }

/-- Reinterpret a `bounded_lattice_hom` as an `inf_top_hom`. -/
def to_inf_top_hom (f : bounded_lattice_hom α β) : inf_top_hom α β := { ..f }

/-- Reinterpret a `bounded_lattice_hom` as a `bounded_order_hom`. -/
def to_bounded_order_hom (f : bounded_lattice_hom α β) : bounded_order_hom α β :=
{ ..f, ..(f.to_lattice_hom : α →o β) }

instance : bounded_lattice_hom_class (bounded_lattice_hom α β) α β :=
{ coe := λ f, f.to_fun,
  coe_injective' := λ f g h, by obtain ⟨⟨⟨_, _⟩, _⟩, _⟩ := f; obtain ⟨⟨⟨_, _⟩, _⟩, _⟩ := g; congr',
  map_sup := λ f, f.map_sup',
  map_inf := λ f, f.map_inf',
  map_top := λ f, f.map_top',
  map_bot := λ f, f.map_bot' }

/-- Helper instance for when there's too many metavariables to apply `fun_like.has_coe_to_fun`
directly. -/
instance : has_coe_to_fun (bounded_lattice_hom α β) (λ _, α → β) := ⟨λ f, f.to_fun⟩

@[simp] lemma to_fun_eq_coe {f : bounded_lattice_hom α β} : f.to_fun = (f : α → β) := rfl

@[ext] lemma ext {f g : bounded_lattice_hom α β} (h : ∀ a, f a = g a) : f = g := fun_like.ext f g h

/-- Copy of a `bounded_lattice_hom` with a new `to_fun` equal to the old one. Useful to fix
definitional equalities. -/
protected def copy (f : bounded_lattice_hom α β) (f' : α → β) (h : f' = f) :
  bounded_lattice_hom α β :=
{ .. f.to_lattice_hom.copy f' h, .. f.to_bounded_order_hom.copy f' h }

@[simp] lemma coe_copy (f : bounded_lattice_hom α β) (f' : α → β) (h : f' = f) :
  ⇑(f.copy f' h) = f' :=
rfl

lemma copy_eq (f : bounded_lattice_hom α β) (f' : α → β) (h : f' = f) : f.copy f' h = f :=
fun_like.ext' h

variables (α)

/-- `id` as a `bounded_lattice_hom`. -/
protected def id : bounded_lattice_hom α α := { ..lattice_hom.id α, ..bounded_order_hom.id α }

instance : inhabited (bounded_lattice_hom α α) := ⟨bounded_lattice_hom.id α⟩

@[simp] lemma coe_id : ⇑(bounded_lattice_hom.id α) = id := rfl

variables {α}

@[simp] lemma id_apply (a : α) : bounded_lattice_hom.id α a = a := rfl

/-- Composition of `bounded_lattice_hom`s as a `bounded_lattice_hom`. -/
def comp (f : bounded_lattice_hom β γ) (g : bounded_lattice_hom α β) : bounded_lattice_hom α γ :=
{ ..f.to_lattice_hom.comp g.to_lattice_hom, ..f.to_bounded_order_hom.comp g.to_bounded_order_hom }

@[simp] lemma coe_comp (f : bounded_lattice_hom β γ) (g : bounded_lattice_hom α β) :
  (f.comp g : α → γ) = f ∘ g := rfl
@[simp] lemma comp_apply (f : bounded_lattice_hom β γ) (g : bounded_lattice_hom α β) (a : α) :
  (f.comp g) a = f (g a) := rfl
@[simp] lemma coe_comp_lattice_hom (f : bounded_lattice_hom β γ) (g : bounded_lattice_hom α β) :
  (f.comp g : lattice_hom α γ) = (f : lattice_hom β γ).comp g := rfl
@[simp] lemma coe_comp_sup_hom (f : bounded_lattice_hom β γ) (g : bounded_lattice_hom α β) :
  (f.comp g : sup_hom α γ) = (f : sup_hom β γ).comp g := rfl
@[simp] lemma coe_comp_inf_hom (f : bounded_lattice_hom β γ) (g : bounded_lattice_hom α β) :
  (f.comp g : inf_hom α γ) = (f : inf_hom β γ).comp g := rfl
@[simp] lemma comp_assoc (f : bounded_lattice_hom γ δ) (g : bounded_lattice_hom β γ)
  (h : bounded_lattice_hom α β) :
  (f.comp g).comp h = f.comp (g.comp h) := rfl
@[simp] lemma comp_id (f : bounded_lattice_hom α β) : f.comp (bounded_lattice_hom.id α) = f :=
bounded_lattice_hom.ext $ λ a, rfl
@[simp] lemma id_comp (f : bounded_lattice_hom α β) : (bounded_lattice_hom.id β).comp f = f :=
bounded_lattice_hom.ext $ λ a, rfl

lemma cancel_right {g₁ g₂ : bounded_lattice_hom β γ} {f : bounded_lattice_hom α β}
  (hf : surjective f) :
  g₁.comp f = g₂.comp f ↔ g₁ = g₂ :=
⟨λ h, bounded_lattice_hom.ext $ hf.forall.2 $ fun_like.ext_iff.1 h, congr_arg _⟩

lemma cancel_left {g : bounded_lattice_hom β γ} {f₁ f₂ : bounded_lattice_hom α β}
  (hg : injective g) :
  g.comp f₁ = g.comp f₂ ↔ f₁ = f₂ :=
⟨λ h, ext $ λ a, hg $ by rw [←comp_apply, h, comp_apply], congr_arg _⟩

end bounded_lattice_hom

/-! ### Dual homs -/

namespace sup_hom
variables [has_sup α] [has_sup β] [has_sup γ]

/-- Reinterpret a supremum homomorphism as an infimum homomorphism between the dual lattices. -/
@[simps] protected def dual : sup_hom α β ≃ inf_hom αᵒᵈ βᵒᵈ :=
{ to_fun := λ f, ⟨f, f.map_sup'⟩,
  inv_fun := λ f, ⟨f, f.map_inf'⟩,
  left_inv := λ f, sup_hom.ext $ λ _, rfl,
  right_inv := λ f, inf_hom.ext $ λ _, rfl }

@[simp] lemma dual_id : (sup_hom.id α).dual = inf_hom.id _ := rfl
@[simp] lemma dual_comp (g : sup_hom β γ) (f : sup_hom α β) :
  (g.comp f).dual = g.dual.comp f.dual := rfl

@[simp] lemma symm_dual_id : sup_hom.dual.symm (inf_hom.id _) = sup_hom.id α := rfl
@[simp] lemma symm_dual_comp (g : inf_hom βᵒᵈ γᵒᵈ) (f : inf_hom αᵒᵈ βᵒᵈ) :
  sup_hom.dual.symm (g.comp f) = (sup_hom.dual.symm g).comp (sup_hom.dual.symm f) := rfl

end sup_hom

namespace inf_hom
variables [has_inf α] [has_inf β] [has_inf γ]

/-- Reinterpret an infimum homomorphism as a supremum homomorphism between the dual lattices. -/
@[simps] protected def dual : inf_hom α β ≃ sup_hom αᵒᵈ βᵒᵈ :=
{ to_fun := λ f, ⟨f, f.map_inf'⟩,
  inv_fun := λ f, ⟨f, f.map_sup'⟩,
  left_inv := λ f, inf_hom.ext $ λ _, rfl,
  right_inv := λ f, sup_hom.ext $ λ _, rfl }

@[simp] lemma dual_id : (inf_hom.id α).dual = sup_hom.id _ := rfl
@[simp] lemma dual_comp (g : inf_hom β γ) (f : inf_hom α β) :
  (g.comp f).dual = g.dual.comp f.dual := rfl

@[simp] lemma symm_dual_id : inf_hom.dual.symm (sup_hom.id _) = inf_hom.id α := rfl
@[simp] lemma symm_dual_comp (g : sup_hom βᵒᵈ γᵒᵈ) (f : sup_hom αᵒᵈ βᵒᵈ) :
  inf_hom.dual.symm (g.comp f) = (inf_hom.dual.symm g).comp (inf_hom.dual.symm f) := rfl

end inf_hom

namespace sup_bot_hom
variables [has_sup α] [has_bot α] [has_sup β] [has_bot β] [has_sup γ] [has_bot γ]

/-- Reinterpret a finitary supremum homomorphism as a finitary infimum homomorphism between the dual
lattices. -/
def dual : sup_bot_hom α β ≃ inf_top_hom αᵒᵈ βᵒᵈ :=
{ to_fun := λ f, ⟨f.to_sup_hom.dual, f.map_bot'⟩,
  inv_fun := λ f, ⟨sup_hom.dual.symm f.to_inf_hom, f.map_top'⟩,
  left_inv := λ f, sup_bot_hom.ext $ λ _, rfl,
  right_inv := λ f, inf_top_hom.ext $ λ _, rfl }

@[simp] lemma dual_id : (sup_bot_hom.id α).dual = inf_top_hom.id _ := rfl
@[simp] lemma dual_comp (g : sup_bot_hom β γ) (f : sup_bot_hom α β) :
  (g.comp f).dual = g.dual.comp f.dual := rfl

@[simp] lemma symm_dual_id : sup_bot_hom.dual.symm (inf_top_hom.id _) = sup_bot_hom.id α := rfl
@[simp] lemma symm_dual_comp (g : inf_top_hom βᵒᵈ γᵒᵈ) (f : inf_top_hom αᵒᵈ βᵒᵈ) :
  sup_bot_hom.dual.symm (g.comp f) = (sup_bot_hom.dual.symm g).comp (sup_bot_hom.dual.symm f) := rfl

end sup_bot_hom

namespace inf_top_hom
variables [has_inf α] [has_top α] [has_inf β] [has_top β] [has_inf γ] [has_top γ]

/-- Reinterpret a finitary infimum homomorphism as a finitary supremum homomorphism between the dual
lattices. -/
@[simps] protected def dual : inf_top_hom α β ≃ sup_bot_hom αᵒᵈ βᵒᵈ :=
{ to_fun := λ f, ⟨f.to_inf_hom.dual, f.map_top'⟩,
  inv_fun := λ f, ⟨inf_hom.dual.symm f.to_sup_hom, f.map_bot'⟩,
  left_inv := λ f, inf_top_hom.ext $ λ _, rfl,
  right_inv := λ f, sup_bot_hom.ext $ λ _, rfl }

@[simp] lemma dual_id : (inf_top_hom.id α).dual = sup_bot_hom.id _ := rfl
@[simp] lemma dual_comp (g : inf_top_hom β γ) (f : inf_top_hom α β) :
  (g.comp f).dual = g.dual.comp f.dual := rfl

@[simp] lemma symm_dual_id : inf_top_hom.dual.symm (sup_bot_hom.id _) = inf_top_hom.id α := rfl
@[simp] lemma symm_dual_comp (g : sup_bot_hom βᵒᵈ γᵒᵈ) (f : sup_bot_hom αᵒᵈ βᵒᵈ) :
  inf_top_hom.dual.symm (g.comp f) = (inf_top_hom.dual.symm g).comp (inf_top_hom.dual.symm f) := rfl

end inf_top_hom

namespace lattice_hom
variables [lattice α] [lattice β] [lattice γ]

/-- Reinterpret a lattice homomorphism as a lattice homomorphism between the dual lattices. -/
@[simps] protected def dual : lattice_hom α β ≃ lattice_hom αᵒᵈ βᵒᵈ :=
{ to_fun := λ f, ⟨f.to_inf_hom.dual, f.map_sup'⟩,
  inv_fun := λ f, ⟨f.to_inf_hom.dual, f.map_sup'⟩,
  left_inv := λ f, ext $ λ a, rfl,
  right_inv := λ f, ext $ λ a, rfl }

@[simp] lemma dual_id : (lattice_hom.id α).dual = lattice_hom.id _ := rfl
@[simp] lemma dual_comp (g : lattice_hom β γ) (f : lattice_hom α β) :
  (g.comp f).dual = g.dual.comp f.dual := rfl

@[simp] lemma symm_dual_id : lattice_hom.dual.symm (lattice_hom.id _) = lattice_hom.id α := rfl
@[simp] lemma symm_dual_comp (g : lattice_hom βᵒᵈ γᵒᵈ) (f : lattice_hom αᵒᵈ βᵒᵈ) :
  lattice_hom.dual.symm (g.comp f) = (lattice_hom.dual.symm g).comp (lattice_hom.dual.symm f) := rfl

end lattice_hom

namespace bounded_lattice_hom
variables [lattice α] [bounded_order α] [lattice β] [bounded_order β] [lattice γ] [bounded_order γ]

/-- Reinterpret a bounded lattice homomorphism as a bounded lattice homomorphism between the dual
bounded lattices. -/
@[simps] protected def dual : bounded_lattice_hom α β ≃ bounded_lattice_hom αᵒᵈ βᵒᵈ :=
{ to_fun := λ f, ⟨f.to_lattice_hom.dual, f.map_bot', f.map_top'⟩,
  inv_fun := λ f, ⟨lattice_hom.dual.symm f.to_lattice_hom, f.map_bot', f.map_top'⟩,
  left_inv := λ f, ext $ λ a, rfl,
  right_inv := λ f, ext $ λ a, rfl }

@[simp] lemma dual_id : (bounded_lattice_hom.id α).dual = bounded_lattice_hom.id _ := rfl
@[simp] lemma dual_comp (g : bounded_lattice_hom β γ) (f : bounded_lattice_hom α β) :
  (g.comp f).dual = g.dual.comp f.dual := rfl

@[simp] lemma symm_dual_id :
  bounded_lattice_hom.dual.symm (bounded_lattice_hom.id _) = bounded_lattice_hom.id α := rfl
@[simp] lemma symm_dual_comp (g : bounded_lattice_hom βᵒᵈ γᵒᵈ) (f : bounded_lattice_hom αᵒᵈ βᵒᵈ) :
  bounded_lattice_hom.dual.symm (g.comp f) =
    (bounded_lattice_hom.dual.symm g).comp (bounded_lattice_hom.dual.symm f) := rfl

end bounded_lattice_hom


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

! This file was ported from Lean 3 source module category_theory.category.ulift
! leanprover-community/mathlib commit 32253a1a1071173b33dc7d6a218cf722c6feb514
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.CategoryTheory.Category.Basic
import Mathlib.CategoryTheory.Equivalence
import Mathlib.CategoryTheory.EqToHom
import Mathlib.Data.ULift

/-!
# Basic API for ULift

This file contains a very basic API for working with the categorical
instance on `ULift C` where `C` is a type with a category instance.

1. `category_theory.ULift.up` is the functorial version of the usual `ULift.up`.
2. `category_theory.ULift.down` is the functorial version of the usual `ULift.down`.
3. `category_theory.ULift.equivalence` is the categorical equivalence between
  `C` and `ULift C`.

# ULiftHom

Given a type `C : Type u`, `ULiftHom.{w} C` is just an alias for `C`.
If we have `category.{v} C`, then `ULiftHom.{w} C` is endowed with a category instance
whose morphisms are obtained by applying `ULift.{w}` to the morphisms from `C`.

This is a category equivalent to `C`. The forward direction of the equivalence is `ULiftHom.up`,
the backward direction is `ULiftHom.donw` and the equivalence is `ULiftHom.equiv`.

# AsSmall

This file also contains a construction which takes a type `C : Type u` with a
category instance `category.{v} C` and makes a small category
`AsSmall.{w} C : Type (max w v u)` equivalent to `C`.

The forward direction of the equivalence, `C ⥤ AsSmall C`, is denoted `AsSmall.up`
and the backward direction is `AsSmall.down`. The equivalence itself is `AsSmall.equiv`.
-/

universe w₁ v₁ v₂ u₁ u₂

namespace CategoryTheory

variable {C : Type u₁} [Category.{v₁} C]

/-- The functorial version of `ULift.up`. -/
@[simps]
def ULift.upFunctor : C ⥤ ULift.{u₂} C where
  obj := ULift.up
  map f := f
#align category_theory.ulift.up_functor CategoryTheory.ULift.upFunctor

/-- The functorial version of `ULift.down`. -/
@[simps]
def ULift.downFunctor : ULift.{u₂} C ⥤ C where
  obj := ULift.down
  map f := f
#align category_theory.ulift.down_functor CategoryTheory.ULift.downFunctor

/-- The categorical equivalence between `C` and `ULift C`. -/
@[simps]
def ULift.equivalence : C ≌ ULift.{u₂} C where
  functor := ULift.upFunctor
  inverse := ULift.downFunctor
  unitIso :=
    { hom := 𝟙 _
      inv := 𝟙 _ }
  counitIso :=
    { hom :=
        { app := fun X => 𝟙 _
          naturality := fun X Y f => by
            change f ≫ 𝟙 _ = 𝟙 _ ≫ f
            simp }
      inv :=
        { app := fun X => 𝟙 _
          naturality := fun X Y f => by
            change f ≫ 𝟙 _ = 𝟙 _ ≫ f
            simp }
      hom_inv_id := by
        ext
        change 𝟙 _ ≫ 𝟙 _ = 𝟙 _
        simp
      inv_hom_id := by
        ext
        change 𝟙 _ ≫ 𝟙 _ = 𝟙 _
        simp }
  functor_unitIso_comp X := by
    change 𝟙 X ≫ 𝟙 X = 𝟙 X
    simp
#align category_theory.ulift.equivalence CategoryTheory.ULift.equivalence

section ULiftHom
/- Porting note: obviously we don't want code that looks like this long term
the ability to turn off unused universe parameter error is desirable -/
/-- `ULiftHom.{w} C` is an alias for `C`, which is endowed with a category instance
  whose morphisms are obtained by applying `ULift.{w}` to the morphisms from `C`.
-/
def ULiftHom.{w,u} (C : Type u) : Type u :=
  let _ := ULift.{w} C
  C
#align category_theory.ulift_hom CategoryTheory.ULiftHom

instance {C} [Inhabited C] : Inhabited (ULiftHom C) :=
  ⟨(default : C)⟩

/-- The obvious function `ULiftHom C → C`. -/
def ULiftHom.objDown {C} (A : ULiftHom C) : C :=
  A
#align category_theory.ulift_hom.obj_down CategoryTheory.ULiftHom.objDown

/-- The obvious function `C → ULiftHom C`. -/
def ULiftHom.objUp {C} (A : C) : ULiftHom C :=
  A
#align category_theory.ulift_hom.obj_up CategoryTheory.ULiftHom.objUp

@[simp]
theorem objDown_objUp {C} (A : C) : (ULiftHom.objUp A).objDown = A :=
  rfl
#align category_theory.obj_down_obj_up CategoryTheory.objDown_objUp

@[simp]
theorem objUp_objDown {C} (A : ULiftHom C) : ULiftHom.objUp A.objDown = A :=
  rfl
#align category_theory.obj_up_obj_down CategoryTheory.objUp_objDown

instance ULiftHom.category : Category.{max v₂ v₁} (ULiftHom.{v₂} C) where
  Hom A B := ULift.{v₂} <| A.objDown ⟶ B.objDown
  id A := ⟨𝟙 _⟩
  comp f g := ⟨f.down ≫ g.down⟩

/-- One half of the quivalence between `C` and `ULiftHom C`. -/
@[simps]
def ULiftHom.up : C ⥤ ULiftHom C where
  obj := ULiftHom.objUp
  map f := ⟨f⟩
#align category_theory.ulift_hom.up CategoryTheory.ULiftHom.up

/-- One half of the quivalence between `C` and `ULiftHom C`. -/
@[simps]
def ULiftHom.down : ULiftHom C ⥤ C where
  obj := ULiftHom.objDown
  map f := f.down
#align category_theory.ulift_hom.down CategoryTheory.ULiftHom.down

/-- The equivalence between `C` and `ULiftHom C`. -/
def ULiftHom.equiv : C ≌ ULiftHom C where
  functor := ULiftHom.up
  inverse := ULiftHom.down
  unitIso := NatIso.ofComponents (fun A => eqToIso rfl) (by aesop_cat)
  counitIso := NatIso.ofComponents (fun A => eqToIso rfl) (by aesop_cat)
#align category_theory.ulift_hom.equiv CategoryTheory.ULiftHom.equiv

end ULiftHom
/- Porting note: we want to keep around the category instance on `D`
so Lean can figure out things further down. So `AsSmall` has been
nolinted. -/
/-- `AsSmall C` is a small category equivalent to `C`.
  More specifically, if `C : Type u` is endowed with `Category.{v} C`, then
  `AsSmall.{w} C : Type (max w v u)` is endowed with an instance of a small category.

  The objects and morphisms of `AsSmall C` are defined by applying `ULift` to the
  objects and morphisms of `C`.

  Note: We require a category instance for this definition in order to have direct
  access to the universe level `v`.
-/
@[nolint unusedArguments]
def AsSmall.{w, v, u} (D : Type u) [Category.{v} D] := ULift.{max w v} D
#align category_theory.as_small CategoryTheory.AsSmall

instance : SmallCategory (AsSmall.{w₁} C) where
  Hom X Y := ULift.{max w₁ u₁} <| X.down ⟶ Y.down
  id X := ⟨𝟙 _⟩
  comp f g := ⟨f.down ≫ g.down⟩

/-- One half of the equivalence between `C` and `AsSmall C`. -/
@[simps]
def AsSmall.up : C ⥤ AsSmall C where
  obj X := ⟨X⟩
  map f := ⟨f⟩
#align category_theory.as_small.up CategoryTheory.AsSmall.up

/-- One half of the equivalence between `C` and `AsSmall C`. -/
@[simps]
def AsSmall.down : AsSmall C ⥤ C where
  obj X := ULift.down X
  map f := f.down
#align category_theory.as_small.down CategoryTheory.AsSmall.down

/-- The equivalence between `C` and `AsSmall C`. -/
@[simps]
def AsSmall.equiv : C ≌ AsSmall C where
  functor := AsSmall.up
  inverse := AsSmall.down
  unitIso := NatIso.ofComponents (fun X => eqToIso rfl) (by aesop_cat)
  counitIso :=
    NatIso.ofComponents
      (fun X =>
        eqToIso <| by
          apply ULift.ext
          rfl)
      (by aesop_cat)
#align category_theory.as_small.equiv CategoryTheory.AsSmall.equiv

instance [Inhabited C] : Inhabited (AsSmall C) :=
  ⟨⟨default⟩⟩

/-- The equivalence between `C` and `ULiftHom (ULift C)`. -/
def ULiftHomULiftCategory.equiv.{v', u', v, u} (C : Type u) [Category.{v} C] :
    C ≌ ULiftHom.{v'} (ULift.{u'} C) :=
  ULift.equivalence.trans ULiftHom.equiv
#align category_theory.ulift_hom_ulift_category.equiv CategoryTheory.ULiftHomULiftCategory.equiv

end CategoryTheory


/-
Copyright (c) 2014 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro
-/
import data.num.basic
import data.bitvec.core

/-!
# Bitwise operations using binary representation of integers

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

## Definitions

* bitwise operations for `pos_num` and `num`,
* `snum`, a type that represents integers as a bit string with a sign bit at the end,
* arithmetic operations for `snum`.
-/

namespace pos_num

  /-- Bitwise "or" for `pos_num`. -/
  def lor : pos_num → pos_num → pos_num
  | 1        (bit0 q) := bit1 q
  | 1        q        := q
  | (bit0 p) 1        := bit1 p
  | p        1        := p
  | (bit0 p) (bit0 q) := bit0 (lor p q)
  | (bit0 p) (bit1 q) := bit1 (lor p q)
  | (bit1 p) (bit0 q) := bit1 (lor p q)
  | (bit1 p) (bit1 q) := bit1 (lor p q)

  /-- Bitwise "and" for `pos_num`. -/
  def land : pos_num → pos_num → num
  | 1        (bit0 q) := 0
  | 1        _        := 1
  | (bit0 p) 1        := 0
  | _        1        := 1
  | (bit0 p) (bit0 q) := num.bit0 (land p q)
  | (bit0 p) (bit1 q) := num.bit0 (land p q)
  | (bit1 p) (bit0 q) := num.bit0 (land p q)
  | (bit1 p) (bit1 q) := num.bit1 (land p q)

  /-- Bitwise `λ a b, a && !b` for `pos_num`. For example, `ldiff 5 9 = 4`:

     101
    1001
    ----
     100

  -/
  def ldiff : pos_num → pos_num → num
  | 1        (bit0 q) := 1
  | 1        _        := 0
  | (bit0 p) 1        := num.pos (bit0 p)
  | (bit1 p) 1        := num.pos (bit0 p)
  | (bit0 p) (bit0 q) := num.bit0 (ldiff p q)
  | (bit0 p) (bit1 q) := num.bit0 (ldiff p q)
  | (bit1 p) (bit0 q) := num.bit1 (ldiff p q)
  | (bit1 p) (bit1 q) := num.bit0 (ldiff p q)

  /-- Bitwise "xor" for `pos_num`. -/
  def lxor : pos_num → pos_num → num
  | 1        1        := 0
  | 1        (bit0 q) := num.pos (bit1 q)
  | 1        (bit1 q) := num.pos (bit0 q)
  | (bit0 p) 1        := num.pos (bit1 p)
  | (bit1 p) 1        := num.pos (bit0 p)
  | (bit0 p) (bit0 q) := num.bit0 (lxor p q)
  | (bit0 p) (bit1 q) := num.bit1 (lxor p q)
  | (bit1 p) (bit0 q) := num.bit1 (lxor p q)
  | (bit1 p) (bit1 q) := num.bit0 (lxor p q)

  /-- `a.test_bit n` is `tt` iff the `n`-th bit (starting from the LSB) in the binary representation
      of `a` is active. If the size of `a` is less than `n`, this evaluates to `ff`. -/
  def test_bit : pos_num → nat → bool
  | 1        0     := tt
  | 1        (n+1) := ff
  | (bit0 p) 0     := ff
  | (bit0 p) (n+1) := test_bit p n
  | (bit1 p) 0     := tt
  | (bit1 p) (n+1) := test_bit p n

  /-- `n.one_bits 0` is the list of indices of active bits in the binary representation of `n`. -/
  def one_bits : pos_num → nat → list nat
  | 1        d := [d]
  | (bit0 p) d := one_bits p (d+1)
  | (bit1 p) d := d :: one_bits p (d+1)

  /-- Left-shift the binary representation of a `pos_num`. -/
  def shiftl (p : pos_num) : nat → pos_num
  | 0     := p
  | (n+1) := bit0 (shiftl n)

  /-- Right-shift the binary representation of a `pos_num`. -/
  def shiftr : pos_num → nat → num
  | p        0     := num.pos p
  | 1        (n+1) := 0
  | (bit0 p) (n+1) := shiftr p n
  | (bit1 p) (n+1) := shiftr p n

end pos_num

namespace num

  /-- Bitwise "or" for `num`. -/
  def lor : num → num → num
  | 0       q       := q
  | p       0       := p
  | (pos p) (pos q) := pos (p.lor q)

  /-- Bitwise "and" for `num`. -/
  def land : num → num → num
  | 0       q       := 0
  | p       0       := 0
  | (pos p) (pos q) := p.land q

  /-- Bitwise `λ a b, a && !b` for `num`. For example, `ldiff 5 9 = 4`:

     101
    1001
    ----
     100

  -/
  def ldiff : num → num → num
  | 0       q       := 0
  | p       0       := p
  | (pos p) (pos q) := p.ldiff q

  /-- Bitwise "xor" for `num`. -/
  def lxor : num → num → num
  | 0       q       := q
  | p       0       := p
  | (pos p) (pos q) := p.lxor q

  /-- Left-shift the binary representation of a `num`. -/
  def shiftl : num → nat → num
  | 0       n := 0
  | (pos p) n := pos (p.shiftl n)

  /-- Right-shift the binary representation of a `pos_num`. -/
  def shiftr : num → nat → num
  | 0       n := 0
  | (pos p) n := p.shiftr n

  /-- `a.test_bit n` is `tt` iff the `n`-th bit (starting from the LSB) in the binary representation
      of `a` is active. If the size of `a` is less than `n`, this evaluates to `ff`. -/
  def test_bit : num → nat → bool
  | 0       n := ff
  | (pos p) n := p.test_bit n

  /-- `n.one_bits` is the list of indices of active bits in the binary representation of `n`. -/
  def one_bits : num → list nat
  | 0       := []
  | (pos p) := p.one_bits 0

end num

/-- This is a nonzero (and "non minus one") version of `snum`.
    See the documentation of `snum` for more details. -/
@[derive has_reflect, derive decidable_eq]
inductive nzsnum : Type
| msb : bool → nzsnum
| bit : bool → nzsnum → nzsnum

/-- Alternative representation of integers using a sign bit at the end.
  The convention on sign here is to have the argument to `msb` denote
  the sign of the MSB itself, with all higher bits set to the negation
  of this sign. The result is interpreted in two's complement.

     13  = ..0001101(base 2) = nz (bit1 (bit0 (bit1 (msb tt))))
     -13 = ..1110011(base 2) = nz (bit1 (bit1 (bit0 (msb ff))))

  As with `num`, a special case must be added for zero, which has no msb,
  but by two's complement symmetry there is a second special case for -1.
  Here the `bool` field indicates the sign of the number.

     0  = ..0000000(base 2) = zero ff
     -1 = ..1111111(base 2) = zero tt -/
@[derive has_reflect, derive decidable_eq]
inductive snum : Type
| zero : bool → snum
| nz : nzsnum → snum
instance : has_coe nzsnum snum := ⟨snum.nz⟩
instance : has_zero snum := ⟨snum.zero ff⟩
instance : has_one nzsnum := ⟨nzsnum.msb tt⟩
instance : has_one snum := ⟨snum.nz 1⟩
instance : inhabited nzsnum := ⟨1⟩
instance : inhabited snum := ⟨0⟩

/-!
The `snum` representation uses a bit string, essentially a list of 0 (`ff`) and 1 (`tt`) bits,
and the negation of the MSB is sign-extended to all higher bits.
-/
namespace nzsnum
  notation (name := nznum.bit) a :: b := bit a b

  /-- Sign of a `nzsnum`. -/
  def sign : nzsnum → bool
  | (msb b) := bnot b
  | (b :: p) := sign p

  /-- Bitwise `not` for `nzsnum`. -/
  @[pattern] def not : nzsnum → nzsnum
  | (msb b) := msb (bnot b)
  | (b :: p) := bnot b :: not p
  prefix `~`:100 := not

  /-- Add an inactive bit at the end of a `nzsnum`. This mimics `pos_num.bit0`. -/
  def bit0 : nzsnum → nzsnum := bit ff

  /-- Add an active bit at the end of a `nzsnum`. This mimics `pos_num.bit1`. -/
  def bit1 : nzsnum → nzsnum := bit tt

  /-- The `head` of a `nzsnum` is the boolean value of its LSB. -/
  def head : nzsnum → bool
  | (msb b)  := b
  | (b :: p) := b

  /-- The `tail` of a `nzsnum` is the `snum` obtained by removing the LSB.
      Edge cases: `tail 1 = 0` and `tail (-2) = -1`. -/
  def tail : nzsnum → snum
  | (msb b)  := snum.zero (bnot b)
  | (b :: p) := p

end nzsnum

namespace snum
  open nzsnum

  /-- Sign of a `snum`. -/
  def sign : snum → bool
  | (zero z) := z
  | (nz p)   := p.sign

  /-- Bitwise `not` for `snum`. -/
  @[pattern] def not : snum → snum
  | (zero z) := zero (bnot z)
  | (nz p)   := ~p
  prefix (name := snum.not) ~ := not

  /-- Add a bit at the end of a `snum`. This mimics `nzsnum.bit`. -/
  @[pattern] def bit : bool → snum → snum
  | b (zero z) := if b = z then zero b else msb b
  | b (nz p)   := p.bit b

  notation (name := snum.bit) a :: b := bit a b

  /-- Add an inactive bit at the end of a `snum`. This mimics `znum.bit0`. -/
  def bit0 : snum → snum := bit ff

  /-- Add an active bit at the end of a `snum`. This mimics `znum.bit1`. -/
  def bit1 : snum → snum := bit tt

  theorem bit_zero (b) : b :: zero b = zero b := by cases b; refl

  theorem bit_one (b) : b :: zero (bnot b) = msb b := by cases b; refl

end snum

namespace nzsnum
  open snum

  /-- A dependent induction principle for `nzsnum`, with base cases
      `0 : snum` and `(-1) : snum`. -/
  def drec' {C : snum → Sort*} (z : Π b, C (snum.zero b))
    (s : Π b p, C p → C (b :: p)) : Π p : nzsnum, C p
  | (msb b)  := by rw ←bit_one; exact s b (snum.zero (bnot b)) (z (bnot b))
  | (bit b p) := s b p (drec' p)
end nzsnum

namespace snum
  open nzsnum

  /-- The `head` of a `snum` is the boolean value of its LSB. -/
  def head : snum → bool
  | (zero z) := z
  | (nz p)   := p.head

  /-- The `tail` of a `snum` is obtained by removing the LSB.
      Edge cases: `tail 1 = 0`, `tail (-2) = -1`, `tail 0 = 0` and `tail (-1) = -1`. -/
  def tail : snum → snum
  | (zero z) := zero z
  | (nz p)   := p.tail

  /-- A dependent induction principle for `snum` which avoids relying on `nzsnum`. -/
  def drec' {C : snum → Sort*} (z : Π b, C (snum.zero b))
    (s : Π b p, C p → C (b :: p)) : Π p, C p
  | (zero b) := z b
  | (nz p)   := p.drec' z s

  /-- An induction principle for `snum` which avoids relying on `nzsnum`. -/
  def rec' {α} (z : bool → α) (s : bool → snum → α → α) : snum → α :=
  drec' z s

  /-- `snum.test_bit n a` is `tt` iff the `n`-th bit (starting from the LSB) of `a` is active.
      If the size of `a` is less than `n`, this evaluates to `ff`. -/
  def test_bit : nat → snum → bool
  | 0     p := head p
  | (n+1) p := test_bit n (tail p)

  /-- The successor of a `snum` (i.e. the operation adding one). -/
  def succ : snum → snum :=
  rec' (λ b, cond b 0 1) (λb p succp, cond b (ff :: succp) (tt :: p))

  /-- The predecessor of a `snum` (i.e. the operation of removing one). -/
  def pred : snum → snum :=
  rec' (λ b, cond b (~1) ~0) (λb p predp, cond b (ff :: p) (tt :: predp))

  /-- The opposite of a `snum`. -/
  protected def neg (n : snum) : snum := succ ~n

  instance : has_neg snum := ⟨snum.neg⟩

  /-- `snum.czadd a b n` is `n + a - b` (where `a` and `b` should be read as either 0 or 1).
      This is useful to implement the carry system in `cadd`. -/
  def czadd : bool → bool → snum → snum
  | ff ff p := p
  | ff tt p := pred p
  | tt ff p := succ p
  | tt tt p := p

end snum

namespace snum

/-- `a.bits n` is the vector of the `n` first bits of `a` (starting from the LSB). -/
def bits : snum → Π n, vector bool n
| p 0     := vector.nil
| p (n+1) := head p ::ᵥ bits (tail p) n

def cadd : snum → snum → bool → snum :=
rec' (λ a p c, czadd c a p) $ λa p IH,
rec' (λb c, czadd c b (a :: p)) $ λb q _ c,
bitvec.xor3 a b c :: IH q (bitvec.carry a b c)

/-- Add two `snum`s. -/
protected def add (a b : snum) : snum := cadd a b ff

instance : has_add snum := ⟨snum.add⟩

/-- subtract two `snum`s. -/
protected def sub (a b : snum) : snum := a + -b

instance : has_sub snum := ⟨snum.sub⟩

/-- Multiply two `snum`s. -/
protected def mul (a : snum) : snum → snum :=
rec' (λ b, cond b (-a) 0) $ λb q IH,
cond b (bit0 IH + a) (bit0 IH)

instance : has_mul snum := ⟨snum.mul⟩

end snum


import tactic
import .stlc

lemma cannonical_forms_bool {t}
  (ht : has_type context.empty t ty.bool) (v : value t) :
  t = tm.tru ∨ t = tm.fls :=
begin
  cases v,
    case value.v_tru: { left, constructor },
    case value.v_fls: { right, constructor },
    repeat { cases ht },
end

lemma cannonical_forms_fun {t T₁ T₂}
  (ht : has_type context.empty t (ty.arrow T₁ T₂)) (v : value t) :
  ∃x u, t = tm.abs x T₁ u :=
begin
  cases v,
    case value.v_abs : { cases ht, existsi _, existsi _, reflexivity },
    repeat { cases ht },
end

lemma cannonical_forms_nat {t}
  (ht : has_type context.empty t ty.nat) (v : value t) :
  ∃n, t = tm.const n :=
begin
  cases v,
    case value.v_const: { existsi _, reflexivity },
    repeat { cases ht },
end

lemma cannonical_forms_pair {t T₁ T₂}
  (ht : has_type context.empty t (ty.prod T₁ T₂)) (v : value t) :
  ∃t₁ t₂, value t₁ ∧ value t₂ ∧ t = tm.pair t₁ t₂ :=
begin
  cases v,
    case value.v_pair: _ _ v₁ v₂ { existsi _, existsi _, exact ⟨v₁, v₂, rfl⟩ },
    repeat { cases ht },
end

lemma cannonical_forms_unit {t}
  (ht : has_type context.empty t ty.unit) (v : value t) :
  t = tm.unit :=
begin
  cases v,
    case value.v_unit: { reflexivity },
    repeat { cases ht },
end

lemma cannonical_forms_sum {t T₁ T₂}
  (ht : has_type context.empty t (ty.sum T₁ T₂)) (v : value t) :
  (∃t₁, value t₁ ∧ t = tm.inl T₂ t₁) ∨ (∃t₂, value t₂ ∧ t = tm.inr T₁ t₂) :=
begin
  cases v,
    case value.v_inl: _ _ v₁ {
      cases ht,
      left,
      existsi _,
      exact ⟨v₁, rfl⟩,
    },
    case value.v_inr: _ _ v₂ {
      cases ht,
      right,
      existsi _,
      exact ⟨v₂, rfl⟩,
    },
    repeat { cases ht },
end

lemma cannonical_forms_list {t T}
  (ht : has_type context.empty t (ty.list T)) (v : value t) :
  (t = tm.nil T ∨ ∃t₁ t₂, value t₁ ∧ value t₂ ∧ t = tm.cons t₁ t₂) :=
begin
  cases v,
    case value.v_nil: { cases ht, left, constructor },
    case value.v_cons: _ _ v₁ v₂ {
      cases ht,
      right,
      existsi _,
      existsi _,
      exact ⟨v₁, v₂, rfl⟩,
    },
    repeat { cases ht },
end

theorem progress {t T} :
  has_type context.empty t T -> value t ∨ ∃t', t -+> t' :=
begin
  generalize h : context.empty = e,
  intro ht,
  induction ht,
    case has_type.t_var: _ _ _ ht { rewrite <-h at ht, cases ht },
    case has_type.t_app: _ _ _ _ _ ht₁ _ ih₁ ih₂ {
      rcases ih₁ h with v₁ | ⟨_, s₁⟩,
        { rcases ih₂ h with v₂ | ⟨_, s₂⟩,
            { cases v₁; cases ht₁, right, existsi _, exact step.st_appabs v₂ },
            { right, existsi _, exact step.st_app2 v₁ s₂ } },
        { right, existsi _, exact step.st_app1 s₁ },
    },
    case has_type.t_prd: _ _ ht ih {
      rcases ih h with v | ⟨_, s⟩,
        { rewrite <-h at ht,
          rcases cannonical_forms_nat ht v with ⟨n, h'⟩,
          rewrite h',
          right,
          cases n with m,
            { existsi _, exact step.st_prdzro },
            { existsi _, exact step.st_prdnzr } },
        { right, existsi _, exact step.st_prd s },
    },
    case has_type.t_scc: _ _ ht ih {
      rcases ih h with v | ⟨_, s⟩,
        { rewrite <-h at ht,
          rcases cannonical_forms_nat ht v with ⟨_, h'⟩,
          rewrite h',
          right,
          existsi _,
          exact step.st_sccn },
        { right, existsi _, exact step.st_scc s },
    },
    case has_type.t_mlt: _ _ _ ht₁ ht₂ ih₁ ih₂ {
      rcases ih₁ h with v₁ | ⟨_, s₁⟩,
        { rewrite <-h at ht₁,
          rcases cannonical_forms_nat ht₁ v₁ with ⟨_, h₁⟩,
          rewrite h₁ at v₁,
          rewrite h₁,
          rcases ih₂ h with v₂ | ⟨_, s₂⟩,
            { rewrite <-h at ht₂,
              rcases cannonical_forms_nat ht₂ v₂ with ⟨_, h₂⟩,
              rewrite h₂,
              right,
              existsi _,
              exact step.st_mltnm },
            { right, existsi _, exact step.st_mlt2 v₁ s₂ },
        },
        { right, existsi _, exact step.st_mlt1 s₁ },
    },
    case has_type.t_iszro: _ _ ht ih {
      rcases ih h with v | ⟨_, s⟩,
        { rewrite <-h at ht,
          rcases cannonical_forms_nat ht v with ⟨n, h'⟩,
          rewrite h',
          right,
          cases n with m,
            { existsi _, exact step.st_iszrozro },
            { existsi _, exact step.st_iszronzr } },
        { right, existsi _, exact step.st_iszro s },
    },
    case has_type.t_tst: _ _ _ _ _ ht₁ _ _ ih₁ {
      rcases ih₁ h with v₁ | ⟨_, s₁⟩,
        { rewrite <-h at ht₁,
          cases cannonical_forms_bool ht₁ v₁,
          repeat { simp [*], right, existsi _ },
            { exact step.st_tsttru },
            { exact step.st_tstfls }, },
        { right, existsi _, exact step.st_tst s₁ },
    },
    case has_type.t_let: _ _ _ _ _ _ _ _ ih₁ ih₂ {
      rcases ih₁ h with v₁ | ⟨_, s₁⟩,
        { right, existsi _, exact step.st_letvalue v₁ },
        { right, existsi _, exact step.st_let s₁ },
    },
    case has_type.t_pair: _ _ _ _ _ _ _ ih₁ ih₂ {
      rcases ih₁ h with v₁ | ⟨_, s₁⟩,
        { rcases ih₂ h with v₂ | ⟨_, s₂⟩,
            { left, exact value.v_pair v₁ v₂ },
            { right, existsi _, exact step.st_pair2 v₁ s₂ } },
        { right, existsi _, exact step.st_pair1 s₁ },
    },
    case has_type.t_fst: _ _ _ _ ht ih {
      rcases ih h with v | ⟨_, s⟩,
        { rewrite <-h at ht,
          rcases cannonical_forms_pair ht v with ⟨_, _, v_h, v_t, h'⟩,
          rewrite h',
          right,
          existsi _,
          exact step.st_fstpair v_h v_t },
        { right, existsi _, exact step.st_fst s },
    },
    case has_type.t_snd: _ _ _ _ ht ih {
      rcases ih h with v | ⟨_, s⟩,
        { rewrite <-h at ht,
          rcases cannonical_forms_pair ht v with ⟨_, _, v_h, v_t, h'⟩,
          rewrite h',
          right,
          existsi _,
          exact step.st_sndpair v_h v_t },
        { right, existsi _, exact step.st_snd s },
    },
    case has_type.t_inl: _ _ _ _ ht ih {
      rcases ih h with v | ⟨_, s⟩,
        { left, exact value.v_inl v },
        { right, existsi _, exact step.st_inl s },
    },
    case has_type.t_inr: _ _ _ _ ht ih {
      rcases ih h with v | ⟨_, s⟩,
        { left, exact value.v_inr v },
        { right, existsi _, exact step.st_inr s }
    },
    case has_type.t_scase: _ _ _ _ _ _ _ _ _ ht _ _ ih {
      rcases ih h with v | ⟨_, s⟩,
        { rewrite <-h at ht,
          rcases cannonical_forms_sum ht v with ⟨_, v', h_inl⟩ | ⟨_, v', h_inr⟩,
            { rewrite h_inl, right, existsi _, exact step.st_scaseinl v' },
            { rewrite h_inr, right, existsi _, exact step.st_scaseinr v' } },
        { right, existsi _, exact step.st_scase s },
    },
    case has_type.t_cons: _ _ _ _ _ _ ih₁ ih₂ {
      rcases ih₁ h with v₁ | ⟨_, s₁⟩,
        { rcases ih₂ h with v₂ | ⟨_, s₂⟩,
            { left, exact value.v_cons v₁ v₂ },
            { right, existsi _, exact step.st_cons2 v₁ s₂ } },
        { right, existsi _, exact step.st_cons1 s₁ },
    },
    case has_type.t_lcase: _ _ _ _ _ _ _ _ ht _ _ ih {
      rcases ih h with v | ⟨_, s⟩,
        { rewrite <-h at ht,
          rcases cannonical_forms_list ht v
            with h_nil | ⟨_, _, v_h, v_t, h_cons⟩,
              { rewrite h_nil, right, existsi _, exact step.st_lcasenil },
              { rewrite h_cons,
                right,
                existsi _,
                exact step.st_lcasecons v_h v_t } },
        { right, existsi _, exact step.st_lcase s },
    },
    case has_type.t_fix: _ _ _ ht ih {
      rcases ih h with v | ⟨_, s⟩,
        { rewrite <-h at ht,
          rcases cannonical_forms_fun ht v with ⟨_, _, h'⟩,
          rewrite h',
          right,
          existsi _,
          exact step.st_fixabs },
        { right, existsi _, exact step.st_fix s },
    },
    repeat { left, constructor },
end

theorem progress' :
  ∀{t T}, has_type context.empty t T -> value t ∨ ∃t', t -+> t' :=
begin
  intro t,
  induction t,
    case tm.var: { intros _ ht, cases ht, cases ht_a },
    case tm.app: _ _ ih₁ ih₂ {
      intros _ ht,
      cases ht,
      rcases ih₁ ht_a with v₁ | ⟨_, s₁⟩,
        { rcases ih₂ ht_a_1 with v₂ | ⟨_, s₂⟩,
            { rcases cannonical_forms_fun ht_a v₁ with ⟨_, _, h⟩,
              rewrite h,
              right,
              existsi _,
              exact step.st_appabs v₂ },
            { right, existsi _, exact step.st_app2 v₁ s₂ } },
        { right, existsi _, exact step.st_app1 s₁ },
    },
    case tm.prd: _ ih {
      intros _ ht,
      cases ht,
      rcases ih ht_a with v | ⟨_, s⟩,
        { rcases cannonical_forms_nat ht_a v with ⟨n, h⟩,
          right,
          rewrite h,
          cases n with m,
            { existsi _, exact step.st_prdzro },
            { existsi _, exact step.st_prdnzr } },
        { right, existsi _, exact step.st_prd s },
    },
    case tm.scc: _ ih {
      intros _ ht,
      cases ht,
      rcases ih ht_a with v | ⟨_, s⟩,
        { rcases cannonical_forms_nat ht_a v with ⟨_, h⟩,
          right,
          rewrite h,
          existsi _,
          exact step.st_sccn },
        { right, existsi _, exact step.st_scc s },
    },
    case tm.mlt: _ _ ih₁ ih₂ {
      intros _ ht,
      cases ht,
      rcases ih₁ ht_a with v₁ | ⟨_, s₁⟩,
        { rcases cannonical_forms_nat ht_a v₁ with ⟨_, h₁⟩,
          right,
          rewrite h₁ at v₁,
          rewrite h₁,
          rcases ih₂ ht_a_1 with v₂ | ⟨_, s₂⟩,
            { rcases cannonical_forms_nat ht_a_1 v₂ with ⟨_, h₂⟩,
              rewrite h₂,
              existsi _,
              exact step.st_mltnm },
            { existsi _, exact step.st_mlt2 v₁ s₂ } },
        { right, existsi _, exact step.st_mlt1 s₁ },
    },
    case tm.iszro: _ ih {
      intros _ ht,
      cases ht,
      rcases ih ht_a with v | ⟨_, s⟩,
        { rcases cannonical_forms_nat ht_a v with ⟨n, h⟩,
          right,
          rewrite h,
          cases n with m,
            { existsi _, exact step.st_iszrozro },
            { existsi _, exact step.st_iszronzr } },
        { right, existsi _, exact step.st_iszro s },
    },
    case tm.tst: _ _ _ ih₁ ih₂ ih₃ {
      intros _ ht,
      cases ht,
      rcases ih₁ ht_a with v₁ | ⟨_, s₁⟩,
        { cases cannonical_forms_bool ht_a v₁ with h_tru h_fls,
            { rewrite h_tru, right, existsi _, exact step.st_tsttru },
            { rewrite h_fls, right, existsi _, exact step.st_tstfls } },
        { right, existsi _, exact step.st_tst s₁ },
    },
    case tm.let_: _ _ _ ih₁ ih₂ {
      intros _ ht,
      cases ht,
      rcases ih₁ ht_a with v₁ | ⟨_, s₁⟩,
        { right, existsi _, exact step.st_letvalue v₁ },
        { right, existsi _, exact step.st_let s₁ },
    },
    case tm.pair: _ _ ih₁ ih₂ {
      intros _ ht,
      cases ht,
      rcases ih₁ ht_a with v₁ | ⟨_, s₁⟩,
        { rcases ih₂ ht_a_1 with v₂ | ⟨_, s₂⟩,
            { left, exact value.v_pair v₁ v₂ },
            { right, existsi _, exact step.st_pair2 v₁ s₂ } },
        { right, existsi _, exact step.st_pair1 s₁ },
    },
    case tm.fst: _ ih {
      intros _ ht,
      cases ht,
      rcases ih ht_a with v | ⟨_, s⟩,
        { rcases cannonical_forms_pair ht_a v with ⟨_, _, v_h, v_t, h'⟩,
          rewrite h',
          right,
          existsi _,
          exact step.st_fstpair v_h v_t },
        { right, existsi _, exact step.st_fst s },
    },
    case tm.snd: _ ih {
      intros _ ht,
      cases ht,
      rcases ih ht_a with v | ⟨_, s⟩,
        { rcases cannonical_forms_pair ht_a v with ⟨_, _, v_h, v_t, h'⟩,
          rewrite h',
          right,
          existsi _,
          exact step.st_sndpair v_h v_t },
        { right, existsi _, exact step.st_snd s },
    },
    case tm.inl: _ _ ih {
      intros _ ht,
      cases ht,
      rcases ih ht_a with v | ⟨_, s⟩,
        { left, exact value.v_inl v },
        { right, existsi _, exact step.st_inl s },
    },
    case tm.inr: _ _ ih {
      intros _ ht,
      cases ht,
      rcases ih ht_a with v | ⟨_, s⟩,
        { left, exact value.v_inr v },
        { right, existsi _, exact step.st_inr s },
    },
    case tm.scase: _ _ _ _ _ ih ih₁ ih₂ {
      intros _ ht,
      cases ht,
      rcases ih ht_a with v | ⟨_, s⟩,
        { rcases cannonical_forms_sum ht_a v
            with ⟨_, v', h_inl⟩ | ⟨_, v', h_inr⟩,
              { rewrite h_inl, right, existsi _, exact step.st_scaseinl v' },
              { rewrite h_inr, right, existsi _, exact step.st_scaseinr v' } },
        { right, existsi _, exact step.st_scase s },
    },
    case tm.cons: _ _ ih₁ ih₂ {
      intros _ ht,
      cases ht,
      rcases ih₁ ht_a with v₁ | ⟨_, s₁⟩,
        { rcases ih₂ ht_a_1 with v₂ | ⟨_, s₂⟩,
            { left, exact value.v_cons v₁ v₂ },
            { right, existsi _, exact step.st_cons2 v₁ s₂ } },
        { right, existsi _, exact step.st_cons1 s₁ },
    },
    case tm.lcase: _ _ _ _ _ ih ih₁ ih₂ {
      intros _ ht,
      cases ht,
      rcases ih ht_a with v | ⟨_, s⟩,
        { rcases cannonical_forms_list ht_a v
            with h_nil | ⟨_, _, v_h, v_t, h_cons⟩,
              { rewrite h_nil, right, existsi _, exact step.st_lcasenil },
              { rewrite h_cons,
                right,
                existsi _,
                exact step.st_lcasecons v_h v_t } },
        { right, existsi _, exact step.st_lcase s },
    },
    case tm.fix: _ ih {
      intros _ ht,
      cases ht,
      rcases ih ht_a with v | ⟨_, s⟩,
        { rcases cannonical_forms_fun ht_a v with ⟨_, _, h'⟩,
          rewrite h',
          right,
          existsi _,
          exact step.st_fixabs },
        { right, existsi _, exact step.st_fix s },
    },
    repeat { intros, left, constructor },
end

lemma free_in_context {x t} (afi : appears_free_in x t) :
  ∀{gamma T}, has_type gamma t T -> ∃T', gamma x = some T' :=
begin
  induction afi,
    repeat { intros, cases a },
    /- appears_free_in.afi_var -/ { existsi T, assumption },
    /- appears_free_in.afi_abs -/ {
      rcases afi_ih a_a with ⟨T', h'⟩,
      rewrite partial_map.update_neq afi_a at h',
      existsi T',
      exact h',
    },
    repeat { apply afi_ih, assumption },
    /- appears_free_in.afi_let2 -/ {
      rcases afi_ih a_a_1 with ⟨T', h'⟩,
      rewrite partial_map.update_neq afi_a at h',
      existsi T',
      exact h',
    },
    /- appears_free_in.afi_scase2 -/ {
      let e := afi_ih a_a_1,
      rewrite partial_map.update_neq afi_a at e,
      exact e,
    },
    /- appears_free_in.afi_scase3 -/ {
      let e := afi_ih a_a_2,
      rewrite partial_map.update_neq afi_a at e,
      exact e,
    },
    /- appears_free_in.afi_lcase3 -/ {
      let e := afi_ih a_a_2,
      rewrite [partial_map.update_neq afi_a_1, partial_map.update_neq afi_a]
        at e,
      exact e,
    },
end

lemma typable_empty__closed {t T} : has_type context.empty t T -> closed t :=
begin
  intros ht x afi,
  rcases free_in_context afi ht with ⟨_, h⟩,
  cases h,
end

lemma context_invariance {gamma t T} (ht : has_type gamma t T) :
  ∀{gamma' : context},
  (∀{x}, appears_free_in x t -> gamma x = gamma' x) -> has_type gamma' t T :=
begin
  induction ht,
    case has_type.t_var: _ x _ h {
      intros _ f,
      apply has_type.t_var,
      rewrite <-f (appears_free_in.afi_var x),
      exact h,
    },
    case has_type.t_abs: _ x T₁ _ _ _ ih {
      intros gamma' f,
      apply has_type.t_abs,
      apply @ih (partial_map.update x T₁ gamma'),
      intros y afi,
      by_cases h : x = y,
        repeat {
          simp [h, partial_map.update, total_map.update];
          exact f (appears_free_in.afi_abs h afi)
        },
    },
    case has_type.t_app: _ _ _ _ _ _ _ ih₁ ih₂ {
      intros _ f,
      apply has_type.t_app,
      repeat { apply ih₁ <|> apply ih₂, intros x afi, apply @f x },
        { exact appears_free_in.afi_app1 afi },
        { exact appears_free_in.afi_app2 afi },
    },
    case has_type.t_tst: gamma _ _ _ _ _ _ _ ih₁ ih₂ ih₃ {
      intros _ f,
      apply has_type.t_tst,
      repeat {
        apply ih₁ <|> apply ih₂ <|> apply ih₃,
        intros x afi,
        apply @f x
      },
        { exact appears_free_in.afi_tst1 afi },
        { exact appears_free_in.afi_tst2 afi },
        { exact appears_free_in.afi_tst3 afi },
    },
    case has_type.t_prd: _ _ _ ih {
      intros _ f,
      apply has_type.t_prd,
      apply ih,
      intros x afi,
      apply @f x,
      exact appears_free_in.afi_prd afi,
    },
    case has_type.t_scc: _ _ _ ih {
      intros _ f,
      apply has_type.t_scc,
      apply ih,
      intros x afi,
      apply @f x,
      exact appears_free_in.afi_scc afi,
    },
    case has_type.t_mlt: _ _ _ _ _ ih₁ ih₂ {
      intros _ f,
      apply has_type.t_mlt,
      repeat { apply ih₁ <|> apply ih₂, intros x afi, apply @f x },
        { exact appears_free_in.afi_mlt1 afi },
        { exact appears_free_in.afi_mlt2 afi },
    },
    case has_type.t_iszro: _ _ _ ih {
      intros _ f,
      apply has_type.t_iszro,
      apply ih,
      intros x afi,
      apply @f x,
      exact appears_free_in.afi_iszro afi,
    },
    case has_type.t_let: _ x _ _ _ _ _ _ ih₁ ih₂ {
      intros _ f,
      apply has_type.t_let,
        { apply ih₁,
          intros y afi,
          apply @f y, exact appears_free_in.afi_let1 afi },
        { apply ih₂,
          intros y afi,
          by_cases h : x = y,
          repeat { simp [*, partial_map.update, total_map.update] },
          apply @f y,
          exact appears_free_in.afi_let2 h afi },
    },
    case has_type.t_pair: _ _ _ _ _ _ _ ih₁ ih₂ {
      intros _ f,
      apply has_type.t_pair,
        { apply ih₁,
          intros _ afi,
          exact f (appears_free_in.afi_pair1 afi) },
        { apply ih₂,
          intros y afi,
          exact f (appears_free_in.afi_pair2 afi) },
    },
    case has_type.t_fst: _ _ _ _ _ ih {
      intros _ f,
      apply has_type.t_fst,
      apply ih,
      intros _ afi,
      exact f (appears_free_in.afi_fst afi),
    },
    case has_type.t_snd: _ _ _ _ _ ih {
      intros _ f,
      apply has_type.t_snd,
      apply ih,
      intros _ afi,
      exact f (appears_free_in.afi_snd afi),
    },
    case has_type.t_inl: _ _ _ _ _ ih {
      intros _ f,
      apply has_type.t_inl,
      apply ih,
      intros _ afi,
      exact f (appears_free_in.afi_inl afi),
    },
    case has_type.t_inr: _ _ _ _ _ ih {
      intros _ f,
      apply has_type.t_inr,
      apply ih,
      intros _ afi,
      exact f (appears_free_in.afi_inr afi),
    },
    case has_type.t_scase: _ _ _ _ y _ _ z _ _ _ _ ih ih₁ ih₂ {
      intros _ f,
      apply has_type.t_scase,
        { apply ih,
          intros _ afi,
          exact f (appears_free_in.afi_scase1 afi) },
        { apply ih₁,
          intros _ afi,
          by_cases h : y = x,
            { simp [h, partial_map.update, total_map.update], },
            { simp [h, partial_map.update, total_map.update],
              exact f (appears_free_in.afi_scase2 h afi) } },
        { apply ih₂,
          intros _ afi,
          by_cases h : z = x,
            { simp [h, partial_map.update, total_map.update] },
            { simp [h, partial_map.update, total_map.update],
              exact f (appears_free_in.afi_scase3 h afi) } },
    },
    case has_type.t_cons: _ _ _ _ _ _ ih₁ ih₂ {
      intros _ f,
      apply has_type.t_cons,
        { apply ih₁,
          intros _ afi,
          exact f (appears_free_in.afi_cons1 afi) },
        { apply ih₂,
          intros _ afi,
          exact f (appears_free_in.afi_cons2 afi) },
    },
    case has_type.t_lcase: _ _ _ _ _ y z _ _ _ _ ih ih₁ ih₂ {
      intros _ f,
      apply has_type.t_lcase,
        { apply ih,
          intros _ afi,
          exact f (appears_free_in.afi_lcase1 afi) },
        { apply ih₁,
          intros _ afi,
          exact f (appears_free_in.afi_lcase2 afi) },
        { apply ih₂,
          intros _ afi,
          by_cases hyx : y = x,
            { simp [symm hyx, partial_map.update, total_map.update] },
            { by_cases hzx : z = x,
                { simp [symm hzx, partial_map.update, total_map.update] },
                { simp [hyx, hzx, partial_map.update, total_map.update],
                  exact f (appears_free_in.afi_lcase3 hyx hzx afi) } } },
    },
    case has_type.t_fix: _ _ _ _ ih {
      intros _ f,
      apply has_type.t_fix,
      apply ih,
      intros _ afi,
      exact f (appears_free_in.afi_fix afi),
    },
    repeat {
      intros,
          exact has_type.t_const
      <|> exact has_type.t_tru
      <|> exact has_type.t_fls
      <|> exact has_type.t_unit
      <|> exact has_type.t_nil
    },
end

lemma substitution_preserves_typing {x U v} :
  ∀{t T gamma},
  has_type (partial_map.update x U gamma) t T -> has_type context.empty v U ->
  has_type gamma ([x:=v]t) T :=
begin
  intro t,
  induction t,
    case tm.var: y {
      intros _ _ ht_t ht_v,
      by_cases h : x = y,
      repeat {
        try { rewrite h at ht_t },
        cases ht_t,
        simp [h] at ht_t_a,
        simp [h, ht_t_a, subst],
      },
        { rewrite ht_t_a at ht_v,
          apply context_invariance ht_v,
          intros z afi,
          apply false.elim,
          exact typable_empty__closed ht_v z afi },
        { exact has_type.t_var ht_t_a },
    },
    case tm.abs: y T' t ih {
      intros T gamma ht_t ht_v,
      by_cases h : x = y,
        { rewrite h at ht_t,
          cases ht_t,
          have ht' : has_type (partial_map.update y T' $
                              partial_map.update y U gamma)
                             t
                             ht_t_T₁₂,
          from ht_t_a,
          rewrite partial_map.update_shadow at ht',
          simp [h, subst],
          exact has_type.t_abs ht' },
        { cases ht_t,
          have ht' : has_type (partial_map.update y T' $
                               partial_map.update x U gamma)
                              t
                              ht_t_T₁₂,
          from ht_t_a,
          rewrite partial_map.update_permute (ne.symm h) at ht',
          simp [h, subst],
          exact has_type.t_abs (ih ht' ht_v) },
    },
    case tm.app: _ _ ih₁ ih₂ {
      intros _ _ ht_t ht_v,
      cases ht_t,
      exact has_type.t_app (ih₁ ht_t_a ht_v) (ih₂ ht_t_a_1 ht_v),
    },
    case tm.prd: _ ih {
      intros _ _ ht_t ht_v,
      cases ht_t,
      exact has_type.t_prd (ih ht_t_a ht_v),
    },
    case tm.scc: _ ih {
      intros _ _ ht_t ht_v,
      cases ht_t,
      exact has_type.t_scc (ih ht_t_a ht_v),
    },
    case tm.mlt: _ _ ih₁ ih₂ {
      intros _ _ ht_t ht_v,
      cases ht_t,
      exact has_type.t_mlt (ih₁ ht_t_a ht_v) (ih₂ ht_t_a_1 ht_v),
    },
    case tm.iszro: _ ih {
      intros _ _ ht_t ht_v,
      cases ht_t,
      exact has_type.t_iszro (ih ht_t_a ht_v),
    },
    case tm.tst: _ _ _ ih₁ ih₂ ih₃ {
      intros _ _ ht_t ht_v,
      cases ht_t,
      exact has_type.t_tst (ih₁ ht_t_a ht_v) (ih₂ ht_t_a_1 ht_v) (ih₃ ht_t_a_2 ht_v),
    },
    case tm.let_: y _ _ ih₁ ih₂ {
      intros _ _ ht_t ht_v,
      by_cases h : y = x,
        { cases ht_t,
          simp [h, subst],
          rewrite h at ht_t_a_1,
          have ht₂ : has_type (partial_map.update x ht_t_T₁ $
                               partial_map.update x U gamma)
                              t_a_2
                              T,
          from ht_t_a_1,
          rewrite partial_map.update_shadow at ht₂,
          exact has_type.t_let (ih₁ ht_t_a ht_v) ht₂ },
        { cases ht_t,
          simp [ne.symm h, subst],
          have ht₂ : has_type (partial_map.update y ht_t_T₁ $
                               partial_map.update x U gamma)
                              t_a_2
                              T,
          from ht_t_a_1,
          rewrite partial_map.update_permute h at ht₂,
          exact has_type.t_let (ih₁ ht_t_a ht_v) (ih₂ ht₂ ht_v) },
    },
    case tm.pair: _ _ ih₁ ih₂ {
      intros _ _ ht_t ht_v,
      cases ht_t,
      exact has_type.t_pair (ih₁ ht_t_a ht_v) (ih₂ ht_t_a_1 ht_v),
    },
    case tm.fst: _ ih {
      intros _ _ ht_t ht_v,
      cases ht_t,
      exact has_type.t_fst (ih ht_t_a ht_v),
    },
    case tm.snd: _ ih {
      intros _ _ ht_t ht_v,
      cases ht_t,
      exact has_type.t_snd (ih ht_t_a ht_v),
    },
    case tm.inl: _ _ ih {
      intros _ _ ht_t ht_v,
      cases ht_t,
      exact has_type.t_inl (ih ht_t_a ht_v),
    },
    case tm.inr: _ _ ih {
      intros _ _ ht_t ht_v,
      cases ht_t,
      exact has_type.t_inr (ih ht_t_a ht_v),
    },
    case tm.scase: _ y _ z _ ih ih₁ ih₂{
      intros _ _ ht_t ht_v,
      cases ht_t,
      apply has_type.t_scase (ih ht_t_a ht_v),
        { by_cases h : y = x,
            { simp [h],
              have ht₁ : has_type (partial_map.update y ht_t_T₁ $
                                   partial_map.update x U gamma)
                                  t_a_2
                                  T,
              from ht_t_a_1,
              simp [h, partial_map.update_shadow] at ht₁,
              exact ht₁ },
            { simp [ne.symm h],
              have ht₁ : has_type (partial_map.update y ht_t_T₁ $
                                   partial_map.update x U gamma)
                                  t_a_2
                                  T,
              from ht_t_a_1,
              rewrite partial_map.update_permute h at ht₁,
              exact ih₁ ht₁ ht_v } },
        { by_cases h : z = x,
          { simp [h],
            have ht₂ : has_type (partial_map.update z ht_t_T₂ $
                                 partial_map.update x U gamma)
                                t_a_4
                                T,
            from ht_t_a_2,
            simp [h, partial_map.update_shadow] at ht₂,
            exact ht₂ },
          { simp [ne.symm h],
            have ht₂ : has_type (partial_map.update z ht_t_T₂ $
                                 partial_map.update x U gamma)
                                t_a_4
                                T,
            from ht_t_a_2,
            rewrite partial_map.update_permute h at ht₂,
            exact ih₂ ht₂ ht_v } },
    },
    case tm.cons: _ _ ih₁ ih₂ {
      intros _ _ ht_t ht_v,
      cases ht_t,
      exact has_type.t_cons (ih₁ ht_t_a ht_v) (ih₂ ht_t_a_1 ht_v),
    },
    case tm.lcase: _ _ y z _ ih ih₁ ih₂ {
      intros _ _ ht_t ht_v,
      cases ht_t,
      apply has_type.t_lcase (ih ht_t_a ht_v) (ih₁ ht_t_a_1 ht_v),
      have ht₂ : has_type (partial_map.update z (ty.list ht_t_T) $
                           partial_map.update y ht_t_T $
                           partial_map.update x U gamma)
                          t_a_4
                          T,
      from ht_t_a_2,
      by_cases hyx : y = x,
        { by_cases hzx : z = x,
            { simp [hyx, hzx, partial_map.update_shadow],
              simp [hyx, hzx, partial_map.update_shadow] at ht₂,
              exact ht₂ },
            { simp [ hyx,
                     partial_map.update_permute hzx,
                     partial_map.update_shadow ],
              simp [ hyx,
                     partial_map.update_permute hzx,
                     partial_map.update_shadow ]
                at ht₂,
              exact ht₂ } },
        { by_cases hzx : z = x,
            { simp [hzx],
              simp [ hzx,
                     partial_map.update_permute hyx,
                     partial_map.update_shadow ]
                at ht₂,
              exact ht₂ },
            { let h := iff.elim_right
                         (decidable.not_or_iff_and_not (x = y) (x = z))
                         (and.intro (ne.symm hyx) (ne.symm hzx)),
              simp [h],
              rewrite [ partial_map.update_permute hyx,
                        partial_map.update_permute hzx ]
                at ht₂,
              exact ih₂ ht₂ ht_v } },
    },
    case tm.fix: _ ih {
      intros _ _ ht_t ht_v,
      cases ht_t,
      exact has_type.t_fix (ih ht_t_a ht_v) ,
    },
    repeat {
      intros _ _ ht_t _,
      cases ht_t,
          exact has_type.t_const
      <|> exact has_type.t_tru
      <|> exact has_type.t_fls
      <|> exact has_type.t_unit
      <|> exact has_type.t_nil
    },
end

theorem preservation {t T} :
  has_type context.empty t T -> ∀{t'}, (t -+> t') -> has_type context.empty t' T :=
begin
  generalize h : context.empty = gamma,
  intro ht,
  induction ht,
    case has_type.t_app: _ _ _ _ _ ht₁ ht₂ ih₁ ih₂  {
      intros _ s,
      cases s,
        case step.st_appabs: {
          rewrite <-h at ht₁ ht₂,
          cases ht₁,
          simp [symm h],
          exact substitution_preserves_typing ht₁_a ht₂,
        },
        case step.st_app1: { exact has_type.t_app (ih₁ h s_a) ht₂ },
        case step.st_app2: { exact has_type.t_app ht₁ (ih₂ h s_a_1) },
    },
    case has_type.t_prd: _ _ ht ih {
      intros _ s,
      cases s,
        case step.st_prdzro: { exact ht },
        case step.st_prdnzr: { exact has_type.t_const },
        case step.st_prd: { exact has_type.t_prd (ih h s_a) },
    },
    case has_type.t_scc: _ _ ht ih {
      intros _ s,
      cases s,
        case step.st_sccn: { exact has_type.t_const },
        case step.st_scc: { exact has_type.t_scc (ih h s_a) },
    },
    case has_type.t_mlt: _ _ _ ht₁ ht₂ ih₁ ih₂ {
      intros _ s,
      cases s,
        case step.st_mlt1: { exact has_type.t_mlt (ih₁ h s_a) ht₂ },
        case step.st_mlt2: { exact has_type.t_mlt ht₁ (ih₂ h s_a_1) },
        case step.st_mltnm: { exact has_type.t_const },
    },
    case has_type.t_iszro: _ _ ht ih {
      intros _ s,
      cases s,
        case step.st_iszrozro: { exact has_type.t_tru },
        case step.st_iszronzr: { exact has_type.t_fls },
        case step.st_iszro: { exact has_type.t_iszro (ih h s_a) },
    },
    case has_type.t_tst: _ _ _ _ _ ht₁ ht₂ ht₃ ih₁ ih₂ ih₃ {
      intros _ s,
      cases s,
        case step.st_tsttru: { exact ht₂ },
        case step.st_tstfls: { exact ht₃ },
        case step.st_tst: { exact has_type.t_tst (ih₁ h s_a) ht₂ ht₃ },
    },
    case has_type.t_let: _ _ _ _ _ _ ht₁ ht₂ ih₁ ih₂ {
      intros _ s,
      cases s,
        case step.st_let: { exact has_type.t_let (ih₁ h s_a) ht₂ },
        case step.st_letvalue: {
          rewrite <-h at ht₁,
          exact substitution_preserves_typing ht₂ ht₁,
        },
    },
    case has_type.t_pair: _ _ _ _ _ ht₁ ht₂ ih₁ ih₂ {
      intros _ s,
      cases s,
        case step.st_pair1: { exact has_type.t_pair (ih₁ h s_a) ht₂ },
        case step.st_pair2: { exact has_type.t_pair ht₁ (ih₂ h s_a_1) },
    },
    case has_type.t_fst: _ _ _ _ ht ih {
      intros _ s,
      cases s,
        case step.st_fstpair: { cases ht, exact ht_a, },
        case step.st_fst: { exact has_type.t_fst (ih h s_a) },
    },
    case has_type.t_snd: _ _ _ _ ht ih {
      intros _ s,
      cases s,
        case step.st_sndpair: { cases ht, exact ht_a_1, },
        case step.st_snd: { exact has_type.t_snd (ih h s_a) },
    },
    case has_type.t_inl: _ _ _ _ ht ih {
      intros _ s,
      cases s,
      exact has_type.t_inl (ih h s_a),
    },
    case has_type.t_inr: _ _ _ _ ht ih {
      intros _ s,
      cases s,
      exact has_type.t_inr (ih h s_a),
    },
    case has_type.t_scase: _ _ _ _ y _ _ z _ ht ht₁ ht₂ ih ih₁ ih₂ {
      intros _ s,
      cases s,
        case step.st_scase: { exact has_type.t_scase (ih h s_a) ht₁ ht₂ },
        case step.st_scaseinl: {
          cases ht,
          rewrite <-h at ht_a,
          exact substitution_preserves_typing ht₁ ht_a,
        },
        case step.st_scaseinr: {
          cases ht,
          rewrite <-h at ht_a,
          exact substitution_preserves_typing ht₂ ht_a,
        },
    },
    case has_type.t_cons: _ _ _ _ ht₁ ht₂ ih₁ ih₂ {
      intros _ s,
      cases s,
        { exact has_type.t_cons (ih₁ h s_a) ht₂ },
        { exact has_type.t_cons ht₁ (ih₂ h s_a_1) },
    },
    case has_type.t_lcase: _ _ _ _ _ y z _ ht ht₁ ht₂ ih ih₁ ih₂ {
      intros _ s,
      cases s,
        { exact has_type.t_lcase (ih h s_a) ht₁ ht₂ },
        { exact ht₁ },
        { cases ht,
          rewrite <-h,
          rewrite <-h at ht_a ht_a_1 ht₂,
          exact substitution_preserves_typing
                  (substitution_preserves_typing ht₂ ht_a_1)
                  ht_a },
    },
    case has_type.t_fix: _ _ _ ht ih {
      intros _ s,
      cases s,
        { exact has_type.t_fix (ih h s_a) },
        { cases ht,
          rewrite <-h,
          rewrite <-h at ht ht_a,
          exact substitution_preserves_typing ht_a (has_type.t_fix ht) },
    },
    repeat { intros _ s, cases s },
end

lemma subject_expansion :
  ∃t t' T,
  (t -+> t') -> has_type context.empty t' T -> ¬has_type context.empty t T :=
begin
  existsi tm.app (tm.abs "x" (ty.arrow ty.bool ty.bool) (tm.var "x")) tm.tru,
  existsi subst "x" tm.tru (tm.var "x"),
  existsi ty.bool,
  intros s ht' ht,
  cases ht,
  cases ht_a,
  cases ht_a_a,
  injection ht_a_a_a with h,
  cases h,
end

lemma soundness {t t' T} (ht : has_type context.empty t T) (ss : t -+>* t') :
  ¬stuck t' :=
begin
  intros stck,
  induction ss,
    case multi.multi_refl: {
      rcases stck with ⟨nf, nv⟩,
      rcases progress ht with v | st,
        { exact nv v },
        { exact nf st },
    },
    case multi.multi_step: _ _ _ s _ ih { exact ih (preservation ht s) stck },
end

theorem unique_types :
  ∀{gamma e T}, has_type gamma e T -> ∀{T'}, has_type gamma e T' -> T = T' :=
begin
  intros _ _ _ ht,
  induction ht,
    case has_type.t_var: _ _ _ h {
      intros _ ht',
      cases ht',
      rewrite h at ht'_a,
      injection ht'_a,
    },
    case has_type.t_abs: _ _ _ _ _ _ ih {
      intros _ ht',
      cases ht',
      apply congr_arg,
      exact ih ht'_a,
    },
    case has_type.t_app: _ _ _ _ _ _ _ ih₁ ih₂ {
      intros _ ht',
      cases ht',
      let h := ih₁ ht'_a,
      rewrite ih₂ ht'_a_1 at h,
      injection h,
    },
    case has_type.t_tst: _ _ _ _ _ _ _ _ _ ih₂ {
      intros _ ht',
      cases ht',
      exact ih₂ ht'_a_1,
    },
    case has_type.t_let: _ _ _ _ _ _ _ _ ih₁ ih₂ {
      intros _ ht',
      cases ht',
      rewrite ih₁ ht'_a at ih₂,
      exact ih₂ ht'_a_1,
    },
    case has_type.t_pair: _ _ _ _ _ _ _ ih₁ ih₂ {
      intros _ ht',
      cases ht',
      rewrite ih₁ ht'_a,
      rewrite ih₂ ht'_a_1,
    },
    case has_type.t_scase: _ _ _ _ _ _ _ _ _ _ _ _ ih ih₁ {
      intros _ ht',
      cases ht',
      cases ih ht'_a,
      exact ih₁ ht'_a_1,
    },
    case has_type.t_cons: _ _ _ _ _ _ _ ih₂ {
      intros _ ht',
      cases ht',
      exact ih₂ ht'_a_1,
    },
    case has_type.t_lcase: _ _ _ _ _ _ _ _ _ _ _ _ ih₁ {
      intros _ ht',
      cases ht',
      exact ih₁ ht'_a_1,
    },
    repeat {
      intros _ ht',
      cases ht',
      cases ht_ih ht'_a,
      reflexivity,
    },
    repeat { intros _ ht', cases ht', reflexivity },
end