/-
Copyright (c) 2021 Yakov Pechersky All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yakov Pechersky, Mario Carneiro
-/

import tactic.norm_num

/-!
# `norm_fin`

This file defines functions for dealing with `fin n` numbers as expressions.

## Main definitions

* `tactic.norm_fin.eval_ineq` is a `norm_num` plugin for normalizing equalities and inequalities of
  type `fin n`.

* `tactic.interactive.norm_fin` is a standalone tactic like `norm_num` for normalizing `fin n`
  expressions anywhere in the goal.

-/

namespace tactic
namespace norm_fin
open norm_num

/-- `normalize_fin n a b` means that `a : fin n` is equivalent to `b : ℕ` in the modular sense -
that is, `↑a ≡ b (mod n)`. This is used for translating the algebraic operations: addition,
multiplication, zero and one, which use modulo for reduction. -/
def normalize_fin (n : ℕ) (a : fin n) (b : ℕ) := a.1 = b % n

/-- `normalize_fin_lt n a b` means that `a : fin n` is equivalent to `b : ℕ` in the embedding
sense - that is, `↑a = b`. This is used for operations that treat `fin n` as the subset
`{0, ..., n-1}` of `ℕ`. For example, `fin.succ : fin n → fin (n+1)` is thought of as the successor
function, but it does not lift to a map `zmod n → zmod (n+1)`; this addition only makes sense if
the input is strictly less than `n`.

`normalize_fin_lt n a b` is equivalent to `normalize_fin n a b ∧ b < n`. -/
def normalize_fin_lt (n : ℕ) (a : fin n) (b : ℕ) := a.1 = b

theorem normalize_fin_lt.coe {n} {a : fin n} {b : ℕ} (h : normalize_fin_lt n a b) : ↑a = b := h

theorem normalize_fin_iff {n} [fact (0 < n)] {a b} :
  normalize_fin n a b ↔ a = fin.of_nat' b :=
iff.symm (fin.eq_iff_veq _ _)

theorem normalize_fin_lt.mk {n a b n'} (hn : n = n')
  (h : normalize_fin n a b) (h2 : b < n') : normalize_fin_lt n a b :=
h.trans $ nat.mod_eq_of_lt $ by rw hn; exact h2

theorem normalize_fin_lt.lt {n a b} (h : normalize_fin_lt n a b) : b < n :=
by rw ← h.coe; exact a.2

theorem normalize_fin_lt.of {n a b} (h : normalize_fin_lt n a b) : normalize_fin n a b :=
h.trans $ eq.symm $ nat.mod_eq_of_lt h.lt

theorem normalize_fin.zero (n) : normalize_fin (n+1) 0 0 := by { rw normalize_fin, norm_num }
theorem normalize_fin_lt.zero (n) : normalize_fin_lt (n+1) 0 0 := refl _
theorem normalize_fin.one (n) : normalize_fin (n+1) 1 1 := refl _
theorem normalize_fin.add {n} {a b : fin n} {a' b' c' : ℕ}
  (ha : normalize_fin n a a') (hb : normalize_fin n b b')
  (h : a' + b' = c') : normalize_fin n (a + b) c' :=
by simp only [normalize_fin, ← h] at *; rw [nat.add_mod, ← ha, ← hb, fin.add_def]
theorem normalize_fin.mul {n} {a b : fin n} {a' b' c' : ℕ}
  (ha : normalize_fin n a a') (hb : normalize_fin n b b')
  (h : a' * b' = c') : normalize_fin n (a * b) c' :=
by simp only [normalize_fin, ← h] at *; rw [nat.mul_mod, ← ha, ← hb, fin.mul_def]
theorem normalize_fin.bit0 {n} {a : fin n} {a' : ℕ}
  (h : normalize_fin n a a') : normalize_fin n (bit0 a) (bit0 a') := h.add h rfl
theorem normalize_fin.bit1 {n} {a : fin (n+1)} {a' : ℕ}
  (h : normalize_fin (n+1) a a') : normalize_fin (n+1) (bit1 a) (bit1 a') :=
h.bit0.add (normalize_fin.one _) rfl

theorem normalize_fin_lt.succ {n} {a : fin n} {a' b : ℕ}
  (h : normalize_fin_lt n a a') (e : a' + 1 = b) : normalize_fin_lt n.succ (fin.succ a) b :=
by simpa [normalize_fin_lt, ← e] using h

theorem normalize_fin_lt.cast_lt {n m} {a : fin m} {ha} {a' : ℕ}
  (h : normalize_fin_lt m a a') : normalize_fin_lt n (fin.cast_lt a ha) a' :=
by simpa [normalize_fin_lt] using h

theorem normalize_fin_lt.cast_le {n m} {nm} {a : fin m} {a' : ℕ}
  (h : normalize_fin_lt m a a') : normalize_fin_lt n (fin.cast_le nm a) a' :=
by simpa [normalize_fin_lt] using h

theorem normalize_fin_lt.cast {n m} {nm} {a : fin m} {a' : ℕ}
  (h : normalize_fin_lt m a a') : normalize_fin_lt n (fin.cast nm a) a' :=
by simpa [normalize_fin_lt] using h

theorem normalize_fin.cast {n m} {nm} {a : fin m} {a' : ℕ}
  (h : normalize_fin m a a') : normalize_fin n (fin.cast nm a) a' :=
by convert ← normalize_fin_lt.cast h

theorem normalize_fin_lt.cast_add {n m} {a : fin n} {a' : ℕ}
  (h : normalize_fin_lt n a a') : normalize_fin_lt (n + m) (fin.cast_add m a) a' :=
by simpa [normalize_fin_lt] using h

theorem normalize_fin_lt.cast_succ {n} {a : fin n} {a' : ℕ}
  (h : normalize_fin_lt n a a') : normalize_fin_lt (n+1) (fin.cast_succ a) a' :=
normalize_fin_lt.cast_add h

theorem normalize_fin_lt.add_nat {n m m'} (hm : m = m') {a : fin n} {a' b : ℕ}
  (h : normalize_fin_lt n a a') (e : a' + m' = b) :
  normalize_fin_lt (n+m) (@fin.add_nat n m a) b :=
by simpa [normalize_fin_lt, ← e, ← hm] using h

theorem normalize_fin_lt.nat_add {n m n'} (hn : n = n') {a : fin m} {a' b : ℕ}
  (h : normalize_fin_lt m a a') (e : n' + a' = b) :
  normalize_fin_lt (n+m) (@fin.nat_add n m a) b :=
by simpa [normalize_fin_lt, ← e, ← hn] using h

theorem normalize_fin.reduce {n} {a : fin n} {n' a' b k nk : ℕ}
  (hn : n = n') (h : normalize_fin n a a') (e1 : n' * k = nk) (e2 : nk + b = a') :
  normalize_fin n a b :=
by rwa [← e2, ← e1, ← hn, normalize_fin, add_comm, nat.add_mul_mod_self_left] at h

theorem normalize_fin_lt.reduce {n} {a : fin n} {n' a' b k nk : ℕ}
  (hn : n = n') (h : normalize_fin n a a') (e1 : n' * k = nk) (e2 : nk + b = a') (hl : b < n') :
  normalize_fin_lt n a b :=
normalize_fin_lt.mk hn (h.reduce hn e1 e2) hl

/-- The monad for the `norm_fin` internal tactics. The state consists of an instance cache for `ℕ`,
and a tuple `(nn, n', p)` where `p` is a proof of `n = n'` and `nn` is `n` evaluated to a natural
number. (`n` itself is implicit.)  It is in an `option` because it is lazily initialized - for many
`n` we will never need this information, and indeed eagerly computing it would make some reductions
fail spuriously if `n` is not a numeral. -/
@[derive [monad, alternative]]
meta def eval_fin_m (α : Type) : Type :=
state_t (instance_cache × option (ℕ × expr × expr)) tactic α

/-- Lifts a tactic into the `eval_fin_m` monad. -/
@[inline] meta def eval_fin_m.lift {α} (m : tactic α) : eval_fin_m α :=
⟨λ ⟨ic, r⟩, do a ← m, pure (a, ic, r)⟩

meta instance {α} : has_coe (tactic α) (eval_fin_m α) := ⟨eval_fin_m.lift⟩

/-- Lifts an `instance_cache` tactic into the `eval_fin_m` monad. -/
@[inline] meta def eval_fin_m.lift_ic {α}
  (m : instance_cache → tactic (instance_cache × α)) : eval_fin_m α :=
⟨λ ⟨ic, r⟩, do (ic, a) ← m ic, pure (a, ic, r)⟩

/-- Evaluates a monadic action with a fresh `n` cache, and restore the old cache on completion of
the action. This is used when evaluating a tactic in the context of a different `n` than the parent
context. For example if we are evaluating `fin.succ a`, then `a : fin n` and
`fin.succ a : fin (n+1)`, so the parent cache will be about `n+1` and we need a separate cache for
`n`. -/
@[inline] meta def eval_fin_m.reset {α} (m : eval_fin_m α) : eval_fin_m α :=
⟨λ ⟨ic, r⟩, do (a, ic, _) ← m.run ⟨ic, none⟩, pure (a, ic, r)⟩

/-- Given `n`, returns a tuple `(nn, n', p)` where `p` is a proof of `n = n'` and `nn` is `n`
evaluated to a natural number. The result of the evaluation is cached for future references.
Future calls to this function must use the same value of `n`, unless it is in a sub-context
created by `eval_fin_m.reset`. -/
meta def eval_fin_m.eval_n (n : expr) : eval_fin_m (ℕ × expr × expr) :=
⟨λ ⟨ic, r⟩, match r with
  | none := do
    (n', p) ← or_refl_conv norm_num.derive n,
    nn ← n'.to_nat,
    let np := (nn, n', p),
    pure (np, ic, some np)
  | some np := pure (np, ic, some np)
  end⟩

/-- Run an `eval_fin_m` action with a new cache and discard the cache after evaluation. -/
@[inline] meta def eval_fin_m.run {α} (m : eval_fin_m α) : tactic α :=
do ic ← mk_instance_cache `(ℕ), (a, _) ← state_t.run m (ic, none), pure a

/-- The expression constructors recognized by the `eval_fin` evaluator. This is used instead of a
direct expr pattern match because expr pattern matches generate very large terms under the
hood so going via an intermediate inductive type like this is more efficient. -/
meta inductive match_fin_result
| zero (n : expr)            -- `(0 : fin (n+1))`
| one (n : expr)             -- `(1 : fin (n+1))`
| add (n a b : expr)         -- `(a + b : fin n)`
| mul (n a b : expr)         -- `(a * b : fin n)`
| bit0 (n a : expr)          -- `(bit0 a : fin n)`
| bit1 (n a : expr)          -- `(bit1 a : fin (n+1))`
| succ (n a : expr)          -- `(fin.succ a : fin n.succ)`
| cast_lt (n m i h : expr)   -- `(fin.cast_lt (i : fin m) (h : i.val < n) : fin n)`
| cast_le (n m h a : expr)   -- `(fin.cast_le (h : n ≤ m) (a : fin n) : fin m)`
| cast (n m h a : expr)      -- `(fin.cast_le (h : n = m) (a : fin n) : fin m)`
| cast_add (n m a : expr)    -- `(fin.cast_add m (a : fin n) : fin (n + m))`
| cast_succ (n a : expr)     -- `(fin.cast_succ (a : fin n) : fin (n + 1))`
| add_nat (n m a : expr)     -- `(fin.add_nat m (a : fin n) : fin (n + m))`
| nat_add (n m a : expr)     -- `(fin.nat_add n (a : fin m) : fin (n + m))`

section
open match_fin_result
/-- Match a fin expression of the form `(coe_fn f a)` where `f` is some fin function. Several fin
functions are written this way: for example `cast_le : n ≤ m → fin n ↪o fin m` is not actually a
function but rather an order embedding with a coercion to a function. -/
meta def match_fin_coe_fn (a : expr) : expr → option match_fin_result
| `(@fin.cast_le %%n %%m %%h) := some (cast_le n m h a)
| `(@fin.cast %%m %%n %%h) := some (cast n m h a)
| `(@fin.cast_add %%n %%m) := some (cast_add n m a)
| `(@fin.cast_succ %%n) := some (cast_succ n a)
| `(@fin.add_nat %%n %%m) := some (add_nat n m a)
| `(@fin.nat_add %%n %%m) := some (nat_add n m a)
| _ := none

/-- Match a fin expression to a `match_fin_result`, for easier pattern matching in the
evaluator. -/
meta def match_fin : expr → option match_fin_result
| `(@has_zero.zero ._ (@fin.has_zero %%n)) := some (zero n)
| `(@has_one.one ._ (@fin.has_one %%n)) := some (one n)
| `(@has_add.add (fin %%n) ._ %%a %%b) := some (add n a b)
| `(@has_mul.mul (fin %%n) ._ %%a %%b) := some (mul n a b)
| `(@_root_.bit0 (fin %%n) ._ %%a) := some (bit0 n a)
| `(@_root_.bit1 ._ (@fin.has_one %%n) ._ %%a) := some (bit1 n a)
| `(@fin.succ %%n %%a) := some (succ n a)
| `(@fin.cast_lt %%n %%m %%a %%h) := some (cast_lt n m a h)
| (expr.app `(@coe_fn ._ ._ %%f) a) := match_fin_coe_fn a f
| _ := none
end

/-- `reduce_fin lt n a (a', pa)` expects that `pa : normalize_fin n a a'` where `a'`
is a natural numeral, and produces `(b, pb)` where `pb : normalize_fin n a b` if `lt` is false, or
`pb : normalize_fin_lt n a b` if `lt` is true. In either case, `b` will be chosen to be less than
`n`, but if `lt` is true then we also prove it. This requires that `n` can be evaluated to a
numeral. -/
meta def reduce_fin' : bool → expr → expr → expr × expr → eval_fin_m (expr × expr)
| lt n a (a', pa) := do
  (nn, n', pn) ← eval_fin_m.eval_n n,
  na ← expr.to_nat a',
  if na < nn then
    if lt then do
      p ← eval_fin_m.lift_ic (λ ic, prove_lt_nat ic a' n'),
      pure (a', `(@normalize_fin_lt.mk).mk_app [n, a, a', n', pn, pa, p])
    else pure (a', pa)
  else
    let nb := na % nn, nk := (na - nb) / nn in
    eval_fin_m.lift_ic $ λ ic, do
      (ic, k) ← ic.of_nat nk,
      (ic, b) ← ic.of_nat nb,
      (ic, nk, pe1) ← prove_mul_nat ic n' k,
      (ic, pe2) ← prove_add_nat ic nk b a',
      if lt then do
        (ic, p) ← prove_lt_nat ic b n',
        pure (ic, b,
          `(@normalize_fin_lt.reduce).mk_app [n, a, n', a', b, k, nk, pn, pa, pe1, pe2, p])
      else pure (ic, b,
          `(@normalize_fin.reduce).mk_app [n, a, n', a', b, k, nk, pn, pa, pe1, pe2])

/-- `eval_fin_lt' eval_fin n a` expects that `a : fin n`, and produces `(b, p)` where
`p : normalize_fin_lt n a b`. (It is mutually recursive with `eval_fin` which is why it takes the
function as an argument.) -/
meta def eval_fin_lt' (eval_fin : expr → eval_fin_m (expr × expr)) :
  expr → expr → eval_fin_m (expr × expr)
| n a := do
  e ← match_fin a,
  match e with
  | match_fin_result.succ n a := do
    (a', pa) ← (eval_fin_lt' n a).reset,
    (b, pb) ← eval_fin_m.lift_ic (λ ic, prove_succ' ic a'),
    pure (b, `(@normalize_fin_lt.succ).mk_app [n, a, a', b, pa, pb])
  | match_fin_result.cast_lt _ m a h := do
    (a', pa) ← (eval_fin_lt' m a).reset,
    pure (a', `(@normalize_fin_lt.cast_lt).mk_app [n, m, a, h, a', pa])
  | match_fin_result.cast_le _ m nm a := do
    (a', pa) ← (eval_fin_lt' m a).reset,
    pure (a', `(@normalize_fin_lt.cast_le).mk_app [n, m, nm, a, a', pa])
  | match_fin_result.cast m _ nm a := do
    (a', pa) ← (eval_fin_lt' m a).reset,
    pure (a', `(@normalize_fin_lt.cast).mk_app [n, m, nm, a, a', pa])
  | match_fin_result.cast_add n m a := do
    (a', pa) ← (eval_fin_lt' m a).reset,
    pure (a', `(@normalize_fin_lt.cast_add).mk_app [n, m, a, a', pa])
  | match_fin_result.cast_succ n a := do
    (a', pa) ← (eval_fin_lt' n a).reset,
    pure (a', `(@normalize_fin_lt.cast_succ).mk_app [n, a, a', pa])
  | match_fin_result.add_nat n m a := do
    (a', pa) ← (eval_fin_lt' n a).reset,
    (m', pm) ← or_refl_conv norm_num.derive m,
    (b, pb) ← eval_fin_m.lift_ic (λ ic, prove_add_nat' ic a' m'),
    pure (b, `(@normalize_fin_lt.add_nat).mk_app [n, m, m', pm, a, a', b, pa, pb])
  | match_fin_result.nat_add n m a := do
    (a', pa) ← (eval_fin_lt' m a).reset,
    (n', pn) ← or_refl_conv norm_num.derive n,
    (b, pb) ← eval_fin_m.lift_ic (λ ic, prove_add_nat' ic n' a'),
    pure (b, `(@normalize_fin_lt.nat_add).mk_app [n, m, n', pn, a, a', b, pa, pb])
  | _ := do
    (_, n', pn) ← eval_fin_m.eval_n n,
    (a', pa) ← eval_fin a >>= reduce_fin' tt n a,
    p ← eval_fin_m.lift_ic (λ ic, prove_lt_nat ic a' n'),
    pure (a', `(@normalize_fin_lt.mk).mk_app [n, a, a', n', pn, pa, p])
  end

/-- Get `n` such that `a : fin n`. -/
meta def get_fin_type (a : expr) : tactic expr := do `(fin %%n) ← infer_type a, pure n

/-- Given `a : fin n`, `eval_fin a` returns `(b, p)` where `p : normalize_fin n a b`. This function
does no reduction of the numeral `b`; for example `eval_fin (5 + 5 : fin 6)` returns `10`. It works
even if `n` is a variable, for example `eval_fin (5 + 5 : fin (n+1))` also returns `10`. -/
meta def eval_fin : expr → eval_fin_m (expr × expr)
| a := do
  m ← match_fin a,
  match m with
  | match_fin_result.zero n := pure (`(0 : ℕ), `(normalize_fin.zero).mk_app [n])
  | match_fin_result.one n := pure (`(1 : ℕ), `(normalize_fin.one).mk_app [n])
  | match_fin_result.add n a b := do
    (a', pa) ← eval_fin a,
    (b', pb) ← eval_fin b,
    (c, pc) ← eval_fin_m.lift_ic (λ ic, prove_add_nat' ic a' b'),
    pure (c, `(@normalize_fin.add).mk_app [n, a, b, a', b', c, pa, pb, pc])
  | match_fin_result.mul n a b := do
    (a', pa) ← eval_fin a,
    (b', pb) ← eval_fin b,
    (c, pc) ← eval_fin_m.lift_ic (λ ic, prove_mul_nat ic a' b'),
    pure (c, `(@normalize_fin.mul).mk_app [n, a, b, a', b', c, pa, pb, pc])
  | match_fin_result.bit0 n a := do
    (a', pa) ← eval_fin a,
    pure (`(@bit0 ℕ _).mk_app [a'], `(@normalize_fin.bit0).mk_app [n, a, a', pa])
  | match_fin_result.bit1 n a := do
    (a', pa) ← eval_fin a,
    pure (`(@bit1 ℕ _ _).mk_app [a'], `(@normalize_fin.bit1).mk_app [n, a, a', pa])
  | match_fin_result.cast m n nm a := do
    (a', pa) ← (eval_fin a).reset,
    pure (a', `(@normalize_fin.cast).mk_app [n, m, nm, a, a', pa])
  | _ := do
    n ← get_fin_type a,
    (a', pa) ← eval_fin_lt' eval_fin n a,
    pure (a', `(@normalize_fin_lt.of).mk_app [n, a, a', pa])
  end

/-- `eval_fin_lt n a` expects that `a : fin n`, and produces `(b, p)` where
`p : normalize_fin_lt n a b`. -/
meta def eval_fin_lt : expr → expr → eval_fin_m (expr × expr) := eval_fin_lt' eval_fin

/-- Given `a : fin n`, `eval_fin ff n a` returns `(b, p)` where `p : normalize_fin n a b`, and
`eval_fin tt n a` returns `p : normalize_fin_lt n a b`. Unlike `eval_fin`, this also does reduction
of the numeral `b`; for example `reduce_fin ff 6 (5 + 5 : fin 6)` returns `4`. As a result, it
fails if `n` is a variable, for example `reduce_fin ff (n+1) (5 + 5 : fin (n+1))` fails. -/
meta def reduce_fin (lt : bool) (n a : expr) : eval_fin_m (expr × expr) :=
eval_fin a >>= reduce_fin' lt n a

/-- If `a b : fin n` and `a'` and `b'` are as returned by `eval_fin`,
then `prove_lt_fin' n a b a' b'` proves `a < b`. -/
meta def prove_lt_fin' : expr → expr → expr → expr × expr → expr × expr → eval_fin_m expr
| n a b a' b' := do
  (a', pa) ← reduce_fin' ff n a a',
  (b', pb) ← reduce_fin' tt n b b',
  p ← eval_fin_m.lift_ic (λ ic, prove_lt_nat ic a' b'),
  pure (`(@normalize_fin.lt).mk_app [n, a, b, a', b', pa, pb, p])

/-- If `a b : fin n` and `a'` and `b'` are as returned by `eval_fin`,
then `prove_le_fin' n a b a' b'` proves `a ≤ b`. -/
meta def prove_le_fin' : expr → expr → expr → expr × expr → expr × expr → eval_fin_m expr
| n a b a' b' := do
  (a', pa) ← reduce_fin' ff n a a',
  (b', pb) ← reduce_fin' tt n b b',
  p ← eval_fin_m.lift_ic (λ ic, prove_le_nat ic a' b'),
  pure (`(@normalize_fin.le).mk_app [n, a, b, a', b', pa, pb, p])

/-- If `a b : fin n` and `a'` and `b'` are as returned by `eval_fin`,
then `prove_eq_fin' n a b a' b'` proves `a = b`. -/
meta def prove_eq_fin' : expr → expr → expr → expr × expr → expr × expr → eval_fin_m expr
| n a b (a', pa) (b', pb) :=
  if a' =ₐ b' then do
    pure (`(@normalize_fin.eq).mk_app [n, a, b, a', pa, pb])
  else do
    (a', pa) ← reduce_fin' ff n a (a', pa),
    (b', pb) ← reduce_fin' ff n b (b', pb),
    guard (a' =ₐ b'),
    pure (`(@normalize_fin.eq).mk_app [n, a, b, a', pa, pb])

/-- Given a function with the type of `prove_eq_fin'`, evaluates it with the given `a` and `b`. -/
meta def eval_prove_fin
  (f : expr → expr → expr → expr × expr → expr × expr → eval_fin_m expr)
  (a b : expr) : tactic expr :=
do n ← get_fin_type a, eval_fin_m.run $ eval_fin a >>= λ a', eval_fin b >>= f n a b a'

/-- If `a b : fin n`, then `prove_eq_fin a b` proves `a = b`. -/
meta def prove_eq_fin : expr → expr → tactic expr := eval_prove_fin prove_eq_fin'
/-- If `a b : fin n`, then `prove_lt_fin a b` proves `a < b`. -/
meta def prove_lt_fin : expr → expr → tactic expr := eval_prove_fin prove_lt_fin'
/-- If `a b : fin n`, then `prove_le_fin a b` proves `a ≤ b`. -/
meta def prove_le_fin : expr → expr → tactic expr := eval_prove_fin prove_le_fin'

section
open norm_num.match_numeral_result

/-- Given expressions `n` and `m` such that `n` is definitionally equal to `m.succ`, and
a natural numeral `a`, proves `(b, ⊢ normalize_fin n b a)`, where `n` and `m` are both used
in the construction of the numeral `b : fin n`. -/
meta def mk_fin_numeral (n m : expr) : expr → option (expr × expr)
| a := match match_numeral a with
  | zero := some (
    expr.app `(@has_zero.zero (fin %%n)) `(@fin.has_zero %%m),
    expr.app `(normalize_fin.zero) m)
  | one := some (
    expr.app `(@has_one.one (fin %%n)) `(@fin.has_one %%m),
    expr.app `(normalize_fin.one) m)
  | bit0 a := do
    (a', p) ← mk_fin_numeral a,
    some (`(bit0 %%a' : fin %%n), `(@normalize_fin.bit0).mk_app [n, a', a, p])
  | bit1 a := do
    (a', p) ← mk_fin_numeral a,
    some (
      `(@_root_.bit1 (fin %%n)).mk_app [`(@fin.has_one %%m), `(@fin.has_add %%n), a'],
      `(@normalize_fin.bit1).mk_app [m, a', a, p])
  | _ := none
  end
end

/-- The common prep work for the cases in `eval_ineq`. Given inputs `a b : fin n`, it calls
`f n a' b' na nb` where `a'` and `b'` are the result of `eval_fin` and `na` and `nb` are
`a' % n` and `b' % n` as natural numbers. -/
meta def eval_rel {α} (a b : expr)
  (f : expr → expr × expr → expr × expr → ℕ → ℕ → eval_fin_m α) : tactic α :=
do n ← get_fin_type a,
  eval_fin_m.run $ do
    (nn, n', pn) ← eval_fin_m.eval_n n,
    (a', pa) ← eval_fin a,
    (b', pb) ← eval_fin b,
    na ← eval_fin_m.lift a'.to_nat,
    nb ← eval_fin_m.lift b'.to_nat,
    f n (a', pa) (b', pb) (na % nn) (nb % nn)

/-- Given `a b : fin n`, proves either `(n, tt, p)` where `p : a < b` or
`(n, ff, p)` where `p : b ≤ a`. -/
meta def prove_lt_ge_fin : expr → expr → tactic (expr × bool × expr)
| a b := eval_rel a b $ λ n a' b' na nb,
  if na < nb then prod.mk n <$> prod.mk tt <$> prove_lt_fin' n a b a' b'
  else prod.mk n <$> prod.mk ff <$> prove_le_fin' n b a b' a'

/-- Given `a b : fin n`, proves either `(n, tt, p)` where `p : a = b` or
`(n, ff, p)` where `p : a ≠ b`. -/
meta def prove_eq_ne_fin : expr → expr → tactic (expr × bool × expr)
| a b := eval_rel a b $ λ n a' b' na nb,
  if na = nb then prod.mk n <$> prod.mk tt <$> prove_eq_fin' n a b a' b'
  else if na < nb then do
    p ← prove_lt_fin' n a b a' b',
    pure (n, ff, `(@ne_of_lt (fin %%n) _).mk_app [a, b, p])
  else do
    p ← prove_lt_fin' n b a b' a',
    pure (n, ff, `(@ne_of_gt (fin %%n) _).mk_app [a, b, p])

/-- A `norm_num` extension that evaluates equalities and inequalities on the type `fin n`.

```
example : (5 : fin 7) = fin.succ (fin.succ 3) := by norm_num
```
-/
@[norm_num] meta def eval_ineq : expr → tactic (expr × expr)
| `(%%a < %%b) := do
  (n, lt, p) ← prove_lt_ge_fin a b,
  if lt then true_intro p else false_intro (`(@not_lt_of_ge (fin %%n) _).mk_app [a, b, p])
| `(%%a ≤ %%b) := do
  (n, lt, p) ← prove_lt_ge_fin b a,
  if lt then false_intro (`(@not_le_of_gt (fin %%n) _).mk_app [a, b, p]) else true_intro p
| `(%%a = %%b) := do
  (n, eq, p) ← prove_eq_ne_fin a b,
  if eq then true_intro p else false_intro p
| `(%%a > %%b) := mk_app ``has_lt.lt [b, a] >>= eval_ineq
| `(%%a ≥ %%b) := mk_app ``has_le.le [b, a] >>= eval_ineq
| `(%%a ≠ %%b) := do
  (n, eq, p) ← prove_eq_ne_fin a b,
  if eq then false_intro `(not_not_intro (%%p : (%%a : fin %%n) = %%b)) else true_intro p
| _ := failed

/-- Evaluates `e : fin n` to a natural number less than `n`. Returns `none` if it is not a natural
number or greater than `n`. -/
meta def as_numeral (n e : expr) : eval_fin_m (option ℕ) :=
match e.to_nat with
| none := pure none
| some ne := do
  (nn, _) ← eval_fin_m.eval_n n,
  pure $ if ne < nn then some ne else none
end

/-- Given `a : fin n`, returns `(b, ⊢ a = b)` where `b` is a normalized fin numeral. Fails if `a`
is already normalized. -/
meta def eval_fin_num (a : expr) : tactic (expr × expr) :=
do n ← get_fin_type a,
  eval_fin_m.run $ do
    as_numeral n a >>= (λ o, guardb o.is_none),
    (a', pa) ← eval_fin a,
    (a', pa) ← reduce_fin' ff n a (a', pa) <|> pure (a', pa),
    (nm + 1, _) ← eval_fin_m.eval_n n | failure,
    m' ← eval_fin_m.lift_ic (λ ic, ic.of_nat nm),
    n' ← eval_fin_m.lift_ic (λ ic, ic.of_nat (nm+1)),
    (b, pb) ← mk_fin_numeral n' m' a',
    pure (b, `(@normalize_fin.eq).mk_app [n, a, b, a', pa, pb])

end norm_fin

namespace interactive
open interactive interactive.types

/-- Rewrites occurrences of fin expressions to normal form anywhere in the goal.
The `norm_num` extension will only rewrite fin expressions if they appear in equalities and
inequalities. For example if the goal is `P (2 + 2 : fin 3)` then `norm_num` will not do anything
but `norm_fin` will reduce the goal to `P 1`.

(The reason this is not part of `norm_num` is because evaluation of fin numerals uses a top down
evaluation strategy while `norm_num` works bottom up; also determining whether a normalization
will work is expensive, meaning that unrelated uses of `norm_num` would be slowed down with this
as a plugin.) -/
meta def norm_fin (hs : parse simp_arg_list) : tactic unit :=
try (simp_top_down tactic.norm_fin.eval_fin_num) >> try (norm_num hs (loc.ns [none]))

/--
Rewrites occurrences of fin expressions to normal form anywhere in the goal.
The `norm_num` extension will only rewrite fin expressions if they appear in equalities and
inequalities. For example if the goal is `P (2 + 2 : fin 3)` then `norm_num` will not do anything
but `norm_fin` will reduce the goal to `P 1`.

```lean
example : (5 : fin 7) = fin.succ (fin.succ 3) := by norm_num
example (P : fin 7 → Prop) (h : P 5) : P (fin.succ (fin.succ 3)) := by norm_fin; exact h
```
-/
add_tactic_doc
{ name        := "norm_fin",
  category    := doc_category.tactic,
  decl_names  := [`tactic.interactive.norm_fin],
  tags        := ["arithmetic", "decision procedure"] }

end interactive
end tactic


/-
Copyright (c) 2019 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl, Patrick Massot, Casper Putz, Anne Baanen, Antoine Labelle
-/
import linear_algebra.matrix.to_lin
import linear_algebra.matrix.trace
import linear_algebra.contraction
import linear_algebra.tensor_product_basis
import linear_algebra.free_module.strong_rank_condition
import linear_algebra.projection

/-!
# Trace of a linear map

This file defines the trace of a linear map.

See also `linear_algebra/matrix/trace.lean` for the trace of a matrix.

## Tags

linear_map, trace, diagonal

-/

noncomputable theory

universes u v w

namespace linear_map

open_locale big_operators
open_locale matrix
open finite_dimensional

open_locale tensor_product

section
variables (R : Type u) [comm_semiring R] {M : Type v} [add_comm_monoid M] [module R M]
variables {ι : Type w} [decidable_eq ι] [fintype ι]
variables {κ : Type*} [decidable_eq κ] [fintype κ]
variables (b : basis ι R M) (c : basis κ R M)

/-- The trace of an endomorphism given a basis. -/
def trace_aux :
  (M →ₗ[R] M) →ₗ[R] R :=
(matrix.trace_linear_map ι R R) ∘ₗ ↑(linear_map.to_matrix b b)

-- Can't be `simp` because it would cause a loop.
lemma trace_aux_def (b : basis ι R M) (f : M →ₗ[R] M) :
  trace_aux R b f = matrix.trace (linear_map.to_matrix b b f) :=
rfl

theorem trace_aux_eq : trace_aux R b = trace_aux R c :=
linear_map.ext $ λ f,
calc  matrix.trace (linear_map.to_matrix b b f)
    = matrix.trace (linear_map.to_matrix b b ((linear_map.id.comp f).comp linear_map.id)) :
  by rw [linear_map.id_comp, linear_map.comp_id]
... = matrix.trace (linear_map.to_matrix c b linear_map.id ⬝
        linear_map.to_matrix c c f ⬝
        linear_map.to_matrix b c linear_map.id) :
  by rw [linear_map.to_matrix_comp _ c, linear_map.to_matrix_comp _ c]
... = matrix.trace (linear_map.to_matrix c c f ⬝
        linear_map.to_matrix b c linear_map.id ⬝
        linear_map.to_matrix c b linear_map.id) :
  by rw [matrix.mul_assoc, matrix.trace_mul_comm]
... = matrix.trace (linear_map.to_matrix c c ((f.comp linear_map.id).comp linear_map.id)) :
  by rw [linear_map.to_matrix_comp _ b, linear_map.to_matrix_comp _ c]
... = matrix.trace (linear_map.to_matrix c c f) :
  by rw [linear_map.comp_id, linear_map.comp_id]

open_locale classical

variables (R) (M)

/-- Trace of an endomorphism independent of basis. -/
def trace : (M →ₗ[R] M) →ₗ[R] R :=
if H : ∃ (s : finset M), nonempty (basis s R M)
then trace_aux R H.some_spec.some
else 0

variables (R) {M}

/-- Auxiliary lemma for `trace_eq_matrix_trace`. -/
theorem trace_eq_matrix_trace_of_finset {s : finset M} (b : basis s R M)
  (f : M →ₗ[R] M) :
  trace R M f = matrix.trace (linear_map.to_matrix b b f) :=
have ∃ (s : finset M), nonempty (basis s R M),
from ⟨s, ⟨b⟩⟩,
by { rw [trace, dif_pos this, ← trace_aux_def], congr' 1, apply trace_aux_eq }

theorem trace_eq_matrix_trace (f : M →ₗ[R] M) :
  trace R M f = matrix.trace (linear_map.to_matrix b b f) :=
by rw [trace_eq_matrix_trace_of_finset R b.reindex_finset_range,
    ← trace_aux_def, ← trace_aux_def, trace_aux_eq R b]

theorem trace_mul_comm (f g : M →ₗ[R] M) :
  trace R M (f * g) = trace R M (g * f) :=
if H : ∃ (s : finset M), nonempty (basis s R M) then let ⟨s, ⟨b⟩⟩ := H in
by { simp_rw [trace_eq_matrix_trace R b, linear_map.to_matrix_mul], apply matrix.trace_mul_comm }
else by rw [trace, dif_neg H, linear_map.zero_apply, linear_map.zero_apply]

/-- The trace of an endomorphism is invariant under conjugation -/
@[simp]
theorem trace_conj (g : M →ₗ[R] M) (f : (M →ₗ[R] M)ˣ) :
  trace R M (↑f * g * ↑f⁻¹) = trace R M g :=
by { rw trace_mul_comm, simp }

end

section

variables {R : Type*} [comm_ring R] {M : Type*} [add_comm_group M] [module R M]
variables (N : Type*) [add_comm_group N] [module R N]
variables {ι : Type*} [fintype ι]

/-- The trace of a linear map correspond to the contraction pairing under the isomorphism
 `End(M) ≃ M* ⊗ M`-/

/-- The trace of a linear map correspond to the contraction pairing under the isomorphism
 `End(M) ≃ M* ⊗ M`-/
lemma trace_eq_contract_of_basis' [decidable_eq ι] (b : basis ι R M) :
  (linear_map.trace R M) =
  (contract_left R M) ∘ₗ (dual_tensor_hom_equiv_of_basis b).symm.to_linear_map :=
by simp [linear_equiv.eq_comp_to_linear_map_symm, trace_eq_contract_of_basis b]

variables (R M N)
variables [module.free R M] [module.finite R M] [module.free R N] [module.finite R N] [nontrivial R]

/-- When `M` is finite free, the trace of a linear map correspond to the contraction pairing under
the isomorphism `End(M) ≃ M* ⊗ M`-/
@[simp] theorem trace_eq_contract :
  (linear_map.trace R M) ∘ₗ (dual_tensor_hom R M M) = contract_left R M :=
trace_eq_contract_of_basis (module.free.choose_basis R M)

@[simp] theorem trace_eq_contract_apply (x : module.dual R M ⊗[R] M) :
  (linear_map.trace R M) ((dual_tensor_hom R M M) x) = contract_left R M x :=
by rw [←comp_apply, trace_eq_contract]

open_locale classical

/-- When `M` is finite free, the trace of a linear map correspond to the contraction pairing under
the isomorphism `End(M) ≃ M* ⊗ M`-/
theorem trace_eq_contract' :
  (linear_map.trace R M) =
  (contract_left R M) ∘ₗ (dual_tensor_hom_equiv R M M).symm.to_linear_map :=
trace_eq_contract_of_basis' (module.free.choose_basis R M)

/-- The trace of the identity endomorphism is the dimension of the free module -/
@[simp] theorem trace_one : trace R M 1 = (finrank R M : R) :=
begin
  have b := module.free.choose_basis R M,
  rw [trace_eq_matrix_trace R b, to_matrix_one, module.free.finrank_eq_card_choose_basis_index],
  simp,
end

/-- The trace of the identity endomorphism is the dimension of the free module -/
@[simp] theorem trace_id : trace R M id = (finrank R M : R) :=
by rw [←one_eq_id, trace_one]

@[simp] theorem trace_transpose : trace R (module.dual R M) ∘ₗ module.dual.transpose = trace R M :=
begin
  let e := dual_tensor_hom_equiv R M M,
  have h : function.surjective e.to_linear_map := e.surjective,
  refine (cancel_right h).1 _,
  ext f m, simp [e],
end

theorem trace_prod_map :
  trace R (M × N) ∘ₗ prod_map_linear R M N M N R =
  (coprod id id : R × R →ₗ[R] R) ∘ₗ prod_map (trace R M) (trace R N) :=
begin
  let e := ((dual_tensor_hom_equiv R M M).prod (dual_tensor_hom_equiv R N N)),
  have h : function.surjective e.to_linear_map := e.surjective,
  refine (cancel_right h).1 _,
  ext,
  { simp only [dual_tensor_hom_equiv, tensor_product.algebra_tensor_module.curry_apply,
  to_fun_eq_coe, tensor_product.curry_apply, coe_restrict_scalars_eq_coe, coe_comp,
  linear_equiv.coe_to_linear_map, coe_inl, function.comp_app, linear_equiv.prod_apply,
  dual_tensor_hom_equiv_of_basis_apply, map_zero, prod_map_apply, coprod_apply, id_coe, id.def,
  add_zero, prod_map_linear_apply, dual_tensor_hom_prod_map_zero, trace_eq_contract_apply,
  contract_left_apply, fst_apply] },
  { simp only [dual_tensor_hom_equiv, tensor_product.algebra_tensor_module.curry_apply,
  to_fun_eq_coe, tensor_product.curry_apply, coe_restrict_scalars_eq_coe, coe_comp,
  linear_equiv.coe_to_linear_map, coe_inr, function.comp_app, linear_equiv.prod_apply,
  dual_tensor_hom_equiv_of_basis_apply, map_zero, prod_map_apply, coprod_apply, id_coe, id.def,
  zero_add, prod_map_linear_apply, zero_prod_map_dual_tensor_hom, trace_eq_contract_apply,
  contract_left_apply, snd_apply], },
end

variables {R M N}

theorem trace_prod_map' (f : M →ₗ[R] M) (g : N →ₗ[R] N) :
  trace R (M × N) (prod_map f g) = trace R M f + trace R N g :=
begin
  have h := ext_iff.1 (trace_prod_map R M N) (f, g),
  simp only [coe_comp, function.comp_app, prod_map_apply, coprod_apply, id_coe, id.def,
  prod_map_linear_apply] at h, exact h,
end

variables (R M N)

open tensor_product function

theorem trace_tensor_product :
  compr₂ (map_bilinear R M N M N) (trace R (M ⊗ N)) =
  compl₁₂ (lsmul R R : R →ₗ[R] R →ₗ[R] R) (trace R M) (trace R N) :=
begin
  apply (compl₁₂_inj
    (show surjective (dual_tensor_hom R M M), from (dual_tensor_hom_equiv R M M).surjective)
    (show surjective (dual_tensor_hom R N N), from (dual_tensor_hom_equiv R N N).surjective)).1,
  ext f m g n,
  simp only [algebra_tensor_module.curry_apply, to_fun_eq_coe, tensor_product.curry_apply,
  coe_restrict_scalars_eq_coe, compl₁₂_apply, compr₂_apply, map_bilinear_apply,
  trace_eq_contract_apply, contract_left_apply, lsmul_apply, algebra.id.smul_eq_mul,
  map_dual_tensor_hom, dual_distrib_apply],
end

theorem trace_comp_comm :
  compr₂ (llcomp R M N M) (trace R M) = compr₂ (llcomp R N M N).flip (trace R N) :=
begin
  apply (compl₁₂_inj
    (show surjective (dual_tensor_hom R N M), from (dual_tensor_hom_equiv R N M).surjective)
    (show surjective (dual_tensor_hom R M N), from (dual_tensor_hom_equiv R M N).surjective)).1,
  ext g m f n,
  simp only [tensor_product.algebra_tensor_module.curry_apply, to_fun_eq_coe,
      linear_equiv.coe_to_linear_map, tensor_product.curry_apply, coe_restrict_scalars_eq_coe,
      compl₁₂_apply, compr₂_apply, flip_apply, llcomp_apply', comp_dual_tensor_hom, map_smul,
      trace_eq_contract_apply, contract_left_apply, smul_eq_mul, mul_comm],
end

variables {R M N}

@[simp]
theorem trace_transpose' (f : M →ₗ[R] M) : trace R _ (module.dual.transpose f) = trace R M f :=
by { rw [←comp_apply, trace_transpose] }

theorem trace_tensor_product' (f : M →ₗ[R] M) (g : N →ₗ[R] N) :
  trace R (M ⊗ N) (map f g) = trace R M f * trace R N g :=
begin
  have h := ext_iff.1 (ext_iff.1 (trace_tensor_product R M N) f) g,
  simp only [compr₂_apply, map_bilinear_apply, compl₁₂_apply, lsmul_apply,
    algebra.id.smul_eq_mul] at h, exact h,
end

theorem trace_comp_comm' (f : M →ₗ[R] N) (g : N →ₗ[R] M) :
  trace R M (g ∘ₗ f) = trace R N (f ∘ₗ g) :=
begin
  have h := ext_iff.1 (ext_iff.1 (trace_comp_comm R M N) g) f,
  simp only [llcomp_apply', compr₂_apply, flip_apply] at h,
  exact h,
end

@[simp] theorem trace_conj' (f : M →ₗ[R] M) (e : M ≃ₗ[R] N) : trace R N (e.conj f) = trace R M f :=
by rw [e.conj_apply, trace_comp_comm', ←comp_assoc, linear_equiv.comp_coe,
  linear_equiv.self_trans_symm, linear_equiv.refl_to_linear_map, id_comp]

theorem is_proj.trace {p : submodule R M} {f : M →ₗ[R] M} (h : is_proj p f)
  [module.free R p] [module.finite R p] [module.free R f.ker] [module.finite R f.ker] :
  trace R M f = (finrank R p : R) :=
by rw [h.eq_conj_prod_map, trace_conj', trace_prod_map', trace_id, map_zero, add_zero]

end

end linear_map


/-
Copyright (c) 2020 Fox Thomson. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Fox Thomson
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.fintype.basic
import Mathlib.computability.DFA
import Mathlib.PostPort

universes u v l

namespace Mathlib

/-!
# Nondeterministic Finite Automata
This file contains the definition of a Nondeterministic Finite Automaton (NFA), a state machine
which determines whether a string (implemented as a list over an arbitrary alphabet) is in a regular
set by evaluating the string over every possible path.
We show that DFA's are equivalent to NFA's however the construction from NFA to DFA uses an
exponential number of states.
Note that this definition allows for Automaton with infinite states, a `fintype` instance must be
supplied for true NFA's.
-/

/-- An NFA is a set of states (`σ`), a transition function from state to state labelled by the
  alphabet (`step`), a starting state (`start`) and a set of acceptance states (`accept`).
  Note the transition function sends a state to a `set` of states. These are the states that it
  may be sent to. -/
structure NFA (α : Type u) (σ : Type v)
where
  step : σ → α → set σ
  start : set σ
  accept : set σ

namespace NFA

protected instance inhabited {α : Type u} {σ : Type v} : Inhabited (NFA α σ) :=
  { default := mk (fun (_x : σ) (_x : α) => ∅) ∅ ∅ }

/-- `M.step_set S a` is the union of `M.step s a` for all `s ∈ S`. -/
def step_set {α : Type u} {σ : Type v} (M : NFA α σ) : set σ → α → set σ :=
  fun (Ss : set σ) (a : α) =>
    do
      let S ← Ss
      step M S a

theorem mem_step_set {α : Type u} {σ : Type v} (M : NFA α σ) (s : σ) (S : set σ) (a : α) : s ∈ step_set M S a ↔ ∃ (t : σ), ∃ (H : t ∈ S), s ∈ step M t a := sorry

/-- `M.eval_from S x` computes all possible paths though `M` with input `x` starting at an element
  of `S`. -/
def eval_from {α : Type u} {σ : Type v} (M : NFA α σ) (start : set σ) : List α → set σ :=
  list.foldl (step_set M) start

/-- `M.eval x` computes all possible paths though `M` with input `x` starting at an element of
  `M.start`. -/
def eval {α : Type u} {σ : Type v} (M : NFA α σ) : List α → set σ :=
  eval_from M (start M)

/-- `M.accepts` is the language of `x` such that there is an accept state in `M.eval x`. -/
def accepts {α : Type u} {σ : Type v} (M : NFA α σ) : language α :=
  fun (x : List α) => ∃ (S : σ), ∃ (H : S ∈ accept M), S ∈ eval M x

/-- `M.to_DFA` is an `DFA` constructed from a `NFA` `M` using the subset construction. The
  states is the type of `set`s of `M.state` and the step function is `M.step_set`. -/
def to_DFA {α : Type u} {σ : Type v} (M : NFA α σ) : DFA α (set σ) :=
  DFA.mk (step_set M) (start M) (set_of fun (S : set σ) => ∃ (s : σ), ∃ (H : s ∈ S), s ∈ accept M)

@[simp] theorem to_DFA_correct {α : Type u} {σ : Type v} (M : NFA α σ) : DFA.accepts (to_DFA M) = accepts M := sorry

end NFA

namespace DFA

/-- `M.to_NFA` is an `NFA` constructed from a `DFA` `M` by using the same start and accept
  states and a transition function which sends `s` with input `a` to the singleton `M.step s a`. -/
def to_NFA {α : Type u} {σ' : Type v} (M : DFA α σ') : NFA α σ' :=
  NFA.mk (fun (s : σ') (a : α) => singleton (step M s a)) (singleton (start M)) (accept M)

@[simp] theorem to_NFA_eval_from_match {α : Type u} {σ : Type v} (M : DFA α σ) (start : σ) (s : List α) : NFA.eval_from (to_NFA M) (singleton start) s = singleton (eval_from M start s) := sorry

@[simp] theorem to_NFA_correct {α : Type u} {σ : Type v} (M : DFA α σ) : NFA.accepts (to_NFA M) = accepts M := sorry


/-
Copyright (c) 2022 Yaël Dillies. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yaël Dillies

! This file was ported from Lean 3 source module order.heyting.basic
! leanprover-community/mathlib commit 4e42a9d0a79d151ee359c270e498b1a00cc6fa4e
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Order.PropInstances

/-!
# Heyting algebras

This file defines Heyting, co-Heyting and bi-Heyting algebras.

An Heyting algebra is a bounded distributive lattice with an implication operation `⇨` such that
`a ≤ b ⇨ c ↔ a ⊓ b ≤ c`. It also comes with a pseudo-complement `ᶜ`, such that `aᶜ = a ⇨ ⊥`.

Co-Heyting algebras are dual to Heyting algebras. They have a difference `\` and a negation `￢`
such that `a \ b ≤ c ↔ a ≤ b ⊔ c` and `￢a = ⊤ \ a`.

Bi-Heyting algebras are Heyting algebras that are also co-Heyting algebras.

From a logic standpoint, Heyting algebras precisely model intuitionistic logic, whereas boolean
algebras model classical logic.

Heyting algebras are the order theoretic equivalent of cartesian-closed categories.

## Main declarations

* `GeneralizedHeytingAlgebra`: Heyting algebra without a top element (nor negation).
* `GeneralizedCoheytingAlgebra`: Co-Heyting algebra without a bottom element (nor complement).
* `HeytingAlgebra`: Heyting algebra.
* `CoheytingAlgebra`: Co-Heyting algebra.
* `BiheytingAlgebra`: bi-Heyting algebra.

## Notation

* `⇨`: Heyting implication
* `\`: Difference
* `￢`: Heyting negation
* `ᶜ`: (Pseudo-)complement

## References

* [Francis Borceux, *Handbook of Categorical Algebra III*][borceux-vol3]

## Tags

Heyting, Brouwer, algebra, implication, negation, intuitionistic
-/

open Function OrderDual

universe u

variable {ι α β : Type _}

/-! ### Notation -/

/-- Syntax typeclass for Heyting implication `⇨`. -/
@[notation_class]
class HImp (α : Type _) where
  /-- Heyting implication `⇨` -/
  himp : α → α → α
#align has_himp HImp

/-- Syntax typeclass for Heyting negation `￢`.

The difference between `HasCompl` and `HNot` is that the former belongs to Heyting algebras,
while the latter belongs to co-Heyting algebras. They are both pseudo-complements, but `compl`
underestimates while `HNot` overestimates. In boolean algebras, they are equal.
See `hnot_eq_compl`.
-/
@[notation_class]
class HNot (α : Type _) where
  /-- Heyting negation `￢` -/
  hnot : α → α
#align has_hnot HNot

export HImp (himp)
export SDiff (sdiff)
export HNot (hnot)

/-- Heyting implication -/
infixr:60 " ⇨ " => himp

/-- Heyting negation -/
prefix:72 "￢" => hnot

section
variable (α β)

instance Prod.himp [HImp α] [HImp β] : HImp (α × β) :=
  ⟨fun a b => (a.1 ⇨ b.1, a.2 ⇨ b.2)⟩

instance Prod.hnot [HNot α] [HNot β] : HNot (α × β) :=
  ⟨fun a => (￢a.1, ￢a.2)⟩

instance Prod.sdiff [SDiff α] [SDiff β] : SDiff (α × β) :=
  ⟨fun a b => (a.1 \ b.1, a.2 \ b.2)⟩

instance Prod.hasCompl [HasCompl α] [HasCompl β] : HasCompl (α × β) :=
  ⟨fun a => (a.1ᶜ, a.2ᶜ)⟩

end

@[simp]
theorem fst_himp [HImp α] [HImp β] (a b : α × β) : (a ⇨ b).1 = a.1 ⇨ b.1 :=
  rfl
#align fst_himp fst_himp

@[simp]
theorem snd_himp [HImp α] [HImp β] (a b : α × β) : (a ⇨ b).2 = a.2 ⇨ b.2 :=
  rfl
#align snd_himp snd_himp

@[simp]
theorem fst_hnot [HNot α] [HNot β] (a : α × β) : (￢a).1 = ￢a.1 :=
  rfl
#align fst_hnot fst_hnot

@[simp]
theorem snd_hnot [HNot α] [HNot β] (a : α × β) : (￢a).2 = ￢a.2 :=
  rfl
#align snd_hnot snd_hnot

@[simp]
theorem fst_sdiff [SDiff α] [SDiff β] (a b : α × β) : (a \ b).1 = a.1 \ b.1 :=
  rfl
#align fst_sdiff fst_sdiff

@[simp]
theorem snd_sdiff [SDiff α] [SDiff β] (a b : α × β) : (a \ b).2 = a.2 \ b.2 :=
  rfl
#align snd_sdiff snd_sdiff

@[simp]
theorem fst_compl [HasCompl α] [HasCompl β] (a : α × β) : aᶜ.1 = a.1ᶜ :=
  rfl
#align fst_compl fst_compl

@[simp]
theorem snd_compl [HasCompl α] [HasCompl β] (a : α × β) : aᶜ.2 = a.2ᶜ :=
  rfl
#align snd_compl snd_compl

namespace Pi

variable {π : ι → Type _}

instance [∀ i, HImp (π i)] : HImp (∀ i, π i) :=
  ⟨fun a b i => a i ⇨ b i⟩

instance [∀ i, HNot (π i)] : HNot (∀ i, π i) :=
  ⟨fun a i => ￢a i⟩

theorem himp_def [∀ i, HImp (π i)] (a b : ∀ i, π i) : a ⇨ b = fun i => a i ⇨ b i :=
  rfl
#align pi.himp_def Pi.himp_def

theorem hnot_def [∀ i, HNot (π i)] (a : ∀ i, π i) : ￢a = fun i => ￢a i :=
  rfl
#align pi.hnot_def Pi.hnot_def

@[simp]
theorem himp_apply [∀ i, HImp (π i)] (a b : ∀ i, π i) (i : ι) : (a ⇨ b) i = a i ⇨ b i :=
  rfl
#align pi.himp_apply Pi.himp_apply

@[simp]
theorem hnot_apply [∀ i, HNot (π i)] (a : ∀ i, π i) (i : ι) : (￢a) i = ￢a i :=
  rfl
#align pi.hnot_apply Pi.hnot_apply

end Pi

/-- A generalized Heyting algebra is a lattice with an additional binary operation `⇨` called
Heyting implication such that `a ⇨` is right adjoint to `a ⊓`.

 This generalizes `HeytingAlgebra` by not requiring a bottom element. -/
class GeneralizedHeytingAlgebra (α : Type _) extends Lattice α, Top α, HImp α where
  /-- `⊤` is a greatest element -/
  le_top : ∀ a : α, a ≤ ⊤
  /-- `a ⇨` is right adjoint to `a ⊓` -/
  le_himp_iff (a b c : α) : a ≤ b ⇨ c ↔ a ⊓ b ≤ c
#align generalized_heyting_algebra GeneralizedHeytingAlgebra

/-- A generalized co-Heyting algebra is a lattice with an additional binary
difference operation `\` such that `\ a` is right adjoint to `⊔ a`.

This generalizes `CoheytingAlgebra` by not requiring a top element. -/
class GeneralizedCoheytingAlgebra (α : Type _) extends Lattice α, Bot α, SDiff α where
  /-- `⊥` is a least element -/
  bot_le : ∀ a : α, ⊥ ≤ a
  /-- `\ a` is right adjoint to `⊔ a` -/
  sdiff_le_iff (a b c : α) : a \ b ≤ c ↔ a ≤ b ⊔ c
#align generalized_coheyting_algebra GeneralizedCoheytingAlgebra

/-- A Heyting algebra is a bounded lattice with an additional binary operation `⇨` called Heyting
implication such that `a ⇨` is right adjoint to `a ⊓`. -/
class HeytingAlgebra (α : Type _) extends GeneralizedHeytingAlgebra α, Bot α, HasCompl α where
  /-- `⊥` is a least element -/
  bot_le : ∀ a : α, ⊥ ≤ a
  /-- `a ⇨` is right adjoint to `a ⊓` -/
  himp_bot (a : α) : a ⇨ ⊥ = aᶜ
#align heyting_algebra HeytingAlgebra

/-- A co-Heyting algebra is a bounded  lattice with an additional binary difference operation `\`
such that `\ a` is right adjoint to `⊔ a`. -/
class CoheytingAlgebra (α : Type _) extends GeneralizedCoheytingAlgebra α, Top α, HNot α where
  /-- `⊤` is a greatest element -/
  le_top : ∀ a : α, a ≤ ⊤
  /-- `⊤ \ a` is `￢a` -/
  top_sdiff (a : α) : ⊤ \ a = ￢a
#align coheyting_algebra CoheytingAlgebra

/-- A bi-Heyting algebra is a Heyting algebra that is also a co-Heyting algebra. -/
class BiheytingAlgebra (α : Type _) extends HeytingAlgebra α, SDiff α, HNot α where
  /-- `\ a` is right adjoint to `⊔ a` -/
  sdiff_le_iff (a b c : α) : a \ b ≤ c ↔ a ≤ b ⊔ c
  /-- `⊤ \ a` is `￢a` -/
  top_sdiff (a : α) : ⊤ \ a = ￢a
#align biheyting_algebra BiheytingAlgebra

-- See note [lower instance priority]
instance (priority := 100) GeneralizedHeytingAlgebra.toOrderTop [GeneralizedHeytingAlgebra α] :
    OrderTop α :=
  { ‹GeneralizedHeytingAlgebra α› with }
#align generalized_heyting_algebra.to_order_top GeneralizedHeytingAlgebra.toOrderTop

-- See note [lower instance priority]
instance (priority := 100) GeneralizedCoheytingAlgebra.toOrderBot [GeneralizedCoheytingAlgebra α] :
    OrderBot α :=
  { ‹GeneralizedCoheytingAlgebra α› with }
#align generalized_coheyting_algebra.to_order_bot GeneralizedCoheytingAlgebra.toOrderBot

-- See note [lower instance priority]
instance (priority := 100) HeytingAlgebra.toBoundedOrder [HeytingAlgebra α] : BoundedOrder α :=
  { bot_le := ‹HeytingAlgebra α›.bot_le }
--#align heyting_algebra.to_bounded_order HeytingAlgebra.toBoundedOrder

-- See note [lower instance priority]
instance (priority := 100) CoheytingAlgebra.toBoundedOrder [CoheytingAlgebra α] : BoundedOrder α :=
  { ‹CoheytingAlgebra α› with }
#align coheyting_algebra.to_bounded_order CoheytingAlgebra.toBoundedOrder

-- See note [lower instance priority]
instance (priority := 100) BiheytingAlgebra.toCoheytingAlgebra [BiheytingAlgebra α] :
    CoheytingAlgebra α :=
  { ‹BiheytingAlgebra α› with }
#align biheyting_algebra.to_coheyting_algebra BiheytingAlgebra.toCoheytingAlgebra

-- See note [reducible non-instances]
/-- Construct a Heyting algebra from the lattice structure and Heyting implication alone. -/
@[reducible]
def HeytingAlgebra.ofHImp [DistribLattice α] [BoundedOrder α] (himp : α → α → α)
    (le_himp_iff : ∀ a b c, a ≤ himp b c ↔ a ⊓ b ≤ c) : HeytingAlgebra α :=
  { ‹DistribLattice α›, ‹BoundedOrder α› with
    himp,
    compl := fun a => himp a ⊥,
    le_himp_iff,
    himp_bot := fun a => rfl }
#align heyting_algebra.of_himp HeytingAlgebra.ofHImp

-- See note [reducible non-instances]
/-- Construct a Heyting algebra from the lattice structure and complement operator alone. -/
@[reducible]
def HeytingAlgebra.ofCompl [DistribLattice α] [BoundedOrder α] (compl : α → α)
    (le_himp_iff : ∀ a b c, a ≤ compl b ⊔ c ↔ a ⊓ b ≤ c) : HeytingAlgebra α :=
  { ‹DistribLattice α›, ‹BoundedOrder α› with
    himp := fun a => (· ⊔ ·) (compl a),
    compl,
    le_himp_iff,
    himp_bot := fun a => sup_bot_eq }
#align heyting_algebra.of_compl HeytingAlgebra.ofCompl

-- See note [reducible non-instances]
/-- Construct a co-Heyting algebra from the lattice structure and the difference alone. -/
@[reducible]
def CoheytingAlgebra.ofSDiff [DistribLattice α] [BoundedOrder α] (sdiff : α → α → α)
    (sdiff_le_iff : ∀ a b c, sdiff a b ≤ c ↔ a ≤ b ⊔ c) : CoheytingAlgebra α :=
  { ‹DistribLattice α›, ‹BoundedOrder α› with
    sdiff,
    hnot := fun a => sdiff ⊤ a,
    sdiff_le_iff,
    top_sdiff := fun a => rfl }
#align coheyting_algebra.of_sdiff CoheytingAlgebra.ofSDiff

-- See note [reducible non-instances]
/-- Construct a co-Heyting algebra from the difference and Heyting negation alone. -/
@[reducible]
def CoheytingAlgebra.ofHNot [DistribLattice α] [BoundedOrder α] (hnot : α → α)
    (sdiff_le_iff : ∀ a b c, a ⊓ hnot b ≤ c ↔ a ≤ b ⊔ c) : CoheytingAlgebra α :=
  { ‹DistribLattice α›, ‹BoundedOrder α› with
    sdiff := fun a b => a ⊓ hnot b,
    hnot,
    sdiff_le_iff,
    top_sdiff := fun a => top_inf_eq }
#align coheyting_algebra.of_hnot CoheytingAlgebra.ofHNot

section GeneralizedHeytingAlgebra

variable [GeneralizedHeytingAlgebra α] {a b c d : α}

/- In this section, we'll give interpretations of these results in the Heyting algebra model of
intuitionistic logic,- where `≤` can be interpreted as "validates", `⇨` as "implies", `⊓` as "and",
`⊔` as "or", `⊥` as "false" and `⊤` as "true". Note that we confuse `→` and `⊢` because those are
the same in this logic.

See also `Prop.heytingAlgebra`. -/
-- `p → q → r ↔ p ∧ q → r`
@[simp]
theorem le_himp_iff : a ≤ b ⇨ c ↔ a ⊓ b ≤ c :=
  GeneralizedHeytingAlgebra.le_himp_iff _ _ _
#align le_himp_iff le_himp_iff

-- `p → q → r ↔ q ∧ p → r`
theorem le_himp_iff' : a ≤ b ⇨ c ↔ b ⊓ a ≤ c := by rw [le_himp_iff, inf_comm]
#align le_himp_iff' le_himp_iff'

-- `p → q → r ↔ q → p → r`
theorem le_himp_comm : a ≤ b ⇨ c ↔ b ≤ a ⇨ c := by rw [le_himp_iff, le_himp_iff']
#align le_himp_comm le_himp_comm

-- `p → q → p`
theorem le_himp : a ≤ b ⇨ a :=
  le_himp_iff.2 inf_le_left
#align le_himp le_himp

-- `p → p → q ↔ p → q`
theorem le_himp_iff_left : a ≤ a ⇨ b ↔ a ≤ b := by rw [le_himp_iff, inf_idem]
#align le_himp_iff_left le_himp_iff_left

-- `p → p`
@[simp]
theorem himp_self : a ⇨ a = ⊤ :=
  top_le_iff.1 <| le_himp_iff.2 inf_le_right
#align himp_self himp_self

-- `(p → q) ∧ p → q`
theorem himp_inf_le : (a ⇨ b) ⊓ a ≤ b :=
  le_himp_iff.1 le_rfl
#align himp_inf_le himp_inf_le

-- `p ∧ (p → q) → q`
theorem inf_himp_le : a ⊓ (a ⇨ b) ≤ b := by rw [inf_comm, ← le_himp_iff]
#align inf_himp_le inf_himp_le

-- `p ∧ (p → q) ↔ p ∧ q`
@[simp]
theorem inf_himp (a b : α) : a ⊓ (a ⇨ b) = a ⊓ b :=
  le_antisymm (le_inf inf_le_left <| by rw [inf_comm, ← le_himp_iff]) <| inf_le_inf_left _ le_himp
#align inf_himp inf_himp

-- `(p → q) ∧ p ↔ q ∧ p`
@[simp]
theorem himp_inf_self (a b : α) : (a ⇨ b) ⊓ a = b ⊓ a := by rw [inf_comm, inf_himp, inf_comm]
#align himp_inf_self himp_inf_self

/-- The **deduction theorem** in the Heyting algebra model of intuitionistic logic:
an implication holds iff the conclusion follows from the hypothesis. -/
@[simp]
theorem himp_eq_top_iff : a ⇨ b = ⊤ ↔ a ≤ b := by rw [← top_le_iff, le_himp_iff, top_inf_eq]
#align himp_eq_top_iff himp_eq_top_iff

-- `p → true`, `true → p ↔ p`
@[simp]
theorem himp_top : a ⇨ ⊤ = ⊤ :=
  himp_eq_top_iff.2 le_top
#align himp_top himp_top

@[simp]
theorem top_himp : ⊤ ⇨ a = a :=
  eq_of_forall_le_iff fun b => by rw [le_himp_iff, inf_top_eq]
#align top_himp top_himp

-- `p → q → r ↔ p ∧ q → r`
theorem himp_himp (a b c : α) : a ⇨ b ⇨ c = a ⊓ b ⇨ c :=
  eq_of_forall_le_iff fun d => by simp_rw [le_himp_iff, inf_assoc]
#align himp_himp himp_himp

-- `(q → r) → (p → q) → q → r`
theorem himp_le_himp_himp_himp : b ⇨ c ≤ (a ⇨ b) ⇨ a ⇨ c := by
  rw [le_himp_iff, le_himp_iff, inf_assoc, himp_inf_self, ← inf_assoc, himp_inf_self, inf_assoc]
  exact inf_le_left
#align himp_le_himp_himp_himp himp_le_himp_himp_himp

@[simp]
theorem himp_inf_himp_inf_le : (b ⇨ c) ⊓ (a ⇨ b) ⊓ a ≤ c := by
  simpa using @himp_le_himp_himp_himp

-- `p → q → r ↔ q → p → r`
theorem himp_left_comm (a b c : α) : a ⇨ b ⇨ c = b ⇨ a ⇨ c := by simp_rw [himp_himp, inf_comm]
#align himp_left_comm himp_left_comm

@[simp]
theorem himp_idem : b ⇨ b ⇨ a = b ⇨ a := by rw [himp_himp, inf_idem]
#align himp_idem himp_idem

theorem himp_inf_distrib (a b c : α) : a ⇨ b ⊓ c = (a ⇨ b) ⊓ (a ⇨ c) :=
  eq_of_forall_le_iff fun d => by simp_rw [le_himp_iff, le_inf_iff, le_himp_iff]
#align himp_inf_distrib himp_inf_distrib

theorem sup_himp_distrib (a b c : α) : a ⊔ b ⇨ c = (a ⇨ c) ⊓ (b ⇨ c) :=
  eq_of_forall_le_iff fun d => by
    rw [le_inf_iff, le_himp_comm, sup_le_iff]
    simp_rw [le_himp_comm]
#align sup_himp_distrib sup_himp_distrib

theorem himp_le_himp_left (h : a ≤ b) : c ⇨ a ≤ c ⇨ b :=
  le_himp_iff.2 <| himp_inf_le.trans h
#align himp_le_himp_left himp_le_himp_left

theorem himp_le_himp_right (h : a ≤ b) : b ⇨ c ≤ a ⇨ c :=
  le_himp_iff.2 <| (inf_le_inf_left _ h).trans himp_inf_le
#align himp_le_himp_right himp_le_himp_right

theorem himp_le_himp (hab : a ≤ b) (hcd : c ≤ d) : b ⇨ c ≤ a ⇨ d :=
  (himp_le_himp_right hab).trans <| himp_le_himp_left hcd
#align himp_le_himp himp_le_himp

@[simp]
theorem sup_himp_self_left (a b : α) : a ⊔ b ⇨ a = b ⇨ a := by
  rw [sup_himp_distrib, himp_self, top_inf_eq]
#align sup_himp_self_left sup_himp_self_left

@[simp]
theorem sup_himp_self_right (a b : α) : a ⊔ b ⇨ b = a ⇨ b := by
  rw [sup_himp_distrib, himp_self, inf_top_eq]
#align sup_himp_self_right sup_himp_self_right

theorem Codisjoint.himp_eq_right (h : Codisjoint a b) : b ⇨ a = a := by
  conv_rhs => rw [← @top_himp _ _ a]
  rw [← h.eq_top, sup_himp_self_left]
#align codisjoint.himp_eq_right Codisjoint.himp_eq_right

theorem Codisjoint.himp_eq_left (h : Codisjoint a b) : a ⇨ b = b :=
  h.symm.himp_eq_right
#align codisjoint.himp_eq_left Codisjoint.himp_eq_left

theorem Codisjoint.himp_inf_cancel_right (h : Codisjoint a b) : a ⇨ a ⊓ b = b := by
  rw [himp_inf_distrib, himp_self, top_inf_eq, h.himp_eq_left]
#align codisjoint.himp_inf_cancel_right Codisjoint.himp_inf_cancel_right

theorem Codisjoint.himp_inf_cancel_left (h : Codisjoint a b) : b ⇨ a ⊓ b = a := by
  rw [himp_inf_distrib, himp_self, inf_top_eq, h.himp_eq_right]
#align codisjoint.himp_inf_cancel_left Codisjoint.himp_inf_cancel_left

theorem le_himp_himp : a ≤ (a ⇨ b) ⇨ b :=
  le_himp_iff.2 inf_himp_le
#align le_himp_himp le_himp_himp

theorem himp_triangle (a b c : α) : (a ⇨ b) ⊓ (b ⇨ c) ≤ a ⇨ c := by
  rw [le_himp_iff, inf_right_comm, ← le_himp_iff]
  exact himp_inf_le.trans le_himp_himp
#align himp_triangle himp_triangle

theorem himp_inf_himp_cancel (hba : b ≤ a) (hcb : c ≤ b) : (a ⇨ b) ⊓ (b ⇨ c) = a ⇨ c :=
  (himp_triangle _ _ _).antisymm <| le_inf (himp_le_himp_left hcb) (himp_le_himp_right hba)
#align himp_inf_himp_cancel himp_inf_himp_cancel

-- See note [lower instance priority]
instance (priority := 100) GeneralizedHeytingAlgebra.toDistribLattice : DistribLattice α :=
  DistribLattice.ofInfSupLe fun a b c => by
    simp_rw [@inf_comm _ _ a, ← le_himp_iff, sup_le_iff, le_himp_iff, ← sup_le_iff]; rfl
#align generalized_heyting_algebra.to_distrib_lattice GeneralizedHeytingAlgebra.toDistribLattice

instance : GeneralizedCoheytingAlgebra αᵒᵈ :=
  { OrderDual.lattice α, OrderDual.orderBot α with
    sdiff := fun a b => toDual (ofDual b ⇨ ofDual a),
    sdiff_le_iff := fun a b c => by
      rw [sup_comm]
      exact le_himp_iff }

instance Prod.generalizedHeytingAlgebra [GeneralizedHeytingAlgebra β] :
    GeneralizedHeytingAlgebra (α × β) :=
  { Prod.lattice α β, Prod.orderTop α β, Prod.himp α β with
    le_himp_iff := fun _ _ _ => and_congr le_himp_iff le_himp_iff }
#align prod.generalized_heyting_algebra Prod.generalizedHeytingAlgebra

instance Pi.generalizedHeytingAlgebra {α : ι → Type _} [∀ i, GeneralizedHeytingAlgebra (α i)] :
    GeneralizedHeytingAlgebra (∀ i, α i) :=
  { Pi.lattice, Pi.orderTop with
    le_himp_iff := fun i => by simp [le_def] }
#align pi.generalized_heyting_algebra Pi.generalizedHeytingAlgebra

end GeneralizedHeytingAlgebra

section GeneralizedCoheytingAlgebra

variable [GeneralizedCoheytingAlgebra α] {a b c d : α}

@[simp]
theorem sdiff_le_iff : a \ b ≤ c ↔ a ≤ b ⊔ c :=
  GeneralizedCoheytingAlgebra.sdiff_le_iff _ _ _
#align sdiff_le_iff sdiff_le_iff

theorem sdiff_le_iff' : a \ b ≤ c ↔ a ≤ c ⊔ b := by rw [sdiff_le_iff, sup_comm]
#align sdiff_le_iff' sdiff_le_iff'

theorem sdiff_le_comm : a \ b ≤ c ↔ a \ c ≤ b := by rw [sdiff_le_iff, sdiff_le_iff']
#align sdiff_le_comm sdiff_le_comm

theorem sdiff_le : a \ b ≤ a :=
  sdiff_le_iff.2 le_sup_right
#align sdiff_le sdiff_le

theorem Disjoint.disjoint_sdiff_left (h : Disjoint a b) : Disjoint (a \ c) b :=
  h.mono_left sdiff_le
#align disjoint.disjoint_sdiff_left Disjoint.disjoint_sdiff_left

theorem Disjoint.disjoint_sdiff_right (h : Disjoint a b) : Disjoint a (b \ c) :=
  h.mono_right sdiff_le
#align disjoint.disjoint_sdiff_right Disjoint.disjoint_sdiff_right

theorem sdiff_le_iff_left : a \ b ≤ b ↔ a ≤ b := by rw [sdiff_le_iff, sup_idem]
#align sdiff_le_iff_left sdiff_le_iff_left

@[simp]
theorem sdiff_self : a \ a = ⊥ :=
  le_bot_iff.1 <| sdiff_le_iff.2 le_sup_left
#align sdiff_self sdiff_self

theorem le_sup_sdiff : a ≤ b ⊔ a \ b :=
  sdiff_le_iff.1 le_rfl
#align le_sup_sdiff le_sup_sdiff

theorem le_sdiff_sup : a ≤ a \ b ⊔ b := by rw [sup_comm, ← sdiff_le_iff]
#align le_sdiff_sup le_sdiff_sup

theorem sup_sdiff_left : a ⊔ a \ b = a :=
  sup_of_le_left sdiff_le
#align sup_sdiff_left sup_sdiff_left

theorem sup_sdiff_right : a \ b ⊔ a = a :=
  sup_of_le_right sdiff_le
#align sup_sdiff_right sup_sdiff_right

theorem inf_sdiff_left : a \ b ⊓ a = a \ b :=
  inf_of_le_left sdiff_le
#align inf_sdiff_left inf_sdiff_left

theorem inf_sdiff_right : a ⊓ a \ b = a \ b :=
  inf_of_le_right sdiff_le
#align inf_sdiff_right inf_sdiff_right

@[simp]
theorem sup_sdiff_self (a b : α) : a ⊔ b \ a = a ⊔ b :=
  le_antisymm (sup_le_sup_left sdiff_le _) (sup_le le_sup_left le_sup_sdiff)
#align sup_sdiff_self sup_sdiff_self

@[simp]
theorem sdiff_sup_self (a b : α) : b \ a ⊔ a = b ⊔ a := by rw [sup_comm, sup_sdiff_self, sup_comm]
#align sdiff_sup_self sdiff_sup_self

alias sdiff_sup_self ← sup_sdiff_self_left
#align sup_sdiff_self_left sup_sdiff_self_left

alias sup_sdiff_self ← sup_sdiff_self_right
#align sup_sdiff_self_right sup_sdiff_self_right

theorem sup_sdiff_eq_sup (h : c ≤ a) : a ⊔ b \ c = a ⊔ b :=
  sup_congr_left (sdiff_le.trans le_sup_right) <| le_sup_sdiff.trans <| sup_le_sup_right h _
#align sup_sdiff_eq_sup sup_sdiff_eq_sup

-- cf. `Set.union_diff_cancel'`
theorem sup_sdiff_cancel' (hab : a ≤ b) (hbc : b ≤ c) : b ⊔ c \ a = c := by
  rw [sup_sdiff_eq_sup hab, sup_of_le_right hbc]
#align sup_sdiff_cancel' sup_sdiff_cancel'

theorem sup_sdiff_cancel_right (h : a ≤ b) : a ⊔ b \ a = b :=
  sup_sdiff_cancel' le_rfl h
#align sup_sdiff_cancel_right sup_sdiff_cancel_right

theorem sdiff_sup_cancel (h : b ≤ a) : a \ b ⊔ b = a := by rw [sup_comm, sup_sdiff_cancel_right h]
#align sdiff_sup_cancel sdiff_sup_cancel

theorem sup_le_of_le_sdiff_left (h : b ≤ c \ a) (hac : a ≤ c) : a ⊔ b ≤ c :=
  sup_le hac <| h.trans sdiff_le
#align sup_le_of_le_sdiff_left sup_le_of_le_sdiff_left

theorem sup_le_of_le_sdiff_right (h : a ≤ c \ b) (hbc : b ≤ c) : a ⊔ b ≤ c :=
  sup_le (h.trans sdiff_le) hbc
#align sup_le_of_le_sdiff_right sup_le_of_le_sdiff_right

@[simp]
theorem sdiff_eq_bot_iff : a \ b = ⊥ ↔ a ≤ b := by rw [← le_bot_iff, sdiff_le_iff, sup_bot_eq]
#align sdiff_eq_bot_iff sdiff_eq_bot_iff

@[simp]
theorem sdiff_bot : a \ ⊥ = a :=
  eq_of_forall_ge_iff fun b => by rw [sdiff_le_iff, bot_sup_eq]
#align sdiff_bot sdiff_bot

@[simp]
theorem bot_sdiff : ⊥ \ a = ⊥ :=
  sdiff_eq_bot_iff.2 bot_le
#align bot_sdiff bot_sdiff

theorem sdiff_sdiff_sdiff_le_sdiff : (a \ b) \ (a \ c) ≤ c \ b := by
  rw [sdiff_le_iff, sdiff_le_iff, sup_left_comm, sup_sdiff_self, sup_left_comm, sdiff_sup_self,
    sup_left_comm]
  exact le_sup_left
#align sdiff_sdiff_sdiff_le_sdiff sdiff_sdiff_sdiff_le_sdiff

@[simp]
theorem le_sup_sdiff_sup_sdiff : a ≤ b ⊔ (a \ c ⊔ c \ b) :=
  by simpa using @sdiff_sdiff_sdiff_le_sdiff

theorem sdiff_sdiff (a b c : α) : (a \ b) \ c = a \ (b ⊔ c) :=
  eq_of_forall_ge_iff fun d => by simp_rw [sdiff_le_iff, sup_assoc]
#align sdiff_sdiff sdiff_sdiff

theorem sdiff_sdiff_left : (a \ b) \ c = a \ (b ⊔ c) :=
  sdiff_sdiff _ _ _
#align sdiff_sdiff_left sdiff_sdiff_left

theorem sdiff_right_comm (a b c : α) : (a \ b) \ c = (a \ c) \ b := by
  simp_rw [sdiff_sdiff, sup_comm]
#align sdiff_right_comm sdiff_right_comm

theorem sdiff_sdiff_comm : (a \ b) \ c = (a \ c) \ b :=
  sdiff_right_comm _ _ _
#align sdiff_sdiff_comm sdiff_sdiff_comm

@[simp]
theorem sdiff_idem : (a \ b) \ b = a \ b := by rw [sdiff_sdiff_left, sup_idem]
#align sdiff_idem sdiff_idem

@[simp]
theorem sdiff_sdiff_self : (a \ b) \ a = ⊥ := by rw [sdiff_sdiff_comm, sdiff_self, bot_sdiff]
#align sdiff_sdiff_self sdiff_sdiff_self

theorem sup_sdiff_distrib (a b c : α) : (a ⊔ b) \ c = a \ c ⊔ b \ c :=
  eq_of_forall_ge_iff fun d => by simp_rw [sdiff_le_iff, sup_le_iff, sdiff_le_iff]
#align sup_sdiff_distrib sup_sdiff_distrib

theorem sdiff_inf_distrib (a b c : α) : a \ (b ⊓ c) = a \ b ⊔ a \ c :=
  eq_of_forall_ge_iff fun d => by
    rw [sup_le_iff, sdiff_le_comm, le_inf_iff]
    simp_rw [sdiff_le_comm]
#align sdiff_inf_distrib sdiff_inf_distrib

theorem sup_sdiff : (a ⊔ b) \ c = a \ c ⊔ b \ c :=
  sup_sdiff_distrib _ _ _
#align sup_sdiff sup_sdiff

@[simp]
theorem sup_sdiff_right_self : (a ⊔ b) \ b = a \ b := by rw [sup_sdiff, sdiff_self, sup_bot_eq]
#align sup_sdiff_right_self sup_sdiff_right_self

@[simp]
theorem sup_sdiff_left_self : (a ⊔ b) \ a = b \ a := by rw [sup_comm, sup_sdiff_right_self]
#align sup_sdiff_left_self sup_sdiff_left_self

theorem sdiff_le_sdiff_right (h : a ≤ b) : a \ c ≤ b \ c :=
  sdiff_le_iff.2 <| h.trans <| le_sup_sdiff
#align sdiff_le_sdiff_right sdiff_le_sdiff_right

theorem sdiff_le_sdiff_left (h : a ≤ b) : c \ b ≤ c \ a :=
  sdiff_le_iff.2 <| le_sup_sdiff.trans <| sup_le_sup_right h _
#align sdiff_le_sdiff_left sdiff_le_sdiff_left

theorem sdiff_le_sdiff (hab : a ≤ b) (hcd : c ≤ d) : a \ d ≤ b \ c :=
  (sdiff_le_sdiff_right hab).trans <| sdiff_le_sdiff_left hcd
#align sdiff_le_sdiff sdiff_le_sdiff

-- cf. `IsCompl.inf_sup`
theorem sdiff_inf : a \ (b ⊓ c) = a \ b ⊔ a \ c :=
  sdiff_inf_distrib _ _ _
#align sdiff_inf sdiff_inf

@[simp]
theorem sdiff_inf_self_left (a b : α) : a \ (a ⊓ b) = a \ b := by
  rw [sdiff_inf, sdiff_self, bot_sup_eq]
#align sdiff_inf_self_left sdiff_inf_self_left

@[simp]
theorem sdiff_inf_self_right (a b : α) : b \ (a ⊓ b) = b \ a := by
  rw [sdiff_inf, sdiff_self, sup_bot_eq]
#align sdiff_inf_self_right sdiff_inf_self_right

theorem Disjoint.sdiff_eq_left (h : Disjoint a b) : a \ b = a := by
  conv_rhs => rw [← @sdiff_bot _ _ a]
  rw [← h.eq_bot, sdiff_inf_self_left]
#align disjoint.sdiff_eq_left Disjoint.sdiff_eq_left

theorem Disjoint.sdiff_eq_right (h : Disjoint a b) : b \ a = b :=
  h.symm.sdiff_eq_left
#align disjoint.sdiff_eq_right Disjoint.sdiff_eq_right

theorem Disjoint.sup_sdiff_cancel_left (h : Disjoint a b) : (a ⊔ b) \ a = b := by
  rw [sup_sdiff, sdiff_self, bot_sup_eq, h.sdiff_eq_right]
#align disjoint.sup_sdiff_cancel_left Disjoint.sup_sdiff_cancel_left

theorem Disjoint.sup_sdiff_cancel_right (h : Disjoint a b) : (a ⊔ b) \ b = a := by
  rw [sup_sdiff, sdiff_self, sup_bot_eq, h.sdiff_eq_left]
#align disjoint.sup_sdiff_cancel_right Disjoint.sup_sdiff_cancel_right

theorem sdiff_sdiff_le : a \ (a \ b) ≤ b :=
  sdiff_le_iff.2 le_sdiff_sup
#align sdiff_sdiff_le sdiff_sdiff_le

theorem sdiff_triangle (a b c : α) : a \ c ≤ a \ b ⊔ b \ c := by
  rw [sdiff_le_iff, sup_left_comm, ← sdiff_le_iff]
  exact sdiff_sdiff_le.trans le_sup_sdiff
#align sdiff_triangle sdiff_triangle

theorem sdiff_sup_sdiff_cancel (hba : b ≤ a) (hcb : c ≤ b) : a \ b ⊔ b \ c = a \ c :=
  (sdiff_triangle _ _ _).antisymm' <| sup_le (sdiff_le_sdiff_left hcb) (sdiff_le_sdiff_right hba)
#align sdiff_sup_sdiff_cancel sdiff_sup_sdiff_cancel

theorem sdiff_le_sdiff_of_sup_le_sup_left (h : c ⊔ a ≤ c ⊔ b) : a \ c ≤ b \ c := by
  rw [← sup_sdiff_left_self, ← @sup_sdiff_left_self _ _ _ b]
  exact sdiff_le_sdiff_right h
#align sdiff_le_sdiff_of_sup_le_sup_left sdiff_le_sdiff_of_sup_le_sup_left

theorem sdiff_le_sdiff_of_sup_le_sup_right (h : a ⊔ c ≤ b ⊔ c) : a \ c ≤ b \ c := by
  rw [← sup_sdiff_right_self, ← @sup_sdiff_right_self _ _ b]
  exact sdiff_le_sdiff_right h
#align sdiff_le_sdiff_of_sup_le_sup_right sdiff_le_sdiff_of_sup_le_sup_right

@[simp]
theorem inf_sdiff_sup_left : a \ c ⊓ (a ⊔ b) = a \ c :=
  inf_of_le_left <| sdiff_le.trans le_sup_left
#align inf_sdiff_sup_left inf_sdiff_sup_left

@[simp]
theorem inf_sdiff_sup_right : a \ c ⊓ (b ⊔ a) = a \ c :=
  inf_of_le_left <| sdiff_le.trans le_sup_right
#align inf_sdiff_sup_right inf_sdiff_sup_right

-- See note [lower instance priority]
instance (priority := 100) GeneralizedCoheytingAlgebra.toDistribLattice : DistribLattice α :=
  { ‹GeneralizedCoheytingAlgebra α› with
    le_sup_inf :=
      fun a b c => by simp_rw [← sdiff_le_iff, le_inf_iff, sdiff_le_iff, ← le_inf_iff]; rfl }
#align generalized_coheyting_algebra.to_distrib_lattice GeneralizedCoheytingAlgebra.toDistribLattice

instance : GeneralizedHeytingAlgebra αᵒᵈ :=
  { OrderDual.lattice α, OrderDual.orderTop α with
    himp := fun a b => toDual (ofDual b \ ofDual a),
    le_himp_iff := fun a b c => by
      rw [inf_comm]
      exact sdiff_le_iff }

instance Prod.generalizedCoheytingAlgebra [GeneralizedCoheytingAlgebra β] :
    GeneralizedCoheytingAlgebra (α × β) :=
  { Prod.lattice α β, Prod.orderBot α β, Prod.sdiff α β with
    sdiff_le_iff := fun _ _ _ => and_congr sdiff_le_iff sdiff_le_iff }
#align prod.generalized_coheyting_algebra Prod.generalizedCoheytingAlgebra

instance Pi.generalizedCoheytingAlgebra {α : ι → Type _} [∀ i, GeneralizedCoheytingAlgebra (α i)] :
    GeneralizedCoheytingAlgebra (∀ i, α i) :=
  { Pi.lattice, Pi.orderBot with
    sdiff_le_iff := fun i => by simp [le_def] }
#align pi.generalized_coheyting_algebra Pi.generalizedCoheytingAlgebra

end GeneralizedCoheytingAlgebra

section HeytingAlgebra

variable [HeytingAlgebra α] {a b c : α}

@[simp]
theorem himp_bot (a : α) : a ⇨ ⊥ = aᶜ :=
  HeytingAlgebra.himp_bot _
#align himp_bot himp_bot

@[simp]
theorem bot_himp (a : α) : ⊥ ⇨ a = ⊤ :=
  himp_eq_top_iff.2 bot_le
#align bot_himp bot_himp

theorem compl_sup_distrib (a b : α) : (a ⊔ b)ᶜ = aᶜ ⊓ bᶜ := by
  simp_rw [← himp_bot, sup_himp_distrib]
#align compl_sup_distrib compl_sup_distrib

@[simp]
theorem compl_sup : (a ⊔ b)ᶜ = aᶜ ⊓ bᶜ :=
  compl_sup_distrib _ _
#align compl_sup compl_sup

theorem compl_le_himp : aᶜ ≤ a ⇨ b :=
  (himp_bot _).ge.trans <| himp_le_himp_left bot_le
#align compl_le_himp compl_le_himp

theorem compl_sup_le_himp : aᶜ ⊔ b ≤ a ⇨ b :=
  sup_le compl_le_himp le_himp
#align compl_sup_le_himp compl_sup_le_himp

theorem sup_compl_le_himp : b ⊔ aᶜ ≤ a ⇨ b :=
  sup_le le_himp compl_le_himp
#align sup_compl_le_himp sup_compl_le_himp

-- `p → ¬ p ↔ ¬ p`
@[simp]
theorem himp_compl (a : α) : a ⇨ aᶜ = aᶜ := by rw [← himp_bot, himp_himp, inf_idem]
#align himp_compl himp_compl

-- `p → ¬ q ↔ q → ¬ p`
theorem himp_compl_comm (a b : α) : a ⇨ bᶜ = b ⇨ aᶜ := by simp_rw [← himp_bot, himp_left_comm]
#align himp_compl_comm himp_compl_comm

theorem le_compl_iff_disjoint_right : a ≤ bᶜ ↔ Disjoint a b := by
  rw [← himp_bot, le_himp_iff, disjoint_iff_inf_le]
#align le_compl_iff_disjoint_right le_compl_iff_disjoint_right

theorem le_compl_iff_disjoint_left : a ≤ bᶜ ↔ Disjoint b a :=
  le_compl_iff_disjoint_right.trans disjoint_comm
#align le_compl_iff_disjoint_left le_compl_iff_disjoint_left

theorem le_compl_comm : a ≤ bᶜ ↔ b ≤ aᶜ := by
  rw [le_compl_iff_disjoint_right, le_compl_iff_disjoint_left]
#align le_compl_comm le_compl_comm

alias le_compl_iff_disjoint_right ↔ _ Disjoint.le_compl_right
#align disjoint.le_compl_right Disjoint.le_compl_right

alias le_compl_iff_disjoint_left ↔ _ Disjoint.le_compl_left
#align disjoint.le_compl_left Disjoint.le_compl_left

alias le_compl_comm ← le_compl_iff_le_compl
#align le_compl_iff_le_compl le_compl_iff_le_compl

alias le_compl_comm ↔ le_compl_of_le_compl _
#align le_compl_of_le_compl le_compl_of_le_compl

theorem disjoint_compl_left : Disjoint (aᶜ) a :=
  disjoint_iff_inf_le.mpr <| le_himp_iff.1 (himp_bot _).ge
#align disjoint_compl_left disjoint_compl_left

theorem disjoint_compl_right : Disjoint a (aᶜ) :=
  disjoint_compl_left.symm
#align disjoint_compl_right disjoint_compl_right

theorem LE.le.disjoint_compl_left (h : b ≤ a) : Disjoint (aᶜ) b :=
  disjoint_compl_left.mono_right h
#align has_le.le.disjoint_compl_left LE.le.disjoint_compl_left

theorem LE.le.disjoint_compl_right (h : a ≤ b) : Disjoint a (bᶜ) :=
  disjoint_compl_right.mono_left h
#align has_le.le.disjoint_compl_right LE.le.disjoint_compl_right

theorem IsCompl.compl_eq (h : IsCompl a b) : aᶜ = b :=
  h.1.le_compl_left.antisymm' <| Disjoint.le_of_codisjoint disjoint_compl_left h.2
#align is_compl.compl_eq IsCompl.compl_eq

theorem IsCompl.eq_compl (h : IsCompl a b) : a = bᶜ :=
  h.1.le_compl_right.antisymm <| Disjoint.le_of_codisjoint disjoint_compl_left h.2.symm
#align is_compl.eq_compl IsCompl.eq_compl

theorem compl_unique (h₀ : a ⊓ b = ⊥) (h₁ : a ⊔ b = ⊤) : aᶜ = b :=
  (IsCompl.of_eq h₀ h₁).compl_eq
#align compl_unique compl_unique

@[simp]
theorem inf_compl_self (a : α) : a ⊓ aᶜ = ⊥ :=
  disjoint_compl_right.eq_bot
#align inf_compl_self inf_compl_self

@[simp]
theorem compl_inf_self (a : α) : aᶜ ⊓ a = ⊥ :=
  disjoint_compl_left.eq_bot
#align compl_inf_self compl_inf_self

theorem inf_compl_eq_bot : a ⊓ aᶜ = ⊥ :=
  inf_compl_self _
#align inf_compl_eq_bot inf_compl_eq_bot

theorem compl_inf_eq_bot : aᶜ ⊓ a = ⊥ :=
  compl_inf_self _
#align compl_inf_eq_bot compl_inf_eq_bot

@[simp]
theorem compl_top : (⊤ : α)ᶜ = ⊥ :=
  eq_of_forall_le_iff fun a => by rw [le_compl_iff_disjoint_right, disjoint_top, le_bot_iff]
#align compl_top compl_top

@[simp]
theorem compl_bot : (⊥ : α)ᶜ = ⊤ := by rw [← himp_bot, himp_self]
#align compl_bot compl_bot

theorem le_compl_compl : a ≤ aᶜᶜ :=
  disjoint_compl_right.le_compl_right
#align le_compl_compl le_compl_compl

theorem compl_anti : Antitone (compl : α → α) := fun _ _ h =>
  le_compl_comm.1 <| h.trans le_compl_compl
#align compl_anti compl_anti

theorem compl_le_compl (h : a ≤ b) : bᶜ ≤ aᶜ :=
  compl_anti h
#align compl_le_compl compl_le_compl

@[simp]
theorem compl_compl_compl (a : α) : aᶜᶜᶜ = aᶜ :=
  (compl_anti le_compl_compl).antisymm le_compl_compl
#align compl_compl_compl compl_compl_compl

@[simp]
theorem disjoint_compl_compl_left_iff : Disjoint (aᶜᶜ) b ↔ Disjoint a b := by
  simp_rw [← le_compl_iff_disjoint_left, compl_compl_compl]
#align disjoint_compl_compl_left_iff disjoint_compl_compl_left_iff

@[simp]
theorem disjoint_compl_compl_right_iff : Disjoint a (bᶜᶜ) ↔ Disjoint a b := by
  simp_rw [← le_compl_iff_disjoint_right, compl_compl_compl]
#align disjoint_compl_compl_right_iff disjoint_compl_compl_right_iff

theorem compl_sup_compl_le : aᶜ ⊔ bᶜ ≤ (a ⊓ b)ᶜ :=
  sup_le (compl_anti inf_le_left) <| compl_anti inf_le_right
#align compl_sup_compl_le compl_sup_compl_le

theorem compl_compl_inf_distrib (a b : α) : (a ⊓ b)ᶜᶜ = aᶜᶜ ⊓ bᶜᶜ := by
  refine' ((compl_anti compl_sup_compl_le).trans (compl_sup_distrib _ _).le).antisymm _
  rw [le_compl_iff_disjoint_right, disjoint_assoc, disjoint_compl_compl_left_iff,
    disjoint_left_comm, disjoint_compl_compl_left_iff, ← disjoint_assoc, inf_comm]
  exact disjoint_compl_right
#align compl_compl_inf_distrib compl_compl_inf_distrib

theorem compl_compl_himp_distrib (a b : α) : (a ⇨ b)ᶜᶜ = aᶜᶜ ⇨ bᶜᶜ := by
  refine' le_antisymm _ _
  · rw [le_himp_iff, ← compl_compl_inf_distrib]
    exact compl_anti (compl_anti himp_inf_le)

  · refine' le_compl_comm.1 ((compl_anti compl_sup_le_himp).trans _)
    rw [compl_sup_distrib, le_compl_iff_disjoint_right, disjoint_right_comm, ←
      le_compl_iff_disjoint_right]
    exact inf_himp_le

#align compl_compl_himp_distrib compl_compl_himp_distrib

instance : CoheytingAlgebra αᵒᵈ :=
  { OrderDual.lattice α, OrderDual.boundedOrder α with
    hnot := toDual ∘ compl ∘ ofDual,
    sdiff := fun a b => toDual (ofDual b ⇨ ofDual a),
    sdiff_le_iff := fun a b c => by
      rw [sup_comm]
      exact le_himp_iff,
    top_sdiff := @himp_bot α _ }

@[simp]
theorem ofDual_hnot (a : αᵒᵈ) : ofDual (￢a) = ofDual aᶜ :=
  rfl
#align of_dual_hnot ofDual_hnot

@[simp]
theorem toDual_compl (a : α) : toDual (aᶜ) = ￢toDual a :=
  rfl
#align to_dual_compl toDual_compl

instance Prod.heytingAlgebra [HeytingAlgebra β] : HeytingAlgebra (α × β) :=
  { Prod.generalizedHeytingAlgebra, Prod.boundedOrder α β, Prod.hasCompl α β with
     himp_bot := fun a => Prod.ext_iff.2 ⟨himp_bot a.1, himp_bot a.2⟩ }
#align prod.heyting_algebra Prod.heytingAlgebra

instance Pi.heytingAlgebra {α : ι → Type _} [∀ i, HeytingAlgebra (α i)] :
    HeytingAlgebra (∀ i, α i) :=
  { Pi.orderBot, Pi.generalizedHeytingAlgebra with
    himp_bot := fun f => funext fun i => himp_bot (f i) }
#align pi.heyting_algebra Pi.heytingAlgebra

end HeytingAlgebra

section CoheytingAlgebra

variable [CoheytingAlgebra α] {a b c : α}

@[simp]
theorem top_sdiff' (a : α) : ⊤ \ a = ￢a :=
  CoheytingAlgebra.top_sdiff _
#align top_sdiff' top_sdiff'

@[simp]
theorem sdiff_top (a : α) : a \ ⊤ = ⊥ :=
  sdiff_eq_bot_iff.2 le_top
#align sdiff_top sdiff_top

theorem hnot_inf_distrib (a b : α) : ￢(a ⊓ b) = ￢a ⊔ ￢b := by
  simp_rw [← top_sdiff', sdiff_inf_distrib]
#align hnot_inf_distrib hnot_inf_distrib

theorem sdiff_le_hnot : a \ b ≤ ￢b :=
  (sdiff_le_sdiff_right le_top).trans_eq <| top_sdiff' _
#align sdiff_le_hnot sdiff_le_hnot

theorem sdiff_le_inf_hnot : a \ b ≤ a ⊓ ￢b :=
  le_inf sdiff_le sdiff_le_hnot
#align sdiff_le_inf_hnot sdiff_le_inf_hnot

-- See note [lower instance priority]
instance (priority := 100) CoheytingAlgebra.toDistribLattice : DistribLattice α :=
  { ‹CoheytingAlgebra α› with
    le_sup_inf :=
      fun a b c => by simp_rw [← sdiff_le_iff, le_inf_iff, sdiff_le_iff, ← le_inf_iff]; rfl }
#align coheyting_algebra.to_distrib_lattice CoheytingAlgebra.toDistribLattice

@[simp]
theorem hnot_sdiff (a : α) : ￢a \ a = ￢a := by rw [← top_sdiff', sdiff_sdiff, sup_idem]
#align hnot_sdiff hnot_sdiff

theorem hnot_sdiff_comm (a b : α) : ￢a \ b = ￢b \ a := by simp_rw [← top_sdiff', sdiff_right_comm]
#align hnot_sdiff_comm hnot_sdiff_comm

theorem hnot_le_iff_codisjoint_right : ￢a ≤ b ↔ Codisjoint a b := by
  rw [← top_sdiff', sdiff_le_iff, codisjoint_iff_le_sup]
#align hnot_le_iff_codisjoint_right hnot_le_iff_codisjoint_right

theorem hnot_le_iff_codisjoint_left : ￢a ≤ b ↔ Codisjoint b a :=
  hnot_le_iff_codisjoint_right.trans Codisjoint_comm
#align hnot_le_iff_codisjoint_left hnot_le_iff_codisjoint_left

theorem hnot_le_comm : ￢a ≤ b ↔ ￢b ≤ a := by
  rw [hnot_le_iff_codisjoint_right, hnot_le_iff_codisjoint_left]
#align hnot_le_comm hnot_le_comm

alias hnot_le_iff_codisjoint_right ↔ _ Codisjoint.hnot_le_right
#align codisjoint.hnot_le_right Codisjoint.hnot_le_right

alias hnot_le_iff_codisjoint_left ↔ _ Codisjoint.hnot_le_left
#align codisjoint.hnot_le_left Codisjoint.hnot_le_left

theorem codisjoint_hnot_right : Codisjoint a (￢a) :=
  codisjoint_iff_le_sup.2 <| sdiff_le_iff.1 (top_sdiff' _).le
#align codisjoint_hnot_right codisjoint_hnot_right

theorem codisjoint_hnot_left : Codisjoint (￢a) a :=
  codisjoint_hnot_right.symm
#align codisjoint_hnot_left codisjoint_hnot_left

theorem LE.le.codisjoint_hnot_left (h : a ≤ b) : Codisjoint (￢a) b :=
  codisjoint_hnot_left.mono_right h
#align has_le.le.codisjoint_hnot_left LE.le.codisjoint_hnot_left

theorem LE.le.codisjoint_hnot_right (h : b ≤ a) : Codisjoint a (￢b) :=
  codisjoint_hnot_right.mono_left h
#align has_le.le.codisjoint_hnot_right LE.le.codisjoint_hnot_right

theorem IsCompl.hnot_eq (h : IsCompl a b) : ￢a = b :=
  h.2.hnot_le_right.antisymm <| Disjoint.le_of_codisjoint h.1.symm codisjoint_hnot_right
#align is_compl.hnot_eq IsCompl.hnot_eq

theorem IsCompl.eq_hnot (h : IsCompl a b) : a = ￢b :=
  h.2.hnot_le_left.antisymm' <| Disjoint.le_of_codisjoint h.1 codisjoint_hnot_right
#align is_compl.eq_hnot IsCompl.eq_hnot

@[simp]
theorem sup_hnot_self (a : α) : a ⊔ ￢a = ⊤ :=
  Codisjoint.eq_top codisjoint_hnot_right
#align sup_hnot_self sup_hnot_self

@[simp]
theorem hnot_sup_self (a : α) : ￢a ⊔ a = ⊤ :=
  Codisjoint.eq_top codisjoint_hnot_left
#align hnot_sup_self hnot_sup_self

@[simp]
theorem hnot_bot : ￢(⊥ : α) = ⊤ :=
  eq_of_forall_ge_iff fun a => by rw [hnot_le_iff_codisjoint_left, codisjoint_bot, top_le_iff]
#align hnot_bot hnot_bot

@[simp]
theorem hnot_top : ￢(⊤ : α) = ⊥ := by rw [← top_sdiff', sdiff_self]
#align hnot_top hnot_top

theorem hnot_hnot_le : ￢￢a ≤ a :=
  codisjoint_hnot_right.hnot_le_left
#align hnot_hnot_le hnot_hnot_le

theorem hnot_anti : Antitone (hnot : α → α) := fun _ _ h => hnot_le_comm.1 <| hnot_hnot_le.trans h
#align hnot_anti hnot_anti

theorem hnot_le_hnot (h : a ≤ b) : ￢b ≤ ￢a :=
  hnot_anti h
#align hnot_le_hnot hnot_le_hnot

@[simp]
theorem hnot_hnot_hnot (a : α) : ￢￢￢a = ￢a :=
  hnot_hnot_le.antisymm <| hnot_anti hnot_hnot_le
#align hnot_hnot_hnot hnot_hnot_hnot

@[simp]
theorem codisjoint_hnot_hnot_left_iff : Codisjoint (￢￢a) b ↔ Codisjoint a b := by
  simp_rw [← hnot_le_iff_codisjoint_right, hnot_hnot_hnot]
#align codisjoint_hnot_hnot_left_iff codisjoint_hnot_hnot_left_iff

@[simp]
theorem codisjoint_hnot_hnot_right_iff : Codisjoint a (￢￢b) ↔ Codisjoint a b := by
  simp_rw [← hnot_le_iff_codisjoint_left, hnot_hnot_hnot]
#align codisjoint_hnot_hnot_right_iff codisjoint_hnot_hnot_right_iff

theorem le_hnot_inf_hnot : ￢(a ⊔ b) ≤ ￢a ⊓ ￢b :=
  le_inf (hnot_anti le_sup_left) <| hnot_anti le_sup_right
#align le_hnot_inf_hnot le_hnot_inf_hnot

theorem hnot_hnot_sup_distrib (a b : α) : ￢￢(a ⊔ b) = ￢￢a ⊔ ￢￢b := by
  refine' ((hnot_inf_distrib _ _).ge.trans <| hnot_anti le_hnot_inf_hnot).antisymm' _
  rw [hnot_le_iff_codisjoint_left, codisjoint_assoc, codisjoint_hnot_hnot_left_iff,
    codisjoint_left_comm, codisjoint_hnot_hnot_left_iff, ← codisjoint_assoc, sup_comm]
  exact codisjoint_hnot_right
#align hnot_hnot_sup_distrib hnot_hnot_sup_distrib

theorem hnot_hnot_sdiff_distrib (a b : α) : ￢￢(a \ b) = ￢￢a \ ￢￢b := by
  refine' le_antisymm _ _
  · refine' hnot_le_comm.1 ((hnot_anti sdiff_le_inf_hnot).trans' _)
    rw [hnot_inf_distrib, hnot_le_iff_codisjoint_right, codisjoint_left_comm, ←
      hnot_le_iff_codisjoint_right]
    exact le_sdiff_sup

  · rw [sdiff_le_iff, ← hnot_hnot_sup_distrib]
    exact hnot_anti (hnot_anti le_sup_sdiff)

#align hnot_hnot_sdiff_distrib hnot_hnot_sdiff_distrib

instance : HeytingAlgebra αᵒᵈ :=
  { OrderDual.lattice α, OrderDual.boundedOrder α with
    compl := toDual ∘ hnot ∘ ofDual,
    himp := fun a b => toDual (ofDual b \ ofDual a),
    le_himp_iff := fun a b c => by
      rw [inf_comm]
      exact sdiff_le_iff,
    himp_bot := @top_sdiff' α _ }

@[simp]
theorem ofDual_compl (a : αᵒᵈ) : ofDual (aᶜ) = ￢ofDual a :=
  rfl
#align of_dual_compl ofDual_compl

@[simp]
theorem ofDual_himp (a b : αᵒᵈ) : ofDual (a ⇨ b) = ofDual b \ ofDual a :=
  rfl
#align of_dual_himp ofDual_himp

@[simp]
theorem toDual_hnot (a : α) : toDual (￢a) = toDual aᶜ :=
  rfl
#align to_dual_hnot toDual_hnot

@[simp]
theorem toDual_sdiff (a b : α) : toDual (a \ b) = toDual b ⇨ toDual a :=
  rfl
#align to_dual_sdiff toDual_sdiff

instance Prod.coheytingAlgebra [CoheytingAlgebra β] : CoheytingAlgebra (α × β) :=
  { Prod.lattice α β, Prod.boundedOrder α β, Prod.sdiff α β, Prod.hnot α β with
    sdiff_le_iff := fun _ _ _ => and_congr sdiff_le_iff sdiff_le_iff,
    top_sdiff := fun a => Prod.ext_iff.2 ⟨top_sdiff' a.1, top_sdiff' a.2⟩ }
#align prod.coheyting_algebra Prod.coheytingAlgebra

instance Pi.coheytingAlgebra {α : ι → Type _} [∀ i, CoheytingAlgebra (α i)] :
    CoheytingAlgebra (∀ i, α i) :=
  { Pi.orderTop, Pi.generalizedCoheytingAlgebra with
    top_sdiff := fun f => funext fun i => top_sdiff' (f i) }
#align pi.coheyting_algebra Pi.coheytingAlgebra

end CoheytingAlgebra

section BiheytingAlgebra

variable [BiheytingAlgebra α] {a : α}

theorem compl_le_hnot : aᶜ ≤ ￢a :=
  (disjoint_compl_left : Disjoint _ a).le_of_codisjoint codisjoint_hnot_right
#align compl_le_hnot compl_le_hnot

end BiheytingAlgebra

/-- Propositions form a Heyting algebra with implication as Heyting implication and negation as
complement. -/
instance Prop.heytingAlgebra : HeytingAlgebra Prop :=
  { Prop.distribLattice, Prop.boundedOrder with
    himp := (· → ·),
    le_himp_iff := fun _ _ _ => and_imp.symm, himp_bot := fun _ => rfl }
#align Prop.heyting_algebra Prop.heytingAlgebra

@[simp]
theorem himp_iff_imp (p q : Prop) : p ⇨ q ↔ p → q :=
  Iff.rfl
#align himp_iff_imp himp_iff_imp

@[simp]
theorem compl_iff_not (p : Prop) : pᶜ ↔ ¬p :=
  Iff.rfl
#align compl_iff_not compl_iff_not

-- See note [reducible non-instances]
/-- A bounded linear order is a bi-Heyting algebra by setting
* `a ⇨ b = ⊤` if `a ≤ b` and `a ⇨ b = b` otherwise.
* `a \ b = ⊥` if `a ≤ b` and `a \ b = a` otherwise. -/
@[reducible]
def LinearOrder.toBiheytingAlgebra [LinearOrder α] [BoundedOrder α] : BiheytingAlgebra α :=
  { LinearOrder.toLattice, ‹BoundedOrder α› with
    himp := fun a b => if a ≤ b then ⊤ else b,
    compl := fun a => if a = ⊥ then ⊤ else ⊥,
    le_himp_iff := fun a b c => by
      change _ ≤ ite _ _ _ ↔ _
      split_ifs with h
      · exact iff_of_true le_top (inf_le_of_right_le h)
      · rw [inf_le_iff, or_iff_left h],
    himp_bot := fun a => if_congr le_bot_iff rfl rfl, sdiff := fun a b => if a ≤ b then ⊥ else a,
    hnot := fun a => if a = ⊤ then ⊥ else ⊤,
    sdiff_le_iff := fun a b c => by
      change ite _ _ _ ≤ _ ↔ _
      split_ifs with h
      · exact iff_of_true bot_le (le_sup_of_le_left h)
      · rw [le_sup_iff, or_iff_right h],
    top_sdiff := fun a => if_congr top_le_iff rfl rfl }
#align linear_order.to_biheyting_algebra LinearOrder.toBiheytingAlgebra

section lift

-- See note [reducible non-instances]
/-- Pullback a `GeneralizedHeytingAlgebra` along an injection. -/
@[reducible]
protected def Function.Injective.generalizedHeytingAlgebra [Sup α] [Inf α] [Top α]
    [HImp α] [GeneralizedHeytingAlgebra β] (f : α → β) (hf : Injective f)
    (map_sup : ∀ a b, f (a ⊔ b) = f a ⊔ f b) (map_inf : ∀ a b, f (a ⊓ b) = f a ⊓ f b)
    (map_top : f ⊤ = ⊤) (map_himp : ∀ a b, f (a ⇨ b) = f a ⇨ f b) : GeneralizedHeytingAlgebra α :=
  { hf.lattice f map_sup map_inf, ‹Top α›, ‹HImp α› with
    le_top := fun a => by
      change f _ ≤ _
      rw [map_top]
      exact le_top,
    le_himp_iff := fun a b c => by
      change f _ ≤ _ ↔ f _ ≤ _
      erw [map_himp, map_inf, le_himp_iff] }
#align function.injective.generalized_heyting_algebra Function.Injective.generalizedHeytingAlgebra

-- See note [reducible non-instances]
/-- Pullback a `GeneralizedCoheytingAlgebra` along an injection. -/
@[reducible]
protected def Function.Injective.generalizedCoheytingAlgebra [Sup α] [Inf α] [Bot α]
    [SDiff α] [GeneralizedCoheytingAlgebra β] (f : α → β) (hf : Injective f)
    (map_sup : ∀ a b, f (a ⊔ b) = f a ⊔ f b) (map_inf : ∀ a b, f (a ⊓ b) = f a ⊓ f b)
    (map_bot : f ⊥ = ⊥) (map_sdiff : ∀ a b, f (a \ b) = f a \ f b) :
    GeneralizedCoheytingAlgebra α :=
  { hf.lattice f map_sup map_inf, ‹Bot α›, ‹SDiff α› with
    bot_le := fun a => by
      change f _ ≤ _
      rw [map_bot]
      exact bot_le,
    sdiff_le_iff := fun a b c => by
      change f _ ≤ _ ↔ f _ ≤ _
      erw [map_sdiff, map_sup, sdiff_le_iff] }
#align function.injective.generalized_coheyting_algebra Function.Injective.generalizedCoheytingAlgebra

-- See note [reducible non-instances]
/-- Pullback a `HeytingAlgebra` along an injection. -/
@[reducible]
protected def Function.Injective.heytingAlgebra [Sup α] [Inf α] [Top α] [Bot α]
    [HasCompl α] [HImp α] [HeytingAlgebra β] (f : α → β) (hf : Injective f)
    (map_sup : ∀ a b, f (a ⊔ b) = f a ⊔ f b) (map_inf : ∀ a b, f (a ⊓ b) = f a ⊓ f b)
    (map_top : f ⊤ = ⊤) (map_bot : f ⊥ = ⊥) (map_compl : ∀ a, f (aᶜ) = f aᶜ)
    (map_himp : ∀ a b, f (a ⇨ b) = f a ⇨ f b) : HeytingAlgebra α :=
  { hf.generalizedHeytingAlgebra f map_sup map_inf map_top map_himp, ‹Bot α›, ‹HasCompl α› with
    bot_le := fun a => by
      change f _ ≤ _
      rw [map_bot]
      exact bot_le,
    himp_bot := fun a => hf <| by erw [map_himp, map_compl, map_bot, himp_bot] }
#align function.injective.heyting_algebra Function.Injective.heytingAlgebra

-- See note [reducible non-instances]
/-- Pullback a `CoheytingAlgebra` along an injection. -/
@[reducible]
protected def Function.Injective.coheytingAlgebra [Sup α] [Inf α] [Top α] [Bot α]
    [HNot α] [SDiff α] [CoheytingAlgebra β] (f : α → β) (hf : Injective f)
    (map_sup : ∀ a b, f (a ⊔ b) = f a ⊔ f b) (map_inf : ∀ a b, f (a ⊓ b) = f a ⊓ f b)
    (map_top : f ⊤ = ⊤) (map_bot : f ⊥ = ⊥) (map_hnot : ∀ a, f (￢a) = ￢f a)
    (map_sdiff : ∀ a b, f (a \ b) = f a \ f b) : CoheytingAlgebra α :=
  { hf.generalizedCoheytingAlgebra f map_sup map_inf map_bot map_sdiff, ‹Top α›, ‹HNot α› with
    le_top := fun a => by
      change f _ ≤ _
      rw [map_top]
      exact le_top,
    top_sdiff := fun a => hf <| by erw [map_sdiff, map_hnot, map_top, top_sdiff'] }
#align function.injective.coheyting_algebra Function.Injective.coheytingAlgebra

-- See note [reducible non-instances]
/-- Pullback a `BiheytingAlgebra` along an injection. -/
@[reducible]
protected def Function.Injective.biheytingAlgebra [Sup α] [Inf α] [Top α] [Bot α]
    [HasCompl α] [HNot α] [HImp α] [SDiff α] [BiheytingAlgebra β] (f : α → β)
    (hf : Injective f) (map_sup : ∀ a b, f (a ⊔ b) = f a ⊔ f b)
    (map_inf : ∀ a b, f (a ⊓ b) = f a ⊓ f b) (map_top : f ⊤ = ⊤) (map_bot : f ⊥ = ⊥)
    (map_compl : ∀ a, f (aᶜ) = f aᶜ) (map_hnot : ∀ a, f (￢a) = ￢f a)
    (map_himp : ∀ a b, f (a ⇨ b) = f a ⇨ f b) (map_sdiff : ∀ a b, f (a \ b) = f a \ f b) :
    BiheytingAlgebra α :=
  { hf.heytingAlgebra f map_sup map_inf map_top map_bot map_compl map_himp,
    hf.coheytingAlgebra f map_sup map_inf map_top map_bot map_hnot map_sdiff with }
#align function.injective.biheyting_algebra Function.Injective.biheytingAlgebra

end lift

namespace PUnit

variable (a b : PUnit.{u + 1})

instance biheytingAlgebra : BiheytingAlgebra PUnit.{u+1} :=
  { PUnit.linearOrder.{u} with
    top := unit,
    bot := unit,
    sup := fun _ _ => unit,
    inf := fun _ _ => unit,
    compl := fun _ => unit,
    sdiff := fun _ _ => unit,
    hnot := fun _ => unit,
    himp := fun _ _ => unit,
    le_top := fun _ => trivial,
    le_sup_left := fun _ _ => trivial,
    le_sup_right := fun _ _ => trivial,
    sup_le := fun _ _ _ _ _ => trivial,
    inf_le_left := fun _ _ => trivial,
    inf_le_right := fun _ _ => trivial,
    le_inf := fun _ _ _ _ _ => trivial,
    bot_le := fun _ => trivial,
    le_himp_iff := fun _ _ _ => Iff.rfl,
    himp_bot := fun _ => rfl,
    top_sdiff := fun _ => rfl,
    sdiff_le_iff := fun _ _ _ => Iff.rfl }

@[simp]
theorem top_eq : (⊤ : PUnit) = unit :=
  rfl
#align punit.top_eq PUnit.top_eq

@[simp]
theorem bot_eq : (⊥ : PUnit) = unit :=
  rfl
#align punit.bot_eq PUnit.bot_eq

@[simp, nolint simpNF]
theorem sup_eq : a ⊔ b = unit :=
  rfl
#align punit.sup_eq PUnit.sup_eq

@[simp, nolint simpNF]
theorem inf_eq : a ⊓ b = unit :=
  rfl
#align punit.inf_eq PUnit.inf_eq

@[simp]
theorem compl_eq : aᶜ = unit :=
  rfl
#align punit.compl_eq PUnit.compl_eq

@[simp, nolint simpNF]
theorem sdiff_eq : a \ b = unit :=
  rfl
#align punit.sdiff_eq PUnit.sdiff_eq

@[simp, nolint simpNF]
theorem hnot_eq : ￢a = unit :=
  rfl
#align punit.hnot_eq PUnit.hnot_eq

-- eligible for `dsimp`
@[simp, nolint simpNF]
theorem himp_eq : a ⇨ b = unit :=
  rfl
#align punit.himp_eq PUnit.himp_eq

end PUnit