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

import Lean.Elab.Tactic.Basic

import Flows.Groundwork

open Lean Parser.Tactic Elab Elab.Tactic Meta

-- From mathlib4
namespace Lean.Expr
/-- If the expression is a constant, return that name. Otherwise return `Name.anonymous`. -/
def constName (e : Expr) : Name :=
e.constName?.getD Name.anonymous

/-- Return the function (name) and arguments of an application. -/
def getAppFnArgs (e : Expr) : Name × Array Expr :=
  Expr.withApp e λ e a => (e.constName, a)

end Lean.Expr
-- End of copied block

namespace Tactic.SolveSet

section Lemmas

variable {α : Type u}

def general_union (l : List (Fintype α)) : Fintype α := List.foldl HasUnion.union ∅ l

theorem in_singleton (a : Fintype α) : a ⊆ general_union [a] :=
  Fintype.included_union_l _ Fintype.included_refl

theorem included_of_included_l (a b c : Fintype α) (h : a ⊆ b) : a ⊆ b ∪ c := sorry
theorem included_of_included_r (a b c : Fintype α) (h : a ⊆ c) : a ⊆ b ∪ c := sorry

theorem union_included (a b c : Fintype α) (h : a ⊆ c) (h' : b ⊆ c) : a ∪ b ⊆ c := sorry

end Lemmas

structure Cache :=
  α : Expr
  univ : Level

structure State :=
  atoms : Array Expr := #[]
  numAtoms : Nat := 0

inductive SetExpr : Type :=
  | void
  | atom (i : Nat)
  | union (l : SetExpr) (r : SetExpr)

instance : Inhabited SetExpr := Inhabited.mk (SetExpr.void)

abbrev SolveM := ReaderT Cache <| StateRefT State MetaM

def SolveM.run (ty : Expr) (m : SolveM α) : MetaM α := do
  let Level.succ u _ ← getLevel ty | throwError "fail"
  (m {α := ty, univ := u }).run' {}

def mkApp (f : Name) (args : Array Expr) : SolveM Expr := do
  let c ← read
  pure $ mkAppN (mkConst f [c.univ]) (#[c.α] ++ args)

def addAtom (e : Expr) : SolveM Nat := do
  let c ← get
  for i in [:c.numAtoms] do
    if ← isDefEq e c.atoms[i] then
      return i
  modify λ c => { c with atoms := c.atoms.push e, numAtoms := c.numAtoms + 1 }
  return c.numAtoms

def getAtomIndex (e : Expr) : SolveM Nat := do
  let c ← get
  for i in [:c.numAtoms] do
    if ← isDefEq e c.atoms[i] then
      return i
  throwError "Atom not found -- this is a bug"

def isAtom (e : Expr) : SolveM Bool := do
  let c ← get
  for i in [:c.numAtoms] do
    if ← isDefEq e c.atoms[i] then
      return true
  return false

def getAtom (i : Nat) : SolveM Expr := do
  let c ← get
  return c.atoms[i]

-- Assumes l and r are ordered according to their first coordinate
partial def concat_map_assocs (l r : List (Nat × Expr)) (f g : Nat → Expr → SolveM Expr) :
  SolveM (List (Nat × Expr)) := go l r [] >>= pure ∘ List.reverse
  where go l r acc :
    SolveM (List (Nat × Expr)) := match (l, r) with
    | ([], []) => pure acc
    | ([], (j, eᵣ) :: r') => do go [] r' <| (j, ← g j eᵣ) :: acc
    | ((i, eₗ) :: l', []) => do go l' [] <| (i, ← f i eₗ) :: acc
    | ((i, eₗ) :: l', (j, eᵣ) :: r') =>
      if i < j then do go l' r <| (i, ← f i eₗ) :: acc
      else if i == j then do go l' r' <| (i, ← f i eₗ) :: acc
      else do go l r' <| (j, ← g j eᵣ) :: acc

partial def atomize (e : Expr) : SolveM (List (Nat × Expr)) :=
  match e.getAppFnArgs with
  | (``EmptyCollection.emptyCollection, #[_, _]) => pure []
  | (``HasUnion.union, #[_, _, eₗ, eᵣ]) => do
    let ml ← atomize eₗ
    let mr ← atomize eᵣ
    let process_l i included : SolveM Expr := do
        let a ← getAtom i
        mkApp ``included_of_included_l #[a, eₗ, eᵣ, included]
    let process_r j included : SolveM Expr := do
        let a ← getAtom j
        mkApp ``included_of_included_r #[a, eₗ, eᵣ, included]
    return (← concat_map_assocs ml mr process_l process_r)
  | _ => do
    let i ← addAtom e
    return [(i, ← mkApp ``Fintype.included_refl #[e])]

partial def prove_included (atomics : Array Expr) (l r : Expr) : SolveM Expr :=
  go l r
  where go l r : SolveM Expr := match l.getAppFnArgs with
    | (``EmptyCollection.emptyCollection, #[_, _]) =>
      mkApp ``Fintype.empty_included #[r]
    | (``HasUnion.union, #[_, _, eₗ, eᵣ]) => do
      let pₗ ← go eₗ r
      let pᵣ ← go eᵣ r
      mkApp ``union_included #[eₗ, eᵣ, r, pₗ, pᵣ]
    | _ => do
      let i ← getAtomIndex l
      pure atomics[i]

partial def check_atoms (e : Expr) : SolveM Bool :=
  match e.getAppFnArgs with
  | (``EmptyCollection.emptyCollection, #[_, _]) => pure true
  | (``HasUnion.union, #[_, _, eₗ, eᵣ]) => do
    return (← check_atoms eₗ) && (← check_atoms eᵣ)
  | _ => isAtom e

def solve_sets (l r : Expr) : SolveM Expr := do
  let atoms := Array.mk
    <| List.map (λ x => x.2)
    <| ← atomize r
  if !(← check_atoms l) then
    throwError "Some atomic formulas on the left aren't included in the right"
  let p ← prove_included atoms l r
  return p

elab "solve_sets " : tactic => liftMetaMAtMain λ g => do
  match (← instantiateMVars (← getMVarDecl g).type).getAppFnArgs with
  | (``HasIncluded.included, #[ty, _, l, r]) =>
    let ty ← match ty.getAppFnArgs with
    | (``Fintype, #[a]) => pure a
    | _ => throwError "Expected Fintype"
    let p ← (solve_sets l r).run ty
    assignExprMVar g p
  | _ => throwError "solve_sets failed, expected an inclusion"

set_option trace.Elab.debug true in
def ex₁ (a b c : Fintype α) : ∅ ∪ b ∪ a ⊆ a ∪ ∅ ∪ b := by solve_sets

end Tactic.SolveSet


lemma eq_zero_of_add_right_eq_self {a b : mynat} : a + b = a → b = 0 :=
begin
intro h,
apply add_left_cancel a,
rw add_zero,
exact h,
end


/-
Copyright (c) 2015 Joe Hendrix. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Joe Hendrix, Sebastian Ullrich
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.vector2
import Mathlib.data.nat.basic
import Mathlib.PostPort

namespace Mathlib

/-!
# Basic operations on bitvectors

This is a work-in-progress, and contains additions to other theories.

This file was moved to mathlib from core Lean in the switch to Lean 3.20.0c. It is not fully in compliance with mathlib style standards.
-/

/-- `bitvec n` is a `vector` of `bool` with length `n`. -/
def bitvec (n : ℕ) := vector Bool n

namespace bitvec

/-- Create a zero bitvector -/
protected def zero (n : ℕ) : bitvec n := vector.repeat false n

/-- Create a bitvector of length `n` whose `n-1`st entry is 1 and other entries are 0. -/
protected def one (n : ℕ) : bitvec n := sorry

/-- Create a bitvector from another with a provably equal length. -/
protected def cong {a : ℕ} {b : ℕ} (h : a = b) : bitvec a → bitvec b := sorry

/-- `bitvec` specific version of `vector.append` -/
def append {m : ℕ} {n : ℕ} : bitvec m → bitvec n → bitvec (m + n) := vector.append

/-! ### Shift operations -/

/-- `shl x i` is the bitvector obtained by left-shifting `x` `i` times and padding with `ff`.
If `x.length < i` then this will return the all-`ff`s bitvector. -/
def shl {n : ℕ} (x : bitvec n) (i : ℕ) : bitvec n :=
  bitvec.cong sorry (vector.append (vector.drop i x) (vector.repeat false (min n i)))

/-- `fill_shr x i fill` is the bitvector obtained by right-shifting `x` `i` times and then
padding with `fill : bool`. If `x.length < i` then this will return the constant `fill`
bitvector. -/
def fill_shr {n : ℕ} (x : bitvec n) (i : ℕ) (fill : Bool) : bitvec n :=
  bitvec.cong sorry (vector.append (vector.repeat fill (min n i)) (vector.take (n - i) x))

/-- unsigned shift right -/
def ushr {n : ℕ} (x : bitvec n) (i : ℕ) : bitvec n := fill_shr x i false

/-- signed shift right -/
def sshr {m : ℕ} : bitvec m → ℕ → bitvec m := sorry

/-! ### Bitwise operations -/

/-- bitwise not -/
/-- bitwise and -/
def not {n : ℕ} : bitvec n → bitvec n := vector.map bnot

/-- bitwise or -/
def and {n : ℕ} : bitvec n → bitvec n → bitvec n := vector.map₂ band

/-- bitwise xor -/
def or {n : ℕ} : bitvec n → bitvec n → bitvec n := vector.map₂ bor

def xor {n : ℕ} : bitvec n → bitvec n → bitvec n := vector.map₂ bxor

/-! ### Arithmetic operators -/

/-- `xor3 x y c` is `((x XOR y) XOR c)`. -/
/-- `carry x y c` is `x && y || x && c || y && c`. -/
protected def xor3 (x : Bool) (y : Bool) (c : Bool) : Bool := bxor (bxor x y) c

protected def carry (x : Bool) (y : Bool) (c : Bool) : Bool := x && y || x && c || y && c

/-- `neg x` is the two's complement of `x`. -/
protected def neg {n : ℕ} (x : bitvec n) : bitvec n :=
  let f : Bool → Bool → Bool × Bool := fun (y c : Bool) => (y || c, bxor y c);
  prod.snd (vector.map_accumr f x false)

/-- Add with carry (no overflow) -/
def adc {n : ℕ} (x : bitvec n) (y : bitvec n) (c : Bool) : bitvec (n + 1) :=
  let f : Bool → Bool → Bool → Bool × Bool :=
    fun (x y c : Bool) => (bitvec.carry x y c, bitvec.xor3 x y c);
  sorry

/-- The sum of two bitvectors -/
protected def add {n : ℕ} (x : bitvec n) (y : bitvec n) : bitvec n := vector.tail (adc x y false)

/-- Subtract with borrow -/
def sbb {n : ℕ} (x : bitvec n) (y : bitvec n) (b : Bool) : Bool × bitvec n :=
  let f : Bool → Bool → Bool → Bool × Bool :=
    fun (x y c : Bool) => (bitvec.carry (!x) y c, bitvec.xor3 x y c);
  vector.map_accumr₂ f x y b

/-- The difference of two bitvectors -/
protected def sub {n : ℕ} (x : bitvec n) (y : bitvec n) : bitvec n := prod.snd (sbb x y false)

protected instance has_zero {n : ℕ} : HasZero (bitvec n) := { zero := bitvec.zero n }

protected instance has_one {n : ℕ} : HasOne (bitvec n) := { one := bitvec.one n }

protected instance has_add {n : ℕ} : Add (bitvec n) := { add := bitvec.add }

protected instance has_sub {n : ℕ} : Sub (bitvec n) := { sub := bitvec.sub }

protected instance has_neg {n : ℕ} : Neg (bitvec n) := { neg := bitvec.neg }

/-- The product of two bitvectors -/
protected def mul {n : ℕ} (x : bitvec n) (y : bitvec n) : bitvec n :=
  let f : bitvec n → Bool → bitvec n := fun (r : bitvec n) (b : Bool) => cond b (r + r + y) (r + r);
  list.foldl f 0 (vector.to_list x)

protected instance has_mul {n : ℕ} : Mul (bitvec n) := { mul := bitvec.mul }

/-! ### Comparison operators -/

/-- `uborrow x y` returns `tt` iff the "subtract with borrow" operation on `x`, `y` and `ff`
required a borrow. -/
def uborrow {n : ℕ} (x : bitvec n) (y : bitvec n) : Bool := prod.fst (sbb x y false)

/-- unsigned less-than proposition -/
/-- unsigned greater-than proposition -/
def ult {n : ℕ} (x : bitvec n) (y : bitvec n) := ↥(uborrow x y)

def ugt {n : ℕ} (x : bitvec n) (y : bitvec n) := ult y x

/-- unsigned less-than-or-equal-to proposition -/
/-- unsigned greater-than-or-equal-to proposition -/
def ule {n : ℕ} (x : bitvec n) (y : bitvec n) := ¬ult y x

def uge {n : ℕ} (x : bitvec n) (y : bitvec n) := ule y x

/-- `sborrow x y` returns `tt` iff `x < y` as two's complement integers -/
def sborrow {n : ℕ} : bitvec n → bitvec n → Bool := sorry

/-- signed less-than proposition -/
/-- signed greater-than proposition -/
def slt {n : ℕ} (x : bitvec n) (y : bitvec n) := ↥(sborrow x y)

/-- signed less-than-or-equal-to proposition -/
def sgt {n : ℕ} (x : bitvec n) (y : bitvec n) := slt y x

/-- signed greater-than-or-equal-to proposition -/
def sle {n : ℕ} (x : bitvec n) (y : bitvec n) := ¬slt y x

def sge {n : ℕ} (x : bitvec n) (y : bitvec n) := sle y x

/-! ### Conversion to `nat` and `int` -/

/-- Create a bitvector from a `nat` -/
protected def of_nat (n : ℕ) : ℕ → bitvec n := sorry

/-- Create a bitvector in the two's complement representation from an `int` -/
protected def of_int (n : ℕ) : ℤ → bitvec (Nat.succ n) := sorry

/-- `add_lsb r b` is `r + r + 1` if `b` is `tt` and `r + r` otherwise. -/
def add_lsb (r : ℕ) (b : Bool) : ℕ := r + r + cond b 1 0

/-- Given a `list` of `bool`s, return the `nat` they represent as a list of binary digits. -/
def bits_to_nat (v : List Bool) : ℕ := list.foldl add_lsb 0 v

/-- Return the natural number encoded by the input bitvector -/
protected def to_nat {n : ℕ} (v : bitvec n) : ℕ := bits_to_nat (vector.to_list v)

theorem bits_to_nat_to_list {n : ℕ} (x : bitvec n) :
    bitvec.to_nat x = bits_to_nat (vector.to_list x) :=
  rfl

-- mul_left_comm

theorem to_nat_append {m : ℕ} (xs : bitvec m) (b : Bool) :
    bitvec.to_nat (vector.append xs (b::ᵥvector.nil)) =
        bitvec.to_nat xs * bit0 1 + bitvec.to_nat (b::ᵥvector.nil) :=
  sorry

theorem bits_to_nat_to_bool (n : ℕ) :
    bitvec.to_nat (to_bool (n % bit0 1 = 1)::ᵥvector.nil) = n % bit0 1 :=
  sorry

theorem of_nat_succ {k : ℕ} {n : ℕ} :
    bitvec.of_nat (Nat.succ k) n =
        vector.append (bitvec.of_nat k (n / bit0 1)) (to_bool (n % bit0 1 = 1)::ᵥvector.nil) :=
  rfl

theorem to_nat_of_nat {k : ℕ} {n : ℕ} : bitvec.to_nat (bitvec.of_nat k n) = n % bit0 1 ^ k := sorry

/-- Return the integer encoded by the input bitvector -/
protected def to_int {n : ℕ} : bitvec n → ℤ := sorry

/-! ### Miscellaneous instances -/

protected instance has_repr (n : ℕ) : has_repr (bitvec n) := has_repr.mk repr

end bitvec

protected instance bitvec.ult.decidable {n : ℕ} {x : bitvec n} {y : bitvec n} :
    Decidable (bitvec.ult x y) :=
  bool.decidable_eq (bitvec.uborrow x y) tt

protected instance bitvec.ugt.decidable {n : ℕ} {x : bitvec n} {y : bitvec n} :
    Decidable (bitvec.ugt x y) :=
  bool.decidable_eq (bitvec.uborrow y x) tt

end Mathlib


import combinatorics.simple_graph.metric
import graph_theory.path

namespace simple_graph
namespace cayley

structure genset (G : Type*) [group G] :=
  (els : finset G)
  (sym : ∀ {s : G}, s ∈ els → s⁻¹ ∈ els)
  (gen : subgroup.closure (coe els) = (⊤ : subgroup G))
  (nem : els.nonempty)
  (irr : (1:G) ∉ els)

variables {G : Type*} [group G] {S S1 S2 : genset G} {a x y z : G}

instance : has_mem G (genset G) := ⟨λ a s, a ∈ s.els⟩

def genset.adj (S : genset G) (x y : G) := x⁻¹ * y ∈ S

lemma shift_adj ⦃x y⦄ (h : S.adj x y) : S.adj (a*x) (a*y) :=
by { unfold genset.adj, convert h using 1, group }

@[symm] lemma adj_symm ⦃x y⦄ (h : S.adj x y) : S.adj y x
:= by { unfold genset.adj, convert S.sym h, group }

def Cay (S : genset G) : simple_graph G :=
{ adj := S.adj,
  symm := adj_symm,
  loopless := λ x h, S.irr (by { convert h, group }) }

def left_shift (a : G) : Cay S →g Cay S := ⟨(*) a, shift_adj⟩

lemma shift : reachable (Cay S) x y → reachable (Cay S) (a*x) (a*y) :=
nonempty.map (walk.map (left_shift a))

lemma inv {h : reachable (Cay S) 1 x} : reachable (Cay S) 1 x⁻¹ :=
by { symmetry, convert @shift _ _ _ x⁻¹ _ _ h; group }

lemma reachable_mp : reachable (Cay S) 1 x :=
begin
  apply subgroup.closure_induction,
  { rw S.gen, trivial },
  { intros y h, apply reachable.step, simpa only [Cay,genset.adj,one_inv,one_mul] },
  { refl },
  { intros u v h1 h2, refine reachable.trans h1 _, convert shift h2, group },
  { intros y h, apply inv, exact h }
end

theorem Cay.connected : connected (Cay S) :=
⟨λ x y, reachable_mp.symm.trans reachable_mp, ⟨1⟩⟩

lemma covariant : (Cay S).dist (a*x) (a*y) = (Cay S).dist x y :=
begin
  have lem : ∀ a {x y}, (Cay S).dist (a*x) (a*y) ≤ (Cay S).dist x y :=
  by { intros a x y, obtain ⟨p,hp⟩ := Cay.connected.exists_walk_of_dist x y,
    rw [←hp,←walk.length_map], exact dist_le (p.map (left_shift a)) },
  apply le_antisymm (lem a), convert lem a⁻¹, group
end

noncomputable def distorsion (S1 S2 : genset G) :=
classical.some (finset.max_of_nonempty (S1.nem.image ((Cay S2).dist 1)))

lemma distorsion_spec : distorsion S1 S2 ∈ (finset.image ((Cay S2).dist 1) S1.els).max :=
classical.some_spec (finset.max_of_nonempty (S1.nem.image ((Cay S2).dist 1)))

lemma distorsion_le {h : (Cay S1).adj x y} : (Cay S2).dist x y ≤ distorsion S1 S2 :=
begin
  refine finset.le_max_of_mem _ distorsion_spec,
  rw [finset.mem_image], refine ⟨x⁻¹ * y, h, _⟩, convert covariant, group
end

lemma lipschitz : (Cay S2).dist x y <= (distorsion S1 S2) * (Cay S1).dist x y :=
begin
  obtain ⟨p,hp⟩ := (@Cay.connected _ _ S1).exists_walk_of_dist x y, rw <-hp, clear hp,
  induction p with u u v w h p ih,
  { simp only [dist_self, walk.length_nil, mul_zero] },
  { simp only [walk.length_cons], transitivity (Cay S2).dist u v + (Cay S2).dist v w,
    apply Cay.connected.dist_triangle, rw [mul_add,mul_one,add_comm],
    apply add_le_add ih, apply distorsion_le, exact h }
end

end cayley
end simple_graph


import Mathlib.Data.List.Perm
import WaterSortPuzzle.Utils

namespace WaterSortPuzzle

/-!
# 水排序拼图的问题定义
-/

/-!
## 定义：颜色
-/

abbrev Color (m : Nat) := Fin m

/-!
## 定义：试管
-/

structure Tube (m h : Nat) where
  val : List (Color m)
  h_volume : val.length ≤ h

namespace Tube

variable (t : Tube m h)

def length : Nat := t.val.length

def sameColorAux : List (Color m) → Prop
| [] => True
| [_] => true
| c₁ :: c₂ :: cs => c₁ = c₂ ∧ sameColorAux (c₂ :: cs)

def sameColor : Prop := sameColorAux t.val

def isEmpty : Prop := t.val = []

instance : Decidable t.isEmpty :=
  if h : t.val = [] then isTrue h else isFalse h

def isFull : Prop := t.length = h

instance : Decidable t.isFull :=
  if h' : t.length = h then isTrue h' else isFalse h'

def topColor (h : ¬t.isEmpty) : Color m :=
  match h' : t.val with
  | [] => absurd h' h
  | c :: cs => c

def topColor? : Option (Color m) :=
  if h : t.isEmpty then none else topColor t h

def empty : Tube m h := ⟨ [], by simp ⟩

def fullSameColor (i : Fin m) : Tube m h := ⟨ List.replicate h i, by simp ⟩

end Tube

/-!
## 定义：试管组

关键类型：

- `ColorPerm`: 试管颜色打乱的命题。
- `ColorComplete`: 试管颜色完备的命题。
- `Tubes`: 试管组
-/

/--
实际上是二维列表的打乱，因而在符号上选择 `~²`
-/
def colorPerm (ts₁ ts₂ : List (Tube m h)) : Prop :=
  let f₁ := ts₁.map Tube.val |>.join
  let f₂ := ts₂.map Tube.val |>.join
  f₁ ~ f₂

infixl:50 " ~² " => colorPerm

theorem colorPerm.mod_h :
  ∀ {ts₁ ts₂ : List (Tube m h)} {i : Fin m}, ts₁ ~² ts₂ →
    let f₁ := ts₁.map Tube.val |>.join ;
    let f₂ := ts₂.map Tube.val |>.join ;
    (f₁.count i) % h = (f₂.count i) % h := by
  intro ts₁ ts₂ i h
  simp_all [List.join, List.count, List.countp, colorPerm]

/--
试管颜色是否完备。有三种不同情况：

- 空列表 是完备的
- 完备列表 加上 装满同一种颜色的试管 是完备的
- 完备列表 打乱颜色顺序是完备的
-/
inductive ColorComplete : List (Tube m h) → Prop
| nil : ColorComplete []
| cons : ColorComplete ts → ColorComplete ((.fullSameColor i)::ts)
| perm : ColorComplete ts → ts ~² ts' → ColorComplete ts'

theorem ColorComplete.mod_h : ∀ {ts : List (Tube m h)}, ColorComplete ts →
  let f := ts.map Tube.val |>.join ;
  ∀ i : Fin m, (f.count i) % h = 0 := by
    intro ts colorComplete_ts
    simp
    induction colorComplete_ts <;> simp [List.count_join]
    . intro i
      exact Nat.zero_mod h
    . rename_i a b c d
      intro i
      sorry
    . sorry

structure Tubes (m h n : Nat) where
  val : List (Tube m h)
  h_num : val.length = n
  h_colorComplete : ColorComplete val

namespace Tubes

variable (ts : Tubes m h n)

def length := ts.val.length

instance : Membership (Tube m h) (Tubes m h n) where
  mem t ts := t ∈ ts.val

def sorted : Prop :=
  ∀ t, t ∈ ts → t.sameColor ∧ t.isFull

def get (m : Fin n) :=
  have m : Fin ts.val.length := by
    rw [ts.h_num]
    assumption
  ts.val.get m

def set (i : Fin n) (t : Tube m h) (hc : ColorComplete (ts.val.set i t)) : Tubes m h n :=
  {
    val := ts.val.set i t
    h_num := by
      rw [List.length_set ts.val i t, ts.h_num]
    h_colorComplete := hc
  }

end Tubes

/-!
## 定义：倾倒过程
-/

/-- 描述倾倒过程 -/
structure PourStep (n : Nat) where
  source : Fin n
  sink : Fin n

/-- 进行一次倾倒 -/
def PourStep.pour (ts : Tubes m h n) (s : PourStep n) : Tubes m h n :=
  let t₁ := ts.get s.source
  let t₂ := ts.get s.sink
  let (t₁', t₂') := match t₁, t₂ with
  | ⟨[], _⟩ , _ => (t₁, t₂)
  | ⟨c::cs, h₁⟩ , ⟨[], h₂⟩ =>
    -- 一些定理证明
    have hc : (c::cs).length > 0  := cs.length_cons_gt_zero c
    have hgt : h > 0              := Nat.lt_of_lt_of_le hc h₁
    have hge : h ≥ 1              := Nat.ge_one_of_gt_zero hgt
    have hlt : cs.length < h      := Nat.lt_of_lt_of_le (cs.length_cons_lt c) h₁
    have hle : cs.length ≤ h      := Nat.le_of_lt hlt
    have hle' : [c].length ≤ h    := hge
    (⟨cs, hle⟩, ⟨[c], hle'⟩)
  | ⟨c₁::cs₁, h₁⟩, ⟨c₂::cs₂, h₂⟩ =>
    if c₁ = c₂ then
      if h' : (c₂::cs₂).length + 1 ≤ h then
        -- 一些定理证明
        have hlt : cs₁.length < h             := Nat.lt_of_lt_of_le (cs₁.length_cons_lt c₁) h₁
        have hle : cs₁.length ≤ h             := Nat.le_of_lt hlt
        have hle' : (c₁::c₂::cs₂).length ≤ h  := by simp only [List.length_cons c₁ (c₂::cs₂), h']
        (⟨cs₁, hle⟩, ⟨c₁::c₂::cs₂, hle'⟩)
      else
        (⟨c₁::cs₁, h₁⟩, ⟨c₂::cs₂, h₂⟩)
    else
      (⟨c₁::cs₁, h₁⟩, ⟨c₂::cs₂, h₂⟩)
  ts
  |>.set s.source t₁' (by sorry)
  |>.set s.sink t₂' sorry

/-- 进行一系列倾倒过程 -/
def Tubes.apply (ts : Tubes m h n) (ss : List (PourStep n)) : Tubes m h n :=
  ss.foldl (λ acc s => s.pour acc) ts

/-!
## 定义：水排序问题

关键类型：

- `Puzzle`: 问题的定义，包括 初始状态及约束、空试管数量 等配置。
- `Solution`: 问题的解，包含一系列步骤，以及正确性证明。

目标即为寻找到一个函数具有 `(p : Puzzle m h n) → Solution p` 的类型。
-/

/-- 问题定义 -/
structure Puzzle (m h n : Nat) where
  /-- 初始状态 -/
  initial : Tubes m h n
  /-- 空试管的数量 -/
  k : Nat := 0
  /-- 初始状态要求所有试管为满的 -/
  h_full : ∀ t, t ∈ initial → t.isFull

/-- 问题解的定义 -/
structure Solution (p : Puzzle m h n) where
  /-- 一系列解的步骤 -/
  steps : List (PourStep n)
  /-- 正确性证明 -/
  h_sorted : (p.initial.apply steps).sorted

end WaterSortPuzzle


/-
Copyright (c) 2016 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Leonardo de Moura
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.data.nat.basic

universes l

namespace Mathlib

def is_valid_char (n : ℕ) :=
  n <
      bit0
        (bit0
          (bit0
            (bit0
              (bit0 (bit0 (bit0 (bit0 (bit0 (bit0 (bit0 (bit1 (bit1 (bit0 (bit1 1)))))))))))))) ∨
    bit1
          (bit1
            (bit1
              (bit1
                (bit1 (bit1 (bit1 (bit1 (bit1 (bit1 (bit1 (bit1 (bit1 (bit0 (bit1 1)))))))))))))) <
        n ∧
      n <
        bit0
          (bit0
            (bit0
              (bit0
                (bit0
                  (bit0
                    (bit0
                      (bit0
                        (bit0
                          (bit0
                            (bit0
                              (bit0
                                (bit0 (bit0 (bit0 (bit0 (bit1 (bit0 (bit0 (bit0 1)))))))))))))))))))

theorem is_valid_char_range_1 (n : ℕ)
    (h :
      n <
        bit0
          (bit0
            (bit0
              (bit0
                (bit0 (bit0 (bit0 (bit0 (bit0 (bit0 (bit0 (bit1 (bit1 (bit0 (bit1 1))))))))))))))) :
    is_valid_char n :=
  Or.inl h

theorem is_valid_char_range_2 (n : ℕ)
    (h₁ :
      bit1
          (bit1
            (bit1
              (bit1
                (bit1 (bit1 (bit1 (bit1 (bit1 (bit1 (bit1 (bit1 (bit1 (bit0 (bit1 1)))))))))))))) <
        n)
    (h₂ :
      n <
        bit0
          (bit0
            (bit0
              (bit0
                (bit0
                  (bit0
                    (bit0
                      (bit0
                        (bit0
                          (bit0
                            (bit0
                              (bit0
                                (bit0
                                  (bit0 (bit0 (bit0 (bit1 (bit0 (bit0 (bit0 1)))))))))))))))))))) :
    is_valid_char n :=
  Or.inr { left := h₁, right := h₂ }

/-- The `char` type represents an unicode scalar value.
    See http://www.unicode.org/glossary/#unicode_scalar_value). -/
structure char where
  val : ℕ
  valid : is_valid_char val

protected instance char.has_sizeof : SizeOf char := { sizeOf := fun (c : char) => char.val c }

namespace char

protected def lt (a : char) (b : char) := val a < val b

protected def le (a : char) (b : char) := val a ≤ val b

protected instance has_lt : HasLess char := { Less := char.lt }

protected instance has_le : HasLessEq char := { LessEq := char.le }

protected instance decidable_lt (a : char) (b : char) : Decidable (a < b) :=
  nat.decidable_lt (val a) (val b)

protected instance decidable_le (a : char) (b : char) : Decidable (a ≤ b) :=
  nat.decidable_le (val a) (val b)

/-
We cannot use tactics dec_trivial or comp_val here because the tactic framework has not been defined yet.
We also do not use `zero_lt_succ _` as a proof term because this proof may not be trivial to check by
external type checkers. See discussion at: https://github.com/leanprover/tc/issues/8
-/

theorem zero_lt_d800 :
    0 <
        bit0
          (bit0
            (bit0
              (bit0
                (bit0 (bit0 (bit0 (bit0 (bit0 (bit0 (bit0 (bit1 (bit1 (bit0 (bit1 1)))))))))))))) :=
  sorry

def of_nat (n : ℕ) : char :=
  dite (is_valid_char n) (fun (h : is_valid_char n) => mk n h)
    fun (h : ¬is_valid_char n) => mk 0 sorry

def to_nat (c : char) : ℕ := val c

theorem eq_of_veq {c : char} {d : char} : val c = val d → c = d := sorry

theorem veq_of_eq {c : char} {d : char} : c = d → val c = val d := sorry

theorem ne_of_vne {c : char} {d : char} (h : val c ≠ val d) : c ≠ d :=
  fun (h' : c = d) => absurd (veq_of_eq h') h

theorem vne_of_ne {c : char} {d : char} (h : c ≠ d) : val c ≠ val d :=
  fun (h' : val c = val d) => absurd (eq_of_veq h') h

end char

protected instance char.decidable_eq : DecidableEq char :=
  fun (i j : char) =>
    decidable_of_decidable_of_iff (nat.decidable_eq (char.val i) (char.val j)) sorry

protected instance char.inhabited : Inhabited char :=
  { default := char.of_nat (bit1 (bit0 (bit0 (bit0 (bit0 (bit0 1)))))) }

end Mathlib


/-
  Stalk of rings.

  https://stacks.math.columbia.edu/tag/007L
  (just says that the category of rings is a type of algebraic structure)
-/

import topology.basic
import sheaves.stalk
import sheaves.presheaf_of_rings

universes u v w

open topological_space

section stalk_of_rings

variables {α : Type u} [topological_space α]
variables (F : presheaf_of_rings α) (x : α)

definition stalk_of_rings := stalk F.to_presheaf x

end stalk_of_rings

-- Stalks are rings.

section stalk_of_rings_is_ring

parameters {α : Type u} [topological_space α]
parameters (F : presheaf_of_rings α) (x : α)

-- Add.

private def stalk_of_rings_add_aux :
stalk.elem F.to_presheaf x →
stalk.elem F.to_presheaf x →
stalk F.to_presheaf x :=
λ s t,
⟦{U := s.U ∩ t.U,
HxU := ⟨s.HxU, t.HxU⟩,
s := F.res s.U _ (set.inter_subset_left _ _) s.s +
     F.res t.U _ (set.inter_subset_right _ _) t.s}⟧

instance stalk_of_rings_has_add : has_add (stalk_of_rings F x) :=
{ add := quotient.lift₂ (stalk_of_rings_add_aux) $
  begin
    intros a1 a2 b1 b2 H1 H2,
    let F' := F.to_presheaf,
    rcases H1 with ⟨U1, ⟨HxU1, ⟨HU1a1U, HU1b1U, HresU1⟩⟩⟩,
    rcases H2 with ⟨U2, ⟨HxU2, ⟨HU2a2U, HU2b2U, HresU2⟩⟩⟩,
    apply quotient.sound,
    use [U1 ∩ U2, ⟨HxU1, HxU2⟩],
    use [set.inter_subset_inter HU1a1U HU2a2U, set.inter_subset_inter HU1b1U HU2b2U],
    repeat { rw (F.res_is_ring_hom _ _ _).map_add },
    have HresU1' :
        (F'.res U1 (U1 ∩ U2) (set.inter_subset_left _ _) ((F'.res a1.U U1 HU1a1U) (a1.s))) =
        (F'.res U1 (U1 ∩ U2) (set.inter_subset_left _ _) ((F'.res b1.U U1 HU1b1U) (b1.s)))
    := by rw HresU1,
    have HresU2' :
        (F'.res U2 (U1 ∩ U2) (set.inter_subset_right _ _) ((F'.res a2.U U2 HU2a2U) (a2.s))) =
        (F'.res U2 (U1 ∩ U2) (set.inter_subset_right _ _) ((F'.res b2.U U2 HU2b2U) (b2.s)))
    := by rw HresU2,
    repeat { rw ←(presheaf.Hcomp' F') at HresU1' },
    repeat { rw ←(presheaf.Hcomp' F') at HresU2' },
    repeat { rw ←(presheaf.Hcomp' F') },
    rw [HresU1', HresU2'],
  end }

instance stalk_of_rings_add_semigroup : add_semigroup (stalk_of_rings F x) :=
{ add := stalk_of_rings_has_add.add,
  add_assoc :=
  begin
    intros a b c,
    refine quotient.induction_on₃ a b c _,
    rintros ⟨U, HxU, sU⟩ ⟨V, HxV, sV⟩ ⟨W, HxW, sW⟩,
    have HUVWsub : U ∩ V ∩ W ⊆ U ∩ (V ∩ W)
    := λ x ⟨⟨HxU, HxV⟩, HxW⟩, ⟨HxU, ⟨HxV, HxW⟩⟩,
    apply quotient.sound,
    use [U ∩ V ∩ W, ⟨⟨HxU, HxV⟩, HxW⟩],
    use [set.subset.refl _, HUVWsub],
    dsimp,
    repeat { rw (F.res_is_ring_hom _ _ _).map_add },
    repeat { erw ←presheaf.Hcomp' },
    rw add_assoc,
  end }

instance stalk_of_rings_add_comm_semigroup : add_comm_semigroup (stalk_of_rings F x) :=
{ add_comm :=
  begin
    intros a b,
    refine quotient.induction_on₂ a b _,
    rintros ⟨U, HxU, sU⟩ ⟨V, HxV, sV⟩,
    apply quotient.sound,
    have HUVUV : U ∩ V ⊆ U ∩ V := λ x HxUV, HxUV,
    have HUVVU : U ∩ V ⊆ V ∩ U := λ x ⟨HxU, HxV⟩, ⟨HxV, HxU⟩,
    use [U ∩ V, ⟨HxU, HxV⟩, HUVUV, HUVVU],
    repeat { rw (F.res_is_ring_hom _ _ _).map_add },
    repeat { rw ←presheaf.Hcomp' },
    rw add_comm,
  end,
  ..stalk_of_rings_add_semigroup }

-- Zero.

private def stalk_of_rings_zero : stalk_of_rings F x :=
⟦{U := opens.univ, HxU := trivial, s:= 0}⟧

instance stalk_of_rings_has_zero : has_zero (stalk_of_rings F x) :=
{ zero := stalk_of_rings_zero }

instance stalk_of_rings_add_comm_monoid : add_comm_monoid (stalk_of_rings F x) :=
{ zero := stalk_of_rings_zero,
  zero_add :=
  begin
    intros a,
    refine quotient.induction_on a _,
    rintros ⟨U, HxU, sU⟩,
    apply quotient.sound,
    have HUsub : U ⊆ opens.univ ∩ U := λ x HxU, ⟨trivial, HxU⟩,
    use [U, HxU, HUsub, set.subset.refl U],
    repeat { rw (F.res_is_ring_hom _ _ _).map_add },
    repeat { rw ←presheaf.Hcomp' },
    erw (is_ring_hom.map_zero ((F.to_presheaf).res _ _ _));
    try { apply_instance },
    rw zero_add,
    refl,
  end,
  add_zero :=
  begin
    intros a,
    refine quotient.induction_on a _,
    rintros ⟨U, HxU, sU⟩,
    apply quotient.sound,
    have HUsub : U ⊆ U ∩ opens.univ := λ x HxU, ⟨HxU, trivial⟩,
    use [U, HxU, HUsub, set.subset.refl U],
    repeat { rw (F.res_is_ring_hom _ _ _).map_add },
    repeat { erw ←presheaf.Hcomp' },
    dsimp,
    erw (is_ring_hom.map_zero ((F.to_presheaf).res _ _ _));
    try { apply_instance },
    rw add_zero,
    refl,
  end,
  ..stalk_of_rings_add_comm_semigroup }

-- Neg.

private def stalk_sub_aux :
stalk.elem F.to_presheaf x →
stalk F.to_presheaf x :=
λ s, ⟦{U := s.U, HxU := s.HxU, s := -s.s}⟧

instance stalk_of_rings_has_neg : has_neg (stalk_of_rings F x) :=
{ neg := quotient.lift stalk_sub_aux $
  begin
    intros a b H,
    rcases H with ⟨U, ⟨HxU, ⟨HUaU, HUbU, HresU⟩⟩⟩,
    apply quotient.sound,
    use [U, HxU, HUaU, HUbU],
    repeat { rw @is_ring_hom.map_neg _ _ _ _ _ (F.res_is_ring_hom _ _ _) },
    rw HresU,
  end }

instance stalk_of_rings_add_comm_group : add_comm_group (stalk_of_rings F x) :=
{ neg := stalk_of_rings_has_neg.neg,
  add_left_neg :=
  begin
    intros a,
    refine quotient.induction_on a _,
    rintros ⟨U, HxU, sU⟩,
    apply quotient.sound,
    have HUUU : U ⊆ U ∩ U := λ x HxU, ⟨HxU, HxU⟩,
    have HUuniv : U ⊆ opens.univ := λ x HxU, trivial,
    use [U, HxU, HUUU, HUuniv],
    repeat { rw (F.res_is_ring_hom _ _ _).map_add },
    repeat { rw ←presheaf.Hcomp' },
    erw (is_ring_hom.map_neg ((F.to_presheaf).res _ _ _));
    try { apply_instance },
    rw add_left_neg,
    erw (is_ring_hom.map_zero ((F.to_presheaf).res _ _ _));
    try { apply_instance },
  end,
  ..stalk_of_rings_add_comm_monoid }

-- Mul.

private def stalk_of_rings_mul_aux :
stalk.elem F.to_presheaf x →
stalk.elem F.to_presheaf x →
stalk F.to_presheaf x :=
λ s t,
⟦{U := s.U ∩ t.U,
HxU := ⟨s.HxU, t.HxU⟩,
s := F.res s.U _ (set.inter_subset_left _ _) s.s *
     F.res t.U _ (set.inter_subset_right _ _) t.s}⟧

instance stalk_of_rings_has_mul : has_mul (stalk_of_rings F x) :=
{ mul := quotient.lift₂ (stalk_of_rings_mul_aux) $
  begin
    intros a1 a2 b1 b2 H1 H2,
    let F' := F.to_presheaf,
    rcases H1 with ⟨U1, ⟨HxU1, ⟨HU1a1U, HU1b1U, HresU1⟩⟩⟩,
    rcases H2 with ⟨U2, ⟨HxU2, ⟨HU2a2U, HU2b2U, HresU2⟩⟩⟩,
    apply quotient.sound,
    use [U1 ∩ U2, ⟨HxU1, HxU2⟩],
    use [set.inter_subset_inter HU1a1U HU2a2U, set.inter_subset_inter HU1b1U HU2b2U],
    repeat { rw (F.res_is_ring_hom _ _ _).map_mul },
    have HresU1' :
        (F'.res U1 (U1 ∩ U2) (set.inter_subset_left _ _) ((F'.res a1.U U1 HU1a1U) (a1.s))) =
        (F'.res U1 (U1 ∩ U2) (set.inter_subset_left _ _) ((F'.res b1.U U1 HU1b1U) (b1.s)))
    := by rw HresU1,
    have HresU2' :
        (F'.res U2 (U1 ∩ U2) (set.inter_subset_right _ _) ((F'.res a2.U U2 HU2a2U) (a2.s))) =
        (F'.res U2 (U1 ∩ U2) (set.inter_subset_right _ _) ((F'.res b2.U U2 HU2b2U) (b2.s)))
    := by rw HresU2,
    repeat { rw ←(presheaf.Hcomp' F') at HresU1' },
    repeat { rw ←(presheaf.Hcomp' F') at HresU2' },
    repeat { rw ←(presheaf.Hcomp' F') },
    rw [HresU1', HresU2'],
  end }

instance stalk_of_rings_mul_semigroup : semigroup (stalk_of_rings F x) :=
{ mul := stalk_of_rings_has_mul.mul,
  mul_assoc :=
  begin
    intros a b c,
    refine quotient.induction_on₃ a b c _,
    rintros ⟨U, HxU, sU⟩ ⟨V, HxV, sV⟩ ⟨W, HxW, sW⟩,
    have HUVWsub : U ∩ V ∩ W ⊆ U ∩ (V ∩ W)
    := λ x ⟨⟨HxU, HxV⟩, HxW⟩, ⟨HxU, ⟨HxV, HxW⟩⟩,
    apply quotient.sound,
    use [U ∩ V ∩ W, ⟨⟨HxU, HxV⟩, HxW⟩],
    use [set.subset.refl _, HUVWsub],
    repeat { rw (F.res_is_ring_hom _ _ _).map_mul },
    repeat { rw ←presheaf.Hcomp' },
    rw mul_assoc,
  end }

instance stalk_of_rings_mul_comm_semigroup : comm_semigroup (stalk_of_rings F x) :=
{ mul_comm :=
  begin
    intros a b,
    refine quotient.induction_on₂ a b _,
    rintros ⟨U, HxU, sU⟩ ⟨V, HxV, sV⟩,
    apply quotient.sound,
    have HUVUV : U ∩ V ⊆ U ∩ V := λ x HxUV, HxUV,
    have HUVVU : U ∩ V ⊆ V ∩ U := λ x ⟨HxU, HxV⟩, ⟨HxV, HxU⟩,
    use [U ∩ V, ⟨HxU, HxV⟩, HUVUV, HUVVU],
    repeat { rw (F.res_is_ring_hom _ _ _).map_mul },
    repeat { rw ←presheaf.Hcomp' },
    rw mul_comm,
  end,
  ..stalk_of_rings_mul_semigroup }

-- One.

private def stalk_of_rings_one : stalk_of_rings F x :=
⟦{U := opens.univ, HxU := trivial, s:= 1}⟧

instance stalk_of_rings_has_one : has_one (stalk_of_rings F x) :=
{ one := stalk_of_rings_one }

instance stalk_of_rings_mul_comm_monoid : comm_monoid (stalk_of_rings F x) :=
{ one := stalk_of_rings_one,
  one_mul :=
  begin
    intros a,
    refine quotient.induction_on a _,
    rintros ⟨U, HxU, sU⟩,
    apply quotient.sound,
    have HUsub : U ⊆ opens.univ ∩ U := λ x HxU, ⟨trivial, HxU⟩,
    use [U, HxU, HUsub, set.subset.refl U],
    repeat { rw (F.res_is_ring_hom _ _ _).map_mul },
    repeat { rw ←presheaf.Hcomp' },
    erw (is_ring_hom.map_one ((F.to_presheaf).res _ _ _));
    try { apply_instance },
    rw one_mul,
    refl,
  end,
  mul_one :=
  begin
    intros a,
    refine quotient.induction_on a _,
    rintros ⟨U, HxU, sU⟩,
    apply quotient.sound,
    have HUsub : U ⊆ U ∩ opens.univ := λ x HxU, ⟨HxU, trivial⟩,
    use [U, HxU, HUsub, set.subset.refl U],
    repeat { rw (F.res_is_ring_hom _ _ _).map_mul },
    repeat { rw ←presheaf.Hcomp' },
    dsimp,
    erw (is_ring_hom.map_one ((F.to_presheaf).res _ _ _));
    try { apply_instance },
    rw mul_one,
    refl,
  end,
  ..stalk_of_rings_mul_comm_semigroup }

-- Ring.

instance stalk_of_rings_is_comm_ring : comm_ring (stalk_of_rings F x) :=
{ left_distrib :=
  begin
    intros a b c,
    refine quotient.induction_on₃ a b c _,
    rintros ⟨U, HxU, sU⟩ ⟨V, HxV, sV⟩ ⟨W, HxW, sW⟩,
    have HUVWsub : U ∩ V ∩ W ⊆ U ∩ (V ∩ W)
    := λ x ⟨⟨HxU, HxV⟩, HxW⟩, ⟨HxU, ⟨HxV, HxW⟩⟩,
    have HUVWsub2 : U ∩ V ∩ W ⊆ U ∩ V ∩ (U ∩ W)
    := λ x ⟨⟨HxU, HxV⟩, HxW⟩, ⟨⟨HxU, HxV⟩, ⟨HxU, HxW⟩⟩,
    apply quotient.sound,
    use [U ∩ V ∩ W, ⟨⟨HxU, HxV⟩, HxW⟩, HUVWsub, HUVWsub2],
    repeat { rw (F.res_is_ring_hom _ _ _).map_mul },
    repeat { rw (F.res_is_ring_hom _ _ _).map_add },
    repeat { rw ←presheaf.Hcomp' },
    repeat { rw (F.res_is_ring_hom _ _ _).map_mul },
    repeat { rw (F.res_is_ring_hom _ _ _).map_add },
    repeat { rw ←presheaf.Hcomp' },
    rw mul_add,
  end,
  right_distrib :=
  begin
    intros a b c,
    refine quotient.induction_on₃ a b c _,
    rintros ⟨U, HxU, sU⟩ ⟨V, HxV, sV⟩ ⟨W, HxW, sW⟩,
    have HUVWrfl : U ∩ V ∩ W ⊆ U ∩ V ∩ W := λ x Hx, Hx,
    have HUVWsub : U ∩ V ∩ W ⊆ U ∩ W ∩ (V ∩ W)
    := λ x ⟨⟨HxU, HxV⟩, HxW⟩, ⟨⟨HxU, HxW⟩, ⟨HxV, HxW⟩⟩,
    apply quotient.sound,
    use [U ∩ V ∩ W, ⟨⟨HxU, HxV⟩, HxW⟩, HUVWrfl, HUVWsub],
    repeat { rw (F.res_is_ring_hom _ _ _).map_mul },
    repeat { rw (F.res_is_ring_hom _ _ _).map_add },
    repeat { rw ←presheaf.Hcomp' },
    repeat { rw (F.res_is_ring_hom _ _ _).map_mul },
    repeat { rw (F.res_is_ring_hom _ _ _).map_add },
    repeat { rw ←presheaf.Hcomp' },
    rw add_mul,
  end,
  ..stalk_of_rings_add_comm_group,
  ..stalk_of_rings_mul_comm_monoid }

end stalk_of_rings_is_ring

-- Stalks are colimits.

section stalk_colimit

variables {α : Type u} [topological_space α]
variables (F : presheaf_of_rings α) (x : α)

variables (S : Type w) [comm_ring S] [decidable_eq S]
variables (G : Π U, F.F U → S) [HG : Π U, is_ring_hom (G U)]
variables (hg : ∀ U V (H : U ⊆ V) r, G U (F.res V U H r) = G V r)

def to_stalk (U : opens α) (HxU : x ∈ U) (s : F.F U) : stalk_of_rings F x
:= ⟦{U := U, HxU := HxU, s := s}⟧

lemma to_stalk.is_ring_hom (U) (HxU) : is_ring_hom (to_stalk F x U HxU) :=
{ map_one := quotient.sound $ ⟨U, HxU, set.subset.refl _, λ x Hx, trivial,
    begin
        erw (F.res_is_ring_hom _ _ _).map_one,
        erw (F.res_is_ring_hom _ _ _).map_one,
    end⟩,
  map_add := λ y z, quotient.sound $ ⟨U, HxU, set.subset.refl _, λ x Hx, ⟨Hx, Hx⟩,
    begin
        erw ←(F.res_is_ring_hom _ _ _).map_add,
        erw presheaf.Hcomp',
    end⟩,
  map_mul := λ y z, quotient.sound $ ⟨U, HxU, set.subset.refl _, λ x Hx, ⟨Hx, Hx⟩,
    begin
        erw ←(F.res_is_ring_hom _ _ _).map_mul,
        erw presheaf.Hcomp',
    end⟩ }

include hg

protected def to_stalk.rec (y : stalk_of_rings F x) : S :=
quotient.lift_on' y (λ Us, G Us.1 Us.3)
(λ ⟨U, HxU, s⟩ ⟨V, HxV, t⟩ ⟨W, HxW, HWU, HWV, Hres⟩,
by dsimp; rw [←hg W U HWU s, ←hg W V HWV t, Hres])

theorem to_stalk.rec_to_stalk (U HxU)
: (to_stalk.rec F x S G hg) ∘ (to_stalk F x U HxU) = G U := rfl

include HG

lemma to_stalk.rec_is_ring_hom : is_ring_hom (to_stalk.rec F x S G hg) :=
{ map_one := (HG opens.univ).map_one ▸ rfl,
  map_add := λ y z, quotient.induction_on₂' y z $ λ ⟨U, HxU, s⟩ ⟨V, HxV, t⟩,
    begin
        show G (U ∩ V) (_ + _) = G _ _ + G _ _,
        rw (HG (U ∩ V)).map_add,
        rw ←hg (U ∩ V) U (set.inter_subset_left _ _),
        rw ←hg (U ∩ V) V (set.inter_subset_right _ _),
    end,
  map_mul := λ y z, quotient.induction_on₂' y z $ λ ⟨U, HxU, s⟩ ⟨V, HxV, t⟩,
    begin
        show G (U ∩ V) (_ * _) = G _ _ * G _ _,
        rw (HG (U ∩ V)).map_mul,
        rw ←hg (U ∩ V) U (set.inter_subset_left _ _),
        rw ←hg (U ∩ V) V (set.inter_subset_right _ _),
    end }

end stalk_colimit


/-
Copyright (c) 2018 Simon Hudon. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Simon Hudon, Scott Morrison
-/
import tactic data.set.lattice data.prod data.vector
       tactic.rewrite data.stream.basic
       tactic.tfae tactic.converter.interactive
       tactic.ring tactic.ring2

section tauto₀
variables p q r : Prop
variables h : p ∧ q ∨ p ∧ r
include h
example : p ∧ p :=
by tauto

end tauto₀

section tauto₁
variables α : Type
variables p q r : α → Prop
variables h : (∃ x, p x ∧ q x) ∨ (∃ x, p x ∧ r x)
include h
example : ∃ x, p x :=
by tauto

end tauto₁

section tauto₂
variables α : Type
variables x : α
variables p q r : α → Prop
variables h₀ : (∀ x, p x → q x → r x) ∨ r x
variables h₁ : p x
variables h₂ : q x

include h₀ h₁ h₂
example : ∃ x, r x :=
by tauto

end tauto₂

section tauto₃

example (p : Prop) : p ∧ true ↔ p := by tauto
example (p : Prop) : p ∨ false ↔ p := by tauto
example (p q r : Prop) [decidable p] [decidable r] : p ∨ (q ∧ r) ↔ (p ∨ q) ∧ (r ∨ p ∨ r) := by tauto
example (p q r : Prop) [decidable q] [decidable r] : p ∨ (q ∧ r) ↔ (p ∨ q) ∧ (r ∨ p ∨ r) := by tauto
example (p q : Prop) [decidable q] [decidable p] (h : ¬ (p ↔ q)) (h' : ¬ p) : q := by tauto
example (p q : Prop) [decidable q] [decidable p] (h : ¬ (p ↔ q)) (h' : p) : ¬ q := by tauto
example (p q : Prop) [decidable q] [decidable p] (h : ¬ (p ↔ q)) (h' : q) : ¬ p := by tauto
example (p q : Prop) [decidable q] [decidable p] (h : ¬ (p ↔ q)) (h' : ¬ q) : p := by tauto
example (p q : Prop) [decidable q] [decidable p] (h : ¬ (p ↔ q)) (h' : ¬ q) (h'' : ¬ p) : false := by tauto
example (p q r : Prop) [decidable q] [decidable p] (h : p ↔ q) (h' : r ↔ q) (h'' : ¬ r) : ¬ p := by tauto
example (p q r : Prop) (h : p ↔ q) (h' : r ↔ q) : p ↔ r :=
by tauto!
example (p q r : Prop) (h : ¬ p = q) (h' : r = q) : p ↔ ¬ r := by tauto!

section modulo_symmetry
variables {p q r : Prop} {α : Type} {x y : α}
variables (h : x = y)
variables (h'' : (p ∧ q ↔ q ∨ r) ↔ (r ∧ p ↔ r ∨ q))
include h
include h''
example (h' : ¬ y = x) : p ∧ q := by tauto
example (h' : p ∧ ¬ y = x) : p ∧ q := by tauto
example : y = x := by tauto
example (h' : ¬ x = y) : p ∧ q := by tauto
example : x = y := by tauto

end modulo_symmetry

end tauto₃

section wlog

example {x y : ℕ} (a : x = 1) : true :=
begin
  suffices : false, trivial,
  wlog h : x = y,
  { guard_target x = y ∨ y = x,
    admit },
  { guard_hyp h := x = y,
    guard_hyp a := x = 1,
    admit }
end

example {x y : ℕ} : true :=
begin
  suffices : false, trivial,
  wlog h : x ≤ y,
  { guard_hyp h := x ≤ y,
    guard_target false,
    admit }
end

example {x y z : ℕ} : true :=
begin
  suffices : false, trivial,
  wlog : x ≤ y + z using x y,
  { guard_target x ≤ y + z ∨ y ≤ x + z,
    admit },
  { guard_hyp case := x ≤ y + z,
    guard_target false,
    admit },
end

example {x : ℕ} (S₀ S₁ : set ℕ) (P : ℕ → Prop)
  (h : x ∈ S₀ ∪ S₁) : true :=
begin
  suffices : false, trivial,
  wlog h' : x ∈ S₀ using S₀ S₁,
  { guard_target x ∈ S₀ ∨ x ∈ S₁,
    admit },
  { guard_hyp h  := x ∈ S₀ ∪ S₁,
    guard_hyp h' := x ∈ S₀,
    admit }
end

example {n m i : ℕ} {p : ℕ → ℕ → ℕ → Prop} : true :=
begin
  suffices : false, trivial,
  wlog : p n m i using [n m i, n i m, i n m],
  { guard_target p n m i ∨ p n i m ∨ p i n m,
    admit },
  { guard_hyp case := p n m i,
    admit }
end

example {n m i : ℕ} {p : ℕ → Prop} : true :=
begin
  suffices : false, trivial,
  wlog : p n using [n m i, m n i, i n m],
  { guard_target p n ∨ p m ∨ p i,
    admit },
  { guard_hyp case := p n,
    admit }
end

example {n m i : ℕ} {p : ℕ → ℕ → Prop} {q : ℕ → ℕ → ℕ → Prop} : true :=
begin
  suffices : q n m i, trivial,
  have h : p n i ∨ p i m ∨ p m i, from sorry,
  wlog : p n i := h using n m i,
  { guard_hyp h := p n i,
    guard_target q n m i,
    admit },
  { guard_hyp h := p i m,
    guard_hyp this := q i m n,
    guard_target q n m i,
    admit },
  { guard_hyp h := p m i,
    guard_hyp this := q m i n,
    guard_target q n m i,
    admit },
end

example (X : Type) (A B C : set X) : A ∩ (B ∪ C) = (A ∩ B) ∪ (A ∩ C) :=
begin
  ext x,
  split,
  { intro hyp,
    cases hyp,
    wlog x_in : x ∈ B using B C,
    { assumption },
    { exact or.inl ⟨hyp_left, x_in⟩ } },
  { intro hyp,
    wlog x_in : x ∈ A ∩ B using B C,
    { assumption },
    { exact ⟨x_in.left, or.inl x_in.right⟩ } }
end

example (X : Type) (A B C : set X) : A ∩ (B ∪ C) = (A ∩ B) ∪ (A ∩ C) :=
begin
  ext x,
  split,
  { intro hyp,
    wlog x_in : x ∈ B := hyp.2 using B C,
    { exact or.inl ⟨hyp.1, x_in⟩ } },
  { intro hyp,
    wlog x_in : x ∈ A ∩ B := hyp using B C,
    { exact ⟨x_in.left, or.inl x_in.right⟩ } }
end

example (X : Type) (A B C : set X) : A ∩ (B ∪ C) = (A ∩ B) ∪ (A ∩ C) :=
begin
  ext x,
  split,
  { intro hyp,
    cases hyp,
    wlog x_in : x ∈ B := hyp_right using B C,
    { exact or.inl ⟨hyp_left, x_in⟩ }, },
  { intro hyp,
    wlog x_in : x ∈ A ∩ B := hyp using B C,
    { exact ⟨x_in.left, or.inl x_in.right⟩ } }
end

end wlog

example (m n p q : nat) (h : m + n = p) : true :=
begin
  have : m + n = q,
  { generalize_hyp h' : m + n = x at h,
    guard_hyp h' := m + n = x,
    guard_hyp h := x = p,
    guard_target m + n = q,
    admit },
  have : m + n = q,
  { generalize_hyp h' : m + n = x at h ⊢,
    guard_hyp h' := m + n = x,
    guard_hyp h := x = p,
    guard_target x = q,
    admit },
  trivial
end

example (α : Sort*) (L₁ L₂ L₃ : list α)
  (H : L₁ ++ L₂ = L₃) : true :=
begin
  have : L₁ ++ L₂ = L₂,
  { generalize_hyp h : L₁ ++ L₂ = L at H,
    induction L with hd tl ih,
    case list.nil
    { tactic.cleanup,
      change list.nil = L₃ at H,
      admit },
    case list.cons
    { change list.cons hd tl = L₃ at H,
      admit } },
  trivial
end

section convert
open set

variables {α β : Type}
local attribute [simp]
private lemma singleton_inter_singleton_eq_empty {x y : α} :
  ({x} ∩ {y} = (∅ : set α)) ↔ x ≠ y :=
by simp [singleton_inter_eq_empty]

example {f : β → α} {x y : α} (h : x ≠ y) : f ⁻¹' {x} ∩ f ⁻¹' {y} = ∅ :=
begin
  have : {x} ∩ {y} = (∅ : set α) := by simpa using h,
  convert preimage_empty,
  rw [←preimage_inter,this],
end

end convert

section rcases

universe u
variables {α β γ : Type u}

example (x : α × β × γ) : true :=
begin
  rcases x with ⟨a, b, c⟩,
  { guard_hyp a := α,
    guard_hyp b := β,
    guard_hyp c := γ,
    trivial }
end

example (x : α × β × γ) : true :=
begin
  rcases x with ⟨a, ⟨b, c⟩⟩,
  { guard_hyp a := α,
    guard_hyp b := β,
    guard_hyp c := γ,
    trivial }
end

example (x : (α × β) × γ) : true :=
begin
  rcases x with ⟨⟨a, b⟩, c⟩,
  { guard_hyp a := α,
    guard_hyp b := β,
    guard_hyp c := γ,
    trivial }
end

example (x : inhabited α × option β ⊕ γ) : true :=
begin
  rcases x with ⟨⟨a⟩, _ | b⟩ | c,
  { guard_hyp a := α, trivial },
  { guard_hyp a := α, guard_hyp b := β, trivial },
  { guard_hyp c := γ, trivial }
end

example (x y : ℕ) (h : x = y) : true :=
begin
  rcases x with _|⟨⟩|z,
  { guard_hyp h := nat.zero = y, trivial },
  { guard_hyp h := nat.succ nat.zero = y, trivial },
  { guard_hyp z := ℕ,
    guard_hyp h := z.succ.succ = y, trivial },
end

-- from equiv.sum_empty
example (s : α ⊕ empty) : true :=
begin
  rcases s with _ | ⟨⟨⟩⟩,
  { guard_hyp s := α, trivial }
end

end rcases

section ext

@[extensionality] lemma unit.ext (x y : unit) : x = y :=
begin
  cases x, cases y, refl
end

example : subsingleton unit :=
begin
  split, intros, ext
end

example (x y : ℕ) : true :=
begin
  have : x = y,
  { ext <|> admit },
  have : x = y,
  { ext i <|> admit },
  have : x = y,
  { ext : 1 <|> admit },
  trivial
end

example (X Y : ℕ × ℕ)  (h : X.1 = Y.1) (h : X.2 = Y.2) : X = Y :=
begin
  ext; assumption
end

example (X Y : (ℕ → ℕ) × ℕ)  (h : ∀ i, X.1 i = Y.1 i) (h : X.2 = Y.2) : X = Y :=
begin
  ext x; solve_by_elim,
end

example (X Y : ℕ → ℕ × ℕ)  (h : ∀ i, X i = Y i) : true :=
begin
  have : X = Y,
  { ext i : 1,
    guard_target X i = Y i,
    admit },
  have : X = Y,
  { ext i,
    guard_target (X i).fst = (Y i).fst, admit,
    guard_target (X i).snd = (Y i).snd, admit, },
  have : X = Y,
  { ext : 1,
    guard_target X x = Y x,
    admit },
  trivial,
end

example (s₀ s₁ : set ℕ) (h : s₁ = s₀) : s₀ = s₁ :=
by { ext1, guard_target x ∈ s₀ ↔ x ∈ s₁, simp * }

example (s₀ s₁ : stream ℕ) (h : s₁ = s₀) : s₀ = s₁ :=
by { ext1, guard_target s₀.nth n = s₁.nth n, simp * }

example (s₀ s₁ : ℤ → set (ℕ × ℕ))
        (h : ∀ i a b, (a,b) ∈ s₀ i ↔ (a,b) ∈ s₁ i) : s₀ = s₁ :=
begin
  ext i ⟨a,b⟩,
  apply h
end

def my_foo {α} (x : semigroup α) (y : group α) : true := trivial

example {α : Type} : true :=
begin
  have : true,
  { refine_struct (@my_foo α { .. } { .. } ),
      -- 9 goals
    guard_tags _field mul semigroup, admit,
      -- case semigroup, mul
      -- α : Type
      -- ⊢ α → α → α

    guard_tags _field mul_assoc semigroup, admit,
      -- case semigroup, mul_assoc
      -- α : Type
      -- ⊢ ∀ (a b c : α), a * b * c = a * (b * c)

    guard_tags _field mul group, admit,
      -- case group, mul
      -- α : Type
      -- ⊢ α → α → α

    guard_tags _field mul_assoc group, admit,
      -- case group, mul_assoc
      -- α : Type
      -- ⊢ ∀ (a b c : α), a * b * c = a * (b * c)

    guard_tags _field one group, admit,
      -- case group, one
      -- α : Type
      -- ⊢ α

    guard_tags _field one_mul group, admit,
      -- case group, one_mul
      -- α : Type
      -- ⊢ ∀ (a : α), 1 * a = a

    guard_tags _field mul_one group, admit,
      -- case group, mul_one
      -- α : Type
      -- ⊢ ∀ (a : α), a * 1 = a

    guard_tags _field inv group, admit,
      -- case group, inv
      -- α : Type
      -- ⊢ α → α

    guard_tags _field mul_left_inv group, admit,
      -- case group, mul_left_inv
      -- α : Type
      -- ⊢ ∀ (a : α), a⁻¹ * a = 1
  },
  trivial
end

def my_bar {α} (x : semigroup α) (y : group α) (i j : α) : α := i

example {α : Type} : true :=
begin
  have : monoid α,
  { refine_struct { mul := my_bar { .. } { .. } },
    guard_tags _field mul semigroup, admit,
    guard_tags _field mul_assoc semigroup, admit,
    guard_tags _field mul group, admit,
    guard_tags _field mul_assoc group, admit,
    guard_tags _field one group, admit,
    guard_tags _field one_mul group, admit,
    guard_tags _field mul_one group, admit,
    guard_tags _field inv group, admit,
    guard_tags _field mul_left_inv group, admit,
    guard_tags _field mul_assoc monoid, admit,
    guard_tags _field one monoid, admit,
    guard_tags _field one_mul monoid, admit,
    guard_tags _field mul_one monoid, admit, },
  trivial
end

structure dependent_fields :=
(a : bool)
(v : if a then ℕ else ℤ)

@[extensionality] lemma df.ext (s t : dependent_fields) (h : s.a = t.a)
 (w : (@eq.rec _ s.a (λ b, if b then ℕ else ℤ) s.v t.a h) = t.v): s = t :=
begin
  cases s, cases t,
  dsimp at *,
  congr,
  exact h,
  subst h,
  simp,
  simp at w,
  exact w,
end

example (s : dependent_fields) : s = s :=
begin
  tactic.ext1 [] {tactic.apply_cfg . new_goals := tactic.new_goals.all},
  guard_target s.a = s.a,
  refl,
  refl,
end

end ext

section apply_rules

example {a b c d e : nat} (h1 : a ≤ b) (h2 : c ≤ d) (h3 : 0 ≤ e) :
a + c * e + a + c + 0 ≤ b + d * e + b + d + e :=
add_le_add (add_le_add (add_le_add (add_le_add h1 (mul_le_mul_of_nonneg_right h2 h3)) h1 ) h2) h3

example {a b c d e : nat} (h1 : a ≤ b) (h2 : c ≤ d) (h3 : 0 ≤ e) :
a + c * e + a + c + 0 ≤ b + d * e + b + d + e :=
by apply_rules [add_le_add, mul_le_mul_of_nonneg_right]

@[user_attribute]
meta def mono_rules : user_attribute :=
{ name := `mono_rules,
  descr := "lemmas usable to prove monotonicity" }
attribute [mono_rules] add_le_add mul_le_mul_of_nonneg_right

example {a b c d e : nat} (h1 : a ≤ b) (h2 : c ≤ d) (h3 : 0 ≤ e) :
a + c * e + a + c + 0 ≤ b + d * e + b + d + e :=
by apply_rules [mono_rules]

example {a b c d e : nat} (h1 : a ≤ b) (h2 : c ≤ d) (h3 : 0 ≤ e) :
a + c * e + a + c + 0 ≤ b + d * e + b + d + e :=
by apply_rules mono_rules

end apply_rules

section h_generalize

variables {α β γ φ ψ : Type} (f : α → α → α → φ → γ)
          (x y : α) (a b : β) (z : φ)
          (h₀ : β = α) (h₁ : β = α) (h₂ : φ = β)
          (hx : x == a) (hy : y == b) (hz : z == a)
include f x y z a b hx hy hz

example : f x y x z = f (eq.rec_on h₀ a) (cast h₀ b) (eq.mpr h₁.symm a) (eq.mpr h₂ a) :=
begin
  guard_hyp_nums 16,
  h_generalize hp : a == p with hh,
  guard_hyp_nums 19,
  guard_hyp' hh := β = α,
  guard_target f x y x z = f p (cast h₀ b) p (eq.mpr h₂ a),
  h_generalize hq : _ == q,
  guard_hyp_nums 21,
  guard_target f x y x z = f p q p (eq.mpr h₂ a),
  h_generalize _ : _ == r,
  guard_hyp_nums 23,
  guard_target f x y x z = f p q p r,
  casesm* [_ == _, _ = _], refl
end

end h_generalize

section h_generalize

variables {α β γ φ ψ : Type} (f : list α → list α → γ)
          (x : list α) (a : list β) (z : φ)
          (h₀ : β = α) (h₁ : list β = list α)
          (hx : x == a)
include f x z a hx h₀ h₁

example : true :=
begin
  have : f x x = f (eq.rec_on h₀ a) (cast h₁ a),
  { guard_hyp_nums 11,
    h_generalize : a == p with _,
    guard_hyp_nums 13,
    guard_hyp' h := β = α,
    guard_target f x x = f p (cast h₁ a),
    h_generalize! : a == q ,
    guard_hyp_nums 13,
    guard_target ∀ q, f x x = f p q,
    casesm* [_ == _, _ = _],
    success_if_fail { refl },
    admit },
  trivial
end

end h_generalize

section assoc_rw
open tactic
example : ∀ x y z a b c : ℕ, true :=
begin
 intros,
 have : x + (y + z) = 3 + y, admit,
 have : a + (b + x) + y + (z + b + c) ≤ 0,
 (do this ← get_local `this,
     tgt ← to_expr ```(a + (b + x) + y + (z + b + c)),
     assoc ← mk_mapp ``add_monoid.add_assoc [`(ℕ),none],
     (l,p) ← assoc_rewrite_intl assoc this tgt,
     note `h none p  ),
 erw h,
 guard_target a + b + 3 + y + b + c ≤ 0,
 admit,
 trivial
end

example : ∀ x y z a b c : ℕ, true :=
begin
 intros,
 have : ∀ y, x + (y + z) = 3 + y, admit,
 have : a + (b + x) + y + (z + b + c) ≤ 0,
 (do this ← get_local `this,
     tgt ← to_expr ```(a + (b + x) + y + (z + b + c)),
     assoc_rewrite_target this ),
 guard_target a + b + 3 + y + b + c ≤ 0,
 admit,
 trivial
end

variables x y z a b c : ℕ
variables h₀ : ∀ (y : ℕ), x + (y + z) = 3 + y
variables h₁ : a + (b + x) + y + (z + b + a) ≤ 0
variables h₂ : y + b + c = y + b + a
include h₀ h₁ h₂
example : a + (b + x) + y + (z + b + c) ≤ 0 :=
by { assoc_rw [h₀,h₂] at *,
     guard_hyp _inst := is_associative ℕ has_add.add,
       -- keep a local instance of is_associative to cache
       -- type class queries
     exact h₁ }

end assoc_rw

-- section tfae

-- example (p q r s : Prop)
--   (h₀ : p ↔ q)
--   (h₁ : q ↔ r)
--   (h₂ : r ↔ s) :
--   p ↔ s :=
-- begin
--   scc,
-- end

-- example (p' p q r r' s s' : Prop)
--   (h₀ : p' → p)
--   (h₀ : p → q)
--   (h₁ : q → r)
--   (h₁ : r' → r)
--   (h₂ : r ↔ s)
--   (h₂ : s → p)
--   (h₂ : s → s') :
--   p ↔ s :=
-- begin
--   scc,
-- end

-- example (p' p q r r' s s' : Prop)
--   (h₀ : p' → p)
--   (h₀ : p → q)
--   (h₁ : q → r)
--   (h₁ : r' → r)
--   (h₂ : r ↔ s)
--   (h₂ : s → p)
--   (h₂ : s → s') :
--   p ↔ s :=
-- begin
--   scc',
--   assumption
-- end

-- example : tfae [true, ∀ n : ℕ, 0 ≤ n * n, true, true] := begin
--   tfae_have : 3 → 1, { intro h, constructor },
--   tfae_have : 2 → 3, { intro h, constructor },
--   tfae_have : 2 ← 1, { intros h n, apply nat.zero_le },
--   tfae_have : 4 ↔ 2, { tauto },
--   tfae_finish,
-- end

-- example : tfae [] := begin
--   tfae_finish,
-- end

-- end tfae

section conv

example : 0 + 0 = 0 :=
begin
  conv_lhs {erw [add_zero]}
end

example : 0 + 0 = 0 :=
begin
  conv_lhs {simp}
end

example : 0 = 0 + 0 :=
begin
  conv_rhs {simp}
end

-- Example with ring discharging the goal
example : 22 + 7 * 4 + 3 * 8 = 0 + 7 * 4 + 46 :=
begin
  conv { ring, },
end

-- Example with ring failing to discharge, to normalizing the goal
example : (22 + 7 * 4 + 3 * 8 = 0 + 7 * 4 + 47) = (74 = 75) :=
begin
  conv { ring, },
end

-- Example with ring discharging the goal
example (x : ℕ) : 22 + 7 * x + 3 * 8 = 0 + 7 * x + 46 :=
begin
  conv { ring, },
end

-- Example with ring failing to discharge, to normalizing the goal
example (x : ℕ) : (22 + 7 * x + 3 * 8 = 0 + 7 * x + 46 + 1)
                    = (7 * x + 46 = 7 * x + 47) :=
begin
  conv { ring, },
end

-- norm_num examples:
example : 22 + 7 * 4 + 3 * 8 = 74 :=
begin
  conv { norm_num, },
end

example (x : ℕ) : 22 + 7 * x + 3 * 8 = 7 * x + 46 :=
begin
  conv { norm_num, },
end

end conv

section clear_aux_decl

example (n m : ℕ) (h₁ : n = m) (h₂ : ∃ a : ℕ, a = n ∧ a = m) : 2 * m = 2 * n :=
let ⟨a, ha⟩ := h₂ in
begin
  clear_aux_decl, -- subst will fail without this line
  subst h₁
end

example (x y : ℕ) (h₁ : ∃ n : ℕ, n * 1 = 2) (h₂ : 1 + 1 = 2 → x * 1 = y) : x = y :=
let ⟨n, hn⟩ := h₁ in
begin
  clear_aux_decl, -- finish produces an error without this line
  finish
end

end clear_aux_decl

section congr

example (c : Prop → Prop → Prop → Prop) (x x' y z z' : Prop)
  (h₀ : x ↔ x')
  (h₁ : z ↔ z') :
  c x y z ↔ c x' y z' :=
begin
  congr',
  { guard_target x = x', ext, assumption },
  { guard_target z = z', ext, assumption },
end

end congr

private meta def get_exception_message (t : lean.parser unit) : lean.parser string
| s := match t s with
       | result.success a s' := result.success "No exception" s
       | result.exception none pos s' := result.success "Exception no msg" s
       | result.exception (some msg) pos s' := result.success (msg ()).to_string s
       end

@[user_command] meta def test_parser1_fail_cmd
(_ : interactive.parse (lean.parser.tk "test_parser1")) : lean.parser unit :=
do
  let msg := "oh, no!",
  let t : lean.parser unit := tactic.fail msg,
  s ← get_exception_message t,
  if s = msg then tactic.skip
  else interaction_monad.fail "Message was corrupted while being passed through `lean.parser.of_tactic`"
.

-- Due to `lean.parser.of_tactic'` priority, the following *should not* fail with
-- a VM check error, and instead catch the error gracefully and just
-- run and succeed silently.
test_parser1


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

! This file was ported from Lean 3 source module algebra.homology.complex_shape
! leanprover-community/mathlib commit 448144f7ae193a8990cb7473c9e9a01990f64ac7
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Algebra.Group.Defs
import Mathbin.Logic.Relation

/-!
# Shapes of homological complexes

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

We define a structure `complex_shape ι` for describing the shapes of homological complexes
indexed by a type `ι`.
This is intended to capture chain complexes and cochain complexes, indexed by either `ℕ` or `ℤ`,
as well as more exotic examples.

Rather than insisting that the indexing type has a `succ` function
specifying where differentials should go,
inside `c : complex_shape` we have `c.rel : ι → ι → Prop`,
and when we define `homological_complex`
we only allow nonzero differentials `d i j` from `i` to `j` if `c.rel i j`.
Further, we require that `{ j // c.rel i j }` and `{ i // c.rel i j }` are subsingletons.
This means that the shape consists of some union of lines, rays, intervals, and circles.

Convenience functions `c.next` and `c.prev` provide these related elements
when they exist, and return their input otherwise.

This design aims to avoid certain problems arising from dependent type theory.
In particular we never have to ensure morphisms `d i : X i ⟶ X (succ i)` compose as
expected (which would often require rewriting by equations in the indexing type).
Instead such identities become separate proof obligations when verifying that a
complex we've constructed is of the desired shape.

If `α` is an `add_right_cancel_semigroup`, then we define `up α : complex_shape α`,
the shape appropriate for cohomology,so `d : X i ⟶ X j` is nonzero only when `j = i + 1`,
as well as `down α : complex_shape α`, appropriate for homology,
so `d : X i ⟶ X j` is nonzero only when `i = j + 1`.
(Later we'll introduce `cochain_complex` and `chain_complex` as abbreviations for
`homological_complex` with one of these shapes baked in.)
-/

open Classical

noncomputable section

#print ComplexShape /-
/-- A `c : complex_shape ι` describes the shape of a chain complex,
with chain groups indexed by `ι`.
Typically `ι` will be `ℕ`, `ℤ`, or `fin n`.

There is a relation `rel : ι → ι → Prop`,
and we will only allow a non-zero differential from `i` to `j` when `rel i j`.

There are axioms which imply `{ j // c.rel i j }` and `{ i // c.rel i j }` are subsingletons.
This means that the shape consists of some union of lines, rays, intervals, and circles.

Below we define `c.next` and `c.prev` which provide these related elements.
-/
@[ext, nolint has_nonempty_instance]
structure ComplexShape (ι : Type _) where
  Rel : ι → ι → Prop
  next_eq : ∀ {i j j'}, Rel i j → Rel i j' → j = j'
  prev_eq : ∀ {i i' j}, Rel i j → Rel i' j → i = i'
#align complex_shape ComplexShape
-/

namespace ComplexShape

variable {ι : Type _}

#print ComplexShape.refl /-
/-- The complex shape where only differentials from each `X.i` to itself are allowed.

This is mostly only useful so we can describe the relation of "related in `k` steps" below.
-/
@[simps]
def refl (ι : Type _) : ComplexShape ι
    where
  Rel i j := i = j
  next_eq i j j' w w' := w.symm.trans w'
  prev_eq i i' j w w' := w.trans w'.symm
#align complex_shape.refl ComplexShape.refl
-/

#print ComplexShape.symm /-
/-- The reverse of a `complex_shape`.
-/
@[simps]
def symm (c : ComplexShape ι) : ComplexShape ι
    where
  Rel i j := c.Rel j i
  next_eq i j j' w w' := c.prev_eq w w'
  prev_eq i i' j w w' := c.next_eq w w'
#align complex_shape.symm ComplexShape.symm
-/

#print ComplexShape.symm_symm /-
@[simp]
theorem symm_symm (c : ComplexShape ι) : c.symm.symm = c :=
  by
  ext
  simp
#align complex_shape.symm_symm ComplexShape.symm_symm
-/

#print ComplexShape.trans /-
/-- The "composition" of two `complex_shape`s.

We need this to define "related in k steps" later.
-/
@[simp]
def trans (c₁ c₂ : ComplexShape ι) : ComplexShape ι
    where
  Rel := Relation.Comp c₁.Rel c₂.Rel
  next_eq i j j' w w' := by
    obtain ⟨k, w₁, w₂⟩ := w
    obtain ⟨k', w₁', w₂'⟩ := w'
    rw [c₁.next_eq w₁ w₁'] at w₂
    exact c₂.next_eq w₂ w₂'
  prev_eq i i' j w w' := by
    obtain ⟨k, w₁, w₂⟩ := w
    obtain ⟨k', w₁', w₂'⟩ := w'
    rw [c₂.prev_eq w₂ w₂'] at w₁
    exact c₁.prev_eq w₁ w₁'
#align complex_shape.trans ComplexShape.trans
-/

#print ComplexShape.subsingleton_next /-
instance subsingleton_next (c : ComplexShape ι) (i : ι) : Subsingleton { j // c.Rel i j } :=
  by
  fconstructor
  rintro ⟨j, rij⟩ ⟨k, rik⟩
  congr
  exact c.next_eq rij rik
#align complex_shape.subsingleton_next ComplexShape.subsingleton_next
-/

#print ComplexShape.subsingleton_prev /-
instance subsingleton_prev (c : ComplexShape ι) (j : ι) : Subsingleton { i // c.Rel i j } :=
  by
  fconstructor
  rintro ⟨i, rik⟩ ⟨j, rjk⟩
  congr
  exact c.prev_eq rik rjk
#align complex_shape.subsingleton_prev ComplexShape.subsingleton_prev
-/

#print ComplexShape.next /-
/-- An arbitary choice of index `j` such that `rel i j`, if such exists.
Returns `i` otherwise.
-/
def next (c : ComplexShape ι) (i : ι) : ι :=
  if h : ∃ j, c.Rel i j then h.some else i
#align complex_shape.next ComplexShape.next
-/

#print ComplexShape.prev /-
/-- An arbitary choice of index `i` such that `rel i j`, if such exists.
Returns `j` otherwise.
-/
def prev (c : ComplexShape ι) (j : ι) : ι :=
  if h : ∃ i, c.Rel i j then h.some else j
#align complex_shape.prev ComplexShape.prev
-/

#print ComplexShape.next_eq' /-
theorem next_eq' (c : ComplexShape ι) {i j : ι} (h : c.Rel i j) : c.next i = j :=
  by
  apply c.next_eq _ h
  dsimp only [next]
  rw [dif_pos]
  exact Exists.choose_spec ⟨j, h⟩
#align complex_shape.next_eq' ComplexShape.next_eq'
-/

#print ComplexShape.prev_eq' /-
theorem prev_eq' (c : ComplexShape ι) {i j : ι} (h : c.Rel i j) : c.prev j = i :=
  by
  apply c.prev_eq _ h
  dsimp only [prev]
  rw [dif_pos]
  exact Exists.choose_spec ⟨i, h⟩
#align complex_shape.prev_eq' ComplexShape.prev_eq'
-/

#print ComplexShape.up' /-
/-- The `complex_shape` allowing differentials from `X i` to `X (i+a)`.
(For example when `a = 1`, a cohomology theory indexed by `ℕ` or `ℤ`)
-/
@[simps]
def up' {α : Type _} [AddRightCancelSemigroup α] (a : α) : ComplexShape α
    where
  Rel i j := i + a = j
  next_eq i j k hi hj := hi.symm.trans hj
  prev_eq i j k hi hj := add_right_cancel (hi.trans hj.symm)
#align complex_shape.up' ComplexShape.up'
-/

#print ComplexShape.down' /-
/-- The `complex_shape` allowing differentials from `X (j+a)` to `X j`.
(For example when `a = 1`, a homology theory indexed by `ℕ` or `ℤ`)
-/
@[simps]
def down' {α : Type _} [AddRightCancelSemigroup α] (a : α) : ComplexShape α
    where
  Rel i j := j + a = i
  next_eq i j k hi hj := add_right_cancel (hi.trans hj.symm)
  prev_eq i j k hi hj := hi.symm.trans hj
#align complex_shape.down' ComplexShape.down'
-/

/- warning: complex_shape.down'_mk -> ComplexShape.down'_mk is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} [_inst_1 : AddRightCancelSemigroup.{u1} α] (a : α) (i : α) (j : α), (Eq.{succ u1} α (HAdd.hAdd.{u1, u1, u1} α α α (instHAdd.{u1} α (AddSemigroup.toHasAdd.{u1} α (AddRightCancelSemigroup.toAddSemigroup.{u1} α _inst_1))) j a) i) -> (ComplexShape.Rel.{u1} α (ComplexShape.down'.{u1} α _inst_1 a) i j)
but is expected to have type
  forall {α : Type.{u1}} [_inst_1 : AddRightCancelSemigroup.{u1} α] (a : α) (i : α) (j : α), (Eq.{succ u1} α (HAdd.hAdd.{u1, u1, u1} α α α (instHAdd.{u1} α (AddSemigroup.toAdd.{u1} α (AddRightCancelSemigroup.toAddSemigroup.{u1} α _inst_1))) j a) i) -> (ComplexShape.Rel.{u1} α (ComplexShape.down'.{u1} α _inst_1 a) i j)
Case conversion may be inaccurate. Consider using '#align complex_shape.down'_mk ComplexShape.down'_mkₓ'. -/
theorem down'_mk {α : Type _} [AddRightCancelSemigroup α] (a : α) (i j : α) (h : j + a = i) :
    (down' a).Rel i j :=
  h
#align complex_shape.down'_mk ComplexShape.down'_mk

#print ComplexShape.up /-
/-- The `complex_shape` appropriate for cohomology, so `d : X i ⟶ X j` only when `j = i + 1`.
-/
@[simps]
def up (α : Type _) [AddRightCancelSemigroup α] [One α] : ComplexShape α :=
  up' 1
#align complex_shape.up ComplexShape.up
-/

#print ComplexShape.down /-
/-- The `complex_shape` appropriate for homology, so `d : X i ⟶ X j` only when `i = j + 1`.
-/
@[simps]
def down (α : Type _) [AddRightCancelSemigroup α] [One α] : ComplexShape α :=
  down' 1
#align complex_shape.down ComplexShape.down
-/

/- warning: complex_shape.down_mk -> ComplexShape.down_mk is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} [_inst_1 : AddRightCancelSemigroup.{u1} α] [_inst_2 : One.{u1} α] (i : α) (j : α), (Eq.{succ u1} α (HAdd.hAdd.{u1, u1, u1} α α α (instHAdd.{u1} α (AddSemigroup.toHasAdd.{u1} α (AddRightCancelSemigroup.toAddSemigroup.{u1} α _inst_1))) j (OfNat.ofNat.{u1} α 1 (OfNat.mk.{u1} α 1 (One.one.{u1} α _inst_2)))) i) -> (ComplexShape.Rel.{u1} α (ComplexShape.down.{u1} α _inst_1 _inst_2) i j)
but is expected to have type
  forall {α : Type.{u1}} [_inst_1 : AddRightCancelSemigroup.{u1} α] [_inst_2 : One.{u1} α] (i : α) (j : α), (Eq.{succ u1} α (HAdd.hAdd.{u1, u1, u1} α α α (instHAdd.{u1} α (AddSemigroup.toAdd.{u1} α (AddRightCancelSemigroup.toAddSemigroup.{u1} α _inst_1))) j (OfNat.ofNat.{u1} α 1 (One.toOfNat1.{u1} α _inst_2))) i) -> (ComplexShape.Rel.{u1} α (ComplexShape.down.{u1} α _inst_1 _inst_2) i j)
Case conversion may be inaccurate. Consider using '#align complex_shape.down_mk ComplexShape.down_mkₓ'. -/
theorem down_mk {α : Type _} [AddRightCancelSemigroup α] [One α] (i j : α) (h : j + 1 = i) :
    (down α).Rel i j :=
  down'_mk (1 : α) i j h
#align complex_shape.down_mk ComplexShape.down_mk

end ComplexShape


import group_theory.free_group group_theory.subgroup

variables {α : Type*} {β : Type*} [decidable_eq α] (T : set α) (r : free_group α)

open group subgroup free_group

def blah (t : α) : free_group α →* free_group unit :=
to_group (λ a, if a = t then of () else 1)

instance {α : Type*} [subsingleton α] : comm_group (free_group α) :=
{ mul_comm := λ a b, sorry,
  ..free_group.group }

def ker_blah_free (t : α) (e : α ≃ option β) (he : e.symm none = t) :
  free_group (β × ℤ) ≃* (blah t).ker :=
{ to_fun := free_group.to_group
    (λ b : β × ℤ, (⟨of t ^ b.2 * of (e.symm (some b.1)) * of t ^ -b.2,
      monoid_hom.mem_ker.2 begin
        rw [monoid_hom.map_mul, monoid_hom.map_mul, mul_right_comm,
          ← monoid_hom.map_mul, ← gpow_add, add_neg_self],
        simp [blah, he.symm]
      end⟩ : (blah t).ker)),
  inv_fun := λ x, begin
    have := x.1,

  end,  }

@[elab_as_eliminator]
lemma normal_closure_induction {G : Type*} [group G] {P : G → Prop} {x : G} {s : set G}
  (h : x ∈ subgroup.normal_closure s)
  (hs : ∀ x ∈ s, P x)
  (h1 : P 1)
  (hmul : ∀ x ∈ s, ∀ y, P y → P (x * y))
  (hinv : ∀ x ∈ s, P x → P x⁻¹) : P x := sorry

theorem freiheitsatz (x : free_group α)
  (hxr : x ∈ subgroup.normal_closure ({r} : set (free_group α)))
  (hxT : x ∈ subgroup.normal_closure (free_group.of '' T)) (hx1 : x ≠ 1) :
  r ∈ subgroup.normal_closure (free_group.of '' T) :=
begin
  revert hxT hx1,
  refine normal_closure_induction hxr _ _ _ _,
  { assume x,
    simp {contextual := tt} },
  { simp },
  { simp only [set.mem_singleton_iff, forall_eq, ne.def] {contextual := tt},
    assume y hy hry, generalize hz : r * y = z, rw hz at hry, clear hxr, revert hz hy y r,
    refine normal_closure_induction hry _ _ _ _,
    { rintros _ ⟨a, haT, rfl⟩ r y ih, }
   },

end
-- begin
--   revert hxr hxT,
--   refine free_group.induction_on r _ _ _ _ x,
--   { intros,
--     exact is_submonoid.one_mem },
--   { assume r x hxr hxT,
--     sorry },
--   { assume y ih x hxr hxT, sorry,
--      },
--   { intros, }
-- end


/-
Copyright (c) 2022 Markus Himmel. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Markus Himmel
-/
import category_theory.subobject.well_powered
import category_theory.limits.preserves.finite
import category_theory.limits.shapes.finite_limits

/-!
# Subobjects in the category of structured arrows

We compute the subobjects of an object `A` in the category `structured_arrow S T` for `T : C ⥤ D`
and `S : D` as a subtype of the subobjects of `A.right`. We deduce that `structured_arrow S T` is
well-powered if `C` is.

## Main declarations
* `structured_arrow.equiv_subtype`: the order-equivalence between `subobject A` and a subtype of
  `subobject A.right`.

## Implementation notes
Our computation requires that `C` has all limits and `T` preserves all limits. Furthermore, we
require that the morphisms of `C` and `D` are in the same universe. It is possible that both of
these requirements can be relaxed by refining the results about limits in comma categories.

We also provide the dual results. As usual, we use `subobject (op A)` for the quotient objects of
`A`.

-/

noncomputable theory

open category_theory.limits opposite

universes v u₁ u₂

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

namespace structured_arrow
variables {S : D} {T : C ⥤ D}

/-- Every subobject of a structured arrow can be projected to a subobject of the underlying
    object. -/
def project_subobject [has_limits C] [preserves_limits T] {A : structured_arrow S T} :
  subobject A → subobject A.right :=
begin
  refine subobject.lift (λ P f hf, by exactI subobject.mk f.right) _,
  introsI P Q f g hf hg i hi,
  refine subobject.mk_eq_mk_of_comm _ _ ((proj S T).map_iso i) _,
  exact congr_arg comma_morphism.right hi
end

@[simp]
lemma project_subobject_mk [has_limits C] [preserves_limits T] {A P : structured_arrow S T}
  (f : P ⟶ A) [mono f] : project_subobject (subobject.mk f) = subobject.mk f.right :=
rfl

lemma project_subobject_factors [has_limits C] [preserves_limits T] {A : structured_arrow S T} :
  ∀ P : subobject A, ∃ q, q ≫ T.map (project_subobject P).arrow = A.hom :=
subobject.ind _ $ λ P f hf,
  ⟨P.hom ≫ T.map (subobject.underlying_iso _).inv, by { dsimp, simp [← T.map_comp] }⟩

/-- A subobject of the underlying object of a structured arrow can be lifted to a subobject of
    the structured arrow, provided that there is a morphism making the subobject into a structured
    arrow. -/
@[simp]
def lift_subobject {A : structured_arrow S T} (P : subobject A.right) {q}
  (hq : q ≫ T.map P.arrow = A.hom) : subobject A :=
subobject.mk (hom_mk P.arrow hq : mk q ⟶ A)

/-- Projecting and then lifting a subobject recovers the original subobject, because there is at
    most one morphism making the projected subobject into a structured arrow. -/
lemma lift_project_subobject [has_limits C] [preserves_limits T] {A : structured_arrow S T} :
  ∀ (P : subobject A) {q} (hq : q ≫ T.map (project_subobject P).arrow = A.hom),
    lift_subobject (project_subobject P) hq = P := subobject.ind _
begin
  introsI P f hf q hq,
  fapply subobject.mk_eq_mk_of_comm,
  { fapply iso_mk,
    { exact subobject.underlying_iso _ },
    { exact (cancel_mono (T.map f.right)).1 (by { dsimp, simpa [← T.map_comp] using hq }) } },
  { exact ext _ _ (by { dsimp, simp })}
end

/-- If `A : S → T.obj B` is a structured arrow for `S : D` and `T : C ⥤ D`, then we can explicitly
    describe the subobjects of `A` as the subobjects `P` of `B` in `C` for which `A.hom` factors
    through the image of `P` under `T`. -/
@[simps]
def subobject_equiv [has_limits C] [preserves_limits T] (A : structured_arrow S T) :
  subobject A ≃o { P : subobject A.right // ∃ q, q ≫ T.map P.arrow = A.hom } :=
{ to_fun := λ P, ⟨project_subobject P, project_subobject_factors P⟩,
  inv_fun := λ P, lift_subobject P.val P.prop.some_spec,
  left_inv := λ P, lift_project_subobject _ _,
  right_inv := λ P, subtype.ext (by simp),
  map_rel_iff' := subobject.ind₂ _
  begin
    introsI P Q f g hf hg,
    refine ⟨λ h, subobject.mk_le_mk_of_comm _ (ext _ _ _), λ h, _⟩,
    { refine hom_mk (subobject.of_mk_le_mk _ _ h) ((cancel_mono (T.map g.right)).1 _),
      simp [← T.map_comp] },
    { simp only [mono_over.mk'_arrow, subobject.of_mk_le_mk_comp, comma.comp_right, hom_mk_right] },
    { refine subobject.mk_le_mk_of_comm (subobject.of_mk_le_mk _ _ h).right _,
      exact congr_arg comma_morphism.right (subobject.of_mk_le_mk_comp h) }
  end }

/-- If `C` is well-powered and complete and `T` preserves limits, then `structured_arrow S T` is
    well-powered. -/
instance well_powered_structured_arrow [well_powered C] [has_limits C] [preserves_limits T] :
  well_powered (structured_arrow S T) :=
{ subobject_small := λ X, small_map (subobject_equiv X).to_equiv }

end structured_arrow

namespace costructured_arrow
variables {S : C ⥤ D} {T : D}

/-- Every quotient of a costructured arrow can be projected to a quotient of the underlying
    object. -/
def project_quotient [has_colimits C] [preserves_colimits S] {A : costructured_arrow S T} :
  subobject (op A) → subobject (op A.left) :=
begin
  refine subobject.lift (λ P f hf, by exactI subobject.mk f.unop.left.op) _,
  introsI P Q f g hf hg i hi,
  refine subobject.mk_eq_mk_of_comm _ _ ((proj S T).map_iso i.unop).op (quiver.hom.unop_inj _),
  have := congr_arg quiver.hom.unop hi,
  simpa using congr_arg comma_morphism.left this,
end

@[simp]
lemma project_quotient_mk [has_colimits C] [preserves_colimits S] {A : costructured_arrow S T}
  {P : (costructured_arrow S T)ᵒᵖ} (f : P ⟶ op A) [mono f] :
  (project_quotient (subobject.mk f)) = subobject.mk f.unop.left.op :=
rfl

/-- A quotient of the underlying object of a costructured arrow can be lifted to a quotient of
    the costructured arrow, provided that there is a morphism making the quotient into a
    costructured arrow. -/
@[simp]
def lift_quotient {A : costructured_arrow S T} (P : subobject (op A.left)) {q}
  (hq : S.map P.arrow.unop ≫ q = A.hom) : subobject (op A) :=
subobject.mk (hom_mk P.arrow.unop hq : A ⟶ mk q).op

/-- Technical lemma for `lift_project_quotient`. -/
@[simp]
lemma unop_left_comp_underlying_iso_hom_unop {A : costructured_arrow S T}
  {P : (costructured_arrow S T)ᵒᵖ} (f : P ⟶ op A) [mono f.unop.left.op] :
  f.unop.left ≫ (subobject.underlying_iso f.unop.left.op).hom.unop =
    (subobject.mk f.unop.left.op).arrow.unop :=
begin
  conv_lhs { congr, rw [← quiver.hom.unop_op f.unop.left] },
  rw [← unop_comp, subobject.underlying_iso_hom_comp_eq_mk]
end

/-- Projecting and then lifting a quotient recovers the original quotient, because there is at most
    one morphism making the projected quotient into a costructured arrow. -/
lemma lift_project_quotient [has_colimits C] [preserves_colimits S] {A : costructured_arrow S T} :
  ∀ (P : subobject (op A)) {q} (hq : S.map (project_quotient P).arrow.unop ≫ q = A.hom),
    lift_quotient (project_quotient P) hq = P := subobject.ind _
begin
  introsI P f hf q hq,
  fapply subobject.mk_eq_mk_of_comm,
  { refine (iso.op (iso_mk _ _) : _ ≅ op (unop P)),
    { exact (subobject.underlying_iso f.unop.left.op).unop },
    { refine (cancel_epi (S.map f.unop.left)).1 _,
      simpa [← category.assoc, ← S.map_comp] using hq } },
  { exact quiver.hom.unop_inj (ext _ _ (by { dsimp, simp })) }
end

/-- Technical lemma for `quotient_equiv`. -/
lemma unop_left_comp_of_mk_le_mk_unop {A : costructured_arrow S T}
  {P Q : (costructured_arrow S T)ᵒᵖ} {f : P ⟶ op A} {g : Q ⟶ op A} [mono f.unop.left.op]
  [mono g.unop.left.op] (h : subobject.mk f.unop.left.op ≤ subobject.mk g.unop.left.op) :
  g.unop.left ≫ (subobject.of_mk_le_mk f.unop.left.op g.unop.left.op h).unop = f.unop.left :=
begin
  conv_lhs { congr, rw [← quiver.hom.unop_op g.unop.left] },
  rw [← unop_comp],
  simp only [subobject.of_mk_le_mk_comp, quiver.hom.unop_op]
end

/-- If `A : S.obj B ⟶ T` is a costructured arrow for `S : C ⥤ D` and `T : D`, then we can
    explicitly describe the quotients of `A` as the quotients `P` of `B` in `C` for which `A.hom`
    factors through the image of `P` under `S`. -/
def quotient_equiv [has_colimits C] [preserves_colimits S] (A : costructured_arrow S T) :
  subobject (op A) ≃o { P : subobject (op A.left) // ∃ q, S.map P.arrow.unop ≫ q = A.hom } :=
{ to_fun := λ P, ⟨project_quotient P, project_quotient_factors P⟩,
  inv_fun := λ P, lift_quotient P.val P.prop.some_spec,
  left_inv := λ P, lift_project_quotient _ _,
  right_inv := λ P, subtype.ext (by simp),
  map_rel_iff' := subobject.ind₂ _
  begin
    introsI P Q f g hf hg,
    refine ⟨λ h, subobject.mk_le_mk_of_comm _ (quiver.hom.unop_inj (ext _ _ _)), λ h, _⟩,
    { refine (hom_mk (subobject.of_mk_le_mk _ _ h).unop ((cancel_epi (S.map g.unop.left)).1 _)).op,
      dsimp only [mono_over.mk'_arrow],
      rw [← category.assoc, ← S.map_comp, unop_left_comp_of_mk_le_mk_unop],
      dsimp,
      simp },
    { exact unop_left_comp_of_mk_le_mk_unop _ },
    { refine subobject.mk_le_mk_of_comm (subobject.of_mk_le_mk _ _ h).unop.left.op _,
      refine quiver.hom.unop_inj _,
      have := congr_arg quiver.hom.unop (subobject.of_mk_le_mk_comp h),
      simpa [-subobject.of_mk_le_mk_comp] using congr_arg comma_morphism.left this }
  end }

/-- If `C` is well-copowered and cocomplete and `S` preserves colimits, then
    `costructured_arrow S T` is well-copowered. -/
instance well_copowered_costructured_arrow [well_powered Cᵒᵖ] [has_colimits C]
  [preserves_colimits S] : well_powered (costructured_arrow S T)ᵒᵖ :=
{ subobject_small := λ X, small_map (quotient_equiv (unop X)).to_equiv }

end costructured_arrow

end category_theory


/-
Copyright (c) 2019 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import category_theory.fin_category
import category_theory.limits.shapes.binary_products
import category_theory.limits.shapes.equalizers
import category_theory.limits.shapes.wide_pullbacks
import category_theory.limits.shapes.pullbacks
import data.fintype.basic

/-!
# Categories with finite limits.

A typeclass for categories with all finite (co)limits.
-/

universes v' u' v u

open category_theory

namespace category_theory.limits

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

/--
A category has all finite limits if every functor `J ⥤ C` with a `fin_category J` instance
has a limit.

This is often called 'finitely complete'.
-/
-- We can't just made this an `abbreviation`
-- because of https://github.com/leanprover-community/lean/issues/429
class has_finite_limits : Prop :=
(out (J : Type v) [𝒥 : small_category J] [@fin_category J 𝒥] : @has_limits_of_shape J 𝒥 C _)

@[priority 100]
instance has_limits_of_shape_of_has_finite_limits
  (J : Type v) [small_category J] [fin_category J] [has_finite_limits C] :
  has_limits_of_shape J C := has_finite_limits.out J

@[priority 100]
instance has_finite_limits_of_has_limits_of_size [has_limits_of_size.{v' u'} C] :
  has_finite_limits C :=
⟨λ J hJ hJ', by { haveI := has_limits_of_size_shrink.{0 0} C,
  exact has_limits_of_shape_of_equivalence (fin_category.equiv_as_type J) }⟩

/-- If `C` has all limits, it has finite limits. -/
@[priority 100]
instance has_finite_limits_of_has_limits [has_limits C] : has_finite_limits C := infer_instance

/--
A category has all finite colimits if every functor `J ⥤ C` with a `fin_category J` instance
has a colimit.

This is often called 'finitely cocomplete'.
-/
class has_finite_colimits : Prop :=
(out (J : Type v) [𝒥 : small_category J] [@fin_category J 𝒥] : @has_colimits_of_shape J 𝒥 C _)

@[priority 100]
instance has_limits_of_shape_of_has_finite_colimits
  (J : Type v) [small_category J] [fin_category J] [has_finite_colimits C] :
  has_colimits_of_shape J C := has_finite_colimits.out J

@[priority 100]
instance has_finite_colimits_of_has_colimits_of_size [has_colimits_of_size.{v' u'} C] :
  has_finite_colimits C :=
⟨λ J hJ hJ', by { haveI := has_colimits_of_size_shrink.{0 0} C,
  exact has_colimits_of_shape_of_equivalence (fin_category.equiv_as_type J) }⟩

/-- If `C` has all colimits, it has finite colimits. -/
@[priority 100]
instance has_finite_colimits_of_has_colimits [has_colimits C] : has_finite_colimits C :=
infer_instance

section

open walking_parallel_pair walking_parallel_pair_hom

instance fintype_walking_parallel_pair : fintype walking_parallel_pair :=
{ elems := [walking_parallel_pair.zero, walking_parallel_pair.one].to_finset,
  complete := λ x, by { cases x; simp } }

local attribute [tidy] tactic.case_bash

instance (j j' : walking_parallel_pair) : fintype (walking_parallel_pair_hom j j') :=
{ elems := walking_parallel_pair.rec_on j
    (walking_parallel_pair.rec_on j' [walking_parallel_pair_hom.id zero].to_finset
      [left, right].to_finset)
    (walking_parallel_pair.rec_on j' ∅ [walking_parallel_pair_hom.id one].to_finset),
  complete := by tidy }

end

instance : fin_category walking_parallel_pair := { }

/-- Equalizers are finite limits, so if `C` has all finite limits, it also has all equalizers -/
example [has_finite_limits C] : has_equalizers C := by apply_instance

/-- Coequalizers are finite colimits, of if `C` has all finite colimits, it also has all
    coequalizers -/
example [has_finite_colimits C] : has_coequalizers C := by apply_instance

variables {J : Type v}

local attribute [tidy] tactic.case_bash

namespace wide_pullback_shape

instance fintype_obj [fintype J] : fintype (wide_pullback_shape J) :=
by { rw wide_pullback_shape, apply_instance }

instance fintype_hom [decidable_eq J] (j j' : wide_pullback_shape J) :
  fintype (j ⟶ j') :=
{ elems :=
  begin
    cases j',
    { cases j,
      { exact {hom.id none} },
      { exact {hom.term j} } },
    { by_cases some j' = j,
      { rw h,
        exact {hom.id j} },
      { exact ∅ } }
  end,
  complete := by tidy }

end wide_pullback_shape

namespace wide_pushout_shape

instance fintype_obj [fintype J] : fintype (wide_pushout_shape J) :=
by { rw wide_pushout_shape, apply_instance }

instance fintype_hom [decidable_eq J] (j j' : wide_pushout_shape J) :
  fintype (j ⟶ j') :=
{ elems :=
  begin
    cases j,
    { cases j',
      { exact {hom.id none} },
      { exact {hom.init j'} } },
    { by_cases some j = j',
      { rw h,
        exact {hom.id j'} },
      { exact ∅ } }
  end,
  complete := by tidy }

end wide_pushout_shape

instance fin_category_wide_pullback [decidable_eq J] [fintype J] :
  fin_category (wide_pullback_shape J) :=
{ fintype_hom := wide_pullback_shape.fintype_hom }

instance fin_category_wide_pushout [decidable_eq J] [fintype J] :
  fin_category (wide_pushout_shape J) :=
{ fintype_hom := wide_pushout_shape.fintype_hom }

/--
`has_finite_wide_pullbacks` represents a choice of wide pullback
for every finite collection of morphisms
-/
-- We can't just made this an `abbreviation`
-- because of https://github.com/leanprover-community/lean/issues/429
class has_finite_wide_pullbacks : Prop :=
(out (J : Type v) [decidable_eq J] [fintype J] : has_limits_of_shape (wide_pullback_shape J) C)

instance has_limits_of_shape_wide_pullback_shape
  (J : Type v) [fintype J] [has_finite_wide_pullbacks C] :
  has_limits_of_shape (wide_pullback_shape J) C :=
by { haveI := @has_finite_wide_pullbacks.out C _ _ J (classical.dec_eq _), apply_instance }

/--
`has_finite_wide_pushouts` represents a choice of wide pushout
for every finite collection of morphisms
-/
class has_finite_wide_pushouts : Prop :=
(out (J : Type v) [decidable_eq J] [fintype J] : has_colimits_of_shape (wide_pushout_shape J) C)

instance has_colimits_of_shape_wide_pushout_shape
  (J : Type v) [fintype J] [has_finite_wide_pushouts C] :
  has_colimits_of_shape (wide_pushout_shape J) C :=
by { haveI := @has_finite_wide_pushouts.out C _ _ J (classical.dec_eq _), apply_instance }

/--
Finite wide pullbacks are finite limits, so if `C` has all finite limits,
it also has finite wide pullbacks
-/

/--
Finite wide pushouts are finite colimits, so if `C` has all finite colimits,
it also has finite wide pushouts
-/
lemma has_finite_wide_pushouts_of_has_finite_limits [has_finite_colimits C] :
  has_finite_wide_pushouts C :=
⟨λ J _ _, by exactI has_finite_colimits.out _⟩

instance fintype_walking_pair : fintype walking_pair :=
{ elems := {walking_pair.left, walking_pair.right},
  complete := λ x, by { cases x; simp } }

/-- Pullbacks are finite limits, so if `C` has all finite limits, it also has all pullbacks -/
example [has_finite_wide_pullbacks C] : has_pullbacks C := by apply_instance

/-- Pushouts are finite colimits, so if `C` has all finite colimits, it also has all pushouts -/
example [has_finite_wide_pushouts C] : has_pushouts C := by apply_instance

end category_theory.limits