/-
Copyright (c) 2020 Simon Hudon. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Simon Hudon
-/
import control.monad.basic
import data.part
import order.hom.order
import tactic.monotonicity
import tactic.wlog

/-!
# Omega Complete Partial Orders

An omega-complete partial order is a partial order with a supremum
operation on increasing sequences indexed by natural numbers (which we
call `ωSup`). In this sense, it is strictly weaker than join complete
semi-lattices as only ω-sized totally ordered sets have a supremum.

The concept of an omega-complete partial order (ωCPO) is useful for the
formalization of the semantics of programming languages. Its notion of
supremum helps define the meaning of recursive procedures.

## Main definitions

 * class `omega_complete_partial_order`
 * `ite`, `map`, `bind`, `seq` as continuous morphisms

## Instances of `omega_complete_partial_order`

 * `part`
 * every `complete_lattice`
 * pi-types
 * product types
 * `monotone_hom`
 * `continuous_hom` (with notation →𝒄)
   * an instance of `omega_complete_partial_order (α →𝒄 β)`
 * `continuous_hom.of_fun`
 * `continuous_hom.of_mono`
 * continuous functions:
   * `id`
   * `ite`
   * `const`
   * `part.bind`
   * `part.map`
   * `part.seq`

## References

 * [Chain-complete posets and directed sets with applications][markowsky1976]
 * [Recursive definitions of partial functions and their computations][cadiou1972]
 * [Semantics of Programming Languages: Structures and Techniques][gunter1992]
-/

universes u v

local attribute [-simp] part.bind_eq_bind part.map_eq_map
open_locale classical

namespace order_hom

variables (α : Type*) (β : Type*) {γ : Type*} {φ : Type*}
variables [preorder α] [preorder β] [preorder γ] [preorder φ]

variables {β γ}

variables {α} {α' : Type*} {β' : Type*} [preorder α'] [preorder β']

/-- `part.bind` as a monotone function -/
@[simps]
def bind {β γ} (f : α →o part β) (g : α →o β → part γ) : α →o part γ :=
{ to_fun := λ x, f x >>= g x,
  monotone' :=
  begin
    intros x y h a,
    simp only [and_imp, exists_prop, part.bind_eq_bind, part.mem_bind_iff,
               exists_imp_distrib],
    intros b hb ha,
    refine ⟨b, f.monotone h _ hb, g.monotone h _ _ ha⟩,
  end }

end order_hom

namespace omega_complete_partial_order

/-- A chain is a monotone sequence.

See the definition on page 114 of [gunter1992]. -/
def chain (α : Type u) [preorder α] :=
ℕ →o α

namespace chain

variables {α : Type u} {β : Type v} {γ : Type*}
variables [preorder α] [preorder β] [preorder γ]

instance : has_coe_to_fun (chain α) (λ _, ℕ → α) := order_hom.has_coe_to_fun

instance [inhabited α] : inhabited (chain α) :=
⟨ ⟨ λ _, default, λ _ _ _, le_rfl ⟩ ⟩

instance : has_mem α (chain α) :=
⟨λa (c : ℕ →o α), ∃ i, a = c i⟩

variables (c c' : chain α)
variables (f : α →o β)
variables (g : β →o γ)

instance : has_le (chain α) :=
{ le := λ x y, ∀ i, ∃ j, x i ≤ y j }

/-- `map` function for `chain` -/
@[simps {fully_applied := ff}] def map : chain β :=
f.comp c

variables {f}

lemma mem_map (x : α) : x ∈ c → f x ∈ chain.map c f :=
λ ⟨i,h⟩, ⟨i, h.symm ▸ rfl⟩

lemma exists_of_mem_map {b : β} : b ∈ c.map f → ∃ a, a ∈ c ∧ f a = b :=
λ ⟨i,h⟩, ⟨c i, ⟨i, rfl⟩, h.symm⟩

lemma mem_map_iff {b : β} : b ∈ c.map f ↔ ∃ a, a ∈ c ∧ f a = b :=
⟨ exists_of_mem_map _, λ h, by { rcases h with ⟨w,h,h'⟩, subst b, apply mem_map c _ h, } ⟩

@[simp]
lemma map_id : c.map order_hom.id = c :=
order_hom.comp_id _

lemma map_comp : (c.map f).map g = c.map (g.comp f) := rfl

@[mono]
lemma map_le_map {g : α →o β} (h : f ≤ g) : c.map f ≤ c.map g :=
λ i, by simp [mem_map_iff]; intros; existsi i; apply h

/-- `chain.zip` pairs up the elements of two chains that have the same index -/
@[simps]
def zip (c₀ : chain α) (c₁ : chain β) : chain (α × β) :=
order_hom.prod c₀ c₁

end chain

end omega_complete_partial_order

open omega_complete_partial_order

section prio
set_option extends_priority 50

/-- An omega-complete partial order is a partial order with a supremum
operation on increasing sequences indexed by natural numbers (which we
call `ωSup`). In this sense, it is strictly weaker than join complete
semi-lattices as only ω-sized totally ordered sets have a supremum.

See the definition on page 114 of [gunter1992]. -/
class omega_complete_partial_order (α : Type*) extends partial_order α :=
(ωSup     : chain α → α)
(le_ωSup  : ∀(c:chain α), ∀ i, c i ≤ ωSup c)
(ωSup_le  : ∀(c:chain α) x, (∀ i, c i ≤ x) → ωSup c ≤ x)

end prio

namespace omega_complete_partial_order
variables {α : Type u} {β : Type v} {γ : Type*}
variables [omega_complete_partial_order α]

/-- Transfer a `omega_complete_partial_order` on `β` to a `omega_complete_partial_order` on `α`
using a strictly monotone function `f : β →o α`, a definition of ωSup and a proof that `f` is
continuous with regard to the provided `ωSup` and the ωCPO on `α`. -/
@[reducible]
protected def lift [partial_order β] (f : β →o α)
  (ωSup₀ : chain β → β)
  (h : ∀ x y, f x ≤ f y → x ≤ y)
  (h' : ∀ c, f (ωSup₀ c) = ωSup (c.map f)) : omega_complete_partial_order β :=
{ ωSup := ωSup₀,
  ωSup_le := λ c x hx, h _ _ (by rw h'; apply ωSup_le; intro; apply f.monotone (hx i)),
  le_ωSup := λ c i, h _ _ (by rw h'; apply le_ωSup (c.map f)) }

lemma le_ωSup_of_le {c : chain α} {x : α} (i : ℕ) (h : x ≤ c i) : x ≤ ωSup c :=
le_trans h (le_ωSup c _)

lemma ωSup_total {c : chain α} {x : α} (h : ∀ i, c i ≤ x ∨ x ≤ c i) : ωSup c ≤ x ∨ x ≤ ωSup c :=
classical.by_cases
  (assume : ∀ i, c i ≤ x, or.inl (ωSup_le _ _ this))
  (assume : ¬ ∀ i, c i ≤ x,
    have ∃ i, ¬ c i ≤ x,
      by simp only [not_forall] at this ⊢; assumption,
    let ⟨i, hx⟩ := this in
    have x ≤ c i, from (h i).resolve_left hx,
    or.inr $ le_ωSup_of_le _ this)

@[mono]
lemma ωSup_le_ωSup_of_le {c₀ c₁ : chain α} (h : c₀ ≤ c₁) : ωSup c₀ ≤ ωSup c₁ :=
ωSup_le _ _ $
λ i, Exists.rec_on (h i) $
λ j h, le_trans h (le_ωSup _ _)

lemma ωSup_le_iff (c : chain α) (x : α) : ωSup c ≤ x ↔ (∀ i, c i ≤ x) :=
begin
  split; intros,
  { transitivity ωSup c,
    exact le_ωSup _ _, assumption },
  exact ωSup_le _ _ ‹_›,
end

/-- A subset `p : α → Prop` of the type closed under `ωSup` induces an
`omega_complete_partial_order` on the subtype `{a : α // p a}`. -/
def subtype {α : Type*} [omega_complete_partial_order α] (p : α → Prop)
  (hp : ∀ (c : chain α), (∀ i ∈ c, p i) → p (ωSup c)) :
  omega_complete_partial_order (subtype p) :=
omega_complete_partial_order.lift
  (order_hom.subtype.val p)
  (λ c, ⟨ωSup _, hp (c.map (order_hom.subtype.val p)) (λ i ⟨n, q⟩, q.symm ▸ (c n).2)⟩)
  (λ x y h, h)
  (λ c, rfl)

section continuity
open chain

variables [omega_complete_partial_order β]
variables [omega_complete_partial_order γ]

/-- A monotone function `f : α →o β` is continuous if it distributes over ωSup.

In order to distinguish it from the (more commonly used) continuity from topology
(see topology/basic.lean), the present definition is often referred to as
"Scott-continuity" (referring to Dana Scott). It corresponds to continuity
in Scott topological spaces (not defined here). -/
def continuous (f : α →o β) : Prop :=
∀ c : chain α, f (ωSup c) = ωSup (c.map f)

/-- `continuous' f` asserts that `f` is both monotone and continuous. -/
def continuous' (f : α → β) : Prop :=
∃ hf : monotone f, continuous ⟨f, hf⟩

lemma continuous'.to_monotone {f : α → β} (hf : continuous' f) : monotone f := hf.fst

lemma continuous.of_bundled (f : α → β) (hf : monotone f)
  (hf' : continuous ⟨f, hf⟩) : continuous' f := ⟨hf, hf'⟩

lemma continuous.of_bundled' (f : α →o β) (hf' : continuous f) : continuous' f :=
⟨f.mono, hf'⟩

lemma continuous'.to_bundled (f : α → β) (hf : continuous' f) :
  continuous ⟨f, hf.to_monotone⟩ := hf.snd

@[simp, norm_cast] lemma continuous'_coe : ∀ {f : α →o β}, continuous' f ↔ continuous f
| ⟨f, hf⟩ := ⟨λ ⟨hf', hc⟩, hc, λ hc, ⟨hf, hc⟩⟩

variables (f : α →o β) (g : β →o γ)

lemma continuous_id : continuous (@order_hom.id α _) :=
by intro; rw c.map_id; refl

lemma continuous_comp (hfc : continuous f) (hgc : continuous g) : continuous (g.comp f):=
begin
  dsimp [continuous] at *, intro,
  rw [hfc,hgc,chain.map_comp]
end

lemma id_continuous' : continuous' (@id α) :=
continuous_id.of_bundled' _

lemma continuous_const (x : β) : continuous (order_hom.const α x) :=
λ c, eq_of_forall_ge_iff $ λ z, by simp [ωSup_le_iff]

lemma const_continuous' (x: β) : continuous' (function.const α x) :=
continuous.of_bundled' (order_hom.const α x) (continuous_const x)

end continuity

end omega_complete_partial_order

namespace part

variables {α : Type u} {β : Type v} {γ : Type*}
open omega_complete_partial_order

lemma eq_of_chain {c : chain (part α)} {a b : α} (ha : some a ∈ c) (hb : some b ∈ c) : a = b :=
begin
  cases ha with i ha, replace ha := ha.symm,
  cases hb with j hb, replace hb := hb.symm,
  wlog h : i ≤ j := le_total i j using [a b i j, b a j i],
  rw [eq_some_iff] at ha hb,
  have := c.monotone h _ ha, apply mem_unique this hb
end

/-- The (noncomputable) `ωSup` definition for the `ω`-CPO structure on `part α`. -/
protected noncomputable def ωSup (c : chain (part α)) : part α :=
if h : ∃a, some a ∈ c then some (classical.some h) else none

lemma ωSup_eq_some {c : chain (part α)} {a : α} (h : some a ∈ c) : part.ωSup c = some a :=
have ∃a, some a ∈ c, from ⟨a, h⟩,
have a' : some (classical.some this) ∈ c, from classical.some_spec this,
calc part.ωSup c = some (classical.some this) : dif_pos this
                ... = some a : congr_arg _ (eq_of_chain a' h)

lemma ωSup_eq_none {c : chain (part α)} (h : ¬∃a, some a ∈ c) : part.ωSup c = none :=
dif_neg h

lemma mem_chain_of_mem_ωSup {c : chain (part α)} {a : α} (h : a ∈ part.ωSup c) : some a ∈ c :=
begin
  simp [part.ωSup] at h, split_ifs at h,
  { have h' := classical.some_spec h_1,
    rw ← eq_some_iff at h, rw ← h, exact h' },
  { rcases h with ⟨ ⟨ ⟩ ⟩ }
end

noncomputable instance omega_complete_partial_order : omega_complete_partial_order (part α) :=
{ ωSup    := part.ωSup,
  le_ωSup := λ c i, by { intros x hx, rw ← eq_some_iff at hx ⊢,
                         rw [ωSup_eq_some, ← hx], rw ← hx, exact ⟨i,rfl⟩ },
  ωSup_le := by { rintros c x hx a ha, replace ha := mem_chain_of_mem_ωSup ha,
                  cases ha with i ha, apply hx i, rw ← ha, apply mem_some } }

section inst

lemma mem_ωSup (x : α) (c : chain (part α)) : x ∈ ωSup c ↔ some x ∈ c :=
begin
  simp [omega_complete_partial_order.ωSup,part.ωSup],
  split,
  { split_ifs, swap, rintro ⟨⟨⟩⟩,
    intro h', have hh := classical.some_spec h,
    simp at h', subst x, exact hh },
  { intro h,
    have h' : ∃ (a : α), some a ∈ c := ⟨_,h⟩,
    rw dif_pos h', have hh := classical.some_spec h',
    rw eq_of_chain hh h, simp }
end

end inst

end part

namespace pi

variables {α : Type*} {β : α → Type*} {γ : Type*}

open omega_complete_partial_order omega_complete_partial_order.chain

instance [∀a, omega_complete_partial_order (β a)] : omega_complete_partial_order (Πa, β a) :=
{ ωSup    := λc a, ωSup (c.map (pi.eval_order_hom a)),
  ωSup_le := assume c f hf a, ωSup_le _ _ $ by { rintro i, apply hf },
  le_ωSup := assume c i x, le_ωSup_of_le _ $ le_rfl }

namespace omega_complete_partial_order

variables [∀ x, omega_complete_partial_order $ β x]
variables [omega_complete_partial_order γ]

lemma flip₁_continuous'
  (f : ∀ x : α, γ → β x) (a : α) (hf : continuous' (λ x y, f y x)) :
  continuous' (f a) :=
continuous.of_bundled _
  (λ x y h, hf.to_monotone h a)
  (λ c, congr_fun (hf.to_bundled _ c) a)

lemma flip₂_continuous'
  (f : γ → Π x, β x) (hf : ∀ x, continuous' (λ g, f g x)) : continuous' f :=
continuous.of_bundled _
  (λ x y h a, (hf a).to_monotone h)
  (by intro c; ext a; apply (hf a).to_bundled _ c)

end omega_complete_partial_order

end pi

namespace prod

open omega_complete_partial_order
variables {α : Type*} {β : Type*} {γ : Type*}
variables [omega_complete_partial_order α]
variables [omega_complete_partial_order β]
variables [omega_complete_partial_order γ]

/-- The supremum of a chain in the product `ω`-CPO. -/
@[simps]
protected def ωSup (c : chain (α × β)) : α × β :=
(ωSup (c.map order_hom.fst), ωSup (c.map order_hom.snd))

@[simps ωSup_fst ωSup_snd]
instance : omega_complete_partial_order (α × β) :=
{ ωSup := prod.ωSup,
  ωSup_le := λ c ⟨x,x'⟩ h, ⟨ωSup_le _ _ $ λ i, (h i).1, ωSup_le _ _ $ λ i, (h i).2⟩,
  le_ωSup := λ c i,
    ⟨le_ωSup (c.map order_hom.fst) i, le_ωSup (c.map order_hom.snd) i⟩ }

end prod

namespace complete_lattice
variables (α : Type u)

/-- Any complete lattice has an `ω`-CPO structure where the countable supremum is a special case
of arbitrary suprema. -/

@[priority 100] -- see Note [lower instance priority]
instance [complete_lattice α] : omega_complete_partial_order α :=
{ ωSup    := λc, ⨆ i, c i,
  ωSup_le := λ ⟨c, _⟩ s hs, by simp only [supr_le_iff, order_hom.coe_fun_mk] at ⊢ hs;
    intros i; apply hs i,
  le_ωSup := assume ⟨c, _⟩ i, by simp only [order_hom.coe_fun_mk]; apply le_supr_of_le i; refl }

variables {α} {β : Type v} [omega_complete_partial_order α] [complete_lattice β]
open omega_complete_partial_order

lemma inf_continuous [is_total β (≤)] (f g : α →o β) (hf : continuous f) (hg : continuous g) :
  continuous (f ⊓ g) :=
begin
  intro c,
  apply eq_of_forall_ge_iff, intro z,
  simp only [inf_le_iff, hf c, hg c, ωSup_le_iff, ←forall_or_distrib_left, ←forall_or_distrib_right,
             function.comp_app, chain.map_coe, order_hom.has_inf_inf_coe],
  split,
  { introv h, apply h },
  { intros h i j,
    apply or.imp _ _ (h (max i j)); apply le_trans; mono*; try { exact le_rfl },
    { apply le_max_left },
    { apply le_max_right }, },
end

lemma inf_continuous' [is_total β (≤)] {f g : α → β} (hf : continuous' f) (hg : continuous' g) :
  continuous' (f ⊓ g) :=
⟨_, inf_continuous _ _ hf.snd hg.snd⟩

lemma Sup_continuous (s : set $ α →o β) (hs : ∀ f ∈ s, continuous f) :
  continuous (Sup s) :=
begin
  intro c, apply eq_of_forall_ge_iff, intro z,
  suffices : (∀ (f ∈ s) n, (f : _) (c n) ≤ z) ↔ (∀ n (f ∈ s), (f : _) (c n) ≤ z),
    by simpa [ωSup_le_iff, hs _ _ _] { contextual := tt },
  exact ⟨λ H n f hf, H f hf n, λ H f hf n, H n f hf⟩
end

lemma supr_continuous {ι : Sort*} {f : ι → α →o β} (h : ∀ i, continuous (f i)) :
  continuous (⨆ i, f i) :=
Sup_continuous _ $ set.forall_range_iff.2 h

theorem Sup_continuous' (s : set (α → β)) (hc : ∀ f ∈ s, continuous' f) :
  continuous' (Sup s) :=
begin
  lift s to set (α →o β) using λ f hf, (hc f hf).to_monotone,
  simp only [set.ball_image_iff, continuous'_coe] at hc,
  rw [Sup_image],
  norm_cast,
  exact supr_continuous (λ f, supr_continuous (λ hf, hc f hf)),
end

lemma sup_continuous {f g : α →o β} (hf : continuous f) (hg : continuous g) :
  continuous (f ⊔ g) :=
begin
  rw ← Sup_pair, apply Sup_continuous,
  rintro f (rfl|rfl|_); assumption
end

lemma top_continuous :
  continuous (⊤ : α →o β) :=
begin
  intro c, apply eq_of_forall_ge_iff, intro z,
  simp only [ωSup_le_iff, forall_const, chain.map_coe, (∘), function.const,
             order_hom.has_top_top, order_hom.const_coe_coe],
end

lemma bot_continuous :
  continuous (⊥ : α →o β) :=
begin
  rw ← Sup_empty,
  exact Sup_continuous _ (λ f hf, hf.elim),
end

end complete_lattice

namespace omega_complete_partial_order

variables {α : Type u} {α' : Type*} {β : Type v} {β' : Type*} {γ : Type*} {φ : Type*}

variables [omega_complete_partial_order α] [omega_complete_partial_order β]
variables [omega_complete_partial_order γ] [omega_complete_partial_order φ]
variables [omega_complete_partial_order α'] [omega_complete_partial_order β']

namespace order_hom

/-- The `ωSup` operator for monotone functions. -/
@[simps]
protected def ωSup (c : chain (α →o β)) : α →o β :=
{ to_fun := λ a, ωSup (c.map (order_hom.apply a)),
  monotone' := λ x y h, ωSup_le_ωSup_of_le (chain.map_le_map _ $ λ a, a.monotone h) }

@[simps ωSup_coe]
instance omega_complete_partial_order : omega_complete_partial_order (α →o β) :=
omega_complete_partial_order.lift order_hom.coe_fn_hom order_hom.ωSup
  (λ x y h, h) (λ c, rfl)

end order_hom

section
variables (α β)

/-- A monotone function on `ω`-continuous partial orders is said to be continuous
if for every chain `c : chain α`, `f (⊔ i, c i) = ⊔ i, f (c i)`.
This is just the bundled version of `order_hom.continuous`. -/
structure continuous_hom extends order_hom α β :=
(cont : continuous (order_hom.mk to_fun monotone'))

attribute [nolint doc_blame] continuous_hom.to_order_hom

infixr ` →𝒄 `:25 := continuous_hom -- Input: \r\MIc

instance : has_coe_to_fun (α →𝒄 β) (λ _, α → β) := ⟨λ f, f.to_order_hom.to_fun⟩

instance : has_coe (α →𝒄 β) (α →o β) :=
{ coe :=  continuous_hom.to_order_hom }

instance : partial_order (α →𝒄 β) :=
partial_order.lift (λ f, f.to_order_hom.to_fun) $ by rintro ⟨⟨⟩⟩ ⟨⟨⟩⟩ h; congr; exact h

/-- See Note [custom simps projection]. We need to specify this projection explicitly in this case,
  because it is a composition of multiple projections. -/
def continuous_hom.simps.apply (h : α →𝒄 β) : α → β := h

initialize_simps_projections continuous_hom
  (to_order_hom_to_fun → apply, -to_order_hom)

end

namespace continuous_hom

theorem congr_fun {f g : α →𝒄 β} (h : f = g) (x : α) : f x = g x :=
congr_arg (λ h : α →𝒄 β, h x) h

theorem congr_arg (f : α →𝒄 β) {x y : α} (h : x = y) : f x = f y :=
congr_arg (λ x : α, f x) h

protected lemma monotone (f : α →𝒄 β) : monotone f := f.monotone'

@[mono] lemma apply_mono {f g : α →𝒄 β} {x y : α} (h₁ : f ≤ g) (h₂ : x ≤ y) : f x ≤ g y :=
order_hom.apply_mono (show (f : α →o β) ≤ g, from h₁) h₂

lemma ite_continuous' {p : Prop} [hp : decidable p] (f g : α → β)
  (hf : continuous' f) (hg : continuous' g) : continuous' (λ x, if p then f x else g x) :=
by split_ifs; simp *

lemma ωSup_bind {β γ : Type v} (c : chain α) (f : α →o part β) (g : α →o β → part γ) :
  ωSup (c.map (f.bind g)) = ωSup (c.map f) >>= ωSup (c.map g) :=
begin
  apply eq_of_forall_ge_iff, intro x,
  simp only [ωSup_le_iff, part.bind_le, chain.mem_map_iff, and_imp, order_hom.bind_coe,
    exists_imp_distrib],
  split; intro h''',
  { intros b hb, apply ωSup_le _ _ _,
    rintros i y hy, simp only [part.mem_ωSup] at hb,
    rcases hb with ⟨j,hb⟩, replace hb := hb.symm,
    simp only [part.eq_some_iff, chain.map_coe, function.comp_app, order_hom.apply_coe]
      at hy hb,
    replace hb : b ∈ f (c (max i j))   := f.mono (c.mono (le_max_right i j)) _ hb,
    replace hy : y ∈ g (c (max i j)) b := g.mono (c.mono (le_max_left i j)) _ _ hy,
    apply h''' (max i j),
    simp only [exists_prop, part.bind_eq_bind, part.mem_bind_iff, chain.map_coe,
               function.comp_app, order_hom.bind_coe],
    exact ⟨_,hb,hy⟩, },
  { intros i, intros y hy,
    simp only [exists_prop, part.bind_eq_bind, part.mem_bind_iff, chain.map_coe,
               function.comp_app, order_hom.bind_coe] at hy,
    rcases hy with ⟨b,hb₀,hb₁⟩,
    apply h''' b _,
    { apply le_ωSup (c.map g) _ _ _ hb₁ },
    { apply le_ωSup (c.map f) i _ hb₀ } },
end

lemma bind_continuous' {β γ : Type v} (f : α → part β) (g : α → β → part γ) :
  continuous' f → continuous' g →
  continuous' (λ x, f x >>= g x)
| ⟨hf,hf'⟩ ⟨hg,hg'⟩ :=
continuous.of_bundled' (order_hom.bind ⟨f,hf⟩ ⟨g,hg⟩)
  (by intro c; rw [ωSup_bind, ← hf', ← hg']; refl)

lemma map_continuous' {β γ : Type v} (f : β → γ) (g : α → part β)
  (hg : continuous' g) :
  continuous' (λ x, f <$> g x) :=
by simp only [map_eq_bind_pure_comp];
   apply bind_continuous' _ _ hg;
   apply const_continuous'

lemma seq_continuous' {β γ : Type v} (f : α → part (β → γ)) (g : α → part β)
  (hf : continuous' f) (hg : continuous' g) :
  continuous' (λ x, f x <*> g x) :=
by simp only [seq_eq_bind_map];
   apply bind_continuous' _ _ hf;
   apply pi.omega_complete_partial_order.flip₂_continuous'; intro;
   apply map_continuous' _ _ hg

lemma continuous (F : α →𝒄 β) (C : chain α) : F (ωSup C) = ωSup (C.map F) :=
continuous_hom.cont _ _

/-- Construct a continuous function from a bare function, a continuous function, and a proof that
they are equal. -/
@[simps, reducible]
def of_fun (f : α → β) (g : α →𝒄 β) (h : f = g) : α →𝒄 β :=
by refine {to_order_hom := {to_fun := f, ..}, ..}; subst h; rcases g with ⟨⟨⟩⟩; assumption

/-- Construct a continuous function from a monotone function with a proof of continuity. -/
@[simps, reducible]
def of_mono (f : α →o β) (h : ∀ c : chain α, f (ωSup c) = ωSup (c.map f)) : α →𝒄 β :=
{ to_fun := f,
  monotone' := f.monotone,
  cont := h }

/-- The identity as a continuous function. -/
@[simps]
def id : α →𝒄 α :=
of_mono order_hom.id continuous_id

/-- The composition of continuous functions. -/
@[simps]
def comp (f : β →𝒄 γ) (g : α →𝒄 β) : α →𝒄 γ :=
of_mono (order_hom.comp (↑f) (↑g)) (continuous_comp _ _ g.cont f.cont)

@[ext]
protected lemma ext (f g : α →𝒄 β) (h : ∀ x, f x = g x) : f = g :=
by cases f; cases g; congr; ext; apply h

protected lemma coe_inj (f g : α →𝒄 β) (h : (f : α → β) = g) : f = g :=
continuous_hom.ext _ _ $ _root_.congr_fun h

@[simp]
lemma comp_id (f : β →𝒄 γ) : f.comp id = f := by ext; refl

@[simp]
lemma id_comp (f : β →𝒄 γ) : id.comp f = f := by ext; refl

@[simp]
lemma comp_assoc (f : γ →𝒄 φ) (g : β →𝒄 γ) (h : α →𝒄 β) : f.comp (g.comp h) = (f.comp g).comp h :=
by ext; refl

@[simp]
lemma coe_apply (a : α) (f : α →𝒄 β) : (f : α →o β) a = f a := rfl

/-- `function.const` is a continuous function. -/
def const (x : β) : α →𝒄 β :=
of_mono (order_hom.const _ x) (continuous_const x)

@[simp] theorem const_apply (f : β) (a : α) : const f a = f := rfl

instance [inhabited β] : inhabited (α →𝒄 β) :=
⟨ const default ⟩

namespace prod

/-- The application of continuous functions as a monotone function.

(It would make sense to make it a continuous function, but we are currently constructing a
`omega_complete_partial_order` instance for `α →𝒄 β`, and we cannot use it as the domain or image
of a continuous function before we do.) -/
@[simps]
def apply : (α →𝒄 β) × α →o β :=
{ to_fun := λ f, f.1 f.2,
  monotone' := λ x y h, by dsimp; transitivity y.fst x.snd; [apply h.1, apply y.1.monotone h.2] }

end prod

/-- The map from continuous functions to monotone functions is itself a monotone function. -/
@[simps]
def to_mono : (α →𝒄 β) →o (α →o β) :=
{ to_fun := λ f, f,
  monotone' := λ x y h, h }

/-- When proving that a chain of applications is below a bound `z`, it suffices to consider the
functions and values being selected from the same index in the chains.

This lemma is more specific than necessary, i.e. `c₀` only needs to be a
chain of monotone functions, but it is only used with continuous functions. -/
@[simp]
lemma forall_forall_merge (c₀ : chain (α →𝒄 β)) (c₁ : chain α) (z : β) :
  (∀ (i j : ℕ), (c₀ i) (c₁ j) ≤ z) ↔ ∀ (i : ℕ), (c₀ i) (c₁ i) ≤ z :=
begin
  split; introv h,
  { apply h },
  { apply le_trans _ (h (max i j)),
    transitivity c₀ i (c₁ (max i j)),
    { apply (c₀ i).monotone, apply c₁.monotone, apply le_max_right },
    { apply c₀.monotone, apply le_max_left } }
end

@[simp]
lemma forall_forall_merge' (c₀ : chain (α →𝒄 β)) (c₁ : chain α) (z : β) :
  (∀ (j i : ℕ), (c₀ i) (c₁ j) ≤ z) ↔ ∀ (i : ℕ), (c₀ i) (c₁ i) ≤ z :=
by rw [forall_swap,forall_forall_merge]

/-- The `ωSup` operator for continuous functions, which takes the pointwise countable supremum
of the functions in the `ω`-chain. -/
@[simps]
protected def ωSup (c : chain (α →𝒄 β)) : α →𝒄 β :=
continuous_hom.of_mono (ωSup $ c.map to_mono)
begin
  intro c',
  apply eq_of_forall_ge_iff, intro z,
  simp only [ωSup_le_iff, (c _).continuous, chain.map_coe, order_hom.apply_coe,
    to_mono_coe, coe_apply, order_hom.omega_complete_partial_order_ωSup_coe,
    forall_forall_merge, forall_forall_merge', (∘), function.eval],
end

@[simps ωSup]
instance : omega_complete_partial_order (α →𝒄 β) :=
omega_complete_partial_order.lift continuous_hom.to_mono continuous_hom.ωSup
  (λ x y h, h) (λ c, rfl)

lemma ωSup_def (c : chain (α →𝒄 β)) (x : α) : ωSup c x = continuous_hom.ωSup c x := rfl

lemma ωSup_ωSup (c₀ : chain (α →𝒄 β)) (c₁ : chain α) :
  ωSup c₀ (ωSup c₁) = ωSup (continuous_hom.prod.apply.comp $ c₀.zip c₁) :=
begin
  apply eq_of_forall_ge_iff, intro z,
  simp only [ωSup_le_iff, (c₀ _).continuous, chain.map_coe, to_mono_coe, coe_apply,
    order_hom.omega_complete_partial_order_ωSup_coe, ωSup_def, forall_forall_merge,
    chain.zip_coe, order_hom.prod_map_coe, order_hom.diag_coe, prod.map_mk,
    order_hom.apply_coe, function.comp_app, prod.apply_coe,
    order_hom.comp_coe, ωSup_apply, function.eval],
end

/-- A family of continuous functions yields a continuous family of functions. -/
@[simps]
def flip {α : Type*} (f : α → β →𝒄 γ) : β →𝒄 α → γ :=
{ to_fun := λ x y, f y x,
  monotone' := λ x y h a, (f a).monotone h,
  cont := by intro; ext; change f x _ = _; rw [(f x).continuous ]; refl, }

/-- `part.bind` as a continuous function. -/
@[simps { rhs_md := reducible }]
noncomputable def bind {β γ : Type v}
  (f : α →𝒄 part β) (g : α →𝒄 β → part γ) : α →𝒄 part γ :=
of_mono (order_hom.bind (↑f) (↑g)) $ λ c, begin
  rw [order_hom.bind, ← order_hom.bind, ωSup_bind, ← f.continuous, ← g.continuous],
  refl
end

/-- `part.map` as a continuous function. -/
@[simps {rhs_md := reducible}]
noncomputable def map {β γ : Type v} (f : β → γ) (g : α →𝒄 part β) : α →𝒄 part γ :=
of_fun (λ x, f <$> g x) (bind g (const (pure ∘ f))) $
by ext; simp only [map_eq_bind_pure_comp, bind_apply, order_hom.bind_coe, const_apply,
  order_hom.const_coe_coe, coe_apply]

/-- `part.seq` as a continuous function. -/
@[simps {rhs_md := reducible}]
noncomputable def seq {β γ : Type v} (f : α →𝒄 part (β → γ)) (g : α →𝒄 part β) :
  α →𝒄 part γ :=
of_fun (λ x, f x <*> g x) (bind f $ (flip $ _root_.flip map g))
  (by ext; simp only [seq_eq_bind_map, flip, part.bind_eq_bind, map_apply, part.mem_bind_iff,
                      bind_apply, order_hom.bind_coe, coe_apply, flip_apply]; refl)

end continuous_hom

end omega_complete_partial_order


/-
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 order.complete_lattice
import order.hom.lattice

/-!
# Complete lattice homomorphisms

This file defines frame homorphisms and complete 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 `⨅`.
* `frame_hom`: Frame homomorphisms. Maps which preserve `⨆`, `⊓` and `⊤`.
* `complete_lattice_hom`: Complete lattice homomorphisms. Maps which preserve `⨆` and `⨅`.

## Typeclasses

* `Sup_hom_class`
* `Inf_hom_class`
* `frame_hom_class`
* `complete_lattice_hom_class`

## Concrete homs

* `complete_lattice.set_preimage`: `set.preimage` as a complete lattice homomorphism.
-/

open function order_dual set

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

/-- The type of `⨆`-preserving functions from `α` to `β`. -/
structure Sup_hom (α β : Type*) [has_Sup α] [has_Sup β] :=
(to_fun   : α → β)
(map_Sup' (s : set α) : to_fun (Sup s) = Sup (to_fun '' s))

/-- The type of `⨅`-preserving functions from `α` to `β`. -/
structure Inf_hom (α β : Type*) [has_Inf α] [has_Inf β] :=
(to_fun   : α → β)
(map_Inf' (s : set α) : to_fun (Inf s) = Inf (to_fun '' s))

/-- The type of frame homomorphisms from `α` to `β`. They preserve finite meets and arbitrary joins.
-/
structure frame_hom (α β : Type*) [complete_lattice α] [complete_lattice β]
  extends inf_top_hom α β :=
(map_Sup' (s : set α) : to_fun (Sup s) = Sup (to_fun '' s))

/-- The type of complete lattice homomorphisms from `α` to `β`. -/
structure complete_lattice_hom (α β : Type*) [complete_lattice α] [complete_lattice β]
  extends Inf_hom α β :=
(map_Sup' (s : set α) : to_fun (Sup s) = Sup (to_fun '' s))

/-- `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) (s : set α) : f (Sup s) = Sup (f '' s))

/-- `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) (s : set α) : f (Inf s) = Inf (f '' s))

/-- `frame_hom_class F α β` states that `F` is a type of frame morphisms. They preserve `⊓` and `⨆`.

You should extend this class when you extend `frame_hom`. -/
class frame_hom_class (F : Type*) (α β : out_param $ Type*) [complete_lattice α]
  [complete_lattice β] extends inf_top_hom_class F α β :=
(map_Sup (f : F) (s : set α) : f (Sup s) = Sup (f '' s))

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

You should extend this class when you extend `complete_lattice_hom`. -/
class complete_lattice_hom_class (F : Type*) (α β : out_param $ Type*) [complete_lattice α]
  [complete_lattice β] extends Inf_hom_class F α β :=
(map_Sup (f : F) (s : set α) : f (Sup s) = Sup (f '' s))

export Sup_hom_class (map_Sup)
export Inf_hom_class (map_Inf)

attribute [simp] map_Sup map_Inf

lemma map_supr [has_Sup α] [has_Sup β] [Sup_hom_class F α β] (f : F) (g : ι → α) :
  f (⨆ i, g i) = ⨆ i, f (g i) :=
by rw [supr, supr, map_Sup, set.range_comp]

lemma map_supr₂ [has_Sup α] [has_Sup β] [Sup_hom_class F α β] (f : F) (g : Π i, κ i → α) :
  f (⨆ i j, g i j) = ⨆ i j, f (g i j) :=
by simp_rw map_supr

lemma map_infi [has_Inf α] [has_Inf β] [Inf_hom_class F α β] (f : F) (g : ι → α) :
  f (⨅ i, g i) = ⨅ i, f (g i) :=
by rw [infi, infi, map_Inf, set.range_comp]

lemma map_infi₂ [has_Inf α] [has_Inf β] [Inf_hom_class F α β] (f : F) (g : Π i, κ i → α) :
  f (⨅ i j, g i j) = ⨅ i j, f (g i j) :=
by simp_rw map_infi

@[priority 100] -- See note [lower instance priority]
instance Sup_hom_class.to_sup_bot_hom_class [complete_lattice α] [complete_lattice β]
  [Sup_hom_class F α β] :
  sup_bot_hom_class F α β :=
{ map_sup := λ f a b, by rw [←Sup_pair, map_Sup, set.image_pair, Sup_pair],
  map_bot := λ f, by rw [←Sup_empty, map_Sup, set.image_empty, Sup_empty] }

@[priority 100] -- See note [lower instance priority]
instance Inf_hom_class.to_inf_top_hom_class [complete_lattice α] [complete_lattice β]
  [Inf_hom_class F α β] :
  inf_top_hom_class F α β :=
{ map_inf := λ f a b, by rw [←Inf_pair, map_Inf, set.image_pair, Inf_pair],
  map_top := λ f, by rw [←Inf_empty, map_Inf, set.image_empty, Inf_empty] }

@[priority 100] -- See note [lower instance priority]
instance frame_hom_class.to_Sup_hom_class [complete_lattice α] [complete_lattice β]
  [frame_hom_class F α β] :
  Sup_hom_class F α β :=
{ .. ‹frame_hom_class F α β› }

@[priority 100] -- See note [lower instance priority]
instance frame_hom_class.to_bounded_lattice_hom_class [complete_lattice α] [complete_lattice β]
  [frame_hom_class F α β] :
  bounded_lattice_hom_class F α β :=
{ .. ‹frame_hom_class F α β›, ..Sup_hom_class.to_sup_bot_hom_class }

@[priority 100] -- See note [lower instance priority]
instance complete_lattice_hom_class.to_frame_hom_class [complete_lattice α] [complete_lattice β]
  [complete_lattice_hom_class F α β] :
  frame_hom_class F α β :=
{ .. ‹complete_lattice_hom_class F α β›, ..Inf_hom_class.to_inf_top_hom_class }

@[priority 100] -- See note [lower instance priority]
instance complete_lattice_hom_class.to_bounded_lattice_hom_class [complete_lattice α]
  [complete_lattice β] [complete_lattice_hom_class F α β] :
  bounded_lattice_hom_class F α β :=
{ ..Sup_hom_class.to_sup_bot_hom_class, ..Inf_hom_class.to_inf_top_hom_class }

@[priority 100] -- See note [lower instance priority]
instance order_iso_class.to_Sup_hom_class [complete_lattice α] [complete_lattice β]
  [order_iso_class F α β] :
  Sup_hom_class F α β :=
⟨λ f s, eq_of_forall_ge_iff $ λ c, by simp only [←le_map_inv_iff, Sup_le_iff, set.ball_image_iff]⟩

@[priority 100] -- See note [lower instance priority]
instance order_iso_class.to_Inf_hom_class [complete_lattice α] [complete_lattice β]
  [order_iso_class F α β] :
  Inf_hom_class F α β :=
⟨λ f s, eq_of_forall_le_iff $ λ c, by simp only [←map_inv_le_iff, le_Inf_iff, set.ball_image_iff]⟩

@[priority 100] -- See note [lower instance priority]
instance order_iso_class.to_complete_lattice_hom_class [complete_lattice α] [complete_lattice β]
  [order_iso_class F α β] :
  complete_lattice_hom_class F α β :=
{ ..order_iso_class.to_Sup_hom_class, ..order_iso_class.to_lattice_hom_class }

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 [complete_lattice α] [complete_lattice β] [frame_hom_class F α β] :
  has_coe_t F (frame_hom α β) :=
⟨λ f, ⟨f, map_Sup f⟩⟩

instance [complete_lattice α] [complete_lattice β] [complete_lattice_hom_class F α β] :
  has_coe_t F (complete_lattice_hom α β) :=
⟨λ f, ⟨f, map_Sup f⟩⟩

/-! ### 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 α β) (λ _, α → β) := fun_like.has_coe_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' }

variables (α)

/-- `id` as a `Sup_hom`. -/
protected def id : Sup_hom α α := ⟨id, λ s, by rw [id, set.image_id]⟩

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' := λ s, by rw [comp_apply, map_Sup, map_Sup, set.image_image] }

@[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 := ext $ λ a, rfl
@[simp] lemma id_comp (f : Sup_hom α β) : (Sup_hom.id β).comp f = f := 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, 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, ext $ λ a, hg $ by rw [←comp_apply, h, comp_apply], congr_arg _⟩

end has_Sup

variables [complete_lattice β]

instance : partial_order (Sup_hom α β) := partial_order.lift _ fun_like.coe_injective

instance : has_bot (Sup_hom α β) :=
⟨⟨λ _, ⊥, λ s, begin
  obtain rfl | hs := s.eq_empty_or_nonempty,
  { rw [set.image_empty, Sup_empty] },
  { rw [hs.image_const, Sup_singleton] }
end⟩⟩

instance : order_bot (Sup_hom α β) := ⟨⊥, λ f a, bot_le⟩

@[simp] lemma coe_bot : ⇑(⊥ : Sup_hom α β) = ⊥ := rfl
@[simp] lemma bot_apply (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 α β) (λ _, α → β) := fun_like.has_coe_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 a `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' }

variables (α)

/-- `id` as an `Inf_hom`. -/
protected def id : Inf_hom α α := ⟨id, λ s, by rw [id, set.image_id]⟩

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 a `Inf_hom`. -/
def comp (f : Inf_hom β γ) (g : Inf_hom α β) : Inf_hom α γ :=
{ to_fun := f ∘ g,
  map_Inf' := λ s, by rw [comp_apply, map_Inf, map_Inf, set.image_image] }

@[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 := ext $ λ a, rfl
@[simp] lemma id_comp (f : Inf_hom α β) : (Inf_hom.id β).comp f = f := 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, 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, ext $ λ a, hg $ by rw [←comp_apply, h, comp_apply], congr_arg _⟩

end has_Inf

variables [complete_lattice β]

instance : partial_order (Inf_hom α β) := partial_order.lift _ fun_like.coe_injective

instance : has_top (Inf_hom α β) :=
⟨⟨λ _, ⊤, λ s, begin
  obtain rfl | hs := s.eq_empty_or_nonempty,
  { rw [set.image_empty, Inf_empty] },
  { rw [hs.image_const, Inf_singleton] }
end⟩⟩

instance : order_top (Inf_hom α β) := ⟨⊤, λ f a, le_top⟩

@[simp] lemma coe_top : ⇑(⊤ : Inf_hom α β) = ⊤ := rfl
@[simp] lemma top_apply (a : α) : (⊤ : Inf_hom α β) a = ⊤ := rfl

end Inf_hom

/-! ### Frame homomorphisms -/

namespace frame_hom
variables [complete_lattice α] [complete_lattice β] [complete_lattice γ] [complete_lattice δ]

instance : frame_hom_class (frame_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' }

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

/-- Reinterpret a `frame_hom` as a `lattice_hom`. -/
def to_lattice_hom (f : frame_hom α β) : lattice_hom α β := f

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

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

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

variables (α)

/-- `id` as a `frame_hom`. -/
protected def id : frame_hom α α := { to_inf_top_hom := inf_top_hom.id α, ..Sup_hom.id α }

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

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

variables {α}

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

/-- Composition of `frame_hom`s as a `frame_hom`. -/
def comp (f : frame_hom β γ) (g : frame_hom α β) : frame_hom α γ :=
{ to_inf_top_hom := f.to_inf_top_hom.comp g.to_inf_top_hom,
  ..(f : Sup_hom β γ).comp (g : Sup_hom α β) }

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

lemma cancel_right {g₁ g₂ : frame_hom β γ} {f : frame_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 : frame_hom β γ} {f₁ f₂ : frame_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 _⟩

instance : partial_order (frame_hom α β) := partial_order.lift _ fun_like.coe_injective

end frame_hom

/-! ### Complete lattice homomorphisms -/

namespace complete_lattice_hom
variables [complete_lattice α] [complete_lattice β] [complete_lattice γ] [complete_lattice δ]

instance : complete_lattice_hom_class (complete_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' }

/-- Reinterpret a `complete_lattice_hom` as a `Sup_hom`. -/
def to_Sup_hom (f : complete_lattice_hom α β) : Sup_hom α β := f

/-- Reinterpret a `complete_lattice_hom` as a `bounded_lattice_hom`. -/
def to_bounded_lattice_hom (f : complete_lattice_hom α β) : bounded_lattice_hom α β := f

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

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

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

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

variables (α)

/-- `id` as a `complete_lattice_hom`. -/
protected def id : complete_lattice_hom α α := { to_fun := id, ..Sup_hom.id α, ..Inf_hom.id α }

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

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

variables {α}

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

/-- Composition of `complete_lattice_hom`s as a `complete_lattice_hom`. -/
def comp (f : complete_lattice_hom β γ) (g : complete_lattice_hom α β) : complete_lattice_hom α γ :=
{ to_Inf_hom := f.to_Inf_hom.comp g.to_Inf_hom, ..f.to_Sup_hom.comp g.to_Sup_hom }

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

lemma cancel_right {g₁ g₂ : complete_lattice_hom β γ} {f : complete_lattice_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 : complete_lattice_hom β γ} {f₁ f₂ : complete_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 complete_lattice_hom

/-! ### Dual homs -/

namespace Sup_hom
variables [has_Sup α] [has_Sup β] [has_Sup γ]

/-- Reinterpret a `⨆`-homomorphism as an `⨅`-homomorphism between the dual orders. -/
@[simps] protected def dual : Sup_hom α β ≃ Inf_hom (order_dual α) (order_dual β) :=
{ to_fun := λ f, ⟨to_dual ∘ f ∘ of_dual, f.map_Sup'⟩,
  inv_fun := λ f, ⟨of_dual ∘ f ∘ to_dual, f.map_Inf'⟩,
  left_inv := λ f, Sup_hom.ext $ λ a, rfl,
  right_inv := λ f, Inf_hom.ext $ λ a, rfl }

@[simp] lemma dual_id : (Sup_hom.id α).dual = Inf_hom.id _ := rfl
@[simp]

@[simp] lemma symm_dual_id : Sup_hom.dual.symm (Inf_hom.id _) = Sup_hom.id α := rfl
@[simp] lemma symm_dual_comp (g : Inf_hom (order_dual β) (order_dual γ))
  (f : Inf_hom (order_dual α) (order_dual β)) :
  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 `⨅`-homomorphism as a `⨆`-homomorphism between the dual orders. -/
@[simps] protected def dual : Inf_hom α β ≃ Sup_hom (order_dual α) (order_dual β) :=
{ to_fun := λ f, { to_fun := to_dual ∘ f ∘ of_dual,
                   map_Sup' := λ _, congr_arg to_dual (map_Inf f _) },
  inv_fun := λ f, { to_fun := of_dual ∘ f ∘ to_dual,
                   map_Inf' := λ _, congr_arg of_dual (map_Sup f _) },
  left_inv := λ f, Inf_hom.ext $ λ a, rfl,
  right_inv := λ f, Sup_hom.ext $ λ a, 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 (order_dual β) (order_dual γ))
  (f : Sup_hom (order_dual α) (order_dual β)) :
  Inf_hom.dual.symm (g.comp f) = (Inf_hom.dual.symm g).comp (Inf_hom.dual.symm f) := rfl

end Inf_hom

namespace complete_lattice_hom
variables [complete_lattice α] [complete_lattice β] [complete_lattice γ]

/-- Reinterpret a complete lattice homomorphism as a complete lattice homomorphism between the dual
lattices. -/
@[simps] protected def dual :
   complete_lattice_hom α β ≃ complete_lattice_hom (order_dual α) (order_dual β) :=
{ to_fun := λ f, ⟨f.to_Sup_hom.dual, f.map_Inf'⟩,
  inv_fun := λ f, ⟨f.to_Sup_hom.dual, f.map_Inf'⟩,
  left_inv := λ f, ext $ λ a, rfl,
  right_inv := λ f, ext $ λ a, rfl }

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

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

end complete_lattice_hom

/-! ### Concrete homs -/

namespace complete_lattice_hom

/-- `set.preimage` as a complete lattice homomorphism. -/
def set_preimage (f : α → β) : complete_lattice_hom (set β) (set α) :=
{ to_fun := preimage f,
  map_Sup' := λ s, preimage_sUnion.trans $ by simp only [set.Sup_eq_sUnion, set.sUnion_image],
  map_Inf' := λ s, preimage_sInter.trans $ by simp only [set.Inf_eq_sInter, set.sInter_image] }

@[simp] lemma coe_set_preimage (f : α → β) : ⇑(set_preimage f) = preimage f := rfl
@[simp] lemma set_preimage_apply (f : α → β) (s : set β) : set_preimage f s = s.preimage f := rfl
@[simp] lemma set_preimage_id : set_preimage (id : α → α) = complete_lattice_hom.id _ := rfl
-- This lemma can't be `simp` because `g ∘ f` matches anything (`id ∘ f = f` synctatically)
lemma set_preimage_comp (g : β → γ) (f : α → β) :
  set_preimage (g ∘ f) = (set_preimage f).comp (set_preimage g) := rfl

end complete_lattice_hom


universe u
variable {α : Type u}

def split : List α → List α × List α
| []       => ([], [])
| [a]      => ([a], [])
| a::b::as => (a :: (split as).1, b :: (split as).2)

theorem ex1 : split [1, 2, 3, 4, 5] = ([1, 3, 5], [2, 4]) :=
rfl