agda-spa/lean/Spa/Lattice.lean

import Mathlib.Order.Lattice
import Mathlib.Order.RelSeries

namespace Spa

def Monotone₂ {α β γ : Type*} [Preorder α] [Preorder β] [Preorder γ]
    (f : α → β → γ) : Prop :=
  (∀ b, Monotone (f · b)) ∧ (∀ a, Monotone (f a ·))

section Folds

variable {α β : Type*} [Preorder α] [Preorder β]

theorem foldr_mono {l₁ l₂ : List α} (f : α → β → β) {b₁ b₂ : β}
    (hl : List.Forall₂ (· ≤ ·) l₁ l₂) (hb : b₁ ≤ b₂)
    (hf₁ : ∀ b, Monotone fun a => f a b) (hf₂ : ∀ a, Monotone (f a)) :
    l₁.foldr f b₁ ≤ l₂.foldr f b₂ := by
  induction hl with
  | nil => exact hb
  | cons hxy _ ih =>
    exact le_trans (hf₁ _ hxy) (hf₂ _ ih)

theorem foldl_mono {l₁ l₂ : List α} (f : β → α → β) {b₁ b₂ : β}
    (hl : List.Forall₂ (· ≤ ·) l₁ l₂) (hb : b₁ ≤ b₂)
    (hf₁ : ∀ a, Monotone fun b => f b a) (hf₂ : ∀ b, Monotone (f b)) :
    l₁.foldl f b₁ ≤ l₂.foldl f b₂ := by
  induction hl generalizing b₁ b₂ with
  | nil => exact hb
  | cons hxy _ ih =>
    exact ih (le_trans (hf₁ _ hb) (hf₂ _ hxy))

omit [Preorder α] in
theorem foldr_mono' (l : List α) (f : α → β → β)
    (hf : ∀ a, Monotone (f a ·)) : Monotone fun b => l.foldr f b := by
  intro b₁ b₂ hb
  induction l with
  | nil => exact hb
  | cons x xs ih => exact hf x ih

omit [Preorder α] in
theorem foldl_mono' (l : List α) (f : β → α → β)
    (hf : ∀ a, Monotone (f · a)) : Monotone fun b => l.foldl f b := by
  intro b₁ b₂ hb
  induction l generalizing b₁ b₂ with
  | nil => exact hb
  | cons x xs ih => exact ih (hf x hb)

end Folds

def BoundedChains (α : Type*) [Preorder α] (n : ℕ) : Prop :=
  ∀ c : LTSeries α, c.length ≤ n

structure PointedLTSeries (α : Type*) (f t : α)(n : ℕ) [Preorder α] where
  series : LTSeries α
  head_series : series.head = f
  last_series : series.last = t
  length_series : series.length = n

theorem BoundedChains.no_longer {α : Type*} [Preorder α] {n : ℕ}
    (h : BoundedChains α n) (c : LTSeries α) : c.length ≠ n + 1 :=
  fun hc => absurd (h c) (by omega)

class FiniteHeightLattice (α : Type*) [Lattice α] extends Bot α, Top α where
  height : ℕ
  longest_chain : PointedLTSeries α ⊥ ⊤ height
  chains_bounded : BoundedChains α height

namespace FixedHeight

variable {α : Type*} [Lattice α] {h : ℕ}

theorem bot_le [FiniteHeightLattice α] : ∀ (a : α), ⊥ ≤ a := by
  intro a
  by_cases heq : ⊥ ⊓ a = ⊥
  · exact inf_eq_left.mp heq
  · exfalso
    have lc := FiniteHeightLattice.longest_chain (α := α)
    have hlt : ⊥ ⊓ a < lc.series.head := by
      rw [lc.head_series]
      exact lt_of_le_of_ne inf_le_left heq
    exact FiniteHeightLattice.chains_bounded.no_longer
      (lc.series.cons (⊥ ⊓ a) hlt)
      (by simp [RelSeries.cons_length, lc.length_series])

end FixedHeight

namespace FiniteHeightLattice

variable (α : Type*) [Lattice α] [FiniteHeightLattice α]

theorem bot_le (a : α) : (⊥ : α) ≤ a := FixedHeight.bot_le a

end FiniteHeightLattice

end Spa