/- Pattern Matching -/

namespace patm

  open Nat

  def sub1 : Nat → Nat
    | zero => zero
    | succ x => x

  def isZero : Nat → Bool
    | 0 => true
    | x + 1 => false

  def swap : α × β → β × α
    | (a, b) => (b, a)

  def bar : Option Nat → Nat
    | none => 0
    | some n => n + 1

  def not : Bool → Bool
    | true => false
    | false => true

  theorem not_not : ∀ (b : Bool), not (not b) = b
    | true => by rfl
    | false => by rfl

  def sub2 : Nat → Nat
    | 0 => 0
    | 1 => 0
    | x + 2 => x

  example (p q : α → Prop)
      : (∃ x, p x ∨ q x) → (∃ x, p x) ∨ (∃ x, q x)
    | Exists.intro x (Or.inl px) => Or.inl (Exists.intro x px)
    | Exists.intro x (Or.inr qx) => Or.inr (Exists.intro x qx)

  def foo : Nat → Nat → Nat
    | 0,   n   => 0
    | m+1, 0   => 1
    | m+1, n+1 => 2

  def bar1 : List Nat → List Nat → Nat
    | [],      []      => 0
    | a :: as, []      => a
    | [],      b :: bs => b
    | a :: as, b :: bs => a + b

  def and : Bool → Bool → Bool
    | true, b => b
    | false, _ => false

  def or : Bool → Bool → Bool
    | true, _ => true
    | false, b => b

  def cond : Bool → α → α → α
    | true, x, _ => x
    | false, _, y => y

end patm

/- Wildcards and Overlapping Patterns -/

namespace wop

  def foo : Nat → Nat → Nat
    | 0, _ => 0
    | _, 0 => 1
    | _, _ => 2

  def f1 : Nat → Nat → Nat
    | 0, _ => 1
    | _, 0 => 2
    | _, _ => default

end wop

/- Structural Recursion and Induction -/

namespace sri

  namespace hidden
    open Nat

    def add : Nat → Nat → Nat
      | m, zero => m
      | m, succ n => succ (add m n)

    theorem zero_add : ∀ n, add zero n = n
      | zero => by rfl
      | succ n => congrArg succ (zero_add n)
  end hidden

  def fib : Nat → Nat
    | 0 => 1
    | 1 => 1
    | n + 2 => fib (n + 1) + fib n

  def fibFast (n: Nat) : Nat :=
    (loop n).1
    where
      loop : Nat → Nat × Nat
        | 0 => (0, 1)
        | n + 1 => let p := loop n; (p.2, p.1 + p.2)

  #eval fibFast 100

  def List.listAdd [Add α] : List α → List α → List α
    | [], _ => []
    | _, [] => []
    | a :: as, b :: bs => (a + b) :: listAdd as bs

  #eval List.listAdd [1, 2, 3] [4, 5, 6, 7] -- [5, 7, 9]

end sri

/- Local Recursive Generators -/

namespace lrg

  def replicate (n : Nat) (a : α) : List α :=
    let rec loop : Nat → List α → List α
    | 0, as => as
    | n + 1, as => loop n (a :: as)
    loop n []

  /-
  @replicate.loop : {α : Type u_1} → α → Nat → List α → List α
  -/
  #check @replicate.loop

  /-
  [4, 4, 4, 4, 4]
  -/
  #eval replicate 5 4

  theorem length_rep (n : Nat) (a : α) : (replicate n a).length = n := by
    let rec aux (n : Nat) (as : List α)
        : (replicate.loop a n as).length = n + as.length := by
      match n with
      | 0 => simp [replicate.loop]
      | n + 1 => simp_arith [replicate.loop, aux]
    exact aux n []

end lrg

/- Well Founded Recursion and Induction -/

namespace wfri

  variable (α : Sort u)
  variable (r : α → α → Prop)

  #check (Acc r : α → Prop) -- ∀ y, r y x → Acc r y
  #check (WellFounded r : Prop)

  namespace hidden

    def div (x y : Nat) : Nat :=
      if h : 0 < y ∧ y ≤ x then
        have : x - y < x := Nat.sub_lt (Nat.lt_of_lt_of_le h.1 h.2) h.1
        div (x - y) y + 1
      else
        0

    #eval div 9 4 -- 2

    example (x y : Nat)
        : div x y = if 0 < y ∧ y ≤ x then div (x - y) y + 1 else 0 := by
      conv => lhs; unfold div

    example (x y : Nat) (h : 0 < y ∧ y ≤ x) : div x y = div (x - y) y + 1 := by
      conv => lhs; unfold div; simp [h]

    def natToBin : Nat → List Nat
      | 0 => [0]
      | 1 => [1]
      | n + 2 =>
        have : (n + 2) / 2 < (n + 2) := sorry
        natToBin ((n + 2) / 2) ++ [n % 2]

    #eval natToBin 45 -- [1, 0, 1, 1, 0, 1]

    def ack : Nat → Nat → Nat
      | 0, n => n + 1
      | m + 1, 0 => ack m 1
      | m + 1, n + 1 => ack m (ack (m + 1) n)
      termination_by ack x y => (x, y)

  end hidden

end wfri

/- Mutual Recursion -/

namespace mr

  mutual
    def even : Nat → Bool
      | 0 => true
      | n + 1 => odd n

    def odd : Nat → Bool
      | 0 => false
      | n + 1 => even n
  end

  theorem even_eq_not_odd : ∀ n, even n = not (odd n) := by
    intro n; induction n
    . simp [even, odd]
    . simp [even, odd, *]

  mutual
    inductive Even : Nat → Prop where
    | even_zero : Even 0
    | even_succ : ∀ n, Odd n → Even (n + 1)

    inductive Odd : Nat → Prop where
    | odd_succ : ∀ n, Even n → Odd (n + 1)
  end

  open Even Odd
    theorem zero_not_odd : ¬ Odd 0 := by
      intro; contradiction

    theorem even_of_odd_succ : ∀ n, Odd (n + 1) → Even n
      | _, odd_succ n h => h

  inductive Term where
  | const : String → Term
  | app : String → List Term → Term

  namespace Term

    mutual
      def numConsts : Term → Nat
        | const _ => 1
        | app _ cs => numConstsLst cs

      def numConstsLst : List Term → Nat
        | [] => 0
        | c :: cs => numConsts c + numConstsLst cs
    end

    def sample := app "f" [app "g" [const "x"], const "y"]

    #eval numConsts sample -- 2

    mutual
      def replaceConst (a b : String) : Term → Term
        | const c => if a == c then const b else const c
        | app c cs => app c (replaceConstLst a b cs)

      def replaceConstLst (a b : String) : List Term → List Term
        | [] => []
        | c :: cs => replaceConst a b c :: replaceConstLst a b cs
    end

    mutual
      theorem numConsts_replaceConst (a b : String) (e : Term)
          : numConsts (replaceConst a b e) = numConsts e := by
        match e with
        | const c => simp [replaceConst]; split <;> simp [numConsts]
        | app c cs => simp [replaceConst, numConsts, numConsts_replaceConstLst a b cs]

      theorem numConsts_replaceConstLst (a b : String) (es : List Term)
          : numConstsLst (replaceConstLst a b es) = numConstsLst es := by
        match es with
        | [] => simp [replaceConstLst, numConstsLst]
        | c :: cs =>
          simp [replaceConstLst, numConstsLst, numConsts_replaceConst a b c,
            numConsts_replaceConstLst a b cs]
    end

  end Term
end mr

/- Dependent Pattern Matching -/

namespace dpm

  inductive Vector (α : Type u) : Nat → Type u where
  | nil : Vector α 0
  | cons : α → {n : Nat} → Vector α n → Vector α (n + 1)

  namespace Vector
    def tailAux (v : Vector α m) : m = n + 1 → Vector α n :=
      Vector.casesOn (motive := fun x _ => x = n + 1 → Vector α n) v
        (fun h : 0 = n + 1 => Nat.noConfusion h)
        (fun (a : α) (m : Nat) (as : Vector α m) =>
          fun (h : m + 1 = n + 1) =>
            Nat.noConfusion h (fun h1 : m = n => h1 ▸ as))

    def tail1 (v : Vector α (n + 1)) : Vector α n :=
      tailAux v rfl

    def head : {n : Nat} → Vector α (n + 1) → α
      | n, cons a as => a

    def tail : {n : Nat} → Vector α (n + 1) → Vector α n
      | n, cons a as => as

    theorem eta : ∀ {n : Nat} (v : Vector α (n + 1)), cons (head v) (tail v) = v
      | n, cons a as => by rfl

    def map (f : α → β → γ) : {n : Nat} → Vector α n → Vector β n → Vector γ n
      | 0, nil, nil => nil
      | n + 1, cons a as, cons b bs => cons (f a b) (map f as bs)

    def zip : {n : Nat} → Vector α n → Vector β n → Vector (α × β) n
      | 0, nil, nil => nil
      | n + 1, cons a as, cons b bs => cons (a, b) (zip as bs)

    #print map.match_1

  end Vector

end dpm

/- Inaccesible Patterns -/

namespace ip

  inductive Vector (α : Type u) : Nat → Type u where
  | nil : Vector α 0
  | cons : α → {n : Nat} → Vector α n → Vector α (n + 1)

  namespace Vector
    def add [Add α] : {n : Nat} → Vector α n → Vector α n → Vector α n
      | 0, _, _ => nil
      | n + 1, cons a as, cons b bs => cons (a + b) (add as bs)

    def add' [Add α] : Vector α n → Vector α n → Vector α n
      | nil,       nil       => nil
      | cons a as, cons b bs => cons (a + b) (add as bs)
  end Vector

end ip

/- Match Expressions -/

namespace me

  def isNotZero : Nat → Bool
    | 0 => false
    | n + 1 => true

  def filter (p : α → Bool) : List α → List α
    | [] => []
    | a :: as =>
      match p a with
      | true => a :: (filter p as)
      | false => filter p as

  example : filter isNotZero [1, 0, 0, 3, 0] = [1, 3] := by rfl

  def bar₁ : Nat × Nat → Nat
  | (m, n) => m + n

  def bar₂ (p : Nat × Nat) : Nat :=
    match p with
    | (m, n) => m + n

  def bar₃ : Nat × Nat → Nat :=
    fun (m, n) => m + n

  def bar₄ (p : Nat × Nat) : Nat :=
    let (m, n) := p; m + n

end me


import Lean4Axiomatic.Integer

namespace Lean4Axiomatic.Rational.Impl.Fraction.Naive

open Coe (coe)
open Integer (Nonzero)
open Natural (step)
open Signed (Positive)

/-!
## Naive fractions

What happens if we put two integers into a fraction without the usual
requirement that the denominator is nonzero?
-/

/--
A "naive" formal fraction of values from an arbitrary type `α`.

We don't require the denominator to be nonzero here. Quite a few of the results
for "normal" fractions still apply to these unrestricted ones. But there are
also some important differences, showing why restricting the denominator is
needed.
-/
structure Fraction (α : Type) : Type :=
  numerator : α
  denominator : α

local infix:90 "//" => Naive.Fraction.mk

/--
Create an ordered pair of `α` values from a `Naive.Fraction α`.

Sometimes it can be helpful to have a strict form of equivalence between
naive fractions, one that works component-wise; conversion to ordered pairs
enables this.
-/
def Fraction.to_prod {α : Type} : Naive.Fraction α → α × α
| a//b => (a, b)

variable {ℕ : Type} [Natural ℕ]
variable {ℤ : Type} [Integer (ℕ := ℕ) ℤ]

/--
An attempted equivalence relation on naive fractions of integers.

Based on the fundamental notion that fractions represent division, the inverse
of multiplication. Informally, we want the following line of reasoning to hold:
1. `p//q ≃ r//s`
2. `(p//q) * q ≃ (r//s) * q`
3. `p ≃ (r * q)//s`
4. `p * s ≃ ((r * q)//s) * s`
5. `p * s ≃ r * q`

This has the same form as the equivalence relation on traditional fractions,
but it's not actually an equivalence relation because it fails to be transitive
(see proofs below).
-/
def eqv : Naive.Fraction ℤ → Naive.Fraction ℤ → Prop
| p//q, r//s => p * s ≃ r * q

/-- Provide the `· ≃ ·` operator for equivalence of naive fractions. -/
instance tildeDash : Operators.TildeDash (Naive.Fraction ℤ) := {
  tildeDash := eqv
}

/-- Naive fraction equivalence is reflexive. -/
theorem eqv_refl {p : Naive.Fraction ℤ} : p ≃ p := by
  revert p; intro (a//b)
  show a//b ≃ a//b
  show a * b ≃ a * b
  exact Rel.refl

/-- Naive fraction equivalence is symmetric. -/
theorem eqv_symm {p q : Naive.Fraction ℤ} : p ≃ q → q ≃ p := by
  revert p; intro (a//b); revert q; intro (c//d)
  intro (_ : a//b ≃ c//d)
  show c//d ≃ a//b
  have : a * d ≃ c * b := ‹a//b ≃ c//d›
  show c * b ≃ a * d
  exact Rel.symm ‹a * d ≃ c * b›

/--
The transitive property fails for "equivalence" on naive fractions.

**Proof intuition**: We assume transitivity holds and show that it leads to a
contradiction. Define fractions `p` and `r` such that `p ≄ r`. Define `q` to be
the fraction `0//0`, and note that `p ≃ q` and `q ≃ r`. Now invoke transitivity
to show that `p ≃ r`, contradicting our definition of `p` and `r`.
-/
theorem eqv_trans_impossible
    : ¬(∀ p q r : Naive.Fraction ℤ, p ≃ q → q ≃ r → p ≃ r)
    := by
  intro (trans : {p q r : Naive.Fraction ℤ} → p ≃ q → q ≃ r → p ≃ r)
  show False
  let p : Naive.Fraction ℤ := 1//0
  let q : Naive.Fraction ℤ := 0//0
  let r : Naive.Fraction ℤ := 1//1
  have : p ≃ q := by
    show 1//0 ≃ 0//0
    show 1 * 0 ≃ 0 * 0
    calc
      (1 : ℤ) * 0 ≃ _ := AA.absorbR
      0           ≃ _ := Rel.symm AA.absorbR
      0 * 0       ≃ _ := Rel.refl
  have : q ≃ r := by
    show 0//0 ≃ 1//1
    show 0 * 1 ≃ 1 * 0
    exact AA.comm
  have : p ≄ r := by
    intro (_ : p ≃ r)
    show False
    have : (1 : ℤ)//0 ≃ 1//1 := ‹p ≃ r›
    have : (1 : ℤ) * 1 ≃ 1 * 0 := ‹(1 : ℤ)//0 ≃ 1//1›
    have : (1 : ℤ) ≃ 0 := calc
      (1 : ℤ) ≃ _ := Rel.symm AA.identR
      1 * 1   ≃ _ := ‹(1 : ℤ) * 1 ≃ 1 * 0›
      1 * 0   ≃ _ := AA.absorbR
      0       ≃ _ := Rel.refl
    have : (1 : ℤ) ≄ 0 := Integer.one_neqv_zero
    exact absurd ‹(1 : ℤ) ≃ 0› ‹(1 : ℤ) ≄ 0›
  have : p ≃ r := trans ‹p ≃ q› ‹q ≃ r›
  exact absurd ‹p ≃ r› ‹p ≄ r›

/-!
Although general transitivity is impossible, by imposing some restrictions we
can prove it. For example, the usual approach of having a nonzero denominator:
-/

/--
Transitivity holds for naive fractions if the middle fraction's denominator is
nonzero.

**Proof intuition**: Using the `p ≃ q` and `q ≃ r` hypotheses, we can almost
show `p ≃ r` -- except that both sides of the equivalence have an extra factor
of `q.denominator`. We're allowed to cancel it out because of the assumption
that it's nonzero.
-/
theorem eqv_trans_nonzero_denom
    {p q r : Naive.Fraction ℤ} : q.denominator ≄ 0 → p ≃ q → q ≃ r → p ≃ r
    := by
  revert p; intro (pn//pd); revert q; intro (qn//qd); revert r; intro (rn//rd)
  intro (_ : qd ≄ 0) (_ : pn//pd ≃ qn//qd) (_ : qn//qd ≃ rn//rd)
  show pn//pd ≃ rn//rd
  have : (pn * rd) * qd ≃ (rn * pd) * qd := calc
    (pn * rd) * qd ≃ _ := AA.substL AA.comm
    (rd * pn) * qd ≃ _ := AA.assoc
    rd * (pn * qd) ≃ _ := AA.substR ‹pn * qd ≃ qn * pd›
    rd * (qn * pd) ≃ _ := Rel.symm AA.assoc
    (rd * qn) * pd ≃ _ := AA.substL AA.comm
    (qn * rd) * pd ≃ _ := AA.substL ‹qn * rd ≃ rn * qd›
    (rn * qd) * pd ≃ _ := AA.assoc
    rn * (qd * pd) ≃ _ := AA.substR AA.comm
    rn * (pd * qd) ≃ _ := Rel.symm AA.assoc
    (rn * pd) * qd ≃ _ := Rel.refl
  have : pn * rd ≃ rn * pd :=
    Integer.mul_cancelR ‹qd ≄ 0› ‹(pn * rd) * qd ≃ (rn * pd) * qd›
  exact this

/-!
What exactly are the conditions under which transitivity on naive fractions is
possible? Looking back at the counterexample in the impossibility proof, the
key idea was setting `q := 0//0`. This forced `p ≃ q` and `q ≃ r` to hold, even
though `p ≄ r`. In fact, it looks as though the value `0//0` is equivalent to
_any_ naive fraction; let's prove it.
-/

/--
The naive fraction `0//0` is equivalent to any naive fraction.

**Proof intuition**: Expanding the definition of equivalence produces an
equivalence of two products, each containing a factor of zero. By absorption,
this is the same as `0 ≃ 0`, which is trivially true.
-/
theorem zero_over_zero_eqv_any {p : Naive.Fraction ℤ} : 0//0 ≃ p := by
  revert p; intro (pn//pd)
  show 0//0 ≃ pn//pd
  show 0 * pd ≃ pn * 0
  calc
    0 * pd ≃ _ := AA.absorbL
    0      ≃ _ := Rel.symm AA.absorbR
    pn * 0 ≃ _ := Rel.refl

/-!
That result is certainly a disaster for creating a model of fractions that
matches our intuition. If every fraction is equivalent to `0//0`, then they are
all equivalent to each other, making them useless as numbers. Fortunately, it
turns out that disallowing `0//0` is the only thing we need to restore
transitivity of equivalence:
-/

/--
Transitivity holds for naive fractions when the middle fraction is not `0//0`.

**Proof intuition**: We already know transitivity holds when the middle
fraction's denominator is nonzero (see `eqv_trans_nonzero_denom`). When its
denominator is zero, the assumptions `p ≃ q` and `q ≃ r` imply that there are
two possibilities: either its numerator is also zero, or the denominators of
the other two fractions are zero. In the first case, the middle fraction is
`0//0`, and transitivity may fail. In the second case, `p ≃ r` reduces to
`0 ≃ 0` because `p` and `r`'s denominators are zero, and transitivity holds.
-/
theorem eqv_trans_almost
    {p q r : Naive.Fraction ℤ}
    : p ≃ q → q ≃ r → (p ≃ r ∨ q.to_prod ≃ (0//0).to_prod)
    := by
  revert p; intro (pn//pd); revert q; intro (qn//qd); revert r; intro (rn//rd)
  intro (_ : pn//pd ≃ qn//qd) (_ : qn//qd ≃ rn//rd)
  show pn//pd ≃ rn//rd ∨ (qn//qd).to_prod ≃ (0//0).to_prod
  show pn * rd ≃ rn * pd ∨ (qn, qd) ≃ (0, 0)
  have : qd ≃ 0 ∨ qd ≄ 0 := Integer.eqv? qd 0
  match ‹qd ≃ 0 ∨ qd ≄ 0› with
  | Or.inl (_ : qd ≃ 0) =>
    have : pn * qd ≃ qn * pd := ‹pn//pd ≃ qn//qd›
    have : qn * rd ≃ rn * qd := ‹qn//qd ≃ rn//rd›
    have : qn * pd ≃ 0 := calc
      qn * pd ≃ _ := Rel.symm ‹pn * qd ≃ qn * pd›
      pn * qd ≃ _ := AA.substR ‹qd ≃ 0›
      pn * 0  ≃ _ := AA.absorbR
      0       ≃ _ := Rel.refl
    have : qn * rd ≃ 0 := calc
      qn * rd ≃ _ := ‹qn * rd ≃ rn * qd›
      rn * qd ≃ _ := AA.substR ‹qd ≃ 0›
      rn * 0  ≃ _ := AA.absorbR
      0       ≃ _ := Rel.refl
    have : qn ≃ 0 ∨ pd ≃ 0 := Integer.mul_split_zero.mp ‹qn * pd ≃ 0›
    have : qn ≃ 0 ∨ rd ≃ 0 := Integer.mul_split_zero.mp ‹qn * rd ≃ 0›
    have : (qn ≃ 0 ∨ pd ≃ 0) ∧ (qn ≃ 0 ∨ rd ≃ 0) :=
      And.intro ‹qn ≃ 0 ∨ pd ≃ 0› ‹qn ≃ 0 ∨ rd ≃ 0›
    have : qn ≃ 0 ∨ (pd ≃ 0 ∧ rd ≃ 0) :=
      Logic.or_distribL_and.mpr ‹(qn ≃ 0 ∨ pd ≃ 0) ∧ (qn ≃ 0 ∨ rd ≃ 0)›
    match ‹qn ≃ 0 ∨ (pd ≃ 0 ∧ rd ≃ 0)› with
    | Or.inl (_ : qn ≃ 0) =>
      have : qn ≃ 0 ∧ qd ≃ 0 := And.intro ‹qn ≃ 0› ‹qd ≃ 0›
      have : (qn, qd) ≃ (0, 0) :=
        Relation.Equivalence.Impl.Prod.eqv_defn.mpr ‹qn ≃ 0 ∧ qd ≃ 0›
      exact Or.inr ‹(qn, qd) ≃ (0, 0)›
    | Or.inr (And.intro (_ : pd ≃ 0) (_ : rd ≃ 0)) =>
      have : pn * rd ≃ rn * pd := calc
        pn * rd ≃ _ := AA.substR ‹rd ≃ 0›
        pn * 0  ≃ _ := AA.absorbR
        0       ≃ _ := Rel.symm AA.absorbR
        rn * 0  ≃ _ := AA.substR (Rel.symm ‹pd ≃ 0›)
        rn * pd ≃ _ := Rel.refl
      exact Or.inl ‹pn * rd ≃ rn * pd›
  | Or.inr (_ : qd ≄ 0) =>
    have : pn * rd ≃ rn * pd :=
      eqv_trans_nonzero_denom
        (q := qn//qd)
        ‹qd ≄ 0›
        ‹pn//pd ≃ qn//qd›
        ‹qn//qd ≃ rn//rd›
    exact Or.inl ‹pn * rd ≃ rn * pd›

/-!
So all we need to do to have useful fractions is disallow the value `0//0`? Not
quite. So far, all of the operations we've defined on naive fractions have put
the numerator and denominator on equal footing; we could swap them and all our
results would still be valid.

Addition of fractions breaks this symmetry. It requires one of the two
components to measure "quantity" (the numerator) and the other to measure
"scale" (the denominator). The choice is arbitrary, but it must be consistent.

Any sensible definition of fractions needs to support a quantity of zero, at
all possible scales. Thus the numerator must be allowed to become zero. But in
order to prevent the `0//0` case, the simplest thing to do is require that the
denominator is never zero. Fortunately, the natural definition of addition
already does this, as we'll soon see.
-/

/--
Addition of naive integer fractions.

**Intuition**: Similar to the definition of equivalence, our informal
justification is that fractions represent a division operation, which is undone
via multiplication. Also, fractions represent an integer quantity (the
numerator) that has been scaled down in size by an integer factor (the
denominator). If two fractions have the same denominator, their numerators are
"at the same scale" and can thus be added directly.

Those principles lead to the following chain of equivalent expressions, that
provide a reason for our definition of addition:
1. `a//b + c//d`
2. `(a//b) * 1 + 1 * (c//d)`
3. `(a//b) * (d//d) + (b//b) * (c//d)`
4. `(a * d)//(b * d) + (b * c)//(b * d)`
5. `(a * d + b * c)//(b * d)`
-/
def add : Naive.Fraction ℤ → Naive.Fraction ℤ → Naive.Fraction ℤ
| a//b, c//d => (a * d + b * c)//(b * d)

/-- Provide the `· + ·` operator for addition of naive fractions. -/
instance addOp : Add (Naive.Fraction ℤ) := {
  add := add
}

/--
As mentioned above, we cannot avoid having zero-valued numerators if we have
addition of fractions. Here's one example where fractions having nonzero
components produce a numerator with value zero when added.
-/
example : (2//4 + (-1 : ℤ)//2).numerator ≃ 0 := by
  show 2 * 2 + 4 * -1 ≃ 0
  calc
    2 * 2 + 4 * (-1 : ℤ)
      ≃ _ := AA.substR (Rel.symm AA.scompatR)
    2 * 2 + -(4 * 1)
      ≃ _ := AA.substR (AA.subst₁ AA.identR)
    2 * 2 + -4
      ≃ _ := Rel.refl
    coe 2 * coe 2 + -4
      ≃ _ := AA.substL (Rel.symm AA.compat₂)
    coe (2 * 2) + -4
      ≃ _ := AA.substL (AA.subst₁ (AA.substL Natural.literal_step))
    coe (step 1 * 2) + -4
      ≃ _ := AA.substL (AA.subst₁ Natural.step_mul)
    coe (1 * 2 + 2) + -4
      ≃ _ := AA.substL (AA.subst₁ (AA.substL AA.identL))
    coe (2 + 2) + -4
      ≃ _ := AA.substL (AA.subst₁ (AA.substL Natural.literal_step))
    coe (step 1 + 2) + -4
      ≃ _ := AA.substL (AA.subst₁ Natural.step_add_swap)
    coe (1 + step 2) + -4
      ≃ _ := AA.substL (AA.subst₁ (AA.substL Natural.literal_step))
    coe (step 0 + step 2) + -4
      ≃ _ := AA.substL (AA.subst₁ Natural.step_add_swap)
    coe (0 + step (step 2)) + -4
      ≃ _ := AA.substL (AA.subst₁ AA.identL)
    coe (step (step 2)) + -4
      ≃ _ := AA.substL (AA.subst₁ (AA.subst₁ (Rel.symm Natural.literal_step)))
    coe (step 3) + -4
      ≃ _ := AA.substL (AA.subst₁ (Rel.symm Natural.literal_step))
    coe 4 + -4
      ≃ _ := Rel.refl
    4 + -4
      ≃ _ := AA.inverseR
    0
      ≃ _ := Rel.refl

/--
Adding two naive fractions with zero-valued denominators always gives `0//0`.

One might hope that there are cases where adding fractions with zero-valued
denominators can make sense, but this proof shows that's not possible. In fact,
even if only one operand's denominator is zero, it can be seen from the proof
that the result's denominator will still be zero. Thus in any expression adding
naive fractions, if there are just two denominators that are zero, the entire
sum will always reduce to `0//0`, a useless result.

**Proof intuition**: Handle the numerator and the denominator separately. The
numerator becomes zero because it's a sum of two products, where each of them
has a zero-valued denominator as one of the factors. The denominator is zero
because both of its factors are zero.
-/
theorem add_zero_denominators
    {a b : ℤ} : (a//0 + b//0).to_prod ≃ (0//0).to_prod
    := by
  show ((a * 0 + 0 * b)//(0 * 0)).to_prod ≃ (0//0).to_prod
  show (a * 0 + 0 * b, 0 * 0) ≃ (0, 0)
  apply Relation.Equivalence.Impl.Prod.eqv_defn.mpr
  show a * 0 + 0 * b ≃ 0 ∧ 0 * 0 ≃ 0
  apply And.intro
  case left =>
    show a * 0 + 0 * b ≃ 0
    calc
      a * 0 + 0 * b ≃ _ := AA.substL AA.absorbR
      0 + 0 * b     ≃ _ := AA.identL
      0 * b         ≃ _ := AA.absorbL
      0             ≃ _ := Rel.refl
  case right =>
    show 0 * 0 ≃ 0
    exact AA.absorbL

/--
Adding two naive fractions with nonzero denominators always gives a result with
a nonzero denominator.

This result enables us to ban fractions with zero-valued denominators: they can
never be produced as long as we always start with nonzero denominators.

**Proof intuition**: The denominator of a sum of fractions is the product of
the denominators of those fractions. And the product of two nonzero integers is
always nonzero.
-/
theorem add_preserves_nonzero_denominators
    {p q : Naive.Fraction ℤ}
    : Nonzero p.denominator → Nonzero q.denominator
    → Nonzero ((p + q).denominator)
    := by
  revert p; intro (pn//pd); revert q; intro (qn//qd)
  intro (_ : Nonzero pd) (_ : Nonzero qd)
  show Nonzero (pn//pd + qn//qd).denominator
  show Nonzero ((pn * qd + pd * qn)//(pd * qd)).denominator
  show Nonzero (pd * qd)
  exact Integer.mul_preserves_nonzero ‹Nonzero pd› ‹Nonzero qd›

/-!
In summary, if we want to have meaningful equivalence between fractions, we
cannot allow them to have the value `0//0`. But that's not quite enough; if we
allow zero-valued denominators with nonzero numerators, addition of fractions
will inevitably give `0//0` results. Thus there's only one possible option:
we can allow zero-valued numerators, but denominators must always be nonzero.
-/

/--
Adding two naive fractions with positive denominators always gives a result
with a positive denominator.

This is an alternative to the nonzero-denominators approach above, which is in
some ways nicer because it restricts negative values to the numerator only. The
sign of the fraction is then fully determined by the numerator, while the
denominator's only role is to represent the size of the numerator's units.

**Proof intuition**: The denominator of a sum of fractions is the product of
the denominators of those fractions. And the product of two positive integers
is always positive.
-/
theorem add_preserves_positive_denominators
    {p q : Naive.Fraction ℤ}
    : Positive p.denominator → Positive q.denominator
    → Positive ((p + q).denominator)
    := by
  revert p; intro (pn//pd); revert q; intro (qn//qd)
  intro (_ : Positive pd) (_ : Positive qd)
  show Positive (pn//pd + qn//qd).denominator
  show Positive ((pn * qd + pd * qn)//(pd * qd)).denominator
  show Positive (pd * qd)
  exact Integer.mul_preserves_positive ‹Positive pd› ‹Positive qd›

end Lean4Axiomatic.Rational.Impl.Fraction.Naive


/-
Copyright (c) 2018 Jeremy Avigad. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Jeremy Avigad
-/
import data.W.basic

/-!
# Polynomial functors

> THIS FILE IS SYNCHRONIZED WITH MATHLIB4.
> Any changes to this file require a corresponding PR to mathlib4.

This file defines polynomial functors and the W-type construction as a
polynomial functor.  (For the M-type construction, see
pfunctor/M.lean.)
-/

universe u

/--
A polynomial functor `P` is given by a type `A` and a family `B` of types over `A`. `P` maps
any type `α` to a new type `P.obj α`, which is defined as the sigma type `Σ x, P.B x → α`.

An element of `P.obj α` is a pair `⟨a, f⟩`, where `a` is an element of a type `A` and
`f : B a → α`. Think of `a` as the shape of the object and `f` as an index to the relevant
elements of `α`.
-/

structure pfunctor :=
(A : Type u) (B : A → Type u)

namespace pfunctor

instance : inhabited pfunctor :=
⟨⟨default, default⟩⟩

variables (P : pfunctor) {α β : Type u}

/-- Applying `P` to an object of `Type` -/
def obj (α : Type*) := Σ x : P.A, P.B x → α

/-- Applying `P` to a morphism of `Type` -/
def map {α β : Type*} (f : α → β) : P.obj α → P.obj β :=
λ ⟨a, g⟩, ⟨a, f ∘ g⟩

instance obj.inhabited [inhabited P.A] [inhabited α] : inhabited (P.obj α) := ⟨⟨default, default⟩⟩
instance : functor P.obj := {map := @map P}

protected theorem map_eq {α β : Type*} (f : α → β) (a : P.A) (g : P.B a → α) :
  @functor.map P.obj _ _ _ f ⟨a, g⟩ = ⟨a, f ∘ g⟩ :=
rfl

protected theorem id_map {α : Type*} : ∀ x : P.obj α, id <$> x = id x :=
λ ⟨a, b⟩, rfl

protected theorem comp_map {α β γ : Type*} (f : α → β) (g : β → γ) :
  ∀ x : P.obj α, (g ∘ f) <$> x = g <$> (f <$> x) :=
λ ⟨a, b⟩, rfl

instance : is_lawful_functor P.obj :=
{id_map := @pfunctor.id_map P, comp_map := @pfunctor.comp_map P}

/-- re-export existing definition of W-types and
adapt it to a packaged definition of polynomial functor -/
def W := _root_.W_type P.B

/- inhabitants of W types is awkward to encode as an instance
assumption because there needs to be a value `a : P.A`
such that `P.B a` is empty to yield a finite tree -/
attribute [nolint has_nonempty_instance] W
variables {P}

/-- root element  of a W tree -/
def W.head : W P → P.A
| ⟨a, f⟩ := a

/-- children of the root of a W tree -/
def W.children : Π x : W P, P.B (W.head x) → W P
| ⟨a, f⟩ := f

/-- destructor for W-types -/
def W.dest : W P → P.obj (W P)
| ⟨a, f⟩ := ⟨a, f⟩

/-- constructor for W-types -/
def W.mk : P.obj (W P) → W P
| ⟨a, f⟩ := ⟨a, f⟩

@[simp] theorem W.dest_mk (p : P.obj (W P)) : W.dest (W.mk p) = p :=
by cases p; reflexivity

@[simp] theorem W.mk_dest (p : W P) : W.mk (W.dest p) = p :=
by cases p; reflexivity

variables (P)

/-- `Idx` identifies a location inside the application of a pfunctor.
For `F : pfunctor`, `x : F.obj α` and `i : F.Idx`, `i` can designate
one part of `x` or is invalid, if `i.1 ≠ x.1` -/
def Idx := Σ x : P.A, P.B x

instance Idx.inhabited [inhabited P.A] [inhabited (P.B default)] : inhabited P.Idx :=
⟨⟨default, default⟩⟩

variables {P}

/-- `x.iget i` takes the component of `x` designated by `i` if any is or returns
a default value -/
def obj.iget [decidable_eq P.A] {α} [inhabited α] (x : P.obj α) (i : P.Idx) : α :=
if h : i.1 = x.1
  then x.2 (cast (congr_arg _ h) i.2)
  else default

@[simp]
lemma fst_map {α β : Type u} (x : P.obj α) (f : α → β) :
  (f <$> x).1 = x.1 := by { cases x; refl }

@[simp]
lemma iget_map [decidable_eq P.A] {α β : Type u} [inhabited α] [inhabited β]
  (x : P.obj α) (f : α → β) (i : P.Idx)
  (h : i.1 = x.1) :
  (f <$> x).iget i = f (x.iget i) :=
by { simp only [obj.iget, fst_map, *, dif_pos, eq_self_iff_true],
     cases x, refl }

end pfunctor

/-
Composition of polynomial functors.
-/

namespace pfunctor

/-- functor composition for polynomial functors -/
def comp (P₂ P₁ : pfunctor.{u}) : pfunctor.{u} :=
⟨ Σ a₂ : P₂.1, P₂.2 a₂ → P₁.1,
  λ a₂a₁, Σ u : P₂.2 a₂a₁.1, P₁.2 (a₂a₁.2 u) ⟩

/-- constructor for composition -/
def comp.mk (P₂ P₁ : pfunctor.{u}) {α : Type} (x : P₂.obj (P₁.obj α)) : (comp P₂ P₁).obj α :=
⟨ ⟨ x.1, sigma.fst ∘ x.2 ⟩, λ a₂a₁, (x.2 a₂a₁.1).2 a₂a₁.2  ⟩

/-- destructor for composition -/
def comp.get (P₂ P₁ : pfunctor.{u}) {α : Type} (x : (comp P₂ P₁).obj α) : P₂.obj (P₁.obj α) :=
⟨ x.1.1, λ a₂, ⟨x.1.2 a₂, λ a₁, x.2 ⟨a₂,a₁⟩ ⟩ ⟩

end pfunctor

/-
Lifting predicates and relations.
-/

namespace pfunctor
variables {P : pfunctor.{u}}
open functor

theorem liftp_iff {α : Type u} (p : α → Prop) (x : P.obj α) :
  liftp p x ↔ ∃ a f, x = ⟨a, f⟩ ∧ ∀ i, p (f i) :=
begin
  split,
  { rintros ⟨y, hy⟩, cases h : y with a f,
    refine ⟨a, λ i, (f i).val, _, λ i, (f i).property⟩,
    rw [←hy, h, pfunctor.map_eq] },
  rintros ⟨a, f, xeq, pf⟩,
  use ⟨a, λ i, ⟨f i, pf i⟩⟩,
  rw [xeq], reflexivity
end

theorem liftp_iff' {α : Type u} (p : α → Prop) (a : P.A) (f : P.B a → α) :
  @liftp.{u} P.obj _ α p ⟨a,f⟩ ↔ ∀ i, p (f i) :=
begin
  simp only [liftp_iff, sigma.mk.inj_iff]; split; intro,
  { casesm* [Exists _, _ ∧ _], subst_vars, assumption },
  repeat { constructor <|> assumption }
end

theorem liftr_iff {α : Type u} (r : α → α → Prop) (x y : P.obj α) :
  liftr r x y ↔ ∃ a f₀ f₁, x = ⟨a, f₀⟩ ∧ y = ⟨a, f₁⟩ ∧ ∀ i, r (f₀ i) (f₁ i) :=
begin
  split,
  { rintros ⟨u, xeq, yeq⟩, cases h : u with a f,
    use [a, λ i, (f i).val.fst, λ i, (f i).val.snd],
    split, { rw [←xeq, h], refl },
    split, { rw [←yeq, h], refl },
    intro i, exact (f i).property },
  rintros ⟨a, f₀, f₁, xeq, yeq, h⟩,
  use ⟨a, λ i, ⟨(f₀ i, f₁ i), h i⟩⟩,
  split,
  { rw [xeq], refl },
  rw [yeq], refl
end

open set

theorem supp_eq {α : Type u} (a : P.A) (f : P.B a → α) :
  @supp.{u} P.obj _ α  (⟨a,f⟩ : P.obj α) = f '' univ :=
begin
  ext, simp only [supp, image_univ, mem_range, mem_set_of_eq],
  split; intro h,
  { apply @h (λ x, ∃ (y : P.B a), f y = x),
    rw liftp_iff', intro, refine ⟨_,rfl⟩ },
  { simp only [liftp_iff'], cases h, subst x,
    tauto }
end

end pfunctor


/-
Copyright (c) 2021 Yury G. Kudryashov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yury G. Kudryashov, Alex Kontorovich
-/
import order.filter.bases

/-!
# (Co)product of a family of filters

> THIS FILE IS SYNCHRONIZED WITH MATHLIB4.
> Any changes to this file require a corresponding PR to mathlib4.

In this file we define two filters on `Π i, α i` and prove some basic properties of these filters.

* `filter.pi (f : Π i, filter (α i))` to be the maximal filter on `Π i, α i` such that
  `∀ i, filter.tendsto (function.eval i) (filter.pi f) (f i)`. It is defined as
  `Π i, filter.comap (function.eval i) (f i)`. This is a generalization of `filter.prod` to indexed
  products.

* `filter.Coprod (f : Π i, filter (α i))`: a generalization of `filter.coprod`; it is the supremum
  of `comap (eval i) (f i)`.
-/

open set function
open_locale classical filter

namespace filter

variables {ι : Type*} {α : ι → Type*} {f f₁ f₂ : Π i, filter (α i)} {s : Π i, set (α i)}

section pi

/-- The product of an indexed family of filters. -/
def pi (f : Π i, filter (α i)) : filter (Π i, α i) := ⨅ i, comap (eval i) (f i)

instance pi.is_countably_generated [countable ι] [∀ i, is_countably_generated (f i)] :
  is_countably_generated (pi f) :=
infi.is_countably_generated _

lemma tendsto_eval_pi (f : Π i, filter (α i)) (i : ι) :
  tendsto (eval i) (pi f) (f i) :=
tendsto_infi' i tendsto_comap

lemma tendsto_pi {β : Type*} {m : β → Π i, α i} {l : filter β} :
  tendsto m l (pi f) ↔ ∀ i, tendsto (λ x, m x i) l (f i) :=
by simp only [pi, tendsto_infi, tendsto_comap_iff]

lemma le_pi {g : filter (Π i, α i)} : g ≤ pi f ↔ ∀ i, tendsto (eval i) g (f i) := tendsto_pi

@[mono] lemma pi_mono (h : ∀ i, f₁ i ≤ f₂ i) : pi f₁ ≤ pi f₂ := infi_mono $ λ i, comap_mono $ h i

lemma mem_pi_of_mem (i : ι) {s : set (α i)} (hs : s ∈ f i) :
  eval i ⁻¹' s ∈ pi f :=
mem_infi_of_mem i $ preimage_mem_comap hs

lemma pi_mem_pi {I : set ι} (hI : I.finite) (h : ∀ i ∈ I, s i ∈ f i) :
  I.pi s ∈ pi f :=
begin
  rw [pi_def, bInter_eq_Inter],
  refine mem_infi_of_Inter hI (λ i, _) subset.rfl,
  exact preimage_mem_comap (h i i.2)
end

lemma mem_pi {s : set (Π i, α i)} : s ∈ pi f ↔
  ∃ (I : set ι), I.finite ∧ ∃ t : Π i, set (α i), (∀ i, t i ∈ f i) ∧ I.pi t ⊆ s :=
begin
  split,
  { simp only [pi, mem_infi', mem_comap, pi_def],
    rintro ⟨I, If, V, hVf, hVI, rfl, -⟩, choose t htf htV using hVf,
    exact ⟨I, If, t, htf, Inter₂_mono (λ i _, htV i)⟩ },
  { rintro ⟨I, If, t, htf, hts⟩,
    exact mem_of_superset (pi_mem_pi If $ λ i _, htf i) hts }
end

lemma mem_pi' {s : set (Π i, α i)} : s ∈ pi f ↔
  ∃ (I : finset ι), ∃ t : Π i, set (α i), (∀ i, t i ∈ f i) ∧ set.pi ↑I t ⊆ s :=
mem_pi.trans exists_finite_iff_finset

lemma mem_of_pi_mem_pi [∀ i, ne_bot (f i)] {I : set ι} (h : I.pi s ∈ pi f) {i : ι} (hi : i ∈ I) :
  s i ∈ f i :=
begin
  rcases mem_pi.1 h with ⟨I', I'f, t, htf, hts⟩,
  refine mem_of_superset (htf i) (λ x hx, _),
  have : ∀ i, (t i).nonempty, from λ i, nonempty_of_mem (htf i),
  choose g hg,
  have : update g i x ∈ I'.pi t,
  { intros j hj, rcases eq_or_ne j i with (rfl|hne); simp * },
  simpa using hts this i hi
end

@[simp] lemma pi_mem_pi_iff [∀ i, ne_bot (f i)] {I : set ι} (hI : I.finite) :
  I.pi s ∈ pi f ↔ ∀ i ∈ I, s i ∈ f i :=
⟨λ h i hi, mem_of_pi_mem_pi h hi, pi_mem_pi hI⟩

lemma has_basis_pi {ι' : ι → Type} {s : Π i, ι' i → set (α i)} {p : Π i, ι' i → Prop}
  (h : ∀ i, (f i).has_basis (p i) (s i)) :
  (pi f).has_basis (λ If : set ι × Π i, ι' i, If.1.finite ∧ ∀ i ∈ If.1, p i (If.2 i))
    (λ If : set ι × Π i, ι' i, If.1.pi (λ i, s i $ If.2 i)) :=
begin
  have : (pi f).has_basis _ _ := has_basis_infi' (λ i, (h i).comap (eval i : (Π j, α j) → α i)),
  convert this,
  ext,
  simp
end

@[simp] lemma pi_inf_principal_univ_pi_eq_bot :
  pi f ⊓ 𝓟 (set.pi univ s) = ⊥ ↔ ∃ i, f i ⊓ 𝓟 (s i) = ⊥ :=
begin
  split,
  { simp only [inf_principal_eq_bot, mem_pi], contrapose!,
    rintros (hsf : ∀ i, ∃ᶠ x in f i, x ∈ s i) I If t htf hts,
    have : ∀ i, (s i ∩ t i).nonempty, from λ i, ((hsf i).and_eventually (htf i)).exists,
    choose x hxs hxt,
    exact hts (λ i hi, hxt i) (mem_univ_pi.2 hxs) },
  { simp only [inf_principal_eq_bot],
    rintro ⟨i, hi⟩,
    filter_upwards [mem_pi_of_mem i hi] with x using mt (λ h, h i trivial), },
end

@[simp] lemma pi_inf_principal_pi_eq_bot [Π i, ne_bot (f i)] {I : set ι} :
  pi f ⊓ 𝓟 (set.pi I s) = ⊥ ↔ ∃ i ∈ I, f i ⊓ 𝓟 (s i) = ⊥ :=
begin
  rw [← univ_pi_piecewise I, pi_inf_principal_univ_pi_eq_bot],
  refine exists_congr (λ i, _),
  by_cases hi : i ∈ I; simp [hi, (‹Π i, ne_bot (f i)› i).ne]
end

@[simp] lemma pi_inf_principal_univ_pi_ne_bot :
  ne_bot (pi f ⊓ 𝓟 (set.pi univ s)) ↔ ∀ i, ne_bot (f i ⊓ 𝓟 (s i)) :=
by simp [ne_bot_iff]

@[simp] lemma pi_inf_principal_pi_ne_bot [Π i, ne_bot (f i)] {I : set ι} :
  ne_bot (pi f ⊓ 𝓟 (I.pi s)) ↔ ∀ i ∈ I, ne_bot (f i ⊓ 𝓟 (s i)) :=
by simp [ne_bot_iff]

instance pi_inf_principal_pi.ne_bot [h : ∀ i, ne_bot (f i ⊓ 𝓟 (s i))] {I : set ι} :
  ne_bot (pi f ⊓ 𝓟 (I.pi s)) :=
(pi_inf_principal_univ_pi_ne_bot.2 ‹_›).mono $ inf_le_inf_left _ $ principal_mono.2 $
  λ x hx i hi, hx i trivial

@[simp] lemma pi_eq_bot : pi f = ⊥ ↔ ∃ i, f i = ⊥ :=
by simpa using @pi_inf_principal_univ_pi_eq_bot ι α f (λ _, univ)

@[simp]

instance [∀ i, ne_bot (f i)] : ne_bot (pi f) := pi_ne_bot.2 ‹_›

@[simp] lemma map_eval_pi (f : Π i, filter (α i)) [∀ i, ne_bot (f i)] (i : ι) :
  map (eval i) (pi f) = f i :=
begin
  refine le_antisymm (tendsto_eval_pi f i) (λ s hs, _),
  rcases mem_pi.1 (mem_map.1 hs) with ⟨I, hIf, t, htf, hI⟩,
  rw [← image_subset_iff] at hI,
  refine mem_of_superset (htf i) ((subset_eval_image_pi _ _).trans hI),
  exact nonempty_of_mem (pi_mem_pi hIf (λ i hi, htf i))
end

@[simp] lemma pi_le_pi [∀ i, ne_bot (f₁ i)] : pi f₁ ≤ pi f₂ ↔ ∀ i, f₁ i ≤ f₂ i :=
⟨λ h i, map_eval_pi f₁ i ▸ (tendsto_eval_pi _ _).mono_left h, pi_mono⟩

@[simp] lemma pi_inj [∀ i, ne_bot (f₁ i)] : pi f₁ = pi f₂ ↔ f₁ = f₂ :=
begin
  refine ⟨λ h, _, congr_arg pi⟩,
  have hle : f₁ ≤ f₂ := pi_le_pi.1 h.le,
  haveI : ∀ i, ne_bot (f₂ i) := λ i, ne_bot_of_le (hle i),
  exact hle.antisymm (pi_le_pi.1 h.ge)
end

end pi

/-! ### `n`-ary coproducts of filters -/

section Coprod

/-- Coproduct of filters. -/
protected def Coprod (f : Π i, filter (α i)) : filter (Π i, α i) :=
⨆ i : ι, comap (eval i) (f i)

lemma mem_Coprod_iff {s : set (Π i, α i)} :
  (s ∈ filter.Coprod f) ↔ (∀ i : ι, (∃ t₁ ∈ f i, eval i ⁻¹' t₁ ⊆ s)) :=
by simp [filter.Coprod]

lemma compl_mem_Coprod {s : set (Π i, α i)} :
  sᶜ ∈ filter.Coprod f ↔ ∀ i, (eval i '' s)ᶜ ∈ f i :=
by simp only [filter.Coprod, mem_supr, compl_mem_comap]

lemma Coprod_ne_bot_iff' :
  ne_bot (filter.Coprod f) ↔ (∀ i, nonempty (α i)) ∧ ∃ d, ne_bot (f d) :=
by simp only [filter.Coprod, supr_ne_bot, ← exists_and_distrib_left, ← comap_eval_ne_bot_iff']

@[simp] lemma Coprod_ne_bot_iff [∀ i, nonempty (α i)] :
  ne_bot (filter.Coprod f) ↔ ∃ d, ne_bot (f d) :=
by simp [Coprod_ne_bot_iff', *]

lemma Coprod_eq_bot_iff' : filter.Coprod f = ⊥ ↔ (∃ i, is_empty (α i)) ∨ f = ⊥ :=
by simpa [not_and_distrib, funext_iff] using not_congr Coprod_ne_bot_iff'

@[simp] lemma Coprod_eq_bot_iff [∀ i, nonempty (α i)] : filter.Coprod f = ⊥ ↔ f = ⊥ :=
by simpa [funext_iff] using not_congr Coprod_ne_bot_iff

@[simp] lemma Coprod_bot' : filter.Coprod (⊥ : Π i, filter (α i)) = ⊥ :=
Coprod_eq_bot_iff'.2 (or.inr rfl)

@[simp] lemma Coprod_bot : filter.Coprod (λ _, ⊥ : Π i, filter (α i)) = ⊥ := Coprod_bot'

lemma ne_bot.Coprod [∀ i, nonempty (α i)] {i : ι} (h : ne_bot (f i)) :
  ne_bot (filter.Coprod f) :=
Coprod_ne_bot_iff.2 ⟨i, h⟩

@[instance] lemma Coprod_ne_bot [∀ i, nonempty (α i)] [nonempty ι] (f : Π i, filter (α i))
  [H : ∀ i, ne_bot (f i)] : ne_bot (filter.Coprod f) :=
(H (classical.arbitrary ι)).Coprod

@[mono] lemma Coprod_mono (hf : ∀ i, f₁ i ≤ f₂ i) : filter.Coprod f₁ ≤ filter.Coprod f₂ :=
supr_mono $ λ i, comap_mono (hf i)

variables {β : ι → Type*} {m : Π i, α i → β i}

lemma map_pi_map_Coprod_le :
  map (λ (k : Π i, α i), λ i, m i (k i)) (filter.Coprod f) ≤ filter.Coprod (λ i, map (m i) (f i)) :=
begin
  simp only [le_def, mem_map, mem_Coprod_iff],
  intros s h i,
  obtain ⟨t, H, hH⟩ := h i,
  exact ⟨{x : α i | m i x ∈ t}, H, λ x hx, hH hx⟩
end

lemma tendsto.pi_map_Coprod {g : Π i, filter (β i)} (h : ∀ i, tendsto (m i) (f i) (g i)) :
  tendsto (λ (k : Π i, α i), λ i, m i (k i)) (filter.Coprod f) (filter.Coprod g) :=
map_pi_map_Coprod_le.trans (Coprod_mono h)

end Coprod

end filter


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

import category_theory.limits.shapes.products
import category_theory.epi_mono

/-!

# Adjunctions involving evaluation

We show that evaluation of functors have adjoints, given the existence of (co)products.

-/

namespace category_theory

open category_theory.limits

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

noncomputable theory

section

variables [∀ (a b : C), has_coproducts_of_shape (a ⟶ b) D]

/-- The left adjoint of evaluation. -/
@[simps]
def evaluation_left_adjoint (c : C) : D ⥤ C ⥤ D :=
{ obj := λ d,
  { obj := λ t, ∐ (λ i : c ⟶ t, d),
    map := λ u v f, sigma.desc $ λ g, sigma.ι (λ _, d) $ g ≫ f,
    map_id' := begin
      intros, ext, simp only [cofan.mk_ι_app, colimit.ι_desc, category.comp_id],
      congr' 1, rw category.comp_id,
    end,
    map_comp' := begin
      intros, ext, simp only [cofan.mk_ι_app, colimit.ι_desc_assoc, colimit.ι_desc],
      congr' 1, rw category.assoc,
    end },
  map := λ d₁ d₂ f,
  { app := λ e, sigma.desc $ λ h, f ≫ sigma.ι (λ _, d₂) h,
    naturality' := by { intros, ext, dsimp, simp } },
  map_id' := by { intros, ext, dsimp, simp },
  map_comp' := by { intros, ext, dsimp, simp } }

/-- The adjunction showing that evaluation is a right adjoint. -/
@[simps unit_app counit_app_app]
def evaluation_adjunction_right (c : C) :
  evaluation_left_adjoint D c ⊣ (evaluation _ _).obj c :=
adjunction.mk_of_hom_equiv
{ hom_equiv := λ d F,
  { to_fun := λ f, sigma.ι (λ _, d) (𝟙 _) ≫ f.app c,
    inv_fun := λ f,
    { app := λ e, sigma.desc $ λ h, f ≫ F.map h,
      naturality' := by { intros, ext, dsimp, simp } },
    left_inv := begin
      intros f,
      ext x g,
      dsimp,
      simp only [colimit.ι_desc, limits.cofan.mk_ι_app, category.assoc, ← f.naturality,
        evaluation_left_adjoint_obj_map, colimit.ι_desc_assoc, cofan.mk_ι_app],
      congr' 2,
      rw category.id_comp
    end,
    right_inv := λ f, by { dsimp, simp } },
  hom_equiv_naturality_left_symm' := by { intros, ext, dsimp, simp },
  hom_equiv_naturality_right' := by { intros, dsimp, simp } }

instance evaluation_is_right_adjoint (c : C) :
  is_right_adjoint ((evaluation _ D).obj c) :=
⟨_, evaluation_adjunction_right _ _⟩

lemma nat_trans.mono_iff_app_mono {F G : C ⥤ D} (η : F ⟶ G) :
  mono η ↔ (∀ c, mono (η.app c)) :=
begin
  split,
  { intros h c,
    exact right_adjoint_preserves_mono (evaluation_adjunction_right D c) h },
  { introsI _,
    apply nat_trans.mono_app_of_mono }
end

end

section

variables [∀ (a b : C), has_products_of_shape (a ⟶ b) D]

/-- The right adjoint of evaluation. -/
@[simps]
def evaluation_right_adjoint (c : C) : D ⥤ C ⥤ D :=
{ obj := λ d,
  { obj := λ t, ∏ (λ i : t ⟶ c, d),
    map := λ u v f, pi.lift $ λ g, pi.π _ $ f ≫ g,
    map_id' := begin
      intros, ext, dsimp,
      simp only [limit.lift_π, category.id_comp, fan.mk_π_app],
      congr, simp,
    end,
    map_comp' := begin
      intros, ext, dsimp,
      simp only [limit.lift_π, fan.mk_π_app, category.assoc],
      congr' 1, simp,
    end },
  map := λ d₁ d₂ f,
  { app := λ t, pi.lift $ λ g, pi.π _ g ≫ f,
    naturality' := by { intros, ext, dsimp, simp } },
  map_id' := by { intros, ext, dsimp, simp },
  map_comp' := by { intros, ext, dsimp, simp } }

/-- The adjunction showing that evaluation is a left adjoint. -/
@[simps unit_app_app counit_app]
def evaluation_adjunction_left (c : C) :
  (evaluation _ _).obj c ⊣ evaluation_right_adjoint D c :=
adjunction.mk_of_hom_equiv
{ hom_equiv := λ F d,
  { to_fun := λ f,
    { app := λ t, pi.lift $ λ g, F.map g ≫ f,
      naturality' := by { intros, ext, dsimp, simp } },
    inv_fun := λ f, f.app _ ≫ pi.π _ (𝟙 _),
    left_inv := λ f, by { dsimp, simp },
    right_inv := begin
      intros f,
      ext x g,
      dsimp,
      simp only [limit.lift_π, evaluation_right_adjoint_obj_map,
        nat_trans.naturality_assoc, fan.mk_π_app],
      congr,
      rw category.comp_id
    end },
  hom_equiv_naturality_left_symm' := by { intros, dsimp, simp },
  hom_equiv_naturality_right' := by { intros, ext, dsimp, simp } }

instance evaluation_is_left_adjoint (c : C) :
  is_left_adjoint ((evaluation _ D).obj c) :=
⟨_, evaluation_adjunction_left _ _⟩

lemma nat_trans.epi_iff_app_epi {F G : C ⥤ D} (η : F ⟶ G) :
  epi η ↔ (∀ c, epi (η.app c)) :=
begin
  split,
  { intros h c,
    exact left_adjoint_preserves_epi (evaluation_adjunction_left D c) h },
  { introsI,
    apply nat_trans.epi_app_of_epi }
end

end

end category_theory


variables p q : Prop

example (h : p ∧ q) : q ∧ p :=
  have hp : p, from and.left h,
  suffices  hq : q, from and.intro hq hp,
  show q, from and.right h


/-
Copyright (c) 2016 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura

Auxiliary lemmas used to compare int numerals.
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.data.int.order

namespace Mathlib

namespace int

/- Auxiliary lemmas for proving that to int numerals are different -/

/- 1. Lemmas for reducing the problem to the case where the numerals are positive -/

protected theorem ne_neg_of_ne {a : ℤ} {b : ℤ} : a ≠ b → -a ≠ -b :=
  fun (h₁ : a ≠ b) (h₂ : -a = -b) => absurd (int.neg_inj h₂) h₁

protected theorem neg_ne_zero_of_ne {a : ℤ} : a ≠ 0 → -a ≠ 0 :=
  fun (h₁ : a ≠ 0) (h₂ : -a = 0) =>
    (fun (this : -a = -0) => (fun (this : a = 0) => absurd this h₁) (int.neg_inj this))
      (eq.mpr (id (Eq._oldrec (Eq.refl (-a = -0)) int.neg_zero)) h₂)

protected theorem zero_ne_neg_of_ne {a : ℤ} (h : 0 ≠ a) : 0 ≠ -a :=
  ne.symm (int.neg_ne_zero_of_ne (ne.symm h))

protected theorem neg_ne_of_pos {a : ℤ} {b : ℤ} : a > 0 → b > 0 → -a ≠ b := sorry

protected theorem ne_neg_of_pos {a : ℤ} {b : ℤ} : a > 0 → b > 0 → a ≠ -b :=
  fun (h₁ : a > 0) (h₂ : b > 0) => ne.symm (int.neg_ne_of_pos h₂ h₁)

/- 2. Lemmas for proving that positive int numerals are nonneg and positive -/

protected theorem one_pos : 1 > 0 := int.zero_lt_one

protected theorem bit0_pos {a : ℤ} : a > 0 → bit0 a > 0 := fun (h : a > 0) => int.add_pos h h

protected theorem bit1_pos {a : ℤ} : a ≥ 0 → bit1 a > 0 :=
  fun (h : a ≥ 0) => int.lt_add_of_le_of_pos (int.add_nonneg h h) int.zero_lt_one

protected theorem zero_nonneg : 0 ≥ 0 := le_refl 0

protected theorem one_nonneg : 1 ≥ 0 := le_of_lt int.zero_lt_one

protected theorem bit0_nonneg {a : ℤ} : a ≥ 0 → bit0 a ≥ 0 := fun (h : a ≥ 0) => int.add_nonneg h h

protected theorem bit1_nonneg {a : ℤ} : a ≥ 0 → bit1 a ≥ 0 :=
  fun (h : a ≥ 0) => le_of_lt (int.bit1_pos h)

protected theorem nonneg_of_pos {a : ℤ} : a > 0 → a ≥ 0 := le_of_lt

/- 3. nat_abs auxiliary lemmas -/

theorem neg_succ_of_nat_lt_zero (n : ℕ) : Int.negSucc n < 0 := sorry

theorem of_nat_ge_zero (n : ℕ) : Int.ofNat n ≥ 0 :=
  le.intro
    (eq.mpr (id (Eq._oldrec (Eq.refl (0 + ↑n = Int.ofNat n)) (int.zero_add ↑n)))
      (eq.mpr (id (Eq._oldrec (Eq.refl (↑n = Int.ofNat n)) (int.coe_nat_eq n)))
        (Eq.refl (Int.ofNat n))))

theorem of_nat_nat_abs_eq_of_nonneg {a : ℤ} : a ≥ 0 → Int.ofNat (nat_abs a) = a := sorry

theorem ne_of_nat_abs_ne_nat_abs_of_nonneg {a : ℤ} {b : ℤ} (ha : a ≥ 0) (hb : b ≥ 0)
    (h : nat_abs a ≠ nat_abs b) : a ≠ b :=
  sorry

protected theorem ne_of_nat_ne_nonneg_case {a : ℤ} {b : ℤ} {n : ℕ} {m : ℕ} (ha : a ≥ 0) (hb : b ≥ 0)
    (e1 : nat_abs a = n) (e2 : nat_abs b = m) (h : n ≠ m) : a ≠ b :=
  (fun (this : nat_abs a ≠ nat_abs b) => ne_of_nat_abs_ne_nat_abs_of_nonneg ha hb this)
    (eq.mpr (id (Eq._oldrec (Eq.refl (nat_abs a ≠ nat_abs b)) e1))
      (eq.mpr (id (Eq._oldrec (Eq.refl (n ≠ nat_abs b)) e2)) h))

/- 4. Aux lemmas for pushing nat_abs inside numerals
   nat_abs_zero and nat_abs_one are defined at init/data/int/basic.lean -/

theorem nat_abs_of_nat_core (n : ℕ) : nat_abs (Int.ofNat n) = n := rfl

theorem nat_abs_of_neg_succ_of_nat (n : ℕ) : nat_abs (Int.negSucc n) = Nat.succ n := rfl

protected theorem nat_abs_add_nonneg {a : ℤ} {b : ℤ} :
    a ≥ 0 → b ≥ 0 → nat_abs (a + b) = nat_abs a + nat_abs b :=
  sorry

protected theorem nat_abs_add_neg {a : ℤ} {b : ℤ} :
    a < 0 → b < 0 → nat_abs (a + b) = nat_abs a + nat_abs b :=
  sorry

protected theorem nat_abs_bit0 (a : ℤ) : nat_abs (bit0 a) = bit0 (nat_abs a) := sorry

protected theorem nat_abs_bit0_step {a : ℤ} {n : ℕ} (h : nat_abs a = n) :
    nat_abs (bit0 a) = bit0 n :=
  eq.mpr (id (Eq._oldrec (Eq.refl (nat_abs (bit0 a) = bit0 n)) (Eq.symm h))) (int.nat_abs_bit0 a)

protected theorem nat_abs_bit1_nonneg {a : ℤ} (h : a ≥ 0) : nat_abs (bit1 a) = bit1 (nat_abs a) :=
  sorry

protected theorem nat_abs_bit1_nonneg_step {a : ℤ} {n : ℕ} (h₁ : a ≥ 0) (h₂ : nat_abs a = n) :
    nat_abs (bit1 a) = bit1 n :=
  eq.mpr (id (Eq._oldrec (Eq.refl (nat_abs (bit1 a) = bit1 n)) (Eq.symm h₂)))
    (int.nat_abs_bit1_nonneg h₁)

end Mathlib


/-
Copyright (c) 2020 David Wärn. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: David Wärn
-/
import order.ideal

/-!
# The back and forth method and countable dense linear orders

## Results

Suppose `α β` are linear orders, with `α` countable and `β` dense, nonempty, without endpoints.
Then there is an order embedding `α ↪ β`. If in addition `α` is dense, nonempty, without
endpoints and `β` is countable, then we can upgrade this to an order isomorphism `α ≃ β`.

The idea for both results is to consider "partial isomorphisms", which
identify a finite subset of `α` with a finite subset of `β`, and prove that
for any such partial isomorphism `f` and `a : α`, we can extend `f` to
include `a` in its domain.

## References

https://en.wikipedia.org/wiki/Back-and-forth_method

## Tags

back and forth, dense, countable, order

-/

noncomputable theory
open_locale classical

namespace order

/-- Suppose `α` is a nonempty dense linear order without endpoints, and
    suppose `lo`, `hi`, are finite subssets with all of `lo` strictly
    before `hi`. Then there is an element of `α` strictly between `lo`
    and `hi`. -/
lemma exists_between_finsets {α : Type*} [linear_order α]
  [densely_ordered α] [no_min_order α] [no_max_order α] [nonem : nonempty α]
  (lo hi : finset α) (lo_lt_hi : ∀ (x ∈ lo) (y ∈ hi), x < y) :
  ∃ m : α, (∀ x ∈ lo, x < m) ∧ (∀ y ∈ hi, m < y) :=
if nlo : lo.nonempty then
  if nhi : hi.nonempty then -- both sets are nonempty, use densely_ordered
    exists.elim (exists_between (lo_lt_hi _ (finset.max'_mem _ nlo) _ (finset.min'_mem _ nhi)))
      (λ m hm, ⟨m, λ x hx, lt_of_le_of_lt (finset.le_max' lo x hx) hm.1,
                   λ y hy, lt_of_lt_of_le hm.2 (finset.min'_le hi y hy)⟩)
  else -- upper set is empty, use `no_max_order`
    exists.elim (exists_gt (finset.max' lo nlo)) (λ m hm,
    ⟨m, λ x hx, lt_of_le_of_lt (finset.le_max' lo x hx) hm,
        λ y hy, (nhi ⟨y, hy⟩).elim⟩)
else
  if nhi : hi.nonempty then -- lower set is empty, use `no_min_order`
    exists.elim (exists_lt (finset.min' hi nhi)) (λ m hm,
    ⟨m, λ x hx, (nlo ⟨x, hx⟩).elim,
        λ y hy, lt_of_lt_of_le hm (finset.min'_le hi y hy)⟩)
  else -- both sets are empty, use nonempty
    nonem.elim (λ m,
    ⟨m, λ x hx, (nlo ⟨x, hx⟩).elim,
        λ y hy, (nhi ⟨y, hy⟩).elim⟩)

variables (α β : Type*) [linear_order α] [linear_order β]

/-- The type of partial order isomorphisms between `α` and `β` defined on finite subsets.
    A partial order isomorphism is encoded as a finite subset of `α × β`, consisting
    of pairs which should be identified. -/
def partial_iso : Type* :=
{ f : finset (α × β) // ∀ (p q ∈ f),
  cmp (prod.fst p) (prod.fst q) = cmp (prod.snd p) (prod.snd q) }

namespace partial_iso

instance : inhabited (partial_iso α β) := ⟨⟨∅, λ p h q, h.elim⟩⟩
instance : preorder (partial_iso α β) := subtype.preorder _

variables {α β}

/-- For each `a`, we can find a `b` in the codomain, such that `a`'s relation to
the domain of `f` is `b`'s relation to the image of `f`.

Thus, if `a` is not already in `f`, then we can extend `f` by sending `a` to `b`.
-/
lemma exists_across [densely_ordered β] [no_min_order β] [no_max_order β] [nonempty β]
  (f : partial_iso α β) (a : α) :
  ∃ b : β, ∀ (p ∈ f.val), cmp (prod.fst p) a = cmp (prod.snd p) b :=
begin
  by_cases h : ∃ b, (a, b) ∈ f.val,
  { cases h with b hb, exact ⟨b, λ p hp, f.property _ hp _ hb⟩, },
  have : ∀ (x ∈ (f.val.filter (λ (p : α × β), p.fst < a)).image prod.snd)
           (y ∈ (f.val.filter (λ (p : α × β), a < p.fst)).image prod.snd),
    x < y,
  { intros x hx y hy,
    rw finset.mem_image at hx hy,
    rcases hx with ⟨p, hp1, rfl⟩,
    rcases hy with ⟨q, hq1, rfl⟩,
    rw finset.mem_filter at hp1 hq1,
    rw ←lt_iff_lt_of_cmp_eq_cmp (f.property _ hp1.1 _ hq1.1),
    exact lt_trans hp1.right hq1.right, },
  cases exists_between_finsets _ _ this with b hb,
  use b,
  rintros ⟨p1, p2⟩ hp,
  have : p1 ≠ a := λ he, h ⟨p2, he ▸ hp⟩,
  cases lt_or_gt_of_ne this with hl hr,
  { have : p1 < a ∧ p2 < b := ⟨hl, hb.1 _ (finset.mem_image.mpr ⟨(p1, p2),
                        finset.mem_filter.mpr ⟨hp, hl⟩, rfl⟩)⟩,
    rw [←cmp_eq_lt_iff, ←cmp_eq_lt_iff] at this, cc, },
  { have : a < p1 ∧ b < p2 := ⟨hr, hb.2 _ (finset.mem_image.mpr ⟨(p1, p2),
                        finset.mem_filter.mpr ⟨hp, hr⟩, rfl⟩)⟩,
    rw [←cmp_eq_gt_iff, ←cmp_eq_gt_iff] at this, cc, },
end

/-- A partial isomorphism between `α` and `β` is also a partial isomorphism between `β` and `α`. -/
protected def comm : partial_iso α β → partial_iso β α :=
subtype.map (finset.image (equiv.prod_comm _ _)) $ λ f hf p hp q hq,
  eq.symm $ hf ((equiv.prod_comm α β).symm p)
(by { rw [←finset.mem_coe, finset.coe_image, equiv.image_eq_preimage] at hp, rwa ←finset.mem_coe })
 ((equiv.prod_comm α β).symm q)
(by { rw [←finset.mem_coe, finset.coe_image, equiv.image_eq_preimage] at hq, rwa ←finset.mem_coe })

variable (β)
/-- The set of partial isomorphisms defined at `a : α`, together with a proof that any
    partial isomorphism can be extended to one defined at `a`. -/
def defined_at_left [densely_ordered β] [no_min_order β] [no_max_order β] [nonempty β]
  (a : α) : cofinal (partial_iso α β) :=
{ carrier := λ f, ∃ b : β, (a, b) ∈ f.val,
  mem_gt :=
  begin
    intro f,
    cases exists_across f a with b a_b,
    refine ⟨⟨insert (a, b) f.val, _⟩, ⟨b, finset.mem_insert_self _ _⟩, finset.subset_insert _ _⟩,
    intros p hp q hq,
    rw finset.mem_insert at hp hq,
    rcases hp with rfl | pf;
    rcases hq with rfl | qf,
    { simp },
    { rw cmp_eq_cmp_symm, exact a_b _ qf },
    { exact a_b _ pf },
    { exact f.property _ pf _ qf },
  end }

variables (α) {β}
/-- The set of partial isomorphisms defined at `b : β`, together with a proof that any
    partial isomorphism can be extended to include `b`. We prove this by symmetry. -/
def defined_at_right [densely_ordered α] [no_min_order α] [no_max_order α] [nonempty α]
  (b : β) : cofinal (partial_iso α β) :=
{ carrier := λ f, ∃ a, (a, b) ∈ f.val,
  mem_gt :=
  begin
    intro f,
    rcases (defined_at_left α b).mem_gt f.comm with ⟨f', ⟨a, ha⟩, hl⟩,
    use f'.comm,
    split,
    { use a,
      change (a, b) ∈ f'.val.image _,
      rwa [←finset.mem_coe, finset.coe_image, equiv.image_eq_preimage] },
    { change _ ⊆ f'.val.image _,
      rw [←finset.coe_subset, finset.coe_image, ← equiv.subset_image],
      change f.val.image _ ⊆ _ at hl,
      rwa [←finset.coe_subset, finset.coe_image] at hl }
  end }

variable {α}

/-- Given an ideal which intersects `defined_at_left β a`, pick `b : β` such that
    some partial function in the ideal maps `a` to `b`. -/
def fun_of_ideal [densely_ordered β] [no_min_order β] [no_max_order β] [nonempty β]
  (a : α) (I : ideal (partial_iso α β)) :
  (∃ f, f ∈ defined_at_left β a ∧ f ∈ I) → { b // ∃ f ∈ I, (a, b) ∈ subtype.val f } :=
classical.indefinite_description _ ∘ (λ ⟨f, ⟨b, hb⟩, hf⟩, ⟨b, f, hf, hb⟩)

/-- Given an ideal which intersects `defined_at_right α b`, pick `a : α` such that
    some partial function in the ideal maps `a` to `b`. -/
def inv_of_ideal [densely_ordered α] [no_min_order α] [no_max_order α] [nonempty α]
  (b : β) (I : ideal (partial_iso α β)) :
  (∃ f, f ∈ defined_at_right α b ∧ f ∈ I) → { a // ∃ f ∈ I, (a, b) ∈ subtype.val f } :=
classical.indefinite_description _ ∘ (λ ⟨f, ⟨a, ha⟩, hf⟩, ⟨a, f, hf, ha⟩)

end partial_iso
open partial_iso

variables (α β)

/-- Any countable linear order embeds in any nonempty dense linear order without endpoints. -/
def embedding_from_countable_to_dense
  [encodable α] [densely_ordered β] [no_min_order β] [no_max_order β] [nonempty β] :
  α ↪o β :=
let our_ideal : ideal (partial_iso α β) := ideal_of_cofinals default $ defined_at_left β in
let F := λ a, fun_of_ideal a our_ideal (cofinal_meets_ideal_of_cofinals _ _ a) in
order_embedding.of_strict_mono (λ a, (F a).val)
begin
  intros a₁ a₂,
  rcases (F a₁).property with ⟨f, hf, ha₁⟩,
  rcases (F a₂).property with ⟨g, hg, ha₂⟩,
  rcases our_ideal.directed _ hf _ hg with ⟨m, hm, fm, gm⟩,
  exact (lt_iff_lt_of_cmp_eq_cmp $ m.property (a₁, _) (fm ha₁) (a₂, _) (gm ha₂)).mp
end

/-- Any two countable dense, nonempty linear orders without endpoints are order isomorphic. -/
def iso_of_countable_dense
  [encodable α] [densely_ordered α] [no_min_order α] [no_max_order α] [nonempty α]
  [encodable β] [densely_ordered β] [no_min_order β] [no_max_order β] [nonempty β] :
  α ≃o β :=
let to_cofinal : α ⊕ β → cofinal (partial_iso α β) :=
  λ p, sum.rec_on p (defined_at_left β) (defined_at_right α) in
let our_ideal : ideal (partial_iso α β) := ideal_of_cofinals default to_cofinal in
let F := λ a, fun_of_ideal a our_ideal (cofinal_meets_ideal_of_cofinals _ to_cofinal (sum.inl a)) in
let G := λ b, inv_of_ideal b our_ideal (cofinal_meets_ideal_of_cofinals _ to_cofinal (sum.inr b)) in
order_iso.of_cmp_eq_cmp (λ a, (F a).val) (λ b, (G b).val)
begin
  intros a b,
  rcases (F a).property with ⟨f, hf, ha⟩,
  rcases (G b).property with ⟨g, hg, hb⟩,
  rcases our_ideal.directed _ hf _ hg with ⟨m, hm, fm, gm⟩,
  exact m.property (a, _) (fm ha) (_, b) (gm hb)
end

end order


import Lean

inductive Tree
  | leaf : Tree
  | node : Tree → Tree → Tree

abbrev notSubtree (x : Tree) (t : Tree) : Prop :=
  Tree.ibelow (motive := fun z => x ≠ z) t

infix:50 "≮" => notSubtree

theorem Tree.acyclic (x t : Tree) : x = t → x ≮ t := by
  let rec right (x s : Tree) (b : Tree) (h : x ≮ b) : node s x ≠ b ∧ node s x ≮ b := by
    match b, h with
    | leaf,     h =>
      apply And.intro _ trivial
      intro h; injection h
    | node l r, h =>
      have ihl : x ≮ l → node s x ≠ l ∧ node s x ≮ l := right x s l
      have ihr : x ≮ r → node s x ≠ r ∧ node s x ≮ r := right x s r
      have hl : x ≠ l ∧ x ≮ l := h.1
      have hr : x ≠ r ∧ x ≮ r := h.2.1
      have ihl : node s x ≠ l ∧ node s x ≮ l := ihl hl.2
      have ihr : node s x ≠ r ∧ node s x ≮ r := ihr hr.2
      apply And.intro
      focus
        intro h
        injection h with _ h
        exact absurd h hr.1
        done
      focus
        apply And.intro
        apply ihl
        apply And.intro _ trivial
        apply ihr
  let rec left (x t : Tree) (b : Tree) (h : x ≮ b) : node x t ≠ b ∧ node x t ≮ b := by
    match b, h with
    | leaf, h     =>
      apply And.intro _ trivial
      intro h; injection h
    | node l r, h =>
      have ihl : x ≮ l → node x t ≠ l ∧ node x t ≮ l := left x t l
      have ihr : x ≮ r → node x t ≠ r ∧ node x t ≮ r := left x t r
      have hl : x ≠ l ∧ x ≮ l := h.1
      have hr : x ≠ r ∧ x ≮ r := h.2.1
      have ihl : node x t ≠ l ∧ node x t ≮ l := ihl hl.2
      have ihr : node x t ≠ r ∧ node x t ≮ r := ihr hr.2
      apply And.intro
      focus
        intro h
        injection h with h _
        exact absurd h hl.1
        done
      focus
        apply And.intro
        apply ihl
        apply And.intro _ trivial
        apply ihr
  let rec aux : (x : Tree) → x ≮ x
    | leaf     => trivial
    | node l r => by
        have ih₁ : l ≮ l := aux l
        have ih₂ : r ≮ r := aux r
        show (node l r ≠ l ∧ node l r ≮ l) ∧ (node l r ≠ r ∧ node l r ≮ r) ∧ True
        apply And.intro
        focus
          apply left
          assumption
        apply And.intro _ trivial
        focus
          apply right
          assumption
  intro h
  subst h
  apply aux

open Tree

theorem ex1 (x : Tree) : x ≠ node leaf (node x leaf) := by
  intro h
  exact absurd rfl $ Tree.acyclic _ _ h |>.2.1.2.1.1

theorem ex2 (x : Tree) : x ≠ node x leaf := by
  intro h
  exact absurd rfl $ Tree.acyclic _ _ h |>.1.1

theorem ex3 (x y : Tree) : x ≠ node y x := by
  intro h
  exact absurd rfl $ Tree.acyclic _ _ h |>.2.1.1


import ontology
open set topological_space classical
set_option pp.generalized_field_notation true
local attribute [instance] prop_decidable
noncomputable theory

namespace ontology

variable {ω : ontology}

-- We discuss prime entities, topological subbasis, basis, open covers and some definitions involving compact sets.
section prime

  variables (e : ω.entity)

  /-- An entity `e` is said to be **meet prime**,
      or **meet irreducible**, if
      for any entities `e₁, e₂` whose
      nonempty conjunction entails `e`,
      one of them must entail `e`.
      This is equivalent to the principal ideal of `e` in
      the partial order of opens being prime. -/
  def entity.mprime :=
    ∀ ⦃e₁ e₂ : ω.entity⦄ ⦃h : e₁.compatible e₂⦄,
    (h.inter ⇒ e) → (e₁ ⇒ e ∨ e₂ ⇒ e)

  /-- An entity `e` is said to be **join prime**,
      or **join irreducible**, if
      for any entities `e₁, e₂` whose
      disjunction is entailed by `e`,
      `e` must entail one of them.
      This is equivalent to the principal filter of `e`
      in the partial order of opens being prime. -/
  def entity.jprime := ∀ ⦃e₁ e₂ : ω.entity⦄, (e ⇒ e₁ ⊔ e₂) → (e ⇒ e₁ ∨ e ⇒ e₂)

  /-- An entity is **completely join prime** if it is join prime and compact.
      This is also occasionally known as the property of being **supercompact**. -/
  def entity.cjprime := e.jprime ∧ e.compact

  /-- An entity `e` is said to be **prime** if it is both join prime and meet prime. -/
  def entity.prime := e.jprime ∧ e.mprime

  /-- An entity `e` is said to be **completely prime** if it is both prime and compact. -/
  def entity.cprime := e.prime ∧ e.compact

  /-- An entity is said to be **absolutely basic** if it belongs to every topological basis
      of open sets. -/
  def entity.abasic := ∀ {B : set ω.event}, is_topological_basis B → e.exists ∈ B

  /-- An entity is said to be **absolutely sub-basic** if it belongs to every `subbasis` -/
  def entity.asubasic := ∀ {B : set ω.event}, is_subbasis B → e.exists ∈ B

  /-- Definition of **open cover**. -/
  def entity.cover (S : set ω.event) : Prop :=
    (∀ (ev : ω.event), ev ∈ S → ev.entitative) ∧
    e ⇒ ⋃₀ S

  /-- Definition of **Minimal open cover**. -/
  def entity.mcover (S : set ω.event) : Prop :=
    e.cover S ∧ ∀ ev ∈ S, ¬ e.cover (S-{ev})

  /-- Definition of **Exact Minimal open cover**. -/
  def entity.emcover (S : set ω.event) : Prop :=
    e.mcover S ∧ ⋃₀ S ⇒ e

  -- TODO: change the definitions below to use covers.
  -- Also consider getting rid of the uncoverable' definition.
  -- In order to do that, it is necessary to change some proofs that need it,
  -- and they become more annoying due to the necessity of casting
  -- entitative events to entities.

  /-- An entity `e` is said to be **uncoverable** if all of its open covers contain a superset of `e`.
      Notice that if the cover is a subset cover this implies that the cover must contain `e`,
      so any cover of `e` by its subsets must be trivial in this sense. -/
  def entity.uncoverable := ∀ ⦃S : set ω.event⦄, (∀ (ev : ω.event), ev ∈ S → ev.entitative) → S.nonempty → e ⇒ ⋃₀ S → ∃ e₂ ∈ S, e ⇒ e₂
  def entity.uncoverable' := ∀ ⦃S : set ω.entity⦄, S.nonempty → e ⇒ Sup S → ∃ e₂ ∈ S, e ⇒ e₂

  /-- An entity `e` is said to be **minimally uncoverable** if all of its minimal open covers contain a superset of `e`.
      Notice that if the cover is a subset cover this implies that the cover must contain `e`,
      so any minimal cover of `e` by its subsets must be trivial in this sense. -/
  def entity.muncoverable := ∀ ⦃S : set ω.event⦄, e.mcover S → ∃ ev ∈ S, e ⇒ ev

  /-! # The following definitions concern entities which are prime in a substantial sense: -/

  /-- Definition of a **Minimal Substantial Cover** of an entity. -/
  def entity.mscover (S : set ω.event) : Prop :=
    e.mcover S ∧ ∀ (s : ω.event), s ∈ S → s.dense

  /-- An entity `e` is said to be **substantially meet prime**,
      or **substantially meet irreducible**, if
      for any substances `s₁, s₂` whose
      conjunction entails `e`,
      one of them must entail `e`. -/
  def entity.smprime :=
    ∀ ⦃e₁ e₂ : ω.entity⦄, e₁.exists.dense → e₂.exists.dense →
    (e₁.exists ∩ e₂ ⇒ e) → (e₁ ⇒ e ∨ e₂ ⇒ e)

  /-- An entity `e` is said to be **substantially join prime**,
      or **substantially join irreducible**, if
      for any substances `s₁, s₂` whose
      disjunction is entailed by `e`,
      `e` must entail one of them. -/
  def entity.sjprime :=
    ∀ ⦃e₁ e₂ : ω.entity⦄, e₁.exists.dense → e₂.exists.dense →
    (e ⇒ e₁.exists ∪ e₂.exists) → (e ⇒ e₁ ∨ e ⇒ e₂)

  /-- An entity `e` is said to be **substantially prime** if it is both substantially join prime and substantially meet prime. -/
  def entity.sprime := e.sjprime ∧ e.smprime

end prime

-- We prove important properties concerning prime entities and basis and relate them to iontologies.
section prime_lemmas
  variables (e : ω.entity)

  @[simp]
  lemma uncoverable'_iff_uncoverable : e.uncoverable' ↔ e.uncoverable :=
    begin
      simp [ entity.uncoverable
           , entity.uncoverable'
           , Sup
           , has_Sup.Sup
           , entity_Sup
           ],
      constructor; intros,
        let S' := {e : ω.entity | e.exists ∈ S},
        obtain ⟨ev, hev⟩ := a_2,
        have c₀ := a_1 ev hev,
        have c : S'.nonempty := ⟨⟨ev, c₀.1, c₀.2⟩, hev⟩,
        specialize a c, simp [c, S'] at a,
        specialize a _, swap,
          cases e,
          simp [has_entailment.entails],
          convert a_3 using 1,
          simp [ext_iff, S'],
          clear_except a_1,
          intros w, constructor; intro h;
          obtain ⟨i, hi₁, hi₂⟩ := h,
            use i.exists, tauto,
          have c := a_1 i hi₁,
          use ⟨i, c.1, c.2⟩, tauto,
        obtain ⟨i, hi₁, hi₂⟩ := a,
        use i.exists, tauto,
      simp [a_1] at a_2,
      let S' := entity.exists '' S,
      obtain ⟨ev, hev⟩ := a_1,
      have c : S'.nonempty,
        refine ⟨ev.exists, _⟩,
        simp [S', set.image],
        use ev, tauto,
      specialize a _ c, swap,
        simp [S', set.image],
        clear_except,
        intros aux x _ h,
        cases h, simp [event.entitative],
        exact ⟨x.existential, x.possible⟩,
      specialize a _, swap,
          cases e,
          simpa [has_entailment.entails],
      simp [S', set.image] at a, clear_except a,
      obtain ⟨i, ⟨e', he'₁, he'₂⟩, hi₂⟩ := a,
      cases he'₂, exact ⟨e', he'₁, hi₂⟩,
    end

  lemma entity.cprime.to_cjprime {e : ω.entity} : e.cprime → e.cjprime :=
    λ h, ⟨h.1.1, h.2⟩

  lemma entity.cjprime_to_cjprime (e : ω.entity) : (e.cjprime ∧ e.mprime) → e.cprime :=
    λ ⟨h₁, h₂⟩, ⟨⟨h₁.1, h₂⟩, h₁.2⟩

  lemma entity.mprime.induction {e : ω.entity} : e.mprime → ∀ {S : set ω.event}, S.nonempty →
                              (∀ ev : ω.event, ev ∈ S → ev.entitative) → finite S → (⋂₀ S).nonempty → ⋂₀ (S) ⇒ e → ∃ e₂ ∈ S, e₂ ⇒ e :=
    begin
      intros h₀ S ne h₁ h₂,
      revert ne h₁,
      apply h₂.induction_on,
        intro absurd,
        simp [set.nonempty] at absurd,
        contradiction,
      intros e₂ s h₃ h₄ h₅ h₆ h₁ h₇ h,
      simp [has_entailment.entails] at *,
      simp [h₆] at *, clear h₆ h₃,
      by_cases c : s.nonempty, swap,
        replace c := not_nonempty_iff_eq_empty.mp c,
        rw c, rw c at h, simp [set.image] at h,
        use e₂, tauto,
      specialize h₅ c _, swap,
        intros ev hev,
        apply h₁ ev, simp [hev],
      specialize h₅ _, swap,
        obtain ⟨w, _, hw⟩ := h₇,
        exact ⟨w, hw⟩,
      simp [entity.mprime] at h₀,
      set e₃ : ω.event := ⋂₀ s,
      have c₁ : event.existential e₃,
        clear_except h₄ h₁,
        apply is_open_sInter, assumption,
        intros ev hev,
        specialize h₁ ev, simp [hev] at h₁,
        exact h₁.1,
      have := h₇,
      obtain ⟨w, h₇₁, h₇₂⟩ := this,
      have : e₃.nonempty := ⟨w, h₇₂⟩,
      let e₃' : ω.entity := ⟨e₃, c₁, this⟩,
      have := h₁ e₂, simp at this,
      let e₂' : ω.entity := ⟨e₂, this.1, this.2⟩,
      specialize @h₀ e₂' e₃' h₇ _, swap,
        simpa [entity.compatible.inter, has_entailment.entails],
      simp [has_entailment.entails] at h₀,
      cases h₀, use e₂, simp [h₀],
      specialize h₅ h₀, clear_except h₅,
      obtain ⟨e', h₁, h₂⟩ := h₅,
      use e', simp [h₁, h₂],
    end

  lemma entity.jprime.induction {e : ω.entity} : e.jprime → ∀ {S : set ω.entity}, S.nonempty →
                              finite S → e ⇒ Sup S → ∃ e₂ ∈ S, e ⇒ e₂ :=
    begin
      intros h₀ S ne h₁,
      revert ne,
      apply h₁.induction_on,
        intro absurd,
        simp [set.nonempty] at absurd,
        contradiction,
      intros e₂ s h₃ h₄ h₅ h₆ h₇,
      simp [Sup, has_Sup.Sup, h₆] at *,
      simp [has_entailment.entails] at *,
      clear h₆,
      by_cases c : s.nonempty, swap,
        replace c := not_nonempty_iff_eq_empty.mp c,
        simp [entity_Sup] at h₇,
        rw c, rw c at h₇, simp at h₇,
        exact ⟨e₂, by simp, h₇⟩,
      specialize h₅ c,
      simp [c] at h₅,
      simp [entity.jprime, entity_sup] at h₀,
      simp [has_entailment.entails] at h₀,
      have aux : entity_Sup (insert e₂ s) h₆ = e₂ ⊔ entity_Sup s c,
        simp [has_Sup.Sup, has_sup.sup, entity_Sup, entity_sup],
      rw aux at h₇,
      specialize h₀ h₇,
      cases h₀, exact ⟨e₂, by simp, h₀⟩,
      specialize h₅ h₀,
      obtain ⟨x, hx₁, hx₂⟩ := h₅,
      exact ⟨x, by simp [hx₁], hx₂⟩,
    end

  -- WORK IN PROGRESS. ONLY NEEDED TO DISCUSS PARTICULARS AND UNIVERSALS.
  -- lemma jprime_iff_muncoverable : e.jprime ↔ e.muncoverable :=
  --   begin
  --     constructor; intro h,
  --       rintros S ⟨⟨h₁,h₂⟩, h₃⟩,
  --       have ne : S.nonempty, admit,
  --       obtain ⟨ev, hev⟩ := ne,
  --       by_cases c₀ : (S-{ev}).nonempty, swap,
  --         admit,
  --       by_cases c₁ : e ⇒ ev,
  --         exact ⟨ev, hev, c₁⟩,
  --       have c : ⋃₀ S = ev ∪ ⋃₀ (S-{ev}),
  --         admit,
  --       rw c at h₂, clear c,
  --       exfalso,
  --       specialize h₃ ev hev, simp [entity.cover] at h₃,
  --       apply h₃; clear h₃,
  --         intros ev' hev' aux, clear aux,
  --         exact h₁ ev' hev',
  --       have c₁ := h₁ ev hev,
  --       have c₂ : event.entitative (⋃₀ (S-{ev})), admit,
  --       let e₁ : ω.entity := ⟨ev, c₁.1, c₁.2⟩,
  --       let e₂ : ω.entity := ⟨⋃₀ (S-{ev}), c₂.1, c₂.2⟩,
  --       specialize @h e₁ e₂ h₂, cases h;
  --       simp [e₁, e₂, has_entailment.entails] at h, clear e₁ e₂,
  --         contradiction,
  --       exact h,
  --     intros e₁ e₂ h₀,
  --     by_contradiction contra, push_neg at contra,
  --     obtain ⟨h₁, h₂⟩ := contra,
  --     let S : set ω.event := {e₁, e₂},
  --     suffices c : e.mcover S,
  --       specialize h c,
  --       simp [S] at h,
  --       obtain ⟨ev, ⟨rfl⟩|⟨rfl⟩, absurd⟩ := h;
  --       contradiction,
  --     clear h, constructor, constructor;
  --       simp [S], rintros ev (⟨rfl⟩|⟨rfl⟩);
  --       unfold_coes; simp, unfold_coes,
  --       simp [has_sup.sup, entity_sup, has_entailment.entails] at h₀,
  --       convert h₀ using 1, exact sup_comm,
  --     simp [S], rintros ev (⟨rfl⟩|⟨rfl⟩);
  --     intros h; unfold_coes at h; replace h := h.2,
  --     -- by_cases c : e₁ = e₂;
  --     --     try {
  --     --       cases c,
  --     --       simp [has_entailment.entails, has_sup.sup, entity_sup] at h₀,
  --     --       contradiction,
  --     --     },
  --     replace h : e ⇒ e₁,
  --       admit,
  --       -- simp [has_entailment.entails] at h,
  --       -- simp [has_entailment.entails],
  --       -- convert h using 1,
  --       -- simp [ext_iff],
  --     swap, replace h : e ⇒ e₂, admit,
  --     all_goals {contradiction},
  --   end

  lemma cjprime_iff_uncoverable' : e.cjprime ↔ e.uncoverable' :=
    begin
      constructor; intro h,
        obtain ⟨pe, ce⟩ := h,
        intros S neS hS,
        replace ce := ce.elim neS hS,
        obtain ⟨s, sne, h₁, h₂, h₃⟩ := ce,
        replace pe := pe.induction sne h₂ h₃,
        obtain ⟨e₂, h₄, h₅⟩ := pe,
        exact ⟨e₂, h₁ h₄, h₅⟩,
      constructor,
        intros e₁ e₂ h₁,
        let s : set ω.entity := {e₁, e₂},
        have c : s.nonempty, use e₁, simp,
        specialize h c, simp [s, -entity_ext_iff] at h,
        specialize h h₁,
        obtain ⟨e',h|h, h₂⟩ := h; rw h at h₂; simp [h₂],
      apply compact_of_finite_subcover,
      intros type U hU h₁,
      let S : set ω.entity := {e : ω.entity | ∃ i, U i = e.exists},
      have ne : S.nonempty,
        simp [S, set.nonempty],
        by_contradiction contra,
        push_neg at contra,
        have c : ∀ i, U i = ∅,
          by_contradiction contra₂,
          push_neg at contra₂,
          obtain ⟨i, hi⟩ := contra₂,
          replace hi := ne_empty_iff_nonempty.mp hi,
          let e' : ω.entity := ⟨U i, hU i, hi⟩,
          specialize contra e' i,
          simp [e'] at contra,
          contradiction,
        obtain ⟨w, hw⟩ := e.possible,
        specialize h₁ hw, simp at h₁,
        obtain ⟨i, hi⟩ := h₁,
        specialize c i,
        rw c at hi, simp at hi,
        contradiction,
      specialize h ne _, swap,
        simp [Sup, has_Sup.Sup, entity_Sup, ne, has_entailment.entails, S, set.subset],
        intros w hw,
        specialize h₁ hw, simp at h₁,
        obtain ⟨i, hi⟩ := h₁,
        let e' : ω.entity := ⟨U i, hU i, ⟨w, hi⟩⟩,
        refine ⟨e', ⟨i, _⟩, _⟩; simp [e'],
        assumption,
      obtain ⟨e₂, ⟨i, hi⟩, h⟩ := h,
      use ({i} : finset type), simp,
      rwa hi,
    end

  lemma cjprime_iff_uncoverable : e.cjprime ↔ e.uncoverable :=
    by convert cjprime_iff_uncoverable' e; ext; symmetry; exact uncoverable'_iff_uncoverable e

  lemma entity.non_disjoint_cover_of_uncoverable : ¬e.uncoverable → ∃ (S : set ω.event),
                                            (∀ (ev : ω.event), ev ∈ S → ev.entitative) ∧
                                            (∀ (ev : ω.event), ev ∈ S → (ev ∩ e.exists).nonempty) ∧
                                            S.nonempty ∧ e ⇒ ⋃₀ S ∧
                                            ∀ (x_1 : ω.event), x_1 ∈ S → ¬(e ⇒ x_1) :=
  begin
    intro h,
    simp [entity.uncoverable] at h,
    obtain ⟨S, h₁, neS, h₂, h₃⟩ := h,
    let S' := {ev : ω.event | ev ∈ S ∧ (ev ∩ e.exists).nonempty},
    use S', constructor,
      intros ev hev, specialize h₁ ev,
      apply h₁, exact hev.1,
    constructor, simp [S'],
    constructor,
      by_contradiction contra,
      unfold set.nonempty at contra,
      push_neg at contra,
      simp [S'] at contra,
      have : ⋃₀ S ∩ e = ∅,
        rw [sUnion_eq_bUnion, Union_inter],
        simp [ext_iff],
        intros w s hs h,
        specialize contra s hs,
        simp [set.nonempty] at contra,
        specialize contra w h,
        exact contra,
      obtain ⟨w, hw⟩ := e.possible,
      suffices c : e.exists ⊆ ⋃₀ S ∩ e.exists,
        unfold_coes at this, rw this at c,
        apply c hw,
      simp only [has_entailment.entails] at h₂,
      simp, exact ⟨h₂, by refl⟩,
    constructor,
      simp [has_entailment.entails],
      intros w hw,
      specialize h₂ hw, simp at h₂, simp,
      obtain ⟨ev, h₁, h₂⟩ := h₂,
      use ev, refine ⟨⟨h₁,_⟩, h₂⟩,
      exact ⟨w, ⟨h₂, hw⟩⟩,
    intros ev hev, apply h₃,
    exact hev.1,
  end

  /-! # Theorem Description.
      The following is probably one of the hardest,
      if not the hardest, theorem we currently have in
      our project. Hence for readability we provide here
      a sketch of how the proof works:

      **Theorem:** An entity `e` is absolutely sub-basic if and only if it is completely prime.

      **Proof:** To prove the `→` side, assume `e` belongs to every subbasis, then supposing that `e`
      were not completely prime we can prove that `B = {e' : ω.entity | e' ≠ e}`
      is a subbasis for the space, but this is absurd since `e` was assumed to belong to every subbasis.

      To prove that `B` is a subbasis, it suffices to show that there is some family of finite
      intersections of entities distinct from `e` which exactly cover `e`,
      for in this manner every entity would either belong to `B` or be exactly
      covered by finite intersections of entities belonging to `B`, making `B` a subbasis.
      Next we consider that if `e` is not completely prime, this must be either because
      it is not meet prime or not uncoverable, and this is because "completely prime"
      is equivalent to "meet prime and uncoverable" via the equivalence we
      have proven between "completely join prime" and "uncoverable" via the `cjprime_iff_uncoverable'`
      lemma, and the trivial equivalence between "completely prime" and "meet prime and completely join prime";
      we then proceed by cases. In what follows remember that `⊓ = ∩` and `⊔ = ∪` for the domain of entities,
      i.e. when the sets being intersected or united are nonempty and open.

      If `e` is not meet prime, this entails that there are entities `e₁, e₂` such that `e₁ ⊓ e₂`
      is nonempty and `e₁ ⊓ e₂ ⇒ e` but neither `e₁ ⇒ e` nor `e₂ ⇒ e`.
      In particular it also follows that `(e₁ ⊔ e) ≠ e` and `e₂ ⊔ e ≠ e`,
      for otherwise we would have `e₁ ⇒ e` and `e₂ ⇒ e`;
      therefore both `e₁ ⊔ e` and `e₂ ⊔ e` belong to `B`.
      Hence, because the singleton family `{(e₁ ⊔ e) ⊓ (e₂ ⊔ e)}`
      exactly covers `e`, `B` is a subbasis.
      The exact cover follows from `(e₁ ⊔ e) ⊓ (e₂ ⊔ e) = (e₁ ⊓ e₂) ⊔ e = e`,
      where the second equality is proven via `e₁ ⊓ e₂ ⇒ e`.

      If `e` is not uncoverable, this entails there is a nonempty cover `S` of `e`
      such that for all `e' ∈ S` it is not the case that `e ⇒ e'`.
      Without loss of generality (guaranteed by `non_disjoint_cover_of_uncoverable`),
      we can also assume that `e' ⊓ e ≠ ∅` for all `e' ∈ S`.
      Now, notice that it not being the case that`e ⇒ e'` implies `e' ⊓ e ≠ e`,
      for otherwise we would have `e ⇒ e' ⊓ e`, and hence `e ⇒ e'`;
      hence `e' ⊓ e ∈ B` for all `e' ∈ S`. Then notice that `e = (⋃ S) ⊓ e = ⋃ e' ⊓ e`,
      hence there is a union of elements of `B` which exactly cover `e`,
      which proves that `B` is a subbasis. The first equality is obtained
      from the fact `S` is a cover, while the second by distributing `⊓` over `⋃`.
      This concludes the first side of the proof.

      To prove the (`←`) side, assume `e` is completely prime and let `B` be an arbitrary subbasis, then we know
      there is a family `{Sᵢ}` of intersections of elements of `B`, such that `e = ⋃ i, Sᵢ`.
      Since we know via `cjprime_iff_uncoverable'` that `e` is uncoverable,
      it follows that there is some `i` such that `e ⇒ Sᵢ`, but we also know that `S_i ⇒ e`, as `Sᵢ ⇒ ⋃ i, Sᵢ = e`,
      therefore `e = Sᵢ`. Furthermore, since `Sᵢ` is an intersection of a finite number of sets and
      `e` is meet prime, we know via `entity.mprime.induction` that there is a `e'ᵢ ∈ Sᵢ` such that
      `e'ᵢ ⇒ e`, and because `e = Sᵢ` we have also that `e ⇒ e'ᵢ`, as `Sᵢ ⇒ e'ᵢ` follows from the fact
      `Sᵢ` is an intersection. As such we have `e = e'ᵢ`, but recall that `e'ᵢ ∈ B`, therefore `e ∈ B`.
      `∎`
  -/

  theorem asubasic_iff_cprime : e.asubasic ↔ e.cprime :=
    begin
      constructor; intro h,
        by_contradiction contra,
        let B := {e' : ω.event | e' ≠ e ∧ e'.entitative},
        suffices c : is_subbasis B,
          specialize h c,
          simp [B] at h, unfold_coes at h,
          simp at h, contradiction,
        simp [is_subbasis],
        intros e',
        by_cases hyp : e' = e, swap,
          use punit, use punit.star,
          use λ _, {e'}, unfold_coes,
          simp [Union_const], unfold_coes,
          cases e, cases e', simp at hyp,
          simpa,
        cases hyp, clear hyp,
        have := e.cjprime_to_cjprime,
        simp only [contra, cjprime_iff_uncoverable'] at this,
        change ¬ (e.uncoverable' ∧ e.mprime) at this,
        push_neg at this, cases this, swap,
          simp [entity.mprime] at this,
          obtain ⟨e₁, e₂, ⟨h₁, h₂⟩, h₃⟩ := this,
          push_neg at h₃,
          obtain ⟨h₃, h₄⟩ := h₃,
          let x := (e₁ ⊔ e),
          let y := (e₂ ⊔ e),
          simp [has_entailment.entails] at h₃ h₄,
          use punit, use punit.star,
          use λ _, {x, y}, unfold_coes,
          constructor;
          simp [ Union_const, x, y], swap,
            change (e₂.exists ∪ e.exists) ∩ (e₁.exists ∪ e.exists) = e.exists,
            rw ←inter_union_distrib_right,
            simp [has_entailment.entails, entity.compatible.inter] at h₂,
            apply union_eq_self_of_subset_left,
            rwa inter_comm,
          refine ⟨⟨x, _⟩, _⟩,
            unfold_coes, simp [x],
          simp [B, has_subset.subset, set.subset],
          rintro a (ha | ha); rw ha; simp; clear ha a;
          intros h; unfold_coes at h; rw ←h at *,
            change ¬set.subset e₂.exists (e₂.exists ∪ e.exists) at h₄,
            apply h₄, apply subset_union_left,
          change ¬set.subset e₁.exists (e₁.exists ∪ e.exists) at h₃,
          apply h₃, apply subset_union_left,
        simp [uncoverable'_iff_uncoverable] at this,
        replace this := e.non_disjoint_cover_of_uncoverable this,
        obtain ⟨S, h₁, h₂, neS, h₃, h₄⟩ := this,
        have : ∀ e' ∈ S, e' ∩ e.exists ≠ e.exists,
          intros e' he' absurdity,
          apply h₄; try{assumption},
          simp [has_entailment.entails, set.subset],
          rw ←absurdity, simp, tauto,
        obtain ⟨s, hs⟩ := neS,
        use S, use ⟨s, hs⟩,
        use λ s, {s.val ∩ e.exists},
        simp [this], constructor,
          intros e' he', simp,
          refine ⟨this e' he', _⟩,
          refine ⟨_, h₂ e' he'⟩,
          apply topological_space.is_open_inter, swap,
            exact e.existential,
          exact (h₁ e' he').1,
        simp [has_entailment.entails] at h₃,
        rw ←Union_inter, apply eq_of_subset_of_subset,
          apply inter_subset_right,
        set aux := (⋃ (i : S), i.val),
        unfold_coes, simp,
        refine ⟨_, by refl⟩,
        convert h₃, simp [ext_iff],
      intros B h,
      obtain ⟨h₁, h₂⟩ := h,
      specialize h₂ e,
      obtain ⟨I, ne, S, ⟨h₂, h₃⟩⟩ := h₂,
      unfold_coes at h₃,
      have imp_e : ∀ i, ⋂₀ S i ⇒ e,
        intro i,
        have c := subset_Union (λ i, ⋂₀ S i) i,
        simp at c,
        rwa h₃ at c,
      have c := (cjprime_iff_uncoverable' e).mp h.to_cjprime,
      simp at c,
      rw ←sUnion_range at h₃,
      set B' := { s | s ∈ range (λ (x : I), ⋂₀ S x) ∧ s.nonempty},
      have neB' : B'.nonempty,
        simp [B', range, set.nonempty],
        by_contradiction contra,
        push_neg at contra,
        have c : ∀ i, ⋂₀ S i = ∅,
          intro i,
          specialize contra (⋂₀ S i),
          cases contra,
            specialize contra i,
            contradiction,
          apply not_nonempty_iff_eq_empty.mp,
          rintro ⟨w, hw⟩,
          specialize contra w,
          contradiction,
        replace c : (λ (x : I), ⋂₀ S x) = (λ (x : I), ∅),
          funext i, exact c i,
        rw c at h₃,
        simp [range, sUnion, ext_iff] at h₃,
        obtain ⟨w, hw⟩ := e.possible,
        specialize h₃ w, simp [hw] at h₃,
        obtain ⟨empty, ⟨i, absurd⟩, insanity⟩ := h₃,
        specialize absurd w,
        contradiction,
        clear ne,
      have hB' : ∀ (ev : ω.event), ev ∈ B' → ev.entitative,
        intros ev hev,
        simp [B', range] at hev,
        obtain ⟨⟨i, hi⟩, ne⟩ := hev,
        refine ⟨_, ne⟩,
        rw ←hi,
        apply is_open_sInter (h₂ i).1,
        intros t ht,
        replace ht := (h₂ i).2.2 ht,
        replace ht := h₁ t ht,
        exact ht.1,
      replace c := c hB' neB',
      specialize c _, swap,
        simp [has_entailment.entails],
        rw ←h₃,
        simp [sUnion, set.subset],
        intros w S' i hS' hw,
        exact ⟨S',⟨⟨i,hS'⟩,⟨w,hw⟩⟩,hw⟩,
      obtain ⟨e₂, H, he₂⟩ := c,
      simp [B', range] at H,
      obtain ⟨⟨i, hi⟩, aux⟩ := H, clear aux,
      rw ←hi at he₂, clear hi e₂,
      clear h₃ neB' hB' B',
      rename h₁ h₀,
      specialize h₂ i,
      obtain ⟨h₁, h₂, h₃⟩ := h₂,
      have c : (⋂₀ S i).nonempty,
        obtain ⟨w, hw⟩ := e.possible,
        replace hw := he₂ hw,
        exact ⟨w, hw⟩,
      replace h := h.1.2.induction h₂ _ h₁ c (imp_e i), swap,
        intros ev hev,
        apply h₀, apply h₃, assumption,
      clear c,
      obtain ⟨e₂, H, h⟩ := h,
      have c : e ⇒ e₂,
        have c := sInter_subset_of_mem H,
        exact subset.trans he₂ c,
      replace c := eq_of_subset_of_subset c h,
      unfold_coes at c,
      specialize h₃ H,
      rwa c,
    end

  lemma absolutely_real_iff_asubasic : e.absolutely_real ↔ e.asubasic :=
    begin
      constructor; intros h,
        intros B basis,
        specialize h basis.intensionalize,
        simp [entity.real, iontology.ientity.up] at h,
        obtain ⟨ie, hie⟩ := h,
        rw ←hie,
        change (subtype B) at ie,
        exact ie.property,
      intros Ω,
      simp [entity.real],
      specialize h Ω.axiom₁,
      simp [range] at h,
      simpa [entity.real, iontology.ientity.up, iontology.ientity.exists],
    end

  lemma absolutely_real_iff_cprime : e.absolutely_real ↔ e.cprime :=
    by convert (asubasic_iff_cprime e); ext; exact absolutely_real_iff_asubasic e

  -- theorem abasic_iff_cjprime : e.abasic ↔ e.cjprime :=
  --   begin
  --     simp [entity.abasic, entity.cjprime],
  --     constructor; intro h, swap,
  --       intros B hB,
  --   end
end prime_lemmas

-- lemmas involving prime entities and the necessary being
section nb_lemmas

  lemma nbe.mprime : ω.nbe.mprime :=
    by simp [entity.mprime]; intros;
       simp [has_entailment.entails, nbe, set.subset]

  theorem weakly_parmenidean_iff₀ : ω.weakly_parmenidean ↔ ω.nbe.uncoverable :=
    begin
      simp,
      constructor; intro h,
        obtain ⟨w, hw⟩ := h,
        simp [parmenidean] at hw,
        intros S hS₁ hS₂ h, clear hS₂,
        simp [nbe, has_entailment.entails, set.subset] at h,
        specialize @h w,
        obtain ⟨ev, hev, h⟩ := h,
        specialize hS₁ ev hev,
        specialize hw ⟨ev, hS₁.1, hS₁.2⟩ h, simp at hw,
        refine ⟨ev, hev, _⟩, rw hw,
        simp [has_entailment.entails, set.subset],
      let S := {ev : ω.event | ev.contingent ∧ ev.entitative},
      specialize @h S _, swap,
        intros ev hev, exact hev.2,
      simp [nbe, has_entailment.entails, set.subset] at h,
      simp [set.nonempty, parmenidean],
      by_contradiction contra, push_neg at contra,
      by_cases c : S.nonempty, swap,
        simp [set.nonempty] at c,
        obtain ⟨w⟩ := ω.wne,
        specialize contra w,
        obtain ⟨e, hw, he⟩ := contra,
        simp [nbe] at he,
        specialize c e.exists w hw he,
        have absurdity := e.entitative,
        contradiction,
      specialize h c, clear c,
      specialize h _, swap,
        intro w, specialize contra w,
        obtain ⟨e, hw, he⟩ := contra,
        simp [nbe] at he,
        exact ⟨e.exists, ⟨⟨⟨e.possible,he⟩,e.entitative⟩,hw⟩⟩,
      clear contra,
      obtain ⟨insanity, ⟨⟨sophistry, illusion⟩, gibberish⟩, nonsense⟩ := h,
      have absurdity : insanity = univ,
        simpa [ext_iff],
      contradiction,
    end
  theorem weakly_parmenidean_iff₁ : ω.weakly_parmenidean ↔ ω.nbe.cprime :=
    begin
      convert weakly_parmenidean_iff₀,
      ext, constructor; intro h,
        replace h := h.to_cjprime,
        replace h := (cjprime_iff_uncoverable' ω.nbe).mp h,
        simp at h, assumption,
      replace h := (cjprime_iff_uncoverable ω.nbe).2 h,
      exact ⟨⟨h.1, nbe.mprime⟩, h.2⟩,
    end
  theorem weakly_parmenidean_iff₂ : ω.weakly_parmenidean ↔ ω.nbe.asubasic :=
    by convert weakly_parmenidean_iff₁; ext; exact asubasic_iff_cprime ω.nbe
  theorem weakly_parmenidean_iff₃ : ω.weakly_parmenidean ↔ ω.nbe.absolutely_real :=
    by convert weakly_parmenidean_iff₂; ext; exact absolutely_real_iff_asubasic ω.nbe

end nb_lemmas

-- We discuss particulars, universals, optional entities, and some unique notions of covering related to them;
-- in terms of which the notions of exemplification and subjective parthood can be defined.
-- THIS SECTION IS VERY MUCH A WORK IN PROGRESS.
section particulars

  variable (e : ω.entity)

  /-- An entity is **particular** if it is substantially join prime. -/
  @[reducible, simp]
  def entity.particular := e.sjprime
  /-- An entity is a **(Neo-Aristotelian) universal** if it is not particular. -/
  @[reducible, simp]
  def entity.universal := ¬ e.sjprime
  /-- An entity is said to be a **proper particular** if it is substantially prime. -/
  @[reducible, simp]
  def entity.pparticular := e.sprime
  /-- An entity is said to be an **aggregate**, or an **improper particular**,
      if it is particular but not a proper particular. -/
  @[reducible, simp]
  def entity.aggregate := e.sjprime ∧ ¬ e.smprime
  /-- An entity is said to be an **ultra-particular** if it is prime. -/
  @[reducible, simp]
  def entity.uparticular := e.prime
  /-- An entity is said to be **monadic**, or **point-like**, if it is
      completely prime. -/
  @[reducible, simp]
  def entity.monadic := e.cprime
  /-- An entity is said to be **angelic (or Divine)** if it is
      both monadic and dense. -/
  @[reducible, simp]
  def entity.angelic := e.monadic ∧ e.exists.dense

   /-- An entity `e` is said to be **(strictly) directly covered** by an entity `e'`
      if `e ⇒' e'` and for every entity `e''` in between `e` and `e'`,
       `e''` is either equal to `e` or to `e'`. -/
  def entity.dcovered (e' : ω.entity) :=
    e ⇒' e' ∧ ∀ e'' : ω.entity,
    e ⇒ e'' → e'' ⇒ e' → e'' = e ∨ e'' = e'

  infixr ` :⇒ `:50 := entity.dcovered

  /-- An entity `e` is said to be **optionally covered** by an entity `e'`
      if it is uniquely pre-covered by `e'`, i.e. if it is pre-coverd by `e'` but
      not pre-covered by anything else. -/
  def entity.ocovered (e' : ω.entity) :=
    e :⇒ e' ∧ ∀ e'', e :⇒ e'' → e'' = e'

  infixr ` !:⇒ `:50 := entity.ocovered

  /-- An entity is said to be **optional** if it is optionally covered by another. -/
  def entity.optional := ∃ e', e !:⇒ e'

  /-- Definition of **Particular Exact Minimal open cover**. -/
  def entity.pemcover (S : set ω.event) : Prop :=
    e.emcover S ∧ ∀ (s : ω.event), s ∈ S →
    ∃ e' : ω.entity, e.particular ∧ e'.exists = s

  /-- Definition of **Infinite Particular Exact Minimal open cover**. -/
  def entity.ipemcover (S : set ω.event) : Prop :=
    e.pemcover S ∧ S.infinite

  /-- A particular entity `e` is said to **exemplify** another
      universal entity `u`, just in case there is an unique ipemcover of
      `u` containing `e` which has only perfect elements if `e` is perfect,
      and only imperfect elements if `e` is imperfect. -/
  def entity.exemplifies (u : ω.entity) : Prop :=
    e.particular ∧ u.universal ∧
    ∃! S, u.ipemcover S ∧ e.exists ∈ S ∧
    (e.exists.dense → ∀ s : ω.event, s ∈ S → s.dense) ∧
    (¬ e.exists.dense → ∀ s : ω.event, s ∈ S → ¬ s.dense)

  /-- A particular entity `e` is said to be a **subjective part** of another
      universal entity `u`, just in case there is an unique pemcover of
      `u` containing `e` which has only perfect elements if `e` is perfect,
      and only imperfect elements if `e` is imperfect.
      "Subjective" comes from the fact that `e` is the subject of
      a predication. -/
  def entity.spart (u : ω.entity) : Prop :=
    e.particular ∧ u.universal ∧
    ∃! S, u.pemcover S ∧ e.exists ∈ S ∧
    (e.exists.dense → ∀ s : ω.event, s ∈ S → s.dense) ∧
    (¬ e.exists.dense → ∀ s : ω.event, s ∈ S → ¬ s.dense)

  /-- An entity is said to be a **true universal** if it can be exemplified. -/
  def entity.tuniversal := ∃ e' : ω.entity, e'.exemplifies e

  /-- An universal is said to be a **subjective whole (collection, or set)**
      if it has subjective parts. -/
  def entity.swhole := ∃ e' : ω.entity, e'.spart e

end particulars

-- lemmas about direct coverings and optional entities
-- THIS SECTION IS VERY MUCH A WORK IN PROGRESS.
section dcovered_lemmas

  variables (e₁ e₂ : ω.entity) (h₁ : e₁.exists.dense) (h₂ : e₂.exists.dense)
  include h₁ h₂

  -- lemma ocovered_of_dcovered_smprime : e₁.smprime → e₁ :⇒ e₂ → e₁ !:⇒ e₂ :=
  --   begin
  --     intros h₃ h₄,
  --     refine ⟨h₄, _⟩,
  --     intros e₃ h₅,
  --     admit,
  --   end

end dcovered_lemmas

end ontology


-- -----------------------------
-- Demostrar que
--    s \ (t ∪ u) ⊆ (s \ t) \ u
-- -----------------------------

import data.set.basic
open set

variable {α : Type}
variables s t u : set α

example : s \ (t ∪ u) ⊆ (s \ t) \ u :=
sorry


import data.real.basic
import tactic.norm_num

theorem M1F_sheet01_Q01a_is_F : ¬ (∀ x : ℝ, x ^ 2 - 3 * x + 2 = 0 → x = 1) :=
begin
  intro H1,
  -- now I'm done, right?
  have H2 := H1 2,
  apply (show (2 : ℝ) ≠ 1, by norm_num),
  apply H2,
  norm_num,
end


import mynat.definition

namespace mynat

theorem succ_inj' (a b : mynat) (hs : succ(a) = succ(b)) : a = b :=
begin
    apply succ_inj,
    exact hs,
end

end mynat