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

! This file was ported from Lean 3 source module combinatorics.derangements.finite
! leanprover-community/mathlib commit c3019c79074b0619edb4b27553a91b2e82242395
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Combinatorics.Derangements.Basic
import Mathbin.Data.Fintype.BigOperators
import Mathbin.Tactic.DeltaInstance
import Mathbin.Tactic.Ring

/-!
# Derangements on fintypes

This file contains lemmas that describe the cardinality of `derangements α` when `α` is a fintype.

# Main definitions

* `card_derangements_invariant`: A lemma stating that the number of derangements on a type `α`
    depends only on the cardinality of `α`.
* `num_derangements n`: The number of derangements on an n-element set, defined in a computation-
    friendly way.
* `card_derangements_eq_num_derangements`: Proof that `num_derangements` really does compute the
    number of derangements.
* `num_derangements_sum`: A lemma giving an expression for `num_derangements n` in terms of
    factorials.
-/

open derangements Equiv Fintype

open BigOperators

variable {α : Type _} [DecidableEq α] [Fintype α]

instance : DecidablePred (derangements α) := fun _ => Fintype.decidableForallFintype

instance : Fintype (derangements α) := by delta_instance derangements

/- warning: card_derangements_invariant -> card_derangements_invariant is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {β : Type.{u2}} [_inst_3 : Fintype.{u1} α] [_inst_4 : DecidableEq.{succ u1} α] [_inst_5 : Fintype.{u2} β] [_inst_6 : DecidableEq.{succ u2} β], (Eq.{1} Nat (Fintype.card.{u1} α _inst_3) (Fintype.card.{u2} β _inst_5)) -> (Eq.{1} Nat (Fintype.card.{u1} (coeSort.{succ u1, succ (succ u1)} (Set.{u1} (Equiv.Perm.{succ u1} α)) Type.{u1} (Set.hasCoeToSort.{u1} (Equiv.Perm.{succ u1} α)) (derangements.{u1} α)) (derangements.fintype.{u1} α (fun (a : α) (b : α) => _inst_4 a b) _inst_3)) (Fintype.card.{u2} (coeSort.{succ u2, succ (succ u2)} (Set.{u2} (Equiv.Perm.{succ u2} β)) Type.{u2} (Set.hasCoeToSort.{u2} (Equiv.Perm.{succ u2} β)) (derangements.{u2} β)) (derangements.fintype.{u2} β (fun (a : β) (b : β) => _inst_6 a b) _inst_5)))
but is expected to have type
  forall {α : Type.{u2}} {β : Type.{u1}} [_inst_3 : Fintype.{u2} α] [_inst_4 : DecidableEq.{succ u2} α] [_inst_5 : Fintype.{u1} β] [_inst_6 : DecidableEq.{succ u1} β], (Eq.{1} Nat (Fintype.card.{u2} α _inst_3) (Fintype.card.{u1} β _inst_5)) -> (Eq.{1} Nat (Fintype.card.{u2} (Set.Elem.{u2} (Equiv.Perm.{succ u2} α) (derangements.{u2} α)) (instFintypeElemPermDerangements.{u2} α (fun (a : α) (b : α) => _inst_4 a b) _inst_3)) (Fintype.card.{u1} (Set.Elem.{u1} (Equiv.Perm.{succ u1} β) (derangements.{u1} β)) (instFintypeElemPermDerangements.{u1} β (fun (a : β) (b : β) => _inst_6 a b) _inst_5)))
Case conversion may be inaccurate. Consider using '#align card_derangements_invariant card_derangements_invariantₓ'. -/
theorem card_derangements_invariant {α β : Type _} [Fintype α] [DecidableEq α] [Fintype β]
    [DecidableEq β] (h : card α = card β) : card (derangements α) = card (derangements β) :=
  Fintype.card_congr (Equiv.derangementsCongr <| equivOfCardEq h)
#align card_derangements_invariant card_derangements_invariant

/- warning: card_derangements_fin_add_two -> card_derangements_fin_add_two is a dubious translation:
lean 3 declaration is
  forall (n : Nat), Eq.{1} Nat (Fintype.card.{0} (coeSort.{1, 2} (Set.{0} (Equiv.Perm.{1} (Fin (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) n (OfNat.ofNat.{0} Nat 2 (OfNat.mk.{0} Nat 2 (bit0.{0} Nat Nat.hasAdd (One.one.{0} Nat Nat.hasOne)))))))) Type (Set.hasCoeToSort.{0} (Equiv.Perm.{1} (Fin (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) n (OfNat.ofNat.{0} Nat 2 (OfNat.mk.{0} Nat 2 (bit0.{0} Nat Nat.hasAdd (One.one.{0} Nat Nat.hasOne)))))))) (derangements.{0} (Fin (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) n (OfNat.ofNat.{0} Nat 2 (OfNat.mk.{0} Nat 2 (bit0.{0} Nat Nat.hasAdd (One.one.{0} Nat Nat.hasOne)))))))) (derangements.fintype.{0} (Fin (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) n (OfNat.ofNat.{0} Nat 2 (OfNat.mk.{0} Nat 2 (bit0.{0} Nat Nat.hasAdd (One.one.{0} Nat Nat.hasOne)))))) (fun (a : Fin (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) n (OfNat.ofNat.{0} Nat 2 (OfNat.mk.{0} Nat 2 (bit0.{0} Nat Nat.hasAdd (One.one.{0} Nat Nat.hasOne)))))) (b : Fin (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) n (OfNat.ofNat.{0} Nat 2 (OfNat.mk.{0} Nat 2 (bit0.{0} Nat Nat.hasAdd (One.one.{0} Nat Nat.hasOne)))))) => Fin.decidableEq (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) n (OfNat.ofNat.{0} Nat 2 (OfNat.mk.{0} Nat 2 (bit0.{0} Nat Nat.hasAdd (One.one.{0} Nat Nat.hasOne))))) a b) (Fin.fintype (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) n (OfNat.ofNat.{0} Nat 2 (OfNat.mk.{0} Nat 2 (bit0.{0} Nat Nat.hasAdd (One.one.{0} Nat Nat.hasOne)))))))) (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) (HMul.hMul.{0, 0, 0} Nat Nat Nat (instHMul.{0} Nat Nat.hasMul) (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) n (OfNat.ofNat.{0} Nat 1 (OfNat.mk.{0} Nat 1 (One.one.{0} Nat Nat.hasOne)))) (Fintype.card.{0} (coeSort.{1, 2} (Set.{0} (Equiv.Perm.{1} (Fin n))) Type (Set.hasCoeToSort.{0} (Equiv.Perm.{1} (Fin n))) (derangements.{0} (Fin n))) (derangements.fintype.{0} (Fin n) (fun (a : Fin n) (b : Fin n) => Fin.decidableEq n a b) (Fin.fintype n)))) (HMul.hMul.{0, 0, 0} Nat Nat Nat (instHMul.{0} Nat Nat.hasMul) (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) n (OfNat.ofNat.{0} Nat 1 (OfNat.mk.{0} Nat 1 (One.one.{0} Nat Nat.hasOne)))) (Fintype.card.{0} (coeSort.{1, 2} (Set.{0} (Equiv.Perm.{1} (Fin (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) n (OfNat.ofNat.{0} Nat 1 (OfNat.mk.{0} Nat 1 (One.one.{0} Nat Nat.hasOne))))))) Type (Set.hasCoeToSort.{0} (Equiv.Perm.{1} (Fin (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) n (OfNat.ofNat.{0} Nat 1 (OfNat.mk.{0} Nat 1 (One.one.{0} Nat Nat.hasOne))))))) (derangements.{0} (Fin (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) n (OfNat.ofNat.{0} Nat 1 (OfNat.mk.{0} Nat 1 (One.one.{0} Nat Nat.hasOne))))))) (derangements.fintype.{0} (Fin (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) n (OfNat.ofNat.{0} Nat 1 (OfNat.mk.{0} Nat 1 (One.one.{0} Nat Nat.hasOne))))) (fun (a : Fin (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) n (OfNat.ofNat.{0} Nat 1 (OfNat.mk.{0} Nat 1 (One.one.{0} Nat Nat.hasOne))))) (b : Fin (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) n (OfNat.ofNat.{0} Nat 1 (OfNat.mk.{0} Nat 1 (One.one.{0} Nat Nat.hasOne))))) => Fin.decidableEq (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) n (OfNat.ofNat.{0} Nat 1 (OfNat.mk.{0} Nat 1 (One.one.{0} Nat Nat.hasOne)))) a b) (Fin.fintype (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) n (OfNat.ofNat.{0} Nat 1 (OfNat.mk.{0} Nat 1 (One.one.{0} Nat Nat.hasOne)))))))))
but is expected to have type
  forall (n : Nat), Eq.{1} Nat (Fintype.card.{0} (Set.Elem.{0} (Equiv.Perm.{1} (Fin (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat instAddNat) n (OfNat.ofNat.{0} Nat 2 (instOfNatNat 2))))) (derangements.{0} (Fin (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat instAddNat) n (OfNat.ofNat.{0} Nat 2 (instOfNatNat 2)))))) (instFintypeElemPermDerangements.{0} (Fin (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat instAddNat) n (OfNat.ofNat.{0} Nat 2 (instOfNatNat 2)))) (fun (a : Fin (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat instAddNat) n (OfNat.ofNat.{0} Nat 2 (instOfNatNat 2)))) (b : Fin (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat instAddNat) n (OfNat.ofNat.{0} Nat 2 (instOfNatNat 2)))) => instDecidableEqFin (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat instAddNat) n (OfNat.ofNat.{0} Nat 2 (instOfNatNat 2))) a b) (Fin.fintype (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat instAddNat) n (OfNat.ofNat.{0} Nat 2 (instOfNatNat 2)))))) (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat instAddNat) (HMul.hMul.{0, 0, 0} Nat Nat Nat (instHMul.{0} Nat instMulNat) (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat instAddNat) n (OfNat.ofNat.{0} Nat 1 (instOfNatNat 1))) (Fintype.card.{0} (Set.Elem.{0} (Equiv.Perm.{1} (Fin n)) (derangements.{0} (Fin n))) (instFintypeElemPermDerangements.{0} (Fin n) (fun (a : Fin n) (b : Fin n) => instDecidableEqFin n a b) (Fin.fintype n)))) (HMul.hMul.{0, 0, 0} Nat Nat Nat (instHMul.{0} Nat instMulNat) (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat instAddNat) n (OfNat.ofNat.{0} Nat 1 (instOfNatNat 1))) (Fintype.card.{0} (Set.Elem.{0} (Equiv.Perm.{1} (Fin (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat instAddNat) n (OfNat.ofNat.{0} Nat 1 (instOfNatNat 1))))) (derangements.{0} (Fin (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat instAddNat) n (OfNat.ofNat.{0} Nat 1 (instOfNatNat 1)))))) (instFintypeElemPermDerangements.{0} (Fin (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat instAddNat) n (OfNat.ofNat.{0} Nat 1 (instOfNatNat 1)))) (fun (a : Fin (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat instAddNat) n (OfNat.ofNat.{0} Nat 1 (instOfNatNat 1)))) (b : Fin (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat instAddNat) n (OfNat.ofNat.{0} Nat 1 (instOfNatNat 1)))) => instDecidableEqFin (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat instAddNat) n (OfNat.ofNat.{0} Nat 1 (instOfNatNat 1))) a b) (Fin.fintype (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat instAddNat) n (OfNat.ofNat.{0} Nat 1 (instOfNatNat 1))))))))
Case conversion may be inaccurate. Consider using '#align card_derangements_fin_add_two card_derangements_fin_add_twoₓ'. -/
theorem card_derangements_fin_add_two (n : ℕ) :
    card (derangements (Fin (n + 2))) =
      (n + 1) * card (derangements (Fin n)) + (n + 1) * card (derangements (Fin (n + 1))) :=
  by
  -- get some basic results about the size of fin (n+1) plus or minus an element
  have h1 : ∀ a : Fin (n + 1), card ({a}ᶜ : Set (Fin (n + 1))) = card (Fin n) :=
    by
    intro a
    simp only [Fintype.card_fin, Finset.card_fin, Fintype.card_ofFinset, Finset.filter_ne' _ a,
      Set.mem_compl_singleton_iff, Finset.card_erase_of_mem (Finset.mem_univ a),
      add_tsub_cancel_right]
  have h2 : card (Fin (n + 2)) = card (Option (Fin (n + 1))) := by simp only [card_fin, card_option]
  -- rewrite the LHS and substitute in our fintype-level equivalence
  simp only [card_derangements_invariant h2,
    card_congr
      (@derangements_recursion_equiv (Fin (n + 1))
        _),-- push the cardinality through the Σ and ⊕ so that we can use `card_n`
    card_sigma,
    card_sum, card_derangements_invariant (h1 _), Finset.sum_const, nsmul_eq_mul, Finset.card_fin,
    mul_add, Nat.cast_id]
#align card_derangements_fin_add_two card_derangements_fin_add_two

#print numDerangements /-
/-- The number of derangements of an `n`-element set. -/
def numDerangements : ℕ → ℕ
  | 0 => 1
  | 1 => 0
  | n + 2 => (n + 1) * (numDerangements n + numDerangements (n + 1))
#align num_derangements numDerangements
-/

#print numDerangements_zero /-
@[simp]
theorem numDerangements_zero : numDerangements 0 = 1 :=
  rfl
#align num_derangements_zero numDerangements_zero
-/

#print numDerangements_one /-
@[simp]
theorem numDerangements_one : numDerangements 1 = 0 :=
  rfl
#align num_derangements_one numDerangements_one
-/

#print numDerangements_add_two /-
theorem numDerangements_add_two (n : ℕ) :
    numDerangements (n + 2) = (n + 1) * (numDerangements n + numDerangements (n + 1)) :=
  rfl
#align num_derangements_add_two numDerangements_add_two
-/

/- warning: num_derangements_succ -> numDerangements_succ is a dubious translation:
lean 3 declaration is
  forall (n : Nat), Eq.{1} Int ((fun (a : Type) (b : Type) [self : HasLiftT.{1, 1} a b] => self.0) Nat Int (HasLiftT.mk.{1, 1} Nat Int (CoeTCₓ.coe.{1, 1} Nat Int (coeBase.{1, 1} Nat Int Int.hasCoe))) (numDerangements (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) n (OfNat.ofNat.{0} Nat 1 (OfNat.mk.{0} Nat 1 (One.one.{0} Nat Nat.hasOne)))))) (HSub.hSub.{0, 0, 0} Int Int Int (instHSub.{0} Int Int.hasSub) (HMul.hMul.{0, 0, 0} Int Int Int (instHMul.{0} Int Int.hasMul) (HAdd.hAdd.{0, 0, 0} Int Int Int (instHAdd.{0} Int Int.hasAdd) ((fun (a : Type) (b : Type) [self : HasLiftT.{1, 1} a b] => self.0) Nat Int (HasLiftT.mk.{1, 1} Nat Int (CoeTCₓ.coe.{1, 1} Nat Int (coeBase.{1, 1} Nat Int Int.hasCoe))) n) (OfNat.ofNat.{0} Int 1 (OfNat.mk.{0} Int 1 (One.one.{0} Int Int.hasOne)))) ((fun (a : Type) (b : Type) [self : HasLiftT.{1, 1} a b] => self.0) Nat Int (HasLiftT.mk.{1, 1} Nat Int (CoeTCₓ.coe.{1, 1} Nat Int (coeBase.{1, 1} Nat Int Int.hasCoe))) (numDerangements n))) (HPow.hPow.{0, 0, 0} Int Nat Int (instHPow.{0, 0} Int Nat (Monoid.Pow.{0} Int Int.monoid)) (Neg.neg.{0} Int Int.hasNeg (OfNat.ofNat.{0} Int 1 (OfNat.mk.{0} Int 1 (One.one.{0} Int Int.hasOne)))) n))
but is expected to have type
  forall (n : Nat), Eq.{1} Int (Nat.cast.{0} Int instNatCastInt (numDerangements (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat instAddNat) n (OfNat.ofNat.{0} Nat 1 (instOfNatNat 1))))) (HSub.hSub.{0, 0, 0} Int Int Int (instHSub.{0} Int Int.instSubInt) (HMul.hMul.{0, 0, 0} Int Int Int (instHMul.{0} Int Int.instMulInt) (HAdd.hAdd.{0, 0, 0} Int Int Int (instHAdd.{0} Int Int.instAddInt) (Nat.cast.{0} Int instNatCastInt n) (OfNat.ofNat.{0} Int 1 (instOfNatInt 1))) (Nat.cast.{0} Int instNatCastInt (numDerangements n))) (HPow.hPow.{0, 0, 0} Int Nat Int (instHPow.{0, 0} Int Nat (Monoid.Pow.{0} Int Int.instMonoidInt)) (Neg.neg.{0} Int Int.instNegInt (OfNat.ofNat.{0} Int 1 (instOfNatInt 1))) n))
Case conversion may be inaccurate. Consider using '#align num_derangements_succ numDerangements_succₓ'. -/
theorem numDerangements_succ (n : ℕ) :
    (numDerangements (n + 1) : ℤ) = (n + 1) * (numDerangements n : ℤ) - (-1) ^ n :=
  by
  induction' n with n hn
  · rfl
  · simp only [numDerangements_add_two, hn, pow_succ, Int.ofNat_mul, Int.ofNat_add, Int.ofNat_succ]
    ring
#align num_derangements_succ numDerangements_succ

/- warning: card_derangements_fin_eq_num_derangements -> card_derangements_fin_eq_numDerangements is a dubious translation:
lean 3 declaration is
  forall {n : Nat}, Eq.{1} Nat (Fintype.card.{0} (coeSort.{1, 2} (Set.{0} (Equiv.Perm.{1} (Fin n))) Type (Set.hasCoeToSort.{0} (Equiv.Perm.{1} (Fin n))) (derangements.{0} (Fin n))) (derangements.fintype.{0} (Fin n) (fun (a : Fin n) (b : Fin n) => Fin.decidableEq n a b) (Fin.fintype n))) (numDerangements n)
but is expected to have type
  forall {n : Nat}, Eq.{1} Nat (Fintype.card.{0} (Set.Elem.{0} (Equiv.Perm.{1} (Fin n)) (derangements.{0} (Fin n))) (instFintypeElemPermDerangements.{0} (Fin n) (fun (a : Fin n) (b : Fin n) => instDecidableEqFin n a b) (Fin.fintype n))) (numDerangements n)
Case conversion may be inaccurate. Consider using '#align card_derangements_fin_eq_num_derangements card_derangements_fin_eq_numDerangementsₓ'. -/
theorem card_derangements_fin_eq_numDerangements {n : ℕ} :
    card (derangements (Fin n)) = numDerangements n :=
  by
  induction' n using Nat.strong_induction_on with n hyp
  obtain _ | _ | n := n; · rfl; · rfl
  -- knock out cases 0 and 1
  -- now we have n ≥ 2. rewrite everything in terms of card_derangements, so that we can use
  -- `card_derangements_fin_add_two`
  rw [numDerangements_add_two, card_derangements_fin_add_two, mul_add,
    hyp _ (Nat.lt_add_of_pos_right zero_lt_two), hyp _ (lt_add_one _)]
#align card_derangements_fin_eq_num_derangements card_derangements_fin_eq_numDerangements

/- warning: card_derangements_eq_num_derangements -> card_derangements_eq_numDerangements is a dubious translation:
lean 3 declaration is
  forall (α : Type.{u1}) [_inst_3 : Fintype.{u1} α] [_inst_4 : DecidableEq.{succ u1} α], Eq.{1} Nat (Fintype.card.{u1} (coeSort.{succ u1, succ (succ u1)} (Set.{u1} (Equiv.Perm.{succ u1} α)) Type.{u1} (Set.hasCoeToSort.{u1} (Equiv.Perm.{succ u1} α)) (derangements.{u1} α)) (derangements.fintype.{u1} α (fun (a : α) (b : α) => _inst_4 a b) _inst_3)) (numDerangements (Fintype.card.{u1} α _inst_3))
but is expected to have type
  forall (α : Type.{u1}) [_inst_3 : Fintype.{u1} α] [_inst_4 : DecidableEq.{succ u1} α], Eq.{1} Nat (Fintype.card.{u1} (Set.Elem.{u1} (Equiv.Perm.{succ u1} α) (derangements.{u1} α)) (instFintypeElemPermDerangements.{u1} α (fun (a : α) (b : α) => _inst_4 a b) _inst_3)) (numDerangements (Fintype.card.{u1} α _inst_3))
Case conversion may be inaccurate. Consider using '#align card_derangements_eq_num_derangements card_derangements_eq_numDerangementsₓ'. -/
theorem card_derangements_eq_numDerangements (α : Type _) [Fintype α] [DecidableEq α] :
    card (derangements α) = numDerangements (card α) :=
  by
  rw [← card_derangements_invariant (card_fin _)]
  exact card_derangements_fin_eq_numDerangements
#align card_derangements_eq_num_derangements card_derangements_eq_numDerangements

/- warning: num_derangements_sum -> numDerangements_sum is a dubious translation:
lean 3 declaration is
  forall (n : Nat), Eq.{1} Int ((fun (a : Type) (b : Type) [self : HasLiftT.{1, 1} a b] => self.0) Nat Int (HasLiftT.mk.{1, 1} Nat Int (CoeTCₓ.coe.{1, 1} Nat Int (coeBase.{1, 1} Nat Int Int.hasCoe))) (numDerangements n)) (Finset.sum.{0, 0} Int Nat Int.addCommMonoid (Finset.range (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) n (OfNat.ofNat.{0} Nat 1 (OfNat.mk.{0} Nat 1 (One.one.{0} Nat Nat.hasOne))))) (fun (k : Nat) => HMul.hMul.{0, 0, 0} Int Int Int (instHMul.{0} Int Int.hasMul) (HPow.hPow.{0, 0, 0} Int Nat Int (instHPow.{0, 0} Int Nat (Monoid.Pow.{0} Int Int.monoid)) (Neg.neg.{0} Int Int.hasNeg (OfNat.ofNat.{0} Int 1 (OfNat.mk.{0} Int 1 (One.one.{0} Int Int.hasOne)))) k) ((fun (a : Type) (b : Type) [self : HasLiftT.{1, 1} a b] => self.0) Nat Int (HasLiftT.mk.{1, 1} Nat Int (CoeTCₓ.coe.{1, 1} Nat Int (coeBase.{1, 1} Nat Int Int.hasCoe))) (Nat.ascFactorial k (HSub.hSub.{0, 0, 0} Nat Nat Nat (instHSub.{0} Nat Nat.hasSub) n k)))))
but is expected to have type
  forall (n : Nat), Eq.{1} Int (Nat.cast.{0} Int instNatCastInt (numDerangements n)) (Finset.sum.{0, 0} Int Nat Int.instAddCommMonoidInt (Finset.range (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat instAddNat) n (OfNat.ofNat.{0} Nat 1 (instOfNatNat 1)))) (fun (k : Nat) => HMul.hMul.{0, 0, 0} Int Int Int (instHMul.{0} Int Int.instMulInt) (HPow.hPow.{0, 0, 0} Int Nat Int Int.instHPowIntNat (Neg.neg.{0} Int Int.instNegInt (OfNat.ofNat.{0} Int 1 (instOfNatInt 1))) k) (Nat.cast.{0} Int instNatCastInt (Nat.ascFactorial k (HSub.hSub.{0, 0, 0} Nat Nat Nat (instHSub.{0} Nat instSubNat) n k)))))
Case conversion may be inaccurate. Consider using '#align num_derangements_sum numDerangements_sumₓ'. -/
theorem numDerangements_sum (n : ℕ) :
    (numDerangements n : ℤ) =
      ∑ k in Finset.range (n + 1), (-1 : ℤ) ^ k * Nat.ascFactorial k (n - k) :=
  by
  induction' n with n hn; · rfl
  rw [Finset.sum_range_succ, numDerangements_succ, hn, Finset.mul_sum, tsub_self,
    Nat.ascFactorial_zero, Int.ofNat_one, mul_one, pow_succ, neg_one_mul, sub_eq_add_neg,
    add_left_inj, Finset.sum_congr rfl]
  -- show that (n + 1) * (-1)^x * asc_fac x (n - x) = (-1)^x * asc_fac x (n.succ - x)
  intro x hx
  have h_le : x ≤ n := finset.mem_range_succ_iff.mp hx
  rw [Nat.succ_sub h_le, Nat.ascFactorial_succ, add_tsub_cancel_of_le h_le, Int.ofNat_mul,
    Int.ofNat_succ, mul_left_comm]
#align num_derangements_sum numDerangements_sum


class magma (α) where op : α → α → α

infix:70 " ⋆ " => magma.op (self := inferInstance)

class leftIdMagma (α) extends magma α where
  identity : α
  id_op (a : α) : identity ⋆ a = a := by intros; rfl

class rightIdMagma (α) extends magma α where
  identity : α
  op_id (a : α) : a ⋆ identity = a := by intros; rfl

class semigroup (α) extends magma α where
  assoc (a b c : α) : (a ⋆ b) ⋆ c = a ⋆ (b ⋆ c) := by intros; rfl

class idMagma (α) extends leftIdMagma α, rightIdMagma α

class monoid (α) extends idMagma α, semigroup α

def magmaMonoid : leftIdMagma (base → base) := {
  op := Function.comp
  identity := id
}

def fnCompMonoid : monoid (base → base) := {
  op := Function.comp, identity := id
}

namespace Ex2

structure A (α) where
  subsingleton : ∀ a b : α, a = b := by assumption

structure B (α) where
  op : α → α → α
  idempotent : ∀ a : α, op a a = a := by assumption
  fav : α := by assumption

structure C (α) where
  op : α → α → α
  comm : ∀ a b : α, op a b = op b a := by assumption

structure D (α) extends A α, B α
structure E (α) extends C α, B α

-- Let's reuse these
theorem s (a b : Unit) : a = b := rfl
def op (_ _ : Unit) : Unit := ()
def i (a : Unit) : op a a = a := s _ a
def c (a b : Unit) : op a b = op b a := s _ _

-- Successfully defined
def d : D Unit := have := s; have := i; have := ()
                  { op }

def e : E Unit := have := c; have := i; have := ()
                  { op }

structure F (α) extends D α, E α
structure G (α) extends E α, D α

def f : F Unit := have := s; have := i; have := c; have := ()
                  { op }
-- `idempotent`, `fav` missing
def g : G Unit := have := s; have := i; have := c; have := ()
                  { op }

end Ex2


import data.real.basic

theorem Q4a : ¬ (∀ (x y : ℝ), M1F.is_irrational x → M1F.is_irrational y → M1F.is_irrational (x+y)) := sorry

theorem Q4b : ¬ (∀ (a : ℝ), ∀ (b : ℚ), M1F.is_irrational a → M1F.is_irrational (a*b)) := sorry


/-
Copyright (c) 2022 Devon Tuma. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Devon Tuma
-/
import computational_monads.support.support
import to_mathlib.general

/-!
# Support of an Oracle Computation as a Finset

This file gives an alternative definition of the support of an `oracle_comp`.
Instead of a `set` as with `oracle_comp.support`, we introduce a definition
  `oracle_comp.fin_support` which gives the support as a `finset`.
The resulting `finset` is equal to `oracle_comp.support` when coerced to a `set`,
  see `fin_support_eq_support`.

This requires a number of decidability hypotheses for the computation itself.
The need for `oracle_comp.decidable` arises from the need to use `finset.bUnion` for `bind'`.
This could be avoided by including a `decidable_eq` requirement of the `pure'` constructor,
but this partially destrays the monad structure of `oracle_comp`.
-/

namespace oracle_comp

open oracle_spec decidable

variables {α β γ : Type} {spec spec' : oracle_spec}

/-- Compute an explicit `finset` of the elements in `support`,
assuming a `decidable` instance on the `oracle_comp` itself (for `finset.bUnion`). -/
def fin_support : Π {α : Type} (oa : oracle_comp spec α) [decidable oa], finset α
| _ _ (decidable_pure' α a h) := {a}
| _ _ (decidable_bind' α β oa ob hoa hob) :=
  have hβ : decidable_eq β := decidable_eq_of_decidable' (hob $ (inhabited_base oa).1),
  @finset.bUnion α β hβ (@fin_support α oa hoa) (λ a, @fin_support β (ob a) (hob a))
| _ _ (decidable_query i t) := finset.univ

section support

variables (oa : oracle_comp spec α) (oa' : oracle_comp spec' α) [decidable oa] [decidable oa']
  (a : α) (s : finset α)

/-- Correctness of `fin_support` with respect to `support`, i.e. the two are equal as `set` -/
theorem mem_fin_support_iff_mem_support : Π {α : Type} (oa : oracle_comp spec α)
  [hoa : decidable oa] (a : α), a ∈ (@fin_support _ _ _ hoa) ↔ a ∈ oa.support
| _ _ (decidable_pure' α a h) α' :=
    by simp [finset.coe_singleton α, support, fin_support]
| _ _ (decidable_bind' α β oa ob hoa hob) b :=
    by simp [fin_support, support,mem_fin_support_iff_mem_support]
| _ _ (decidable_query i t) u :=
    by simp [support, fin_support]

lemma fin_support_eq_to_finset : oa.fin_support = oa.support.to_finset :=
finset.ext (λ x, by simp only [mem_fin_support_iff_mem_support, set.mem_to_finset])

@[simp] theorem coe_fin_support_eq_support : ↑oa.fin_support = oa.support :=
set.ext (λ a, (mem_fin_support_iff_mem_support oa a))

lemma fin_support_eq_iff_support_eq_coe : oa.fin_support = s ↔ oa.support = ↑s :=
by rw [← coe_fin_support_eq_support, finset.coe_inj]

lemma fin_support_eq_fin_support_iff_support_eq_support :
  oa.fin_support = oa'.fin_support ↔ oa.support = oa'.support :=
by rw [fin_support_eq_iff_support_eq_coe, coe_fin_support_eq_support]

lemma fin_support_subset_iff_support_subset_coe : oa.fin_support ⊆ s ↔ oa.support ⊆ ↑s :=
by rw [← finset.coe_subset, coe_fin_support_eq_support]

lemma subset_fin_support_iff_coe_subset_support : s ⊆ oa.fin_support ↔ ↑s ⊆ oa.support :=
by rw [← finset.coe_subset, coe_fin_support_eq_support]

lemma support_subset_coe_fin_support : oa.support ⊆ ↑oa.fin_support :=
by rw [coe_fin_support_eq_support oa]

lemma coe_fin_support_subset_support : ↑oa.fin_support ⊆ oa.support :=
by rw [coe_fin_support_eq_support oa]

end support

section return

variables [decidable_eq α] (a x : α)

@[simp] lemma fin_support_return : (return a : oracle_comp spec α).fin_support = {a} := rfl

lemma mem_fin_support_return_iff : x ∈ (return a : oracle_comp spec α).fin_support ↔ x = a :=
finset.mem_singleton

lemma mem_fin_support_return_self : x ∈ (return x : oracle_comp spec α).fin_support :=
finset.mem_singleton_self x

@[simp] lemma fin_support_pure' : (pure' α a : oracle_comp spec α).fin_support = {a} := rfl

lemma mem_fin_support_pure'_iff : x ∈ (pure' α a : oracle_comp spec α).fin_support ↔ x = a :=
finset.mem_singleton

lemma mem_fin_support_pure'_self : x ∈ (pure' α x : oracle_comp spec α).fin_support :=
finset.mem_singleton_self x

lemma fin_support_pure : (pure a : oracle_comp spec α).fin_support = {a} := rfl

lemma mem_fin_support_pure_iff : x ∈ (pure a : oracle_comp spec α).fin_support ↔ x = a :=
finset.mem_singleton

lemma mem_fin_support_pure_self : x ∈ (pure x : oracle_comp spec α).fin_support :=
finset.mem_singleton_self x

end return

section bind

variables (oa : oracle_comp spec α) (ob : α → oracle_comp spec β)
  [decidable oa] [∀ a, decidable (ob a)] (y : β)

@[simp] lemma fin_support_bind : (oa >>= ob).fin_support = @finset.bUnion α β
  (decidable_eq_of_decidable (oa >>= ob)) oa.fin_support (λ a, (ob a).fin_support) :=
by simp only [fin_support_eq_iff_support_eq_coe, support_bind,
  finset.coe_bUnion, coe_fin_support_eq_support]

lemma mem_fin_support_bind_iff : y ∈ (oa >>= ob).fin_support ↔
  ∃ x ∈ oa.fin_support, y ∈ (ob x).fin_support :=
by rw [fin_support_bind, finset.mem_bUnion]

@[simp] lemma fin_support_bind' : (bind' α β oa ob).fin_support = @finset.bUnion α β
  (decidable_eq_of_decidable (oa >>= ob)) oa.fin_support (λ a, (ob a).fin_support) :=
fin_support_bind oa ob

lemma mem_fin_support_bind'_iff : y ∈ (bind' α β oa ob).fin_support ↔
  ∃ x ∈ oa.fin_support, y ∈ (ob x).fin_support :=
mem_fin_support_bind_iff oa ob y

end bind

section query

variables (i : spec.ι) (t : spec.domain i) (u : spec.range i)

@[simp] lemma fin_support_query : (query i t).fin_support = ⊤ := rfl

lemma mem_fin_support_query : u ∈ (query i t).fin_support := finset.mem_univ u

end query

end oracle_comp


/-
Copyright (c) 2017 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura
-/
import data.rbtree.basic
universe u

namespace rbnode
variables {α : Type u} {lt : α → α → Prop}

lemma mem_of_min_eq (lt : α → α → Prop) [is_irrefl α lt] {a : α} {t : rbnode α} :
  t.min = some a → mem lt a t :=
begin
  induction t,
  { intros, contradiction },
  all_goals
  { cases t_lchild; simp [rbnode.min]; intro h,
    { subst t_val, simp [mem, irrefl_of lt a] },
    all_goals { rw [mem], simp [t_ih_lchild h] } }
end

lemma mem_of_max_eq (lt : α → α → Prop) [is_irrefl α lt] {a : α} {t : rbnode α} :
  t.max = some a → mem lt a t :=
begin
  induction t,
  { intros, contradiction },
  all_goals
  { cases t_rchild; simp [rbnode.max]; intro h,
    { subst t_val, simp [mem, irrefl_of lt a] },
    all_goals { rw [mem], simp [t_ih_rchild h] } }
end

variables [is_strict_weak_order α lt]

lemma eq_leaf_of_min_eq_none {t : rbnode α} : t.min = none → t = leaf :=
begin
  induction t,
  { intros, refl },
  all_goals
  { cases t_lchild; simp [rbnode.min, false_implies_iff]; intro h,
    all_goals { have := t_ih_lchild h, contradiction } }
end

lemma eq_leaf_of_max_eq_none {t : rbnode α} : t.max = none → t = leaf :=
begin
  induction t,
  { intros, refl },
  all_goals
  { cases t_rchild; simp [rbnode.max, false_implies_iff]; intro h,
    all_goals { have := t_ih_rchild h, contradiction } }
end

lemma min_is_minimal {a : α} {t : rbnode α} :
  ∀ {lo hi}, is_searchable lt t lo hi → t.min = some a → ∀ {b}, mem lt b t → a ≈[lt] b ∨ lt a b :=
begin
  classical,
  induction t,
  { simp [strict_weak_order.equiv], intros _ _ hs hmin b, contradiction },
  all_goals
  { cases t_lchild; intros lo hi hs hmin b hmem,
    { simp [rbnode.min] at hmin, subst t_val,
      simp [mem] at hmem, cases hmem with heqv hmem,
      { left, exact heqv.swap },
      { have := lt_of_mem_right hs (by constructor) hmem,
        right, assumption } },
    all_goals
    { have hs' := hs,
      cases hs, simp [rbnode.min] at hmin,
      rw [mem] at hmem, blast_disjs,
      { exact t_ih_lchild hs_hs₁ hmin hmem },
      { have hmm       := mem_of_min_eq lt hmin,
        have a_lt_val  := lt_of_mem_left hs' (by constructor) hmm,
        have a_lt_b    := lt_of_lt_of_incomp a_lt_val hmem.swap,
        right, assumption },
      { have hmm       := mem_of_min_eq lt hmin,
        have a_lt_b    := lt_of_mem_left_right hs' (by constructor) hmm hmem,
        right, assumption } } }
end

lemma max_is_maximal {a : α} {t : rbnode α} :
  ∀ {lo hi}, is_searchable lt t lo hi → t.max = some a → ∀ {b}, mem lt b t → a ≈[lt] b ∨ lt b a :=
begin
  classical,
  induction t,
  { simp [strict_weak_order.equiv], intros _ _ hs hmax b, contradiction },
  all_goals
  { cases t_rchild; intros lo hi hs hmax b hmem,
    { simp [rbnode.max] at hmax, subst t_val,
      simp [mem] at hmem, cases hmem with hmem heqv,
      { have := lt_of_mem_left hs (by constructor) hmem,
        right, assumption },
      { left, exact heqv.swap } },
    all_goals
    { have hs' := hs,
      cases hs, simp [rbnode.max] at hmax,
      rw [mem] at hmem, blast_disjs,
      { have hmm       := mem_of_max_eq lt hmax,
        have a_lt_b    := lt_of_mem_left_right hs' (by constructor) hmem hmm,
        right, assumption },
      { have hmm       := mem_of_max_eq lt hmax,
        have val_lt_a  := lt_of_mem_right hs' (by constructor) hmm,
        have a_lt_b    := lt_of_incomp_of_lt hmem val_lt_a,
        right, assumption },
      { exact t_ih_rchild hs_hs₂ hmax hmem } } }
end

end rbnode


/-
Copyright (c) 2021 OpenAI. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kunhao Zheng, Stanislas Polu, David Renshaw, OpenAI GPT-f
-/
import mathzoo.imports.miniF2F

open_locale nat rat real big_operators topological_space

theorem mathd_algebra_412
  (x y : ℝ)
  (h₀ : x + y = 25)
  (h₁ : x - y = 11) :
  x = 18 :=
begin
  linarith,
end


import .lovelib

/-! # LoVe Homework 7: Metaprogramming

Homework must be done individually. -/

set_option pp.beta true
set_option pp.generalized_field_notation false

namespace LoVe

/-! ## Question 1 (9 points): A `mindless` Tactic

We develop a tactic that automates some of the mindless `intro`/`apply`
proofs that formed the core of lecture 2.

We proceed in three steps.

1.1 (6 points). Develop a `mindless_safe` tactic that applies the
introduction rules for `true`, `∧`, and `↔`, that invokes `tactic.intro` (or
`tactic.intro1`) for `→`/`∀`, and that invokes `tactic.assumption`, repeatedly
on all goals. The tactic generalizes `intro_ands` from the exercise.

Hint: You can use the `<|>` operator between the rules/tactics used for
different symbols. -/

#check tactic.repeat
#check tactic.applyc
#check tactic.intro
#check tactic.intro1

meta def mindless_safe : tactic unit :=
tactic.repeat
  (tactic.applyc `true.intro
   <|> tactic.applyc `and.intro
   <|> tactic.applyc `iff.intro
   <|> (do tactic.intro1, pure ())
   <|> tactic.assumption)

lemma abcd (a b c d : Prop) (hc : c) :
  a → ¬ b ∧ (c ↔ d) :=
begin
  mindless_safe,
  /- The proof state should be roughly as follows:

  a b c d : Prop,
  hc : c,
  a_1 : a,
  a_2 : b
  ⊢ false

  a b c d : Prop,
  hc : c,
  a_1 : a,
  a_2 : c
  ⊢ d -/
  repeat { sorry }
end

/-! 1.2 (3 points). Develop a `mindless_unsafe` tactic that works on the current
goal. For each hypothesis in turn:

1. It first tries to apply the hypothesis in turn using `tactic.apply`.

2. If this does not fail, it invokes some `continue` tactic, which is passed as
   argument.

3. If this does not fail, it invokes `tactic.done`, which succeeds only if there
   are no goals left.

Once a hypothesis has been found for which steps 1 to 3 succeed,
`mindless_unsafe` succeeds. -/

meta def mindless_unsafe (continue : tactic unit) : tactic unit :=
do
  hs ← tactic.local_context,
  list.mfirst (λh, do tactic.apply h, continue, tactic.done) hs

/-! A few tests follow. -/

lemma modus_ponens (a b : Prop) (ha : a) (hab : a → b) :
  b :=
by mindless_unsafe tactic.assumption

lemma junky_modus_ponens (a b c d : Prop) (ha : a) (hcb : c → b) (hab : a → b)
    (hdb : d → b) :
  b :=
by mindless_unsafe tactic.assumption

lemma refl_modus_ponens (n : ℕ) (b : Prop) (hnnb : n = n → b) :
  b :=
by mindless_unsafe tactic.reflexivity

/-! Finally, everything comes together with the `mindless` tactic below. The
tactic performs a depth-bounded search for a proof, applying `mindless_safe`
and `mindless_unsafe` on all goals in alternation. The bound is necessary to
eventually backtrack. -/

meta def mindless : ℕ → tactic unit
| 0           := mindless_safe
| (depth + 1) :=
  do
    mindless_safe,
    tactic.all_goals (tactic.try (mindless_unsafe (mindless depth))),
    pure ()

/-! Some tests are provided below. All should succeed. -/

lemma I (a : Prop) :
  a → a :=
by mindless 0

lemma K (a b : Prop) :
  a → b → b :=
by mindless 0

lemma C (a b c : Prop) :
  (a → b → c) → b → a → c :=
by mindless 1

lemma proj_1st (a : Prop) :
  a → a → a :=
by mindless 0

lemma some_nonsense (a b c : Prop) :
  (a → b → c) → a → (a → c) → b → c :=
by mindless 1

lemma contrapositive (a b : Prop) :
  (a → b) → ¬ b → ¬ a :=
by mindless 2

lemma B (a b c : Prop) :
  (a → b) → (c → a) → c → b :=
by mindless 2

lemma S (a b c : Prop) :
  (a → b → c) → (a → b) → a → c :=
by mindless 2

lemma more_nonsense (a b c : Prop) :
  (c → (a → b) → a) → c → b → a :=
by mindless 1

lemma even_more_nonsense (a b c : Prop) :
  (a → a → b) → (b → c) → a → b → c :=
by mindless 1

lemma weak_peirce (a b : Prop) :
  ((((a → b) → a) → a) → b) → b :=
by mindless 3

lemma one_for_the_road (a c : Prop) (ha : a) (hccc : c → c → c) (hac : a → c) :
  c :=
by mindless 1

/-! ## Question 2 (2 bonus points): An `auto` Tactic

2.1 (1 bonus point). Develop an Isabelle-style `auto` tactic.

This tactic would apply all harmless introduction and elimination rules. In
addition, it would try potentially harmful rules (such as `or.intro_left` and
`false.elim`) but backtrack at some point (or try several possibilities in
parallel). Iterative deepening may be a valid approach, or best-first search, or
breadth-first search. The tactic should also attempt to apply assumptions whose
conclusion matches the goal, but backtrack if necessary.

See also "Automatic Proof and Disproof in Isabelle/HOL"
(https://www.cs.vu.nl/~jbe248/frocos2011-dis-proof.pdf) by Blanchette, Bulwahn,
and Nipkow, and the references they give.

2.2 (1 bonus point). Test your tactic on some benchmarks.

You can try your tactic on logic puzzles of the kinds we proved in exercise 2
and homework 2. Please include these below. -/

end LoVe


/-
Copyright (c) 2018 Sébastien Gouëzel. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Sébastien Gouëzel
Adapted from the corresponding theory for complete lattices.

Theory of conditionally complete lattices.

A conditionally complete lattice is a lattice in which every non-empty bounded subset s
has a least upper bound and a greatest lower bound, denoted below by Sup s and Inf s.
Typical examples are real, nat, int with their usual orders.

The theory is very comparable to the theory of complete lattices, except that suitable
boundedness and non-emptyness assumptions have to be added to most statements.
We introduce two predicates bdd_above and bdd_below to express this boundedness, prove
their basic properties, and then go on to prove most useful properties of Sup and Inf
in conditionally complete lattices.

To differentiate the statements between complete lattices and conditionally complete
lattices, we prefix Inf and Sup in the statements by c, giving cInf and cSup. For instance,
Inf_le is a statement in complete lattices ensuring Inf s ≤ x, while cInf_le is the same
statement in conditionally complete lattices with an additional assumption that s is
bounded below.
-/
import
  order.lattice order.complete_lattice order.bounds
  tactic.finish data.set.countable

set_option old_structure_cmd true

open preorder set lattice

universes u v
variables {α : Type u} {β : Type v}

section preorder
variables [preorder α] {s t : set α} {a b : α}

/-Sets bounded above and bounded below.-/
def bdd_above (s : set α) := ∃x, ∀y∈s, y ≤ x
def bdd_below (s : set α) := ∃x, ∀y∈s, x ≤ y

/-Introduction rules for boundedness above and below.
Most of the time, it is more efficient to use ⟨w, P⟩ where P is a proof
that all elements of the set are bounded by w. However, they are sometimes handy.-/
lemma bdd_above.mk (a : α) (H : ∀y∈s, y≤a) : bdd_above s := ⟨a, H⟩
lemma bdd_below.mk (a : α) (H : ∀y∈s, a≤y) : bdd_below s := ⟨a, H⟩

/-Empty sets and singletons are trivially bounded. For finite sets, we need
a notion of maximum and minimum, i.e., a lattice structure, see later on.-/
@[simp] lemma bdd_above_empty [inhabited α] : bdd_above (∅ : set α) :=
⟨default α, by simp⟩

@[simp] lemma bdd_below_empty [inhabited α] : bdd_below (∅ : set α) :=
⟨default α, by simp⟩

@[simp] lemma bdd_above_singleton : bdd_above ({a} : set α) :=
⟨a, by simp⟩

@[simp] lemma bdd_below_singleton : bdd_below ({a} : set α) :=
⟨a, by simp⟩

/-If a set is included in another one, boundedness of the second implies boundedness
of the first-/
lemma bdd_above_subset (_ : s ⊆ t) (_ : bdd_above t) : bdd_above s :=
let ⟨w, hw⟩ := ‹bdd_above t› in  /-hw : ∀ (y : α), y ∈ t → y ≤ w-/
⟨w, assume (y : α) (_ : y ∈ s), hw _ (‹s ⊆ t› ‹y ∈ s›)⟩

lemma bdd_below_subset (_ : s ⊆ t) (_ : bdd_below t) : bdd_below s :=
let ⟨w, hw⟩ := ‹bdd_below t› in  /-hw : ∀ (y : α), y ∈ t → w ≤ y-/
⟨w, assume (y : α) (_ : y ∈ s), hw _ (‹s ⊆ t› ‹y ∈ s›)⟩

/- Boundedness of intersections of sets, in different guises, deduced from the
monotonicity of boundedness.-/
lemma bdd_above_Int1 (_ : bdd_above s) : bdd_above (s ∩ t) :=
by apply bdd_above_subset _ ‹bdd_above s›; simp

lemma bdd_above_Int2 (_ : bdd_above t) : bdd_above (s ∩ t) :=
by apply bdd_above_subset _ ‹bdd_above t›; simp

lemma bdd_below_Int1 (_ : bdd_below s) : bdd_below (s ∩ t) :=
by apply bdd_below_subset _ ‹bdd_below s›; simp

lemma bdd_below_Int2 (_ : bdd_below t) : bdd_below (s ∩ t) :=
by apply bdd_below_subset _ ‹bdd_below t›; simp

end preorder

/--When there is a global maximum, every set is bounded above.-/
@[simp] lemma bdd_above_top [order_top α] (s : set α) : bdd_above s :=
⟨⊤, by intros; apply order_top.le_top⟩

/--When there is a global minimum, every set is bounded below.-/
@[simp] lemma bdd_below_bot [order_bot α] (s : set α): bdd_below s :=
⟨⊥, by intros; apply order_bot.bot_le⟩

/-When there is a max (i.e., in the class semilattice_sup), then the union of
two bounded sets is bounded, by the maximum of the bounds for the two sets.
With this, we deduce that finite sets are bounded by induction, and that a finite
union of bounded sets is bounded.-/
section semilattice_sup
variables [semilattice_sup α] {s t : set α} {a b : α}

/--The union of two sets is bounded above if and only if each of the sets is.-/
@[simp] lemma bdd_above_union : bdd_above (s ∪ t) ↔ bdd_above s ∧ bdd_above t :=
⟨show bdd_above (s ∪ t) → (bdd_above s ∧ bdd_above t), from
  assume : bdd_above (s ∪ t),
  have S : bdd_above s, by apply bdd_above_subset _ ‹bdd_above (s ∪ t)›; simp,
  have T : bdd_above t, by apply bdd_above_subset _ ‹bdd_above (s ∪ t)›; simp,
  and.intro S T,
show (bdd_above s ∧ bdd_above t) → bdd_above (s ∪ t), from
  assume H : bdd_above s ∧ bdd_above t,
  let ⟨⟨ws, hs⟩, ⟨wt, ht⟩⟩ := H in
    /-hs : ∀ (y : α), y ∈ s → y ≤ ws      ht : ∀ (y : α), y ∈ s → y ≤ wt-/
  have Bs : ∀b∈s, b ≤ ws ⊔ wt,
    by intros; apply le_trans (hs b ‹b ∈ s›) _; simp,
  have Bt : ∀b∈t, b ≤ ws ⊔ wt,
    by intros; apply le_trans (ht b ‹b ∈ t›) _; simp,
  show bdd_above (s ∪ t),
    begin
    apply bdd_above.mk (ws ⊔ wt),
    intros b H_1,
    cases H_1,
    apply Bs _ ‹b ∈ s›,
    apply Bt _ ‹b ∈ t›,
    end⟩

/--Adding a point to a set preserves its boundedness above.-/
@[simp] lemma bdd_above_insert : bdd_above (insert a s) ↔ bdd_above s :=
⟨show bdd_above (insert a s) → bdd_above s, from bdd_above_subset (by simp),
 show bdd_above s → bdd_above (insert a s), by rw [insert_eq]; simp [-singleton_union] {contextual := tt}⟩

/--A finite set is bounded above.-/
lemma bdd_above_finite [inhabited α] (_ : finite s) : bdd_above s :=
by apply finite.induction_on ‹finite s›; simp; simp

/--A finite union of sets which are all bounded above is still bounded above.-/
lemma bdd_above_finite_union [inhabited α] {β : Type v} {I : set β} {S : β → set α} (H : finite I) :
(bdd_above (⋃i∈I, S i)) ↔ (∀i ∈ I, bdd_above (S i)) :=
⟨show (bdd_above (⋃i∈I, S i)) → (∀i ∈ I, bdd_above (S i)), by
  intros;
  apply bdd_above_subset _ ‹bdd_above (⋃i∈I, S i)›;
  apply subset_bUnion_of_mem ‹i ∈ I›,
show (∀i ∈ I, bdd_above (S i)) → (bdd_above (⋃i∈I, S i)),
  by apply finite.induction_on ‹finite I›; simp; finish⟩

end semilattice_sup

/-When there is a min (i.e., in the class semilattice_inf), then the union of
two sets which are bounded from below is bounded from below, by the minimum of
the bounds for the two sets. With this, we deduce that finite sets are
bounded below by induction, and that a finite union of sets which are bounded below
is still bounded below.-/

section semilattice_inf
variables [semilattice_inf α] {s t : set α} {a b : α}

/--The union of two sets is bounded below if and only if each of the sets is.-/
@[simp] lemma bdd_below_union : bdd_below (s ∪ t) ↔ bdd_below s ∧ bdd_below t :=
⟨show bdd_below (s ∪ t) → (bdd_below s ∧ bdd_below t), from
  assume : bdd_below (s ∪ t),
  have S : bdd_below s, by apply bdd_below_subset _ ‹bdd_below (s ∪ t)›; simp,
  have T : bdd_below t, by apply bdd_below_subset _ ‹bdd_below (s ∪ t)›; simp,
  and.intro S T,
show (bdd_below s ∧ bdd_below t) → bdd_below (s ∪ t), from
  assume H : bdd_below s ∧ bdd_below t,
  let ⟨⟨ws, hs⟩, ⟨wt, ht⟩⟩ := H in
    /-hs : ∀ (y : α), y ∈ s → ws ≤ y      ht : ∀ (y : α), y ∈ s → wt ≤ y-/
  have Bs : ∀b∈s, ws ⊓ wt ≤ b,
    by intros; apply le_trans _ (hs b ‹b ∈ s›); simp,
  have Bt : ∀b∈t, ws ⊓ wt ≤ b,
    by intros; apply le_trans _ (ht b ‹b ∈ t›); simp,
  show bdd_below (s ∪ t),
    begin
    apply bdd_below.mk (ws ⊓ wt),
    intros b H_1,
    cases H_1,
    apply Bs _ ‹b ∈ s›,
    apply Bt _ ‹b ∈ t›,
    end⟩

/--Adding a point to a set preserves its boundedness below.-/
@[simp] lemma bdd_below_insert : bdd_below (insert a s) ↔ bdd_below s :=
⟨show bdd_below (insert a s) → bdd_below s, from bdd_below_subset (by simp),
 show bdd_below s → bdd_below (insert a s), by rw[insert_eq]; simp [-singleton_union] {contextual := tt}⟩

/--A finite set is bounded below.-/
lemma bdd_below_finite [inhabited α] (_ : finite s) : bdd_below s :=
by apply finite.induction_on ‹finite s›; simp; simp

/--A finite union of sets which are all bounded below is still bounded below.-/
lemma bdd_below_finite_union [inhabited α] {β : Type v} {I : set β} {S : β → set α} (H : finite I) :
(bdd_below (⋃i∈I, S i)) ↔ (∀i ∈ I, bdd_below (S i)) :=
⟨show (bdd_below (⋃i∈I, S i)) → (∀i ∈ I, bdd_below (S i)), by
  intros;
  apply bdd_below_subset _ ‹bdd_below (⋃i∈I, S i)›;
  apply subset_bUnion_of_mem ‹i ∈ I›,
show (∀i ∈ I, bdd_below (S i)) → (bdd_below (⋃i∈I, S i)),
  by apply finite.induction_on ‹finite I›; simp; finish⟩

end semilattice_inf

namespace lattice
/-- A conditionally complete lattice is a lattice in which
every nonempty subset which is bounded above has a supremum, and
every nonempty subset which is bounded below has an infimum.
Typical examples are real numbers or natural numbers.

To differentiate the statements from the corresponding statements in (unconditional)
complete lattices, we prefix Inf and Sup by a c everywhere. The same statements should
hold in both worlds, sometimes with additional assumptions of non-emptyness or
boundedness.-/
class conditionally_complete_lattice (α : Type u) extends lattice α, has_Sup α, has_Inf α :=
(le_cSup : ∀s a, bdd_above s → a ∈ s → a ≤ Sup s)
(cSup_le : ∀s a, s ≠ ∅ → (∀b∈s, b ≤ a) → Sup s ≤ a)
(cInf_le : ∀s a, bdd_below s → a ∈ s → Inf s ≤ a)
(le_cInf : ∀s a, s ≠ ∅ → (∀b∈s, a ≤ b) → a ≤ Inf s)

class conditionally_complete_linear_order (α : Type u)
  extends conditionally_complete_lattice α, linear_order α

class conditionally_complete_linear_order_bot (α : Type u)
  extends conditionally_complete_lattice α, linear_order α, order_bot α :=
(cSup_empty : Sup ∅ = ⊥)

/- A complete lattice is a conditionally complete lattice, as there are no restrictions
on the properties of Inf and Sup in a complete lattice.-/

instance conditionally_complete_lattice_of_complete_lattice [complete_lattice α]:
  conditionally_complete_lattice α :=
{ le_cSup := by intros; apply le_Sup; assumption,
  cSup_le := by intros; apply Sup_le; assumption,
  cInf_le := by intros; apply Inf_le; assumption,
  le_cInf := by intros; apply le_Inf; assumption,
  ..‹complete_lattice α›}

instance conditionally_complete_linear_order_of_complete_linear_order [complete_linear_order α]:
  conditionally_complete_linear_order α :=
{ ..lattice.conditionally_complete_lattice_of_complete_lattice, .. ‹complete_linear_order α› }

section conditionally_complete_lattice
variables [conditionally_complete_lattice α] {s t : set α} {a b : α}

theorem le_cSup (h₁ : bdd_above s) (h₂ : a ∈ s) : a ≤ Sup s :=
conditionally_complete_lattice.le_cSup s a h₁ h₂

theorem cSup_le (h₁ : s ≠ ∅) (h₂ : ∀b∈s, b ≤ a) : Sup s ≤ a :=
conditionally_complete_lattice.cSup_le s a h₁ h₂

theorem cInf_le (h₁ : bdd_below s) (h₂ : a ∈ s) : Inf s ≤ a :=
conditionally_complete_lattice.cInf_le s a h₁ h₂

theorem le_cInf (h₁ : s ≠ ∅) (h₂ : ∀b∈s, a ≤ b) : a ≤ Inf s :=
conditionally_complete_lattice.le_cInf s a h₁ h₂

theorem le_cSup_of_le (_ : bdd_above s) (hb : b ∈ s) (h : a ≤ b) : a ≤ Sup s :=
le_trans h (le_cSup ‹bdd_above s› hb)

theorem cInf_le_of_le (_ : bdd_below s) (hb : b ∈ s) (h : b ≤ a) : Inf s ≤ a :=
le_trans (cInf_le ‹bdd_below s› hb) h

theorem cSup_le_cSup (_ : bdd_above t) (_ : s ≠ ∅) (h : s ⊆ t) : Sup s ≤ Sup t :=
cSup_le ‹s ≠ ∅› (assume (a) (ha : a ∈ s), le_cSup ‹bdd_above t› (h ha))

theorem cInf_le_cInf (_ : bdd_below t) (_ :s ≠ ∅) (h : s ⊆ t) : Inf t ≤ Inf s :=
le_cInf ‹s ≠ ∅› (assume (a) (ha : a ∈ s), cInf_le ‹bdd_below t› (h ha))

theorem cSup_le_iff (_ : bdd_above s) (_ : s ≠ ∅) : Sup s ≤ a ↔ (∀b ∈ s, b ≤ a) :=
⟨assume (_ : Sup s ≤ a) (b) (_ : b ∈ s),
  le_trans (le_cSup ‹bdd_above s› ‹b ∈ s›) ‹Sup s ≤ a›,
  cSup_le ‹s ≠ ∅›⟩

theorem le_cInf_iff (_ : bdd_below s) (_ : s ≠ ∅) : a ≤ Inf s ↔ (∀b ∈ s, a ≤ b) :=
⟨assume (_ : a ≤ Inf s) (b) (_ : b ∈ s),
  le_trans ‹a ≤ Inf s› (cInf_le ‹bdd_below s› ‹b ∈ s›),
  le_cInf ‹s ≠ ∅›⟩

lemma cSup_upper_bounds_eq_cInf {s : set α} (h : bdd_below s) (hs : s ≠ ∅) :
  Sup {a | ∀x∈s, a ≤ x} = Inf s :=
let ⟨b, hb⟩ := h, ⟨a, ha⟩ := ne_empty_iff_exists_mem.1 hs in
le_antisymm
  (cSup_le (ne_empty_iff_exists_mem.2 ⟨b, hb⟩) $ assume a ha, le_cInf hs ha)
  (le_cSup ⟨a, assume y hy, hy a ha⟩ $ assume x hx, cInf_le h hx)

lemma cInf_lower_bounds_eq_cSup {s : set α} (h : bdd_above s) (hs : s ≠ ∅) :
  Inf {a | ∀x∈s, x ≤ a} = Sup s :=
let ⟨b, hb⟩ := h, ⟨a, ha⟩ := ne_empty_iff_exists_mem.1 hs in
le_antisymm
  (cInf_le ⟨a, assume y hy, hy a ha⟩ $ assume x hx, le_cSup h hx)
  (le_cInf (ne_empty_iff_exists_mem.2 ⟨b, hb⟩) $ assume a ha, cSup_le hs ha)

/--Introduction rule to prove that b is the supremum of s: it suffices to check that b
is larger than all elements of s, and that this is not the case of any w<b.-/
theorem cSup_intro (_ : s ≠ ∅) (_ : ∀a∈s, a ≤ b) (H : ∀w, w < b → (∃a∈s, w < a)) : Sup s = b :=
have bdd_above s := ⟨b, by assumption⟩,
have (Sup s < b) ∨ (Sup s = b) := lt_or_eq_of_le (cSup_le ‹s ≠ ∅› ‹∀a∈s, a ≤ b›),
have ¬(Sup s < b) :=
  assume: Sup s < b,
  let ⟨a, _, _⟩ := (H (Sup s) ‹Sup s < b›) in  /- a ∈ s, Sup s < a-/
  have Sup s < Sup s := lt_of_lt_of_le ‹Sup s < a› (le_cSup ‹bdd_above s› ‹a ∈ s›),
  show false, by finish [lt_irrefl (Sup s)],
show Sup s = b, by finish

/--Introduction rule to prove that b is the infimum of s: it suffices to check that b
is smaller than all elements of s, and that this is not the case of any w>b.-/
theorem cInf_intro (_ : s ≠ ∅) (_ : ∀a∈s, b ≤ a) (H : ∀w, b < w → (∃a∈s, a < w)) : Inf s = b :=
have bdd_below s := ⟨b, by assumption⟩,
have (b < Inf s) ∨ (b = Inf s) := lt_or_eq_of_le (le_cInf ‹s ≠ ∅› ‹∀a∈s, b ≤ a›),
have ¬(b < Inf s) :=
  assume: b < Inf s,
  let ⟨a, _, _⟩ := (H (Inf s) ‹b < Inf s›) in  /- a ∈ s, a < Inf s-/
  have Inf s < Inf s := lt_of_le_of_lt (cInf_le ‹bdd_below s› ‹a ∈ s›) ‹a < Inf s› ,
  show false, by finish [lt_irrefl (Inf s)],
show Inf s = b, by finish

/--When an element a of a set s is larger than all elements of the set, it is Sup s-/
theorem cSup_of_in_of_le (_ : a ∈ s) (_ : ∀w∈s, w ≤ a) : Sup s = a :=
have bdd_above s := ⟨a, by assumption⟩,
have s ≠ ∅ := ne_empty_of_mem ‹a ∈ s›,
have A : a ≤ Sup s := le_cSup ‹bdd_above s› ‹a ∈ s›,
have B : Sup s ≤ a := cSup_le ‹s ≠ ∅› ‹∀w∈s, w ≤ a›,
le_antisymm B A

/--When an element a of a set s is smaller than all elements of the set, it is Inf s-/
theorem cInf_of_in_of_le (_ : a ∈ s) (_ : ∀w∈s, a ≤ w) : Inf s = a :=
have bdd_below s := ⟨a, by assumption⟩,
have s ≠ ∅ := ne_empty_of_mem ‹a ∈ s›,
have A : Inf s ≤ a := cInf_le ‹bdd_below s› ‹a ∈ s›,
have B : a ≤ Inf s := le_cInf ‹s ≠ ∅› ‹∀w∈s, a ≤ w›,
le_antisymm A B

/--b < Sup s when there is an element a in s with b < a, when s is bounded above.
This is essentially an iff, except that the assumptions for the two implications are
slightly different (one needs boundedness above for one direction, nonemptyness and linear
order for the other one), so we formulate separately the two implications, contrary to
the complete_lattice case.-/
lemma lt_cSup_of_lt (_ : bdd_above s) (_ : a ∈ s) (_ : b < a) : b < Sup s :=
lt_of_lt_of_le ‹b < a› (le_cSup ‹bdd_above s› ‹a ∈ s›)

/--Inf s < b s when there is an element a in s with a < b, when s is bounded below.
This is essentially an iff, except that the assumptions for the two implications are
slightly different (one needs boundedness below for one direction, nonemptyness and linear
order for the other one), so we formulate separately the two implications, contrary to
the complete_lattice case.-/

lemma cInf_lt_of_lt (_ : bdd_below s) (_ : a ∈ s) (_ : a < b) : Inf s < b :=
lt_of_le_of_lt (cInf_le ‹bdd_below s› ‹a ∈ s›) ‹a < b›

/--The supremum of a singleton is the element of the singleton-/
@[simp] theorem cSup_singleton (a : α) : Sup {a} = a :=
have A : a ≤ Sup {a} :=
  by apply le_cSup _ _; simp; simp,
have B : Sup {a} ≤ a :=
  by apply cSup_le _ _; simp; simp,
le_antisymm B A

/--The infimum of a singleton is the element of the singleton-/
@[simp] theorem cInf_singleton (a : α) : Inf {a} = a :=
have A : Inf {a} ≤ a :=
  by apply cInf_le _ _; simp; simp,
have B : a ≤ Inf {a} :=
  by apply le_cInf _ _; simp; simp,
le_antisymm A B

/--If a set is bounded below and above, and nonempty, its infimum is less than or equal to
its supremum.-/
theorem cInf_le_cSup (_ : bdd_below s) (_ : bdd_above s) (_ : s ≠ ∅) : Inf s ≤ Sup s :=
let ⟨w, hw⟩ := exists_mem_of_ne_empty ‹s ≠ ∅› in   /-hw : w ∈ s-/
have Inf s ≤ w := cInf_le ‹bdd_below s› ‹w ∈ s›,
have w ≤ Sup s := le_cSup ‹bdd_above s› ‹w ∈ s›,
le_trans ‹Inf s ≤ w› ‹w ≤ Sup s›

/--The sup of a union of sets is the max of the suprema of each subset, under the assumptions
that all sets are bounded above and nonempty.-/
theorem cSup_union (_ : bdd_above s) (_ : s ≠ ∅) (_ : bdd_above t) (_ : t ≠ ∅) :
Sup (s ∪ t) = Sup s ⊔ Sup t :=
have A : Sup (s ∪ t) ≤ Sup s ⊔ Sup t :=
  have s ∪ t ≠ ∅ := by simp at *; finish,
  have F : ∀b∈ s∪t, b ≤ Sup s ⊔ Sup t :=
    begin
      intros,
      cases H,
      apply le_trans (le_cSup ‹bdd_above s› ‹b ∈ s›) _, simp,
      apply le_trans (le_cSup ‹bdd_above t› ‹b ∈ t›) _, simp
    end,
  cSup_le this F,
have B : Sup s ⊔ Sup t ≤ Sup (s ∪ t) :=
  have Sup s ≤ Sup (s ∪ t) := by apply cSup_le_cSup _ ‹s ≠ ∅›; simp; finish,
  have Sup t ≤ Sup (s ∪ t) := by apply cSup_le_cSup _ ‹t ≠ ∅›; simp; finish,
  by simp; split; assumption; assumption,
le_antisymm A B

/--The inf of a union of sets is the min of the infima of each subset, under the assumptions
that all sets are bounded below and nonempty.-/
theorem cInf_union (_ : bdd_below s) (_ : s ≠ ∅) (_ : bdd_below t) (_ : t ≠ ∅) :
Inf (s ∪ t) = Inf s ⊓ Inf t :=
have A : Inf s ⊓ Inf t ≤ Inf (s ∪ t) :=
  have s ∪ t ≠ ∅ := by simp at *; finish,
  have F : ∀b∈ s∪t, Inf s ⊓ Inf t ≤ b :=
    begin
      intros,
      cases H,
      apply le_trans _ (cInf_le ‹bdd_below s› ‹b ∈ s›), simp,
      apply le_trans _ (cInf_le ‹bdd_below t› ‹b ∈ t›), simp
    end,
  le_cInf this F,
have B : Inf (s ∪ t) ≤ Inf s ⊓ Inf t  :=
  have Inf (s ∪ t) ≤ Inf s := by apply cInf_le_cInf _ ‹s ≠ ∅›; simp; finish,
  have Inf (s ∪ t) ≤ Inf t := by apply cInf_le_cInf _ ‹t ≠ ∅›; simp; finish,
  by simp; split; assumption; assumption,
le_antisymm B A

/--The supremum of an intersection of sets is bounded by the minimum of the suprema of each
set, if all sets are bounded above and nonempty.-/
theorem cSup_inter_le (_ : bdd_above s) (_ : bdd_above t) (_ : s ∩ t ≠ ∅) :
Sup (s ∩ t) ≤ Sup s ⊓ Sup t :=
begin
  apply cSup_le ‹s ∩ t ≠ ∅› _, simp, intros b _ _, split,
  apply le_cSup ‹bdd_above s› ‹b ∈ s›,
  apply le_cSup ‹bdd_above t› ‹b ∈ t›
end

/--The infimum of an intersection of sets is bounded below by the maximum of the
infima of each set, if all sets are bounded below and nonempty.-/
theorem le_cInf_inter (_ : bdd_below s) (_ : bdd_below t) (_ : s ∩ t ≠ ∅) :
Inf s ⊔ Inf t ≤ Inf (s ∩ t) :=
begin
  apply le_cInf ‹s ∩ t ≠ ∅› _, simp, intros b _ _, split,
  apply cInf_le ‹bdd_below s› ‹b ∈ s›,
  apply cInf_le ‹bdd_below t› ‹b ∈ t›
end

/-- The supremum of insert a s is the maximum of a and the supremum of s, if s is
nonempty and bounded above.-/
theorem cSup_insert (_ : bdd_above s) (_ : s ≠ ∅) : Sup (insert a s) = a ⊔ Sup s :=
calc Sup (insert a s)
        = Sup ({a} ∪ s)   : by rw [insert_eq]
    ... = Sup {a} ⊔ Sup s : by apply cSup_union _ _ ‹bdd_above s› ‹s ≠ ∅›; simp; simp
    ... = a ⊔ Sup s       : by simp

/-- The infimum of insert a s is the minimum of a and the infimum of s, if s is
nonempty and bounded below.-/
theorem cInf_insert (_ : bdd_below s) (_ : s ≠ ∅) : Inf (insert a s) = a ⊓ Inf s :=
calc Inf (insert a s)
        = Inf ({a} ∪ s)   : by rw [insert_eq]
    ... = Inf {a} ⊓ Inf s : by apply cInf_union _ _ ‹bdd_below s› ‹s ≠ ∅›; simp; simp
    ... = a ⊓ Inf s       : by simp

@[simp] lemma cInf_interval [conditionally_complete_lattice α] : Inf {b | a ≤ b} = a :=
cInf_of_in_of_le (by simp) (λw Hw, by simp at Hw; apply Hw)

@[simp] lemma cSup_interval [conditionally_complete_lattice α] : Sup {b | b ≤ a} = a :=
cSup_of_in_of_le (by simp) (λw Hw, by simp at Hw; apply Hw)

end conditionally_complete_lattice

section conditionally_complete_linear_order
variables [conditionally_complete_linear_order α] {s t : set α} {a b : α}

/--When b < Sup s, there is an element a in s with b < a, if s is nonempty and the order is
a linear order.-/
lemma exists_lt_of_lt_cSup (_ : s ≠ ∅) (_ : b < Sup s) : ∃a∈s, b < a :=
begin
  apply classical.by_contradiction,
  assume : ¬ (∃a∈s, b < a),
  have : Sup s ≤ b :=
    by apply cSup_le ‹s ≠ ∅› _; finish,
  apply lt_irrefl b (lt_of_lt_of_le ‹b < Sup s› ‹Sup s ≤ b›)
end

/--When Inf s < b, there is an element a in s with a < b, if s is nonempty and the order is
a linear order.-/
lemma exists_lt_of_cInf_lt (_ : s ≠ ∅) (_ : Inf s < b) : ∃a∈s, a < b :=
begin
  apply classical.by_contradiction,
  assume : ¬ (∃a∈s, a < b),
  have : b ≤ Inf s :=
    by apply le_cInf ‹s ≠ ∅› _; finish,
  apply lt_irrefl b (lt_of_le_of_lt ‹b ≤ Inf s› ‹Inf s < b›)
end

end conditionally_complete_linear_order

section conditionally_complete_linear_order_bot
variables [conditionally_complete_linear_order_bot α]

lemma cSup_empty [conditionally_complete_linear_order_bot α] : (Sup ∅ : α) = ⊥ :=
conditionally_complete_linear_order_bot.cSup_empty α

end conditionally_complete_linear_order_bot

section

local attribute [instance] classical.prop_decidable

noncomputable instance : has_Inf ℕ :=
⟨λs, if h : ∃n, n ∈ s then @nat.find (λn, n ∈ s) _ h else 0⟩

noncomputable instance : has_Sup ℕ :=
⟨λs, if h : ∃n, ∀a∈s, a ≤ n then @nat.find (λn, ∀a∈s, a ≤ n) _ h else 0⟩

lemma Inf_nat_def {s : set ℕ} (h : ∃n, n ∈ s) : Inf s = @nat.find (λn, n ∈ s) _ h :=
dif_pos _

lemma Sup_nat_def {s : set ℕ} (h : ∃n, ∀a∈s, a ≤ n) :
  Sup s = @nat.find (λn, ∀a∈s, a ≤ n) _ h :=
dif_pos _

/-- This instanec is necessary, otherwise the lattice operations would be derive via
conditionally_complete_linear_order_bot and marked as noncomputable. -/
instance : lattice ℕ := infer_instance

noncomputable instance : conditionally_complete_linear_order_bot ℕ :=
{ Sup := Sup, Inf := Inf,
  le_cSup    := assume s a hb ha, by rw [Sup_nat_def hb]; revert a ha; exact @nat.find_spec _ _ hb,
  cSup_le    := assume s a hs ha, by rw [Sup_nat_def ⟨a, ha⟩]; exact nat.find_min' _ ha,
  le_cInf    := assume s a hs hb,
    by rw [Inf_nat_def (ne_empty_iff_exists_mem.1 hs)]; exact hb _ (@nat.find_spec (λn, n ∈ s) _ _),
  cInf_le    := assume s a hb ha, by rw [Inf_nat_def ⟨a, ha⟩]; exact nat.find_min' _ ha,
  cSup_empty :=
  begin
    simp [Sup_nat_def],
    apply bot_unique (nat.find_min' _ _),
    trivial
  end,
  .. (infer_instance : order_bot ℕ), .. (infer_instance : lattice ℕ),
  .. (infer_instance : linear_order ℕ) }

end

end lattice /-end of namespace lattice-/

namespace with_top
open lattice
local attribute [instance] classical.prop_decidable

variables [conditionally_complete_linear_order_bot α]

lemma has_lub (s : set (with_top α)) : ∃a, is_lub s a :=
begin
  by_cases hs : s = ∅, { subst hs, exact ⟨⊥, is_lub_empty⟩, },
  rcases ne_empty_iff_exists_mem.1 hs with ⟨x, hxs⟩,
  by_cases bnd : ∃b:α, ↑b ∈ upper_bounds s,
  { rcases bnd with ⟨b, hb⟩,
    have bdd : bdd_above {a : α | ↑a ∈ s}, from ⟨b, assume y hy, coe_le_coe.1 $ hb _ hy⟩,
    refine ⟨(Sup {a : α | ↑a ∈ s} : α), _, _⟩,
    { assume a has,
      rcases (le_coe_iff _ _).1 (hb _ has) with ⟨a, rfl, h⟩,
      exact (coe_le_coe.2 $ le_cSup bdd has) },
    { assume a hs,
      rcases (le_coe_iff _ _).1 (hb _ hxs) with ⟨x, rfl, h⟩,
      refine (coe_le_iff _ _).2 (assume c hc, _), subst hc,
      exact (cSup_le (ne_empty_of_mem hxs) $ assume b (hbs : ↑b ∈ s), coe_le_coe.1 $ hs _ hbs), } },
  exact ⟨⊤, assume a _, le_top, assume a,
    match a with
    | some a, ha := (bnd ⟨a, ha⟩).elim
    | none,   ha := _root_.le_refl ⊤
    end⟩
end

lemma has_glb (s : set (with_top α)) : ∃a, is_glb s a :=
begin
  by_cases hs : ∃x:α, ↑x ∈ s,
  { rcases hs with ⟨x, hxs⟩,
    refine ⟨(Inf {a : α | ↑a ∈ s} : α), _, _⟩,
    exact (assume a has, (coe_le_iff _ _).2 $ assume x hx, cInf_le (bdd_below_bot _) $
      show ↑x ∈ s, from hx ▸ has),
    { assume a has,
      rcases (le_coe_iff _ _).1 (has _ hxs) with ⟨x, rfl, h⟩,
      exact (coe_le_coe.2 $ le_cInf (ne_empty_of_mem hxs) $
        assume b hbs, coe_le_coe.1 $ has _ hbs) } },
  exact ⟨⊤, assume a, match a with
    | some a, ha := (hs ⟨a, ha⟩).elim
    | none,   ha := _root_.le_refl _
    end,
    assume a _, le_top⟩
end

noncomputable instance : has_Sup (with_top α) := ⟨λs, classical.some $ has_lub s⟩
noncomputable instance : has_Inf (with_top α) := ⟨λs, classical.some $ has_glb s⟩

lemma is_lub_Sup (s : set (with_top α)) : is_lub s (Sup s) := classical.some_spec _
lemma is_glb_Inf (s : set (with_top α)) : is_glb s (Inf s) := classical.some_spec _

noncomputable instance : complete_linear_order (with_top α) :=
{ Sup := Sup, le_Sup := assume s, (is_lub_Sup s).1, Sup_le := assume s, (is_lub_Sup s).2,
  Inf := Inf, le_Inf := assume s, (is_glb_Inf s).2, Inf_le := assume s, (is_glb_Inf s).1,
  .. with_top.linear_order, ..with_top.lattice, ..with_top.order_top, ..with_top.order_bot }

lemma coe_Sup {s : set α} (hb : bdd_above s) : (↑(Sup s) : with_top α) = (⨆a∈s, ↑a) :=
begin
  by_cases hs : s = ∅,
  { simp [hs, cSup_empty], refl },
  apply le_antisymm,
  { refine ((coe_le_iff _ _).2 $ assume b hb, cSup_le hs $ assume a has, coe_le_coe.1 $ hb ▸ _),
    exact (le_supr_of_le a $ le_supr_of_le has $ _root_.le_refl _) },
  { exact (supr_le $ assume a, supr_le $ assume ha, coe_le_coe.2 $ le_cSup hb ha) }
end

lemma coe_Inf {s : set α} (hs : s ≠ ∅) : (↑(Inf s) : with_top α) = (⨅a∈s, ↑a) :=
let ⟨x, hx⟩ := ne_empty_iff_exists_mem.1 hs in
have (⨅a∈s, ↑a : with_top α) ≤ x, from infi_le_of_le x $ infi_le_of_le hx $ _root_.le_refl _,
let ⟨r, r_eq, hr⟩ := (le_coe_iff _ _).1 this in
le_antisymm
  (le_infi $ assume a, le_infi $ assume ha, coe_le_coe.2 $ cInf_le (bdd_below_bot s) ha)
  begin
    refine (r_eq.symm ▸ coe_le_coe.2 $ le_cInf hs $ assume a has, coe_le_coe.1 $ _),
    refine (r_eq ▸ infi_le_of_le a _),
    exact (infi_le_of_le has $ _root_.le_refl _),
  end

end with_top


import xenalib.M1Fstuff algebra.group_power xenalib.square_root

-- automatic coercions to reals

section M1F_Sheet02

-- #check arbitrary
-- #print arbitrary
-- #check default
-- #print default

-- ask about this
/-
example : arbitrary = default :=
begin
unfold eq,

end
-/
-- set_option pp.all true

def countable_union_from_zero {α : Type} (X : nat → set α ) := { t : α | exists i, t ∈ X i}
def countable_union_from_one {α : Type} (X : nat → set α ) := { t : α | exists i, i > 0 ∧ t ∈ X i}

def Q1a_sets : ℕ → set ℝ := λ n x, ↑n ≤ x ∧ x < (n+1)

-- #check Q1a_sets

/-
def Q1a_sets2 : ℕ → set ℝ := λ n, { x | ↑ n ≤ x ∧ x < (n+1)}
example : Q1a_sets = Q1a_sets2 :=
begin
apply funext,
intro n,
unfold Q1a_sets,
unfold Q1a_sets2,
apply funext,
intro x,unfold set_of,
end

-/
-- set_option pp.all true

theorem Q1a : countable_union_from_zero Q1a_sets = { x | 0 ≤ x} :=
begin
unfold countable_union_from_zero,
unfold Q1a_sets,
apply funext,
intro x,
unfold set_of,
have H : ∃ (n : ℤ), ↑n ≤ x ∧ x < ↑n + 1,
  exact M1F.floor_real_exists x,
apply propext,
split,
  intro H2,
  cases H2 with i H3,
  have H4 : ↑i ≤ x,
    exact H3.left,
  have H5 : (0:ℤ) ≤ ↑i,
    exact int.coe_zero_le i,
  apply le_trans _ H4,
  simp [H5],

intro H2,
cases H with n H3,
have H4 : ((0:ℤ):ℝ) < (n:real) +(1:real),
  exact lt_of_le_of_lt H2 H3.right,
have H5 : ((0:ℤ):ℝ) < (n:ℝ) + ((1:ℤ):ℝ),
  rw [int.cast_one], exact H4,
clear H4,
-- rw [←int.cast_add] at H4,
-- have H5 : (0:ℤ) < n + of_rat(1),
--   exact H4,
-- rw [of_rat_add,of_rat_lt] at H5,
-- clear H4,
rw [←int.cast_add,int.cast_lt] at H5,
rw [int.lt_iff_add_one_le] at H5,
simp at H5,
have H : ∃ (n_1 : ℕ), n = ↑n_1,
  exact int.eq_coe_of_zero_le H5,
cases H with i H4,
clear H5 H2,
existsi i,
split,
  exact calc (i:ℝ) = ((i:ℤ):ℝ) : by simp
  ... = (n:ℝ) : int.cast_inj.mpr (eq.symm H4)
  ... ≤ x : H3.left,
suffices H : (↑n : ℝ) = (↑i : ℝ),
  rw [←H],exact H3.right,
rw [H4],
refl,
end

def Q1b_sets : ℕ → set ℝ := λ n x, 1/(↑n) ≤ x ∧ x ≤ 1

-- set_option pp.notation false
-- set_option class.instance_max_depth

-- set_option pp.all true

theorem Q1b : countable_union_from_one Q1b_sets = { x | 0 < x ∧ x ≤ 1} :=
begin
unfold countable_union_from_one,
unfold Q1b_sets,
apply funext,
intro x,
unfold set_of,
apply propext,
split;intro H,
  cases H with i Hi,
  split,
  tactic.swap,
    exact Hi.right.right,
    suffices H2 : (0:ℝ)  < 1/(↑i),
    exact lt_of_lt_of_le H2 Hi.right.left,
--  have H3 : of_rat (((0:nat):int):rat) < of_rat ((i:int):rat),
--    rw [of_rat_lt,rat.coe_int_lt,int.coe_nat_lt_coe_nat_iff],
--    exact Hi.left,
    rw [←int.cast_zero],
    exact lt_div_of_mul_lt (nat.cast_lt.mpr Hi.left) (by simp [zero_lt_one]),
have H2 : 0 < 1/x,
  exact lt_div_of_mul_lt H.left (by simp [zero_lt_one]),
have H3 : ∃ (n : ℤ), ↑n ≤ 1 / x ∧ 1 / x < ↑n + 1,
  exact M1F.floor_real_exists (1/x),
  cases H3 with n Hn,
  have H3 : (0:ℝ) < (n:ℝ) + (1:ℝ),
    exact lt_of_lt_of_le H2 (le_of_lt Hn.right),
  rw [←int.cast_one,←int.cast_add,←int.cast_zero,int.cast_lt,int.lt_iff_add_one_le] at H3,
  have H4 : ↑0 ≤ n,
    apply le_of_add_le_add_right H3,
  cases n with nnat nfalse,
    tactic.swap,
  have H5 : (0:ℤ) < (0:ℤ),
    exact calc (0:ℤ) ≤ int.neg_succ_of_nat nfalse : H4
          ... < 0 : int.neg_succ_of_nat_lt_zero nfalse,
  exfalso,
  apply H5,
  clear H3 H4,
  existsi (nnat+1),
  split,
    exact calc 0< nat.succ nnat : nat.zero_lt_succ nnat
    ... = nnat+1 : rfl,
  split,
  tactic.swap,
  exact H.right,
  have H4 : x > 0,
    unfold gt,exact H.left,
  have H5 : nnat+1>0,
     exact (nat.zero_lt_succ nnat),
  have H6 : (((nnat+1):ℕ):ℝ) > 0,
    exact nat.cast_lt.mpr H5,
  have H7 : ((int.of_nat nnat):ℝ) + 1 = (((nnat+1):ℕ):ℝ), simp,
  have Hnr : 1 / x < ↑(int.of_nat nnat) + 1,
    exact Hn.right,
    rw [H7] at Hnr,
  clear Hn H5,
  suffices H5 : 1 ≤ ↑(nnat+1)*x,
    exact div_le_of_le_mul H6 H5,
exact (div_le_iff_le_mul_of_pos H4).mp (le_of_lt Hnr)
end

def Q1c_sets : ℕ → set ℝ := λ n x, -↑n < x ∧ x < n

-- #check max,

theorem Q1c : countable_union_from_one Q1c_sets = { x | true } :=
begin
unfold countable_union_from_one,
unfold Q1c_sets,
apply funext,
intro x,
unfold set_of,
apply propext,
split;intro H,
trivial,
have H2 : ∃ (n : ℤ), ↑n ≤ x ∧ x < ↑n + 1,
  exact M1F.floor_real_exists x,
have H3 : ∃ (m : ℤ), ↑m ≤ (-x) ∧ (-x) < ↑m + 1,
  exact M1F.floor_real_exists (-x),
cases H2 with n Hn,
cases H3 with m Hm,
let iz:ℤ := max (1:ℤ) (max (n+1) ((m+1))),
have H4 : iz ≥ 1,
  exact le_max_left (1:ℤ) _,
have H5 : ∃ (i:ℕ), iz=i,
  exact int.eq_coe_of_zero_le (le_trans (le_of_lt (zero_lt_one)) H4),
cases H5 with i Hi,
existsi i,
split,
suffices H1 : 0<i,
exact H1,
rw [←int.coe_nat_lt_coe_nat_iff,←Hi],
exact lt_of_lt_of_le zero_lt_one H4,
split,
suffices H1 : -↑i ≤ -(↑m + (1:ℝ)),
  exact lt_of_le_of_lt H1 (neg_lt.mp Hm.right),
  suffices H2 : (↑m+1)≤ (↑i:ℝ),
  exact neg_le_neg H2,
  rw [←int.cast_one,←int.cast_add],
  suffices H5 : (((m+1):ℤ):ℝ)≤((i:ℤ):ℝ),
    exact H5,
  rw [int.cast_le],
  rw [←Hi],
  exact calc m+1 ≤ max (n+1) (m+1) : le_max_right (n+1) (m+1)
            ... ≤ iz : le_max_right 1 _,

  suffices H1 : (n:ℝ)+1 ≤ i, -- of_rat ((n:ℤ):ℚ) + of_rat ((1:ℤ):ℚ) ≤ of_rat ((i:ℤ):ℚ),
    exact lt_of_lt_of_le Hn.right H1,
  rw [←int.cast_one,←int.cast_add],
  suffices H8 : (((n+1):ℤ):ℝ)≤ ((i:ℤ):ℝ), -- of_rat_add,of_rat_le_of_rat,←rat.coe_int_add,rat.coe_int_le],
    exact H8,
  rw [int.cast_le,←Hi],
  exact calc n+1 ≤ max (n+1) (m+1) : le_max_left (n+1) (m+1)
            ... ≤ iz : le_max_right 1 _,
end

def countable_intersection_from_one {α : Type} (X : nat → set α ) := { t : α | ∀ i, i>0 → t ∈ X i}

-- part d has same sets as part c

-- set_option pp.notation false

theorem Q1d : countable_intersection_from_one Q1c_sets = {x | -1<x ∧ x<1} :=
begin
unfold countable_intersection_from_one,
unfold Q1c_sets,
apply funext,
intro x,
unfold set_of,
apply propext,
unfold has_mem.mem set.mem,
-- all that unfolding leaves us with
/-
x : ℝ
⊢ (∀ (i : ℕ), i > 0 → -↑i < x ∧ x < ↑i) ↔ -1 < x ∧ x < 1
-/
split;intro H,
  simpa using ((H 1) (zero_lt_one)),
intro i,
intro Hi,
have i_le_one, exact nat.succ_le_of_lt Hi,
split,
  exact calc -(i:ℝ) ≤ -↑1 : neg_le_neg (nat.cast_le.2 i_le_one)
  ...            =  -1 : by simp
  ... <x : H.left,
exact calc x < 1 : H.right
...          = ↑(1:ℕ) : by simp
... ≤ ↑i : nat.cast_le.2 i_le_one
end

-- question 2

def open_zero_one := { x : ℝ | 0<x ∧ x<1}

theorem Q2 : forall x : ℝ, x ∈ open_zero_one → ∃ y : ℝ, y ∈ open_zero_one ∧ x<y :=
begin
intro x,
intro H,
have H1 : (0:ℝ) < (2:ℝ),
  exact lt_add_of_le_of_pos zero_le_one zero_lt_one,
existsi (x+1)/2,
split,
  split,
    have H2 : 0<x,
      exact H.left,
    have H3 : 0 < (x+1),
      exact lt_add_of_lt_of_nonneg' H2 zero_le_one,
    exact lt_div_of_mul_lt H1 (by simp [H3]),
  suffices H2 : (x+1) < 2,
-- tell nmario that without simp theres a timeout
    exact div_lt_of_mul_lt_of_pos H1 (by simp [H2]),
  exact add_lt_add_right H.right 1,
have H2 : x*(1+1) < (x+1),
  rw [mul_add,mul_one,add_lt_add_iff_left],
  exact H.right,
have H3 : x*2<(x+1),
  exact H2,
exact lt_div_of_mul_lt H1 H3,
  -- simp [div_lt_div_of_lt_of_pos H2 H1],
end

-- set_option pp.notation false
infix ` ** `: 80 := monoid.pow
theorem Q3a (n : int) : (3:ℤ) ∣ n ** 2 → (3:ℤ) ∣ n :=
begin
intro Hn2,
-- let r := n % 3,
-- let q := int.div n 3,
-- have H : n = 3*q+r,
have H : n % 3 < 3,
  exact @int.mod_lt_of_pos n 3 (by exact dec_trivial),
have H2 : n%3 ≥ 0,
  exact int.mod_nonneg n (by exact dec_trivial),
have H3 : exists r:ℕ, (n%3) = int.of_nat r,
  exact (int.eq_coe_of_zero_le H2),
cases H3 with r Hr,
have H3 : r<3,
  rw [←int.coe_nat_lt_coe_nat_iff,←int.of_nat_eq_coe,←Hr],
  exact H,
cases r with r0,
  exact (int.dvd_iff_mod_eq_zero 3 n).mpr Hr,
cases r0 with r1,
  clear H H2 H3,
  exfalso,
  have H : (n+2)%3=0,
    rw [←int.mod_add_mod,Hr],
    have H : int.of_nat 1 + 2 = 3,
      exact dec_trivial,
    rw [H],
    exact int.mod_self,
  have H2 : 3 ∣ ((n-2)*(n+2)),
--    rw [←int.dvd_iff_mod_eq_zero],
  rw [←int.dvd_iff_mod_eq_zero] at H,
  exact dvd_trans H (dvd_mul_left _ _),
simp at H2,
rw [mul_add,add_mul,add_mul,add_assoc,←add_assoc (2*n) _ _,mul_comm 2 n,←mul_add,add_neg_self,mul_zero,zero_add] at H2,
unfold monoid.pow at Hn2,
have H3 : 3 ∣ n * (n * 1) - (n * n + 2 * -2),
  exact dvd_sub Hn2 H2,
simp at H3,
have H4 : ¬ ((3:ℤ) ∣ 2*2),
  exact dec_trivial,
exact H4 H3,
cases r1 with r2,
  clear H H2 H3,
  exfalso,
  have H : (n+1)%3=0,
    rw [←int.mod_add_mod,Hr],
    have H : int.of_nat 2 + 1 = 3,
      exact dec_trivial,
    rw [H],
    exact int.mod_self,
  have H2 : 3 ∣ ((n-1)*(n+1)),
--    rw [←int.dvd_iff_mod_eq_zero],
  rw [←int.dvd_iff_mod_eq_zero] at H,
  exact dvd_trans H (dvd_mul_left _ _),
simp at H2,
rw [mul_add,add_mul,add_mul,add_assoc,←add_assoc (1*n) _ _,mul_comm 1 n,←mul_add,add_neg_self,mul_zero,zero_add] at H2,
unfold monoid.pow at Hn2,
have H3 : 3 ∣ n * (n * 1) - (n * n + 1 * -1),
exact dvd_sub Hn2 H2,
simp at H3,
have H4 : ¬ ((3:ℤ) ∣ 1),
  exact dec_trivial,
  exact H4 H3,
exfalso,
have H4 : r2+4 ≤ 3,
  exact nat.succ_le_of_lt H3,
repeat {rw [nat.succ_le_succ_iff] at H4},
have H5 : nat.succ r2 > 0,
  exact nat.zero_lt_succ r2,
have H6 : 0 < 0,
  exact calc 0 < r2+1 : H5 ... ≤ 0 : H4,
have H7 : 0 ≠ 0, exact ne_of_gt H6,
have H8 : 0 = 0, refl,
exact H7 H8
-- unfold int.nat_mod at r,
-- unfold int.div at q,
end

-- square root of 3

def exists_sqrt_3 := square_root.exists_unique_square_root 3 (by norm_num)

-- #check exists_sqrt_3
-- exists_sqrt_3 : ∃ (q : ℝ), q ≥ 0 ∧ q ^ 2 = 3 ∧ ∀ (s : ℝ), s ≥ 0 ∧ s ^ 2 = 3 → s = q

noncomputable def sqrt3 := classical.some (exists_sqrt_3)
def sqrt3_proof := classical.some_spec (exists_sqrt_3)

-- #check sqrt3_proof

example : sqrt3 ** 2 = 3 := sqrt3_proof.right.left

noncomputable example : monoid ℝ := by apply_instance

-- set_option pp.all true
theorem no_rational_squared_is_three : ¬ (∃ (q:ℚ),q**2=3) :=
begin
intro H0,cases H0 with q Hq2,
rw [pow_two_eq_mul_self] at Hq2,
let n:=q.num,
let d0:=q.denom,
have Hq_is_n_div_d : q=n/d0,
  rw [rat.num_denom q,rat.mk_eq_div],
  refl,
have Hd0_not_zero : ¬ (d0=0),
  intro Hd0,
  have Hq0 : q=0,
    rwa [Hd0,nat.cast_zero,div_zero] at Hq_is_n_div_d,
  rw [Hq0,mul_zero] at Hq2,
  revert Hq2,
  norm_num,
let d:ℤ:=↑d0,
rw [rat.num_denom q] at Hq2,
rw [rat.mk_eq_div] at Hq2,
change q.denom with d0 at Hq2,
change (d0:ℤ) with d at Hq2,
have Hd_not_zero : ¬ (d=↑(0:ℕ)),
  intro H0, apply Hd0_not_zero,
  change d with ↑d0 at H0,
  exact int.of_nat.inj H0,

-- tidy up
change q.num with n at Hq2,
clear Hq_is_n_div_d Hd0_not_zero,

rw [div_mul_div] at Hq2,
have H0 : (d:ℚ) * (d:ℚ) ≠ 0,
  intro H1,
  apply Hd_not_zero,
  rw [←int.cast_zero,←int.cast_mul,int.cast_inj] at H1,
  cases eq_zero_or_eq_zero_of_mul_eq_zero H1,
    assumption,
  assumption,
  have H1 : (3:ℚ) * (↑d * ↑d) = ↑n * ↑n,
    exact (eq_div_iff_mul_eq _ _ H0).mp (eq.symm Hq2),
  have H2 : ((3:ℤ):ℚ) * (↑d * ↑d) = ↑n * ↑n,
    exact H1,
  rw [←int.cast_mul,←int.cast_mul,←int.cast_mul,int.cast_inj] at H2,

-- tidy up; now in Z.
clear Hq2 H0 H1,
-- coprimality of n and d0 built into rat
have H0 : nat.coprime (int.nat_abs n) d0,
  exact q.cop,
have H3 : n*n=n**2,
  exact mul_self_eq_pow_two,
rw [H3] at H2,
have H1 : (3:ℤ) ∣ n**2,
  exact ⟨d*d,eq.symm H2⟩,
have H4 : (3:ℤ) ∣ n,
  exact Q3a n H1,
cases H4 with n1 H5,
rw [←H3,H5] at H2,clear H3,
rw [mul_assoc] at H2,
have H6 : d * d = n1 * (3 * n1),
  exact eq_of_mul_eq_mul_left (by norm_num) H2,clear H2,
  rw [mul_comm n1,mul_assoc] at H6,
  rw [mul_self_eq_pow_two] at H6,
have H2 : (3:ℤ) ∣ d**2,
  exact ⟨n1 * n1, H6⟩,
clear H1 H6,
have H1 : (3:ℤ) ∣ d,
  exact Q3a d H2,
clear H2,
cases H1 with d1 H2,
-- now know H5 : n=3*something,
-- H2 : d = 3 * something,
-- H0 : n coprime to d (modulo coercions)
-- Seems like I now have to coerce everything down to nat
let n0 := int.nat_abs n,
clear Hd_not_zero,
change int.nat_abs n with n0 at H0,
let n2 := int.nat_abs n1,
have H1 : n0 = 3 * n2,
  change (3:ℕ) with int.nat_abs (3:ℤ),
  rw [←int.nat_abs_mul,←H5],
clear H5,
let d2 := int.nat_abs d1,
have H3 : d0 = 3 * d2,
  rw [←int.nat_abs_of_nat d0],
  change 3 with int.nat_abs (3:ℤ),
  change d2 with int.nat_abs d1,
  rw [←int.nat_abs_mul,←H2],
rw [H1,H3] at H0,
clear H3 H2 d d0 H1 n0 n q,
have H1 : nat.coprime (3 * n2) 3,
  exact nat.coprime.coprime_mul_right_right H0,
clear H0,
  rw [mul_comm] at H1,
have H2 :nat.coprime 3 3,
  exact nat.coprime.coprime_mul_left H1,
clear H1 n2 d2 n1 d1,
have H0 : nat.gcd 3 3 = 1,
  exact H2,clear H2,
have H1 : 3 ∣ nat.gcd 3 3,
  exact nat.dvd_gcd ⟨1,mul_one 3⟩ ⟨1,mul_one 3⟩,
rw H0 at H1,
clear H0,
have H0 : 3 = 1,
exact nat.eq_one_of_dvd_one H1,
clear H1,
revert H0,
norm_num,
end

theorem Q3b : M1F.is_irrational (sqrt3) :=
begin
unfold M1F.is_irrational,
intro H,
cases H with q Hq,
have Hq2 : q*q = (3:ℚ),
  rw [←@rat.cast_inj ℝ _ _ (q*q) (3:ℚ),rat.cast_mul,Hq,mul_self_eq_pow_two],
  unfold sqrt3,
  rw [sqrt3_proof.right.left],
  norm_num,
clear Hq,
rw [mul_self_eq_pow_two] at Hq2,
apply no_rational_squared_is_three,
existsi q,
exact Hq2,
end

-- #print no_rational_squared_is_three -- interesting with pp.all true

#print Q3b

theorem Q4a : ¬ (∀ (x y : ℝ), M1F.is_irrational x → M1F.is_irrational y → M1F.is_irrational (x+y)) :=
begin
intro H,
let H2 := H sqrt3 (-sqrt3) Q3b,
have H3 : M1F.is_irrational (-sqrt3),
  unfold M1F.is_irrational,
  intro H4,
  cases H4 with q Hq,
  apply Q3b,
  exact ⟨-q,
    begin
    rw [rat.cast_neg],
    exact eq.symm (eq_neg_iff_eq_neg.mpr (Hq)),
    end
  ⟩,
apply H2 H3,
exact ⟨0,
begin
rw [add_neg_self,rat.cast_zero],
end
⟩,
end

theorem Q4b : ¬ (∀ (a : ℝ), ∀ (b : ℚ), M1F.is_irrational a → M1F.is_irrational (a*b)) :=
begin
intro H,
let H2 := H sqrt3 0 Q3b,
apply H2,
exact ⟨0,by rw [rat.cast_zero,mul_zero]⟩,
end

theorem Q5a : ∀ (x : ℝ), ∃ (y:ℝ), x+y=2 :=
begin
intro x,
exact ⟨-x+2,by rw [←add_assoc,add_neg_self,zero_add]⟩,
end

theorem Q5b : ¬ (∃ (y:ℝ), ∀ (x:ℝ), x+y=2) :=
begin
intro H,
cases H with y Hy,
let H := Hy (-y),
rw [neg_add_self] at H,
revert H,
norm_num,
end

theorem Q6 : square_root.sqrt_abs 2 + square_root.sqrt_abs 6 < square_root.sqrt_abs 15 :=
begin
let s2 := square_root.sqrt_abs 2,
change square_root.sqrt_abs 2 with s2, --
let s6 := square_root.sqrt_abs 6,
change square_root.sqrt_abs 6 with s6, --
let s15 := square_root.sqrt_abs 15,
change square_root.sqrt_abs 15 with s15, --  I just want names for these variables.
have Hs15 : s15**2 = 15,
  exact square_root.sqrt_abs_squared 15 (by norm_num),
rw [pow_two_eq_mul_self] at Hs15,
have Hs2 : s2**2 = 2,
  exact square_root.sqrt_abs_squared 2 (by norm_num),
rw [pow_two_eq_mul_self] at Hs2,
have Hs6 : s6**2 = 6,
  exact square_root.sqrt_abs_squared 6 (by norm_num), -- I know I'll need these things at some point.
rw [pow_two_eq_mul_self] at Hs6,
apply imp_of_not_or (le_or_gt s15 (s2 + s6)),
intro H1,
-- now square both sides of H1
have H2 : s15 ≥ 0,
exact square_root.sqrt_abs_ge_zero 15,
have H3 : s15*s15 ≤ (s2+s6)*(s2+s6) := mul_self_le_mul_self H2 H1,
  rw [Hs15,add_mul_self_eq,Hs2,Hs6] at H3,
  rw [←sub_le_iff_le_add,add_comm,←sub_le_iff_le_add] at H3,
revert H3,
norm_num,
intro H3,
have H4 : 7*7 ≤ (s2*(s6*2))*(s2*(s6*2)) := mul_self_le_mul_self (by norm_num) H3,
have H5 : (49:ℝ) ≤ 48 := calc
49 = 7 * 7 : by norm_num
... ≤ s2 * (s6 * 2) * (s2 * (s6 * 2)) : H4
... = (s2*s2)*(s6*s6)*(2*2) : by simp
... = (2:ℝ)*6*(2*2) : by rw [Hs2,Hs6]
... = 48 : by norm_num,
revert H5,
norm_num,
end

/- Q7 : are the following numbers rational or irrational

(a) sqrt(2)+sqrt(3/2)
(b) 1+sqrt(2)+sqrt(3/2)
(c) 2sqrt(18)-3sqrt(8)
-/

theorem Q7a : M1F.is_irrational (square_root.sqrt_abs 2 + square_root.sqrt_abs (3/2)) :=
begin

let s2 := square_root.sqrt_abs 2,
change square_root.sqrt_abs 2 with s2,
have Hs2 : s2**2 = 2,
  exact square_root.sqrt_abs_squared 2 (by norm_num),
rw [pow_two_eq_mul_self] at Hs2,

let s3o2 := square_root.sqrt_abs (3/2),
change square_root.sqrt_abs (3/2) with s3o2,
have Hs3o2 : s3o2**2 = 3/2,
  exact square_root.sqrt_abs_squared (3/2) (by norm_num),
rw [pow_two_eq_mul_self] at Hs3o2,

intro H,cases H with q Hq,

have H1 : (q:ℝ)*q = 2 + 2*s2*s3o2 + (3/2) := calc
(q:ℝ)*q = (s2 + s3o2)*(s2+s3o2) : by rw [Hq]
... = _ : by rw [add_mul_self_eq]
... =  2 + 2*s2*s3o2 + (3/2) : by rw [Hs2,Hs3o2],

rw [←sub_eq_iff_eq_add,add_comm,←sub_eq_iff_eq_add] at H1,

let r:ℚ := q*q-3/2-2,
have H2 : (r:ℝ)=↑q * ↑q - 3 / 2 - 2,
norm_num,
rw [←H2] at H1,

let s:ℚ := r/2,

have H2not0 : (2:ℝ) ≠ 0 := by norm_num,
have Htemp : (2*(s2*s3o2))/2 = s2*s3o2 := mul_div_cancel_left (s2*s3o2) H2not0,
rw ←mul_assoc at Htemp,
have H3 : (s:ℝ)*s=3 := calc
(s:ℝ)*s=(r/2)*(r/2) : by simp
... = ((2*s2*s3o2)/2)*((2*s2*s3o2)/2) : by rw [H1]
... = (s2*s3o2)*(s2*s3o2) : by rw [Htemp] -- simp [H2not0,mul_assoc,mul_div_cancel_left] -- rw [mul_assoc,mul_div_cancel_left,mul_assoc,mul_div_cancel_left];exact H2not0
... = (s2*s2)*(s3o2*s3o2) : by simp
... = 2*(3/2) : by rw [Hs2,Hs3o2]
... = 3 : by norm_num,

let t:ℚ := abs s,

have H4 : (t:ℝ)*t=3,
  change t with abs s,
  rwa [←rat.cast_mul,abs_mul_abs_self,rat.cast_mul],

have H4 : (t:ℝ) = sqrt3,
  apply sqrt3_proof.right.right t,
  split,
    change t with abs s,
    rw [rat.cast_abs],
    exact abs_nonneg (s:ℝ),
  rwa [pow_two_eq_mul_self],

have Htemp2 :M1F.is_irrational (t:ℝ),
  rw [H4],
  exact Q3b,

apply Htemp2,
existsi t,
refl,
end

theorem Q7b : M1F.is_irrational (1+square_root.sqrt_abs 2+square_root.sqrt_abs (3/2)) :=
begin
intro H,
apply Q7a,
cases H with q Hq,
existsi (q-1),
rw [rat.cast_sub,Hq],
simp,
end

theorem Q7c : exists q:ℚ, (q:ℝ) = 2*square_root.sqrt_abs 18 - 3 * square_root.sqrt_abs 8 :=
begin
existsi (0:ℚ),
rw [rat.cast_zero],apply eq.symm,
rw [sub_eq_zero_iff_eq,mul_comm],
-- apply eq.symm,
apply mul_eq_of_eq_div,
  norm_num,
apply eq.symm,
apply square_root.sqrt_abs_unique,
  { norm_num},
split,
  apply div_nonneg_of_nonneg_of_pos _ _,
    apply mul_nonneg _ _,
      norm_num,
    apply square_root.sqrt_abs_ge_zero _,
  norm_num,
-- rw [div_eq_mul_inv],
exact calc
3 * square_root.sqrt_abs 8 / 2 * (3 * square_root.sqrt_abs 8 / 2)
   = (square_root.sqrt_abs 8) * (square_root.sqrt_abs 8) * 3 * 3 / 2 / 2 : by simp [div_eq_mul_inv]
... = 8*3*3/2/2 : by rw [square_root.sqrt_abs_mul_self 8 (by norm_num)]
... = 18 : by norm_num,
end

#print Q3b

end M1F_Sheet02


import geometry.manifold.charted_space
import to_mathlib.topology.local_homeomorph

namespace charted_space

open set

variables (H : Type*) (M : Type*) [topological_space H] [topological_space M] [charted_space H M]

@[simp] lemma Union_source_eq_univ : (⋃ (x : M), (chart_at H x).source) = (univ : set M) :=
eq_univ_iff_forall.mpr (λ x, mem_Union.mpr ⟨x, mem_chart_source H x⟩)

variables {M}

lemma is_open_iff (s : set M) :
  is_open s ↔ ∀ (x : M), is_open $ chart_at H x '' ((chart_at H x).source ∩ s) :=
begin
  refine ⟨λ h x, (chart_at H x).image_open_of_open' h, λ h, _⟩,
  rw [← s.inter_univ, ← Union_source_eq_univ H M, s.inter_Union],
  refine is_open_Union (λ x, _),
  have : s ∩ (chart_at H x).source ⊆ (chart_at H x).source := inter_subset_right _ _,
  rw [(chart_at H x).is_open_image_iff_of_subset_source this, inter_comm],
  exact h x,
end

end charted_space


/-
Copyright (c) 2015 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura, Jeremy Avigad, Mario Carneiro
-/
import data.nat.factors
import data.nat.prime
import tactic.norm_num

/-!
# Primality prover

This file provides a `norm_num` extention to prove that natural numbers are prime.

-/

namespace tactic
namespace norm_num

lemma is_prime_helper (n : ℕ)
  (h₁ : 1 < n) (h₂ : nat.min_fac n = n) : nat.prime n :=
nat.prime_def_min_fac.2 ⟨h₁, h₂⟩

lemma min_fac_bit0 (n : ℕ) : nat.min_fac (bit0 n) = 2 :=
by simp [nat.min_fac_eq, show 2 ∣ bit0 n, by simp [bit0_eq_two_mul n]]

/-- A predicate representing partial progress in a proof of `min_fac`. -/
def min_fac_helper (n k : ℕ) : Prop :=
0 < k ∧ bit1 k ≤ nat.min_fac (bit1 n)

theorem min_fac_helper.n_pos {n k : ℕ} (h : min_fac_helper n k) : 0 < n :=
pos_iff_ne_zero.2 $ λ e,
by rw e at h; exact not_le_of_lt (nat.bit1_lt h.1) h.2

lemma min_fac_ne_bit0 {n k : ℕ} : nat.min_fac (bit1 n) ≠ bit0 k :=
begin
  rw bit0_eq_two_mul,
  refine (λ e, absurd ((nat.dvd_add_iff_right _).2
    (dvd_trans ⟨_, e⟩ (nat.min_fac_dvd _))) _); simp
end

lemma min_fac_helper_0 (n : ℕ) (h : 0 < n) : min_fac_helper n 1 :=
begin
  refine ⟨zero_lt_one, lt_of_le_of_ne _ min_fac_ne_bit0.symm⟩,
  rw nat.succ_le_iff,
  refine lt_of_le_of_ne (nat.min_fac_pos _) (λ e, nat.not_prime_one _),
  rw e,
  exact nat.min_fac_prime (nat.bit1_lt h).ne',
end

lemma min_fac_helper_2 (n k k' : ℕ) (e : k + 1 = k')
  (np : ¬ nat.prime (bit1 k)) (h : min_fac_helper n k) : min_fac_helper n k' :=
begin
  refine min_fac_helper_1 e _ h,
  intro e₁, rw ← e₁ at np,
  exact np (nat.min_fac_prime $ ne_of_gt $ nat.bit1_lt h.n_pos)
end

lemma min_fac_helper_3 (n k k' c : ℕ) (e : k + 1 = k')
  (nc : bit1 n % bit1 k = c) (c0 : 0 < c)
  (h : min_fac_helper n k) : min_fac_helper n k' :=
begin
  refine min_fac_helper_1 e _ h,
  refine mt _ (ne_of_gt c0), intro e₁,
  rw [← nc, ← nat.dvd_iff_mod_eq_zero, ← e₁],
  apply nat.min_fac_dvd
end

lemma min_fac_helper_4 (n k : ℕ) (hd : bit1 n % bit1 k = 0)
  (h : min_fac_helper n k) : nat.min_fac (bit1 n) = bit1 k :=
by { rw ← nat.dvd_iff_mod_eq_zero at hd,
  exact le_antisymm (nat.min_fac_le_of_dvd (nat.bit1_lt h.1) hd) h.2 }

lemma min_fac_helper_5 (n k k' : ℕ) (e : bit1 k * bit1 k = k')
  (hd : bit1 n < k') (h : min_fac_helper n k) : nat.min_fac (bit1 n) = bit1 n :=
begin
  refine (nat.prime_def_min_fac.1 (nat.prime_def_le_sqrt.2
    ⟨nat.bit1_lt h.n_pos, _⟩)).2,
  rw ← e at hd,
  intros m m2 hm md,
  have := le_trans h.2 (le_trans (nat.min_fac_le_of_dvd m2 md) hm),
  rw nat.le_sqrt at this,
  exact not_le_of_lt hd this
end

open _root_.norm_num

/-- Given `e` a natural numeral and `d : nat` a factor of it, return `⊢ ¬ prime e`. -/
meta def prove_non_prime (e : expr) (n d₁ : ℕ) : tactic expr :=
do let e₁ := reflect d₁,
  c ← mk_instance_cache `(nat),
  (c, p₁) ← prove_lt_nat c `(1) e₁,
  let d₂ := n / d₁, let e₂ := reflect d₂,
  (c, e', p) ← prove_mul_nat c e₁ e₂,
  guard (e' =ₐ e),
  (c, p₂) ← prove_lt_nat c `(1) e₂,
  return $ `(@nat.not_prime_mul').mk_app [e₁, e₂, e, p, p₁, p₂]

/-- Given `a`,`a1 := bit1 a`, `n1` the value of `a1`, `b` and `p : min_fac_helper a b`,
  returns `(c, ⊢ min_fac a1 = c)`. -/
meta def prove_min_fac_aux (a a1 : expr) (n1 : ℕ) :
  instance_cache → expr → expr → tactic (instance_cache × expr × expr)
| ic b p := do
  k ← b.to_nat,
  let k1 := bit1 k,
  let b1 := `(bit1:ℕ→ℕ).mk_app [b],
  if n1 < k1*k1 then do
    (ic, e', p₁) ← prove_mul_nat ic b1 b1,
    (ic, p₂) ← prove_lt_nat ic a1 e',
    return (ic, a1, `(min_fac_helper_5).mk_app [a, b, e', p₁, p₂, p])
  else let d := k1.min_fac in
  if to_bool (d < k1) then do
    let k' := k+1, let e' := reflect k',
    (ic, p₁) ← prove_succ ic b e',
    p₂ ← prove_non_prime b1 k1 d,
    prove_min_fac_aux ic e' $ `(min_fac_helper_2).mk_app [a, b, e', p₁, p₂, p]
  else do
    let nc := n1 % k1,
    (ic, c, pc) ← prove_div_mod ic a1 b1 tt,
    if nc = 0 then
      return (ic, b1, `(min_fac_helper_4).mk_app [a, b, pc, p])
    else do
      (ic, p₀) ← prove_pos ic c,
      let k' := k+1, let e' := reflect k',
      (ic, p₁) ← prove_succ ic b e',
      prove_min_fac_aux ic e' $ `(min_fac_helper_3).mk_app [a, b, e', c, p₁, pc, p₀, p]

/-- Given `a` a natural numeral, returns `(b, ⊢ min_fac a = b)`. -/
meta def prove_min_fac (ic : instance_cache) (e : expr) : tactic (instance_cache × expr × expr) :=
match match_numeral e with
| match_numeral_result.zero := return (ic, `(2:ℕ), `(nat.min_fac_zero))
| match_numeral_result.one := return (ic, `(1:ℕ), `(nat.min_fac_one))
| match_numeral_result.bit0 e := return (ic, `(2), `(min_fac_bit0).mk_app [e])
| match_numeral_result.bit1 e := do
  n ← e.to_nat,
  c ← mk_instance_cache `(nat),
  (c, p) ← prove_pos c e,
  let a1 := `(bit1:ℕ→ℕ).mk_app [e],
  prove_min_fac_aux e a1 (bit1 n) c `(1) (`(min_fac_helper_0).mk_app [e, p])
| _ := failed
end

/-- A partial proof of `factors`. Asserts that `l` is a sorted list of primes, lower bounded by a
prime `p`, which multiplies to `n`. -/
def factors_helper (n p : ℕ) (l : list ℕ) : Prop :=
p.prime → list.chain (≤) p l ∧ (∀ a ∈ l, nat.prime a) ∧ list.prod l = n

lemma factors_helper_nil (a : ℕ) : factors_helper 1 a [] :=
λ pa, ⟨list.chain.nil, by rintro _ ⟨⟩, list.prod_nil⟩

lemma factors_helper_cons' (n m a b : ℕ) (l : list ℕ)
  (h₁ : b * m = n) (h₂ : a ≤ b) (h₃ : nat.min_fac b = b)
  (H : factors_helper m b l) : factors_helper n a (b :: l) :=
λ pa,
  have pb : b.prime, from nat.prime_def_min_fac.2 ⟨le_trans pa.two_le h₂, h₃⟩,
  let ⟨f₁, f₂, f₃⟩ := H pb in
  ⟨list.chain.cons h₂ f₁, λ c h, h.elim (λ e, e.symm ▸ pb) (f₂ _),
   by rw [list.prod_cons, f₃, h₁]⟩

lemma factors_helper_cons (n m a b : ℕ) (l : list ℕ)
  (h₁ : b * m = n) (h₂ : a < b) (h₃ : nat.min_fac b = b)
  (H : factors_helper m b l) : factors_helper n a (b :: l) :=
factors_helper_cons' _ _ _ _ _ h₁ h₂.le h₃ H

lemma factors_helper_sn (n a : ℕ) (h₁ : a < n) (h₂ : nat.min_fac n = n) : factors_helper n a [n] :=
factors_helper_cons _ _ _ _ _ (mul_one _) h₁ h₂ (factors_helper_nil _)

lemma factors_helper_same (n m a : ℕ) (l : list ℕ) (h : a * m = n)
  (H : factors_helper m a l) : factors_helper n a (a :: l) :=
λ pa, factors_helper_cons' _ _ _ _ _ h le_rfl (nat.prime_def_min_fac.1 pa).2 H pa

lemma factors_helper_same_sn (a : ℕ) : factors_helper a a [a] :=
factors_helper_same _ _ _ _ (mul_one _) (factors_helper_nil _)

lemma factors_helper_end (n : ℕ) (l : list ℕ) (H : factors_helper n 2 l) : nat.factors n = l :=
let ⟨h₁, h₂, h₃⟩ := H nat.prime_two in
have _, from list.chain'_iff_pairwise.1 (@list.chain'.tail _ _ (_::_) h₁),
(list.eq_of_perm_of_sorted (nat.factors_unique h₃ h₂) this (nat.factors_sorted _)).symm

/-- Given `n` and `a` natural numerals, returns `(l, ⊢ factors_helper n a l)`. -/
meta def prove_factors_aux :
  instance_cache → expr → expr → ℕ → ℕ → tactic (instance_cache × expr × expr)
| c en ea n a :=
  let b := n.min_fac in
  if b < n then do
    let m := n / b,
    (c, em) ← c.of_nat m,
    if b = a then do
      (c, _, p₁) ← prove_mul_nat c ea em,
      (c, l, p₂) ← prove_factors_aux c em ea m a,
      pure (c, `(%%ea::%%l:list ℕ), `(factors_helper_same).mk_app [en, em, ea, l, p₁, p₂])
    else do
      (c, eb) ← c.of_nat b,
      (c, _, p₁) ← prove_mul_nat c eb em,
      (c, p₂) ← prove_lt_nat c ea eb,
      (c, _, p₃) ← prove_min_fac c eb,
      (c, l, p₄) ← prove_factors_aux c em eb m b,
      pure (c, `(%%eb::%%l : list ℕ),
        `(factors_helper_cons).mk_app [en, em, ea, eb, l, p₁, p₂, p₃, p₄])
  else if b = a then
    pure (c, `([%%ea] : list ℕ), `(factors_helper_same_sn).mk_app [ea])
  else do
    (c, p₁) ← prove_lt_nat c ea en,
    (c, _, p₂) ← prove_min_fac c en,
    pure (c, `([%%en] : list ℕ), `(factors_helper_sn).mk_app [en, ea, p₁, p₂])

/-- Evaluates the `prime` and `min_fac` functions. -/
@[norm_num] meta def eval_prime : expr → tactic (expr × expr)
| `(nat.prime %%e) := do
  n ← e.to_nat,
  match n with
  | 0 := false_intro `(nat.not_prime_zero)
  | 1 := false_intro `(nat.not_prime_one)
  | _ := let d₁ := n.min_fac in
    if d₁ < n then prove_non_prime e n d₁ >>= false_intro
    else do
      let e₁ := reflect d₁,
      c ← mk_instance_cache `(ℕ),
      (c, p₁) ← prove_lt_nat c `(1) e₁,
      (c, e₁, p) ← prove_min_fac c e,
      true_intro $ `(is_prime_helper).mk_app [e, p₁, p]
  end
| `(nat.min_fac %%e) := do
  ic ← mk_instance_cache `(ℕ),
  prod.snd <$> prove_min_fac ic e
| `(nat.factors %%e) := do
  n ← e.to_nat,
  match n with
  | 0 := pure (`(@list.nil ℕ), `(nat.factors_zero))
  | 1 := pure (`(@list.nil ℕ), `(nat.factors_one))
  | _ := do
    c ← mk_instance_cache `(ℕ),
    (c, l, p) ← prove_factors_aux c e `(2) n 2,
    pure (l, `(factors_helper_end).mk_app [e, l, p])
  end
| _ := failed

end norm_num
end tactic


/-
Copyright (c) 2018 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import category_theory.natural_isomorphism
import logic.equiv.basic

/-!
# Full and faithful functors

We define typeclasses `full` and `faithful`, decorating functors.

Use `F.map_injective` to retrieve the fact that `F.map` is injective when `[faithful F]`,
and `F.preimage` to obtain preimages of morphisms when `[full F]`.

We prove some basic "cancellation" lemmas for full and/or faithful functors.

See `category_theory.equivalence` for the fact that a functor is an equivalence if and only if
it is fully faithful and essentially surjective.

-/

-- declare the `v`'s first; see `category_theory.category` for an explanation
universes v₁ v₂ v₃ u₁ u₂ u₃

namespace category_theory

variables {C : Type u₁} [category.{v₁} C] {D : Type u₂} [category.{v₂} D]

/--
A functor `F : C ⥤ D` is full if for each `X Y : C`, `F.map` is surjective.
In fact, we use a constructive definition, so the `full F` typeclass contains data,
specifying a particular preimage of each `f : F.obj X ⟶ F.obj Y`.

See https://stacks.math.columbia.edu/tag/001C.
-/
class full (F : C ⥤ D) :=
(preimage : ∀ {X Y : C} (f : (F.obj X) ⟶ (F.obj Y)), X ⟶ Y)
(witness' : ∀ {X Y : C} (f : (F.obj X) ⟶ (F.obj Y)), F.map (preimage f) = f . obviously)

restate_axiom full.witness'
attribute [simp] full.witness

/--
A functor `F : C ⥤ D` is faithful if for each `X Y : C`, `F.map` is injective.

See https://stacks.math.columbia.edu/tag/001C.
-/
class faithful (F : C ⥤ D) : Prop :=
(map_injective' [] : ∀ {X Y : C}, function.injective (@functor.map _ _ _ _ F X Y) . obviously)

restate_axiom faithful.map_injective'

namespace functor
lemma map_injective (F : C ⥤ D) [faithful F] {X Y : C} :
  function.injective $ @functor.map _ _ _ _ F X Y :=
faithful.map_injective F

/-- The specified preimage of a morphism under a full functor. -/
def preimage (F : C ⥤ D) [full F] {X Y : C} (f : F.obj X ⟶ F.obj Y) : X ⟶ Y :=
full.preimage.{v₁ v₂} f
@[simp] lemma image_preimage (F : C ⥤ D) [full F] {X Y : C} (f : F.obj X ⟶ F.obj Y) :
  F.map (preimage F f) = f :=
by unfold preimage; obviously
end functor

variables {F : C ⥤ D} [full F] [faithful F] {X Y Z : C}

@[simp] lemma preimage_id : F.preimage (𝟙 (F.obj X)) = 𝟙 X :=
F.map_injective (by simp)
@[simp] lemma preimage_comp (f : F.obj X ⟶ F.obj Y) (g : F.obj Y ⟶ F.obj Z) :
  F.preimage (f ≫ g) = F.preimage f ≫ F.preimage g :=
F.map_injective (by simp)
@[simp] lemma preimage_map (f : X ⟶ Y) :
  F.preimage (F.map f) = f :=
F.map_injective (by simp)

/-- If `F : C ⥤ D` is fully faithful, every isomorphism `F.obj X ≅ F.obj Y` has a preimage. -/
def preimage_iso (f : (F.obj X) ≅ (F.obj Y)) : X ≅ Y :=
{ hom := F.preimage f.hom,
  inv := F.preimage f.inv,
  hom_inv_id' := F.map_injective (by simp),
  inv_hom_id' := F.map_injective (by simp), }

@[simp] lemma preimage_iso_hom (f : (F.obj X) ≅ (F.obj Y)) :
  (preimage_iso f).hom = F.preimage f.hom := rfl
@[simp] lemma preimage_iso_inv (f : (F.obj X) ≅ (F.obj Y)) :
  (preimage_iso f).inv = F.preimage (f.inv) := rfl
@[simp] lemma preimage_iso_map_iso (f : X ≅ Y) : preimage_iso (F.map_iso f) = f :=
by tidy

variables (F)

/--
If the image of a morphism under a fully faithful functor in an isomorphism,
then the original morphisms is also an isomorphism.
-/
lemma is_iso_of_fully_faithful (f : X ⟶ Y) [is_iso (F.map f)] : is_iso f :=
⟨⟨F.preimage (inv (F.map f)),
  ⟨F.map_injective (by simp), F.map_injective (by simp)⟩⟩⟩

/-- If `F` is fully faithful, we have an equivalence of hom-sets `X ⟶ Y` and `F X ⟶ F Y`. -/
def equiv_of_fully_faithful {X Y} : (X ⟶ Y) ≃ (F.obj X ⟶ F.obj Y) :=
{ to_fun := λ f, F.map f,
  inv_fun := λ f, F.preimage f,
  left_inv := λ f, by simp,
  right_inv := λ f, by simp }

@[simp]
lemma equiv_of_fully_faithful_apply {X Y : C} (f : X ⟶ Y) :
  equiv_of_fully_faithful F f = F.map f := rfl
@[simp]
lemma equiv_of_fully_faithful_symm_apply {X Y} (f : F.obj X ⟶ F.obj Y) :
  (equiv_of_fully_faithful F).symm f = F.preimage f := rfl

end category_theory

namespace category_theory

variables {C : Type u₁} [category.{v₁} C]

instance full.id : full (𝟭 C) :=
{ preimage := λ _ _ f, f }

instance faithful.id : faithful (𝟭 C) := by obviously

variables {D : Type u₂} [category.{v₂} D] {E : Type u₃} [category.{v₃} E]
variables (F F' : C ⥤ D) (G : D ⥤ E)

instance faithful.comp [faithful F] [faithful G] : faithful (F ⋙ G) :=
{ map_injective' := λ _ _ _ _ p, F.map_injective (G.map_injective p) }

lemma faithful.of_comp [faithful $ F ⋙ G] : faithful F :=
{ map_injective' := λ X Y, (F ⋙ G).map_injective.of_comp }

section
variables {F F'}

/-- If `F` is full, and naturally isomorphic to some `F'`, then `F'` is also full. -/
def full.of_iso [full F] (α : F ≅ F') : full F' :=
{ preimage := λ X Y f, F.preimage ((α.app X).hom ≫ f ≫ (α.app Y).inv),
  witness' := λ X Y f, by simp [←nat_iso.naturality_1 α], }

lemma faithful.of_iso [faithful F] (α : F ≅ F') : faithful F' :=
{ map_injective' := λ X Y f f' h, F.map_injective
  (by rw [←nat_iso.naturality_1 α.symm, h, nat_iso.naturality_1 α.symm]) }
end

variables {F G}

lemma faithful.of_comp_iso {H : C ⥤ E} [ℋ : faithful H] (h : F ⋙ G ≅ H) : faithful F :=
@faithful.of_comp _ _ _ _ _ _ F G (faithful.of_iso h.symm)

alias faithful.of_comp_iso ← category_theory.iso.faithful_of_comp

-- We could prove this from `faithful.of_comp_iso` using `eq_to_iso`,
-- but that would introduce a cyclic import.
lemma faithful.of_comp_eq {H : C ⥤ E} [ℋ : faithful H] (h : F ⋙ G = H) : faithful F :=
@faithful.of_comp _ _ _ _ _ _ F G (h.symm ▸ ℋ)

alias faithful.of_comp_eq ← eq.faithful_of_comp

variables (F G)

/-- “Divide” a functor by a faithful functor. -/
protected def faithful.div (F : C ⥤ E) (G : D ⥤ E) [faithful G]
  (obj : C → D) (h_obj : ∀ X, G.obj (obj X) = F.obj X)
  (map : Π {X Y}, (X ⟶ Y) → (obj X ⟶ obj Y))
  (h_map : ∀ {X Y} {f : X ⟶ Y}, G.map (map f) == F.map f) :
  C ⥤ D :=
{ obj := obj,
  map := @map,
  map_id' :=
  begin
    assume X,
    apply G.map_injective,
    apply eq_of_heq,
    transitivity F.map (𝟙 X), from h_map,
    rw [F.map_id, G.map_id, h_obj X]
  end,
  map_comp' :=
  begin
    assume X Y Z f g,
    apply G.map_injective,
    apply eq_of_heq,
    transitivity F.map (f ≫ g), from h_map,
    rw [F.map_comp, G.map_comp],
    congr' 1;
      try { exact (h_obj _).symm };
      exact h_map.symm
  end }

-- This follows immediately from `functor.hext` (`functor.hext h_obj @h_map`),
-- but importing `category_theory.eq_to_hom` causes an import loop:
-- category_theory.eq_to_hom → category_theory.opposites →
-- category_theory.equivalence → category_theory.fully_faithful
lemma faithful.div_comp (F : C ⥤ E) [faithful F] (G : D ⥤ E) [faithful G]
  (obj : C → D) (h_obj : ∀ X, G.obj (obj X) = F.obj X)
  (map : Π {X Y}, (X ⟶ Y) → (obj X ⟶ obj Y))
  (h_map : ∀ {X Y} {f : X ⟶ Y}, G.map (map f) == F.map f) :
  (faithful.div F G obj @h_obj @map @h_map) ⋙ G = F :=
begin
  casesI F with F_obj _ _ _, casesI G with G_obj _ _ _,
  unfold faithful.div functor.comp,
  unfold_projs at h_obj,
  have: F_obj = G_obj ∘ obj := (funext h_obj).symm,
  substI this,
  congr,
  funext,
  exact eq_of_heq h_map
end

lemma faithful.div_faithful (F : C ⥤ E) [faithful F] (G : D ⥤ E) [faithful G]
  (obj : C → D) (h_obj : ∀ X, G.obj (obj X) = F.obj X)
  (map : Π {X Y}, (X ⟶ Y) → (obj X ⟶ obj Y))
  (h_map : ∀ {X Y} {f : X ⟶ Y}, G.map (map f) == F.map f) :
  faithful (faithful.div F G obj @h_obj @map @h_map) :=
(faithful.div_comp F G _ h_obj _ @h_map).faithful_of_comp

instance full.comp [full F] [full G] : full (F ⋙ G) :=
{ preimage := λ _ _ f, F.preimage (G.preimage f) }

/-- If `F ⋙ G` is full and `G` is faithful, then `F` is full. -/
def full.of_comp_faithful [full $ F ⋙ G] [faithful G] : full F :=
{ preimage := λ X Y f, (F ⋙ G).preimage (G.map f),
  witness' := λ X Y f, G.map_injective ((F ⋙ G).image_preimage _) }

/-- If `F ⋙ G` is full and `G` is faithful, then `F` is full. -/
def full.of_comp_faithful_iso {F : C ⥤ D} {G : D ⥤ E} {H : C ⥤ E} [full H] [faithful G]
  (h : F ⋙ G ≅ H) : full F :=
@full.of_comp_faithful _ _ _ _ _ _ F G (full.of_iso h.symm) _

/--
Given a natural isomorphism between `F ⋙ H` and `G ⋙ H` for a fully faithful functor `H`, we
can 'cancel' it to give a natural iso between `F` and `G`.
-/
def fully_faithful_cancel_right {F G : C ⥤ D} (H : D ⥤ E)
  [full H] [faithful H] (comp_iso: F ⋙ H ≅ G ⋙ H) : F ≅ G :=
nat_iso.of_components
  (λ X, preimage_iso (comp_iso.app X))
  (λ X Y f, H.map_injective (by simpa using comp_iso.hom.naturality f))

@[simp]
lemma fully_faithful_cancel_right_hom_app {F G : C ⥤ D} {H : D ⥤ E}
  [full H] [faithful H] (comp_iso: F ⋙ H ≅ G ⋙ H) (X : C) :
  (fully_faithful_cancel_right H comp_iso).hom.app X = H.preimage (comp_iso.hom.app X) :=
rfl

@[simp]
lemma fully_faithful_cancel_right_inv_app {F G : C ⥤ D} {H : D ⥤ E}
  [full H] [faithful H] (comp_iso: F ⋙ H ≅ G ⋙ H) (X : C) :
  (fully_faithful_cancel_right H comp_iso).inv.app X = H.preimage (comp_iso.inv.app X) :=
rfl

end category_theory