import Saturn.Core
import Saturn.FinSeq
import Saturn.Vector
import Saturn.Clause
open Nat
open FinSeq

/-
If a SAT problem is not satisfiable, then there is a resolution tree that proves it.
Here we define the resolution tree as a structure, building up from resolution triples,
which are proofs of a clause by resolution from other clauses. The apex of the tree is the
empty clause, which is a contradiction.

We also construct lifts of a resolution tree from a branch. The lift is either a contradiction
or the proof of a unit clause associated to a branch.
-/

theorem not_not_eq(bf b bb : Bool) : Not (b = bf) → Not (bb = bf) → b = bb :=
  match bf with
  | true => fun w ww =>
    Eq.trans (eq_false_of_ne_true w) (Eq.symm (eq_false_of_ne_true ww))
  | false => fun w ww =>
    Eq.trans (eq_true_of_ne_false w) (Eq.symm (eq_true_of_ne_false ww))

/-
The structure `Join` corresponds to the values of a literal in the three clauses in a proof
by resolution, with the literal not the literal being resolved, i.e., the one that appears
with opposite signs.
-/
inductive Join (left right top : Option Bool) where
  | noneNone : (left = none) → (right = none) → (top = none)→ Join left right top
  | noneSome : (b : Bool) → (left = none) → (right = some b) → (top = some b)→ Join left right top
  | someNone : (b : Bool) → (left = some b) → (right = none) → (top = some b)→ Join left right top
  | someSome : (b : Bool) → (left = some b) → (right = some b) → (top = some b)→ Join left right top

-- Join given the bottom literals and consistency
def getJoin (bf : Bool)(left right : Option Bool) :
  Not (left = some bf) → Not (right = some bf) →
    Σ (top : Option Bool),  Join left right top :=
      match left with
      | none =>
        match right with
        | none => fun _ _ => ⟨none, Join.noneNone rfl rfl rfl⟩
        | some b => fun _ w =>
          if c: b = bf then
            absurd (congrArg some c) w
          else
            ⟨some b, Join.noneSome b rfl rfl rfl⟩
      | some b =>
        fun w =>
          if c: b = bf then
            absurd (congrArg some c) w
          else
            match right with
            | none =>
              fun wr => ⟨some b, Join.someNone b rfl rfl rfl⟩
            | some bb =>
              fun wr =>
                have lem1 : Not (bb = bf) := by
                  intro hyp
                  exact (wr (congrArg some hyp))
                have lem2 : bb = b := not_not_eq bf bb b lem1 c
                ⟨some b, Join.someSome b rfl (congrArg some lem2) rfl⟩

-- deduction that the top of the join is not `some bf` if the bottom ones are not
theorem top_of_join_not_positive(bf : Bool)(left right top: Option Bool): Join left right top →
    Not (left = some bf) → Not (right = some bf) →
       Not (top = some bf) :=
        fun join =>
          match join with
          | Join.noneNone _ _ wt => fun _ _ hyp =>
            let lem := Eq.trans (Eq.symm hyp) wt
            Option.noConfusion lem
          | Join.someNone b wl _ wt =>
            fun nwl _  hyp =>
              have lem : left = some bf := by
                rw [wl]
                rw [← wt]
                assumption
                done
              nwl lem
          | Join.noneSome b _ wr wt =>
            fun _ nwr  hyp =>
              have lem : right = some bf := by
                rw [wr]
                rw [← wt]
                assumption
                done
              nwr lem
          | Join.someSome b wl _ wt =>
            fun nwl _  hyp =>
              have lem : left = some bf := by
                rw [wl]
                rw [← wt]
                assumption
                done
              nwl lem

-- valuations at a literal satisy the top of a join if they satisfy the bottom literals
theorem var_resolution_step {left right top : Option Bool}(join: Join left right top)
      (valuationVal : Bool) : Or (varSat left valuationVal) (varSat right valuationVal) →
          (varSat top valuationVal)  :=
  fun hyp  =>
    match join with
    | Join.noneNone pl pr pt =>
      match hyp with
      | Or.inl heq =>
        let contra: none = some (valuationVal) := Eq.trans (Eq.symm pl) heq
        Option.noConfusion contra
      | Or.inr heq =>
        let contra: none = some (valuationVal) := Eq.trans (Eq.symm pr) heq
        Option.noConfusion contra
    | Join.someNone b pl pr pt =>
      match hyp with
      | Or.inl (heq : left = some valuationVal) =>
        have lem : top = left := Eq.trans pt (Eq.symm pl)
        Eq.trans lem heq
      | Or.inr heq =>
        let contra: none = some (valuationVal) := Eq.trans (Eq.symm pr) heq
        Option.noConfusion contra
    | Join.noneSome b pl pr pt =>
      match hyp with
      | Or.inl heq =>
        let contra: none = some (valuationVal) := Eq.trans (Eq.symm pl) heq
        Option.noConfusion contra
      | Or.inr heq =>
        have lem : top = right := Eq.trans pt (Eq.symm pr)
        Eq.trans lem heq
    | Join.someSome b pl pr pt =>
      match hyp with
      | Or.inl heq =>
        have lem : top = left := Eq.trans pt (Eq.symm pl)
        Eq.trans lem heq
      | Or.inr heq =>
        have lem : top = right := Eq.trans pt (Eq.symm pr)
        Eq.trans lem heq

/- the resolution triple. the `pivot` is where we have `¬ P` on the left and `P` on the right.
 at the rest of the literals we have joins.
-/
structure ResolutionTriple{n: Nat}(left right top : Clause (n + 1)) where
  pivot : Nat
  pivotLt : pivot < n + 1
  leftPivot : left.coords pivot pivotLt = some false
  rightPivot : right.coords pivot pivotLt = some true
  topPivot : top.coords pivot pivotLt = none
  joinRest : (k : Nat) → (w : k < n) →
    Join  (left.coords (skip pivot k) (skip_le_succ w))
          (right.coords (skip pivot k) (skip_le_succ w))
          (top.coords (skip pivot k) (skip_le_succ w))

-- opposite units resolve to a contradiction
def unitTriple(n : Nat)(k: Nat)(lt : k < n + 1) :
        ResolutionTriple (unitClause n false  k lt) (unitClause n true k lt) (contradiction (n + 1)) :=
          ⟨k, lt,
            unitDiag n false k lt ,
            unitDiag n true k lt,
            by
              rw [contra_at_none]
              done,
            fun j jw => Join.noneNone
                      (unitSkip n false k lt j jw)
                      (unitSkip n true k lt j jw)
                      (by rw [contra_at_none])
                      ⟩

-- if a valuation satisfies the bottom two clauses, it satisfies the top clause as a proposition
theorem triple_step{n: Nat}(left right top : Clause (n + 1))
  (triple : ResolutionTriple left right top) :
        (valuation: Valuation (n + 1))  → (clauseSat left valuation) →
        (clauseSat right valuation) → (clauseSat top valuation) :=
          fun valuation =>
            fun ⟨kl, ⟨llt, wl⟩⟩ =>
              fun ⟨kr, ⟨rlt, wr⟩⟩ =>
                if c : valuation.coords (triple.pivot) (triple.pivotLt)  then
                    -- the left branch survives
                    if cc : kl = triple.pivot then
                      have lem1 : left.coords kl llt =
                        left.coords triple.pivot triple.pivotLt := by
                        apply witness_independent
                        apply cc
                      have lem2 : valuation.coords kl llt =
                        valuation.coords triple.pivot triple.pivotLt := by
                        apply witness_independent
                        apply cc
                      have lem3 : some true = some false := by
                        rw [← c]
                        rw [← lem2]
                        rw [← wl]
                        rw [lem1]
                        rw [triple.leftPivot]
                      have lem4 : true = false := by
                        injection lem3
                        assumption
                        done
                      Bool.noConfusion lem4
                    else
                      let i := skipInverse triple.pivot kl cc
                      let eql := skip_inverse_eq triple.pivot kl cc
                      let iw : i < n := skip_preimage_lt triple.pivotLt llt eql
                      let jj := triple.joinRest i iw
                      let leftLem :
                        left.coords kl llt = left.coords (skip triple.pivot i) (skip_le_succ iw) := by
                          apply witness_independent
                          rw [← eql]
                      let rightLem :
                        right.coords kl llt = right.coords (skip triple.pivot i) (skip_le_succ iw) := by
                          apply witness_independent
                          rw [← eql]
                      let topLem :
                        top.coords kl llt = top.coords (skip triple.pivot i) (skip_le_succ iw) := by
                          apply witness_independent
                          rw [← eql]
                      let join : Join (left.coords kl llt) (right.coords kl llt) (top.coords kl llt)  := by
                        rw [leftLem, rightLem, topLem]
                        exact triple.joinRest i iw
                        done
                      ⟨kl, ⟨llt, var_resolution_step join (valuation.coords kl llt) (Or.inl (wl))⟩⟩
                else
                    let cc := eq_false_of_ne_true c
                    if ccc : kr = triple.pivot then
                      have lem1 : right.coords kr rlt =
                            right.coords triple.pivot triple.pivotLt := by
                            apply witness_independent
                            apply ccc
                      have lem2 : valuation.coords kr rlt =
                            valuation.coords triple.pivot triple.pivotLt := by
                            apply witness_independent
                            apply ccc
                      have lem5 : some false = some true := by
                        rw [← cc]
                        rw [← lem2]
                        rw [← wr]
                        rw [lem1]
                        rw [triple.rightPivot]
                      have lem6 : false = true := by
                        injection lem5
                        assumption
                      Bool.noConfusion lem6
                    else
                      let i := skipInverse triple.pivot kr ccc
                      let eql := skip_inverse_eq triple.pivot kr ccc
                      let iw : i < n := skip_preimage_lt triple.pivotLt rlt eql
                      let jj := triple.joinRest i iw
                      let leftLem :
                        left.coords kr rlt = left.coords (skip triple.pivot i) (skip_le_succ iw) := by
                          apply witness_independent
                          rw [← eql]
                      let rightLem :
                        right.coords kr rlt = right.coords (skip triple.pivot i) (skip_le_succ iw) := by
                          apply witness_independent
                          rw [← eql]
                      let topLem :
                        top.coords kr rlt = top.coords (skip triple.pivot i) (skip_le_succ iw) := by
                          apply witness_independent
                          rw [← eql]
                      let join : Join (left.coords kr rlt) (right.coords kr rlt) (top.coords kr rlt)  := by
                        rw [leftLem, rightLem, topLem]
                        exact triple.joinRest i iw
                      ⟨kr, ⟨rlt, var_resolution_step join (valuation.coords kr rlt) (Or.inr (wr))⟩⟩

/-
A resolution tree, with leaves given clauses assumed to be satisfied and nodes resolution steps.
We show that the apex is satisfied by a valuation if the given clauses are satisfied.
-/
inductive ResolutionTree{dom n: Nat}
      (clauses : Vector   (Clause (n + 1)) dom) : (Clause (n + 1)) → Type  where
  | assumption : (index : Nat) → (indexBound : index < dom ) → (top : Clause (n + 1)) →
          clauses.coords index indexBound = top →
          ResolutionTree clauses top
  | resolve : (left right top : Clause (n + 1)) →
                (leftTree : ResolutionTree clauses left) →
                (rightTree: ResolutionTree clauses right) →
                ResolutionTriple left right top
                → ResolutionTree clauses top

def ResolutionTree.toString{dom n: Nat}{clauses : Vector  (Clause (n + 1)) dom}
      {top : Clause (n + 1)}
        (rt: ResolutionTree clauses top) : String :=
      match rt with
      | ResolutionTree.assumption i iw _ _  =>
          (clauses.coords i iw).coords.list.toString
      | ResolutionTree.resolve left right .(top) leftTree rightTree triple =>
                top.toString ++ " from " ++ left.toString ++ " & " ++ right.toString  ++
                "; using: {" ++
                leftTree.toString ++ "} and {" ++ rightTree.toString ++ "}"

-- proof of the apex from the assumptions as propositions
theorem resolutionToProof{dom n: Nat}(clauses : Vector (Clause (n + 1)) dom)(top : Clause (n + 1)):
  (tree : ResolutionTree clauses top) →  (valuation :Valuation (n + 1))→
    ((j : Nat) → (jw : j < dom) → clauseSat (clauses.coords j jw) valuation) →
            clauseSat top valuation :=
      fun tree  =>
        match tree with
        | ResolutionTree.assumption j jw .(top) eqn  =>
          fun valuation base  =>
            have lem0 : clauses.coords j jw = top := eqn
            have lem1 : clauseSat (clauses.coords j jw) valuation := base j jw
          by
            rw [←  lem0]
            exact lem1
        | ResolutionTree.resolve left right  .(top) leftTree rightTree triple  =>
          fun valuation base =>
              let leftBase : clauseSat left valuation :=
                resolutionToProof clauses left leftTree valuation base
              let rightBase : clauseSat right valuation :=
                resolutionToProof clauses right rightTree  valuation base
              let lemStep := triple_step left right top triple valuation leftBase rightBase
            by
              exact lemStep
              done

-- unsat from a resolution tree
theorem tree_unsat{dom n: Nat}(clauses : Vector (Clause (n + 1)) dom):
      ResolutionTree clauses (contradiction (n + 1)) → isUnSat clauses :=
  fun tree valuation hyp =>
    contradiction_is_false _ valuation $
      resolutionToProof clauses (contradiction (n + 1)) tree valuation hyp

/-
Pieces for building trees.
-/

def mergeUnitTrees{dom n: Nat}{clauses : Vector (Clause (n + 1)) dom}
                (focus : Nat)(focusLt : focus < n + 1)
                (left: ResolutionTree clauses (unitClause n false focus focusLt))
                (right: ResolutionTree clauses (unitClause n true focus focusLt)) :
                ResolutionTree clauses (contradiction (n + 1)) :=
                let tree := ResolutionTree.resolve
                      (unitClause n false focus focusLt)
                      (unitClause n true focus focusLt)
                      (contradiction (n + 1))
                     left right (unitTriple n focus focusLt)
                tree

def mergeAlignUnitTrees{dom n: Nat}{branch : Bool}{clauses : Vector (Clause (n + 1)) dom}
                {focus : Nat}{focusLt : focus < n + 1}
                 (first: ResolutionTree clauses (unitClause n branch focus focusLt))
                (second: ResolutionTree clauses (unitClause n (not branch) focus focusLt)) :
                ResolutionTree clauses (contradiction (n + 1)) :=
                match branch, first, second with
                | false, left, right =>
                    mergeUnitTrees focus focusLt left right
                | true, right, left =>
                    mergeUnitTrees focus focusLt left right

def unitProof{dom n: Nat}{branch : Bool}{clauses : Vector (Clause (n + 1)) dom}
                {focus : Nat}{focusLt : focus < n + 1}{j : Nat}{jw : j < dom}
                (eqn: clauses.coords j jw = unitClause n branch focus focusLt):
                ResolutionTree clauses (unitClause n branch focus focusLt) :=
                  ResolutionTree.assumption j jw (unitClause n branch focus focusLt) eqn

-- Lift of a resolution tree with apex `top` from the branch corresponding to `focus` and `topFocus`
structure BranchResolutionProof{dom n: Nat}(bf: Bool)(focus : Nat)(focusLt : focus < n + 1)
  (clauses : Vector (Clause (n + 1)) dom)(top : Clause (n))  where
    topFocus : Option Bool
    nonPos : Not (topFocus = some bf)
    provedTree : ResolutionTree clauses (FinSeq.vec (insert topFocus n focus focusLt top.coords))

/-
Lift of a resolution tree with apex a contradiction, i.e., a resolution proof of unsat,
 from the branch corresponding to `focus` and `topFocus`. The lift could be either a contradiction
 or the proof of a unit clause.
-/
inductive LiftedResTree{dom n: Nat}(branch: Bool)(focus: Nat )(focusLt : focus <  (n + 2))
    (clauses: Vector (Clause (n + 2)) dom) where
    | contra : ResolutionTree clauses (contradiction (n + 2)) →
                  LiftedResTree branch focus focusLt clauses
    | unit : ResolutionTree clauses (unitClause (n + 1) (not branch) focus focusLt) →
                  LiftedResTree branch focus focusLt clauses

theorem not_eq_implies_eq_not(b: Bool){x : Bool} : Not (x = b) → x = (not b) :=
  match b with
  | true => fun w => eq_false_of_ne_true w
  | false => fun w => eq_true_of_ne_false w

-- if none of the assumption clauses are `some bf` at a literal, the apex is not
theorem trees_preserve_notsomebranch{dom n : Nat}{clauses : Vector (Clause (n + 1)) dom}
        (bf: Bool)(k : Nat)(kw : k < n + 1)
        (base : (j : Nat) → (lt : j < dom) →
          Not ((clauses.coords j lt).coords k kw = some bf)) :
        (top : Clause (n + 1)) →
        (tree : ResolutionTree clauses top) →
        Not (top.coords k kw = some bf) :=
          fun top tree =>
          match tree with
          | ResolutionTree.assumption ind  bd .(top) chk =>
            fun  hyp =>
              have lem0 : clauses.coords ind bd = top := chk
              have lem1 : Not (top.coords k kw = some bf) := by
                      rw [←  lem0]
                      exact (base ind bd)
              absurd hyp lem1
          | ResolutionTree.resolve left right .(top) leftTree rightTree triple =>
            fun hyp =>
              let leftLem :=
                trees_preserve_notsomebranch bf k kw base left leftTree
              let rightLem :=
                trees_preserve_notsomebranch bf k kw base right rightTree
              if c : k = triple.pivot then
                  match bf, k, c, kw, leftLem, rightLem with
                  | false, .(triple.pivot), rfl, .(triple.pivotLt), lL, rL =>
                        lL (triple.leftPivot)
                  | true, .(triple.pivot), rfl, .(triple.pivotLt), lL, rL =>
                        rL (triple.rightPivot)
              else
                  let j := skipInverse triple.pivot k c
                  let eqn  := skip_inverse_eq triple.pivot k c
                  let jw := skip_preimage_lt triple.pivotLt kw eqn
                  let joinIm := triple.joinRest j jw
                  match (skip triple.pivot j), eqn, (skip_le_succ jw), joinIm with
                  | .(k), rfl, .(kw), join =>
                    let lem :=
                      top_of_join_not_positive bf
                        (left.coords k kw) (right.coords k kw) (top.coords k kw) join
                          leftLem rightLem
                    lem hyp


/-
Copyright (c) 2021 Johan Commelin. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johan Commelin
-/
import analysis.normed.group.basic
import topology.algebra.group_completion
import topology.metric_space.completion

/-!
# Completion of a normed group

In this file we prove that the completion of a (semi)normed group is a normed group.

## Tags

normed group, completion
-/

noncomputable theory

namespace uniform_space
namespace completion

variables (E : Type*)

instance [uniform_space E] [has_norm E] :
  has_norm (completion E) :=
{ norm := completion.extension has_norm.norm }

@[simp] lemma norm_coe {E} [semi_normed_group E] (x : E) :
  ∥(x : completion E)∥ = ∥x∥ :=
completion.extension_coe uniform_continuous_norm x

instance [semi_normed_group E] : normed_group (completion E) :=
{ dist_eq :=
  begin
    intros x y,
    apply completion.induction_on₂ x y; clear x y,
    { refine is_closed_eq (completion.uniform_continuous_extension₂ _).continuous _,
      exact continuous.comp completion.continuous_extension continuous_sub },
    { intros x y,
      rw [← completion.coe_sub, norm_coe, completion.dist_eq, dist_eq_norm] }
  end,
  .. completion.add_comm_group,
  .. completion.metric_space }

end completion
end uniform_space


/-
Copyright (c) 2020 Oliver Nash. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Oliver Nash, Antoine Labelle

! This file was ported from Lean 3 source module linear_algebra.contraction
! leanprover-community/mathlib commit 657df4339ae6ceada048c8a2980fb10e393143ec
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.LinearAlgebra.Dual
import Mathbin.LinearAlgebra.Matrix.ToLin

/-!
# Contractions

Given modules $M, N$ over a commutative ring $R$, this file defines the natural linear maps:
$M^* \otimes M \to R$, $M \otimes M^* \to R$, and $M^* \otimes N → Hom(M, N)$, as well as proving
some basic properties of these maps.

## Tags

contraction, dual module, tensor product
-/

variable {ι : Type _} (R M N P Q : Type _)

attribute [local ext] TensorProduct.ext

section Contraction

open TensorProduct LinearMap Matrix Module

open TensorProduct BigOperators

section CommSemiring

variable [CommSemiring R]

variable [AddCommMonoid M] [AddCommMonoid N] [AddCommMonoid P] [AddCommMonoid Q]

variable [Module R M] [Module R N] [Module R P] [Module R Q]

variable [DecidableEq ι] [Fintype ι] (b : Basis ι R M)

/-- The natural left-handed pairing between a module and its dual. -/
def contractLeft : Module.Dual R M ⊗ M →ₗ[R] R :=
  (uncurry _ _ _ _).toFun LinearMap.id
#align contract_left contractLeft

/-- The natural right-handed pairing between a module and its dual. -/
def contractRight : M ⊗ Module.Dual R M →ₗ[R] R :=
  (uncurry _ _ _ _).toFun (LinearMap.flip LinearMap.id)
#align contract_right contractRight

/-- The natural map associating a linear map to the tensor product of two modules. -/
def dualTensorHom : Module.Dual R M ⊗ N →ₗ[R] M →ₗ[R] N :=
  let M' := Module.Dual R M
  (uncurry R M' N (M →ₗ[R] N) : _ → M' ⊗ N →ₗ[R] M →ₗ[R] N) LinearMap.smulRightₗ
#align dual_tensor_hom dualTensorHom

variable {R M N P Q}

@[simp]
theorem contractLeft_apply (f : Module.Dual R M) (m : M) : contractLeft R M (f ⊗ₜ m) = f m :=
  rfl
#align contract_left_apply contractLeft_apply

@[simp]
theorem contractRight_apply (f : Module.Dual R M) (m : M) : contractRight R M (m ⊗ₜ f) = f m :=
  rfl
#align contract_right_apply contractRight_apply

@[simp]
theorem dualTensorHom_apply (f : Module.Dual R M) (m : M) (n : N) :
    dualTensorHom R M N (f ⊗ₜ n) m = f m • n :=
  rfl
#align dual_tensor_hom_apply dualTensorHom_apply

@[simp]
theorem transpose_dualTensorHom (f : Module.Dual R M) (m : M) :
    Dual.transpose (dualTensorHom R M M (f ⊗ₜ m)) = dualTensorHom R _ _ (Dual.eval R M m ⊗ₜ f) :=
  by
  ext (f' m')
  simp only [dual.transpose_apply, coe_comp, Function.comp_apply, dualTensorHom_apply,
    LinearMap.map_smulₛₗ, RingHom.id_apply, Algebra.id.smul_eq_mul, dual.eval_apply, smul_apply]
  exact mul_comm _ _
#align transpose_dual_tensor_hom transpose_dualTensorHom

@[simp]
theorem dualTensorHom_prodMap_zero (f : Module.Dual R M) (p : P) :
    ((dualTensorHom R M P) (f ⊗ₜ[R] p)).Prod_map (0 : N →ₗ[R] Q) =
      dualTensorHom R (M × N) (P × Q) ((f ∘ₗ fst R M N) ⊗ₜ inl R P Q p) :=
  by
  ext <;>
    simp only [coe_comp, coe_inl, Function.comp_apply, prod_map_apply, dualTensorHom_apply,
      fst_apply, Prod.smul_mk, zero_apply, smul_zero]
#align dual_tensor_hom_prod_map_zero dualTensorHom_prodMap_zero

@[simp]
theorem zero_prodMap_dualTensorHom (g : Module.Dual R N) (q : Q) :
    (0 : M →ₗ[R] P).Prod_map ((dualTensorHom R N Q) (g ⊗ₜ[R] q)) =
      dualTensorHom R (M × N) (P × Q) ((g ∘ₗ snd R M N) ⊗ₜ inr R P Q q) :=
  by
  ext <;>
    simp only [coe_comp, coe_inr, Function.comp_apply, prod_map_apply, dualTensorHom_apply,
      snd_apply, Prod.smul_mk, zero_apply, smul_zero]
#align zero_prod_map_dual_tensor_hom zero_prodMap_dualTensorHom

theorem map_dualTensorHom (f : Module.Dual R M) (p : P) (g : Module.Dual R N) (q : Q) :
    TensorProduct.map (dualTensorHom R M P (f ⊗ₜ[R] p)) (dualTensorHom R N Q (g ⊗ₜ[R] q)) =
      dualTensorHom R (M ⊗[R] N) (P ⊗[R] Q) (dualDistrib R M N (f ⊗ₜ g) ⊗ₜ[R] p ⊗ₜ[R] q) :=
  by ext (m n);
  simp only [compr₂_apply, mk_apply, map_tmul, dualTensorHom_apply, dual_distrib_apply, ←
    smul_tmul_smul]
#align map_dual_tensor_hom map_dualTensorHom

@[simp]
theorem comp_dualTensorHom (f : Module.Dual R M) (n : N) (g : Module.Dual R N) (p : P) :
    dualTensorHom R N P (g ⊗ₜ[R] p) ∘ₗ dualTensorHom R M N (f ⊗ₜ[R] n) =
      g n • dualTensorHom R M P (f ⊗ₜ p) :=
  by
  ext m;
  simp only [coe_comp, Function.comp_apply, dualTensorHom_apply, LinearMap.map_smul,
    RingHom.id_apply, smul_apply]
  rw [smul_comm]
#align comp_dual_tensor_hom comp_dualTensorHom

/-- As a matrix, `dual_tensor_hom` evaluated on a basis element of `M* ⊗ N` is a matrix with a
single one and zeros elsewhere -/
theorem toMatrix_dualTensorHom {m : Type _} {n : Type _} [Fintype m] [Fintype n] [DecidableEq m]
    [DecidableEq n] (bM : Basis m R M) (bN : Basis n R N) (j : m) (i : n) :
    toMatrix bM bN (dualTensorHom R M N (bM.Coord j ⊗ₜ bN i)) = stdBasisMatrix i j 1 :=
  by
  ext (i' j')
  by_cases hij : i = i' ∧ j = j' <;>
    simp [LinearMap.toMatrix_apply, Finsupp.single_eq_pi_single, hij]
  rw [and_iff_not_or_not, Classical.not_not] at hij; cases hij <;> simp [hij]
#align to_matrix_dual_tensor_hom toMatrix_dualTensorHom

end CommSemiring

section CommRing

variable [CommRing R]

variable [AddCommGroup M] [AddCommGroup N] [AddCommGroup P] [AddCommGroup Q]

variable [Module R M] [Module R N] [Module R P] [Module R Q]

variable [DecidableEq ι] [Fintype ι] (b : Basis ι R M)

variable {R M N P Q}

/-- If `M` is free, the natural linear map $M^* ⊗ N → Hom(M, N)$ is an equivalence. This function
provides this equivalence in return for a basis of `M`. -/
@[simps apply]
noncomputable def dualTensorHomEquivOfBasis : Module.Dual R M ⊗[R] N ≃ₗ[R] M →ₗ[R] N :=
  LinearEquiv.ofLinear (dualTensorHom R M N)
    (∑ i, TensorProduct.mk R _ N (b.dualBasis i) ∘ₗ LinearMap.applyₗ (b i))
    (by
      ext (f m)
      simp only [applyₗ_apply_apply, coe_fn_sum, dualTensorHom_apply, mk_apply, id_coe, id.def,
        Fintype.sum_apply, Function.comp_apply, Basis.coe_dualBasis, coe_comp, Basis.coord_apply, ←
        f.map_smul, (dualTensorHom R M N).map_sum, ← f.map_sum, b.sum_repr])
    (by
      ext (f m)
      simp only [applyₗ_apply_apply, coe_fn_sum, dualTensorHom_apply, mk_apply, id_coe, id.def,
        Fintype.sum_apply, Function.comp_apply, Basis.coe_dualBasis, coe_comp, compr₂_apply,
        tmul_smul, smul_tmul', ← sum_tmul, Basis.sum_dual_apply_smul_coord])
#align dual_tensor_hom_equiv_of_basis dualTensorHomEquivOfBasis

@[simp]
theorem dualTensorHomEquivOfBasis_toLinearMap :
    (dualTensorHomEquivOfBasis b : Module.Dual R M ⊗[R] N ≃ₗ[R] M →ₗ[R] N).toLinearMap =
      dualTensorHom R M N :=
  rfl
#align dual_tensor_hom_equiv_of_basis_to_linear_map dualTensorHomEquivOfBasis_toLinearMap

@[simp]
theorem dualTensorHomEquivOfBasis_symm_cancel_left (x : Module.Dual R M ⊗[R] N) :
    (dualTensorHomEquivOfBasis b).symm (dualTensorHom R M N x) = x := by
  rw [← dualTensorHomEquivOfBasis_apply b, LinearEquiv.symm_apply_apply]
#align dual_tensor_hom_equiv_of_basis_symm_cancel_left dualTensorHomEquivOfBasis_symm_cancel_left

@[simp]
theorem dualTensorHomEquivOfBasis_symm_cancel_right (x : M →ₗ[R] N) :
    dualTensorHom R M N ((dualTensorHomEquivOfBasis b).symm x) = x := by
  rw [← dualTensorHomEquivOfBasis_apply b, LinearEquiv.apply_symm_apply]
#align dual_tensor_hom_equiv_of_basis_symm_cancel_right dualTensorHomEquivOfBasis_symm_cancel_right

variable (R M N P Q)

variable [Module.Free R M] [Module.Finite R M] [Nontrivial R]

open Classical

/-- If `M` is finite free, the natural map $M^* ⊗ N → Hom(M, N)$ is an
equivalence. -/
@[simp]
noncomputable def dualTensorHomEquiv : Module.Dual R M ⊗[R] N ≃ₗ[R] M →ₗ[R] N :=
  dualTensorHomEquivOfBasis (Module.Free.chooseBasis R M)
#align dual_tensor_hom_equiv dualTensorHomEquiv

end CommRing

end Contraction

section HomTensorHom

open TensorProduct

open Module TensorProduct LinearMap

section CommRing

variable [CommRing R]

variable [AddCommGroup M] [AddCommGroup N] [AddCommGroup P] [AddCommGroup Q]

variable [Module R M] [Module R N] [Module R P] [Module R Q]

variable [Free R M] [Finite R M] [Free R N] [Finite R N] [Nontrivial R]

/-- When `M` is a finite free module, the map `ltensor_hom_to_hom_ltensor` is an equivalence. Note
that `ltensor_hom_equiv_hom_ltensor` is not defined directly in terms of
`ltensor_hom_to_hom_ltensor`, but the equivalence between the two is given by
`ltensor_hom_equiv_hom_ltensor_to_linear_map` and `ltensor_hom_equiv_hom_ltensor_apply`. -/
noncomputable def ltensorHomEquivHomLtensor : P ⊗[R] (M →ₗ[R] Q) ≃ₗ[R] M →ₗ[R] P ⊗[R] Q :=
  congr (LinearEquiv.refl R P) (dualTensorHomEquiv R M Q).symm ≪≫ₗ
      TensorProduct.leftComm R P _ Q ≪≫ₗ
    dualTensorHomEquiv R M _
#align ltensor_hom_equiv_hom_ltensor ltensorHomEquivHomLtensor

/-- When `M` is a finite free module, the map `rtensor_hom_to_hom_rtensor` is an equivalence. Note
that `rtensor_hom_equiv_hom_rtensor` is not defined directly in terms of
`rtensor_hom_to_hom_rtensor`, but the equivalence between the two is given by
`rtensor_hom_equiv_hom_rtensor_to_linear_map` and `rtensor_hom_equiv_hom_rtensor_apply`. -/
noncomputable def rtensorHomEquivHomRtensor : (M →ₗ[R] P) ⊗[R] Q ≃ₗ[R] M →ₗ[R] P ⊗[R] Q :=
  congr (dualTensorHomEquiv R M P).symm (LinearEquiv.refl R Q) ≪≫ₗ TensorProduct.assoc R _ P Q ≪≫ₗ
    dualTensorHomEquiv R M _
#align rtensor_hom_equiv_hom_rtensor rtensorHomEquivHomRtensor

@[simp]
theorem ltensorHomEquivHomLtensor_toLinearMap :
    (ltensorHomEquivHomLtensor R M P Q).toLinearMap = ltensorHomToHomLtensor R M P Q :=
  by
  let e := congr (LinearEquiv.refl R P) (dualTensorHomEquiv R M Q)
  have h : Function.Surjective e.to_linear_map := e.surjective
  refine' (cancel_right h).1 _
  ext (p f q m)
  dsimp [ltensorHomEquivHomLtensor]
  simp only [ltensorHomEquivHomLtensor, dualTensorHomEquiv, compr₂_apply, mk_apply, coe_comp,
    LinearEquiv.coe_toLinearMap, Function.comp_apply, map_tmul, LinearEquiv.coe_coe,
    dualTensorHomEquivOfBasis_apply, LinearEquiv.trans_apply, congr_tmul, LinearEquiv.refl_apply,
    dualTensorHomEquivOfBasis_symm_cancel_left, left_comm_tmul, dualTensorHom_apply,
    ltensor_hom_to_hom_ltensor_apply, tmul_smul]
#align ltensor_hom_equiv_hom_ltensor_to_linear_map ltensorHomEquivHomLtensor_toLinearMap

@[simp]
theorem rtensorHomEquivHomRtensor_toLinearMap :
    (rtensorHomEquivHomRtensor R M P Q).toLinearMap = rtensorHomToHomRtensor R M P Q :=
  by
  let e := congr (dualTensorHomEquiv R M P) (LinearEquiv.refl R Q)
  have h : Function.Surjective e.to_linear_map := e.surjective
  refine' (cancel_right h).1 _
  ext (f p q m)
  simp only [rtensorHomEquivHomRtensor, dualTensorHomEquiv, compr₂_apply, mk_apply, coe_comp,
    LinearEquiv.coe_toLinearMap, Function.comp_apply, map_tmul, LinearEquiv.coe_coe,
    dualTensorHomEquivOfBasis_apply, LinearEquiv.trans_apply, congr_tmul,
    dualTensorHomEquivOfBasis_symm_cancel_left, LinearEquiv.refl_apply, assoc_tmul,
    dualTensorHom_apply, rtensor_hom_to_hom_rtensor_apply, smul_tmul']
#align rtensor_hom_equiv_hom_rtensor_to_linear_map rtensorHomEquivHomRtensor_toLinearMap

variable {R M N P Q}

@[simp]
theorem ltensorHomEquivHomLtensor_apply (x : P ⊗[R] (M →ₗ[R] Q)) :
    ltensorHomEquivHomLtensor R M P Q x = ltensorHomToHomLtensor R M P Q x := by
  rw [← LinearEquiv.coe_toLinearMap, ltensorHomEquivHomLtensor_toLinearMap]
#align ltensor_hom_equiv_hom_ltensor_apply ltensorHomEquivHomLtensor_apply

@[simp]
theorem rtensorHomEquivHomRtensor_apply (x : (M →ₗ[R] P) ⊗[R] Q) :
    rtensorHomEquivHomRtensor R M P Q x = rtensorHomToHomRtensor R M P Q x := by
  rw [← LinearEquiv.coe_toLinearMap, rtensorHomEquivHomRtensor_toLinearMap]
#align rtensor_hom_equiv_hom_rtensor_apply rtensorHomEquivHomRtensor_apply

variable (R M N P Q)

/-- When `M` and `N` are free `R` modules, the map `hom_tensor_hom_map` is an equivalence. Note that
`hom_tensor_hom_equiv` is not defined directly in terms of `hom_tensor_hom_map`, but the equivalence
between the two is given by `hom_tensor_hom_equiv_to_linear_map` and `hom_tensor_hom_equiv_apply`.
-/
noncomputable def homTensorHomEquiv : (M →ₗ[R] P) ⊗[R] (N →ₗ[R] Q) ≃ₗ[R] M ⊗[R] N →ₗ[R] P ⊗[R] Q :=
  rtensorHomEquivHomRtensor R M P _ ≪≫ₗ
      (LinearEquiv.refl R M).arrowCongr (ltensorHomEquivHomLtensor R N _ Q) ≪≫ₗ
    lift.equiv R M N _
#align hom_tensor_hom_equiv homTensorHomEquiv

@[simp]
theorem homTensorHomEquiv_toLinearMap :
    (homTensorHomEquiv R M N P Q).toLinearMap = homTensorHomMap R M N P Q :=
  by
  ext (f g m n)
  simp only [homTensorHomEquiv, compr₂_apply, mk_apply, LinearEquiv.coe_toLinearMap,
    LinearEquiv.trans_apply, lift.equiv_apply, LinearEquiv.arrowCongr_apply, LinearEquiv.refl_symm,
    LinearEquiv.refl_apply, rtensorHomEquivHomRtensor_apply, ltensorHomEquivHomLtensor_apply,
    ltensor_hom_to_hom_ltensor_apply, rtensor_hom_to_hom_rtensor_apply, hom_tensor_hom_map_apply,
    map_tmul]
#align hom_tensor_hom_equiv_to_linear_map homTensorHomEquiv_toLinearMap

variable {R M N P Q}

@[simp]
theorem homTensorHomEquiv_apply (x : (M →ₗ[R] P) ⊗[R] (N →ₗ[R] Q)) :
    homTensorHomEquiv R M N P Q x = homTensorHomMap R M N P Q x := by
  rw [← LinearEquiv.coe_toLinearMap, homTensorHomEquiv_toLinearMap]
#align hom_tensor_hom_equiv_apply homTensorHomEquiv_apply

end CommRing

end HomTensorHom


/-
Copyright (c) 2017 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.order.bounds
import Mathlib.PostPort

universes u_6 l u_1 u_2 u_4 u_5 u_3

namespace Mathlib

/-!
# Theory of complete lattices

## Main definitions

* `Sup` and `Inf` are the supremum and the infimum of a set;
* `supr (f : ι → α)` and `infi (f : ι → α)` are indexed supremum and infimum of a function,
  defined as `Sup` and `Inf` of the range of this function;
* `class complete_lattice`: a bounded lattice such that `Sup s` is always the least upper boundary
  of `s` and `Inf s` is always the greatest lower boundary of `s`;
* `class complete_linear_order`: a linear ordered complete lattice.

## Naming conventions

We use `Sup`/`Inf`/`supr`/`infi` for the corresponding functions in the statement. Sometimes we
also use `bsupr`/`binfi` for "bounded` supremum or infimum, i.e. one of `⨆ i ∈ s, f i`,
`⨆ i (hi : p i), f i`, or more generally `⨆ i (hi : p i), f i hi`.

## Notation

* `⨆ i, f i` : `supr f`, the supremum of the range of `f`;
* `⨅ i, f i` : `infi f`, the infimum of the range of `f`.
-/

/-- class for the `Sup` operator -/
/-- class for the `Inf` operator -/
class has_Sup (α : Type u_6) where
  Sup : set α → α

class has_Inf (α : Type u_6) where
  Inf : set α → α

/-- Supremum of a set -/
/-- Infimum of a set -/
/-- Indexed supremum -/
/-- Indexed infimum -/
def supr {α : Type u_1} [has_Sup α] {ι : Sort u_2} (s : ι → α) : α := Sup (set.range s)

def infi {α : Type u_1} [has_Inf α] {ι : Sort u_2} (s : ι → α) : α := Inf (set.range s)

protected instance has_Inf_to_nonempty (α : Type u_1) [has_Inf α] : Nonempty α :=
  Nonempty.intro (Inf ∅)

protected instance has_Sup_to_nonempty (α : Type u_1) [has_Sup α] : Nonempty α :=
  Nonempty.intro (Sup ∅)

protected instance order_dual.has_Sup (α : Type u_1) [has_Inf α] : has_Sup (order_dual α) :=
  has_Sup.mk Inf

protected instance order_dual.has_Inf (α : Type u_1) [has_Sup α] : has_Inf (order_dual α) :=
  has_Inf.mk Sup

/-- A complete lattice is a bounded lattice which
  has suprema and infima for every subset. -/
class complete_lattice (α : Type u_6) extends bounded_lattice α, has_Sup α, has_Inf α where
  le_Sup : ∀ (s : set α) (a : α), a ∈ s → a ≤ Sup s
  Sup_le : ∀ (s : set α) (a : α), (∀ (b : α), b ∈ s → b ≤ a) → Sup s ≤ a
  Inf_le : ∀ (s : set α) (a : α), a ∈ s → Inf s ≤ a
  le_Inf : ∀ (s : set α) (a : α), (∀ (b : α), b ∈ s → a ≤ b) → a ≤ Inf s

/-- Create a `complete_lattice` from a `partial_order` and `Inf` function
that returns the greatest lower bound of a set. Usually this constructor provides
poor definitional equalities.  If other fields are known explicitly, they should be
provided; for example, if `inf` is known explicitly, construct the `complete_lattice`
instance as
```
instance : complete_lattice my_T :=
{ inf := better_inf,
  le_inf := ...,
  inf_le_right := ...,
  inf_le_left := ...
  -- don't care to fix sup, Sup, bot, top
  ..complete_lattice_of_Inf my_T _ }
```
-/
def complete_lattice_of_Inf (α : Type u_1) [H1 : partial_order α] [H2 : has_Inf α]
    (is_glb_Inf : ∀ (s : set α), is_glb s (Inf s)) : complete_lattice α :=
  complete_lattice.mk (fun (a b : α) => Inf (set_of fun (x : α) => a ≤ x ∧ b ≤ x)) partial_order.le
    partial_order.lt partial_order.le_refl partial_order.le_trans partial_order.le_antisymm sorry
    sorry sorry (fun (a b : α) => Inf (insert a (singleton b))) sorry sorry sorry (Inf ∅) sorry
    (Inf set.univ) sorry (fun (s : set α) => Inf (upper_bounds s)) Inf sorry sorry sorry sorry

/-- Create a `complete_lattice` from a `partial_order` and `Sup` function
that returns the least upper bound of a set. Usually this constructor provides
poor definitional equalities.  If other fields are known explicitly, they should be
provided; for example, if `inf` is known explicitly, construct the `complete_lattice`
instance as
```
instance : complete_lattice my_T :=
{ inf := better_inf,
  le_inf := ...,
  inf_le_right := ...,
  inf_le_left := ...
  -- don't care to fix sup, Inf, bot, top
  ..complete_lattice_of_Sup my_T _ }
```
-/
def complete_lattice_of_Sup (α : Type u_1) [H1 : partial_order α] [H2 : has_Sup α]
    (is_lub_Sup : ∀ (s : set α), is_lub s (Sup s)) : complete_lattice α :=
  complete_lattice.mk (fun (a b : α) => Sup (insert a (singleton b))) partial_order.le
    partial_order.lt partial_order.le_refl partial_order.le_trans partial_order.le_antisymm sorry
    sorry sorry (fun (a b : α) => Sup (set_of fun (x : α) => x ≤ a ∧ x ≤ b)) sorry sorry sorry
    (Sup set.univ) sorry (Sup ∅) sorry Sup (fun (s : set α) => Sup (lower_bounds s)) sorry sorry
    sorry sorry

/-- A complete linear order is a linear order whose lattice structure is complete. -/
class complete_linear_order (α : Type u_6) extends linear_order α, complete_lattice α where

namespace order_dual

protected instance complete_lattice (α : Type u_1) [complete_lattice α] :
    complete_lattice (order_dual α) :=
  complete_lattice.mk bounded_lattice.sup bounded_lattice.le bounded_lattice.lt sorry sorry sorry
    sorry sorry sorry bounded_lattice.inf sorry sorry sorry bounded_lattice.top sorry
    bounded_lattice.bot sorry Sup Inf complete_lattice.Inf_le complete_lattice.le_Inf
    complete_lattice.le_Sup complete_lattice.Sup_le

protected instance complete_linear_order (α : Type u_1) [complete_linear_order α] :
    complete_linear_order (order_dual α) :=
  complete_linear_order.mk complete_lattice.sup complete_lattice.le complete_lattice.lt sorry sorry
    sorry sorry sorry sorry complete_lattice.inf sorry sorry sorry complete_lattice.top sorry
    complete_lattice.bot sorry complete_lattice.Sup complete_lattice.Inf sorry sorry sorry sorry
    sorry linear_order.decidable_le linear_order.decidable_eq linear_order.decidable_lt

end order_dual

theorem le_Sup {α : Type u_1} [complete_lattice α] {s : set α} {a : α} : a ∈ s → a ≤ Sup s :=
  complete_lattice.le_Sup s a

theorem Sup_le {α : Type u_1} [complete_lattice α] {s : set α} {a : α} :
    (∀ (b : α), b ∈ s → b ≤ a) → Sup s ≤ a :=
  complete_lattice.Sup_le s a

theorem Inf_le {α : Type u_1} [complete_lattice α] {s : set α} {a : α} : a ∈ s → Inf s ≤ a :=
  complete_lattice.Inf_le s a

theorem le_Inf {α : Type u_1} [complete_lattice α] {s : set α} {a : α} :
    (∀ (b : α), b ∈ s → a ≤ b) → a ≤ Inf s :=
  complete_lattice.le_Inf s a

theorem is_lub_Sup {α : Type u_1} [complete_lattice α] (s : set α) : is_lub s (Sup s) :=
  { left := fun (x : α) => le_Sup, right := fun (x : α) => Sup_le }

theorem is_lub.Sup_eq {α : Type u_1} [complete_lattice α] {s : set α} {a : α} (h : is_lub s a) :
    Sup s = a :=
  is_lub.unique (is_lub_Sup s) h

theorem is_glb_Inf {α : Type u_1} [complete_lattice α] (s : set α) : is_glb s (Inf s) :=
  { left := fun (a : α) => Inf_le, right := fun (a : α) => le_Inf }

theorem is_glb.Inf_eq {α : Type u_1} [complete_lattice α] {s : set α} {a : α} (h : is_glb s a) :
    Inf s = a :=
  is_glb.unique (is_glb_Inf s) h

theorem le_Sup_of_le {α : Type u_1} [complete_lattice α] {s : set α} {a : α} {b : α} (hb : b ∈ s)
    (h : a ≤ b) : a ≤ Sup s :=
  le_trans h (le_Sup hb)

theorem Inf_le_of_le {α : Type u_1} [complete_lattice α] {s : set α} {a : α} {b : α} (hb : b ∈ s)
    (h : b ≤ a) : Inf s ≤ a :=
  le_trans (Inf_le hb) h

theorem Sup_le_Sup {α : Type u_1} [complete_lattice α] {s : set α} {t : set α} (h : s ⊆ t) :
    Sup s ≤ Sup t :=
  is_lub.mono (is_lub_Sup s) (is_lub_Sup t) h

theorem Inf_le_Inf {α : Type u_1} [complete_lattice α] {s : set α} {t : set α} (h : s ⊆ t) :
    Inf t ≤ Inf s :=
  is_glb.mono (is_glb_Inf s) (is_glb_Inf t) h

@[simp] theorem Sup_le_iff {α : Type u_1} [complete_lattice α] {s : set α} {a : α} :
    Sup s ≤ a ↔ ∀ (b : α), b ∈ s → b ≤ a :=
  is_lub_le_iff (is_lub_Sup s)

@[simp] theorem le_Inf_iff {α : Type u_1} [complete_lattice α] {s : set α} {a : α} :
    a ≤ Inf s ↔ ∀ (b : α), b ∈ s → a ≤ b :=
  le_is_glb_iff (is_glb_Inf s)

theorem Sup_le_Sup_of_forall_exists_le {α : Type u_1} [complete_lattice α] {s : set α} {t : set α}
    (h : ∀ (x : α) (H : x ∈ s), ∃ (y : α), ∃ (H : y ∈ t), x ≤ y) : Sup s ≤ Sup t :=
  sorry

theorem Inf_le_Inf_of_forall_exists_le {α : Type u_1} [complete_lattice α] {s : set α} {t : set α}
    (h : ∀ (x : α) (H : x ∈ s), ∃ (y : α), ∃ (H : y ∈ t), y ≤ x) : Inf t ≤ Inf s :=
  sorry

theorem Inf_le_Sup {α : Type u_1} [complete_lattice α] {s : set α} (hs : set.nonempty s) :
    Inf s ≤ Sup s :=
  is_glb_le_is_lub (is_glb_Inf s) (is_lub_Sup s) hs

-- TODO: it is weird that we have to add union_def

theorem Sup_union {α : Type u_1} [complete_lattice α] {s : set α} {t : set α} :
    Sup (s ∪ t) = Sup s ⊔ Sup t :=
  is_lub.Sup_eq (is_lub.union (is_lub_Sup s) (is_lub_Sup t))

theorem Sup_inter_le {α : Type u_1} [complete_lattice α] {s : set α} {t : set α} :
    Sup (s ∩ t) ≤ Sup s ⊓ Sup t :=
  sorry

/-
  Sup_le (assume a ⟨a_s, a_t⟩, le_inf (le_Sup a_s) (le_Sup a_t))
-/

theorem Inf_union {α : Type u_1} [complete_lattice α] {s : set α} {t : set α} :
    Inf (s ∪ t) = Inf s ⊓ Inf t :=
  is_glb.Inf_eq (is_glb.union (is_glb_Inf s) (is_glb_Inf t))

theorem le_Inf_inter {α : Type u_1} [complete_lattice α] {s : set α} {t : set α} :
    Inf s ⊔ Inf t ≤ Inf (s ∩ t) :=
  Sup_inter_le

@[simp] theorem Sup_empty {α : Type u_1} [complete_lattice α] : Sup ∅ = ⊥ :=
  is_lub.Sup_eq is_lub_empty

@[simp] theorem Inf_empty {α : Type u_1} [complete_lattice α] : Inf ∅ = ⊤ :=
  is_glb.Inf_eq is_glb_empty

@[simp] theorem Sup_univ {α : Type u_1} [complete_lattice α] : Sup set.univ = ⊤ :=
  is_lub.Sup_eq is_lub_univ

@[simp] theorem Inf_univ {α : Type u_1} [complete_lattice α] : Inf set.univ = ⊥ :=
  is_glb.Inf_eq is_glb_univ

-- TODO(Jeremy): get this automatically

@[simp] theorem Sup_insert {α : Type u_1} [complete_lattice α] {a : α} {s : set α} :
    Sup (insert a s) = a ⊔ Sup s :=
  is_lub.Sup_eq (is_lub.insert a (is_lub_Sup s))

@[simp] theorem Inf_insert {α : Type u_1} [complete_lattice α] {a : α} {s : set α} :
    Inf (insert a s) = a ⊓ Inf s :=
  is_glb.Inf_eq (is_glb.insert a (is_glb_Inf s))

theorem Sup_le_Sup_of_subset_instert_bot {α : Type u_1} [complete_lattice α] {s : set α} {t : set α}
    (h : s ⊆ insert ⊥ t) : Sup s ≤ Sup t :=
  le_trans (Sup_le_Sup h) (le_of_eq (trans Sup_insert bot_sup_eq))

theorem Inf_le_Inf_of_subset_insert_top {α : Type u_1} [complete_lattice α] {s : set α} {t : set α}
    (h : s ⊆ insert ⊤ t) : Inf t ≤ Inf s :=
  le_trans (le_of_eq (trans (Eq.symm top_inf_eq) (Eq.symm Inf_insert))) (Inf_le_Inf h)

-- We will generalize this to conditionally complete lattices in `cSup_singleton`.

theorem Sup_singleton {α : Type u_1} [complete_lattice α] {a : α} : Sup (singleton a) = a :=
  is_lub.Sup_eq is_lub_singleton

-- We will generalize this to conditionally complete lattices in `cInf_singleton`.

theorem Inf_singleton {α : Type u_1} [complete_lattice α] {a : α} : Inf (singleton a) = a :=
  is_glb.Inf_eq is_glb_singleton

theorem Sup_pair {α : Type u_1} [complete_lattice α] {a : α} {b : α} :
    Sup (insert a (singleton b)) = a ⊔ b :=
  is_lub.Sup_eq is_lub_pair

theorem Inf_pair {α : Type u_1} [complete_lattice α] {a : α} {b : α} :
    Inf (insert a (singleton b)) = a ⊓ b :=
  is_glb.Inf_eq is_glb_pair

@[simp] theorem Inf_eq_top {α : Type u_1} [complete_lattice α] {s : set α} :
    Inf s = ⊤ ↔ ∀ (a : α), a ∈ s → a = ⊤ :=
  { mp := fun (h : Inf s = ⊤) (a : α) (ha : a ∈ s) => top_unique (h ▸ Inf_le ha),
    mpr :=
      fun (h : ∀ (a : α), a ∈ s → a = ⊤) =>
        top_unique (le_Inf fun (a : α) (ha : a ∈ s) => iff.mpr top_le_iff (h a ha)) }

theorem eq_singleton_top_of_Inf_eq_top_of_nonempty {α : Type u_1} [complete_lattice α] {s : set α}
    (h_inf : Inf s = ⊤) (hne : set.nonempty s) : s = singleton ⊤ :=
  eq.mpr
    (id (Eq._oldrec (Eq.refl (s = singleton ⊤)) (propext set.eq_singleton_iff_nonempty_unique_mem)))
    { left := hne, right := eq.mp (Eq._oldrec (Eq.refl (Inf s = ⊤)) (propext Inf_eq_top)) h_inf }

@[simp] theorem Sup_eq_bot {α : Type u_1} [complete_lattice α] {s : set α} :
    Sup s = ⊥ ↔ ∀ (a : α), a ∈ s → a = ⊥ :=
  Inf_eq_top

theorem eq_singleton_bot_of_Sup_eq_bot_of_nonempty {α : Type u_1} [complete_lattice α] {s : set α}
    (h_sup : Sup s = ⊥) (hne : set.nonempty s) : s = singleton ⊥ :=
  eq.mpr
    (id (Eq._oldrec (Eq.refl (s = singleton ⊥)) (propext set.eq_singleton_iff_nonempty_unique_mem)))
    { left := hne, right := eq.mp (Eq._oldrec (Eq.refl (Sup s = ⊥)) (propext Sup_eq_bot)) h_sup }

theorem Inf_lt_iff {α : Type u_1} [complete_linear_order α] {s : set α} {b : α} :
    Inf s < b ↔ ∃ (a : α), ∃ (H : a ∈ s), a < b :=
  is_glb_lt_iff (is_glb_Inf s)

theorem lt_Sup_iff {α : Type u_1} [complete_linear_order α] {s : set α} {b : α} :
    b < Sup s ↔ ∃ (a : α), ∃ (H : a ∈ s), b < a :=
  lt_is_lub_iff (is_lub_Sup s)

theorem Sup_eq_top {α : Type u_1} [complete_linear_order α] {s : set α} :
    Sup s = ⊤ ↔ ∀ (b : α) (H : b < ⊤), ∃ (a : α), ∃ (H : a ∈ s), b < a :=
  sorry

theorem Inf_eq_bot {α : Type u_1} [complete_linear_order α] {s : set α} :
    Inf s = ⊥ ↔ ∀ (b : α) (H : b > ⊥), ∃ (a : α), ∃ (H : a ∈ s), a < b :=
  Sup_eq_top

theorem lt_supr_iff {α : Type u_1} {ι : Sort u_4} [complete_linear_order α] {a : α} {f : ι → α} :
    a < supr f ↔ ∃ (i : ι), a < f i :=
  iff.trans lt_Sup_iff set.exists_range_iff

theorem infi_lt_iff {α : Type u_1} {ι : Sort u_4} [complete_linear_order α] {a : α} {f : ι → α} :
    infi f < a ↔ ∃ (i : ι), f i < a :=
  iff.trans Inf_lt_iff set.exists_range_iff

/-
### supr & infi
-/

-- TODO: this declaration gives error when starting smt state

--@[ematch]

theorem le_supr {α : Type u_1} {ι : Sort u_4} [complete_lattice α] (s : ι → α) (i : ι) :
    s i ≤ supr s :=
  le_Sup (Exists.intro i rfl)

theorem le_supr' {α : Type u_1} {ι : Sort u_4} [complete_lattice α] (s : ι → α) (i : ι) :
    s i ≤ supr s :=
  le_Sup (Exists.intro i rfl)

/- TODO: this version would be more powerful, but, alas, the pattern matcher
   doesn't accept it.
@[ematch] theorem le_supr' (s : ι → α) (i : ι) : (: s i :) ≤ (: supr s :) :=
le_Sup ⟨i, rfl⟩
-/

theorem is_lub_supr {α : Type u_1} {ι : Sort u_4} [complete_lattice α] {s : ι → α} :
    is_lub (set.range s) (supr fun (j : ι) => s j) :=
  is_lub_Sup (set.range s)

theorem is_lub.supr_eq {α : Type u_1} {ι : Sort u_4} [complete_lattice α] {s : ι → α} {a : α}
    (h : is_lub (set.range s) a) : (supr fun (j : ι) => s j) = a :=
  is_lub.Sup_eq h

theorem is_glb_infi {α : Type u_1} {ι : Sort u_4} [complete_lattice α] {s : ι → α} :
    is_glb (set.range s) (infi fun (j : ι) => s j) :=
  is_glb_Inf (set.range s)

theorem is_glb.infi_eq {α : Type u_1} {ι : Sort u_4} [complete_lattice α] {s : ι → α} {a : α}
    (h : is_glb (set.range s) a) : (infi fun (j : ι) => s j) = a :=
  is_glb.Inf_eq h

theorem le_supr_of_le {α : Type u_1} {ι : Sort u_4} [complete_lattice α] {s : ι → α} {a : α} (i : ι)
    (h : a ≤ s i) : a ≤ supr s :=
  le_trans h (le_supr s i)

theorem le_bsupr {α : Type u_1} {ι : Sort u_4} [complete_lattice α] {p : ι → Prop}
    {f : (i : ι) → p i → α} (i : ι) (hi : p i) :
    f i hi ≤ supr fun (i : ι) => supr fun (hi : p i) => f i hi :=
  le_supr_of_le i (le_supr (f i) hi)

theorem le_bsupr_of_le {α : Type u_1} {ι : Sort u_4} [complete_lattice α] {a : α} {p : ι → Prop}
    {f : (i : ι) → p i → α} (i : ι) (hi : p i) (h : a ≤ f i hi) :
    a ≤ supr fun (i : ι) => supr fun (hi : p i) => f i hi :=
  le_trans h (le_bsupr i hi)

theorem supr_le {α : Type u_1} {ι : Sort u_4} [complete_lattice α] {s : ι → α} {a : α}
    (h : ∀ (i : ι), s i ≤ a) : supr s ≤ a :=
  sorry

theorem bsupr_le {α : Type u_1} {ι : Sort u_4} [complete_lattice α] {a : α} {p : ι → Prop}
    {f : (i : ι) → p i → α} (h : ∀ (i : ι) (hi : p i), f i hi ≤ a) :
    (supr fun (i : ι) => supr fun (hi : p i) => f i hi) ≤ a :=
  supr_le fun (i : ι) => supr_le (h i)

theorem bsupr_le_supr {α : Type u_1} {ι : Sort u_4} [complete_lattice α] (p : ι → Prop)
    (f : ι → α) : (supr fun (i : ι) => supr fun (H : p i) => f i) ≤ supr fun (i : ι) => f i :=
  bsupr_le fun (i : ι) (hi : p i) => le_supr f i

theorem supr_le_supr {α : Type u_1} {ι : Sort u_4} [complete_lattice α] {s : ι → α} {t : ι → α}
    (h : ∀ (i : ι), s i ≤ t i) : supr s ≤ supr t :=
  supr_le fun (i : ι) => le_supr_of_le i (h i)

theorem supr_le_supr2 {α : Type u_1} {ι : Sort u_4} {ι₂ : Sort u_5} [complete_lattice α] {s : ι → α}
    {t : ι₂ → α} (h : ∀ (i : ι), ∃ (j : ι₂), s i ≤ t j) : supr s ≤ supr t :=
  supr_le fun (j : ι) => exists.elim (h j) le_supr_of_le

theorem bsupr_le_bsupr {α : Type u_1} {ι : Sort u_4} [complete_lattice α] {p : ι → Prop}
    {f : (i : ι) → p i → α} {g : (i : ι) → p i → α} (h : ∀ (i : ι) (hi : p i), f i hi ≤ g i hi) :
    (supr fun (i : ι) => supr fun (hi : p i) => f i hi) ≤
        supr fun (i : ι) => supr fun (hi : p i) => g i hi :=
  bsupr_le fun (i : ι) (hi : p i) => le_trans (h i hi) (le_bsupr i hi)

theorem supr_le_supr_const {α : Type u_1} {ι : Sort u_4} {ι₂ : Sort u_5} [complete_lattice α]
    {a : α} (h : ι → ι₂) : (supr fun (i : ι) => a) ≤ supr fun (j : ι₂) => a :=
  supr_le ((le_supr fun (j : ι₂) => a) ∘ h)

@[simp] theorem supr_le_iff {α : Type u_1} {ι : Sort u_4} [complete_lattice α] {s : ι → α} {a : α} :
    supr s ≤ a ↔ ∀ (i : ι), s i ≤ a :=
  iff.trans (is_lub_le_iff is_lub_supr) set.forall_range_iff

theorem supr_lt_iff {α : Type u_1} {ι : Sort u_4} [complete_lattice α] {s : ι → α} {a : α} :
    supr s < a ↔ ∃ (b : α), ∃ (H : b < a), ∀ (i : ι), s i ≤ b :=
  sorry

theorem Sup_eq_supr {α : Type u_1} [complete_lattice α] {s : set α} :
    Sup s = supr fun (a : α) => supr fun (H : a ∈ s) => a :=
  le_antisymm (Sup_le fun (b : α) (h : b ∈ s) => le_supr_of_le b (le_supr (fun (h : b ∈ s) => b) h))
    (supr_le fun (b : α) => supr_le fun (h : b ∈ s) => le_Sup h)

theorem le_supr_iff {α : Type u_1} {ι : Sort u_4} [complete_lattice α] {s : ι → α} {a : α} :
    a ≤ supr s ↔ ∀ (b : α), (∀ (i : ι), s i ≤ b) → a ≤ b :=
  { mp := fun (h : a ≤ supr s) (b : α) (hb : ∀ (i : ι), s i ≤ b) => le_trans h (supr_le hb),
    mpr :=
      fun (h : ∀ (b : α), (∀ (i : ι), s i ≤ b) → a ≤ b) => h (supr s) fun (i : ι) => le_supr s i }

theorem monotone.le_map_supr {α : Type u_1} {β : Type u_2} {ι : Sort u_4} [complete_lattice α]
    {s : ι → α} [complete_lattice β] {f : α → β} (hf : monotone f) :
    (supr fun (i : ι) => f (s i)) ≤ f (supr s) :=
  supr_le fun (i : ι) => hf (le_supr s i)

theorem monotone.le_map_supr2 {α : Type u_1} {β : Type u_2} {ι : Sort u_4} [complete_lattice α]
    [complete_lattice β] {f : α → β} (hf : monotone f) {ι' : ι → Sort u_3}
    (s : (i : ι) → ι' i → α) :
    (supr fun (i : ι) => supr fun (h : ι' i) => f (s i h)) ≤
        f (supr fun (i : ι) => supr fun (h : ι' i) => s i h) :=
  le_trans (supr_le_supr fun (i : ι) => monotone.le_map_supr hf) (monotone.le_map_supr hf)

theorem monotone.le_map_Sup {α : Type u_1} {β : Type u_2} [complete_lattice α] [complete_lattice β]
    {s : set α} {f : α → β} (hf : monotone f) :
    (supr fun (a : α) => supr fun (H : a ∈ s) => f a) ≤ f (Sup s) :=
  eq.mpr
    (id
      (Eq._oldrec (Eq.refl ((supr fun (a : α) => supr fun (H : a ∈ s) => f a) ≤ f (Sup s)))
        Sup_eq_supr))
    (monotone.le_map_supr2 hf fun (a : α) (H : a ∈ s) => a)

theorem supr_comp_le {α : Type u_1} {ι : Sort u_4} [complete_lattice α] {ι' : Sort u_2} (f : ι' → α)
    (g : ι → ι') : (supr fun (x : ι) => f (g x)) ≤ supr fun (y : ι') => f y :=
  supr_le_supr2 fun (x : ι) => Exists.intro (g x) (le_refl (f (g x)))

theorem monotone.supr_comp_eq {α : Type u_1} {β : Type u_2} {ι : Sort u_4} [complete_lattice α]
    [preorder β] {f : β → α} (hf : monotone f) {s : ι → β} (hs : ∀ (x : β), ∃ (i : ι), x ≤ s i) :
    (supr fun (x : ι) => f (s x)) = supr fun (y : β) => f y :=
  le_antisymm (supr_comp_le f fun (x : ι) => s x)
    (supr_le_supr2 fun (x : β) => Exists.imp (fun (i : ι) (hi : x ≤ s i) => hf hi) (hs x))

theorem function.surjective.supr_comp {ι : Sort u_4} {ι₂ : Sort u_5} {α : Type u_1} [has_Sup α]
    {f : ι → ι₂} (hf : function.surjective f) (g : ι₂ → α) :
    (supr fun (x : ι) => g (f x)) = supr fun (y : ι₂) => g y :=
  sorry

theorem supr_congr {ι : Sort u_4} {ι₂ : Sort u_5} {α : Type u_1} [has_Sup α] {f : ι → α}
    {g : ι₂ → α} (h : ι → ι₂) (h1 : function.surjective h) (h2 : ∀ (x : ι), g (h x) = f x) :
    (supr fun (x : ι) => f x) = supr fun (y : ι₂) => g y :=
  sorry

-- TODO: finish doesn't do well here.

theorem supr_congr_Prop {α : Type u_1} [has_Sup α] {p : Prop} {q : Prop} {f₁ : p → α} {f₂ : q → α}
    (pq : p ↔ q) (f : ∀ (x : q), f₁ (iff.mpr pq x) = f₂ x) : supr f₁ = supr f₂ :=
  eq.mpr (id (Eq._oldrec (Eq.refl (supr f₁ = supr f₂)) (Eq.symm (funext f))))
    (Eq.symm
      (function.surjective.supr_comp
        (fun (h : p) => Exists.intro (iff.mp pq h) (Eq.refl (iff.mpr pq (iff.mp pq h)))) f₁))

theorem infi_le {α : Type u_1} {ι : Sort u_4} [complete_lattice α] (s : ι → α) (i : ι) :
    infi s ≤ s i :=
  Inf_le (Exists.intro i rfl)

theorem infi_le' {α : Type u_1} {ι : Sort u_4} [complete_lattice α] (s : ι → α) (i : ι) :
    infi s ≤ s i :=
  Inf_le (Exists.intro i rfl)

theorem infi_le_of_le {α : Type u_1} {ι : Sort u_4} [complete_lattice α] {s : ι → α} {a : α} (i : ι)
    (h : s i ≤ a) : infi s ≤ a :=
  le_trans (infi_le s i) h

theorem binfi_le {α : Type u_1} {ι : Sort u_4} [complete_lattice α] {p : ι → Prop}
    {f : (i : ι) → p i → α} (i : ι) (hi : p i) :
    (infi fun (i : ι) => infi fun (hi : p i) => f i hi) ≤ f i hi :=
  infi_le_of_le i (infi_le (f i) hi)

theorem binfi_le_of_le {α : Type u_1} {ι : Sort u_4} [complete_lattice α] {a : α} {p : ι → Prop}
    {f : (i : ι) → p i → α} (i : ι) (hi : p i) (h : f i hi ≤ a) :
    (infi fun (i : ι) => infi fun (hi : p i) => f i hi) ≤ a :=
  le_trans (binfi_le i hi) h

theorem le_infi {α : Type u_1} {ι : Sort u_4} [complete_lattice α] {s : ι → α} {a : α}
    (h : ∀ (i : ι), a ≤ s i) : a ≤ infi s :=
  sorry

theorem le_binfi {α : Type u_1} {ι : Sort u_4} [complete_lattice α] {a : α} {p : ι → Prop}
    {f : (i : ι) → p i → α} (h : ∀ (i : ι) (hi : p i), a ≤ f i hi) :
    a ≤ infi fun (i : ι) => infi fun (hi : p i) => f i hi :=
  le_infi fun (i : ι) => le_infi (h i)

theorem infi_le_binfi {α : Type u_1} {ι : Sort u_4} [complete_lattice α] (p : ι → Prop)
    (f : ι → α) : (infi fun (i : ι) => f i) ≤ infi fun (i : ι) => infi fun (H : p i) => f i :=
  le_binfi fun (i : ι) (hi : p i) => infi_le f i

theorem infi_le_infi {α : Type u_1} {ι : Sort u_4} [complete_lattice α] {s : ι → α} {t : ι → α}
    (h : ∀ (i : ι), s i ≤ t i) : infi s ≤ infi t :=
  le_infi fun (i : ι) => infi_le_of_le i (h i)

theorem infi_le_infi2 {α : Type u_1} {ι : Sort u_4} {ι₂ : Sort u_5} [complete_lattice α] {s : ι → α}
    {t : ι₂ → α} (h : ∀ (j : ι₂), ∃ (i : ι), s i ≤ t j) : infi s ≤ infi t :=
  le_infi fun (j : ι₂) => exists.elim (h j) infi_le_of_le

theorem binfi_le_binfi {α : Type u_1} {ι : Sort u_4} [complete_lattice α] {p : ι → Prop}
    {f : (i : ι) → p i → α} {g : (i : ι) → p i → α} (h : ∀ (i : ι) (hi : p i), f i hi ≤ g i hi) :
    (infi fun (i : ι) => infi fun (hi : p i) => f i hi) ≤
        infi fun (i : ι) => infi fun (hi : p i) => g i hi :=
  le_binfi fun (i : ι) (hi : p i) => le_trans (binfi_le i hi) (h i hi)

theorem infi_le_infi_const {α : Type u_1} {ι : Sort u_4} {ι₂ : Sort u_5} [complete_lattice α]
    {a : α} (h : ι₂ → ι) : (infi fun (i : ι) => a) ≤ infi fun (j : ι₂) => a :=
  le_infi ((infi_le fun (i : ι) => a) ∘ h)

@[simp] theorem le_infi_iff {α : Type u_1} {ι : Sort u_4} [complete_lattice α] {s : ι → α} {a : α} :
    a ≤ infi s ↔ ∀ (i : ι), a ≤ s i :=
  { mp := fun (this : a ≤ infi s) (i : ι) => le_trans this (infi_le s i), mpr := le_infi }

theorem Inf_eq_infi {α : Type u_1} [complete_lattice α] {s : set α} :
    Inf s = infi fun (a : α) => infi fun (H : a ∈ s) => a :=
  Sup_eq_supr

theorem monotone.map_infi_le {α : Type u_1} {β : Type u_2} {ι : Sort u_4} [complete_lattice α]
    {s : ι → α} [complete_lattice β] {f : α → β} (hf : monotone f) :
    f (infi s) ≤ infi fun (i : ι) => f (s i) :=
  le_infi fun (i : ι) => hf (infi_le s i)

theorem monotone.map_infi2_le {α : Type u_1} {β : Type u_2} {ι : Sort u_4} [complete_lattice α]
    [complete_lattice β] {f : α → β} (hf : monotone f) {ι' : ι → Sort u_3}
    (s : (i : ι) → ι' i → α) :
    f (infi fun (i : ι) => infi fun (h : ι' i) => s i h) ≤
        infi fun (i : ι) => infi fun (h : ι' i) => f (s i h) :=
  monotone.le_map_supr2 (monotone.order_dual hf) fun (i : ι) (h : ι' i) => s i h

theorem monotone.map_Inf_le {α : Type u_1} {β : Type u_2} [complete_lattice α] [complete_lattice β]
    {s : set α} {f : α → β} (hf : monotone f) :
    f (Inf s) ≤ infi fun (a : α) => infi fun (H : a ∈ s) => f a :=
  eq.mpr
    (id
      (Eq._oldrec (Eq.refl (f (Inf s) ≤ infi fun (a : α) => infi fun (H : a ∈ s) => f a))
        Inf_eq_infi))
    (monotone.map_infi2_le hf fun (a : α) (H : a ∈ s) => a)

theorem le_infi_comp {α : Type u_1} {ι : Sort u_4} [complete_lattice α] {ι' : Sort u_2} (f : ι' → α)
    (g : ι → ι') : (infi fun (y : ι') => f y) ≤ infi fun (x : ι) => f (g x) :=
  infi_le_infi2 fun (x : ι) => Exists.intro (g x) (le_refl (f (g x)))

theorem monotone.infi_comp_eq {α : Type u_1} {β : Type u_2} {ι : Sort u_4} [complete_lattice α]
    [preorder β] {f : β → α} (hf : monotone f) {s : ι → β} (hs : ∀ (x : β), ∃ (i : ι), s i ≤ x) :
    (infi fun (x : ι) => f (s x)) = infi fun (y : β) => f y :=
  le_antisymm (infi_le_infi2 fun (x : β) => Exists.imp (fun (i : ι) (hi : s i ≤ x) => hf hi) (hs x))
    (le_infi_comp (fun (y : β) => f y) fun (x : ι) => s x)

theorem function.surjective.infi_comp {ι : Sort u_4} {ι₂ : Sort u_5} {α : Type u_1} [has_Inf α]
    {f : ι → ι₂} (hf : function.surjective f) (g : ι₂ → α) :
    (infi fun (x : ι) => g (f x)) = infi fun (y : ι₂) => g y :=
  function.surjective.supr_comp hf g

theorem infi_congr {ι : Sort u_4} {ι₂ : Sort u_5} {α : Type u_1} [has_Inf α] {f : ι → α}
    {g : ι₂ → α} (h : ι → ι₂) (h1 : function.surjective h) (h2 : ∀ (x : ι), g (h x) = f x) :
    (infi fun (x : ι) => f x) = infi fun (y : ι₂) => g y :=
  supr_congr h h1 h2

theorem infi_congr_Prop {α : Type u_1} [has_Inf α] {p : Prop} {q : Prop} {f₁ : p → α} {f₂ : q → α}
    (pq : p ↔ q) (f : ∀ (x : q), f₁ (iff.mpr pq x) = f₂ x) : infi f₁ = infi f₂ :=
  supr_congr_Prop pq f

theorem supr_const_le {α : Type u_1} {ι : Sort u_4} [complete_lattice α] {x : α} :
    (supr fun (h : ι) => x) ≤ x :=
  supr_le fun (_x : ι) => le_rfl

theorem le_infi_const {α : Type u_1} {ι : Sort u_4} [complete_lattice α] {x : α} :
    x ≤ infi fun (h : ι) => x :=
  le_infi fun (_x : ι) => le_rfl

-- We will generalize this to conditionally complete lattices in `cinfi_const`.

theorem infi_const {α : Type u_1} {ι : Sort u_4} [complete_lattice α] [Nonempty ι] {a : α} :
    (infi fun (b : ι) => a) = a :=
  eq.mpr
    (id
      (Eq._oldrec (Eq.refl ((infi fun (b : ι) => a) = a)) (infi.equations._eqn_1 fun (b : ι) => a)))
    (eq.mpr (id (Eq._oldrec (Eq.refl (Inf (set.range fun (b : ι) => a) = a)) set.range_const))
      (eq.mpr (id (Eq._oldrec (Eq.refl (Inf (singleton a) = a)) Inf_singleton)) (Eq.refl a)))

-- We will generalize this to conditionally complete lattices in `csupr_const`.

theorem supr_const {α : Type u_1} {ι : Sort u_4} [complete_lattice α] [Nonempty ι] {a : α} :
    (supr fun (b : ι) => a) = a :=
  infi_const

@[simp] theorem infi_top {α : Type u_1} {ι : Sort u_4} [complete_lattice α] :
    (infi fun (i : ι) => ⊤) = ⊤ :=
  top_unique (le_infi fun (i : ι) => le_refl ⊤)

@[simp] theorem supr_bot {α : Type u_1} {ι : Sort u_4} [complete_lattice α] :
    (supr fun (i : ι) => ⊥) = ⊥ :=
  infi_top

@[simp] theorem infi_eq_top {α : Type u_1} {ι : Sort u_4} [complete_lattice α] {s : ι → α} :
    infi s = ⊤ ↔ ∀ (i : ι), s i = ⊤ :=
  iff.trans Inf_eq_top set.forall_range_iff

@[simp] theorem supr_eq_bot {α : Type u_1} {ι : Sort u_4} [complete_lattice α] {s : ι → α} :
    supr s = ⊥ ↔ ∀ (i : ι), s i = ⊥ :=
  iff.trans Sup_eq_bot set.forall_range_iff

@[simp] theorem infi_pos {α : Type u_1} [complete_lattice α] {p : Prop} {f : p → α} (hp : p) :
    (infi fun (h : p) => f h) = f hp :=
  le_antisymm (infi_le (fun (h : p) => f h) hp) (le_infi fun (h : p) => le_refl (f hp))

@[simp] theorem infi_neg {α : Type u_1} [complete_lattice α] {p : Prop} {f : p → α} (hp : ¬p) :
    (infi fun (h : p) => f h) = ⊤ :=
  le_antisymm le_top (le_infi fun (h : p) => false.elim (hp h))

@[simp] theorem supr_pos {α : Type u_1} [complete_lattice α] {p : Prop} {f : p → α} (hp : p) :
    (supr fun (h : p) => f h) = f hp :=
  le_antisymm (supr_le fun (h : p) => le_refl (f h)) (le_supr f hp)

@[simp] theorem supr_neg {α : Type u_1} [complete_lattice α] {p : Prop} {f : p → α} (hp : ¬p) :
    (supr fun (h : p) => f h) = ⊥ :=
  le_antisymm (supr_le fun (h : p) => false.elim (hp h)) bot_le

theorem supr_eq_dif {α : Type u_1} [complete_lattice α] {p : Prop} [Decidable p] (a : p → α) :
    (supr fun (h : p) => a h) = dite p (fun (h : p) => a h) fun (h : ¬p) => ⊥ :=
  sorry

theorem supr_eq_if {α : Type u_1} [complete_lattice α] {p : Prop} [Decidable p] (a : α) :
    (supr fun (h : p) => a) = ite p a ⊥ :=
  supr_eq_dif fun (_x : p) => a

theorem infi_eq_dif {α : Type u_1} [complete_lattice α] {p : Prop} [Decidable p] (a : p → α) :
    (infi fun (h : p) => a h) = dite p (fun (h : p) => a h) fun (h : ¬p) => ⊤ :=
  supr_eq_dif fun (h : p) => a h

theorem infi_eq_if {α : Type u_1} [complete_lattice α] {p : Prop} [Decidable p] (a : α) :
    (infi fun (h : p) => a) = ite p a ⊤ :=
  infi_eq_dif fun (_x : p) => a

-- TODO: should this be @[simp]?

theorem infi_comm {α : Type u_1} {ι : Sort u_4} {ι₂ : Sort u_5} [complete_lattice α]
    {f : ι → ι₂ → α} :
    (infi fun (i : ι) => infi fun (j : ι₂) => f i j) =
        infi fun (j : ι₂) => infi fun (i : ι) => f i j :=
  le_antisymm
    (le_infi
      fun (i : ι₂) =>
        le_infi fun (j : ι) => infi_le_of_le j (infi_le (fun (j_1 : ι₂) => f j j_1) i))
    (le_infi
      fun (j : ι) => le_infi fun (i : ι₂) => infi_le_of_le i (infi_le (fun (i_1 : ι) => f i_1 i) j))

/- TODO: this is strange. In the proof below, we get exactly the desired
   among the equalities, but close does not get it.
begin
  apply @le_antisymm,
    simp, intros,
    begin [smt]
      ematch, ematch, ematch, trace_state, have := le_refl (f i_1 i),
      trace_state, close
    end
end
-/

-- TODO: should this be @[simp]?

theorem supr_comm {α : Type u_1} {ι : Sort u_4} {ι₂ : Sort u_5} [complete_lattice α]
    {f : ι → ι₂ → α} :
    (supr fun (i : ι) => supr fun (j : ι₂) => f i j) =
        supr fun (j : ι₂) => supr fun (i : ι) => f i j :=
  infi_comm

@[simp] theorem infi_infi_eq_left {α : Type u_1} {β : Type u_2} [complete_lattice α] {b : β}
    {f : (x : β) → x = b → α} : (infi fun (x : β) => infi fun (h : x = b) => f x h) = f b rfl :=
  sorry

@[simp] theorem infi_infi_eq_right {α : Type u_1} {β : Type u_2} [complete_lattice α] {b : β}
    {f : (x : β) → b = x → α} : (infi fun (x : β) => infi fun (h : b = x) => f x h) = f b rfl :=
  sorry

@[simp] theorem supr_supr_eq_left {α : Type u_1} {β : Type u_2} [complete_lattice α] {b : β}
    {f : (x : β) → x = b → α} : (supr fun (x : β) => supr fun (h : x = b) => f x h) = f b rfl :=
  infi_infi_eq_left

@[simp] theorem supr_supr_eq_right {α : Type u_1} {β : Type u_2} [complete_lattice α] {b : β}
    {f : (x : β) → b = x → α} : (supr fun (x : β) => supr fun (h : b = x) => f x h) = f b rfl :=
  infi_infi_eq_right

theorem infi_subtype {α : Type u_1} {ι : Sort u_4} [complete_lattice α] {p : ι → Prop}
    {f : Subtype p → α} :
    (infi fun (x : Subtype p) => f x) =
        infi fun (i : ι) => infi fun (h : p i) => f { val := i, property := h } :=
  sorry

theorem infi_subtype' {α : Type u_1} {ι : Sort u_4} [complete_lattice α] {p : ι → Prop}
    {f : (i : ι) → p i → α} :
    (infi fun (i : ι) => infi fun (h : p i) => f i h) =
        infi fun (x : Subtype p) => f (↑x) (subtype.property x) :=
  Eq.symm infi_subtype

theorem infi_subtype'' {α : Type u_1} [complete_lattice α] {ι : Type u_2} (s : set ι) (f : ι → α) :
    (infi fun (i : ↥s) => f ↑i) = infi fun (t : ι) => infi fun (H : t ∈ s) => f t :=
  infi_subtype

theorem infi_inf_eq {α : Type u_1} {ι : Sort u_4} [complete_lattice α] {f : ι → α} {g : ι → α} :
    (infi fun (x : ι) => f x ⊓ g x) = (infi fun (x : ι) => f x) ⊓ infi fun (x : ι) => g x :=
  sorry

/- TODO: here is another example where more flexible pattern matching
   might help.

begin
  apply @le_antisymm,
  safe, pose h := f a ⊓ g a, begin [smt] ematch, ematch  end
end
-/

theorem infi_inf {α : Type u_1} {ι : Sort u_4} [complete_lattice α] [h : Nonempty ι] {f : ι → α}
    {a : α} : (infi fun (x : ι) => f x) ⊓ a = infi fun (x : ι) => f x ⊓ a :=
  sorry

theorem inf_infi {α : Type u_1} {ι : Sort u_4} [complete_lattice α] [Nonempty ι] {f : ι → α}
    {a : α} : (a ⊓ infi fun (x : ι) => f x) = infi fun (x : ι) => a ⊓ f x :=
  sorry

theorem binfi_inf {α : Type u_1} {ι : Sort u_4} [complete_lattice α] {p : ι → Prop}
    {f : (i : ι) → p i → α} {a : α} (h : ∃ (i : ι), p i) :
    (infi fun (i : ι) => infi fun (h : p i) => f i h) ⊓ a =
        infi fun (i : ι) => infi fun (h : p i) => f i h ⊓ a :=
  sorry

theorem inf_binfi {α : Type u_1} {ι : Sort u_4} [complete_lattice α] {p : ι → Prop}
    {f : (i : ι) → p i → α} {a : α} (h : ∃ (i : ι), p i) :
    (a ⊓ infi fun (i : ι) => infi fun (h : p i) => f i h) =
        infi fun (i : ι) => infi fun (h : p i) => a ⊓ f i h :=
  sorry

theorem supr_sup_eq {α : Type u_1} {β : Type u_2} [complete_lattice α] {f : β → α} {g : β → α} :
    (supr fun (x : β) => f x ⊔ g x) = (supr fun (x : β) => f x) ⊔ supr fun (x : β) => g x :=
  infi_inf_eq

theorem supr_sup {α : Type u_1} {ι : Sort u_4} [complete_lattice α] [h : Nonempty ι] {f : ι → α}
    {a : α} : (supr fun (x : ι) => f x) ⊔ a = supr fun (x : ι) => f x ⊔ a :=
  infi_inf

theorem sup_supr {α : Type u_1} {ι : Sort u_4} [complete_lattice α] [Nonempty ι] {f : ι → α}
    {a : α} : (a ⊔ supr fun (x : ι) => f x) = supr fun (x : ι) => a ⊔ f x :=
  inf_infi

/- supr and infi under Prop -/

@[simp] theorem infi_false {α : Type u_1} [complete_lattice α] {s : False → α} : infi s = ⊤ :=
  le_antisymm le_top (le_infi fun (i : False) => false.elim i)

@[simp] theorem supr_false {α : Type u_1} [complete_lattice α] {s : False → α} : supr s = ⊥ :=
  le_antisymm (supr_le fun (i : False) => false.elim i) bot_le

@[simp] theorem infi_true {α : Type u_1} [complete_lattice α] {s : True → α} : infi s = s trivial :=
  le_antisymm (infi_le s trivial)
    (le_infi
      fun (_x : True) =>
        (fun (_a : True) => true.dcases_on _a (idRhs (s trivial ≤ s trivial) (le_refl (s trivial))))
          _x)

@[simp] theorem supr_true {α : Type u_1} [complete_lattice α] {s : True → α} : supr s = s trivial :=
  sorry

@[simp] theorem infi_exists {α : Type u_1} {ι : Sort u_4} [complete_lattice α] {p : ι → Prop}
    {f : Exists p → α} :
    (infi fun (x : Exists p) => f x) =
        infi fun (i : ι) => infi fun (h : p i) => f (Exists.intro i h) :=
  sorry

@[simp] theorem supr_exists {α : Type u_1} {ι : Sort u_4} [complete_lattice α] {p : ι → Prop}
    {f : Exists p → α} :
    (supr fun (x : Exists p) => f x) =
        supr fun (i : ι) => supr fun (h : p i) => f (Exists.intro i h) :=
  infi_exists

theorem infi_and {α : Type u_1} [complete_lattice α] {p : Prop} {q : Prop} {s : p ∧ q → α} :
    infi s = infi fun (h₁ : p) => infi fun (h₂ : q) => s { left := h₁, right := h₂ } :=
  sorry

/-- The symmetric case of `infi_and`, useful for rewriting into a infimum over a conjunction -/
theorem infi_and' {α : Type u_1} [complete_lattice α] {p : Prop} {q : Prop} {s : p → q → α} :
    (infi fun (h₁ : p) => infi fun (h₂ : q) => s h₁ h₂) =
        infi fun (h : p ∧ q) => s (and.left h) (and.right h) :=
  Eq.symm infi_and

theorem supr_and {α : Type u_1} [complete_lattice α] {p : Prop} {q : Prop} {s : p ∧ q → α} :
    supr s = supr fun (h₁ : p) => supr fun (h₂ : q) => s { left := h₁, right := h₂ } :=
  infi_and

/-- The symmetric case of `supr_and`, useful for rewriting into a supremum over a conjunction -/
theorem supr_and' {α : Type u_1} [complete_lattice α] {p : Prop} {q : Prop} {s : p → q → α} :
    (supr fun (h₁ : p) => supr fun (h₂ : q) => s h₁ h₂) =
        supr fun (h : p ∧ q) => s (and.left h) (and.right h) :=
  Eq.symm supr_and

theorem infi_or {α : Type u_1} [complete_lattice α] {p : Prop} {q : Prop} {s : p ∨ q → α} :
    infi s = (infi fun (h : p) => s (Or.inl h)) ⊓ infi fun (h : q) => s (Or.inr h) :=
  sorry

theorem supr_or {α : Type u_1} [complete_lattice α] {p : Prop} {q : Prop} {s : p ∨ q → α} :
    (supr fun (x : p ∨ q) => s x) =
        (supr fun (i : p) => s (Or.inl i)) ⊔ supr fun (j : q) => s (Or.inr j) :=
  infi_or

theorem Sup_range {ι : Sort u_4} {α : Type u_1} [has_Sup α] {f : ι → α} :
    Sup (set.range f) = supr f :=
  rfl

theorem Inf_range {ι : Sort u_4} {α : Type u_1} [has_Inf α] {f : ι → α} :
    Inf (set.range f) = infi f :=
  rfl

theorem supr_range {α : Type u_1} {β : Type u_2} {ι : Sort u_4} [complete_lattice α] {g : β → α}
    {f : ι → β} :
    (supr fun (b : β) => supr fun (H : b ∈ set.range f) => g b) = supr fun (i : ι) => g (f i) :=
  sorry

theorem infi_range {α : Type u_1} {β : Type u_2} {ι : Sort u_4} [complete_lattice α] {g : β → α}
    {f : ι → β} :
    (infi fun (b : β) => infi fun (H : b ∈ set.range f) => g b) = infi fun (i : ι) => g (f i) :=
  supr_range

theorem Inf_image {α : Type u_1} {β : Type u_2} [complete_lattice α] {s : set β} {f : β → α} :
    Inf (f '' s) = infi fun (a : β) => infi fun (H : a ∈ s) => f a :=
  sorry

theorem Sup_image {α : Type u_1} {β : Type u_2} [complete_lattice α] {s : set β} {f : β → α} :
    Sup (f '' s) = supr fun (a : β) => supr fun (H : a ∈ s) => f a :=
  Inf_image

/-
### supr and infi under set constructions
-/

theorem infi_emptyset {α : Type u_1} {β : Type u_2} [complete_lattice α] {f : β → α} :
    (infi fun (x : β) => infi fun (H : x ∈ ∅) => f x) = ⊤ :=
  sorry

theorem supr_emptyset {α : Type u_1} {β : Type u_2} [complete_lattice α] {f : β → α} :
    (supr fun (x : β) => supr fun (H : x ∈ ∅) => f x) = ⊥ :=
  sorry

theorem infi_univ {α : Type u_1} {β : Type u_2} [complete_lattice α] {f : β → α} :
    (infi fun (x : β) => infi fun (H : x ∈ set.univ) => f x) = infi fun (x : β) => f x :=
  sorry

theorem supr_univ {α : Type u_1} {β : Type u_2} [complete_lattice α] {f : β → α} :
    (supr fun (x : β) => supr fun (H : x ∈ set.univ) => f x) = supr fun (x : β) => f x :=
  sorry

theorem infi_union {α : Type u_1} {β : Type u_2} [complete_lattice α] {f : β → α} {s : set β}
    {t : set β} :
    (infi fun (x : β) => infi fun (H : x ∈ s ∪ t) => f x) =
        (infi fun (x : β) => infi fun (H : x ∈ s) => f x) ⊓
          infi fun (x : β) => infi fun (H : x ∈ t) => f x :=
  sorry

theorem infi_split {α : Type u_1} {β : Type u_2} [complete_lattice α] (f : β → α) (p : β → Prop) :
    (infi fun (i : β) => f i) =
        (infi fun (i : β) => infi fun (h : p i) => f i) ⊓
          infi fun (i : β) => infi fun (h : ¬p i) => f i :=
  sorry

theorem infi_split_single {α : Type u_1} {β : Type u_2} [complete_lattice α] (f : β → α) (i₀ : β) :
    (infi fun (i : β) => f i) = f i₀ ⊓ infi fun (i : β) => infi fun (h : i ≠ i₀) => f i :=
  sorry

theorem infi_le_infi_of_subset {α : Type u_1} {β : Type u_2} [complete_lattice α] {f : β → α}
    {s : set β} {t : set β} (h : s ⊆ t) :
    (infi fun (x : β) => infi fun (H : x ∈ t) => f x) ≤
        infi fun (x : β) => infi fun (H : x ∈ s) => f x :=
  sorry

theorem supr_union {α : Type u_1} {β : Type u_2} [complete_lattice α] {f : β → α} {s : set β}
    {t : set β} :
    (supr fun (x : β) => supr fun (H : x ∈ s ∪ t) => f x) =
        (supr fun (x : β) => supr fun (H : x ∈ s) => f x) ⊔
          supr fun (x : β) => supr fun (H : x ∈ t) => f x :=
  infi_union

theorem supr_split {α : Type u_1} {β : Type u_2} [complete_lattice α] (f : β → α) (p : β → Prop) :
    (supr fun (i : β) => f i) =
        (supr fun (i : β) => supr fun (h : p i) => f i) ⊔
          supr fun (i : β) => supr fun (h : ¬p i) => f i :=
  infi_split (fun (i : β) => f i) fun (i : β) => p i

theorem supr_split_single {α : Type u_1} {β : Type u_2} [complete_lattice α] (f : β → α) (i₀ : β) :
    (supr fun (i : β) => f i) = f i₀ ⊔ supr fun (i : β) => supr fun (h : i ≠ i₀) => f i :=
  infi_split_single (fun (i : β) => f i) i₀

theorem supr_le_supr_of_subset {α : Type u_1} {β : Type u_2} [complete_lattice α] {f : β → α}
    {s : set β} {t : set β} (h : s ⊆ t) :
    (supr fun (x : β) => supr fun (H : x ∈ s) => f x) ≤
        supr fun (x : β) => supr fun (H : x ∈ t) => f x :=
  infi_le_infi_of_subset h

theorem infi_insert {α : Type u_1} {β : Type u_2} [complete_lattice α] {f : β → α} {s : set β}
    {b : β} :
    (infi fun (x : β) => infi fun (H : x ∈ insert b s) => f x) =
        f b ⊓ infi fun (x : β) => infi fun (H : x ∈ s) => f x :=
  Eq.trans infi_union
    (congr_arg (fun (x : α) => x ⊓ infi fun (x : β) => infi fun (H : x ∈ s) => f x)
      infi_infi_eq_left)

theorem supr_insert {α : Type u_1} {β : Type u_2} [complete_lattice α] {f : β → α} {s : set β}
    {b : β} :
    (supr fun (x : β) => supr fun (H : x ∈ insert b s) => f x) =
        f b ⊔ supr fun (x : β) => supr fun (H : x ∈ s) => f x :=
  Eq.trans supr_union
    (congr_arg (fun (x : α) => x ⊔ supr fun (x : β) => supr fun (H : x ∈ s) => f x)
      supr_supr_eq_left)

theorem infi_singleton {α : Type u_1} {β : Type u_2} [complete_lattice α] {f : β → α} {b : β} :
    (infi fun (x : β) => infi fun (H : x ∈ singleton b) => f x) = f b :=
  sorry

theorem infi_pair {α : Type u_1} {β : Type u_2} [complete_lattice α] {f : β → α} {a : β} {b : β} :
    (infi fun (x : β) => infi fun (H : x ∈ insert a (singleton b)) => f x) = f a ⊓ f b :=
  sorry

theorem supr_singleton {α : Type u_1} {β : Type u_2} [complete_lattice α] {f : β → α} {b : β} :
    (supr fun (x : β) => supr fun (H : x ∈ singleton b) => f x) = f b :=
  infi_singleton

theorem supr_pair {α : Type u_1} {β : Type u_2} [complete_lattice α] {f : β → α} {a : β} {b : β} :
    (supr fun (x : β) => supr fun (H : x ∈ insert a (singleton b)) => f x) = f a ⊔ f b :=
  sorry

theorem infi_image {α : Type u_1} {β : Type u_2} [complete_lattice α] {γ : Type u_3} {f : β → γ}
    {g : γ → α} {t : set β} :
    (infi fun (c : γ) => infi fun (H : c ∈ f '' t) => g c) =
        infi fun (b : β) => infi fun (H : b ∈ t) => g (f b) :=
  sorry

theorem supr_image {α : Type u_1} {β : Type u_2} [complete_lattice α] {γ : Type u_3} {f : β → γ}
    {g : γ → α} {t : set β} :
    (supr fun (c : γ) => supr fun (H : c ∈ f '' t) => g c) =
        supr fun (b : β) => supr fun (H : b ∈ t) => g (f b) :=
  infi_image

/-!
### `supr` and `infi` under `Type`
-/

theorem infi_of_empty' {α : Type u_1} {ι : Sort u_4} [complete_lattice α] (h : ι → False)
    {s : ι → α} : infi s = ⊤ :=
  top_unique (le_infi fun (i : ι) => false.elim (h i))

theorem supr_of_empty' {α : Type u_1} {ι : Sort u_4} [complete_lattice α] (h : ι → False)
    {s : ι → α} : supr s = ⊥ :=
  bot_unique (supr_le fun (i : ι) => false.elim (h i))

theorem infi_of_empty {α : Type u_1} {ι : Sort u_4} [complete_lattice α] (h : ¬Nonempty ι)
    {s : ι → α} : infi s = ⊤ :=
  infi_of_empty' fun (i : ι) => h (Nonempty.intro i)

theorem supr_of_empty {α : Type u_1} {ι : Sort u_4} [complete_lattice α] (h : ¬Nonempty ι)
    {s : ι → α} : supr s = ⊥ :=
  supr_of_empty' fun (i : ι) => h (Nonempty.intro i)

@[simp] theorem infi_empty {α : Type u_1} [complete_lattice α] {s : empty → α} : infi s = ⊤ :=
  infi_of_empty nonempty_empty

@[simp] theorem supr_empty {α : Type u_1} [complete_lattice α] {s : empty → α} : supr s = ⊥ :=
  supr_of_empty nonempty_empty

theorem supr_bool_eq {α : Type u_1} [complete_lattice α] {f : Bool → α} :
    (supr fun (b : Bool) => f b) = f tt ⊔ f false :=
  sorry

theorem infi_bool_eq {α : Type u_1} [complete_lattice α] {f : Bool → α} :
    (infi fun (b : Bool) => f b) = f tt ⊓ f false :=
  supr_bool_eq

theorem is_glb_binfi {α : Type u_1} {β : Type u_2} [complete_lattice α] {s : set β} {f : β → α} :
    is_glb (f '' s) (infi fun (x : β) => infi fun (H : x ∈ s) => f x) :=
  sorry

theorem supr_subtype {α : Type u_1} {ι : Sort u_4} [complete_lattice α] {p : ι → Prop}
    {f : Subtype p → α} :
    (supr fun (x : Subtype p) => f x) =
        supr fun (i : ι) => supr fun (h : p i) => f { val := i, property := h } :=
  infi_subtype

theorem supr_subtype' {α : Type u_1} {ι : Sort u_4} [complete_lattice α] {p : ι → Prop}
    {f : (i : ι) → p i → α} :
    (supr fun (i : ι) => supr fun (h : p i) => f i h) =
        supr fun (x : Subtype p) => f (↑x) (subtype.property x) :=
  Eq.symm supr_subtype

theorem Sup_eq_supr' {α : Type u_1} [complete_lattice α] {s : set α} :
    Sup s = supr fun (x : ↥s) => ↑x :=
  sorry

theorem is_lub_bsupr {α : Type u_1} {β : Type u_2} [complete_lattice α] {s : set β} {f : β → α} :
    is_lub (f '' s) (supr fun (x : β) => supr fun (H : x ∈ s) => f x) :=
  sorry

theorem infi_sigma {α : Type u_1} {β : Type u_2} [complete_lattice α] {p : β → Type u_3}
    {f : sigma p → α} :
    (infi fun (x : sigma p) => f x) = infi fun (i : β) => infi fun (h : p i) => f (sigma.mk i h) :=
  sorry

theorem supr_sigma {α : Type u_1} {β : Type u_2} [complete_lattice α] {p : β → Type u_3}
    {f : sigma p → α} :
    (supr fun (x : sigma p) => f x) = supr fun (i : β) => supr fun (h : p i) => f (sigma.mk i h) :=
  infi_sigma

theorem infi_prod {α : Type u_1} {β : Type u_2} [complete_lattice α] {γ : Type u_3}
    {f : β × γ → α} :
    (infi fun (x : β × γ) => f x) = infi fun (i : β) => infi fun (j : γ) => f (i, j) :=
  sorry

theorem supr_prod {α : Type u_1} {β : Type u_2} [complete_lattice α] {γ : Type u_3}
    {f : β × γ → α} :
    (supr fun (x : β × γ) => f x) = supr fun (i : β) => supr fun (j : γ) => f (i, j) :=
  infi_prod

theorem infi_sum {α : Type u_1} {β : Type u_2} [complete_lattice α] {γ : Type u_3} {f : β ⊕ γ → α} :
    (infi fun (x : β ⊕ γ) => f x) =
        (infi fun (i : β) => f (sum.inl i)) ⊓ infi fun (j : γ) => f (sum.inr j) :=
  sorry

theorem supr_sum {α : Type u_1} {β : Type u_2} [complete_lattice α] {γ : Type u_3} {f : β ⊕ γ → α} :
    (supr fun (x : β ⊕ γ) => f x) =
        (supr fun (i : β) => f (sum.inl i)) ⊔ supr fun (j : γ) => f (sum.inr j) :=
  infi_sum

/-!
### `supr` and `infi` under `ℕ`
-/

theorem supr_ge_eq_supr_nat_add {α : Type u_1} [complete_lattice α] {u : ℕ → α} (n : ℕ) :
    (supr fun (i : ℕ) => supr fun (H : i ≥ n) => u i) = supr fun (i : ℕ) => u (i + n) :=
  sorry

theorem infi_ge_eq_infi_nat_add {α : Type u_1} [complete_lattice α] {u : ℕ → α} (n : ℕ) :
    (infi fun (i : ℕ) => infi fun (H : i ≥ n) => u i) = infi fun (i : ℕ) => u (i + n) :=
  supr_ge_eq_supr_nat_add n

theorem supr_eq_top {α : Type u_1} {ι : Sort u_4} [complete_linear_order α] (f : ι → α) :
    supr f = ⊤ ↔ ∀ (b : α), b < ⊤ → ∃ (i : ι), b < f i :=
  sorry

theorem infi_eq_bot {α : Type u_1} {ι : Sort u_4} [complete_linear_order α] (f : ι → α) :
    infi f = ⊥ ↔ ∀ (b : α), b > ⊥ → ∃ (i : ι), f i < b :=
  sorry

/-!
### Instances
-/

protected instance complete_lattice_Prop : complete_lattice Prop :=
  complete_lattice.mk bounded_distrib_lattice.sup bounded_distrib_lattice.le
    bounded_distrib_lattice.lt sorry sorry sorry sorry sorry sorry bounded_distrib_lattice.inf sorry
    sorry sorry bounded_distrib_lattice.top sorry bounded_distrib_lattice.bot sorry
    (fun (s : set Prop) => ∃ (a : Prop), ∃ (H : a ∈ s), a)
    (fun (s : set Prop) => ∀ (a : Prop), a ∈ s → a) sorry sorry sorry sorry

theorem Inf_Prop_eq {s : set Prop} : Inf s = ∀ (p : Prop), p ∈ s → p := rfl

theorem Sup_Prop_eq {s : set Prop} : Sup s = ∃ (p : Prop), ∃ (H : p ∈ s), p := rfl

theorem infi_Prop_eq {ι : Sort u_1} {p : ι → Prop} : (infi fun (i : ι) => p i) = ∀ (i : ι), p i :=
  sorry

theorem supr_Prop_eq {ι : Sort u_1} {p : ι → Prop} : (supr fun (i : ι) => p i) = ∃ (i : ι), p i :=
  sorry

protected instance pi.has_Sup {α : Type u_1} {β : α → Type u_2} [(i : α) → has_Sup (β i)] :
    has_Sup ((i : α) → β i) :=
  has_Sup.mk fun (s : set ((i : α) → β i)) (i : α) => supr fun (f : ↥s) => coe f i

protected instance pi.has_Inf {α : Type u_1} {β : α → Type u_2} [(i : α) → has_Inf (β i)] :
    has_Inf ((i : α) → β i) :=
  has_Inf.mk fun (s : set ((i : α) → β i)) (i : α) => infi fun (f : ↥s) => coe f i

protected instance pi.complete_lattice {α : Type u_1} {β : α → Type u_2}
    [(i : α) → complete_lattice (β i)] : complete_lattice ((i : α) → β i) :=
  complete_lattice.mk bounded_lattice.sup bounded_lattice.le bounded_lattice.lt sorry sorry sorry
    sorry sorry sorry bounded_lattice.inf sorry sorry sorry bounded_lattice.top sorry
    bounded_lattice.bot sorry Sup Inf sorry sorry sorry sorry

theorem Inf_apply {α : Type u_1} {β : α → Type u_2} [(i : α) → has_Inf (β i)]
    {s : set ((a : α) → β a)} {a : α} : Inf s a = infi fun (f : ↥s) => coe f a :=
  rfl

theorem infi_apply {α : Type u_1} {β : α → Type u_2} {ι : Sort u_3} [(i : α) → has_Inf (β i)]
    {f : ι → (a : α) → β a} {a : α} : infi (fun (i : ι) => f i) a = infi fun (i : ι) => f i a :=
  sorry

theorem Sup_apply {α : Type u_1} {β : α → Type u_2} [(i : α) → has_Sup (β i)]
    {s : set ((a : α) → β a)} {a : α} : Sup s a = supr fun (f : ↥s) => coe f a :=
  rfl

theorem supr_apply {α : Type u_1} {β : α → Type u_2} {ι : Sort u_3} [(i : α) → has_Sup (β i)]
    {f : ι → (a : α) → β a} {a : α} : supr (fun (i : ι) => f i) a = supr fun (i : ι) => f i a :=
  infi_apply

theorem monotone_Sup_of_monotone {α : Type u_1} {β : Type u_2} [preorder α] [complete_lattice β]
    {s : set (α → β)} (m_s : ∀ (f : α → β), f ∈ s → monotone f) : monotone (Sup s) :=
  fun (x y : α) (h : x ≤ y) =>
    supr_le fun (f : ↥s) => le_supr_of_le f (m_s (↑f) (subtype.property f) h)

theorem monotone_Inf_of_monotone {α : Type u_1} {β : Type u_2} [preorder α] [complete_lattice β]
    {s : set (α → β)} (m_s : ∀ (f : α → β), f ∈ s → monotone f) : monotone (Inf s) :=
  fun (x y : α) (h : x ≤ y) =>
    le_infi fun (f : ↥s) => infi_le_of_le f (m_s (↑f) (subtype.property f) h)

namespace prod

protected instance has_Inf (α : Type u_1) (β : Type u_2) [has_Inf α] [has_Inf β] :
    has_Inf (α × β) :=
  has_Inf.mk fun (s : set (α × β)) => (Inf (fst '' s), Inf (snd '' s))

protected instance has_Sup (α : Type u_1) (β : Type u_2) [has_Sup α] [has_Sup β] :
    has_Sup (α × β) :=
  has_Sup.mk fun (s : set (α × β)) => (Sup (fst '' s), Sup (snd '' s))

protected instance complete_lattice (α : Type u_1) (β : Type u_2) [complete_lattice α]
    [complete_lattice β] : complete_lattice (α × β) :=
  complete_lattice.mk bounded_lattice.sup bounded_lattice.le bounded_lattice.lt sorry sorry sorry
    sorry sorry sorry bounded_lattice.inf sorry sorry sorry bounded_lattice.top sorry
    bounded_lattice.bot sorry Sup Inf sorry sorry sorry sorry

end Mathlib


/-
Copyright (c) 2020 Oliver Nash. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Oliver Nash

! This file was ported from Lean 3 source module algebra.lie.universal_enveloping
! leanprover-community/mathlib commit 32b08ef840dd25ca2e47e035c5da03ce16d2dc3c
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Algebra.Lie.OfAssociative
import Mathbin.Algebra.RingQuot
import Mathbin.LinearAlgebra.TensorAlgebra.Basic

/-!
# Universal enveloping algebra

Given a commutative ring `R` and a Lie algebra `L` over `R`, we construct the universal
enveloping algebra of `L`, together with its universal property.

## Main definitions

  * `universal_enveloping_algebra`: the universal enveloping algebra, endowed with an
    `R`-algebra structure.
  * `universal_enveloping_algebra.ι`: the Lie algebra morphism from `L` to its universal
    enveloping algebra.
  * `universal_enveloping_algebra.lift`: given an associative algebra `A`, together with a Lie
    algebra morphism `f : L →ₗ⁅R⁆ A`, `lift R L f : universal_enveloping_algebra R L →ₐ[R] A` is the
    unique morphism of algebras through which `f` factors.
  * `universal_enveloping_algebra.ι_comp_lift`: states that the lift of a morphism is indeed part
    of a factorisation.
  * `universal_enveloping_algebra.lift_unique`: states that lifts of morphisms are indeed unique.
  * `universal_enveloping_algebra.hom_ext`: a restatement of `lift_unique` as an extensionality
    lemma.

## Tags

lie algebra, universal enveloping algebra, tensor algebra
-/

universe u₁ u₂ u₃

variable (R : Type u₁) (L : Type u₂)

variable [CommRing R] [LieRing L] [LieAlgebra R L]

-- mathport name: exprιₜ
local notation "ιₜ" => TensorAlgebra.ι R

namespace UniversalEnvelopingAlgebra

/-- The quotient by the ideal generated by this relation is the universal enveloping algebra.

Note that we have avoided using the more natural expression:
| lie_compat (x y : L) : rel (ιₜ ⁅x, y⁆) ⁅ιₜ x, ιₜ y⁆
so that our construction needs only the semiring structure of the tensor algebra. -/
inductive Rel : TensorAlgebra R L → TensorAlgebra R L → Prop
  | lie_compat (x y : L) : Rel (ιₜ ⁅x, y⁆ + ιₜ y * ιₜ x) (ιₜ x * ιₜ y)
#align universal_enveloping_algebra.rel UniversalEnvelopingAlgebra.Rel

end UniversalEnvelopingAlgebra

/- ./././Mathport/Syntax/Translate/Command.lean:42:9: unsupported derive handler algebra[algebra] R -/
/-- The universal enveloping algebra of a Lie algebra. -/
def UniversalEnvelopingAlgebra :=
  RingQuot (UniversalEnvelopingAlgebra.Rel R L)deriving Inhabited, Ring,
  «./././Mathport/Syntax/Translate/Command.lean:42:9: unsupported derive handler algebra[algebra] R»
#align universal_enveloping_algebra UniversalEnvelopingAlgebra

namespace UniversalEnvelopingAlgebra

/-- The quotient map from the tensor algebra to the universal enveloping algebra as a morphism of
associative algebras. -/
def mkAlgHom : TensorAlgebra R L →ₐ[R] UniversalEnvelopingAlgebra R L :=
  RingQuot.mkAlgHom R (Rel R L)
#align universal_enveloping_algebra.mk_alg_hom UniversalEnvelopingAlgebra.mkAlgHom

variable {L}

/-- The natural Lie algebra morphism from a Lie algebra to its universal enveloping algebra. -/
def ι : L →ₗ⁅R⁆ UniversalEnvelopingAlgebra R L :=
  { (mkAlgHom R L).toLinearMap.comp ιₜ with
    map_lie' := fun x y =>
      by
      suffices mk_alg_hom R L (ιₜ ⁅x, y⁆ + ιₜ y * ιₜ x) = mk_alg_hom R L (ιₜ x * ιₜ y)
        by
        rw [AlgHom.map_mul] at this
        simp [LieRing.of_associative_ring_bracket, ← this]
      exact RingQuot.mkAlgHom_rel _ (rel.lie_compat x y) }
#align universal_enveloping_algebra.ι UniversalEnvelopingAlgebra.ι

variable {A : Type u₃} [Ring A] [Algebra R A] (f : L →ₗ⁅R⁆ A)

/-- The universal property of the universal enveloping algebra: Lie algebra morphisms into
associative algebras lift to associative algebra morphisms from the universal enveloping algebra. -/
def lift : (L →ₗ⁅R⁆ A) ≃ (UniversalEnvelopingAlgebra R L →ₐ[R] A)
    where
  toFun f :=
    RingQuot.liftAlgHom R
      ⟨TensorAlgebra.lift R (f : L →ₗ[R] A), by
        intro a b h; induction' h with x y
        simp only [LieRing.of_associative_ring_bracket, map_add, TensorAlgebra.lift_ι_apply,
          LieHom.coe_toLinearMap, LieHom.map_lie, map_mul, sub_add_cancel]⟩
  invFun F := (F : UniversalEnvelopingAlgebra R L →ₗ⁅R⁆ A).comp (ι R)
  left_inv f := by
    ext
    simp only [ι, mk_alg_hom, TensorAlgebra.lift_ι_apply, LieHom.coe_toLinearMap,
      LinearMap.toFun_eq_coe, LinearMap.coe_comp, LieHom.coe_comp, AlgHom.coe_to_lieHom,
      LieHom.coe_mk, Function.comp_apply, AlgHom.toLinearMap_apply,
      RingQuot.liftAlgHom_mkAlgHom_apply]
  right_inv F := by
    ext
    simp only [ι, mk_alg_hom, TensorAlgebra.lift_ι_apply, LieHom.coe_toLinearMap,
      LinearMap.toFun_eq_coe, LinearMap.coe_comp, LieHom.coe_linearMap_comp,
      AlgHom.comp_toLinearMap, Function.comp_apply, AlgHom.toLinearMap_apply,
      RingQuot.liftAlgHom_mkAlgHom_apply, AlgHom.coe_to_lieHom, LieHom.coe_mk]
#align universal_enveloping_algebra.lift UniversalEnvelopingAlgebra.lift

@[simp]
theorem lift_symm_apply (F : UniversalEnvelopingAlgebra R L →ₐ[R] A) :
    (lift R).symm F = (F : UniversalEnvelopingAlgebra R L →ₗ⁅R⁆ A).comp (ι R) :=
  rfl
#align universal_enveloping_algebra.lift_symm_apply UniversalEnvelopingAlgebra.lift_symm_apply

@[simp]
theorem ι_comp_lift : lift R f ∘ ι R = f :=
  funext <| LieHom.ext_iff.mp <| (lift R).symm_apply_apply f
#align universal_enveloping_algebra.ι_comp_lift UniversalEnvelopingAlgebra.ι_comp_lift

@[simp]
theorem lift_ι_apply (x : L) : lift R f (ι R x) = f x := by
  rw [← Function.comp_apply (lift R f) (ι R) x, ι_comp_lift]
#align universal_enveloping_algebra.lift_ι_apply UniversalEnvelopingAlgebra.lift_ι_apply

theorem lift_unique (g : UniversalEnvelopingAlgebra R L →ₐ[R] A) : g ∘ ι R = f ↔ g = lift R f :=
  by
  refine' Iff.trans _ (lift R).symm_apply_eq
  constructor <;>
    · intro h
      ext
      simp [← h]
#align universal_enveloping_algebra.lift_unique UniversalEnvelopingAlgebra.lift_unique

/-- See note [partially-applied ext lemmas]. -/
@[ext]
theorem hom_ext {g₁ g₂ : UniversalEnvelopingAlgebra R L →ₐ[R] A}
    (h :
      (g₁ : UniversalEnvelopingAlgebra R L →ₗ⁅R⁆ A).comp (ι R) =
        (g₂ : UniversalEnvelopingAlgebra R L →ₗ⁅R⁆ A).comp (ι R)) :
    g₁ = g₂ :=
  have h' : (lift R).symm g₁ = (lift R).symm g₂ := by ext; simp [h]
  (lift R).symm.Injective h'
#align universal_enveloping_algebra.hom_ext UniversalEnvelopingAlgebra.hom_ext

end UniversalEnvelopingAlgebra


import catalan

def balance (l : list (fin 2)) : ℤ := (l.count 1 : ℤ) - (l.count 0)
@[simp] lemma balance_def {l} : balance l = (l.count 1 : ℤ) - (l.count 0) := rfl

@[simp] lemma balance_nil : balance [] = 0 :=
  by rw [balance, list.count_nil, list.count_nil, sub_self]

structure dyck_word :=
  (chars : list (fin 2))
  (total_balance : balance chars = 0)
  (suffix_balance : ∀ t, t <:+ chars → balance t ≥ 0)

lemma list.length_eq_count0_add_count1 (l : list (fin 2)) : l.length = l.count 0 + l.count 1 :=
begin
  induction l with head tail ih, {
    simp only [list.count_nil, list.length],
  }, {
    fin_cases head,
    all_goals {simp [ih, nat.succ_eq_add_one], abel, },
  }
end

namespace dyck_word

lemma even_length (d : dyck_word) : even d.chars.length :=
begin
  use [d.chars.count 0],
  have h₁ := d.total_balance,
  rw [balance] at h₁,
  rw [list.length_eq_count0_add_count1],
  linarith,
end

lemma list.is_suffix_of_append {α} {l a b : list α} (h : l <:+ (a ++ b)) : (∃ k, k <:+ a ∧ k ++ b = l) ∨ (l <:+ b) :=
begin
  simp [←list.mem_tails] at h,
  simp_rw [list.mem_tails] at h,
  cases h, {left, exact h},
  right,
  replace h := list.tail_subset _ h,
  rwa list.mem_tails at h,
end

def append (a b : dyck_word) : dyck_word := {
  chars := a.chars ++ b.chars,
  total_balance := by {
    have h₁ := a.total_balance,
    have h₂ := b.total_balance,
    simp [balance, list.count_append] at *,
    linarith,
  },
  suffix_balance := by {
    rintro t ht,
    rcases list.is_suffix_of_append ht with ⟨ta, hta, rfl⟩ | ht₂, {
      have h₁ := a.suffix_balance _ hta,
      have h₂ := b.total_balance,
      simp only [int.coe_nat_add, list.count_append, balance_def] at *,
      linarith,
    }, {
      linarith [b.suffix_balance _ ht₂],
    }
  },
}

lemma list.suffix_singleton {α} {a : α} {l} (h : l <:+ [a]) : l = [] ∨ l = [a] :=
begin
  cases l, {left, refl},
  right,
  have h₁ := list.length_le_of_sublist (list.sublist_of_suffix h),
  simp [list.length_eq_zero] at h₁,
  subst h₁,
  apply list.eq_of_sublist_of_length_eq (list.sublist_of_suffix h),
  simp,
end

def wrap (a : dyck_word) : dyck_word := {
  chars := [0] ++ a.chars ++ [1],
  total_balance := by {
    simpa using a.total_balance,
  },
  suffix_balance := by {
    rintro t ht,
    simp at ht,
    rw list.suffix_cons_iff at ht,
    rcases ht with rfl | _, {
      apply ge_of_eq,
      simpa using a.total_balance,
    }, {
      rcases list.is_suffix_of_append ht with ⟨ta, hta, rfl⟩ | ht₂, {
        have h₁ := a.suffix_balance _ hta,
        simp at *,
        linarith,
      }, {
        rcases list.suffix_singleton ht₂ with ⟨rfl, rfl⟩,
        { simp },
        { simp [h] },
      }
    }
  },
}

-- TODO: unique construction through nil, append, wrap -> induction principle on dyck_word

def sized_dyck_word (n : ℕ) := {d : dyck_word // d.chars.length = n}

instance {n} : fintype (sized_dyck_word n) := sorry

theorem catalan_eq_dyck_words_card {n : ℕ} : catalan n = fintype.card (sized_dyck_word (2 * n)) := sorry

end dyck_word