/-
Copyright (c) 2022 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro
-/
import Mathlib.Data.List.Basic

/-!
# `lrat_proof` command

Defines a macro for producing SAT proofs from CNF / LRAT files.
These files are commonly used in the SAT community for writing proofs.

Most SAT solvers support export to [DRAT](https://arxiv.org/abs/1610.06229) format,
but this format can be expensive to reconstruct because it requires recomputing all
unit propagation steps. The [LRAT](https://arxiv.org/abs/1612.02353) format solves this
issue by attaching a proof to the deduction of each new clause.
(The L in LRAT stands for Linear time verification.)
There are several verified checkers for the LRAT format, and the program implemented here
makes it possible to use the lean kernel as an LRAT checker as well and expose the results
as a standard propositional theorem.

The input to the `lrat_proof` command is the name of the theorem to define,
and the statement (written in CNF format) and the proof (in LRAT format).
For example:
```
lrat_proof foo
  "p cnf 2 4  1 2 0  -1 2 0  1 -2 0  -1 -2 0"
  "5 -2 0 4 3 0  5 d 3 4 0  6 1 0 5 1 0  6 d 1 0  7 0 5 2 6 0"
```
produces a theorem:
```
foo : ∀ (a a_1 : Prop), (¬a ∧ ¬a_1 ∨ a ∧ ¬a_1) ∨ ¬a ∧ a_1 ∨ a ∧ a_1
```

* You can see the theorem statement by hovering over the word `foo`.
* You can use the `example` keyword in place of `foo` to avoid generating a theorem.
* You can use the `include_str` macro in place of the two strings
  to load CNF / LRAT files from disk.
-/

open Lean hiding Literal HashMap
open Std

namespace Sat

/-- A literal is a positive or negative occurrence of an atomic propositional variable.
  Note that unlike DIMACS, 0 is a valid variable index. -/
inductive Literal
| pos : Nat → Literal
| neg : Nat → Literal

/-- Construct a literal. Positive numbers are translated to positive literals,
  and negative numbers become negative literals. The input is assumed to be nonzero. -/
def Literal.ofInt (i : Int) : Literal :=
  if i < 0 then Literal.neg (-i-1).toNat else Literal.pos (i-1).toNat

/-- Swap the polarity of a literal. -/
def Literal.negate : Literal → Literal
| pos i => neg i
| neg i => pos i

instance : ToExpr Literal where
  toTypeExpr := mkConst ``Literal
  toExpr
  | Literal.pos i => mkApp (mkConst ``Literal.pos) (mkRawNatLit i)
  | Literal.neg i => mkApp (mkConst ``Literal.neg) (mkRawNatLit i)

/-- A clause is a list of literals, thought of as a disjunction like `a ∨ b ∨ ¬c`. -/
def Clause := List Literal

def Clause.nil : Clause := []
def Clause.cons : Literal → Clause → Clause := List.cons

/-- A formula is a list of clauses, thought of as a conjunction like `(a ∨ b) ∧ c ∧ (¬c ∨ ¬d)`. -/
abbrev Fmla := List Clause

/-- A single clause as a formula. -/
def Fmla.one (c : Clause) : Fmla := [c]

/-- A conjunction of formulas. -/
def Fmla.and (a b : Fmla) : Fmla := a ++ b

/-- Formula `f` subsumes `f'` if all the clauses in `f'` are in `f`.
We use this to prove that all clauses in the formula are subsumed by it. -/
structure Fmla.subsumes (f f' : Fmla) : Prop where
  prop : ∀ x, x ∈ f' → x ∈ f

theorem Fmla.subsumes_self (f : Fmla) : f.subsumes f := ⟨fun _ h ↦ h⟩
theorem Fmla.subsumes_left (f f₁ f₂ : Fmla) (H : f.subsumes (f₁.and f₂)) : f.subsumes f₁ :=
  ⟨fun _ h ↦ H.1 _ $ List.mem_append.2 $ Or.inl h⟩
theorem Fmla.subsumes_right (f f₁ f₂ : Fmla) (H : f.subsumes (f₁.and f₂)) : f.subsumes f₂ :=
  ⟨fun _ h ↦ H.1 _ $ List.mem_append.2 $ Or.inr h⟩

/-- A valuation is an assignment of values to all the propositional variables. -/
def Valuation := Nat → Prop

/-- `v.neg lit` asserts that literal `lit` is falsified in the valuation. -/
def Valuation.neg (v : Valuation) : Literal → Prop
| Literal.pos i => ¬ v i
| Literal.neg i => v i

/-- `v.satisfies c` asserts that clause `c` satisfied by the valuation.
It is written in a negative way: A clause like `a ∨ ¬b ∨ c` is rewritten as
`¬a → b → ¬c → False`, so we are asserting that it is not the case that
all literals in the clause are falsified. -/
def Valuation.satisfies (v : Valuation) : Clause → Prop
| [] => False
| l::c => v.neg l → v.satisfies c

/-- `v.satisfies_fmla f` asserts that formula `f` is satisfied by the valuation.
A formula is satisfied if all clauses in it are satisfied. -/
structure Valuation.satisfies_fmla (v : Valuation) (f : Fmla) : Prop where
  prop : ∀ c, c ∈ f → v.satisfies c

/-- `f.proof c` asserts that `c` is derivable from `f`. -/
def Fmla.proof (f : Fmla) (c : Clause) : Prop :=
  ∀ v : Valuation, v.satisfies_fmla f → v.satisfies c

/-- If `f` subsumes `c` (i.e. `c ∈ f`), then `f.proof c`. -/
theorem Fmla.proof_of_subsumes (H : Fmla.subsumes f (Fmla.one c)) : f.proof c :=
  fun _ h ↦ h.1 _ $ H.1 _ $ List.Mem.head ..

/-- The core unit-propagation step.

We have a local context of assumptions `¬l'` (sometimes called an assignment)
and we wish to add `¬l` to the context, that is, we want to prove `l` is also falsified.
This is because there is a clause `a ∨ b ∨ ¬l` in the global context
such that all literals in the clause are falsified except for `¬l`;
so in the context `h₁` where we suppose that `¬l` is falsified,
the clause itself is falsified so we can prove `False`.
We continue the proof in `h₂`, with the assumption that `l` is falsified. -/
theorem Valuation.by_cases {v : Valuation} {l}
  (h₁ : v.neg l.negate → False) (h₂ : v.neg l → False) : False :=
match l with
| Literal.pos _ => h₂ h₁
| Literal.neg _ => h₁ h₂

/-- `v.implies p [a, b, c] 0` definitionally unfolds to `(v 0 ↔ a) → (v 1 ↔ b) → (v 2 ↔ c) → p`.
This is used to introduce assumptions about the first `n` values of `v` during reification. -/
def Valuation.implies (v : Valuation) (p : Prop) : List Prop → Nat → Prop
| [], _ => p
| a::as, n => (v n ↔ a) → v.implies p as (n+1)

/-- `Valuation.mk [a, b, c]` is a valuation which is `a` at 0, `b` at 1 and `c` at 2, and false
everywhere else. -/
def Valuation.mk : List Prop → Valuation
| [], _ => False
| a::_, 0 => a
| _::as, n+1 => mk as n

/-- The fundamental relationship between `mk` and `implies`:
`(mk ps).implies p ps 0` is equivalent to `p`. -/
theorem Valuation.mk_implies (as₁) : as = List.reverseAux as₁ ps →
  (Valuation.mk as).implies p ps as₁.length → p := by
  induction ps generalizing as₁ with
  | nil => exact fun _ ↦ id
  | cons a as ih =>
    refine fun e H ↦ @ih (a::as₁) e (H ?_)
    subst e; clear ih H
    suffices ∀ n n', n' = List.length as₁ + n →
      ∀ bs, mk (as₁.reverseAux bs) n' ↔ mk bs n from this 0 _ rfl (a::as)
    induction as₁ with simp
    | cons b as₁ ih => exact fun n bs ↦ ih (n+1) _ (Nat.succ_add ..) _

/-- Asserts that `¬⟦f⟧_v` implies `p`. -/
structure Fmla.reify (v : Valuation) (f : Fmla) (p : Prop) : Prop where
  prop : ¬ v.satisfies_fmla f → p

/-- If `f` is unsatisfiable, and every `v` which agrees with `ps` implies `¬⟦f⟧_v → p`, then `p`.
Equivalently, there exists a valuation `v` which agrees with `ps`,
and every such valuation yields `¬⟦f⟧_v` because `f` is unsatisfiable. -/
theorem Fmla.refute (f : Fmla) (hf : f.proof [])
  (hv : ∀ v, Valuation.implies v (Fmla.reify v f p) ps 0) : p :=
  (Valuation.mk_implies [] rfl (hv _)).1 (hf _)

/-- Negation turns AND into OR, so `¬⟦f₁ ∧ f₂⟧_v ≡ ¬⟦f₁⟧_v ∨ ¬⟦f₂⟧_v`. -/
theorem Fmla.reify_or (h₁ : Fmla.reify v f₁ a) (h₂ : Fmla.reify v f₂ b) :
  Fmla.reify v (f₁.and f₂) (a ∨ b) := by
  refine ⟨fun H ↦ by_contra fun hn ↦ H ⟨fun c h ↦ by_contra fun hn' ↦ ?_⟩⟩
  rcases List.mem_append.1 h with h | h
  · exact hn $ Or.inl $ h₁.1 fun Hc ↦ hn' $ Hc.1 _ h
  · exact hn $ Or.inr $ h₂.1 fun Hc ↦ hn' $ Hc.1 _ h

/-- Asserts that `¬⟦c⟧_v` implies `p`. -/
structure Clause.reify (v : Valuation) (c : Clause) (p : Prop) : Prop where
  prop : ¬ v.satisfies c → p

/-- Reification of a single clause formula. -/
theorem Fmla.reify_one (h : Clause.reify v c a) : Fmla.reify v (Fmla.one c) a :=
  ⟨fun H ↦ h.1 fun h ↦ H ⟨fun | _, List.Mem.head .. => h⟩⟩

/-- Asserts that `¬⟦l⟧_v` implies `p`. -/
structure Literal.reify (v : Valuation) (l : Literal) (p : Prop) : Prop where
  prop : v.neg l → p

/-- Negation turns OR into AND, so `¬⟦l ∨ c⟧_v ≡ ¬⟦l⟧_v ∧ ¬⟦c⟧_v`. -/
theorem Clause.reify_and (h₁ : Literal.reify v l a) (h₂ : Clause.reify v c b) :
  Clause.reify v (Clause.cons l c) (a ∧ b) :=
  ⟨fun H ↦ ⟨h₁.1 (by_contra fun hn ↦ H hn.elim), h₂.1 fun h ↦ H fun _ ↦ h⟩⟩

/-- The reification of the empty clause is `True`: `¬⟦⊥⟧_v ≡ True`. -/
theorem Clause.reify_zero : Clause.reify v Clause.nil True := ⟨fun _ ↦ trivial⟩

/-- The reification of a singleton clause `¬⟦l⟧_v ≡ ¬⟦l⟧_v`. -/
theorem Clause.reify_one (h₁ : Literal.reify v l a) : Clause.reify v (Clause.nil.cons l) a :=
  ⟨fun H ↦ ((Clause.reify_and h₁ Clause.reify_zero).1 H).1⟩

/-- The reification of a positive literal `¬⟦a⟧_v ≡ ¬a`. -/
theorem Literal.reify_pos (h : v n ↔ a) : (Literal.pos n).reify v ¬a := ⟨mt h.2⟩

/-- The reification of a negative literal `¬⟦¬a⟧_v ≡ a`. -/
theorem Literal.reify_neg (h : v n ↔ a) : (Literal.neg n).reify v a := ⟨h.1⟩

end Sat

namespace Mathlib.Tactic.Sat

/-- The representation of a global clause. -/
structure Clause where
  /-- The list of literals as read from the input file -/
  lits : Array Int
  /-- The clause expression of type `Clause` -/
  expr : Expr
  /-- A proof of `⊢ ctx.proof c`.
  Note that we do not use `have` statements to cache these proofs:
  this is literally the proof expression itself. As a result, the proof terms
  rely heavily on dag-like sharing of the expression, and printing these proof terms
  directly is likely to crash lean for larger examples. -/
  proof : Expr

/-- Construct the clause expression from the input list. For example `[1, -2]` is translated to
`Clause.cons (Literal.pos 1) (Clause.cons (Literal.neg 2) Clause.nil)`. -/
def buildClause (arr : Array Int) : Expr :=
  let nil  := mkConst ``Sat.Clause.nil
  let cons := mkConst ``Sat.Clause.cons
  arr.foldr (fun i e ↦ mkApp2 cons (toExpr $ Sat.Literal.ofInt i) e) nil

/-- Constructs the formula expression from the input CNF, as a balanced tree of `Fmla.and` nodes. -/
partial def buildConj (arr : Array (Array Int)) (start stop : Nat) : Expr :=
  match stop - start with
  | 0 => panic! "empty"
  | 1 => mkApp (mkConst ``Sat.Fmla.one) (buildClause arr[start]!)
  | len =>
    let mid := start + len / 2
    mkApp2 (mkConst ``Sat.Fmla.and) (buildConj arr start mid) (buildConj arr mid stop)

/-- Constructs the proofs of `⊢ ctx.proof c` for each clause `c` in `ctx`.
The proofs are stashed in a `HashMap` keyed on the clause ID. -/
partial def buildClauses (arr : Array (Array Int)) (ctx : Expr) (start stop : Nat)
  (f p : Expr) (accum : Nat × HashMap Nat Clause) : Nat × HashMap Nat Clause :=
  match stop - start with
  | 0 => panic! "empty"
  | 1 =>
    let c := f.appArg!
    let proof := mkApp3 (mkConst ``Sat.Fmla.proof_of_subsumes) ctx c p
    let n := accum.1 + 1
    (n, accum.2.insert n { lits := arr[start]!, expr := c, proof })
  | len =>
    let mid := start + len / 2
    let f₁ := f.appFn!.appArg!
    let f₂ := f.appArg!
    let p₁ := mkApp4 (mkConst ``Sat.Fmla.subsumes_left) ctx f₁ f₂ p
    let p₂ := mkApp4 (mkConst ``Sat.Fmla.subsumes_right) ctx f₁ f₂ p
    let accum := buildClauses arr ctx start mid f₁ p₁ accum
    buildClauses arr ctx mid stop f₂ p₂ accum

/-- A localized clause reference.
It is the same as `Clause` except that the proof is now a local variable. -/
structure LClause where
  /-- The list of literals as read from the input file -/
  lits : Array Int
  /-- The clause expression of type `Clause` -/
  expr : Expr
  /-- The bound variable index of the hypothesis asserting `⊢ ctx.proof c`,
  _counting from the outside and 1-based_. (We use this numbering because we will need to
  reference the variable from multiple binder depths.) -/
  depth : Nat

/-- Construct an individual proof step `⊢ ctx.proof c`.

  * `db`: the current global context
  * `ns`, `clause`: the new clause
  * `pf`: the LRAT proof trace
  * `ctx`: the main formula

  The proof has three steps:

  1. Introduce local assumptions `have h1 : ctx.proof c1 := p1` for each clause `c1`
     referenced in the proof. We actually do all the introductions at once,
     as in `(fun h1 h2 h3 ↦ ...) p1 p2 p3`, because we want `p_i` to not be under any binders
     to avoid the cost of `instantiate` during typechecking and get the benefits of dag-like
     sharing in the `pi` (which are themselves previous proof steps which may be large terms).
     The hypotheses are in `gctx`, keyed on the clause ID.

  2. Unfold `⊢ ctx.proof [a, b, c]` to
     `∀ v, v.satisfies_fmla ctx → v.neg a → v.neg b → v.neg c → False` and `intro v hv ha hb hc`,
     storing each `ha : v.neg a` in `lctx`, keyed on the literal `a`.

  3. For each LRAT step `hc : ctx.proof [x, y]`, `hc v hv : v.neg x → v.neg y → False`.
     We look for a literal that is not falsified in the clause. Since it is a unit propagation
     step, there can be at most one such literal.
     * If `x` is the non-falsified clause, let `x'` denote the negated literal of `x`.
       Then `x'.negate` reduces to `x`, so `hnx : v.neg x'.negate |- hc v hv hnx hy : False`,
       so we construct the term
         `by_cases (fun hnx : v.neg x'.negate ↦ hc v hv hnx hy) (fun hx : v.neg x ↦ ...)`
       and `hx` is added to the local context.
     * If all clauses are falsified, then we are done: `hc v hv hx hy : False`.
-/
partial def buildProofStep (db : HashMap Nat Clause)
  (ns pf : Array Int) (ctx clause : Expr) : Except String Expr := Id.run do
  let mut lams := #[]
  let mut args := #[]
  let mut gctx : HashMap Nat LClause := {}
  -- step 1
  for i in pf do
    let i := i.natAbs
    let some cl := db.find? i | return Except.error "missing clause"
    if !gctx.contains i then
      lams := lams.push (mkApp2 (mkConst ``Sat.Fmla.proof) ctx cl.expr)
      args := args.push cl.proof
      gctx := gctx.insert i {
        lits := cl.lits
        expr := cl.expr
        depth := args.size
      }
  let n := args.size
  -- step 2
  let mut f :=
    (mkAppN · args) ∘
    lams.foldr (mkLambda `c default) ∘
    mkLambda `v default (mkConst ``Sat.Valuation) ∘
    mkLambda `hv default (mkApp2 (mkConst ``Sat.Valuation.satisfies_fmla) (mkBVar 0) ctx)
  let v depth := mkBVar (depth + 1)
  let hv depth := mkBVar depth
  lams := #[]
  let mut clause := clause
  let mut depth := 0
  let mut lctx : HashMap Int Nat := {}
  for i in ns do
    let l := clause.appFn!.appArg!
    clause := clause.appArg!
    lams := lams.push (mkApp2 (mkConst ``Sat.Valuation.neg) (v depth) l)
    depth := depth.succ
    lctx := lctx.insert i depth
  f := f ∘ lams.foldr (mkLambda `h default)
  -- step 3
  for (step : Int) in pf do
    if step < 0 then return Except.error "unimplemented: RAT step"
    let some cl := gctx.find? step.toNat | return Except.error "missing clause"
    let mut unit := none
    for i in cl.lits do
      unless lctx.contains i do
        if unit.isSome then return Except.error s!"not unit: {cl.lits}"
        depth := depth.succ
        unit := some i
    let mut pr := mkApp2 (mkBVar (depth + n + 2 - cl.depth)) (v depth) (hv depth)
    for i in cl.lits do
      pr := mkApp pr <| mkBVar (match lctx.find? i with | some k => depth - k | _ => 0)
    let some u := unit | return Except.ok <| f pr
    let lit := toExpr $ Sat.Literal.ofInt u
    let nlit := toExpr $ Sat.Literal.ofInt (-u)
    let d1 := depth-1
    let app := mkApp3 (mkConst ``Sat.Valuation.by_cases) (v d1) nlit <|
      mkLambda `h default (mkApp2 (mkConst ``Sat.Valuation.neg) (v d1) lit) pr
    let dom := mkApp2 (mkConst ``Sat.Valuation.neg) (v d1) nlit
    f := fun e ↦ f <| mkApp app <| mkLambda `h default dom e
    lctx := lctx.insert (-u) depth
  return Except.error s!"no refutation: {ns}, {pf}, {lctx.toList}"

/-- An LRAT step is either an addition or a deletion step. -/
inductive LRATStep
| /-- An addition step, with the clause ID, the clause literal list, and the proof trace -/
  add (id : Nat) (lits : Array Int) (proof : Array Int) : LRATStep
| /-- A (multiple) deletion step, which deletes all the listed clause IDs from the context -/
  del (ids : Array Nat) : LRATStep

/-- Build the main proof of `⊢ ctx.proof []` using the LRAT proof trace.

  * `arr`: The input CNF
  * `ctx`: The abbreviated formula, a constant like `foo.ctx_1`
  * `ctx'`: The definitional expansion of the formula, a tree of `Fmla.and` nodes
  * `steps`: The input LRAT proof trace
-/
partial def buildProof (arr : Array (Array Int)) (ctx ctx' : Expr)
  (steps : Array LRATStep) : MetaM Expr := do
  let p := mkApp (mkConst ``Sat.Fmla.subsumes_self) ctx
  let mut db := (buildClauses arr ctx 0 arr.size ctx' p default).2
  for step in steps do
    match step with
    | LRATStep.del ds => db := ds.foldl (·.erase ·) db
    | LRATStep.add i ns pf =>
      let e := buildClause ns
      match buildProofStep db ns pf ctx e with
      | Except.ok proof =>
        if ns.isEmpty then return proof
        db := db.insert i { lits := ns, expr := e, proof }
      | Except.error msg => throwError msg
  throwError "failed to prove empty clause"

/-- Build the type and value of the reified theorem. This rewrites all the SAT definitions
into standard operators on `Prop`, for example if the formula is `[[1, 2], [-1, 2], [-2]]` then
this produces a proof of `⊢ ∀ a b : Prop, (a ∧ b) ∨ (¬a ∧ b) ∨ ¬b`. We use the input `nvars` to
decide how many quantifiers to use.

Most of the proof is under `2 * nvars + 1` quantifiers
`a1 .. an : Prop, v : Valuation, h1 : v 0 ↔ a1, ... hn : v (n-1) ↔ an ⊢ ...`, and we do the index
arithmetic by hand.

  1. First, we call `reifyFormula ctx'` which returns `a` and `pr : reify v ctx' a`
  2. Then we build `fun (v : Valuation) (h1 : v 0 ↔ a1) ... (hn : v (n-1) ↔ an) ↦ pr`
  3. We have to lower expression `a` from step 1 out of the quantifiers by lowering all variable
     indices by `nvars+1`. This is okay because `v` and `h1..hn` do not appear in `a`.
  4. We construct the expression `ps`, which is `a1 .. an : Prop ⊢ [a1, ..., an] : List Prop`
  5. `refute ctx (hf : ctx.proof []) (fun v h1 .. hn ↦ pr) : a` forces some definitional unfolding
     since `fun h1 .. hn ↦ pr` should have type `implies v (reify v ctx a) [a1, ..., an] a`,
     which involves unfolding `implies` n times as well as `ctx ↦ ctx'`.
  6. Finally, we `intro a1 ... an` so that we have a proof of `∀ a1 ... an, a`.
-/
partial def buildReify (ctx ctx' proof : Expr) (nvars : Nat) : Expr × Expr := Id.run do
  let (e, pr) := reifyFmla ctx'
  let mut pr := pr
  for i in [0:nvars] do
    let j := nvars-i-1
    let ty := mkApp2 (mkConst ``Iff) (mkApp (mkBVar j) (mkRawNatLit j)) (mkBVar nvars)
    pr := mkLambda `h default ty pr
  pr := mkLambda `v default (mkConst ``Sat.Valuation) pr
  let mut e := e.lowerLooseBVars (nvars+1) (nvars+1)
  let cons := mkApp (mkConst ``List.cons [levelZero]) (mkSort levelZero)
  let nil := mkApp (mkConst ``List.nil [levelZero]) (mkSort levelZero)
  let rec mkPS depth e
  | 0 => e
  | n+1 => mkPS (depth+1) (mkApp2 cons (mkBVar depth) e) n
  pr := mkApp5 (mkConst ``Sat.Fmla.refute) e (mkPS 0 nil nvars) ctx proof pr
  for _ in [0:nvars] do
    e := mkForall `a default (mkSort levelZero) e
    pr := mkLambda `a default (mkSort levelZero) pr
  pure (e, pr)
where
  /-- The `v` variable under the `a1 ... an, v, h1 ... hn` context -/
  v := mkBVar nvars
  /-- Returns `a` and `pr : reify v f a` given a formula `f` -/
  reifyFmla f :=
    match f.getAppFn.constName! with
    | ``Sat.Fmla.and =>
      let f₁ := f.appFn!.appArg!
      let f₂ := f.appArg!
      let (e₁, h₁) := reifyFmla f₁
      let (e₂, h₂) := reifyFmla f₂
      (mkApp2 (mkConst ``Or) e₁ e₂, mkApp7 (mkConst ``Sat.Fmla.reify_or) v f₁ e₁ f₂ e₂ h₁ h₂)
    | ``Sat.Fmla.one =>
      let c := f.appArg!
      let (e, h) := reifyClause c
      (e, mkApp4 (mkConst ``Sat.Fmla.reify_one) v c e h)
    | _ => panic! "not a valid formula"
  /-- Returns `a` and `pr : reify v c a` given a clause `c` -/
  reifyClause c :=
    if c.appFn!.isConst then
      (mkConst ``True, mkApp (mkConst ``Sat.Clause.reify_zero) v)
    else reifyClause1 c
  /-- Returns `a` and `pr : reify v c a` given a nonempty clause `c` -/
  reifyClause1 c :=
    let l := c.appFn!.appArg!
    let c := c.appArg!
    let (e₁, h₁) := reifyLiteral l
    if c.isConst then
      (e₁, mkApp4 (mkConst ``Sat.Clause.reify_one) v l e₁ h₁)
    else
      let (e₂, h₂) := reifyClause1 c
      (mkApp2 (mkConst ``And) e₁ e₂, mkApp7 (mkConst ``Sat.Clause.reify_and) v l e₁ c e₂ h₁ h₂)
  /-- Returns `a` and `pr : reify v l a` given a literal `c` -/
  reifyLiteral l :=
    let n := l.appArg!
    let (e, h) := reifyVar n
    match l.appFn!.constName! with
    | ``Sat.Literal.pos =>
      (mkApp (mkConst ``Not) e, mkApp4 (mkConst ``Sat.Literal.reify_pos) v e n h)
    | ``Sat.Literal.neg =>
      (e, mkApp4 (mkConst ``Sat.Literal.reify_neg) v e n h)
    | _ => panic! "not a valid literal"
  /-- Returns `a` and `pr : v n ↔ a` given a variable index `n`.
  These are both lookups into the context
  `(a0 .. a(n-1) : Prop) (v) (h1 : v 0 ↔ a0) ... (hn : v (n-1) ↔ a(n-1))`. -/
  reifyVar v :=
    let n := v.natLit?.get!
    (mkBVar (2 * nvars - n), mkBVar (nvars - n - 1))
open Lean

namespace Parser
open Lean Parsec

/-- Parse a natural number -/
def parseNat : Parsec Nat := Json.Parser.natMaybeZero

/-- Parse an integer -/
def parseInt : Parsec Int := do
  if (← peek!) = '-' then skip; pure $ -(← parseNat) else parseNat

/-- Parse a list of integers terminated by 0 -/
partial def parseInts (arr : Array Int := #[]) : Parsec (Array Int) := do
  match ← parseInt <* ws with
  | 0 => pure arr
  | n => parseInts (arr.push n)

/-- Parse a list of natural numbers terminated by 0 -/
partial def parseNats (arr : Array Nat := #[]) : Parsec (Array Nat) := do
  match ← parseNat <* ws with
  | 0 => pure arr
  | n => parseNats (arr.push n)

/-- Parse a DIMACS format `.cnf` file.
This is not very robust; we assume the file has had comments stripped. -/
def parseDimacs : Parsec (Nat × Array (Array Int)) := do
  pstring "p cnf" *> ws
  let nvars ← parseNat <* ws
  let nclauses ← parseNat <* ws
  let mut clauses := Array.mkEmpty nclauses
  for _ in [:nclauses] do
    clauses := clauses.push (← parseInts)
  pure (nvars, clauses)

/-- Parse an LRAT file into a list of steps. -/
def parseLRAT : Parsec (Array LRATStep) := many do
  let step ← parseNat <* ws
  if (← peek!) = 'd' then skip <* ws; pure $ LRATStep.del (← parseNats)
  else ws; pure $ LRATStep.add step (← parseInts) (← parseInts)

end Parser

/-- Core of `fromLRAT`. Constructs the context and main proof definitions,
but not the reification theorem. Returns:

  * `nvars`: the number of variables specified in the CNF file
  * `ctx`: The abbreviated formula, a constant like `foo.ctx_1`
  * `ctx'`: The definitional expansion of the formula, a tree of `Fmla.and` nodes
  * `proof`: A proof of `ctx.proof []`
-/
def fromLRATAux (cnf lrat : String) (name : Name) : MetaM (Nat × Expr × Expr × Expr) := do
  let Parsec.ParseResult.success _ (nvars, arr) := Parser.parseDimacs cnf.mkIterator
    | throwError "parse CNF failed"
  if arr.isEmpty then throwError "empty CNF"
  let ctx' := buildConj arr 0 arr.size
  let ctxName ← mkAuxName (name ++ `ctx) 1
  addDecl $ Declaration.defnDecl {
    name := ctxName
    levelParams := []
    type        := mkConst ``Sat.Fmla
    value       := ctx'
    hints       := ReducibilityHints.regular 0
    safety      := DefinitionSafety.safe
  }
  let ctx := mkConst ctxName
  let Parsec.ParseResult.success _ steps := Parser.parseLRAT lrat.mkIterator
    | throwError "parse LRAT failed"
  let proof ← buildProof arr ctx ctx' steps
  let declName ← mkAuxName (name ++ `proof) 1
  addDecl $ Declaration.thmDecl {
    name := declName
    levelParams := []
    type        := mkApp2 (mkConst ``Sat.Fmla.proof) ctx (buildClause #[])
    value       := proof
  }
  return (nvars, ctx, ctx', mkConst declName)

/-- Main entry point. Given strings `cnf` and `lrat` with unparsed file data, and a name `name`,
adds `theorem name : type := proof` where `type` is a propositional theorem like
`∀ (a a_1 : Prop), (¬a ∧ ¬a_1 ∨ a ∧ ¬a_1) ∨ ¬a ∧ a_1 ∨ a ∧ a_1`.

Also creates auxiliaries named `name.ctx_1` (for the CNF formula)
and `name.proof_1` (for the LRAT proof), with `name` itself containing the reification proof. -/
def fromLRAT (cnf lrat : String) (name : Name) : MetaM Unit := do
  let (nvars, ctx, ctx', proof) ← fromLRATAux cnf lrat name
  let (type, value) := buildReify ctx ctx' proof nvars
  addDecl $ Declaration.thmDecl { name, levelParams := [], type, value }

open Elab Term

/--
A macro for producing SAT proofs from CNF / LRAT files.
These files are commonly used in the SAT community for writing proofs.

The input to the `lrat_proof` command is the name of the theorem to define,
and the statement (written in CNF format) and the proof (in LRAT format).
For example:
```
lrat_proof foo
  "p cnf 2 4  1 2 0  -1 2 0  1 -2 0  -1 -2 0"
  "5 -2 0 4 3 0  5 d 3 4 0  6 1 0 5 1 0  6 d 1 0  7 0 5 2 6 0"
```
produces a theorem:
```
foo : ∀ (a a_1 : Prop), (¬a ∧ ¬a_1 ∨ a ∧ ¬a_1) ∨ ¬a ∧ a_1 ∨ a ∧ a_1
```

* You can see the theorem statement by hovering over the word `foo`.
* You can use the `example` keyword in place of `foo` to avoid generating a theorem.
* You can use the `include_str` macro in place of the two strings
  to load CNF / LRAT files from disk.
-/
elab "lrat_proof" n:(ident <|> "example") cnf:term:max lrat:term:max : command => do
  let name := (← getCurrNamespace) ++ if n.1.isIdent then n.1.getId else `_example
  Command.liftTermElabM do
    let cnf ← unsafe evalTerm String (mkConst ``String) cnf
    let lrat ← unsafe evalTerm String (mkConst ``String) lrat
    let go := do
      fromLRAT cnf lrat name
      withSaveInfoContext do
        Term.addTermInfo' n (mkConst name) (isBinder := true)
    if n.1.isIdent then go else withoutModifyingEnv go

lrat_proof example
  -- The CNF file
  "p cnf 2 4
   1 2 0
   -1 2 0
   1 -2 0
   -1 -2 0"
  -- The LRAT file
  "5 -2 0 4 3 0
   5 d 3 4 0
   6 1 0 5 1 0
   6 d 1 0
   7 0 5 2 6 0"

-- lrat_proof full2
--   (include_str "full2.cnf")
--   (include_str "full2.lrat")

/--
A macro for producing SAT proofs from CNF / LRAT files.
These files are commonly used in the SAT community for writing proofs.

The input to the `from_lrat` term syntax is two string expressions with
the statement (written in CNF format) and the proof (in LRAT format).
For example:
```
def foo := from_lrat
  "p cnf 2 4  1 2 0  -1 2 0  1 -2 0  -1 -2 0"
  "5 -2 0 4 3 0  5 d 3 4 0  6 1 0 5 1 0  6 d 1 0  7 0 5 2 6 0"
```
produces a theorem:
```
foo : ∀ (a a_1 : Prop), (¬a ∧ ¬a_1 ∨ a ∧ ¬a_1) ∨ ¬a ∧ a_1 ∨ a ∧ a_1
```

* You can use this term after `have :=` or in `def foo :=` to produce the term
  without constraining the type.
* You can use it when a specific type is expected, but it currently does not
  pay any attention to the shape of the goal and always produces the same theorem,
  so you can only use this to do alpha renaming.
* You can use the `include_str` macro in place of the two strings
  to load CNF / LRAT files from disk.
-/
elab "from_lrat" cnf:term:max lrat:term:max : term => do
  let cnf ← unsafe evalTerm String (mkConst ``String) cnf
  let lrat ← unsafe evalTerm String (mkConst ``String) lrat
  let name ← mkAuxName `lrat
  fromLRAT cnf lrat name
  return mkConst name

example : ∀ (a b : Prop), (¬a ∧ ¬b ∨ a ∧ ¬b) ∨ ¬a ∧ b ∨ a ∧ b := from_lrat
  "p cnf 2 4  1 2 0  -1 2 0  1 -2 0  -1 -2 0"
  "5 -2 0 4 3 0  5 d 3 4 0  6 1 0 5 1 0  6 d 1 0  7 0 5 2 6 0"


import data.set.basic data.real.basic tactic.ring
import analysis.topology.continuity
import analysis.real
import data.vector

open set

namespace set_theory_review

def sin (x : ℝ) : ℝ := sorry
def cos (x : ℝ) : ℝ := sorry

namespace problem1

-- (1) Consider the sine function defined by f(x) = sin x for (−∞ < x < ∞).

-- uhm we don't actually have the sin function in Lean yet ...
def f (x : ℝ) : ℝ := sin x
-- nor pi
def pi : ℝ := sorry

-- but if we did, we could prove this!

namespace part_a

-- What is the image of π/2 under f?
lemma answer_proof : f (pi / 2) = 1 := sorry

end part_a

namespace part_b

-- Find f⁻¹(1).

-- so we uh just take the inverse of the function, right?
-- -- lemma part_b : function.inv_fun f 1 = pi/2
-- wrong, that's not well defined, we can't prove anything about it ...

-- might as well just repeat ourselves:
lemma answer_proof : f (pi / 2) = 1 := part_a.answer_proof
-- or give the precise set
def answer : set ℝ := {x | f x = 1}
-- aka the preimage
lemma proof_preimage : answer = f ⁻¹' {1} :=
  begin
  apply set.ext, intro x, simpa,
  end
-- which does include pi/2, by part a
lemma includes_half_pi : pi / 2 ∈ answer := part_a.answer_proof

end part_b

lemma sin_pi_6 : f (pi/6) = 1/2 := sorry

namespace part_c

-- Find f([0, π/6]), f([π/6, π/2]), f([0, π/2]).
lemma part_i : f '' Icc 0 (pi/6) = Icc 0 (1/2) := sorry
lemma part_ii : f '' Icc (pi/6) (pi/2) = Icc (1/2) 1 := sorry
lemma part_iii : f '' Icc 0 (pi/2) = Icc 0 1 := sorry

end part_c

namespace part_d

-- (d) Interpret the result of part (c) in view of the theorem:
--       If f : A → B and if X ⊂ A and Y ⊂ A, then f(X ∪ Y) = f(X) ∪ f(Y).

-- we do have that theorem already:
#check set.image_union

-- I'll just reprove it quickly:
theorem reproof {A B : Type} (f : A → B) (X Y : set A) :
  f '' (X ∪ Y) = f '' X ∪ f '' Y :=
  begin
  unfold set.image,
  unfold has_union.union set.union,
  apply set.ext, intro b, simp,
  constructor,
  intro e, apply exists.elim e, intro a, intro h,
  cases h, cases h_left,
  { left, existsi a, tauto },
  { right, existsi a, tauto },
  intro e, cases e,
  { apply exists.elim e, intro a, intro h,
    existsi a, constructor, left, tauto, tauto
  },
  { apply exists.elim e, intro a, intro h,
    existsi a, constructor, right, tauto, tauto
  },
  end

-- helper theorem: [a, b] ∪ [c, d] = [a, d], given the following assumptions
theorem Icc_union {α : Type*} [linear_order α] (a b c d : α) :
  a ≤ c → b ≥ c → b ≤ d →
  Icc a b ∪ Icc c d = Icc a d :=
    begin
    intros,
    unfold Icc, apply set.ext, intro x, simp,
    constructor,
    {
      intro h, cases h,
      constructor, exact h.1, transitivity, exact h.2, assumption,
      constructor, transitivity, assumption, exact h.1, exact h.2,
    }, {
      intro h,
      have m : x ≤ b ∨ b ≤ x := linear_order.le_total x b,
      cases m,
      left, constructor, exact h.1, exact m,
      right, constructor, transitivity, assumption, exact m, exact h.2,
    }
    end

-- so we can get part_c.part_iii from the previous two
theorem proof : f '' Icc 0 (pi/2) = Icc 0 1 :=
  begin
  have : Icc 0 (pi/6) ∪ Icc (pi/6) (pi/2) = Icc 0 (pi/2),
  {
    apply Icc_union,
    /-
    3 goals
    ⊢ 0 ≤ pi / 6
    ⊢ pi / 6 ≥ pi / 6
    ⊢ pi / 6 ≤ pi / 2
    -/
    -- but we can't prove the ordering of pi since pi isn't defined here
    admit, exact le_refl (pi/6), admit,
  },
  rw ← this, rw reproof, rw part_c.part_i, rw part_c.part_ii,
  apply Icc_union,
  exact le_of_lt one_half_pos,
  exact le_refl (1/2),
  exact le_of_lt one_half_lt_one,
  end

end part_d

namespace part_e

-- (e) Let A = [0, π/6], B = [5π/6, π]. Does f(A ∩ B) = f(A) ∩ f(B)?

-- nope, because A ∩ B = ∅, but f(A) = f(B) = [0, 1/2]

def A := Icc 0 (pi/6)
def B := Icc (5*pi/6) (pi)
lemma A_image : f '' A = Icc 0 (1/2) := sorry
lemma B_image : f '' B = Icc 0 (1/2) := sorry

theorem proof : f '' (A ∩ B) ≠ f '' A ∩ f '' B :=
  begin
  rw [A_image, B_image],
  have : A ∩ B = ∅,
  {
    apply set.ext, intro x, simp,
    show 0 ≤ x ∧ x ≤ pi/6 → ¬ (5*pi/6 ≤ x ∧ x ≤ pi),
    suffices : x ≤ pi/6 → x < 5*pi/6,
    {
      intro h, apply not_and_of_not_left,
      apply not_le_of_lt,
      exact this h.2,
    },
    intro h,
    apply lt_of_le_of_lt,
    exact h,
    show pi / 6 < 5 * pi / 6, admit,
  },
  rw this, simp [-one_div_eq_inv],
  rw set.ext_iff,
  -- proof by contradiction, essentially
  -- (to prove (¬ p) you need to prove (p → false))
  -- (actually, that is true by definition: not p := p → false)
  intro empty_eq_Icc,
  -- 0 is an element in the interval
  exact (empty_eq_Icc 0).2 ⟨le_refl 0, le_of_lt one_half_pos⟩
  end

end part_e

end problem1

namespace problem2

-- (2) Can you give a geometric interpretation for the Cartesian product of
-- (a) A line segment and a triangle?

-- A triangular prism?

-- (b) A large circle and a small circle?

-- An ellipsoid??? Or maybe something in 4d space, since the circles are
-- each 2d ...
-- (My roommate: "Prolly ... a bigger circle?")

end problem2

namespace problem3

-- (3) If f : (−1, 1) → ℝ is defined by f(x) = arcsin x and
--     g : (−π/2, π/2) → ℝ by g(x) = tan x, let h = g ◦ f. Write a simple
--     formula for h. What are the domain and range of h?

-- h x = g (f x) = tan (arcsin x) = sin (arcsin x) / cos (arcsin x)
--     = x / cos (arcsin x) = x / sqrt(1 - x²)
--     = sqrt(x² / (1 - x²))
--     = if x = 0 then 0 else (x⁻² - 1)^(-1/2)

-- aux proof of cos (arcsin x) = sqrt(1 - x^2):
--   forall y:
--   (cos y)^2 + (sin y)^2 = 1
--   cos y = sqrt(1 - (sin y)^2)
--   rewrite y = arcsin x:
--   cos (arcsin x) = sqrt(1 - (sin (arcsin x))^2)
--   cos (arcsin x) = sqrt(1 - x^2)

-- domain of f : (-1, 1), range of f : (-π/2, π/2),
--   since f is continuous and monotonic between f(-1) = -π/2 and f(1) = π/2
-- domain of g : (-π/2, π/2), range of g : (-∞, ∞),
--   since f is continuous and lim[x → ±π/2] f = ±∞
-- so domain of h : (-1, 1), range of h : (-∞, ∞)

end problem3

namespace problem4

-- (4) Let f : ℝ → ℝ be defined by f(x) = 2x. Can you think of functions g
--     and h which satisfy these two equations?
-- g ◦ f = 2 * g * h
-- h ◦ f = h^2 − g^2

def f (x : ℝ) := 2*x

def problem := ∃ (g h : ℝ → ℝ), ∀ x,
  g (f x) = 2 * g x * h x ∧
  h (f x) = (h x)^2 - (g x)^2

def g (x : ℝ) := sin x
def h (x : ℝ) := cos x

-- graph it! obviously can't prove it here ...
lemma sin_two_eq_two_sin_cos :
  ∀ x, sin (2 * x) = 2 * sin x * cos x := sorry
lemma sin_two_eq_cos_sqr_sub_sin_sqr :
  ∀ x, cos (2 * x) = (cos x)^2 - (sin x)^2 := sorry

-- our proof is just a term with type defined by the problem
-- (that is, it is a proof of the existence of such functions)
def proof : problem :=
  begin
  existsi g,
  existsi h,
  intro x,
  constructor,
  exact sin_two_eq_two_sin_cos x,
  exact sin_two_eq_cos_sqr_sub_sin_sqr x,
  end

end problem4

-- The next few questions concern the notion of the characteristic function
-- of a set, which we now define. Let A be a subset of the real numbers ℝ.
-- Define the characteristic function of A χ_A : ℝ → ℝ to be

-- χ_A(x) = 1 if x ∈ A; 0 if x ∈ ℝ \ A.

-- this is the same spirit, in particular it works for
-- a set of any type (which is also how it was assumed
-- to be generalized in the examples), mapping
-- 1 to true and 0 to false
def χ {α : Type} (A : set α) (a : α) := a ∈ A
-- but really it's just the identity function
-- (this is because sets in set theory are represented as functions
-- α → Prop, for some α : Type, where the proposition returned
-- is true for only the (a : α) in the set.)
-- (in HoTT, a set also means that it has no path constructors.)
@[simp] lemma χ_id {α : Type} (A : set α) : χ A = A := rfl

namespace problem5

-- (5) If f : ℝ → ℝ is defined by f(x) = x^2 and χ_[0,9] is the
--     characteristic function of [0, 9], of what subset of ℝ is
--     χ[0,9] ◦ f the characteristic function?

def real.sqr (x : ℝ) := x ^ 2
def zero_through_nine : set ℝ := Icc 0 9

def answer : set ℝ := Icc (-3) 3

theorem proof : answer = χ zero_through_nine ∘ real.sqr :=
  begin
  apply set.ext, intro x,
  show -3 ≤ x ∧ x ≤ 3 ↔ 0 ≤ x^2 ∧ x^2 ≤ 9,
  unfold has_pow.pow monoid.pow, simp,
  rw (by ring : (9 : ℝ) = 3 * 3),
  constructor,
  {
    intro h,
    have : x * x = abs x * abs x,
      by_cases x = 0, { rw h, simp },
      apply (mul_self_eq_mul_self_iff _ _).2,
      apply abs_by_cases (λ y, x = y ∨ x = -y),
      left, tauto, right, rw neg_neg,
    rw this,
    constructor,
    exact mul_self_nonneg (abs x),
    apply mul_self_le_mul_self,
    exact abs_nonneg x,
    apply abs_le.2, exact h,
  }, {
    intro h,
    rw ← abs_le,
    have : (0 : ℝ) ≤ 3,
      { change real.of_rat 0 ≤ real.of_rat 3
      , apply le_of_lt
      , rw real.of_rat_lt
      , from dec_trivial
      },
    rw ((by rw @real.sqrt_sqr (3 : ℝ); assumption) : 3 = real.sqrt (3^2)),
    unfold has_pow.pow monoid.pow, simp,
    rw ← real.sqrt_mul_self_eq_abs x,
    rw real.sqrt_le,
    exact h.2, exact h.1,
    apply le_of_lt,
    change real.of_rat 0 < real.of_rat (3 * 3),
    rw real.of_rat_lt,
    from dec_trivial
  }
  end

end problem5

namespace problem6

-- (6) If f : A → B is a function and χ_E is the characteristic function of
-- E ⊂ B, of what subset of A is χ_E ◦ f the characteristic function?

-- that's just the preimage of f over E, the set of points in the domain such
-- that their image under f is in E: { x : A | f x ∈ E }
def answer {A B : Type} (f : A → B) (E : set B) := f ⁻¹' E
#print set.preimage
theorem proof {A B : Type} (f : A → B) (E : set B)
  : χ E ∘ f = answer f E :=
  begin apply set.ext, intro x, simpa end

end problem6

namespace problem7

-- (7) Using whatever concept of continuity you possess, answer the
--     following questions (the answer is supposed to be intuitive,
--     and is not meant to include a rigorous proof):

-- (a) Is there a continuous characteristic function on ℝ? That is, is there
--     a subset A of ℝ such that χ_A is continuous?

-- Yes, there are two: A = ℝ, and A = ∅.

-- (b) Are there three such functions?

-- No, any deviation from a constant function produces a discontinuity.

end problem7

namespace problem8

-- (8) Draw the graphs of two continuous functions f and g with the same
--     domain. Would you guess that the functions
--     M := max(f, g) and m := min(f, g) are continuous?

-- [insert graphs badly drawn with crayons as if penned by a 5yo] jk

-- Yes, I would guess so.
-- And it's this is actually a theorem already ...
-- The gist of it is this lemma
#check continuous_if
-- which basically says that piecewise functions, in order to be continuous,
-- must be equal when the if  statement switches between true and false (and
-- of course, the functions should be continuous otherwise). The if
-- statement does indeed switch between true and false when the functions
-- are equal, by the definition of `max` and `min`.

def pointwise {A B I O : Type} (f : A → B → O) (g : I → A) (h : I → B) :=
  λ i, f (g i) (h i)

theorem proof (f g : ℝ → ℝ) : continuous f → continuous g → continuous (pointwise max f g) ∧ continuous (pointwise min f g) :=
  begin
  intros cf cg,
  constructor,
  exact continuous_max cf cg,
  exact continuous_min cf cg,
  end

end problem8

namespace problem9

-- (9) (a) If f : A → B and g : B → C and both f and g are injective,
--         is g ◦ f also injective?
--     (b) If f is not injective, is it still possible that g ◦ f is
--         injective?
--     (c) Give an example in which f is injective, g is not injective,
--         but g ◦ f is injective.
open function

-- it's very straightforward ...
theorem part_a {A B C : Type} (f : A → B) (g : B → C) : function.injective f → function.injective g → function.injective (g ∘ f) :=
  flip function.injective_comp

theorem part_b {A B C : Type} (f : A → B) (g : B → C) : ¬ function.injective f → function.injective g → ¬ function.injective (g ∘ f) :=
  begin
  intros f_ninj g_inj comp_inj,
  apply f_ninj,
  intros a b e,
  unfold function.injective function.comp at comp_inj,
  apply comp_inj (congr_arg _ e),
  end

namespace part_c

def A := unit
def B := bool
def C := unit
def f : A → B := λ _, ff
def g : B → C := λ _, unit.star
theorem proof : injective f ∧ ¬ injective g ∧ injective (g ∘ f) :=
  begin
  constructor,
  intros _ _ _, apply @subsingleton.elim unit,
  constructor,
  intro f,
  exact bool.no_confusion (@f tt ff (by apply @subsingleton.elim unit)),
  intros _ _ _, apply @subsingleton.elim unit,
  end

end part_c

end problem9

namespace problem10

-- (10) Let P_n be the set of polynomial functions f of degree n,
--          f(x) = a_0 + a_1 * x + · · · a_n * x^n
--      where n is a fixed non-negative integer and the coefficients
--      a0, . . . , an are integers. Prove that P_n is countable.

-- In this problem I'll use `encodable α` instead of `countable α`, which is
-- defined as `nonempty (encodable α)` (that is, the mere proposition
-- that there exists an encoding for the type).

-- A vector of numbers of size n essentially represents the data of a
-- polynomial of degree (n-1); that is, there is a bijection between these
-- mathematical objects. So I'll prove that a vector of encodables is
-- encodable.

-- The gist of the proof is induction on n, using cartesian products
-- to add another layer to the vector.

theorem encodable_equiv {α β : Type} : α ≃ β → encodable α → encodable β :=
  begin
  intros eqv c,
  apply encodable.mk (c.encode ∘ eqv.2) (option.map eqv.1 ∘ c.decode),
  intro b, simp, existsi (eqv.2 b),
  rw c.encodek, simp, exact eqv.4 b,
  end

theorem encodable_array {α : Type} : encodable α → ∀ n : ℕ, encodable (vector α n) :=
  begin
  intros c n, induction n with n ih,
  suffices : unit ≃ vector α 0,
  {
    apply encodable_equiv this, apply_instance,
  },
  apply equiv.mk (λ _, vector.nil) (λ _, unit.star),
  intro _, apply subsingleton.elim,
  intro _, rw vector.eq_nil x,
  suffices : (α × vector α n) ≃ vector α (n+1),
  {
    apply encodable_equiv this,
    apply @encodable.prod _ _ c ih,
  },
  apply equiv.mk
    (λ (p : α × vector α n), vector.cons p.1 p.2)
    (λ a, begin
    cases a with l p,
    cases l, exfalso, exact nat.succ_ne_zero _ (eq.symm p),
    constructor, exact l_hd,
    apply subtype.mk l_tl,
    exact nat.succ.inj p,
    end),
  intro a, cases a, cases a_snd, simpa,
  intro a, cases a, simp,
  cases a_val, exfalso, exact nat.succ_ne_zero _ (eq.symm a_property),
  simpa,
  end

end problem10

namespace problem11

-- (11) Prove that if B is a countable subset of an uncountable set A, then
-- A \ B is uncountable.
theorem proof {α : Type} (A B : set α)
  (H : B ⊆ A) (HA : ¬(countable A)) (HB : countable B) : ¬(countable (A \ B)) :=
  λ HC,
  have this : (A \ B) ∪ B = A :=
    eq.trans diff_union_self (union_eq_self_of_subset_right H),
  HA (eq.mp (congr_arg countable this) (countable_union HC HB))

end problem11

end set_theory_review


import classes.context_free.closure_properties.union
import classes.context_free.closure_properties.intersection

/-- The class of context-free languages isn't closed under complement. -/
theorem nnyCF_of_complement_CF : ¬ (∀ T : Type, ∀ L : language T,
    is_CF L  →  is_CF (Lᶜ)
) :=
begin
  intro h,
  have nny := nnyCF_of_CF_i_CF,
  push_neg at nny,
  rcases nny with ⟨T, L₁, L₂, ⟨hL₁, hL₂⟩, hyp_neg⟩,
  specialize h T,
  have hu := CF_of_CF_u_CF (L₁ᶜ) (L₂ᶜ) ⟨h L₁ hL₁, h L₂ hL₂⟩,
  have contra := h (L₁ᶜ + L₂ᶜ) hu,
  apply hyp_neg,
  -- golfed by Eric Wieser
  rwa [language.add_def, set.compl_union, compl_compl, compl_compl] at contra,
end


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

! This file was ported from Lean 3 source module category_theory.monoidal.CommMon_
! leanprover-community/mathlib commit a836c6dba9bd1ee2a0cdc9af0006a596f243031c
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.CategoryTheory.Monoidal.Braided
import Mathbin.CategoryTheory.Monoidal.Mon_

/-!
# The category of commutative monoids in a braided monoidal category.
-/

universe v₁ v₂ u₁ u₂ u

open CategoryTheory

open CategoryTheory.MonoidalCategory

variable (C : Type u₁) [Category.{v₁} C] [MonoidalCategory.{v₁} C] [BraidedCategory.{v₁} C]

/-- A commutative monoid object internal to a monoidal category.
-/
structure CommMon_ extends Mon_ C where
  mul_comm' : (β_ _ _).Hom ≫ mul = mul := by obviously
#align CommMon_ CommMon_

restate_axiom CommMon_.mul_comm'

attribute [simp, reassoc.1] CommMon_.mul_comm

namespace CommMon_

/-- The trivial commutative monoid object. We later show this is initial in `CommMon_ C`.
-/
@[simps]
def trivial : CommMon_ C :=
  { Mon_.trivial C with mul_comm' := by dsimp; rw [braiding_left_unitor, unitors_equal] }
#align CommMon_.trivial CommMon_.trivial

instance : Inhabited (CommMon_ C) :=
  ⟨trivial C⟩

variable {C} {M : CommMon_ C}

instance : Category (CommMon_ C) :=
  InducedCategory.category CommMon_.toMon_

@[simp]
theorem id_hom (A : CommMon_ C) : Mon_.Hom.hom (𝟙 A) = 𝟙 A.pt :=
  rfl
#align CommMon_.id_hom CommMon_.id_hom

@[simp]
theorem comp_hom {R S T : CommMon_ C} (f : R ⟶ S) (g : S ⟶ T) :
    Mon_.Hom.hom (f ≫ g) = f.Hom ≫ g.Hom :=
  rfl
#align CommMon_.comp_hom CommMon_.comp_hom

section

variable (C)

/-- The forgetful functor from commutative monoid objects to monoid objects. -/
def forget₂Mon_ : CommMon_ C ⥤ Mon_ C :=
  inducedFunctor CommMon_.toMon_ deriving Full, Faithful
#align CommMon_.forget₂_Mon_ CommMon_.forget₂Mon_

@[simp]
theorem forget₂_Mon_obj_one (A : CommMon_ C) : ((forget₂Mon_ C).obj A).one = A.one :=
  rfl
#align CommMon_.forget₂_Mon_obj_one CommMon_.forget₂_Mon_obj_one

@[simp]
theorem forget₂_Mon_obj_mul (A : CommMon_ C) : ((forget₂Mon_ C).obj A).mul = A.mul :=
  rfl
#align CommMon_.forget₂_Mon_obj_mul CommMon_.forget₂_Mon_obj_mul

@[simp]
theorem forget₂_Mon_map_hom {A B : CommMon_ C} (f : A ⟶ B) : ((forget₂Mon_ C).map f).Hom = f.Hom :=
  rfl
#align CommMon_.forget₂_Mon_map_hom CommMon_.forget₂_Mon_map_hom

end

instance uniqueHomFromTrivial (A : CommMon_ C) : Unique (trivial C ⟶ A) :=
  Mon_.uniqueHomFromTrivial A.toMon_
#align CommMon_.unique_hom_from_trivial CommMon_.uniqueHomFromTrivial

open CategoryTheory.Limits

instance : HasInitial (CommMon_ C) :=
  hasInitial_of_unique (trivial C)

end CommMon_

namespace CategoryTheory.LaxBraidedFunctor

variable {C} {D : Type u₂} [Category.{v₂} D] [MonoidalCategory.{v₂} D] [BraidedCategory.{v₂} D]

/-- A lax braided functor takes commutative monoid objects to commutative monoid objects.

That is, a lax braided functor `F : C ⥤ D` induces a functor `CommMon_ C ⥤ CommMon_ D`.
-/
@[simps]
def mapCommMon (F : LaxBraidedFunctor C D) : CommMon_ C ⥤ CommMon_ D
    where
  obj A :=
    { F.toLaxMonoidalFunctor.mapMon.obj A.toMon_ with
      mul_comm' := by
        dsimp
        have := F.braided
        slice_lhs 1 2 => rw [← this]
        slice_lhs 2 3 => rw [← CategoryTheory.Functor.map_comp, A.mul_comm] }
  map A B f := F.toLaxMonoidalFunctor.mapMon.map f
#align category_theory.lax_braided_functor.map_CommMon CategoryTheory.LaxBraidedFunctor.mapCommMon

variable (C) (D)

/-- `map_CommMon` is functorial in the lax braided functor. -/
def mapCommMonFunctor : LaxBraidedFunctor C D ⥤ CommMon_ C ⥤ CommMon_ D
    where
  obj := mapCommMon
  map F G α := { app := fun A => { Hom := α.app A.pt } }
#align category_theory.lax_braided_functor.map_CommMon_functor CategoryTheory.LaxBraidedFunctor.mapCommMonFunctor

end CategoryTheory.LaxBraidedFunctor

namespace CommMon_

open CategoryTheory.LaxBraidedFunctor

namespace EquivLaxBraidedFunctorPunit

/-- Implementation of `CommMon_.equiv_lax_braided_functor_punit`. -/
@[simps]
def laxBraidedToCommMon : LaxBraidedFunctor (Discrete PUnit.{u + 1}) C ⥤ CommMon_ C
    where
  obj F := (F.mapCommMon : CommMon_ _ ⥤ CommMon_ C).obj (trivial (Discrete PUnit))
  map F G α := ((mapCommMonFunctor (Discrete PUnit) C).map α).app _
#align CommMon_.equiv_lax_braided_functor_punit.lax_braided_to_CommMon CommMon_.EquivLaxBraidedFunctorPunit.laxBraidedToCommMon

/-- Implementation of `CommMon_.equiv_lax_braided_functor_punit`. -/
@[simps]
def commMonToLaxBraided : CommMon_ C ⥤ LaxBraidedFunctor (Discrete PUnit.{u + 1}) C
    where
  obj A :=
    { obj := fun _ => A.pt
      map := fun _ _ _ => 𝟙 _
      ε := A.one
      μ := fun _ _ => A.mul
      map_id' := fun _ => rfl
      map_comp' := fun _ _ _ _ _ => (Category.id_comp (𝟙 A.pt)).symm }
  map A B f :=
    { app := fun _ => f.Hom
      naturality' := fun _ _ _ => by
        dsimp
        rw [category.id_comp, category.comp_id]
      unit' := f.OneHom
      tensor' := fun _ _ => f.MulHom }
#align CommMon_.equiv_lax_braided_functor_punit.CommMon_to_lax_braided CommMon_.EquivLaxBraidedFunctorPunit.commMonToLaxBraided

attribute [local tidy] tactic.discrete_cases

attribute [local simp] eq_to_iso_map

/-- Implementation of `CommMon_.equiv_lax_braided_functor_punit`. -/
@[simps]
def unitIso :
    𝟭 (LaxBraidedFunctor (Discrete PUnit.{u + 1}) C) ≅
      laxBraidedToCommMon C ⋙ commMonToLaxBraided C :=
  NatIso.ofComponents
    (fun F =>
      LaxBraidedFunctor.mkIso
        (MonoidalNatIso.ofComponents
          (fun _ => F.toLaxMonoidalFunctor.toFunctor.mapIso (eqToIso (by ext))) (by tidy) (by tidy)
          (by tidy)))
    (by tidy)
#align CommMon_.equiv_lax_braided_functor_punit.unit_iso CommMon_.EquivLaxBraidedFunctorPunit.unitIso

/-- Implementation of `CommMon_.equiv_lax_braided_functor_punit`. -/
@[simps]
def counitIso : commMonToLaxBraided C ⋙ laxBraidedToCommMon C ≅ 𝟭 (CommMon_ C) :=
  NatIso.ofComponents
    (fun F =>
      { Hom := { Hom := 𝟙 _ }
        inv := { Hom := 𝟙 _ } })
    (by tidy)
#align CommMon_.equiv_lax_braided_functor_punit.counit_iso CommMon_.EquivLaxBraidedFunctorPunit.counitIso

end EquivLaxBraidedFunctorPunit

open EquivLaxBraidedFunctorPunit

attribute [local simp] eq_to_iso_map

/-- Commutative monoid objects in `C` are "just" braided lax monoidal functors from the trivial
braided monoidal category to `C`.
-/
@[simps]
def equivLaxBraidedFunctorPunit : LaxBraidedFunctor (Discrete PUnit.{u + 1}) C ≌ CommMon_ C
    where
  Functor := laxBraidedToCommMon C
  inverse := commMonToLaxBraided C
  unitIso := unitIso C
  counitIso := counitIso C
#align CommMon_.equiv_lax_braided_functor_punit CommMon_.equivLaxBraidedFunctorPunit

end CommMon_


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

/-!
# Locally bounded maps

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

This file defines locally bounded maps between bornologies.

We use the `fun_like` design, so each type of morphisms has a companion typeclass which is meant to
be satisfied by itself and all stricter types.

## Types of morphisms

* `locally_bounded_map`: Locally bounded maps. Maps which preserve boundedness.

## Typeclasses

* `locally_bounded_map_class`
-/

open bornology filter function set

variables {F α β γ δ : Type*}

/-- The type of bounded maps from `α` to `β`, the maps which send a bounded set to a bounded set. -/
structure locally_bounded_map (α β : Type*) [bornology α] [bornology β] :=
(to_fun : α → β)
(comap_cobounded_le' : (cobounded β).comap to_fun ≤ cobounded α)

section
set_option old_structure_cmd true

/-- `locally_bounded_map_class F α β` states that `F` is a type of bounded maps.

You should extend this class when you extend `locally_bounded_map`. -/
class locally_bounded_map_class (F : Type*) (α β : out_param $ Type*) [bornology α]
  [bornology β]
  extends fun_like F α (λ _, β) :=
(comap_cobounded_le (f : F) : (cobounded β).comap f ≤ cobounded α)

end

export locally_bounded_map_class (comap_cobounded_le)

lemma is_bounded.image [bornology α] [bornology β] [locally_bounded_map_class F α β] {f : F}
  {s : set α} (hs : is_bounded s) : is_bounded (f '' s) :=
comap_cobounded_le_iff.1 (comap_cobounded_le f) hs

instance [bornology α] [bornology β] [locally_bounded_map_class F α β] :
  has_coe_t F (locally_bounded_map α β) :=
⟨λ f, ⟨f, comap_cobounded_le f⟩⟩

namespace locally_bounded_map
variables [bornology α] [bornology β] [bornology γ]
  [bornology δ]

instance : locally_bounded_map_class (locally_bounded_map α β) α β :=
{ coe := λ f, f.to_fun,
  coe_injective' := λ f g h, by { cases f, cases g, congr' },
  comap_cobounded_le := λ f, f.comap_cobounded_le' }

/-- Helper instance for when there's too many metavariables to apply `fun_like.has_coe_to_fun`
directly. -/
instance : has_coe_to_fun (locally_bounded_map α β) (λ _, α → β) := fun_like.has_coe_to_fun

@[simp] lemma to_fun_eq_coe {f : locally_bounded_map α β} : f.to_fun = (f : α → β) := rfl

@[ext] lemma ext {f g : locally_bounded_map α β} (h : ∀ a, f a = g a) : f = g := fun_like.ext f g h

/-- Copy of a `locally_bounded_map` with a new `to_fun` equal to the old one. Useful to fix
definitional equalities. -/
protected def copy (f : locally_bounded_map α β) (f' : α → β) (h : f' = f) :
  locally_bounded_map α β :=
⟨f', h.symm ▸ f.comap_cobounded_le'⟩

@[simp] lemma coe_copy (f : locally_bounded_map α β) (f' : α → β) (h : f' = f) :
  ⇑(f.copy f' h) = f' :=
rfl

lemma copy_eq (f : locally_bounded_map α β) (f' : α → β) (h : f' = f) : f.copy f' h = f :=
fun_like.ext' h

/-- Construct a `locally_bounded_map` from the fact that the function maps bounded sets to bounded
sets. -/
def of_map_bounded (f : α → β) (h) : locally_bounded_map α β := ⟨f, comap_cobounded_le_iff.2 h⟩

@[simp] lemma coe_of_map_bounded (f : α → β) {h} : ⇑(of_map_bounded f h) = f := rfl
@[simp] lemma of_map_bounded_apply (f : α → β) {h} (a : α) : of_map_bounded f h a = f a := rfl

variables (α)

/-- `id` as a `locally_bounded_map`. -/
protected def id : locally_bounded_map α α := ⟨id, comap_id.le⟩

instance : inhabited (locally_bounded_map α α) := ⟨locally_bounded_map.id α⟩

@[simp] lemma coe_id : ⇑(locally_bounded_map.id α) = id := rfl

variables {α}

@[simp] lemma id_apply (a : α) : locally_bounded_map.id α a = a := rfl

/-- Composition of `locally_bounded_map`s as a `locally_bounded_map`. -/
def comp (f : locally_bounded_map β γ) (g : locally_bounded_map α β) : locally_bounded_map α γ :=
{ to_fun := f ∘ g,
  comap_cobounded_le' :=
    comap_comap.ge.trans $ (comap_mono f.comap_cobounded_le').trans g.comap_cobounded_le' }

@[simp] lemma coe_comp (f : locally_bounded_map β γ) (g : locally_bounded_map α β) :
  ⇑(f.comp g) = f ∘ g := rfl
@[simp] lemma comp_apply (f : locally_bounded_map β γ) (g : locally_bounded_map α β) (a : α) :
  f.comp g a = f (g a) := rfl
@[simp] lemma comp_assoc (f : locally_bounded_map γ δ) (g : locally_bounded_map β γ)
  (h : locally_bounded_map α β) :
  (f.comp g).comp h = f.comp (g.comp h) := rfl
@[simp] lemma comp_id (f : locally_bounded_map α β) :
  f.comp (locally_bounded_map.id α) = f := ext $ λ a, rfl
@[simp] lemma id_comp (f : locally_bounded_map α β) :
  (locally_bounded_map.id β).comp f = f := ext $ λ a, rfl

lemma cancel_right {g₁ g₂ : locally_bounded_map β γ} {f : locally_bounded_map α β}
  (hf : surjective f) :
  g₁.comp f = g₂.comp f ↔ g₁ = g₂ :=
⟨λ h, ext $ hf.forall.2 $ fun_like.ext_iff.1 h, congr_arg _⟩

lemma cancel_left {g : locally_bounded_map β γ} {f₁ f₂ : locally_bounded_map α β}
  (hg : injective g) :
  g.comp f₁ = g.comp f₂ ↔ f₁ = f₂ :=
⟨λ h, ext $ λ a, hg $ by rw [←comp_apply, h, comp_apply], congr_arg _⟩

end locally_bounded_map


/-
Copyright 2020 Google LLC

Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at

      http://www.apache.org/licenses/LICENSE-2.0

Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
 -/

import data.set.disjointed data.set.countable
import data.set.lattice data.set.finite
import formal_ml.nat

/-
  Theorems about sets. The best repository of theorems about sets is
  /mathlib/src/data/set/basic.lean.
 -/

--Novel, used: move to mathlib?
--Alternately, look into topological_space.lean, and see what is necessary.
lemma set.preimage_fst_def {α β:Type*} {Bα:set (set α)}:
    (@set.preimage (α × β) α (@prod.fst α β) '' Bα) =
    {U : set (α × β) | ∃ (A : set α) (H : A ∈ Bα), U = @set.prod α β A (@set.univ β)} :=
begin
  ext,split;intros A1A,
  {
    simp at A1A,
    cases A1A with A A1A,
    cases A1A with A1B A1C,
    subst x,
    split,
    simp,
    split,
    apply A1B,
    unfold set.prod,
    simp,
    refl,
  },
  {
    simp at A1A,
    cases A1A with A A1A,
    cases A1A with A1B A1C,
    subst x,
    split,
    split,
    apply A1B,
    unfold set.prod,
    simp,
    refl
  }
end

--Novel, used.
lemma set.preimage_snd_def {α β:Type*} {Bβ:set (set β)}:
    (@set.preimage (α × β) β (@prod.snd α β) '' Bβ) =
    {U : set (α × β) | ∃ (B : set β) (H : B ∈ Bβ), U = @set.prod α β (@set.univ α) B} :=
begin
    ext,split;intros A1A,
    {
      simp at A1A,
      cases A1A with A A1A,
      cases A1A with A1B A1C,
      subst x,
      split,
      simp,
      split,
      apply A1B,
      unfold set.prod,
      simp,
      refl,
    },
    {
      simp at A1A,
      cases A1A with A A1A,
      cases A1A with A1B A1C,
      subst x,
      split,
      split,
      apply A1B,
      unfold set.prod,
      simp,
      refl
    }
end

--Novel, used.
--Similar, but not identical to set.preimage_sUnion.
--Could probably replace it.
lemma set.preimage_sUnion' {α β:Type*} (f:α → β) (T:set (set β)):
 (f ⁻¹' ⋃₀ T)=⋃₀ (set.image (set.preimage f)  T) :=
begin
  rw set.preimage_sUnion,
  ext,split;intros A1;simp;simp at A1;apply A1,
end

--Novel, used.
lemma set.prod_sUnion_right {α:Type*} (A:set α) {β:Type*} (B:set (set β)):
  (set.prod A (⋃₀ B)) = ⋃₀  {C:set (α× β)|∃ b∈ B, C=(set.prod A b)} :=
begin
  ext,split;intro A1,
  {
    cases A1 with A2 A3,
    cases A3 with b A4,
    cases A4 with A5 A6,
    simp,
    apply exists.intro (set.prod A b),
    split,
    {
      apply exists.intro b,
      split,
      exact A5,
      refl,
    },
    {
      split;assumption,
    }
  },
  {
    cases A1 with Ab A2,
    cases A2 with A3 A4,
    cases A3 with b A5,
    cases A5 with A6 A7,
    subst Ab,
    cases A4 with A8 A9,
    split,
    {
      exact A8,
    },
    {
      simp,
      apply exists.intro b,
      split;assumption,
    }
  }
end

--Novel, used.
lemma set.prod_sUnion_left {α:Type*} (A:set (set α)) {β:Type*} (B:set β):
  (set.prod (⋃₀ A) B) = ⋃₀  {C:set (α× β)|∃ a∈ A, C=(set.prod a B)} :=
begin
  ext,split;intro A1,
  {
    cases A1 with A2 A3,
    cases A2 with a A4,
    cases A4 with A5 A6,
    simp,
    apply exists.intro (set.prod a B),
    split,
    {
      apply exists.intro a,
      split,
      exact A5,
      refl,
    },
    {
      split;assumption,
    }
  },
  {
    cases A1 with Ab A2,
    cases A2 with A3 A4,
    cases A3 with b A5,
    cases A5 with A6 A7,
    subst Ab,
    cases A4 with A8 A9,
    split,
    {
      simp,
      apply exists.intro b,
      split;assumption,
    },
    {
      exact A9,
    }
  }
end

--Novel, used.
lemma union_trichotomy {β:Type*} [decidable_eq β] {b:β} {S S2:finset β}:
  b∈ (S ∪ S2) ↔ (
      ((b∈  S) ∧ (b∉ S2)) ∨
      ((b∈ S) ∧ (b ∈ S2)) ∨
      ((b∉ S) ∧ (b∈ S2))) :=
begin
  have B1:(b∈ S)∨ (b∉ S),
  {
    apply classical.em,
  },
  have B2:(b∈ S2)∨ (b∉ S2),
  {
    apply classical.em,
  },
  split;intro A1,
  {
    simp at A1,
    cases A1,
    {
      cases B2,
      {
        right,left,
        apply and.intro A1 B2,
      },
      {
        left,
        apply and.intro A1 B2,
      },
    },
    {
      right,
      cases B1,
      {
        left,
        apply and.intro B1 A1,
      },
      {
        right,
        apply and.intro B1 A1,
      },
    },
  },
  {
    simp,
    cases A1,
    {
      left,
      apply A1.left,
    },
    cases A1,
    {
      left,
      apply A1.left,
    },
    {
      right,
      apply A1.right,
    },
  },
end

/-
  There are theorems about disjoint properties, but not about disjoint sets.
  It would be good to figure out a long-term strategy of dealing with
  disjointedness, as it is pervasive through measure theory and probability
  theory. Disjoint is defined on lattices, and sets are basically the canonical
  complete lattice. However, the relationship between complementary sets and
  disjointedness is lost, as complementarity doesn't exist in a generic complete
  lattice.

  SIDE NOTE: lattice.lean now has a ton of theorems. Follow set.disjoint_compl_right
 -/
--Replace with disjoint.symm

lemma set.disjoint.symm {α:Type*} {A B:set α}:disjoint A B → disjoint B A :=
begin
  apply @disjoint.symm (set α) _,
end

--Unused, but there are parallels in mathlib for finset and list.
--Too trivial now.
lemma set.disjoint_comm {α:Type*} {A B:set α}:disjoint A B ↔ disjoint B A :=
begin
  apply @disjoint.comm (set α) _,
end

lemma set.disjoint_compl_right {α:Type*} (B:set α):disjoint B Bᶜ :=
begin
  rw disjoint_iff,
  simp,
end

lemma set.disjoint_inter_compl {α:Type*} (A B C:set α):disjoint (A ∩ B) (C∩ Bᶜ) :=
begin
  apply set.disjoint_of_subset_left (set.inter_subset_right A B),
  apply set.disjoint_of_subset_right (set.inter_subset_right C Bᶜ),
  simp [disjoint_iff],
end

--In general, disjoint A C → disjoint (A ⊓ B) C
lemma set.disjoint_inter_left {α:Type*} {A B C:set α}:
  disjoint A C →
  disjoint (A ∩ B) (C) :=
begin
  intros A1,
  apply set.disjoint_of_subset_left _ A1,
  apply set.inter_subset_left,
end

--In general, disjoint A C → disjoint A (B ⊓ C)
lemma set.disjoint_inter_right {α:Type*} {A B C:set α}:
  disjoint A C →
  disjoint A (B ∩ C) :=
begin
  intros A1,
  apply set.disjoint_of_subset_right _ A1,
  apply set.inter_subset_right,
end

/-
  The connection between Union and supremum comes in
  useful in measure theory. The next three theorems
  do this directly.
 -/
lemma set.le_Union {α:Type*} {f:ℕ → set α} {n:ℕ}:
    f n ≤ set.Union f :=
begin
  rw set.le_eq_subset,
  rw set.subset_def,
  intros a A3,
  simp,
  apply exists.intro n A3,
end

lemma set.Union_le {α:Type*} {f:ℕ → set α} {S:set α}:
    (∀ i, f i ≤ S) →
    set.Union f ≤ S :=
begin
  intro A1,
  rw set.le_eq_subset,
  rw set.subset_def,
  intros x A2,
  simp at A2,
  cases A2 with n A2,
  apply A1 n A2,
end

lemma supr_eq_Union {α:Type*}
    {f:ℕ → set α}:
    supr f = set.Union f :=
begin
  apply le_antisymm,
  {
    apply @supr_le (set α) _ _,
    intro i,
    apply set.le_Union,
  },
  {
    apply set.Union_le,
    intros n,
    apply @le_supr (set α) _ _,
  },
end

lemma empty_of_subset_empty {α:Type*} (X:set α):
    X ⊆ ∅ → X = ∅ :=
begin
  have A1:(∅:set α) = ⊥ := rfl,
  rw A1,
  rw ← set.le_eq_subset,
  intro A2,
  rw le_bot_iff at A2,
  apply A2,
end

lemma subset_empty_iff {α:Type*} (X:set α):
    X ⊆ ∅ ↔ X = ∅ :=
begin
  have A1:(∅:set α) = ⊥ := rfl,
  rw A1,
  rw ← set.le_eq_subset,
  apply le_bot_iff,
end

lemma set.eq_univ_iff_univ_subset {α:Type*} {S:set α}:
  set.univ ⊆ S ↔ S = set.univ :=
begin
  have A1:@set.univ α = ⊤ := rfl,
  rw A1,
  rw ← set.le_eq_subset,
  apply top_le_iff,
end

lemma preimage_if {α β:Type*}
  {E:set α} {D:decidable_pred E}
  {X Y:α → β} {S:set β}:
  set.preimage (λ a:α, if (E a) then (X a) else (Y a)) S =
  (E ∩ set.preimage X S) ∪ (Eᶜ ∩ set.preimage Y S) :=
begin
  ext a;split;intros A1,
  {
    cases (classical.em (a∈ E)) with A2 A2,
    {
      rw set.mem_preimage at A1,
      rw if_pos at A1,
      apply set.mem_union_left,
      apply set.mem_inter A2,
      rw set.mem_preimage,
      apply A1,
      rw set.mem_def at A2,
      apply A2,
    },
    {
      rw set.mem_preimage at A1,
      rw if_neg at A1,
      apply set.mem_union_right,
      apply set.mem_inter,
      apply set.mem_compl,
      apply A2,
      rw set.mem_preimage,
      apply A1,
      rw set.mem_def at A2,
      apply A2,
    },
  },
  {
    rw set.mem_preimage,
    rw set.mem_union at A1,
    cases A1 with A1 A1;
    rw set.mem_inter_eq at A1;
    cases A1 with A2 A3;
    rw set.mem_preimage at A3;
    rw set.mem_def at A2,
    {
      rw if_pos,
      apply A3,
      apply A2,
    },
    {
      rw if_neg,
      apply A3,
      apply A2,
    },
  },
end

lemma set.insert_inter_of_not_mem {α:Type*} {A B:set α} {x:α}:(x∉ B) → ((insert x A) ∩ B = A ∩ B) :=
begin
  intros A1,
  ext a,
  split;intros A2;simp at A2;simp,
  {
    cases A2 with A2 A3,
    cases A2 with A2 A4,
    {
      subst A2,
      exfalso,
      apply A1 A3,
    },
    {
      apply and.intro A4 A3,
    },
  },
  {
    apply and.intro (or.inr A2.left) A2.right,
  },
end

lemma set.inter_insert_of_not_mem {α:Type*} {A B:set α} {x:α}:(x∉ A) → (A ∩ (insert x B) = A ∩ B) :=
begin
  intros A1,
  rw set.inter_comm,
  rw set.insert_inter_of_not_mem A1,
  rw set.inter_comm,
end

lemma set.not_mem_of_inter_insert {α:Type*} {A B:set α} {x:α}:(x∉ A) → (A ∩ (insert x B) = A ∩ B) :=
begin
  intros A1,
  rw set.inter_comm,
  rw set.insert_inter_of_not_mem A1,
  rw set.inter_comm,
end

lemma set.inter_insert_of_mem {α:Type*} {A B:set α} {x:α}:(x∈ A) → (A ∩ (insert x B) = insert x (A ∩ B)) :=
begin
  intros A1,
  rw set.insert_inter,
  rw set.insert_eq_of_mem A1,
end

lemma set.mem_of_inter_insert {α:Type*} {A B C:set α} {x:α}:
  (A ∩ (insert x B) = insert x (C)) → (x ∈ A) :=
begin
  intros A1,
  have B1 := set.mem_insert x (C),
  rw ← A1 at B1,
  simp at B1,
  apply B1,
end

lemma set.eq_of_insert_of_not_mem {α:Type*} {A B:set α} {x:α}:(x∉ A) → (x∉ B) → (insert x A  = insert x B)
  → A = B :=
begin
  intros A1 A3 A2,
  ext a;split;intros B1;have C1 := set.mem_insert_of_mem x B1,
  {
    rw A2 at C1,
    apply set.mem_of_mem_insert_of_ne C1,
    intros C2,
    subst a,
    apply A1 B1,
  },
  {
    rw ← A2 at C1,
    apply set.mem_of_mem_insert_of_ne C1,
    intros C2,
    subst a,
    apply A3 B1,
  },
end

lemma directed_superset_of_monotone_dual {α:Type*} {f:ℕ → set α}:
  (@monotone ℕ (set α) _ (order_dual.preorder (set α)) f) → (directed superset f)
 := begin
  intros h_mono,
  intros i j,
  cases (le_total i j) with h_i_le_j h_j_le_i,
  { apply exists.intro j,
    split,
    apply h_mono,
    apply h_i_le_j,
    apply set.subset.refl },
  { apply exists.intro i,
    split,
    apply set.subset.refl,
    apply h_mono,
    apply h_j_le_i },
end

lemma monotone_of_monotone_nat_dual_iff {α:Type*} {f:ℕ → set α}:
  (@monotone ℕ (set α) _ (order_dual.preorder (set α)) f) ↔ (∀ (n:ℕ), f (n.succ) ⊆ f n) := begin
  split,
  { intros h_mono,
    intros n,
    apply h_mono,
    apply le_of_lt (nat.lt_succ_self _) },
  { intros h_mono_nat,
    apply @monotone_of_monotone_nat (set α) (order_dual.preorder (set α)),
    intros n,
    apply h_mono_nat },
end

lemma directed_superset_of_monotone_nat_dual {α:Type*} {f:ℕ → set α}:
  (∀ (n:ℕ), f (n.succ) ⊆ f n) → (directed superset f) := begin
  rw ← monotone_of_monotone_nat_dual_iff,
  apply directed_superset_of_monotone_dual,
end

/- Note: monotone is a stronger property than directed.
   e.g., directed can be increasing or decreasing, or
   have a single maximal element in the middle. -/
lemma directed_subset_of_monotone {α:Type*} {f:ℕ → set α}:
  monotone f → (directed set.subset f) := begin
  intros h_mono,
  intros i j,
  cases  (le_total i j),
  { apply exists.intro j,
    split,
    apply h_mono h,
    apply set.subset.refl },
  { apply exists.intro i,
    split,
    apply set.subset.refl,
    apply h_mono h },
end


/-
Copyright (c) 2018 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl
-/
import data.multiset.nodup

/-!
# The cartesian product of multisets
-/

namespace multiset

section pi
variables {α : Type*}
open function

/-- Given `δ : α → Type*`, `pi.empty δ` is the trivial dependent function out of the empty
multiset. -/
def pi.empty (δ : α → Type*) : (Πa∈(0:multiset α), δ a) .

variables [decidable_eq α] {δ : α → Type*}

/-- Given `δ : α → Type*`, a multiset `m` and a term `a`, as well as a term `b : δ a` and a
function `f` such that `f a' : δ a'` for all `a'` in `m`, `pi.cons m a b f` is a function `g` such
that `g a'' : δ a''` for all `a''` in `a ::ₘ m`. -/
def pi.cons (m : multiset α) (a : α) (b : δ a) (f : Πa∈m, δ a) : Πa'∈a ::ₘ m, δ a' :=
λa' ha', if h : a' = a then eq.rec b h.symm else f a' $ (mem_cons.1 ha').resolve_left h

lemma pi.cons_same {m : multiset α} {a : α} {b : δ a} {f : Πa∈m, δ a} (h : a ∈ a ::ₘ m) :
  pi.cons m a b f a h = b :=
dif_pos rfl

lemma pi.cons_ne {m : multiset α} {a a' : α} {b : δ a} {f : Πa∈m, δ a}
  (h' : a' ∈ a ::ₘ m) (h : a' ≠ a) :
  pi.cons m a b f a' h' = f a' ((mem_cons.1 h').resolve_left h) :=
dif_neg h

lemma pi.cons_swap {a a' : α} {b : δ a} {b' : δ a'} {m : multiset α} {f : Πa∈m, δ a} (h : a ≠ a') :
  pi.cons (a' ::ₘ m) a b (pi.cons m a' b' f) == pi.cons (a ::ₘ m) a' b' (pi.cons m a b f) :=
begin
  apply hfunext rfl,
  rintro a'' _ rfl,
  refine hfunext (by rw [cons_swap]) (λ ha₁ ha₂ _, _),
  rcases ne_or_eq a'' a with h₁ | rfl,
  rcases eq_or_ne a'' a' with rfl | h₂,
  all_goals { simp [*, pi.cons_same, pi.cons_ne] },
end

/-- `pi m t` constructs the Cartesian product over `t` indexed by `m`. -/
def pi (m : multiset α) (t : Πa, multiset (δ a)) : multiset (Πa∈m, δ a) :=
m.rec_on {pi.empty δ} (λa m (p : multiset (Πa∈m, δ a)), (t a).bind $ λb, p.map $ pi.cons m a b)
begin
  intros a a' m n,
  by_cases eq : a = a',
  { subst eq },
  { simp [map_bind, bind_bind (t a') (t a)],
    apply bind_hcongr, { rw [cons_swap a a'] },
    intros b hb,
    apply bind_hcongr, { rw [cons_swap a a'] },
    intros b' hb',
    apply map_hcongr, { rw [cons_swap a a'] },
    intros f hf,
    exact pi.cons_swap eq }
end

@[simp] lemma pi_zero (t : Πa, multiset (δ a)) : pi 0 t = {pi.empty δ} := rfl

@[simp] lemma pi_cons (m : multiset α) (t : Πa, multiset (δ a)) (a : α) :
  pi (a ::ₘ m) t = ((t a).bind $ λb, (pi m t).map $ pi.cons m a b) :=
rec_on_cons a m

lemma pi_cons_injective {a : α} {b : δ a} {s : multiset α} (hs : a ∉ s) :
  function.injective (pi.cons s a b) :=
assume f₁ f₂ eq, funext $ assume a', funext $ assume h',
have ne : a ≠ a', from assume h, hs $ h.symm ▸ h',
have a' ∈ a ::ₘ s, from mem_cons_of_mem h',
calc f₁ a' h' = pi.cons s a b f₁ a' this : by rw [pi.cons_ne this ne.symm]
  ... = pi.cons s a b f₂ a' this : by rw [eq]
  ... = f₂ a' h' : by rw [pi.cons_ne this ne.symm]

lemma card_pi (m : multiset α) (t : Πa, multiset (δ a)) :
  card (pi m t) = prod (m.map $ λa, card (t a)) :=
multiset.induction_on m (by simp) (by simp [mul_comm] {contextual := tt})

protected lemma nodup.pi {s : multiset α} {t : Π a, multiset (δ a)} :
  nodup s → (∀a∈s, nodup (t a)) → nodup (pi s t) :=
multiset.induction_on s (assume _ _, nodup_singleton _)
begin
  assume a s ih hs ht,
  have has : a ∉ s, by simp at hs; exact hs.1,
  have hs : nodup s, by simp at hs; exact hs.2,
  simp,
  refine ⟨λ b hb, (ih hs $ λ a' h', ht a' $ mem_cons_of_mem h').map (pi_cons_injective has), _⟩,
  refine (ht a $ mem_cons_self _ _).pairwise _,
  from assume b₁ hb₁ b₂ hb₂ neb, disjoint_map_map.2 (assume f hf g hg eq,
    have pi.cons s a b₁ f a (mem_cons_self _ _) = pi.cons s a b₂ g a (mem_cons_self _ _),
      by rw [eq],
    neb $ show b₁ = b₂, by rwa [pi.cons_same, pi.cons_same] at this)
end

@[simp]
lemma pi.cons_ext {m : multiset α} {a : α} (f : Π a' ∈ a ::ₘ m, δ a') :
  pi.cons m a (f _ (mem_cons_self _ _)) (λ a' ha', f a' (mem_cons_of_mem ha')) = f :=
begin
  ext a' h',
  by_cases a' = a,
  { subst h, rw [pi.cons_same] },
  { rw [pi.cons_ne _ h] }
end

lemma mem_pi (m : multiset α) (t : Πa, multiset (δ a)) :
  ∀f:Πa∈m, δ a, (f ∈ pi m t) ↔ (∀a (h : a ∈ m), f a h ∈ t a) :=
begin
  intro f,
  induction m using multiset.induction_on with a m ih,
  { simpa using show f = pi.empty δ, by funext a ha; exact ha.elim },
  simp_rw [pi_cons, mem_bind, mem_map, ih],
  split,
  { rintro ⟨b, hb, f', hf', rfl⟩ a' ha',
    by_cases a' = a,
    { subst h, rwa [pi.cons_same] },
    { rw [pi.cons_ne _ h], apply hf' } },
  { intro hf,
    refine ⟨_, hf a (mem_cons_self _ _), _, λ a ha, hf a (mem_cons_of_mem ha), _⟩,
    rw pi.cons_ext }
end

end pi

end multiset


/-
Copyright (c) 2020 Johan Commelin. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johan Commelin
-/
import data.fintype.order
import order.category.LinearOrder

/-!
# Nonempty finite linear orders

This defines `NonemptyFinLinOrd`, the category of nonempty finite linear orders with monotone maps.
This is the index category for simplicial objects.
-/

universes u v

open category_theory

/-- A typeclass for nonempty finite linear orders. -/
class nonempty_fin_lin_ord (α : Type*) extends fintype α, linear_order α :=
(nonempty : nonempty α . tactic.apply_instance)

attribute [instance] nonempty_fin_lin_ord.nonempty

@[priority 100]
instance nonempty_fin_lin_ord.to_bounded_order (α : Type*) [nonempty_fin_lin_ord α] :
  bounded_order α :=
fintype.to_bounded_order α

instance punit.nonempty_fin_lin_ord : nonempty_fin_lin_ord punit :=
{ .. punit.linear_ordered_cancel_add_comm_monoid,
  .. punit.fintype }

instance fin.nonempty_fin_lin_ord (n : ℕ) : nonempty_fin_lin_ord (fin (n+1)) :=
{ .. fin.fintype _,
  .. fin.linear_order }

instance ulift.nonempty_fin_lin_ord (α : Type u) [nonempty_fin_lin_ord α] :
  nonempty_fin_lin_ord (ulift.{v} α) :=
{ nonempty := ⟨ulift.up ⊥⟩,
  .. linear_order.lift equiv.ulift (equiv.injective _),
  .. ulift.fintype _ }

instance (α : Type*) [nonempty_fin_lin_ord α] : nonempty_fin_lin_ord (order_dual α) :=
{ ..order_dual.fintype α }

/-- The category of nonempty finite linear orders. -/
def NonemptyFinLinOrd := bundled nonempty_fin_lin_ord

namespace NonemptyFinLinOrd

instance : bundled_hom.parent_projection @nonempty_fin_lin_ord.to_linear_order := ⟨⟩

attribute [derive [large_category, concrete_category]] NonemptyFinLinOrd

instance : has_coe_to_sort NonemptyFinLinOrd Type* := bundled.has_coe_to_sort

/-- Construct a bundled `NonemptyFinLinOrd` from the underlying type and typeclass. -/
def of (α : Type*) [nonempty_fin_lin_ord α] : NonemptyFinLinOrd := bundled.of α

@[simp] lemma coe_of (α : Type*) [nonempty_fin_lin_ord α] : ↥(of α) = α := rfl

instance : inhabited NonemptyFinLinOrd := ⟨of punit⟩

instance (α : NonemptyFinLinOrd) : nonempty_fin_lin_ord α := α.str

instance has_forget_to_LinearOrder : has_forget₂ NonemptyFinLinOrd LinearOrder :=
bundled_hom.forget₂ _ _

/-- Constructs an equivalence between nonempty finite linear orders from an order isomorphism
between them. -/
@[simps] def iso.mk {α β : NonemptyFinLinOrd.{u}} (e : α ≃o β) : α ≅ β :=
{ hom := e,
  inv := e.symm,
  hom_inv_id' := by { ext, exact e.symm_apply_apply x },
  inv_hom_id' := by { ext, exact e.apply_symm_apply x } }

/-- `order_dual` as a functor. -/
@[simps] def dual : NonemptyFinLinOrd ⥤ NonemptyFinLinOrd :=
{ obj := λ X, of (order_dual X), map := λ X Y, order_hom.dual }

/-- The equivalence between `FinPartialOrder` and itself induced by `order_dual` both ways. -/
@[simps functor inverse] def dual_equiv : NonemptyFinLinOrd ≌ NonemptyFinLinOrd :=
equivalence.mk dual dual
  (nat_iso.of_components (λ X, iso.mk $ order_iso.dual_dual X) $ λ X Y f, rfl)
  (nat_iso.of_components (λ X, iso.mk $ order_iso.dual_dual X) $ λ X Y f, rfl)

end NonemptyFinLinOrd

lemma NonemptyFinLinOrd_dual_comp_forget_to_LinearOrder :
  NonemptyFinLinOrd.dual ⋙ forget₂ NonemptyFinLinOrd LinearOrder =
    forget₂ NonemptyFinLinOrd LinearOrder ⋙ LinearOrder.dual := rfl


/-
Copyright (c) 2021 Yaël Dillies, Bhavik Mehta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yaël Dillies, Bhavik Mehta
-/
import .mathlib

/-!
# Constructions of `finpartition`
-/

open finpartition finset

variables {α : Type*}

section
variables [decidable_eq α] {s : finset α}

lemma equitabilise_aux1' {m a b : ℕ} (hs : a*m + b*(m+1) = s.card) (A : finpartition s)
  (h : s = ∅) :
  ∃ (P : finpartition s),
    (∀ (x : finset α), x ∈ P.parts → x.card = m ∨ x.card = m + 1) ∧
    (∀ x, x ∈ A.parts → (x \ finset.bUnion (P.parts.filter (λ y, y ⊆ x)) id).card ≤ m) ∧
    ((P.parts.filter (λ i, finset.card i = m+1)).card = b) :=
begin
  subst h,
  rw unique.eq_default A,
  refine ⟨finpartition.empty _, by simp, by simp, _⟩,
  simp only [finset.card_empty, nat.mul_eq_zero, nat.succ_ne_zero, or_false,
    add_eq_zero_iff, and_false] at hs,
  simp [hs.2.symm],
end

lemma equitabilise_aux2' {m a b : ℕ} (hs : a*m + b*(m+1) = s.card) (A : finset (finset α))
  (subs : ∀ i ∈ A, i ⊆ s) (h : m = 0) :
  ∃ (P : finpartition s),
    (∀ (x : finset α), x ∈ P.parts → x.card = m ∨ x.card = m+1) ∧
    (∀ x, x ∈ A → (x \ finset.bUnion (P.parts.filter (λ y, y ⊆ x)) id).card ≤ m) ∧
    ((P.parts.filter (λ i, finset.card i = m+1)).card = b) :=
begin
  subst h,
  simp only [mul_one, zero_add, mul_zero] at hs,
  simp only [exists_prop, finset.card_eq_zero, zero_add, le_zero_iff, sdiff_eq_empty_iff_subset],
  refine ⟨⊥, by simp, λ x hx i hi, _, _⟩,
  { simp only [mem_bUnion, exists_prop, mem_filter, id.def, and_assoc],
    exact ⟨{i}, mem_map_of_mem _ (subs x hx hi), by simpa, by simp⟩ },
  { rw [filter_true_of_mem, card_bot, hs],
    simp }
end

lemma equitabilise_aux' {m a b : ℕ} (hs : a*m + b*(m+1) = s.card) (A : finpartition s) :
  ∃ (P : finpartition s),
    (∀ (x : finset α), x ∈ P.parts → x.card = m ∨ x.card = m + 1) ∧
    (∀ x, x ∈ A.parts → (x \ finset.bUnion (P.parts.filter (λ y, y ⊆ x)) id).card ≤ m) ∧
    ((P.parts.filter (λ i, finset.card i = m+1)).card = b) :=
begin
  induction s using finset.strong_induction with s ih generalizing A a b,
  cases s.eq_empty_or_nonempty with h hs_ne,
  { apply equitabilise_aux1' hs _ h },
  cases m.eq_zero_or_pos with h m_pos,
  { apply equitabilise_aux2' hs _ (λ i hi, A.le hi) h },
  have : 0 < a ∨ 0 < b,
  { by_contra,
    push_neg at h,
    simp only [le_zero_iff] at h,
    rw [h.1, h.2] at hs,
    simp only [add_zero, zero_mul, eq_comm, finset.card_eq_zero] at hs,
    exact hs_ne.ne_empty hs },
  set p'_size := if 0 < a then m else m+1 with h',
  have : 0 < p'_size,
  { rw h',
    split_ifs,
    { apply m_pos },
    exact nat.succ_pos' },
  by_cases ∃ p ∈ A.parts, m+1 ≤ finset.card p,
  { rcases h with ⟨p, hp₁, hp₂⟩,
    have : p'_size ≤ p.card,
    { apply le_trans _ hp₂,
      rw h',
      split_ifs,
      { apply nat.le_succ },
      refl },
    obtain ⟨p', hp'₁, hp'₂⟩ := exists_smaller_set _ _ this,
    have hcard : ite (0 < a) (a - 1) a * m + ite (0 < a) b (b - 1) * (m + 1) = (s \ p').card,
    { rw [card_sdiff (hp'₁.trans (A.le hp₁)), ←hs, hp'₂, h'],
      split_ifs,
      { rw [nat.mul_sub_right_distrib, one_mul, tsub_add_eq_add_tsub (nat.le_mul_of_pos_left h)] },
      { rw [nat.mul_sub_right_distrib, one_mul, ←nat.add_sub_assoc],
        apply nat.le_mul_of_pos_left (‹0 < a ∨ 0 < b›.resolve_left h) } },
    have : p'.nonempty,
    { rwa [←card_pos, hp'₂] },
    obtain ⟨P', hP'₁, hP'₂, hP'₃⟩ :=
      @ih (s \ p') (sdiff_ssubset (hp'₁.trans (A.le hp₁)) this)
        (A.avoid p')
        (if 0 < a then a-1 else a)
        (if 0 < a then b else b-1)
        hcard,
    refine ⟨P'.extend this.ne_empty sdiff_disjoint (sdiff_sup_cancel $ hp'₁.trans $ A.le hp₁),
      _,  _, _⟩,
    { simp only [mem_insert, forall_eq_or_imp, extend_parts, and_iff_left hP'₁, hp'₂, h'],
      apply ite_eq_or_eq },
    { conv in (_ ∈ _) {rw ←finset.insert_erase hp₁},
      simp only [and_imp, mem_insert, forall_eq_or_imp, ne.def, extend_parts],
      split,
      { simp only [filter_insert, if_pos hp'₁, bUnion_insert, mem_erase, id.def],
        rcases eq_or_ne p p',
        { cases h.symm,
          rw sdiff_eq_empty_iff_subset.2,
          { simp },
          apply subset_union_left },
        apply le_trans (card_le_of_subset _) (hP'₂ (p \ p') _),
        { intros i,
          simp only [not_exists, mem_bUnion, and_imp, mem_union, mem_filter, mem_sdiff, id.def,
            not_or_distrib],
          intros hi₁ hi₂ hi₃,
          exact ⟨⟨hi₁, hi₂⟩, λ x hx hx', hi₃ _ hx (finset.subset.trans hx' (sdiff_subset _ _))⟩ },
        { simp only [avoid, sdiff_eq_empty_iff_subset, mem_image, exists_prop, of_erase, mem_erase,
            bot_eq_empty, ne.def],
          exact ⟨λ i, h (i.antisymm hp'₁), _, hp₁, rfl⟩ }},
      intros x hx,
      apply (card_le_of_subset _).trans (hP'₂ x _),
      { apply sdiff_subset_sdiff (finset.subset.refl _) (bUnion_subset_bUnion_of_subset_left _ _),
        refine filter_subset_filter _ (subset_insert _ _) },
      { simp only [avoid, of_erase, mem_erase, mem_image, bot_eq_empty],
        refine ⟨(nonempty_of_mem_parts _ (mem_of_mem_erase hx)).ne_empty, _,
          mem_of_mem_erase hx, _⟩,
        rw finset.sdiff_eq_self_iff_disjoint,
        refine disjoint.mono_right hp'₁ _,
        apply A.disjoint (mem_of_mem_erase hx) hp₁ (ne_of_mem_erase hx) } },
    simp only [extend_parts, filter_insert, hp'₂, h', nat.one_ne_zero, ite_eq_right_iff,
      self_eq_add_right],
    split_ifs,
    { rw [card_insert_of_not_mem, hP'₃, if_neg h, nat.sub_add_cancel],
      apply ‹0 < a ∨ 0 < b›.resolve_left h,
      simp only [mem_filter, hp'₂, h', if_neg h, eq_self_iff_true, and_true],
      intro t,
      obtain ⟨i, hi⟩ := ‹p'.nonempty›,
      apply (mem_sdiff.1 (P'.le t hi)).2 hi },
    { rw [hP'₃, if_pos],
      simpa using h } },
  push_neg at h,
  have : p'_size ≤ s.card,
  { rw [←hs, h'],
    split_ifs,
    { apply le_add_right (nat.le_mul_of_pos_left ‹0 < a›) },
    exact le_add_left (nat.le_mul_of_pos_left (‹0 < a ∨ 0 < b›.resolve_left ‹¬0 < a›)) },
  obtain ⟨s', hs'₁, hs'₂⟩ := exists_smaller_set _ _ this,
  have hs' : s'.nonempty,
  { rwa [←card_pos, hs'₂] },
  have : ite (0 < a) (a - 1) a * m + ite (0 < a) b (b - 1) * (m + 1) = (s \ s').card,
  { rw [card_sdiff ‹s' ⊆ s›, hs'₂, h', ←hs],
    split_ifs,
    { rw [nat.mul_sub_right_distrib, one_mul,
        tsub_add_eq_add_tsub (nat.le_mul_of_pos_left ‹0 < a›)] },
    rw [nat.mul_sub_right_distrib, one_mul, ←nat.add_sub_assoc],
    exact nat.le_mul_of_pos_left (‹0 < a ∨ 0 < b›.resolve_left ‹¬0 < a›) },
  obtain ⟨P', hP'₁, hP'₂, hP'₃⟩ := @ih (s \ s') (sdiff_ssubset hs'₁ ‹s'.nonempty›) (A.avoid s')
    (if 0 < a then a-1 else a)
    (if 0 < a then b else b-1)
    this,
  refine ⟨P'.extend hs'.ne_empty sdiff_disjoint (sdiff_sup_cancel hs'₁), _, _, _⟩,
  { simp only [extend_parts, mem_insert, forall_eq_or_imp, and_iff_left hP'₁, hs'₂, h'],
    apply ite_eq_or_eq },
  { intros x hx,
    refine le_trans (card_le_of_subset (sdiff_subset _ _)) _,
    rw ←nat.lt_succ_iff,
    exact h _ hx },
  rw [extend_parts, filter_insert, hs'₂, h'],
  simp only [nat.one_ne_zero, ite_eq_right_iff, self_eq_add_right],
  split_ifs,
  { rw [card_insert_of_not_mem, hP'₃, if_neg h_1, nat.sub_add_cancel],
    { apply ‹0 < a ∨ 0 < b›.resolve_left h_1 },
    simp only [mem_filter, hs'₂, h', if_neg h_1, eq_self_iff_true, and_true],
    intro t,
    obtain ⟨i, hi⟩ := ‹s'.nonempty›,
    exact (mem_sdiff.1 (P'.le t hi)).2 hi },
  { rw [hP'₃, if_pos],
    simpa using h_1 }
end

/-! ### Equitabilise -/

namespace finpartition

/-- Given a partition `Q` of `s`, as well as a proof that `a*m + b*(m+1) = s.card`, build a new
partition `P` of `s` where each part has size `m` or `m+1`, every part of `Q` is the union of
parts of `P` plus at most `m` extra elements, there are `b` parts of size `m+1` and provided
`m > 0`, there are `a` parts of size `m` and hence `a+b` parts in total.
The `m > 0` condition is required since there may be zero or one parts of size `0`, while `a` could
be arbitrary. -/
noncomputable def equitabilise (Q : finpartition s) {m a b : ℕ} (h : a * m + b * (m + 1) = s.card) :
  finpartition s :=
(equitabilise_aux' h Q).some

lemma card_eq_of_mem_parts_equitabilise {Q : finpartition s} {m a b : ℕ}
  (h : a*m + b*(m+1) = s.card) {u : finset α} (hu : u ∈ (Q.equitabilise h).parts) :
  u.card = m ∨ u.card = m + 1 :=
(equitabilise_aux' h Q).some_spec.1 _ hu

lemma equitabilise.is_equipartition (Q : finpartition s) {m a b : ℕ}
  (h : a*m + b*(m+1) = s.card) :
  (Q.equitabilise h).is_equipartition :=
set.equitable_on_iff_exists_eq_eq_add_one.2 ⟨m, λ u hu, card_eq_of_mem_parts_equitabilise h hu⟩

lemma card_filter_equitabilise_big (Q : finpartition s) {m a b : ℕ}
  (h : a*m + b*(m+1) = s.card) :
  ((Q.equitabilise h).parts.filter (λ u : finset α, u.card = m + 1)).card = b :=
(equitabilise_aux' h Q).some_spec.2.2

lemma card_filter_equitabilise_small (Q : finpartition s) {m a b : ℕ} (hm : 0 < m)
  (h : a*m + b*(m+1) = s.card) :
  ((Q.equitabilise h).parts.filter (λ u : finset α, u.card = m)).card = a :=
begin
  refine (mul_eq_mul_right_iff.1 ((add_left_inj (b * (m + 1))).1 _)).resolve_right hm.ne',
  rw [h, ←(Q.equitabilise h).sum_card_parts],
  have hunion : (Q.equitabilise h).parts = (Q.equitabilise h).parts.filter (λ u, u.card = m) ∪
    (Q.equitabilise h).parts.filter (λ u, u.card = m + 1),
  { rw [←filter_or, filter_true_of_mem],
    exact λ x hx, card_eq_of_mem_parts_equitabilise h hx },
  nth_rewrite 1 hunion,
  rw [sum_union, sum_const_nat (λ x hx, (mem_filter.1 hx).2),
    sum_const_nat (λ x hx, (mem_filter.1 hx).2), Q.card_filter_equitabilise_big],
  refine λ x hx, nat.succ_ne_self m _,
  rw [inf_eq_inter, mem_inter, mem_filter, mem_filter] at hx,
  rw [nat.succ_eq_add_one, ←hx.2.2, hx.1.2],
end

lemma equitabilise.parts_card {Q : finpartition s} {m a b : ℕ} (hm : 0 < m)
  (h : a * m + b * (m + 1) = s.card) :
  (Q.equitabilise h).parts.card = a + b :=
begin
  have hunion : (Q.equitabilise h).parts = (Q.equitabilise h).parts.filter (λ u, u.card = m) ∪
    (Q.equitabilise h).parts.filter (λ u, u.card = m + 1),
  { rw [←filter_or, filter_true_of_mem],
    exact λ x hx, card_eq_of_mem_parts_equitabilise h hx },
  rw [hunion, card_union_eq, Q.card_filter_equitabilise_small hm, Q.card_filter_equitabilise_big],
  refine λ x hx, nat.succ_ne_self m _,
  rw [inf_eq_inter, mem_inter, mem_filter, mem_filter] at hx,
  rw [nat.succ_eq_add_one, ←hx.2.2, hx.1.2],
end

lemma almost_in_atoms_of_mem_parts_equitabilise {Q : finpartition s} {m a b : ℕ}
  (h : a * m + b * (m + 1) = s.card) {u : finset α} (hu : u ∈ Q.parts) :
  (u \ ((Q.equitabilise h).parts.filter $ λ x, x ⊆ u).bUnion id).card ≤ m :=
begin
  refine (card_le_of_subset _).trans ((classical.some_spec (equitabilise_aux' h Q)).2.1 u hu),
  intros x,
  simp only [not_exists, mem_bUnion, and_imp, mem_filter, mem_sdiff, id.def, ne.def],
  refine λ hxu hx, ⟨hxu, λ a ha hau, _⟩,
  obtain rfl | hanemp := eq_or_ne a ∅,
  { exact not_mem_empty _ },
  { apply hx _ ha hau },
end

end finpartition

end

/-! ### Atomise -/

open finpartition

section atomise
variables [decidable_eq α] {s : finset α}

lemma union_of_atoms_aux {s : finset α} {Q : finset (finset α)} {A : finset α}
  (hA : A ∈ Q) (hs : A ⊆ s) (i : α) :
  (∃ (B ∈ (atomise s Q).parts), B ⊆ A ∧ i ∈ B) ↔ i ∈ A :=
begin
  split,
  { rintro ⟨B, hB₁, hB₂, hB₃⟩,
    exact hB₂ hB₃ },
  intro hi,
  obtain ⟨B, hB₁, hB₂⟩ := (atomise s Q).exists_mem (hs hi),
  refine ⟨B, hB₁, λ j hj, _, hB₂⟩,
  obtain ⟨P, hP, rfl⟩ := (mem_atomise.1 hB₁).2,
  simp only [mem_filter] at hB₂ hj,
  rwa [←hj.2 _ hA, hB₂.2 _ hA]
end

open_locale classical

lemma union_of_atoms' {s : finset α} {Q : finset (finset α)} (A : finset α)
  (hx : A ∈ Q) (hs : A ⊆ s) :
  ((atomise s Q).parts.filter (λ B, B ⊆ A ∧ B.nonempty)).bUnion id = A :=
begin
  ext x,
  simp only [mem_bUnion, exists_prop, mem_filter, id.def, and_assoc],
  rw ←union_of_atoms_aux hx hs,
  simp only [exists_prop, finset.nonempty],
  tauto,
end

lemma partial_atomise {s : finset α} {Q : finset (finset α)} (A : finset α) (hA : A ∈ Q) :
  ((atomise s Q).parts.filter (λ B, B ⊆ A ∧ B.nonempty)).card ≤ 2^(Q.card - 1) :=
begin
  suffices h :
    (atomise s Q).parts.filter (λ B, B ⊆ A ∧ B.nonempty) ⊆
      (Q.erase A).powerset.image (λ P, s.filter (λ i, ∀ x ∈ Q, x ∈ insert A P ↔ i ∈ x)),
  { apply (card_le_of_subset h).trans (card_image_le.trans _),
    rw [card_powerset, card_erase_of_mem hA, nat.pred_eq_sub_one] },
  rw subset_iff,
  simp only [mem_erase, mem_sdiff, mem_powerset, mem_image, exists_prop, mem_filter, and_assoc,
    finset.nonempty, exists_imp_distrib, and_imp, mem_atomise, forall_apply_eq_imp_iff₂],
  rintro P' i hi P PQ rfl hy₂ j hj,
  refine ⟨P.erase A, erase_subset_erase _ PQ, _⟩,
  have : A ∈ P,
  { rw mem_filter at hi,
    rw hi.2 _ hA,
    apply hy₂ (mem_filter.2 hi) },
  simp only [insert_erase this, filter_congr_decidable],
end

end atomise

/-! ### Dummy -/

/-- Arbitrary equipartition into `t` parts -/
lemma dummy_equipartition [decidable_eq α] (s : finset α) {t : ℕ} (ht : 0 < t) (hs : t ≤ s.card) :
  ∃ (P : finpartition s), P.is_equipartition ∧ P.parts.card = t :=
begin
  have : (t - s.card % t) * (s.card / t) + (s.card % t) * (s.card / t + 1) = s.card,
  { rw [nat.mul_sub_right_distrib, mul_add, ←add_assoc, nat.sub_add_cancel, mul_one, add_comm,
      nat.mod_add_div],
    exact nat.mul_le_mul_right _ ((nat.mod_lt _ ht).le) },
  refine ⟨(finpartition.indiscrete (finset.card_pos.1 $ ht.trans_le hs).ne_empty).equitabilise this,
    equitabilise.is_equipartition _ _, _⟩,
  rw [equitabilise.parts_card (nat.div_pos hs ht), nat.sub_add_cancel (nat.mod_lt _ ht).le],
end