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

/-!
# `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
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 v 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 i => h₂ h₁
| Literal.neg i => 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
| [], n => False
| a::as, 0 => a
| 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 i 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 i 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.isIdent then n.getId else `_example
  Command.liftTermElabM name do
    let cnf ← unsafe (Mathlib.Eval.evalTerm String (mkConst ``String) cnf)
    let lrat ← unsafe (Mathlib.Eval.evalTerm String (mkConst ``String) lrat)
    let go := do
      fromLRAT cnf lrat name
      withSaveInfoContext do
        Term.addTermInfo n (mkConst name) (isBinder := true)
    if n.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 (Mathlib.Eval.evalTerm String (mkConst ``String) cnf)
  let lrat ← unsafe (Mathlib.Eval.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"


/-
Copyright (c) 2019 Seul Baek. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Seul Baek
-/

/-
Miscellaneous.
-/

import tactic.localized

variables {α β γ : Type}

namespace omega

lemma fun_mono_2 {p : α → β → γ} {a1 a2 : α} {b1 b2 : β} :
  a1 = a2 → b1 = b2 → (p a1 b1 = p a2 b2) :=
λ h1 h2, by rw [h1, h2]

lemma pred_mono_2' {c : Prop → Prop → Prop} {a1 a2 b1 b2 : Prop} :
  (a1 ↔ a2) → (b1 ↔ b2) → (c a1 b1 ↔ c a2 b2) :=
λ h1 h2, by rw [h1, h2]

/-- Update variable assignment for a specific variable
    and leave everything else unchanged -/
def update (m : nat) (a : α) (v : nat → α) : nat → α
| n := if n = m then a else v n

localized "notation (name := omega.update) v ` ⟨`m` ↦ `a`⟩` := omega.update m a v" in omega

lemma update_eq (m : nat) (a : α) (v : nat → α) : (v ⟨m ↦ a⟩) m = a :=
by simp only [update, if_pos rfl]

lemma update_eq_of_ne {m : nat} {a : α} {v : nat → α} (k : nat) :
  k ≠ m → update m a v k = v k :=
by {intro h1, unfold update, rw if_neg h1}

/-- Assign a new value to the zeroth variable, and push all
    other assignments up by 1 -/
def update_zero (a : α) (v : nat → α) : nat → α
| 0     := a
| (k+1) := v k

open tactic

/-- Intro with a fresh name -/
meta def intro_fresh : tactic unit :=
do n ← mk_fresh_name,
   intro n,
   skip

/-- Revert an expr if it passes the given test -/
meta def revert_cond (t : expr → tactic unit) (x : expr) : tactic unit :=
(t x >> revert x >> skip) <|> skip

/-- Revert all exprs in the context that pass the given test -/
meta def revert_cond_all (t : expr → tactic unit) : tactic unit :=
do hs ← local_context, mmap (revert_cond t) hs, skip

/-- Try applying a tactic to each of the element in a list
    until success, and return the first successful result -/
meta def app_first {α β : Type} (t : α → tactic β) : list α → tactic β
| [] := failed
| (a :: as) := t a <|> app_first as

end omega


/-
Copyright (c) 2021 Oliver Nash. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Oliver Nash
-/
import algebra.algebra.restrict_scalars
import algebra.lie.tensor_product

/-!
# Extension and restriction of scalars for Lie algebras

Lie algebras have a well-behaved theory of extension and restriction of scalars.

## Main definitions

 * `lie_algebra.extend_scalars.lie_algebra`
 * `lie_algebra.restrict_scalars.lie_algebra`

## Tags

lie ring, lie algebra, extension of scalars, restriction of scalars, base change
-/

universes u v w w₁ w₂ w₃

open_locale tensor_product

variables (R : Type u) (A : Type w) (L : Type v)

namespace lie_algebra

namespace extend_scalars

variables [comm_ring R] [comm_ring A] [algebra R A] [lie_ring L] [lie_algebra R L]

/-- The Lie bracket on the extension of a Lie algebra `L` over `R` by an algebra `A` over `R`.

In fact this bracket is fully `A`-bilinear but without a significant upgrade to our mixed-scalar
support in the tensor product library, it is far easier to bootstrap like this, starting with the
definition below. -/
private def bracket' : (A ⊗[R] L) →ₗ[R] (A ⊗[R] L) →ₗ[R] A ⊗[R] L :=
tensor_product.curry $
  (tensor_product.map (algebra.lmul' R) (lie_module.to_module_hom R L L : L ⊗[R] L →ₗ[R] L))
  ∘ₗ ↑(tensor_product.tensor_tensor_tensor_comm R A L A L)

@[simp] private lemma bracket'_tmul (s t : A) (x y : L) :
  bracket' R A L (s ⊗ₜ[R] x) (t ⊗ₜ[R] y) = (s*t) ⊗ₜ ⁅x, y⁆ :=
by simp [bracket']

instance : has_bracket (A ⊗[R] L) (A ⊗[R] L) := { bracket := λ x y, bracket' R A L x y, }

private lemma bracket_def (x y : A ⊗[R] L) : ⁅x, y⁆ = bracket' R A L x y := rfl

@[simp] lemma bracket_tmul (s t : A) (x y : L) : ⁅s ⊗ₜ[R] x, t ⊗ₜ[R] y⁆ = (s*t) ⊗ₜ ⁅x, y⁆ :=
by rw [bracket_def, bracket'_tmul]

private lemma bracket_lie_self (x : A ⊗[R] L) : ⁅x, x⁆ = 0 :=
begin
  simp only [bracket_def],
  apply x.induction_on,
  { simp only [linear_map.map_zero, eq_self_iff_true, linear_map.zero_apply], },
  { intros a l,
    simp only [bracket'_tmul, tensor_product.tmul_zero, eq_self_iff_true, lie_self], },
  { intros z₁ z₂ h₁ h₂,
    suffices : bracket' R A L z₁ z₂ + bracket' R A L z₂ z₁ = 0,
    { rw [linear_map.map_add, linear_map.map_add, linear_map.add_apply, linear_map.add_apply,
        h₁, h₂, zero_add, add_zero, add_comm, this], },
    apply z₁.induction_on,
    { simp only [linear_map.map_zero, add_zero, linear_map.zero_apply], },
    { intros a₁ l₁, apply z₂.induction_on,
      { simp only [linear_map.map_zero, add_zero, linear_map.zero_apply], },
      { intros a₂ l₂,
        simp only [← lie_skew l₂ l₁, mul_comm a₁ a₂, tensor_product.tmul_neg, bracket'_tmul,
          add_right_neg], },
      { intros y₁ y₂ hy₁ hy₂,
        simp only [hy₁, hy₂, add_add_add_comm, add_zero, linear_map.add_apply,
          linear_map.map_add], }, },
    { intros y₁ y₂ hy₁ hy₂,
      simp only [add_add_add_comm, hy₁, hy₂, add_zero, linear_map.add_apply,
        linear_map.map_add], }, },
end

private lemma bracket_leibniz_lie (x y z : A ⊗[R] L) : ⁅x, ⁅y, z⁆⁆ = ⁅⁅x, y⁆, z⁆ + ⁅y, ⁅x, z⁆⁆ :=
begin
  simp only [bracket_def],
  apply x.induction_on,
  { simp only [linear_map.map_zero, add_zero, eq_self_iff_true, linear_map.zero_apply], },
  { intros a₁ l₁,
    apply y.induction_on,
    { simp only [linear_map.map_zero, add_zero, eq_self_iff_true, linear_map.zero_apply], },
    { intros a₂ l₂,
      apply z.induction_on,
      { simp only [linear_map.map_zero, add_zero], },
      { intros a₃ l₃, simp only [bracket'_tmul],
        rw [mul_left_comm a₂ a₁ a₃, mul_assoc, leibniz_lie, tensor_product.tmul_add], },
      { intros u₁ u₂ h₁ h₂,
        simp only [add_add_add_comm, h₁, h₂, linear_map.map_add], }, },
    { intros u₁ u₂ h₁ h₂,
      simp only [add_add_add_comm, h₁, h₂, linear_map.add_apply, linear_map.map_add], }, },
  { intros u₁ u₂ h₁ h₂,
    simp only [add_add_add_comm, h₁, h₂, linear_map.add_apply, linear_map.map_add], },
end

instance : lie_ring (A ⊗[R] L) :=
{ add_lie     := λ x y z, by simp only [bracket_def, linear_map.add_apply, linear_map.map_add],
  lie_add     := λ x y z, by simp only [bracket_def, linear_map.map_add],
  lie_self    := bracket_lie_self R A L,
  leibniz_lie := bracket_leibniz_lie R A L, }

private lemma bracket_lie_smul (a : A) (x y : A ⊗[R] L) : ⁅x, a • y⁆ = a • ⁅x, y⁆ :=
begin
  apply x.induction_on,
  { simp only [zero_lie, smul_zero], },
  { intros a₁ l₁, apply y.induction_on,
    { simp only [lie_zero, smul_zero], },
    { intros a₂ l₂,
      simp only [bracket_def, bracket', tensor_product.smul_tmul', mul_left_comm a₁ a a₂,
        tensor_product.curry_apply, algebra.lmul'_apply, algebra.id.smul_eq_mul, function.comp_app,
        linear_equiv.coe_coe, linear_map.coe_comp, tensor_product.map_tmul,
        tensor_product.tensor_tensor_tensor_comm_tmul], },
    { intros z₁ z₂ h₁ h₂,
      simp only [h₁, h₂, smul_add, lie_add], }, },
  { intros z₁ z₂ h₁ h₂,
    simp only [h₁, h₂, smul_add, add_lie], },
end

instance lie_algebra : lie_algebra A (A ⊗[R] L) :=
{ lie_smul := bracket_lie_smul R A L, }

end extend_scalars

namespace restrict_scalars

open restrict_scalars

variables [h : lie_ring L]

include h

instance : lie_ring (restrict_scalars R A L) := h

variables [comm_ring A] [lie_algebra A L]

@[nolint unused_arguments]
instance lie_algebra [comm_ring R] [algebra R A] : lie_algebra R (restrict_scalars R A L) :=
{ lie_smul := λ t x y, (lie_smul _ (show L, from x) (show L, from y) : _),
  .. (by apply_instance : module R (restrict_scalars R A L)), }

end restrict_scalars

end lie_algebra


/-
Copyright (c) 2019 Minchao Wu. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Minchao Wu, Mario Carneiro
-/
import computability.halting

/-!
# Strong reducibility and degrees.

This file defines the notions of computable many-one reduction and one-one
reduction between sets, and shows that the corresponding degrees form a
semilattice.

## Notations

This file uses the local notation `⊕'` for `sum.elim` to denote the disjoint union of two degrees.

## References

* [Robert Soare, *Recursively enumerable sets and degrees*][soare1987]

## Tags

computability, reducibility, reduction
-/

universes u v w
open function

/--
`p` is many-one reducible to `q` if there is a computable function translating questions about `p`
to questions about `q`.
-/
def many_one_reducible {α β} [primcodable α] [primcodable β] (p : α → Prop) (q : β → Prop) :=
∃ f, computable f ∧ ∀ a, p a ↔ q (f a)

infix ` ≤₀ `:1000 := many_one_reducible

theorem many_one_reducible.mk {α β} [primcodable α] [primcodable β] {f : α → β} (q : β → Prop)
  (h : computable f) : (λ a, q (f a)) ≤₀ q := ⟨f, h, λ a, iff.rfl⟩

@[refl]
theorem many_one_reducible_refl {α} [primcodable α] (p : α → Prop) :
  p ≤₀ p := ⟨id, computable.id, by simp⟩

@[trans]
theorem many_one_reducible.trans {α β γ} [primcodable α] [primcodable β] [primcodable γ]
  {p : α → Prop} {q : β → Prop} {r : γ → Prop} : p ≤₀ q → q ≤₀ r → p ≤₀ r
| ⟨f, c₁, h₁⟩ ⟨g, c₂, h₂⟩ := ⟨g ∘ f, c₂.comp c₁,
  λ a, ⟨λ h, by rwa [←h₂, ←h₁], λ h, by rwa [h₁, h₂]⟩⟩

theorem reflexive_many_one_reducible {α} [primcodable α] :
  reflexive (@many_one_reducible α α _ _) :=
many_one_reducible_refl

theorem transitive_many_one_reducible {α} [primcodable α] :
  transitive (@many_one_reducible α α _ _) :=
λ p q r, many_one_reducible.trans

/--
`p` is one-one reducible to `q` if there is an injective computable function translating questions
about `p` to questions about `q`.
-/
def one_one_reducible {α β} [primcodable α] [primcodable β] (p : α → Prop) (q : β → Prop) :=
∃ f, computable f ∧ injective f ∧ ∀ a, p a ↔ q (f a)

infix ` ≤₁ `:1000 := one_one_reducible

theorem one_one_reducible.mk {α β} [primcodable α] [primcodable β] {f : α → β} (q : β → Prop)
  (h : computable f) (i : injective f) : (λ a, q (f a)) ≤₁ q := ⟨f, h, i, λ a, iff.rfl⟩

@[refl]
theorem one_one_reducible_refl {α} [primcodable α] (p : α → Prop) :
  p ≤₁ p := ⟨id, computable.id, injective_id, by simp⟩

@[trans]
theorem one_one_reducible.trans {α β γ} [primcodable α] [primcodable β] [primcodable γ]
  {p : α → Prop} {q : β → Prop} {r : γ → Prop} : p ≤₁ q → q ≤₁ r → p ≤₁ r
| ⟨f, c₁, i₁, h₁⟩ ⟨g, c₂, i₂, h₂⟩ := ⟨g ∘ f, c₂.comp c₁, i₂.comp i₁,
  λ a, ⟨λ h, by rwa [←h₂, ←h₁], λ h, by rwa [h₁, h₂]⟩⟩

theorem one_one_reducible.to_many_one {α β} [primcodable α] [primcodable β]
  {p : α → Prop} {q : β → Prop} : p ≤₁ q → p ≤₀ q
| ⟨f, c, i, h⟩ := ⟨f, c, h⟩

theorem one_one_reducible.of_equiv {α β} [primcodable α] [primcodable β]
    {e : α ≃ β} (q : β → Prop) (h : computable e) :
  (q ∘ e) ≤₁ q :=
one_one_reducible.mk _ h e.injective

theorem one_one_reducible.of_equiv_symm {α β} [primcodable α] [primcodable β]
    {e : α ≃ β} (q : β → Prop) (h : computable e.symm) :
  q ≤₁ (q ∘ e) :=
by convert one_one_reducible.of_equiv _ h; funext; simp

theorem reflexive_one_one_reducible {α} [primcodable α] :
  reflexive (@one_one_reducible α α _ _) :=
one_one_reducible_refl

theorem transitive_one_one_reducible {α} [primcodable α] :
  transitive (@one_one_reducible α α _ _) :=
λ p q r, one_one_reducible.trans

namespace computable_pred
variables {α : Type*} {β : Type*} {σ : Type*}
variables [primcodable α] [primcodable β] [primcodable σ]
open computable

theorem computable_of_many_one_reducible
  {p : α → Prop} {q : β → Prop}
  (h₁ : p ≤₀ q) (h₂ : computable_pred q) : computable_pred p :=
begin
  rcases h₁ with ⟨f, c, hf⟩,
  rw [show p = λ a, q (f a), from set.ext hf],
  rcases computable_iff.1 h₂ with ⟨g, hg, rfl⟩,
  exact ⟨by apply_instance, by simpa using hg.comp c⟩
end

theorem computable_of_one_one_reducible
  {p : α → Prop} {q : β → Prop}
  (h : p ≤₁ q) : computable_pred q → computable_pred p :=
computable_of_many_one_reducible h.to_many_one

end computable_pred

/-- `p` and `q` are many-one equivalent if each one is many-one reducible to the other. -/
def many_one_equiv {α β} [primcodable α] [primcodable β]
  (p : α → Prop) (q : β → Prop) := p ≤₀ q ∧ q ≤₀ p

/-- `p` and `q` are one-one equivalent if each one is one-one reducible to the other. -/
def one_one_equiv {α β} [primcodable α] [primcodable β]
  (p : α → Prop) (q : β → Prop) := p ≤₁ q ∧ q ≤₁ p

@[refl]
theorem many_one_equiv_refl {α} [primcodable α] (p : α → Prop) : many_one_equiv p p :=
⟨many_one_reducible_refl _, many_one_reducible_refl _⟩

@[symm]
theorem many_one_equiv.symm {α β} [primcodable α] [primcodable β]
  {p : α → Prop} {q : β → Prop} : many_one_equiv p q → many_one_equiv q p := and.swap

@[trans]
theorem many_one_equiv.trans {α β γ} [primcodable α] [primcodable β] [primcodable γ]
  {p : α → Prop} {q : β → Prop} {r : γ → Prop} :
  many_one_equiv p q → many_one_equiv q r → many_one_equiv p r
| ⟨pq, qp⟩ ⟨qr, rq⟩ := ⟨pq.trans qr, rq.trans qp⟩

theorem equivalence_of_many_one_equiv {α} [primcodable α] :
  equivalence (@many_one_equiv α α _ _) :=
⟨many_one_equiv_refl, λ x y, many_one_equiv.symm, λ x y z, many_one_equiv.trans⟩

@[refl]
theorem one_one_equiv_refl {α} [primcodable α] (p : α → Prop) : one_one_equiv p p :=
⟨one_one_reducible_refl _, one_one_reducible_refl _⟩

@[symm]
theorem one_one_equiv.symm {α β} [primcodable α] [primcodable β]
  {p : α → Prop} {q : β → Prop} : one_one_equiv p q → one_one_equiv q p := and.swap

@[trans]
theorem one_one_equiv.trans {α β γ} [primcodable α] [primcodable β] [primcodable γ]
  {p : α → Prop} {q : β → Prop} {r : γ → Prop} :
  one_one_equiv p q → one_one_equiv q r → one_one_equiv p r
| ⟨pq, qp⟩ ⟨qr, rq⟩ := ⟨pq.trans qr, rq.trans qp⟩

theorem equivalence_of_one_one_equiv {α} [primcodable α] : equivalence (@one_one_equiv α α _ _) :=
⟨one_one_equiv_refl, λ x y, one_one_equiv.symm, λ x y z, one_one_equiv.trans⟩

theorem one_one_equiv.to_many_one {α β} [primcodable α] [primcodable β]
  {p : α → Prop} {q : β → Prop} : one_one_equiv p q → many_one_equiv p q
| ⟨pq, qp⟩ := ⟨pq.to_many_one, qp.to_many_one⟩

/-- a computable bijection -/
def equiv.computable {α β} [primcodable α] [primcodable β] (e : α ≃ β) :=
computable e ∧ computable e.symm

theorem equiv.computable.symm {α β} [primcodable α] [primcodable β] {e : α ≃ β} :
  e.computable → e.symm.computable := and.swap

theorem equiv.computable.trans {α β γ} [primcodable α] [primcodable β] [primcodable γ]
  {e₁ : α ≃ β} {e₂ : β ≃ γ} :
  e₁.computable → e₂.computable → (e₁.trans e₂).computable
| ⟨l₁, r₁⟩ ⟨l₂, r₂⟩ := ⟨l₂.comp l₁, r₁.comp r₂⟩

theorem computable.eqv (α) [denumerable α] : (denumerable.eqv α).computable :=
⟨computable.encode, computable.of_nat _⟩

theorem computable.equiv₂ (α β) [denumerable α] [denumerable β] :
  (denumerable.equiv₂ α β).computable :=
(computable.eqv _).trans (computable.eqv _).symm

theorem one_one_equiv.of_equiv {α β} [primcodable α] [primcodable β]
  {e : α ≃ β} (h : e.computable) {p} : one_one_equiv (p ∘ e) p :=
⟨one_one_reducible.of_equiv _ h.1, one_one_reducible.of_equiv_symm _ h.2⟩

theorem many_one_equiv.of_equiv {α β} [primcodable α] [primcodable β]
  {e : α ≃ β} (h : e.computable) {p} : many_one_equiv (p ∘ e) p :=
(one_one_equiv.of_equiv h).to_many_one

theorem many_one_equiv.le_congr_left {α β γ} [primcodable α] [primcodable β] [primcodable γ]
  {p : α → Prop} {q : β → Prop} {r : γ → Prop}
  (h : many_one_equiv p q) : p ≤₀ r ↔ q ≤₀ r := ⟨h.2.trans, h.1.trans⟩

theorem many_one_equiv.le_congr_right {α β γ} [primcodable α] [primcodable β] [primcodable γ]
  {p : α → Prop} {q : β → Prop} {r : γ → Prop}
  (h : many_one_equiv q r) : p ≤₀ q ↔ p ≤₀ r := ⟨λ h', h'.trans h.1, λ h', h'.trans h.2⟩

theorem one_one_equiv.le_congr_left {α β γ} [primcodable α] [primcodable β] [primcodable γ]
  {p : α → Prop} {q : β → Prop} {r : γ → Prop}
  (h : one_one_equiv p q) : p ≤₁ r ↔ q ≤₁ r := ⟨h.2.trans, h.1.trans⟩

theorem one_one_equiv.le_congr_right {α β γ} [primcodable α] [primcodable β] [primcodable γ]
  {p : α → Prop} {q : β → Prop} {r : γ → Prop}
  (h : one_one_equiv q r) : p ≤₁ q ↔ p ≤₁ r := ⟨λ h', h'.trans h.1, λ h', h'.trans h.2⟩

theorem many_one_equiv.congr_left {α β γ} [primcodable α] [primcodable β] [primcodable γ]
  {p : α → Prop} {q : β → Prop} {r : γ → Prop}
  (h : many_one_equiv p q) : many_one_equiv p r ↔ many_one_equiv q r :=
and_congr h.le_congr_left h.le_congr_right

theorem many_one_equiv.congr_right {α β γ} [primcodable α] [primcodable β] [primcodable γ]
  {p : α → Prop} {q : β → Prop} {r : γ → Prop}
  (h : many_one_equiv q r) : many_one_equiv p q ↔ many_one_equiv p r :=
and_congr h.le_congr_right h.le_congr_left

theorem one_one_equiv.congr_left {α β γ} [primcodable α] [primcodable β] [primcodable γ]
  {p : α → Prop} {q : β → Prop} {r : γ → Prop}
  (h : one_one_equiv p q) : one_one_equiv p r ↔ one_one_equiv q r :=
and_congr h.le_congr_left h.le_congr_right

theorem one_one_equiv.congr_right {α β γ} [primcodable α] [primcodable β] [primcodable γ]
  {p : α → Prop} {q : β → Prop} {r : γ → Prop}
  (h : one_one_equiv q r) : one_one_equiv p q ↔ one_one_equiv p r :=
and_congr h.le_congr_right h.le_congr_left

@[simp] lemma ulower.down_computable {α} [primcodable α] : (ulower.equiv α).computable :=
⟨primrec.ulower_down.to_comp, primrec.ulower_up.to_comp⟩

lemma many_one_equiv_up {α} [primcodable α] {p : α → Prop} : many_one_equiv (p ∘ ulower.up) p :=
many_one_equiv.of_equiv ulower.down_computable.symm

local infix ` ⊕' `:1001 := sum.elim

open nat.primrec

theorem one_one_reducible.disjoin_left {α β} [primcodable α] [primcodable β]
  {p : α → Prop} {q : β → Prop} : p ≤₁ p ⊕' q :=
⟨sum.inl, computable.sum_inl, λ x y, sum.inl.inj_iff.1, λ a, iff.rfl⟩

theorem one_one_reducible.disjoin_right {α β} [primcodable α] [primcodable β]
  {p : α → Prop} {q : β → Prop} : q ≤₁ p ⊕' q :=
⟨sum.inr, computable.sum_inr, λ x y, sum.inr.inj_iff.1, λ a, iff.rfl⟩

theorem disjoin_many_one_reducible {α β γ} [primcodable α] [primcodable β] [primcodable γ]
  {p : α → Prop} {q : β → Prop} {r : γ → Prop} : p ≤₀ r → q ≤₀ r → p ⊕' q ≤₀ r
| ⟨f, c₁, h₁⟩ ⟨g, c₂, h₂⟩ := ⟨sum.elim f g,
  computable.id.sum_cases (c₁.comp computable.snd).to₂ (c₂.comp computable.snd).to₂,
  λ x, by cases x; [apply h₁, apply h₂]⟩

theorem disjoin_le {α β γ} [primcodable α] [primcodable β] [primcodable γ]
  {p : α → Prop} {q : β → Prop} {r : γ → Prop} : p ⊕' q ≤₀ r ↔ p ≤₀ r ∧ q ≤₀ r :=
⟨λ h, ⟨one_one_reducible.disjoin_left.to_many_one.trans h,
  one_one_reducible.disjoin_right.to_many_one.trans h⟩,
 λ ⟨h₁, h₂⟩, disjoin_many_one_reducible h₁ h₂⟩

variables {α : Type u} [primcodable α] [inhabited α]
variables {β : Type v} [primcodable β] [inhabited β]
variables {γ : Type w} [primcodable γ] [inhabited γ]

/--
Computable and injective mapping of predicates to sets of natural numbers.
-/
def to_nat (p : set α) : set ℕ :=
{ n | p ((encodable.decode α n).get_or_else default) }

@[simp]
lemma to_nat_many_one_reducible {p : set α} : to_nat p ≤₀ p :=
⟨λ n, (encodable.decode α n).get_or_else default,
 computable.option_get_or_else computable.decode (computable.const _),
 λ _, iff.rfl⟩

@[simp]
lemma many_one_reducible_to_nat {p : set α} : p ≤₀ to_nat p :=
⟨encodable.encode, computable.encode, by simp [to_nat, set_of]⟩

@[simp]
lemma many_one_reducible_to_nat_to_nat {p : set α} {q : set β} :
  to_nat p ≤₀ to_nat q ↔ p ≤₀ q :=
⟨λ h, many_one_reducible_to_nat.trans (h.trans to_nat_many_one_reducible),
 λ h, to_nat_many_one_reducible.trans (h.trans many_one_reducible_to_nat)⟩

@[simp]
lemma to_nat_many_one_equiv {p : set α} : many_one_equiv (to_nat p) p :=
by simp [many_one_equiv]

@[simp]
lemma many_one_equiv_to_nat (p : set α) (q : set β) :
  many_one_equiv (to_nat p) (to_nat q) ↔ many_one_equiv p q :=
by simp [many_one_equiv]

/-- A many-one degree is an equivalence class of sets up to many-one equivalence. -/
def many_one_degree : Type :=
quotient (⟨many_one_equiv, equivalence_of_many_one_equiv⟩ : setoid (set ℕ))

namespace many_one_degree

/-- The many-one degree of a set on a primcodable type. -/
def of (p : α → Prop) : many_one_degree :=
quotient.mk' (to_nat p)

@[elab_as_eliminator]
protected lemma ind_on {C : many_one_degree → Prop} (d : many_one_degree)
  (h : ∀ p : set ℕ, C (of p)) : C d :=
quotient.induction_on' d h

/--
Lifts a function on sets of natural numbers to many-one degrees.
-/
@[elab_as_eliminator, reducible]
protected def lift_on {φ} (d : many_one_degree) (f : set ℕ → φ)
  (h : ∀ p q, many_one_equiv p q → f p = f q) : φ :=
quotient.lift_on' d f h

@[simp]
protected lemma lift_on_eq {φ} (p : set ℕ) (f : set ℕ → φ)
    (h : ∀ p q, many_one_equiv p q → f p = f q) :
  (of p).lift_on f h = f p :=
rfl

/--
Lifts a binary function on sets of natural numbers to many-one degrees.
-/
@[elab_as_eliminator, reducible, simp]
protected def lift_on₂ {φ} (d₁ d₂ : many_one_degree) (f : set ℕ → set ℕ → φ)
    (h : ∀ p₁ p₂ q₁ q₂, many_one_equiv p₁ p₂ → many_one_equiv q₁ q₂ → f p₁ q₁ = f p₂ q₂) :
  φ :=
d₁.lift_on (λ p, d₂.lift_on (f p) (λ q₁ q₂ hq, h _ _ _ _ (by refl) hq))
begin
  intros p₁ p₂ hp,
  induction d₂ using many_one_degree.ind_on,
  apply h,
  assumption,
  refl,
end

@[simp]
protected lemma lift_on₂_eq {φ} (p q : set ℕ) (f : set ℕ → set ℕ → φ)
    (h : ∀ p₁ p₂ q₁ q₂, many_one_equiv p₁ p₂ → many_one_equiv q₁ q₂ → f p₁ q₁ = f p₂ q₂) :
  (of p).lift_on₂ (of q) f h = f p q :=
rfl

@[simp] lemma of_eq_of {p : α → Prop} {q : β → Prop} : of p = of q ↔ many_one_equiv p q :=
by simp [of, quotient.eq']

instance : inhabited many_one_degree := ⟨of (∅ : set ℕ)⟩

/--
For many-one degrees `d₁` and `d₂`, `d₁ ≤ d₂` if the sets in `d₁` are many-one reducible to the
sets in `d₂`.
-/
instance : has_le many_one_degree :=
⟨λ d₁ d₂, many_one_degree.lift_on₂ d₁ d₂ (≤₀) $
  λ p₁ p₂ q₁ q₂ hp hq, propext ((hp.le_congr_left).trans (hq.le_congr_right))⟩

@[simp] lemma of_le_of {p : α → Prop} {q : β → Prop} : of p ≤ of q ↔ p ≤₀ q :=
many_one_reducible_to_nat_to_nat

private lemma le_refl (d : many_one_degree) : d ≤ d :=
by induction d using many_one_degree.ind_on; simp

private lemma le_antisymm {d₁ d₂ : many_one_degree} : d₁ ≤ d₂ → d₂ ≤ d₁ → d₁ = d₂ :=
begin
  induction d₁ using many_one_degree.ind_on,
  induction d₂ using many_one_degree.ind_on,
  intros hp hq,
  simp only [*, many_one_equiv, of_le_of, of_eq_of, true_and] at *
end

private lemma le_trans {d₁ d₂ d₃ : many_one_degree} :
  d₁ ≤ d₂ → d₂ ≤ d₃ → d₁ ≤ d₃ :=
begin
  induction d₁ using many_one_degree.ind_on,
  induction d₂ using many_one_degree.ind_on,
  induction d₃ using many_one_degree.ind_on,
  apply many_one_reducible.trans
end

instance : partial_order many_one_degree :=
{ le := (≤),
  le_refl := le_refl,
  le_trans := λ _ _ _, le_trans,
  le_antisymm := λ _ _, le_antisymm }

/-- The join of two degrees, induced by the disjoint union of two underlying sets. -/
instance : has_add many_one_degree :=
⟨λ d₁ d₂, d₁.lift_on₂ d₂ (λ a b, of (a ⊕' b))
  begin
    rintros a b c d ⟨hl₁, hr₁⟩ ⟨hl₂, hr₂⟩,
    rw of_eq_of,
    exact ⟨disjoin_many_one_reducible
        (hl₁.trans one_one_reducible.disjoin_left.to_many_one)
        (hl₂.trans one_one_reducible.disjoin_right.to_many_one),
      disjoin_many_one_reducible
        (hr₁.trans one_one_reducible.disjoin_left.to_many_one)
        (hr₂.trans one_one_reducible.disjoin_right.to_many_one)⟩
  end⟩

@[simp] lemma add_of (p : set α) (q : set β) : of (p ⊕' q) = of p + of q :=
of_eq_of.mpr
  ⟨disjoin_many_one_reducible
    (many_one_reducible_to_nat.trans one_one_reducible.disjoin_left.to_many_one)
    (many_one_reducible_to_nat.trans one_one_reducible.disjoin_right.to_many_one),
   disjoin_many_one_reducible
    (to_nat_many_one_reducible.trans one_one_reducible.disjoin_left.to_many_one)
    (to_nat_many_one_reducible.trans one_one_reducible.disjoin_right.to_many_one)⟩

@[simp] protected theorem add_le {d₁ d₂ d₃ : many_one_degree} :
  d₁ + d₂ ≤ d₃ ↔ d₁ ≤ d₃ ∧ d₂ ≤ d₃ :=
begin
  induction d₁ using many_one_degree.ind_on,
  induction d₂ using many_one_degree.ind_on,
  induction d₃ using many_one_degree.ind_on,
  simpa only [← add_of, of_le_of] using disjoin_le
end

@[simp] protected theorem le_add_left (d₁ d₂ : many_one_degree) : d₁ ≤ d₁ + d₂ :=
(many_one_degree.add_le.1 (by refl)).1

@[simp] protected theorem le_add_right (d₁ d₂ : many_one_degree) : d₂ ≤ d₁ + d₂ :=
(many_one_degree.add_le.1 (by refl)).2

instance : semilattice_sup many_one_degree :=
{ sup := (+),
  le_sup_left := many_one_degree.le_add_left,
  le_sup_right := many_one_degree.le_add_right,
  sup_le := λ a b c h₁ h₂, many_one_degree.add_le.2 ⟨h₁, h₂⟩,
  ..many_one_degree.partial_order }

end many_one_degree


namespace hidden
universe u

inductive eq {α : Type u} (a : α) : α → Prop
| refl : eq a

@[elab_as_eliminator]
theorem subst {α : Type u} {a b : α} {P : α → Prop}
  (h₁ : eq a b) (h₂ : P a) : P b :=
eq.rec h₂ h₁

-- BEGIN
theorem symm {α : Type u} {a b : α} (h : eq a b) : eq b a :=
subst h (eq.refl a)

theorem trans {α : Type u} {a b c : α}
  (h₁ : eq a b) (h₂ : eq b c) : eq a c :=
subst h₂ h₁

theorem congr {α β : Type u} {a b : α} (f : α → β)
  (h : eq a b) : eq (f a) (f b) :=
subst h (eq.refl $ f a)

-- END
end hidden


import .src_field_lemmas

namespace mth1001

namespace myreal

class myordered_field (R : Type) extends myfield R :=
(pos : R → Prop)
(decidable_pos : decidable_pred pos)
(trichotomy : ∀ x : R, pos x ∧ ¬x = 0 ∧ ¬pos (-x) ∨ ¬pos x ∧ x = 0 ∧ ¬pos (-x)
  ∨ ¬pos x ∧ x ≠ 0 ∧ pos (-x))
(pos_add_of_pos_of_pos : ∀ x y, pos x → pos y → pos (x+y))
(pos_mul_of_pos_of_pos : ∀ x y, pos x → pos y → pos (x*y))

variables {R : Type} [myordered_field R]

open_locale classical

noncomputable theory

def lt (x y : R) := myordered_field.pos (y-x)

def le (x y : R) := (lt x y) ∨ (x=y)

instance : has_lt R := ⟨lt⟩

instance : has_le R := ⟨le⟩

lemma decidable_le' (a b : R) : decidable (a≤b) := by apply_instance

def max (a b : R) := ite (b ≤ a) a b

def abs (a : R) := max a (-a)

def upper_bound (u : R) (S : set R) := ∀ s ∈ S, s ≤ u

def is_sup (u : R) (S : set R) :=
(upper_bound u S) ∧ (∀ v : R, upper_bound v S → u ≤ v)

def lower_bound (v : R) (S : set R) := ∀ s ∈ S, v ≤ s

def is_inf (u : R) (S : set R) :=
(lower_bound u S) ∧ (∀ v : R, lower_bound v S → v ≤ u)

def minus_set (S : set R) := {x | -x ∈ S}

def bounded_above (S : set R) := ∃ u : R, upper_bound u S

def bounded_below (S : set R) := ∃ v : R, lower_bound v S

def bounded (S : set R) := (bounded_above S) ∧ (bounded_below S)

end myreal

end mth1001


import classes.context_free.basics.definition
import utilities.list_utils

/-- Pumping lemma for context-free languages. -/
lemma CF_pumping {T : Type} {L : language T} (cf : is_CF L) :
  ∃ n : ℕ, ∀ w ∈ L, list.length w ≥ n → (
    ∃ u v x y z : list T,
      (w = u ++ v ++ x ++ y ++ z) ∧
      (v ++ y).length > 0         ∧
      (v ++ x ++ y).length ≤ n    ∧
      (∀ i : ℕ, u ++ v ^ i ++ x ++ y ^ i ++ z ∈ L)
  ) :=
sorry


lemma example3 (a b : mynat) (h : succ a = b) : succ(succ(a)) = succ(b) :=
begin
rw h,
refl,
end


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

! This file was ported from Lean 3 source module data.nat.choose.cast
! leanprover-community/mathlib commit 69c6a5a12d8a2b159f20933e60115a4f2de62b58
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Data.Nat.Choose.Basic
import Mathbin.Data.Nat.Factorial.Cast

/-!
# Cast of binomial coefficients

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

This file allows calculating the binomial coefficient `a.choose b` as an element of a division ring
of characteristic `0`.
-/

open Nat

variable (K : Type _) [DivisionRing K] [CharZero K]

namespace Nat

/- warning: nat.cast_choose -> Nat.cast_choose is a dubious translation:
lean 3 declaration is
  forall (K : Type.{u1}) [_inst_1 : DivisionRing.{u1} K] [_inst_2 : CharZero.{u1} K (AddGroupWithOne.toAddMonoidWithOne.{u1} K (AddCommGroupWithOne.toAddGroupWithOne.{u1} K (Ring.toAddCommGroupWithOne.{u1} K (DivisionRing.toRing.{u1} K _inst_1))))] {a : Nat} {b : Nat}, (LE.le.{0} Nat Nat.hasLe a b) -> (Eq.{succ u1} K ((fun (a : Type) (b : Type.{u1}) [self : HasLiftT.{1, succ u1} a b] => self.0) Nat K (HasLiftT.mk.{1, succ u1} Nat K (CoeTCₓ.coe.{1, succ u1} Nat K (Nat.castCoe.{u1} K (AddMonoidWithOne.toNatCast.{u1} K (AddGroupWithOne.toAddMonoidWithOne.{u1} K (AddCommGroupWithOne.toAddGroupWithOne.{u1} K (Ring.toAddCommGroupWithOne.{u1} K (DivisionRing.toRing.{u1} K _inst_1)))))))) (Nat.choose b a)) (HDiv.hDiv.{u1, u1, u1} K K K (instHDiv.{u1} K (DivInvMonoid.toHasDiv.{u1} K (DivisionRing.toDivInvMonoid.{u1} K _inst_1))) ((fun (a : Type) (b : Type.{u1}) [self : HasLiftT.{1, succ u1} a b] => self.0) Nat K (HasLiftT.mk.{1, succ u1} Nat K (CoeTCₓ.coe.{1, succ u1} Nat K (Nat.castCoe.{u1} K (AddMonoidWithOne.toNatCast.{u1} K (AddGroupWithOne.toAddMonoidWithOne.{u1} K (AddCommGroupWithOne.toAddGroupWithOne.{u1} K (Ring.toAddCommGroupWithOne.{u1} K (DivisionRing.toRing.{u1} K _inst_1)))))))) (Nat.factorial b)) (HMul.hMul.{u1, u1, u1} K K K (instHMul.{u1} K (Distrib.toHasMul.{u1} K (Ring.toDistrib.{u1} K (DivisionRing.toRing.{u1} K _inst_1)))) ((fun (a : Type) (b : Type.{u1}) [self : HasLiftT.{1, succ u1} a b] => self.0) Nat K (HasLiftT.mk.{1, succ u1} Nat K (CoeTCₓ.coe.{1, succ u1} Nat K (Nat.castCoe.{u1} K (AddMonoidWithOne.toNatCast.{u1} K (AddGroupWithOne.toAddMonoidWithOne.{u1} K (AddCommGroupWithOne.toAddGroupWithOne.{u1} K (Ring.toAddCommGroupWithOne.{u1} K (DivisionRing.toRing.{u1} K _inst_1)))))))) (Nat.factorial a)) ((fun (a : Type) (b : Type.{u1}) [self : HasLiftT.{1, succ u1} a b] => self.0) Nat K (HasLiftT.mk.{1, succ u1} Nat K (CoeTCₓ.coe.{1, succ u1} Nat K (Nat.castCoe.{u1} K (AddMonoidWithOne.toNatCast.{u1} K (AddGroupWithOne.toAddMonoidWithOne.{u1} K (AddCommGroupWithOne.toAddGroupWithOne.{u1} K (Ring.toAddCommGroupWithOne.{u1} K (DivisionRing.toRing.{u1} K _inst_1)))))))) (Nat.factorial (HSub.hSub.{0, 0, 0} Nat Nat Nat (instHSub.{0} Nat Nat.hasSub) b a))))))
but is expected to have type
  forall (K : Type.{u1}) [_inst_1 : DivisionRing.{u1} K] [_inst_2 : CharZero.{u1} K (AddGroupWithOne.toAddMonoidWithOne.{u1} K (Ring.toAddGroupWithOne.{u1} K (DivisionRing.toRing.{u1} K _inst_1)))] {a : Nat} {b : Nat}, (LE.le.{0} Nat instLENat a b) -> (Eq.{succ u1} K (Nat.cast.{u1} K (NonAssocRing.toNatCast.{u1} K (Ring.toNonAssocRing.{u1} K (DivisionRing.toRing.{u1} K _inst_1))) (Nat.choose b a)) (HDiv.hDiv.{u1, u1, u1} K K K (instHDiv.{u1} K (DivisionRing.toDiv.{u1} K _inst_1)) (Nat.cast.{u1} K (NonAssocRing.toNatCast.{u1} K (Ring.toNonAssocRing.{u1} K (DivisionRing.toRing.{u1} K _inst_1))) (Nat.factorial b)) (HMul.hMul.{u1, u1, u1} K K K (instHMul.{u1} K (NonUnitalNonAssocRing.toMul.{u1} K (NonAssocRing.toNonUnitalNonAssocRing.{u1} K (Ring.toNonAssocRing.{u1} K (DivisionRing.toRing.{u1} K _inst_1))))) (Nat.cast.{u1} K (NonAssocRing.toNatCast.{u1} K (Ring.toNonAssocRing.{u1} K (DivisionRing.toRing.{u1} K _inst_1))) (Nat.factorial a)) (Nat.cast.{u1} K (NonAssocRing.toNatCast.{u1} K (Ring.toNonAssocRing.{u1} K (DivisionRing.toRing.{u1} K _inst_1))) (Nat.factorial (HSub.hSub.{0, 0, 0} Nat Nat Nat (instHSub.{0} Nat instSubNat) b a))))))
Case conversion may be inaccurate. Consider using '#align nat.cast_choose Nat.cast_chooseₓ'. -/
theorem cast_choose {a b : ℕ} (h : a ≤ b) : (b.choose a : K) = b ! / (a ! * (b - a)!) :=
  by
  have : ∀ {n : ℕ}, (n ! : K) ≠ 0 := fun n => Nat.cast_ne_zero.2 (factorial_ne_zero _)
  rw [eq_div_iff_mul_eq (mul_ne_zero this this)]
  rw_mod_cast [← mul_assoc, choose_mul_factorial_mul_factorial h]
#align nat.cast_choose Nat.cast_choose

/- warning: nat.cast_add_choose -> Nat.cast_add_choose is a dubious translation:
lean 3 declaration is
  forall (K : Type.{u1}) [_inst_1 : DivisionRing.{u1} K] [_inst_2 : CharZero.{u1} K (AddGroupWithOne.toAddMonoidWithOne.{u1} K (AddCommGroupWithOne.toAddGroupWithOne.{u1} K (Ring.toAddCommGroupWithOne.{u1} K (DivisionRing.toRing.{u1} K _inst_1))))] {a : Nat} {b : Nat}, Eq.{succ u1} K ((fun (a : Type) (b : Type.{u1}) [self : HasLiftT.{1, succ u1} a b] => self.0) Nat K (HasLiftT.mk.{1, succ u1} Nat K (CoeTCₓ.coe.{1, succ u1} Nat K (Nat.castCoe.{u1} K (AddMonoidWithOne.toNatCast.{u1} K (AddGroupWithOne.toAddMonoidWithOne.{u1} K (AddCommGroupWithOne.toAddGroupWithOne.{u1} K (Ring.toAddCommGroupWithOne.{u1} K (DivisionRing.toRing.{u1} K _inst_1)))))))) (Nat.choose (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) a b) a)) (HDiv.hDiv.{u1, u1, u1} K K K (instHDiv.{u1} K (DivInvMonoid.toHasDiv.{u1} K (DivisionRing.toDivInvMonoid.{u1} K _inst_1))) ((fun (a : Type) (b : Type.{u1}) [self : HasLiftT.{1, succ u1} a b] => self.0) Nat K (HasLiftT.mk.{1, succ u1} Nat K (CoeTCₓ.coe.{1, succ u1} Nat K (Nat.castCoe.{u1} K (AddMonoidWithOne.toNatCast.{u1} K (AddGroupWithOne.toAddMonoidWithOne.{u1} K (AddCommGroupWithOne.toAddGroupWithOne.{u1} K (Ring.toAddCommGroupWithOne.{u1} K (DivisionRing.toRing.{u1} K _inst_1)))))))) (Nat.factorial (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) a b))) (HMul.hMul.{u1, u1, u1} K K K (instHMul.{u1} K (Distrib.toHasMul.{u1} K (Ring.toDistrib.{u1} K (DivisionRing.toRing.{u1} K _inst_1)))) ((fun (a : Type) (b : Type.{u1}) [self : HasLiftT.{1, succ u1} a b] => self.0) Nat K (HasLiftT.mk.{1, succ u1} Nat K (CoeTCₓ.coe.{1, succ u1} Nat K (Nat.castCoe.{u1} K (AddMonoidWithOne.toNatCast.{u1} K (AddGroupWithOne.toAddMonoidWithOne.{u1} K (AddCommGroupWithOne.toAddGroupWithOne.{u1} K (Ring.toAddCommGroupWithOne.{u1} K (DivisionRing.toRing.{u1} K _inst_1)))))))) (Nat.factorial a)) ((fun (a : Type) (b : Type.{u1}) [self : HasLiftT.{1, succ u1} a b] => self.0) Nat K (HasLiftT.mk.{1, succ u1} Nat K (CoeTCₓ.coe.{1, succ u1} Nat K (Nat.castCoe.{u1} K (AddMonoidWithOne.toNatCast.{u1} K (AddGroupWithOne.toAddMonoidWithOne.{u1} K (AddCommGroupWithOne.toAddGroupWithOne.{u1} K (Ring.toAddCommGroupWithOne.{u1} K (DivisionRing.toRing.{u1} K _inst_1)))))))) (Nat.factorial b))))
but is expected to have type
  forall (K : Type.{u1}) [_inst_1 : DivisionRing.{u1} K] [_inst_2 : CharZero.{u1} K (AddGroupWithOne.toAddMonoidWithOne.{u1} K (Ring.toAddGroupWithOne.{u1} K (DivisionRing.toRing.{u1} K _inst_1)))] {a : Nat} {b : Nat}, Eq.{succ u1} K (Nat.cast.{u1} K (NonAssocRing.toNatCast.{u1} K (Ring.toNonAssocRing.{u1} K (DivisionRing.toRing.{u1} K _inst_1))) (Nat.choose (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat instAddNat) a b) a)) (HDiv.hDiv.{u1, u1, u1} K K K (instHDiv.{u1} K (DivisionRing.toDiv.{u1} K _inst_1)) (Nat.cast.{u1} K (NonAssocRing.toNatCast.{u1} K (Ring.toNonAssocRing.{u1} K (DivisionRing.toRing.{u1} K _inst_1))) (Nat.factorial (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat instAddNat) a b))) (HMul.hMul.{u1, u1, u1} K K K (instHMul.{u1} K (NonUnitalNonAssocRing.toMul.{u1} K (NonAssocRing.toNonUnitalNonAssocRing.{u1} K (Ring.toNonAssocRing.{u1} K (DivisionRing.toRing.{u1} K _inst_1))))) (Nat.cast.{u1} K (NonAssocRing.toNatCast.{u1} K (Ring.toNonAssocRing.{u1} K (DivisionRing.toRing.{u1} K _inst_1))) (Nat.factorial a)) (Nat.cast.{u1} K (NonAssocRing.toNatCast.{u1} K (Ring.toNonAssocRing.{u1} K (DivisionRing.toRing.{u1} K _inst_1))) (Nat.factorial b))))
Case conversion may be inaccurate. Consider using '#align nat.cast_add_choose Nat.cast_add_chooseₓ'. -/
theorem cast_add_choose {a b : ℕ} : ((a + b).choose a : K) = (a + b)! / (a ! * b !) := by
  rw [cast_choose K (le_add_right le_rfl), add_tsub_cancel_left]
#align nat.cast_add_choose Nat.cast_add_choose

/- warning: nat.cast_choose_eq_pochhammer_div -> Nat.cast_choose_eq_pochhammer_div is a dubious translation:
lean 3 declaration is
  forall (K : Type.{u1}) [_inst_1 : DivisionRing.{u1} K] [_inst_2 : CharZero.{u1} K (AddGroupWithOne.toAddMonoidWithOne.{u1} K (AddCommGroupWithOne.toAddGroupWithOne.{u1} K (Ring.toAddCommGroupWithOne.{u1} K (DivisionRing.toRing.{u1} K _inst_1))))] (a : Nat) (b : Nat), Eq.{succ u1} K ((fun (a : Type) (b : Type.{u1}) [self : HasLiftT.{1, succ u1} a b] => self.0) Nat K (HasLiftT.mk.{1, succ u1} Nat K (CoeTCₓ.coe.{1, succ u1} Nat K (Nat.castCoe.{u1} K (AddMonoidWithOne.toNatCast.{u1} K (AddGroupWithOne.toAddMonoidWithOne.{u1} K (AddCommGroupWithOne.toAddGroupWithOne.{u1} K (Ring.toAddCommGroupWithOne.{u1} K (DivisionRing.toRing.{u1} K _inst_1)))))))) (Nat.choose a b)) (HDiv.hDiv.{u1, u1, u1} K K K (instHDiv.{u1} K (DivInvMonoid.toHasDiv.{u1} K (DivisionRing.toDivInvMonoid.{u1} K _inst_1))) (Polynomial.eval.{u1} K (Ring.toSemiring.{u1} K (DivisionRing.toRing.{u1} K _inst_1)) ((fun (a : Type) (b : Type.{u1}) [self : HasLiftT.{1, succ u1} a b] => self.0) Nat K (HasLiftT.mk.{1, succ u1} Nat K (CoeTCₓ.coe.{1, succ u1} Nat K (Nat.castCoe.{u1} K (AddMonoidWithOne.toNatCast.{u1} K (AddGroupWithOne.toAddMonoidWithOne.{u1} K (AddCommGroupWithOne.toAddGroupWithOne.{u1} K (Ring.toAddCommGroupWithOne.{u1} K (DivisionRing.toRing.{u1} K _inst_1)))))))) (HSub.hSub.{0, 0, 0} Nat Nat Nat (instHSub.{0} Nat Nat.hasSub) a (HSub.hSub.{0, 0, 0} Nat Nat Nat (instHSub.{0} Nat Nat.hasSub) b (OfNat.ofNat.{0} Nat 1 (OfNat.mk.{0} Nat 1 (One.one.{0} Nat Nat.hasOne)))))) (pochhammer.{u1} K (Ring.toSemiring.{u1} K (DivisionRing.toRing.{u1} K _inst_1)) b)) ((fun (a : Type) (b : Type.{u1}) [self : HasLiftT.{1, succ u1} a b] => self.0) Nat K (HasLiftT.mk.{1, succ u1} Nat K (CoeTCₓ.coe.{1, succ u1} Nat K (Nat.castCoe.{u1} K (AddMonoidWithOne.toNatCast.{u1} K (AddGroupWithOne.toAddMonoidWithOne.{u1} K (AddCommGroupWithOne.toAddGroupWithOne.{u1} K (Ring.toAddCommGroupWithOne.{u1} K (DivisionRing.toRing.{u1} K _inst_1)))))))) (Nat.factorial b)))
but is expected to have type
  forall (K : Type.{u1}) [_inst_1 : DivisionRing.{u1} K] [_inst_2 : CharZero.{u1} K (AddGroupWithOne.toAddMonoidWithOne.{u1} K (Ring.toAddGroupWithOne.{u1} K (DivisionRing.toRing.{u1} K _inst_1)))] (a : Nat) (b : Nat), Eq.{succ u1} K (Nat.cast.{u1} K (NonAssocRing.toNatCast.{u1} K (Ring.toNonAssocRing.{u1} K (DivisionRing.toRing.{u1} K _inst_1))) (Nat.choose a b)) (HDiv.hDiv.{u1, u1, u1} K K K (instHDiv.{u1} K (DivisionRing.toDiv.{u1} K _inst_1)) (Polynomial.eval.{u1} K (DivisionSemiring.toSemiring.{u1} K (DivisionRing.toDivisionSemiring.{u1} K _inst_1)) (Nat.cast.{u1} K (NonAssocRing.toNatCast.{u1} K (Ring.toNonAssocRing.{u1} K (DivisionRing.toRing.{u1} K _inst_1))) (HSub.hSub.{0, 0, 0} Nat Nat Nat (instHSub.{0} Nat instSubNat) a (HSub.hSub.{0, 0, 0} Nat Nat Nat (instHSub.{0} Nat instSubNat) b (OfNat.ofNat.{0} Nat 1 (instOfNatNat 1))))) (pochhammer.{u1} K (DivisionSemiring.toSemiring.{u1} K (DivisionRing.toDivisionSemiring.{u1} K _inst_1)) b)) (Nat.cast.{u1} K (NonAssocRing.toNatCast.{u1} K (Ring.toNonAssocRing.{u1} K (DivisionRing.toRing.{u1} K _inst_1))) (Nat.factorial b)))
Case conversion may be inaccurate. Consider using '#align nat.cast_choose_eq_pochhammer_div Nat.cast_choose_eq_pochhammer_divₓ'. -/
theorem cast_choose_eq_pochhammer_div (a b : ℕ) :
    (a.choose b : K) = (pochhammer K b).eval (a - (b - 1) : ℕ) / b ! := by
  rw [eq_div_iff_mul_eq (Nat.cast_ne_zero.2 b.factorial_ne_zero : (b ! : K) ≠ 0), ← Nat.cast_mul,
    mul_comm, ← Nat.descFactorial_eq_factorial_mul_choose, ← cast_desc_factorial]
#align nat.cast_choose_eq_pochhammer_div Nat.cast_choose_eq_pochhammer_div

/- warning: nat.cast_choose_two -> Nat.cast_choose_two is a dubious translation:
lean 3 declaration is
  forall (K : Type.{u1}) [_inst_1 : DivisionRing.{u1} K] [_inst_2 : CharZero.{u1} K (AddGroupWithOne.toAddMonoidWithOne.{u1} K (AddCommGroupWithOne.toAddGroupWithOne.{u1} K (Ring.toAddCommGroupWithOne.{u1} K (DivisionRing.toRing.{u1} K _inst_1))))] (a : Nat), Eq.{succ u1} K ((fun (a : Type) (b : Type.{u1}) [self : HasLiftT.{1, succ u1} a b] => self.0) Nat K (HasLiftT.mk.{1, succ u1} Nat K (CoeTCₓ.coe.{1, succ u1} Nat K (Nat.castCoe.{u1} K (AddMonoidWithOne.toNatCast.{u1} K (AddGroupWithOne.toAddMonoidWithOne.{u1} K (AddCommGroupWithOne.toAddGroupWithOne.{u1} K (Ring.toAddCommGroupWithOne.{u1} K (DivisionRing.toRing.{u1} K _inst_1)))))))) (Nat.choose a (OfNat.ofNat.{0} Nat 2 (OfNat.mk.{0} Nat 2 (bit0.{0} Nat Nat.hasAdd (One.one.{0} Nat Nat.hasOne)))))) (HDiv.hDiv.{u1, u1, u1} K K K (instHDiv.{u1} K (DivInvMonoid.toHasDiv.{u1} K (DivisionRing.toDivInvMonoid.{u1} K _inst_1))) (HMul.hMul.{u1, u1, u1} K K K (instHMul.{u1} K (Distrib.toHasMul.{u1} K (Ring.toDistrib.{u1} K (DivisionRing.toRing.{u1} K _inst_1)))) ((fun (a : Type) (b : Type.{u1}) [self : HasLiftT.{1, succ u1} a b] => self.0) Nat K (HasLiftT.mk.{1, succ u1} Nat K (CoeTCₓ.coe.{1, succ u1} Nat K (Nat.castCoe.{u1} K (AddMonoidWithOne.toNatCast.{u1} K (AddGroupWithOne.toAddMonoidWithOne.{u1} K (AddCommGroupWithOne.toAddGroupWithOne.{u1} K (Ring.toAddCommGroupWithOne.{u1} K (DivisionRing.toRing.{u1} K _inst_1)))))))) a) (HSub.hSub.{u1, u1, u1} K K K (instHSub.{u1} K (SubNegMonoid.toHasSub.{u1} K (AddGroup.toSubNegMonoid.{u1} K (AddGroupWithOne.toAddGroup.{u1} K (AddCommGroupWithOne.toAddGroupWithOne.{u1} K (Ring.toAddCommGroupWithOne.{u1} K (DivisionRing.toRing.{u1} K _inst_1))))))) ((fun (a : Type) (b : Type.{u1}) [self : HasLiftT.{1, succ u1} a b] => self.0) Nat K (HasLiftT.mk.{1, succ u1} Nat K (CoeTCₓ.coe.{1, succ u1} Nat K (Nat.castCoe.{u1} K (AddMonoidWithOne.toNatCast.{u1} K (AddGroupWithOne.toAddMonoidWithOne.{u1} K (AddCommGroupWithOne.toAddGroupWithOne.{u1} K (Ring.toAddCommGroupWithOne.{u1} K (DivisionRing.toRing.{u1} K _inst_1)))))))) a) (OfNat.ofNat.{u1} K 1 (OfNat.mk.{u1} K 1 (One.one.{u1} K (AddMonoidWithOne.toOne.{u1} K (AddGroupWithOne.toAddMonoidWithOne.{u1} K (AddCommGroupWithOne.toAddGroupWithOne.{u1} K (Ring.toAddCommGroupWithOne.{u1} K (DivisionRing.toRing.{u1} K _inst_1)))))))))) (OfNat.ofNat.{u1} K 2 (OfNat.mk.{u1} K 2 (bit0.{u1} K (Distrib.toHasAdd.{u1} K (Ring.toDistrib.{u1} K (DivisionRing.toRing.{u1} K _inst_1))) (One.one.{u1} K (AddMonoidWithOne.toOne.{u1} K (AddGroupWithOne.toAddMonoidWithOne.{u1} K (AddCommGroupWithOne.toAddGroupWithOne.{u1} K (Ring.toAddCommGroupWithOne.{u1} K (DivisionRing.toRing.{u1} K _inst_1))))))))))
but is expected to have type
  forall (K : Type.{u1}) [_inst_1 : DivisionRing.{u1} K] [_inst_2 : CharZero.{u1} K (AddGroupWithOne.toAddMonoidWithOne.{u1} K (Ring.toAddGroupWithOne.{u1} K (DivisionRing.toRing.{u1} K _inst_1)))] (a : Nat), Eq.{succ u1} K (Nat.cast.{u1} K (NonAssocRing.toNatCast.{u1} K (Ring.toNonAssocRing.{u1} K (DivisionRing.toRing.{u1} K _inst_1))) (Nat.choose a (OfNat.ofNat.{0} Nat 2 (instOfNatNat 2)))) (HDiv.hDiv.{u1, u1, u1} K K K (instHDiv.{u1} K (DivisionRing.toDiv.{u1} K _inst_1)) (HMul.hMul.{u1, u1, u1} K K K (instHMul.{u1} K (NonUnitalNonAssocRing.toMul.{u1} K (NonAssocRing.toNonUnitalNonAssocRing.{u1} K (Ring.toNonAssocRing.{u1} K (DivisionRing.toRing.{u1} K _inst_1))))) (Nat.cast.{u1} K (NonAssocRing.toNatCast.{u1} K (Ring.toNonAssocRing.{u1} K (DivisionRing.toRing.{u1} K _inst_1))) a) (HSub.hSub.{u1, u1, u1} K K K (instHSub.{u1} K (Ring.toSub.{u1} K (DivisionRing.toRing.{u1} K _inst_1))) (Nat.cast.{u1} K (NonAssocRing.toNatCast.{u1} K (Ring.toNonAssocRing.{u1} K (DivisionRing.toRing.{u1} K _inst_1))) a) (OfNat.ofNat.{u1} K 1 (One.toOfNat1.{u1} K (NonAssocRing.toOne.{u1} K (Ring.toNonAssocRing.{u1} K (DivisionRing.toRing.{u1} K _inst_1))))))) (OfNat.ofNat.{u1} K 2 (instOfNat.{u1} K 2 (NonAssocRing.toNatCast.{u1} K (Ring.toNonAssocRing.{u1} K (DivisionRing.toRing.{u1} K _inst_1))) (instAtLeastTwoHAddNatInstHAddInstAddNatOfNat (OfNat.ofNat.{0} Nat 0 (instOfNatNat 0))))))
Case conversion may be inaccurate. Consider using '#align nat.cast_choose_two Nat.cast_choose_twoₓ'. -/
theorem cast_choose_two (a : ℕ) : (a.choose 2 : K) = a * (a - 1) / 2 := by
  rw [← cast_desc_factorial_two, desc_factorial_eq_factorial_mul_choose, factorial_two, mul_comm,
    cast_mul, cast_two, eq_div_iff_mul_eq (two_ne_zero : (2 : K) ≠ 0)]
#align nat.cast_choose_two Nat.cast_choose_two

end Nat


import tactic
import .topology
noncomputable theory

section cover

-- cover of a set
structure cover (I X : Type) :=
  (part : I → set X)
  (hx : ∀ (x : X), ∃ (i : I), x ∈ part i)

-- coercion so we can write "U i" when (U : cover I X) and (i : I)
instance cover_to_parts (I X : Type) : has_coe_to_fun (cover I X) :=
  {F   := λ _, I → set X,
   coe := λ U, U.part}

lemma cover_set_eq {I X : Type} (U : cover I X) (A : set X) :
  A = ⋃₀ {A' | ∃ j, A' = (U j) ∩ A} :=
begin
  ext a, split; intro ha,
  obtain ⟨i, hi⟩ := U.hx a,
  use (U i) ∩ A, exact ⟨⟨i, rfl⟩, hi, ha⟩,
  obtain ⟨A', ⟨j, hj⟩, hA''⟩ := ha, rw hj at hA'', exact hA''.2,
end

example {X Y : Type} (f : X → Y) (U : set Y) : set.preimage f U → U :=
  λ x, ⟨f x.val, x.prop⟩

example {X Y : Type} (f : X → Y) : X → f '' set.univ :=
  λ x, ⟨f x, ⟨x, trivial, rfl⟩⟩

-- consistent functions on each part of the cover
structure gluing_data (I X Y : Type) :=
  (U : cover I X)
  (f : Π (i : I), U i → Y)
  (hglue : ∀ (i j : I) (x : X) (hxi : x ∈ U i) (hxj : x ∈ U j),
    (f i) ⟨x, hxi⟩ = (f j) ⟨x, hxj⟩)

-- what it means for f : X → Y to be compatible with gluing data
def compatible {I X Y : Type} (gl : gluing_data I X Y) (f : X → Y) :=
  ∀ (i : I) (x : X) (hxi : x ∈ gl.U i), f x = gl.f i ⟨x, hxi⟩

lemma compatible_iff_restrict_eq
  {I X Y : Type} (gl : gluing_data I X Y) {f : X → Y} :
  compatible gl f ↔ ∀ (i : I), subtype.restrict f _ = gl.f i :=
begin
  split; intros hf i, specialize hf i,
  ext ⟨x, hx⟩, rw subtype.restrict_apply, exact hf x hx,
  intros x hx, rw ← hf, rw subtype.restrict_apply,
end

-- existence of compatible function
-- (uses choice, even though the result is unique)
def mk_function {I X Y : Type} (gl : gluing_data I X Y) : X → Y :=
λ x, let ⟨i, hxi⟩ := classical.subtype_of_exists (gl.U.hx x) in
  gl.f i ⟨x, hxi⟩

lemma mk_compatible {I X Y} (gl : @gluing_data I X Y) :
  compatible gl (mk_function gl) :=
begin
  intros i x hxi,
  let j := classical.subtype_of_exists (gl.U.hx x),
  exact gl.hglue j.val i x j.prop hxi,
end

lemma compatible_unique {I X Y : Type} (gl : @gluing_data I X Y) (f g : X → Y) :
  compatible gl f → compatible gl g → f = g :=
begin
  intros hf hg,
  ext, obtain ⟨i, hxi⟩ := gl.U.hx x,
  specialize hf i x hxi,
  specialize hg i x hxi,
  rwa [hf, hg],
end

section refine

@[reducible]
def pullback_cover {I X Y : Type} (f : X → Y) (U : cover I Y) : cover I X :=
  ⟨ λ i, f ⁻¹' (U i),
    λ x, U.hx (f x)⟩
infix `⁻¹c`:110 := pullback_cover

lemma pullback_cover.comp {I X Y Z : Type} (f : X → Y) (g : Y → Z)
  (U : cover I Z) : (g ∘ f) ⁻¹c U = f ⁻¹c (g ⁻¹c U) := by split

variables
  (I J X Y : Type)
  (CI : cover I X)
  (CJ : cover J X)
  (gl : gluing_data I X Y)

def refine : cover (I × J) X :=
 ⟨λ ij, (CI.part ij.1) ∩ (CJ.part ij.2),
  λ x, let ⟨i, hxi⟩ := CI.hx x in
       let ⟨j, hxj⟩ := CJ.hx x in
       ⟨⟨i, j⟩, ⟨hxi, hxj⟩⟩⟩

/-
Note: this is asymmetric: f is defined on Uᵢ ∩ Vⱼ
as the restriction of f from Uᵢ, not Vⱼ.
-/
def gl_refine : gluing_data (I × J) X Y :=
  ⟨ -- U, f, hglue
    refine I J X gl.U CJ, -- U
    λ ⟨i, j⟩ ⟨x, hxij⟩,
    gl.f i ⟨x, hxij.left⟩,
    λ ⟨i₁, j₁⟩ ⟨i₂, j₂⟩ x ⟨hxi₁, hxj₁⟩ ⟨hxi₂, hxj₂⟩,
    gl.hglue i₁ i₂ x hxi₁ hxi₂,
  ⟩

lemma compat_of_refine_of_compat (f : X → Y) :
  compatible gl f →
  compatible (gl_refine _ _ _ _ CJ gl) f :=
begin
  rintros hf ⟨i, j⟩ x ⟨hxi, hxj⟩,
  exact hf i x hxi,
end

end refine

end cover

section open_cover
open topology
--(@pullback J E' B π' V)

structure open_cover (I X : Type) [topology X] extends (cover I X) :=
  (hopen : ∀ (i : I), part i ∈ opens X)

instance (I X : Type) [topology X] :
  has_coe (open_cover I X) (cover I X) := ⟨λ U, ⟨U.part, U.hx⟩⟩

structure cts_gluing_data (I X Y : Type) [topology X] [topology Y] :=
  (U : open_cover I X)
  (f : Π (i : I), (U i) → Y)
  (hglue : ∀ (i j : I) (x : X) (hxi : x ∈ U i) (hxj : x ∈ U j),
    (f i) ⟨x, hxi⟩ = (f j) ⟨x, hxj⟩)
  (hf : Π (i : I), cts (f i))

instance (I X Y : Type) [topology X] [topology Y] :
  has_coe (cts_gluing_data I X Y) (gluing_data I X Y) :=
  ⟨λ gl, ⟨gl.U, gl.f, gl.hglue⟩⟩

variables {I X : Type} [topology X]

lemma subset_open_iff_open_cover (U : open_cover I X) (A : set X) :
  A ∈ opens X ↔ ∀ (i : I), (U i) ∩ A ∈ opens X :=
begin
  split, intros hA i, apply inter₂ _ _ (U.hopen i) hA,
  intro hA,
  rw cover_set_eq U.to_cover A,
  apply union, rintros A' ⟨i, hi⟩, rw hi, exact hA i,
end

def open_cover.refine {J : Type} (CI : open_cover I X) (CJ : open_cover J X) :
  open_cover (I × J) X :=
  { part  := (refine I J X CI CJ).part,
    hx    := (refine I J X CI CJ).hx,
    hopen := λ ⟨i, j⟩, inter₂ _ _ (CI.hopen i) (CJ.hopen j),
  }
/-  ⟨λ ⟨i, j⟩, (CI i) ∩ (CJ j),
  λ x, let ⟨i, hxi⟩ := CI.to_cover.hx x.1 in
       let ⟨j, hxj⟩ := CJ.to_cover.hx x.2 in
       ⟨⟨i, j⟩, ⟨hxi, hxj⟩⟩⟩
-/
variables {Y : Type} [topology Y]
  (U : open_cover I X) (gl : cts_gluing_data I X Y)
  (f g : X → Y)

@[reducible]
def pullback_open_cover (hf : cts f) (U : open_cover I Y) : open_cover I X :=
  ⟨ pullback_cover f ↑U,
    λ i, hf _ (U.hopen i)⟩

lemma cts_iff_cts_on_cover (f : X → Y) : cts f ↔
  Π (i : I), @cts _ _ (subspace_topology (U i)) _
                      (subtype.restrict f (U i)) :=
begin
  split,
  intros hf i, apply pullback_cts_along_inverse_image, exact hf,
  intro hfi,
  -- check continuity pointwise, then on a piece of the cover
  rw cts_iff_ptwise_cts, intro x,
  obtain ⟨i, hxi⟩ := U.hx x, specialize hfi i,
  rw cts_iff_ptwise_cts at hfi, specialize hfi ⟨x, hxi⟩,
  rwa cts_at_pt_of_open f (U i) (U.hopen i) x hxi,
end

-- function compatible with cts gluing data is cts
-- (mostly equivalent to cts_iff_cts_on_cover)
lemma cts_of_cts_compat :
  compatible (gl : gluing_data I X Y) f → cts f :=
begin
  intro hf,
  rw cts_iff_cts_on_cover gl.U,
  rw compatible_iff_restrict_eq at hf,
  intro i, specialize hf i, convert gl.hf i,
end

-- the glued function is continuous! 🎉
lemma mk_function_cts : cts (mk_function (gl : gluing_data I X Y)) :=
  cts_of_cts_compat gl
  (mk_function (gl : gluing_data I X Y))
  (mk_compatible ↑gl)

end open_cover

-- an attempt at doing covers using maps rather than subsets
section b_cover

structure b_cover (I X : Type) :=
  (part   : I → Type)
  (map    : Π {i : I}, (part i) → X)
  (hx     : ∀ (x : X), ∃ i (u : part i), map u = x)

instance b_cover_to_parts (I X : Type) : has_coe_to_fun (b_cover I X) :=
  {F   := λ _, I → Type,
   coe := λ U, U.part}

def to_fun {I X : Type} (U : b_cover I X) (i : I) : U i → X :=
  λ x, U.map x

structure b_cover₂ (I X : Type) extends (b_cover I X) :=
  (part₂   : I → I → Type)
  (map₂l   : Π {i j : I}, (part₂ i j) → part i)
  (map₂r   : Π {i j : I}, (part₂ i j) → part j)
  (compat₂ : Π {i j : I} (u_ij : part₂ i j),
             map (map₂l u_ij) = map (map₂r u_ij))
  (hx₂     : ∀ {i j : I} {u_i : part i} {u_j : part j},
             map u_i = map u_j ↔
             ∃ u_ij, map₂l u_ij = u_i ∧ map₂r u_ij = u_j)

-- consistent functions on each part of the cover
structure b_gluing_data (I X Y : Type) extends (b_cover₂ I X) :=
  (f  : Π {i : I}, part i → Y)
  (hglue : ∀ {i j : I} (u : part₂ i j),
           f (map₂l u) = f (map₂r u))

-- what it means for f : X → Y to be compatible with gluing data
def b_compatible {I X Y : Type} (gl : b_gluing_data I X Y) (f : X → Y) :=
  ∀ {i : I} (u : gl.part i), f (gl.map u) = gl.f u

-- existence of compatible function
-- (uses choice, even though the result is unique)
def b_mk_function {I X Y : Type} (gl : b_gluing_data I X Y) : X → Y :=
  λ x, let hi := classical.some_spec (gl.hx x) in
       let u := classical.some hi in
       gl.f u

lemma b_mk_compatible {I X Y} (gl : b_gluing_data I X Y) :
  b_compatible gl (b_mk_function gl) :=
begin
  intros i v,
  let hi := classical.some_spec (gl.hx (gl.map v)),
  let u := classical.some hi,
  let hu := classical.some_spec hi, rw gl.hx₂ at hu,
  change gl.f u = gl.f v,
  obtain ⟨uij, hl, hr⟩ := hu, change gl.map₂l uij = u at hl,
  have key := gl.hglue uij, rwa [hl, hr] at key,
end

lemma b_compatible_unique {I X Y : Type} (gl : b_gluing_data I X Y) (f g : X → Y) :
  b_compatible gl f → b_compatible gl g → f = g :=
begin
  intros hf hg,
  ext, obtain ⟨i, ⟨u, hu⟩⟩ := gl.hx x,
  specialize hf u, specialize hg u, rw hu at *,
  rwa [hf, hg],
end

section b_refine

variables
  (I J X Y : Type)
  (CI : b_cover I X)
  (CJ : b_cover J X)
  (gl : b_gluing_data I X Y)

def b_refine : b_cover (I × J) X :=
 ⟨λ ⟨i, j⟩, {uv : CI i × CJ j // CI.map uv.fst = CJ.map uv.snd},
  λ ⟨i, j⟩ ⟨uv, h⟩, CI.map uv.fst,
  begin
    intro x,
    obtain ⟨i, ⟨u, hu⟩⟩ := CI.hx x,
    obtain ⟨j, ⟨v, hv⟩⟩ := CJ.hx x,
    use ⟨i, j⟩, use ⟨u, v⟩, rwa [hu, hv],
  end⟩

/-
Note: this is asymmetric: f is defined on Uᵢ ∩ Vⱼ
as the restriction of f from Uᵢ, not Vⱼ.
-/
def b_gl_refine : b_gluing_data (I × J) X Y := sorry
/-
  ⟨ -- U, f, hglue
    b_refine I J X CI CJ, -- U
    λ ⟨i, j⟩ ⟨x, hxij⟩,
    gl.f i ⟨x, hxij.left⟩,
    λ ⟨i₁, j₁⟩ ⟨i₂, j₂⟩ x ⟨hxi₁, hxj₁⟩ ⟨hxi₂, hxj₂⟩,
    gl.hglue i₁ i₂ x hxi₁ hxi₂,
  ⟩
-/

end b_refine
end b_cover


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

import category_theory.functor
import .isomorphism

universes u v

namespace category_theory

section
variables {C : Type u} [𝒞 : category.{u v} C]
include 𝒞

def eq_to_iso {X Y : C} (p : X = Y) : X ≅ Y := by rw p

@[simp,ematch] lemma eq_to_iso_refl (X : C) : eq_to_iso (eq.refl X) = (iso.refl X) := rfl

@[simp,ematch] lemma eq_to_iso_trans {X Y Z : C} (p : X = Y) (q : Y = Z) : (eq_to_iso p) ♢ (eq_to_iso q) = eq_to_iso (p.trans q) :=
begin /- obviously' says: -/ ext, induction q, induction p, dsimp at *, simp at * end
end

namespace functor

universes u₁ v₁ u₂ v₂

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

@[simp,ematch] lemma eq_to_iso (F : C ↝ D) {X Y : C} (p : X = Y) : F.on_isos (eq_to_iso p) = eq_to_iso (congr_arg F.obj p) :=
begin /- obviously says: -/ ext, induction p, dsimp at *, simp at * end
end functor
end category_theory