/-
Copyright (c) 2017 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Sebastian Ullrich

! This file was ported from Lean 3 source module init.data.string.ops
! leanprover-community/mathlib commit 9af482290ef68e8aaa5ead01aa7b09b7be7019fd
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
prelude
import Leanbin.Init.Data.Bool.Lemmas
import Leanbin.Init.Data.String.Basic
import Leanbin.Init.Meta.WellFoundedTactics

namespace String

namespace Iterator

@[simp]
theorem nextToString_mkIterator (s : String) : s.mkIterator.nextToString = s := by
  induction s <;> rfl
#align string.iterator.next_to_string_mk_iterator String.Iterator.nextToString_mkIterator

@[simp]
theorem length_nextToString_next (it : Iterator) :
    it.next.nextToString.length = it.nextToString.length - 1 := by
  cases it <;> cases it_snd <;>
    simp [iterator.next, iterator.next_to_string, String.length, Nat.add_sub_cancel_left]
#align string.iterator.length_next_to_string_next String.Iterator.length_nextToString_next

theorem zero_lt_length_nextToString_of_hasNext {it : Iterator} :
    it.hasNext → 0 < it.nextToString.length := by
  cases it <;> cases it_snd <;>
    simp [iterator.has_next, iterator.next_to_string, String.length, Nat.zero_lt_one_add,
      Nat.add_comm, false_imp_iff]
#align string.iterator.zero_lt_length_next_to_string_of_has_next String.Iterator.zero_lt_length_nextToString_of_hasNext

end Iterator

-- TODO(Sebastian): generalize to something like
-- https://doc.rust-lang.org/std/primitive.str.html#method.split
private def split_core (p : Char → Bool) : Iterator → Iterator → List String
  | start, stop =>
    if h : stop.hasNext then
      -- wf hint
      have : stop.nextToString.length - 1 < stop.nextToString.length :=
        Nat.sub_lt (Iterator.zero_lt_length_nextToString_of_hasNext h) (by decide)
      if p stop.curr then
        let rest := stop.next.nextToString
        (start.extract stop).getD "" :: split_core stop.next stop.next
      else split_core start stop.next
    else [start.nextToString]termination_by'
  ⟨_, measure_wf fun e => e.2.nextToString.length⟩
#align string.split_core string.split_core

/- warning: string.split -> String.split is a dubious translation:
lean 3 declaration is
  (Char -> Bool) -> String -> (List.{0} String)
but is expected to have type
  String -> (Char -> Bool) -> (List.{0} String)
Case conversion may be inaccurate. Consider using '#align string.split String.splitₓ'. -/
def split (p : Char → Bool) (s : String) : List String :=
  splitCore p s.mkIterator s.mkIterator
#align string.split String.split

end String


import util.meta.tactic
import data.nat.basic
import util.data.nat
import util.data.order
import tactic

import separation.heap.basic

namespace heap

open nat list (hiding bind)

@[simp]
lemma heap_emp_disjoint (h : heap)
: heap.emp ## h :=
by { dunfold disjoint heap.emp, intros, left, refl }

@[simp]
lemma disjoint_heap_emp (h : heap)
: h ## heap.emp :=
by { dunfold disjoint heap.emp, intros, right, refl }

@[simp]
lemma heap_emp_part'_eq_self (h : heap)
: part' heap.emp h (heap_emp_disjoint _) = h :=
begin
  apply funext, intro,
  unfold part',
  cases (h x) ; simp [heap.emp,has_orelse.orelse,option.orelse]
end

@[simp]
lemma part'_heap_emp_eq_self (h : heap)
: part' h heap.emp (disjoint_heap_emp _) = h :=
begin
  apply funext, intro,
  unfold part',
  cases (h x) ; simp [heap.emp,has_orelse.orelse,option.orelse]
end

lemma maplet_disjoint_heap_mk_of_lt {p q : pointer} (v : word) (vs : list word)
  (h : p < q)
: disjoint (maplet p v) (heap.mk q vs) :=
begin
  revert q v,
  induction vs with v vs ; intros q v h,
  { apply disjoint_heap_emp },
  { simp [(##)], intro ptr,
    simp_intros h₁ [or_iff_not_imp,heap.mk],
    split,
    { simp [maplet] at ⊢ h₁,
      ite_cases with h₀ at h₁ ⊢,
      { contradiction },
      rw [← h₀,if_neg],
      apply ne_of_gt, apply h  },
    { revert h₁, rw ← or_iff_not_imp,
      apply vs_ih,
      transitivity q, assumption,
      apply lt_add_of_pos_right,
      apply zero_lt_one, } }
end

lemma maplet_disjoint_heap_mk (p : pointer) (v : word) (vs : list word)
: maplet p v ## heap.mk (p + 1) vs :=
begin
  apply maplet_disjoint_heap_mk_of_lt,
  apply lt_add_of_pos_right,
  apply zero_lt_one,
end

lemma heap_mk_cons (p : pointer) (v : word) (vs : list word)
:   heap.mk p (v :: vs)
  = part' (maplet p v) (heap.mk (p+1) vs) (maplet_disjoint_heap_mk p v vs) :=
by { funext x, simp [heap.mk,part'] }

@[symm]
lemma disjoint_symm {h₀ h₁ : heap}
  (h : h₀ ## h₁)
: h₁ ## h₀ :=
assume p, or.symm (h p)

lemma part'_comm {h₀ h₁ : heap}
  (h : h₀ ## h₁)
: part' h₀ h₁ = part' h₁ h₀ (disjoint_symm h) :=
begin
  funext p, unfold part',
  cases h p with h h ; simp [h],
end

lemma part_disjoint_assoc_left {h₀ h₁ h₂ : heap}
  (Hdisj : h₀ ## h₁)
  (Hdisj' : h₁ ## h₂)
  (h : part' h₀ h₁ Hdisj ## h₂)
: h₀ ## part' h₁ h₂ Hdisj' :=
begin
  intro p,
  cases h p with h' h' ; unfold part' at *,
  { rw or_else_eq_none_iff at h',
    simp [h'.left] },
  { simp [h',Hdisj p], },
end

lemma part_disjoint_assoc_right {h₀ h₁ h₂ : heap}
  (Hdisj : h₀ ## h₁)
  (Hdisj' : h₁ ## h₂)
  (h : h₀ ## part' h₁ h₂)
: part' h₀ h₁ ## h₂ :=
begin
  intro p,
  cases h p with h' h' ; unfold part' at *,
  { simp [h',Hdisj' p], },
  { rw or_else_eq_none_iff at h',
    simp [h'.right] },
end

@[simp]
lemma eq_emp_of_part' (hp a : heap)
  (h  : a ## hp)
: a = part' a hp ↔ hp = heap.emp :=
begin
  split ; intro h₀,
  { funext k,
    have h₁ : a k = part' a hp h k,
    { rw ← h₀, },
    clear h₀,
    dsimp [part',heap.emp,heap.disjoint] at *,
    specialize h k,
    cases h with h₂ h₂ ; simp [h₂] at h₁,
    rw h₁, rw h₂, },
  { simp [h₀], }
end

lemma part'_disjoint {h₁ h₂ h₃ : heap}
  {H₀ : h₂ ## h₃}
  (H₁ : h₁ ## h₃)
  (H₂ : h₁ ## h₂)
: part' h₂ h₃ ## h₁ :=
begin
  intro p,
  rw [or.comm,or_iff_not_imp,part',or_else_eq_none_iff],
  intros H₃,
  specialize H₁ p,
  specialize H₂ p,
  rw or_iff_not_imp at H₁ H₂,
  split
  ; apply_assumption
  ; apply_assumption,
end

lemma disjoint_part' {h₁ h₂ h₃ : heap}
  {H₀ : h₂ ## h₃}
  (H₁ : h₁ ## h₃)
  (H₁ : h₁ ## h₂)
: h₁ ## part' h₂ h₃ :=
by { apply disjoint_symm,
     apply part'_disjoint
     ; assumption }

lemma disjoint_of_part'_disjoint_right {h₁ h₂ h₃ : heap}
  (H₁ : h₂ ## h₃)
  (H₀ : part' h₂ h₃ ## h₁)
: h₃ ## h₁ :=
begin
  intro p,
  cases H₀ p with H₂ H₂,
  { unfold part' at H₂,
    rw or_else_eq_none_iff at H₂,
    simp [H₂.right] },
  { simp [H₂] }
end

lemma disjoint_of_part'_disjoint_left {h₁ h₂ h₃ : heap}
  (H₁ : h₂ ## h₃)
  (H₀ : part' h₂ h₃ ## h₁)
: h₂ ## h₁ :=
begin
  have H₁ := disjoint_symm H₁,
  apply disjoint_of_part'_disjoint_right H₁,
  rw part'_comm, apply H₀,
end

lemma disjoint_of_disjoint_part'_right {h₁ h₂ h₃ : heap}
  (H₁ : h₂ ## h₃)
  (H₀ : h₁ ## part' h₂ h₃)
: h₁ ## h₃ :=
begin
  intro p,
  rw or_iff_not_imp,
  intro H₂,
  specialize H₀ p,
  rw or_iff_not_imp at H₀,
  specialize H₀ H₂,
  simp [part'] at H₀,
  apply H₀.right,
end

lemma disjoint_of_disjoint_part'_left {h₁ h₂ h₃ : heap}
  (H₁ : h₂ ## h₃)
  (H₀ : h₁ ## part' h₂ h₃)
: h₁ ## h₂ :=
by { apply disjoint_of_disjoint_part'_right,
     rw part'_comm, apply H₀,
     symmetry, apply H₁, }

namespace tactic.interactive

open heap
open tactic tactic.interactive (ite_cases)
open lean lean.parser interactive interactive.types

meta def break_disjoint_asm_symm (l : expr)
: tactic unit :=
do t ← infer_type l,
   match t with
    | `(%%h₀ ## (%%h₁ : heap)) :=
      do h ← get_unused_name `h,
         to_expr ``(disjoint_symm %%l) >>= note h none,
         return ()
    | _ :=
         fail $ format! "expecting {l} of the form _ ## _"
   end

meta def break_disjoint_asm_r (l : expr)
: tactic (list expr) :=
do t ← infer_type l,
   match t with
    | `(%%h₀ ## part' %%h₁ %%h₂ %%h₃) :=
      do h ← get_unused_name `h,
         r ← to_expr ``(disjoint_of_disjoint_part'_right _ %%l) >>= note h none,
         h ← get_unused_name `h,
         r' ← to_expr ``(disjoint_of_disjoint_part'_left _ %%l) >>= note h none,
         try (tactic.clear l),
         return [r,r']
    | _ :=
         fail $ format! "expecting {l} of the form _ ## _"
   end
meta def break_disjoint_asm_l (l : expr)
: tactic (list expr) :=
do t ← infer_type l,
   match t with
    | `(part' %%h₁ %%h₂ %%h₃ ## %%h₀) :=
      do h ← get_unused_name `h,
         r ← to_expr ``(disjoint_of_part'_disjoint_right _ %%l) >>= note h none,
         h ← get_unused_name `h,
         r' ← to_expr ``(disjoint_of_part'_disjoint_left _ %%l) >>= note h none,
         try (tactic.clear l),
         return [r,r']
    | _ :=
         break_disjoint_asm_r l
   end

meta def break_disjoint_asm'
: expr → tactic unit
| l :=
do xs ← break_disjoint_asm_l l,
   xs.for_each (try ∘ break_disjoint_asm')

meta def break_disjoint_asm (l : parse ident)
: tactic (list expr) :=
do get_local l >>= break_disjoint_asm_l

meta def break_disjoint_asms
: tactic unit :=
do ls ← local_context,
   ls.for_each (try ∘ break_disjoint_asm'),
   ls ← local_context,
   ls.for_each (try ∘ break_disjoint_asm_symm)

meta def prove_disjoint'
: tactic unit :=
    assumption
<|> (`[ apply part'_disjoint ] ; assumption )
<|> (`[ apply disjoint_part' ] ; assumption )
<|> failed

meta def prove_disjoint
: tactic unit :=
do break_disjoint_asms,
   prove_disjoint'

run_cmd add_interactive [`prove_disjoint]

end tactic.interactive

lemma part'_assoc {h₀ h₁ h₂ : heap}
  (Hdisj₀ : h₀ ## h₁)
  (Hdisj₂ : part' h₀ h₁ ## h₂)
: part' (part' h₀ h₁) h₂ Hdisj₂ = part' h₀ (part' h₁ h₂
     (by prove_disjoint)) (by prove_disjoint) :=
by { funext p, simp [part'] }

lemma delete_disjoint_delete {p : pointer} {n : ℕ} {hp₀ hp₁ : heap}
  (h : hp₀ ## hp₁)
: heap.delete p n hp₀ ## heap.delete p n hp₁ :=
begin
  revert p,
  induction n with n ; intro p,
  { intro q,
    simp [heap.delete,h q], },
  { intro q,
    simp [heap.delete],
    ite_cases,
    apply n_ih, simp },
end

lemma delete_over_part' {p : pointer} {n : ℕ} {hp₀ hp₁ : heap}
  (h : hp₀ ## hp₁)
:   heap.delete p n (part' hp₀ hp₁)
  = part' (heap.delete p n hp₀) (heap.delete p n hp₁) (delete_disjoint_delete h) :=
begin
  revert p,
  induction n with n ; intro p,
  { funext q,
    refl },
  { funext q,
    simp [heap.delete],
    ite_cases with h',
    { simp [n_ih,part',heap.delete,if_neg,h'], },
    { simp [part',heap.delete,if_pos,h'], } }
end

lemma heap_delete_maplet (p q : pointer) (k : ℕ) (v : word)
  (h : p < q)
: heap.delete q k (maplet p v) = maplet p v :=
begin
  funext x,
  revert q,
  induction k with k ; intros q h, refl,
  { simp [heap.delete],
    ite_cases, apply @k_ih (q + 1) _,
    { transitivity q, assumption,
      apply lt_succ_self },
    simp [maplet],
    subst x,
    rw if_neg,
    apply ne_of_lt h },
end

lemma delete_part'_heap_mk {p : pointer} {vs : list word} {hp : heap}
  (h : heap.mk p vs ## hp)
: heap.delete p (length vs) (part' (heap.mk p vs) hp) = hp :=
begin
  revert p,
  induction vs with v vs
  ; intros p h₀,
  { simp [heap.delete,heap.mk], funext q, refl },
  { funext q,
    simp [length,add_one,heap.delete],
    ite_cases,
    { simp [heap_mk_cons],
      have h₁ : heap.mk (p + 1) vs ## hp,
      { simp [heap.mk] at h₀,
        intro p',
        specialize h₀ p',
        rw or_iff_not_imp at h₀ ⊢,
        intros h₁, apply h₀,
        rw or_else_eq_none_iff,
        revert h₁, apply mt,
        apply and.elim_right, },
      have h₂ : heap.delete (succ p) (length vs) (maplet p v) = maplet p v,
      { apply heap_delete_maplet, apply lt_succ_self, },
      simp [part'_assoc,delete_over_part',vs_ih h₁,h₂,part',maplet,if_neg,h], },
  { have h₁ : maplet p v ## hp,
    { rw heap_mk_cons at h₀, prove_disjoint },
    simp [(##)] at h₁,
    specialize h₁ q, rw [or_iff_not_imp] at h₁,
    symmetry, apply h₁,
    simp [maplet,if_pos,h] }, }
end

lemma part'_insert (hp hp' : heap) (p : pointer) (v : word)
  (h₀ : hp.insert p v ## hp')
  (h₁ : hp ## hp')
: part' (hp.insert p v) hp' = (part' hp hp').insert p v :=
begin
  funext x,
  simp [part',heap.insert],
  ite_cases,
  simp [some_or_else],
end

lemma maplet_insert_disjoint_iff (p : pointer) (v v' : word) (hp : heap)
: (maplet p v).insert p v' ## hp ↔ maplet p v ## hp :=
begin
  simp [disjoint,heap.insert],
  apply forall_congr,
  intro p',
  ite_cases,
  simp [maplet,if_pos,h],
end

@[simp]
lemma some_part'
  (hp₀ hp₁ : heap)
  (h : hp₀ ## hp₁)
: some (part' hp₀ hp₁) = part (some hp₀) (some hp₁) :=
by { simp [part,bind,option.bind,dif_pos, h], }

@[simp]
lemma heap_emp_part
  (hp : heap)
: part (some heap.emp) (some hp) = some hp :=
by simp [part]

@[simp]
lemma part_heap_emp
  (hp : heap)
: part (some hp) (some heap.emp) = some hp :=
by simp [part]

end heap

namespace tactic.interactive

open heap
open tactic tactic.interactive (ite_cases)
open lean lean.parser interactive interactive.types

meta def try_then (x y : tactic unit) : tactic unit :=
focus1 $
do (some ()) ← try_core x | tactic.skip,
   tactic.all_goals y

meta def expand_part_ite : tactic unit :=
do tactic.try `[ dsimp [part] ],
   tactic.reflexivity <|> try_then (ite_cases none $ loc.ns [none]) expand_part_ite

meta def contradict_asm
: tactic unit :=
do ls ← local_context,
   ls.any_of (λ e,
     do `(¬ %%t) ← infer_type e | failed ,
         exfalso, tactic.apply e, tactic.clear e)

end tactic.interactive

namespace heap

lemma part_assoc
  (a b c : option heap)
: part (part a b) c = part a (part b c) :=
begin
  cases a ; cases b ; cases c
  ; expand_part_ite,
   all_goals { {contradict_asm ; prove_disjoint} <|> rw part'_assoc },
end

lemma part_comm
  (a b : option heap)
: part a b = part b a :=
begin
  cases a ; cases b
  ; dsimp [part] ; try { refl }
  ; ite_cases with i
  ; ite_cases with i'
  ; try { contradict_asm, symmetry, assumption },
  rw part'_comm,
end

instance : is_associative (option heap) part :=
⟨ part_assoc ⟩
instance : is_commutative (option heap) part :=
⟨ part_comm ⟩

lemma disjoint_of_is_some_part
  {hp₀ hp₁ : heap}
  (h : (part (some hp₀) (some hp₁)).is_some)
: hp₀ ## hp₁ :=
by { dsimp [part] at h,
     ite_cases with h at h,
     contradiction,
     assumption }

lemma disjoint_of_part_eq_some
  {hp₀ hp₁ hp₂ : heap}
  (h : some hp₂ = (part (some hp₀) (some hp₁)))
: hp₀ ## hp₁ :=
by { apply disjoint_of_is_some_part, rw ← h, exact rfl }

lemma eq_part'_of_some_eq_part
  (hp₀ hp₁ hp : heap)
  (h : some hp = part (some hp₀) (some hp₁))
: hp = part' hp₀ hp₁ (disjoint_of_part_eq_some h) :=
by { apply @option.no_confusion _ _ (some hp) (some _) _ id,
     simp [h], }

lemma is_some_of_is_some_part_right
  (hp₀ : option heap) {hp₁ : option heap}
  (h : (part hp₀ hp₁).is_some)
: hp₁.is_some :=
by { cases hp₀ ; cases hp₁ ; try { contradiction },
     exact rfl }

lemma is_some_of_is_some_part_left
  {hp₀ : option heap} (hp₁ : option heap)
  (h : (part hp₀ hp₁).is_some)
: hp₀.is_some :=
by { cases hp₀ ; cases hp₁ ; try { contradiction },
     exact rfl }

@[simp]
lemma some_eq_some_iff (x y : heap)
: some x = some y ↔ x = y :=
by { split ; intro h, injection h, subst x }

def opt_apl : option heap → pointer → option word
 | (some hp) p := hp p
 | none _ := none

lemma opt_apl_some (hp : heap) (p : pointer)
: opt_apl (some hp) p = hp p :=
rfl

lemma opt_apl_part_maplet (hp : heap) (p : pointer) (v : word)
  (h : maplet p v ## hp)
: (opt_apl (part (some (maplet p v)) (some hp)) p) = some v :=
begin
  unfold part,
  rw [dif_pos] ; [ skip , apply h ],
  rw [opt_apl,part',maplet,if_pos rfl],
  refl,
end

@[simp]
lemma eq_emp_of_part (a : heap) (hp : option heap)
: some a = part (some a) hp ↔ hp = some heap.emp :=
begin
  cases hp ; dsimp [part],
  split ; intro h ; contradiction,
  ite_cases with h₀,
  split ; intros h₁,
  { contradiction },
  { injection h₁ with h₂, simp [h₂] at h₀,
    cases h₀, },
  split ; intro h₁ ; injection h₁ with h₂,
  { simp [eq_emp_of_part'] at h₂,
    simp [h₂] },
  { simp [h₂], }
end

@[simp]
lemma part'_eq_emp (a b : option heap)
: part a b = some heap.emp ↔ a = some heap.emp ∧ b = some heap.emp :=
begin
  split ; simp_intros h ;
  cases a ; cases b
  ; try { refl }
  ; try { cases h with h₀ h₁ }
  ; try { contradiction }
  ; try { rw [h₀,h₁,← some_part' _ _ (disjoint_heap_emp _)
             ,heap_emp_part'_eq_self] },
  { unfold part at h,
    revert h, ite_cases with h,
    contradiction,
    intro h₀,
    injection h₀ with h₁,
    have h₂ : ∀ p, part' a b h p = heap.emp p,
    { intro, rw h₁ },
    simp [part',heap.emp] at h₂,
    split ; congr ; funext p,
    { simp [(h₂ p).left], refl },
    { simp [(h₂ p).right], refl }, }
end

@[simp]
lemma emp_left_combine (hp : heap)
: heap.emp <+ hp = hp :=
by { funext y, simp [left_combine,heap.emp], }

@[simp]
lemma left_combine_emp (hp : heap)
: hp <+ heap.emp = hp :=
by { funext y, simp [left_combine,heap.emp], }

@[simp]
lemma heap_mk_nil_eq_emp (p : pointer)
: heap.mk p [] = heap.emp := by simp [heap.mk]

-- #check [3] ++ (3 : ℕ)

@[simp]
lemma heap_mk_eq_none (p p' : pointer) (vs : list word)
: heap.mk p vs p' = none ↔ p' < p ∨ p + vs.length ≤ p' :=
begin
  induction vs generalizing p,
  { split; intro, apply lt_or_le,
    refl, },
  { simp!, split_ifs,
    { subst p', simp [lt_irrefl,nat.one_add,nat.zero_lt_succ],  },
    { simp [add_assoc,vs_ih], apply or_congr; [skip, refl], replace h := ne.symm h,
      simp [nat.lt_succ_iff,le_iff_lt h] } }
end

lemma some_insert_left_eq_part {hp₀ hp₁ : heap}
  (h : hp₀ ## hp₁)
: some (hp₀ <+ hp₁) = part (some hp₀) (some hp₁) :=
by dsimp [part]; split_ifs; ext; simp!

end heap


/-
Copyright (c) 2018 Simon Hudon. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Simon Hudon, Sean Leather
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.algebra.free_monoid
import Mathlib.algebra.opposites
import Mathlib.control.traversable.instances
import Mathlib.control.traversable.lemmas
import Mathlib.category_theory.category.default
import Mathlib.category_theory.endomorphism
import Mathlib.category_theory.types
import Mathlib.category_theory.category.Kleisli
import Mathlib.PostPort

universes u u_1

namespace Mathlib

/-!

# List folds generalized to `traversable`

Informally, we can think of `foldl` as a special case of `traverse` where we do not care about the
reconstructed data structure and, in a state monad, we care about the final state.

The obvious way to define `foldl` would be to use the state monad but it
is nicer to reason about a more abstract interface with `fold_map` as a
primitive and `fold_map_hom` as a defining property.

```
def fold_map {α ω} [has_one ω] [has_mul ω] (f : α → ω) : t α → ω := ...

lemma fold_map_hom (α β)
  [monoid α] [monoid β] (f : α → β) [is_monoid_hom f]
  (g : γ → α) (x : t γ) :
  f (fold_map g x) = fold_map (f ∘ g) x :=
...
```

`fold_map` uses a monoid ω to accumulate a value for every element of
a data structure and `fold_map_hom` uses a monoid homomorphism to
substitute the monoid used by `fold_map`. The two are sufficient to
define `foldl`, `foldr` and `to_list`. `to_list` permits the
formulation of specifications in terms of operations on lists.

Each fold function can be defined using a specialized
monoid. `to_list` uses a free monoid represented as a list with
concatenation while `foldl` uses endofunctions together with function
composition.

The definition through monoids uses `traverse` together with the
applicative functor `const m` (where `m` is the monoid). As an
implementation, `const` guarantees that no resource is spent on
reconstructing the structure during traversal.

A special class could be defined for `foldable`, similarly to Haskell,
but the author cannot think of instances of `foldable` that are not also
`traversable`.
-/

namespace monoid

/--
For a list, foldl f x [y₀,y₁] reduces as follows
  calc  foldl f x [y₀,y₁]
      = foldl f (f x y₀) [y₁]      : rfl
  ... = foldl f (f (f x y₀) y₁) [] : rfl
  ... = f (f x y₀) y₁              : rfl

with f : α → β → α
     x : α
     [y₀,y₁] : list β

We can view the above as a composition of functions:

  ... = f (f x y₀) y₁              : rfl
  ... = flip f y₁ (flip f y₀ x)    : rfl
  ... = (flip f y₁ ∘ flip f y₀) x  : rfl

We can use traverse and const to construct this composition:

  calc   const.run (traverse (λ y, const.mk' (flip f y)) [y₀,y₁]) x
       = const.run ((::) <$> const.mk' (flip f y₀) <*> traverse (λ y, const.mk' (flip f y)) [y₁]) x
  ...  = const.run ((::) <$> const.mk' (flip f y₀) <*>
           ( (::) <$> const.mk' (flip f y₁) <*> traverse (λ y, const.mk' (flip f y)) [] )) x
  ...  = const.run ((::) <$> const.mk' (flip f y₀) <*>
           ( (::) <$> const.mk' (flip f y₁) <*> pure [] )) x
  ...  = const.run ( ((::) <$> const.mk' (flip f y₁) <*> pure []) ∘
           ((::) <$> const.mk' (flip f y₀)) ) x
  ...  = const.run ( const.mk' (flip f y₁) ∘ const.mk' (flip f y₀) ) x
  ...  = const.run ( flip f y₁ ∘ flip f y₀ ) x
  ...  = f (f x y₀) y₁

And this is how `const` turns a monoid into an applicative functor and
how the monoid of endofunctions define `foldl`.
-/
def foldl (α : Type u) := category_theory.End αᵒᵖ

def foldl.mk {α : Type u} (f : α → α) : foldl α := opposite.op f

def foldl.get {α : Type u} (x : foldl α) : α → α := opposite.unop x

def foldl.of_free_monoid {α : Type u} {β : Type u} (f : β → α → β) (xs : free_monoid α) : foldl β :=
  opposite.op (flip (list.foldl f) xs)

def foldr (α : Type u) := category_theory.End α

def foldr.mk {α : Type u} (f : α → α) : foldr α := f

def foldr.get {α : Type u} (x : foldr α) : α → α := x

def foldr.of_free_monoid {α : Type u} {β : Type u} (f : α → β → β) (xs : free_monoid α) : foldr β :=
  flip (list.foldr f) xs

def mfoldl (m : Type u → Type u) [Monad m] (α : Type u) :=
  category_theory.End (category_theory.Kleisli.mk m α)ᵒᵖ

def mfoldl.mk {m : Type u → Type u} [Monad m] {α : Type u} (f : α → m α) : mfoldl m α :=
  opposite.op f

def mfoldl.get {m : Type u → Type u} [Monad m] {α : Type u} (x : mfoldl m α) : α → m α :=
  opposite.unop x

def mfoldl.of_free_monoid {m : Type u → Type u} [Monad m] {α : Type u} {β : Type u}
    (f : β → α → m β) (xs : free_monoid α) : mfoldl m β :=
  opposite.op (flip (mfoldl f) xs)

def mfoldr (m : Type u → Type u) [Monad m] (α : Type u) :=
  category_theory.End (category_theory.Kleisli.mk m α)

def mfoldr.mk {m : Type u → Type u} [Monad m] {α : Type u} (f : α → m α) : mfoldr m α := f

def mfoldr.get {m : Type u → Type u} [Monad m] {α : Type u} (x : mfoldr m α) : α → m α := x

def mfoldr.of_free_monoid {m : Type u → Type u} [Monad m] {α : Type u} {β : Type u}
    (f : α → β → m β) (xs : free_monoid α) : mfoldr m β :=
  flip (list.mfoldr f) xs

end monoid

namespace traversable

def fold_map {t : Type u → Type u} [traversable t] {α : Type u} {ω : Type u} [HasOne ω] [Mul ω]
    (f : α → ω) : t α → ω :=
  traverse (functor.const.mk' ∘ f)

def foldl {α : Type u} {β : Type u} {t : Type u → Type u} [traversable t] (f : α → β → α) (x : α)
    (xs : t β) : α :=
  monoid.foldl.get (fold_map (monoid.foldl.mk ∘ flip f) xs) x

def foldr {α : Type u} {β : Type u} {t : Type u → Type u} [traversable t] (f : α → β → β) (x : β)
    (xs : t α) : β :=
  monoid.foldr.get (fold_map (monoid.foldr.mk ∘ f) xs) x

/--
Conceptually, `to_list` collects all the elements of a collection
in a list. This idea is formalized by

  `lemma to_list_spec (x : t α) : to_list x = fold_map free_monoid.mk x`.

The definition of `to_list` is based on `foldl` and `list.cons` for
speed. It is faster than using `fold_map free_monoid.mk` because, by
using `foldl` and `list.cons`, each insertion is done in constant
time. As a consequence, `to_list` performs in linear.

On the other hand, `fold_map free_monoid.mk` creates a singleton list
around each element and concatenates all the resulting lists. In
`xs ++ ys`, concatenation takes a time proportional to `length xs`. Since
the order in which concatenation is evaluated is unspecified, nothing
prevents each element of the traversable to be appended at the end
`xs ++ [x]` which would yield a `O(n²)` run time. -/
def to_list {α : Type u} {t : Type u → Type u} [traversable t] : t α → List α :=
  list.reverse ∘ foldl (flip List.cons) []

def length {α : Type u} {t : Type u → Type u} [traversable t] (xs : t α) : ℕ :=
  ulift.down (foldl (fun (l : ulift ℕ) (_x : α) => ulift.up (ulift.down l + 1)) (ulift.up 0) xs)

def mfoldl {α : Type u} {β : Type u} {t : Type u → Type u} [traversable t] {m : Type u → Type u}
    [Monad m] (f : α → β → m α) (x : α) (xs : t β) : m α :=
  monoid.mfoldl.get (fold_map (monoid.mfoldl.mk ∘ flip f) xs) x

def mfoldr {α : Type u} {β : Type u} {t : Type u → Type u} [traversable t] {m : Type u → Type u}
    [Monad m] (f : α → β → m β) (x : β) (xs : t α) : m β :=
  monoid.mfoldr.get (fold_map (monoid.mfoldr.mk ∘ f) xs) x

def map_fold {α : Type u} {β : Type u} [monoid α] [monoid β] (f : α → β) [is_monoid_hom f] :
    applicative_transformation (functor.const α) (functor.const β) :=
  applicative_transformation.mk (fun (x : Type u_1) => f) sorry sorry

def free.mk {α : Type u} : α → free_monoid α := list.ret

def free.map {α : Type u} {β : Type u} (f : α → β) : free_monoid α → free_monoid β := list.map f

theorem free.map_eq_map {α : Type u} {β : Type u} (f : α → β) (xs : List α) :
    f <$> xs = free.map f xs :=
  rfl

protected instance free.map.is_monoid_hom {α : Type u} {β : Type u} (f : α → β) :
    is_monoid_hom (free.map f) :=
  is_monoid_hom.mk
    (eq.mpr
      (id
        ((fun (a a_1 : free_monoid β) (e_1 : a = a_1) (ᾰ ᾰ_1 : free_monoid β) (e_2 : ᾰ = ᾰ_1) =>
            congr (congr_arg Eq e_1) e_2)
          (free.map f 1) []
          (Eq.trans
            (Eq.trans
              ((fun (f f_1 : α → β) (e_1 : f = f_1) (ᾰ ᾰ_1 : free_monoid α) (e_2 : ᾰ = ᾰ_1) =>
                  congr (congr_arg free.map e_1) e_2)
                f f (Eq.refl f) 1 [] free_monoid.one_def)
              (congr_fun (free.map.equations._eqn_1 f) []))
            (list.map.equations._eqn_1 f))
          1 [] free_monoid.one_def))
      (Eq.refl []))

protected instance fold_foldl {α : Type u} {β : Type u} (f : β → α → β) :
    is_monoid_hom (monoid.foldl.of_free_monoid f) :=
  is_monoid_hom.mk rfl

theorem foldl.unop_of_free_monoid {α : Type u} {β : Type u} (f : β → α → β) (xs : free_monoid α)
    (a : β) : opposite.unop (monoid.foldl.of_free_monoid f xs) a = list.foldl f a xs :=
  rfl

protected instance fold_foldr {α : Type u} {β : Type u} (f : α → β → β) :
    is_monoid_hom (monoid.foldr.of_free_monoid f) :=
  is_monoid_hom.mk rfl

@[simp] theorem mfoldl.unop_of_free_monoid {α : Type u} {β : Type u} (m : Type u → Type u) [Monad m]
    [is_lawful_monad m] (f : β → α → m β) (xs : free_monoid α) (a : β) :
    opposite.unop (monoid.mfoldl.of_free_monoid f xs) a = mfoldl f a xs :=
  rfl

protected instance fold_mfoldl {α : Type u} {β : Type u} (m : Type u → Type u) [Monad m]
    [is_lawful_monad m] (f : β → α → m β) : is_monoid_hom (monoid.mfoldl.of_free_monoid f) :=
  is_monoid_hom.mk rfl

protected instance fold_mfoldr {α : Type u} {β : Type u} (m : Type u → Type u) [Monad m]
    [is_lawful_monad m] (f : α → β → m β) : is_monoid_hom (monoid.mfoldr.of_free_monoid f) :=
  is_monoid_hom.mk rfl

theorem fold_map_hom {α : Type u} {β : Type u} {γ : Type u} {t : Type u → Type u} [traversable t]
    [is_lawful_traversable t] [monoid α] [monoid β] (f : α → β) [is_monoid_hom f] (g : γ → α)
    (x : t γ) : f (fold_map g x) = fold_map (f ∘ g) x :=
  Eq.trans
    (Eq.trans (Eq.trans rfl rfl)
      (is_lawful_traversable.naturality (map_fold f) (functor.const.mk' ∘ g) x))
    rfl

theorem fold_map_hom_free {α : Type u} {β : Type u} {t : Type u → Type u} [traversable t]
    [is_lawful_traversable t] [monoid β] (f : free_monoid α → β) [is_monoid_hom f] (x : t α) :
    f (fold_map free.mk x) = fold_map (f ∘ free.mk) x :=
  fold_map_hom f free.mk x

theorem fold_mfoldl_cons {α : Type u} {β : Type u} {m : Type u → Type u} [Monad m]
    [is_lawful_monad m] (f : α → β → m α) (x : β) (y : α) : mfoldl f y (free.mk x) = f y x :=
  sorry

theorem fold_mfoldr_cons {α : Type u} {β : Type u} {m : Type u → Type u} [Monad m]
    [is_lawful_monad m] (f : β → α → m α) (x : β) (y : α) : list.mfoldr f y (free.mk x) = f x y :=
  sorry

@[simp] theorem foldl.of_free_monoid_comp_free_mk {α : Type u} {β : Type u} (f : α → β → α) :
    monoid.foldl.of_free_monoid f ∘ free.mk = monoid.foldl.mk ∘ flip f :=
  rfl

@[simp] theorem foldr.of_free_monoid_comp_free_mk {α : Type u} {β : Type u} (f : β → α → α) :
    monoid.foldr.of_free_monoid f ∘ free.mk = monoid.foldr.mk ∘ f :=
  rfl

@[simp] theorem mfoldl.of_free_monoid_comp_free_mk {α : Type u} {β : Type u} {m : Type u → Type u}
    [Monad m] [is_lawful_monad m] (f : α → β → m α) :
    monoid.mfoldl.of_free_monoid f ∘ free.mk = monoid.mfoldl.mk ∘ flip f :=
  sorry

@[simp] theorem mfoldr.of_free_monoid_comp_free_mk {α : Type u} {β : Type u} {m : Type u → Type u}
    [Monad m] [is_lawful_monad m] (f : β → α → m α) :
    monoid.mfoldr.of_free_monoid f ∘ free.mk = monoid.mfoldr.mk ∘ f :=
  sorry

theorem to_list_spec {α : Type u} {t : Type u → Type u} [traversable t] [is_lawful_traversable t]
    (xs : t α) : to_list xs = fold_map free.mk xs :=
  sorry

theorem fold_map_map {α : Type u} {β : Type u} {γ : Type u} {t : Type u → Type u} [traversable t]
    [is_lawful_traversable t] [monoid γ] (f : α → β) (g : β → γ) (xs : t α) :
    fold_map g (f <$> xs) = fold_map (g ∘ f) xs :=
  sorry

theorem foldl_to_list {α : Type u} {β : Type u} {t : Type u → Type u} [traversable t]
    [is_lawful_traversable t] (f : α → β → α) (xs : t β) (x : α) :
    foldl f x xs = list.foldl f x (to_list xs) :=
  sorry

theorem foldr_to_list {α : Type u} {β : Type u} {t : Type u → Type u} [traversable t]
    [is_lawful_traversable t] (f : α → β → β) (xs : t α) (x : β) :
    foldr f x xs = list.foldr f x (to_list xs) :=
  sorry

theorem to_list_map {α : Type u} {β : Type u} {t : Type u → Type u} [traversable t]
    [is_lawful_traversable t] (f : α → β) (xs : t α) : to_list (f <$> xs) = f <$> to_list xs :=
  sorry

@[simp] theorem foldl_map {α : Type u} {β : Type u} {γ : Type u} {t : Type u → Type u}
    [traversable t] [is_lawful_traversable t] (g : β → γ) (f : α → γ → α) (a : α) (l : t β) :
    foldl f a (g <$> l) = foldl (fun (x : α) (y : β) => f x (g y)) a l :=
  sorry

@[simp] theorem foldr_map {α : Type u} {β : Type u} {γ : Type u} {t : Type u → Type u}
    [traversable t] [is_lawful_traversable t] (g : β → γ) (f : γ → α → α) (a : α) (l : t β) :
    foldr f a (g <$> l) = foldr (f ∘ g) a l :=
  sorry

@[simp] theorem to_list_eq_self {α : Type u} {xs : List α} : to_list xs = xs := sorry

theorem length_to_list {α : Type u} {t : Type u → Type u} [traversable t] [is_lawful_traversable t]
    {xs : t α} : length xs = list.length (to_list xs) :=
  sorry

theorem mfoldl_to_list {α : Type u} {β : Type u} {t : Type u → Type u} [traversable t]
    [is_lawful_traversable t] {m : Type u → Type u} [Monad m] [is_lawful_monad m] {f : α → β → m α}
    {x : α} {xs : t β} : mfoldl f x xs = mfoldl f x (to_list xs) :=
  sorry

theorem mfoldr_to_list {α : Type u} {β : Type u} {t : Type u → Type u} [traversable t]
    [is_lawful_traversable t] {m : Type u → Type u} [Monad m] [is_lawful_monad m] (f : α → β → m β)
    (x : β) (xs : t α) : mfoldr f x xs = list.mfoldr f x (to_list xs) :=
  sorry

@[simp] theorem mfoldl_map {α : Type u} {β : Type u} {γ : Type u} {t : Type u → Type u}
    [traversable t] [is_lawful_traversable t] {m : Type u → Type u} [Monad m] [is_lawful_monad m]
    (g : β → γ) (f : α → γ → m α) (a : α) (l : t β) :
    mfoldl f a (g <$> l) = mfoldl (fun (x : α) (y : β) => f x (g y)) a l :=
  sorry

@[simp] theorem mfoldr_map {α : Type u} {β : Type u} {γ : Type u} {t : Type u → Type u}
    [traversable t] [is_lawful_traversable t] {m : Type u → Type u} [Monad m] [is_lawful_monad m]
    (g : β → γ) (f : γ → α → m α) (a : α) (l : t β) : mfoldr f a (g <$> l) = mfoldr (f ∘ g) a l :=
  sorry

end Mathlib


/-
  The stalks of the structure presheaf on the basis are local rings.
-/

import ring_theory.ideals
import ring_theory.localization
import to_mathlib.localization.local_rings
import to_mathlib.localization.localization_alt
import sheaves.stalk_of_rings_on_standard_basis
import spectrum_of_a_ring.structure_presheaf
import spectrum_of_a_ring.structure_presheaf_localization
import spectrum_of_a_ring.structure_presheaf_res

universe u

variables {R : Type u} [comm_ring R]
variables (P : Spec R)

open localization localization_alt stalk_of_rings_on_standard_basis
open classical

def Bstd := D_fs_standard_basis R

namespace strucutre_presheaf_stalks

def F := structure_presheaf_on_basis R

def FP := stalk_of_rings_on_standard_basis Bstd F P

-- This is essentially the map from x to x/1.
def φ : R → FP P := λ x,
⟦{ U := opens.univ,
   BU := (D_fs_standard_basis R).1,
   Hx := set.mem_univ P,
   s := (of : R → localization R (S (opens.univ))) x, }⟧

instance FP.is_comm_ring : comm_ring (FP P) :=
by simp [FP]; by apply_instance

instance prime.is_submonoid : is_submonoid (-P.1 : set R) :=
{ one_mem := P.1.ne_top_iff_one.1 P.2.1,
  mul_mem := λ x y hnx hny hxy, or.cases_on (P.2.2 hxy) hnx hny }

instance φP.is_ring_hom : is_ring_hom (φ P) :=
{ map_one := rfl,
  map_mul := λ x y,
    begin
      apply quotient.sound,
      use [opens.univ, (D_fs_standard_basis R).1, set.mem_univ P],
      use [set.subset.refl _, (λ x Hx, ⟨Hx, Hx⟩)],
      rw (F.res_is_ring_hom _ _ _).map_mul,
      rw ←presheaf_on_basis.Hcomp',
      rw ←presheaf_on_basis.Hcomp',
      rw of.is_ring_hom.map_mul,
      rw (F.res_is_ring_hom _ _ _).map_mul,
    end,
  map_add := λ x y,
    begin
      apply quotient.sound,
      use [opens.univ, (D_fs_standard_basis R).1, set.mem_univ P],
      use [set.subset.refl _, (λ x Hx, ⟨Hx, Hx⟩)],
      rw (F.res_is_ring_hom _ _ _).map_add,
      rw ←presheaf_on_basis.Hcomp',
      rw ←presheaf_on_basis.Hcomp',
      rw of.is_ring_hom.map_add,
      rw (F.res_is_ring_hom _ _ _).map_add,
    end, }

lemma stalk_local.inverts_data : inverts_data (-P.1 : set R) (φ P) :=
begin
  rintros ⟨s, Hs⟩,
  change s ∉ P.val at Hs,
  let BDs := D_fs.mem R s,
  have HsS : s ∈ S (Spec.DO R s) := S.f_mem s,
  let sinv : FP P :=
    ⟦{ U := Spec.DO R s,
       BU := BDs,
       Hx := Hs,
       s := ⟦⟨1, ⟨s, HsS⟩⟩⟧, }⟧,
  use sinv,
  apply quotient.sound,
  use [Spec.DO R s, BDs, Hs, (λ x Hx, ⟨trivial, Hx⟩), set.subset_univ _],
  simp,
  erw (F.res_is_ring_hom _ _ _).map_mul,
  erw (F.res_is_ring_hom _ _ _).map_one,
  iterate 2 { rw ←presheaf_on_basis.Hcomp', },
  erw presheaf_on_basis.Hid',
  erw structure_presheaf_on_basis.res_eq,
  erw ←structure_presheaf_on_basis.res_comp_of',
  apply quotient.sound,
  use [1, is_submonoid.one_mem _],
  simp,
end

lemma stalk_local.has_denom : has_denom (-P.1 : set R) (φ P) :=
begin
  intros x,
  apply quotient.induction_on x,
  rintros ⟨U, BU, HPU, s⟩,
  -- s ∈ R[1/S(U)].
  apply quotient.induction_on s,
  rintros ⟨p, ⟨q, Hq⟩⟩,
  change U ⊆ Spec.DO R q at Hq,
  -- Since P ∈ D(q).
  have HqnP : q ∉ P.val := Hq HPU,
  use [⟨⟨q, HqnP⟩, p⟩],
  apply quotient.sound,
  use [U, BU, HPU, (λ x Hx, ⟨trivial, Hx⟩), set.subset_univ _],
  simp,
  erw (F.res_is_ring_hom _ _ _).map_mul,
  iterate 2 { rw ←presheaf_on_basis.Hcomp', },
  erw presheaf_on_basis.Hid',
  erw structure_presheaf_on_basis.res_eq,
  iterate 2 { erw ←structure_presheaf_on_basis.res_comp_of', },
  apply quotient.sound,
  use [1, is_submonoid.one_mem _],
  simp,
end

noncomputable def stalk_local.has_denom_data : has_denom_data (-P.1 : set R) (φ P) :=
has_denom_some (-P.1 : set R) (φ P) (stalk_local.has_denom P)

lemma stalk_local.ker_le : ker (φ P) ≤ submonoid_ann (-P.1 : set R) :=
begin
  intros x Hx,
  change φ P x = 0 at Hx,
  erw quotient.eq at Hx,
  rcases Hx with ⟨W, BW, HPW, HWuniv1, HWuniv2, Hres⟩,
  dsimp at Hres,
  erw is_ring_hom.map_zero (F.res (D_fs_standard_basis R).1 BW HWuniv2) at Hres,
  erw structure_presheaf_on_basis.res_eq at Hres,
  erw ←structure_presheaf_on_basis.res_comp_of' at Hres,
  erw quotient.eq at Hres,
  rcases Hres with ⟨t, HtSW, Ht⟩,
  simp at Ht,
  have HtnP : t ∉ P.val := HtSW HPW,
  use ⟨⟨x, ⟨t, HtnP⟩⟩, Ht⟩,
end

noncomputable def stalk_local.localization : is_localization_data (-P.1 : set R) (φ P) :=
{ inverts := stalk_local.inverts_data P,
  has_denom := stalk_local.has_denom_data P,
  ker_le := stalk_local.ker_le P, }

lemma stalk_local : is_local_ring (FP P) :=
local_ring.of_is_localization_data_at_prime P.2 (stalk_local.localization P)

end strucutre_presheaf_stalks


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

/-!
# The Yoneda embedding

The Yoneda embedding as a functor `yoneda : C ⥤ (Cᵒᵖ ⥤ Type v₁)`,
along with an instance that it is `fully_faithful`.

Also the Yoneda lemma, `yoneda_lemma : (yoneda_pairing C) ≅ (yoneda_evaluation C)`.

## References
* [Stacks: Opposite Categories and the Yoneda Lemma](https://stacks.math.columbia.edu/tag/001L)
-/

namespace category_theory
open opposite

universes v₁ u₁ u₂-- morphism levels before object levels. See note [category_theory universes].

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

/--
The Yoneda embedding, as a functor from `C` into presheaves on `C`.

See https://stacks.math.columbia.edu/tag/001O.
-/
@[simps]
def yoneda : C ⥤ (Cᵒᵖ ⥤ Type v₁) :=
{ obj := λ X,
  { obj := λ Y, unop Y ⟶ X,
    map := λ Y Y' f g, f.unop ≫ g,
    map_comp' := λ _ _ _ f g, begin ext, dsimp, erw [category.assoc] end,
    map_id' := λ Y, begin ext, dsimp, erw [category.id_comp] end },
  map := λ X X' f, { app := λ Y g, g ≫ f } }

/--
The co-Yoneda embedding, as a functor from `Cᵒᵖ` into co-presheaves on `C`.
-/
@[simps] def coyoneda : Cᵒᵖ ⥤ (C ⥤ Type v₁) :=
{ obj := λ X,
  { obj := λ Y, unop X ⟶ Y,
    map := λ Y Y' f g, g ≫ f,
    map_comp' := λ _ _ _ f g, begin ext1, dsimp, erw [category.assoc] end,
    map_id' := λ Y, begin ext1, dsimp, erw [category.comp_id] end },
  map := λ X X' f, { app := λ Y g, f.unop ≫ g },
  map_comp' := λ _ _ _ f g, begin ext, dsimp, erw [category.assoc] end,
  map_id' := λ X, begin ext, dsimp, erw [category.id_comp] end }

namespace yoneda

lemma obj_map_id {X Y : C} (f : op X ⟶ op Y) :
  ((@yoneda C _).obj X).map f (𝟙 X) = ((@yoneda C _).map f.unop).app (op Y) (𝟙 Y) :=
by obviously

@[simp] lemma naturality {X Y : C} (α : yoneda.obj X ⟶ yoneda.obj Y)
  {Z Z' : C} (f : Z ⟶ Z') (h : Z' ⟶ X) : f ≫ α.app (op Z') h = α.app (op Z) (f ≫ h) :=
(functor_to_types.naturality _ _ α f.op h).symm

/--
The Yoneda embedding is full.

See https://stacks.math.columbia.edu/tag/001P.
-/
instance yoneda_full : full (@yoneda C _) :=
{ preimage := λ X Y f, (f.app (op X)) (𝟙 X) }

/--
The Yoneda embedding is faithful.

See https://stacks.math.columbia.edu/tag/001P.
-/
instance yoneda_faithful : faithful (@yoneda C _) :=
{ map_injective' := λ X Y f g p,
  begin
    injection p with h,
    convert (congr_fun (congr_fun h (op X)) (𝟙 X)); dsimp; simp,
  end }

/-- Extensionality via Yoneda. The typical usage would be
```
-- Goal is `X ≅ Y`
apply yoneda.ext,
-- Goals are now functions `(Z ⟶ X) → (Z ⟶ Y)`, `(Z ⟶ Y) → (Z ⟶ X)`, and the fact that these
functions are inverses and natural in `Z`.
```
-/
def ext (X Y : C)
  (p : Π {Z : C}, (Z ⟶ X) → (Z ⟶ Y)) (q : Π {Z : C}, (Z ⟶ Y) → (Z ⟶ X))
  (h₁ : Π {Z : C} (f : Z ⟶ X), q (p f) = f) (h₂ : Π {Z : C} (f : Z ⟶ Y), p (q f) = f)
  (n : Π {Z Z' : C} (f : Z' ⟶ Z) (g : Z ⟶ X), p (f ≫ g) = f ≫ p g) : X ≅ Y :=
@preimage_iso _ _ _ _ yoneda _ _ _ _
  (nat_iso.of_components (λ Z, { hom := p, inv := q, }) (by tidy))

/--
If `yoneda.map f` is an isomorphism, so was `f`.
-/
lemma is_iso {X Y : C} (f : X ⟶ Y) [is_iso (yoneda.map f)] : is_iso f :=
is_iso_of_fully_faithful yoneda f

end yoneda

namespace coyoneda

@[simp] lemma naturality {X Y : Cᵒᵖ} (α : coyoneda.obj X ⟶ coyoneda.obj Y)
  {Z Z' : C} (f : Z' ⟶ Z) (h : unop X ⟶ Z') : (α.app Z' h) ≫ f = α.app Z (h ≫ f) :=
begin erw [functor_to_types.naturality], refl end

instance coyoneda_full : full (@coyoneda C _) :=
{ preimage := λ X Y f, ((f.app (unop X)) (𝟙 _)).op }

instance coyoneda_faithful : faithful (@coyoneda C _) :=
{ map_injective' := λ X Y f g p,
  begin
    injection p with h,
    have t := (congr_fun (congr_fun h (unop X)) (𝟙 _)),
    simpa using congr_arg quiver.hom.op t,
  end }

/--
If `coyoneda.map f` is an isomorphism, so was `f`.
-/
lemma is_iso {X Y : Cᵒᵖ} (f : X ⟶ Y) [is_iso (coyoneda.map f)] : is_iso f :=
is_iso_of_fully_faithful coyoneda f

-- No need to use Cᵒᵖ here, works with any category
/-- A Type-valued presheaf `P` is isomorphic to the composition of `P` with the
  coyoneda functor coming from `punit`. -/
@[simps] def iso_comp_punit (P : C ⥤ Type v₁) : (P ⋙ coyoneda.obj (op punit.{v₁+1})) ≅ P :=
{ hom := { app := λ X f, f punit.star},
  inv := { app := λ X a _, a } }

end coyoneda

/--
A presheaf `F` is representable if there is object `X` so `F ≅ yoneda.obj X`.

See https://stacks.math.columbia.edu/tag/001Q.
-/
-- TODO should we make this a Prop, merely asserting existence of such an object?
class representable (F : Cᵒᵖ ⥤ Type v₁) :=
(X : C)
(w : yoneda.obj X ≅ F)

end category_theory

namespace category_theory
-- For the rest of the file, we are using product categories,
-- so need to restrict to the case morphisms are in 'Type', not 'Sort'.

universes v₁ u₁ u₂ -- morphism levels before object levels. See note [category_theory universes].

open opposite

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

-- We need to help typeclass inference with some awkward universe levels here.
instance prod_category_instance_1 : category ((Cᵒᵖ ⥤ Type v₁) × Cᵒᵖ) :=
category_theory.prod.{(max u₁ v₁) v₁} (Cᵒᵖ ⥤ Type v₁) Cᵒᵖ

instance prod_category_instance_2 : category (Cᵒᵖ × (Cᵒᵖ ⥤ Type v₁)) :=
category_theory.prod.{v₁ (max u₁ v₁)} Cᵒᵖ (Cᵒᵖ ⥤ Type v₁)

open yoneda

/--
The "Yoneda evaluation" functor, which sends `X : Cᵒᵖ` and `F : Cᵒᵖ ⥤ Type`
to `F.obj X`, functorially in both `X` and `F`.
-/
def yoneda_evaluation : Cᵒᵖ × (Cᵒᵖ ⥤ Type v₁) ⥤ Type (max u₁ v₁) :=
evaluation_uncurried Cᵒᵖ (Type v₁) ⋙ ulift_functor.{u₁}

@[simp] lemma yoneda_evaluation_map_down
  (P Q : Cᵒᵖ × (Cᵒᵖ ⥤ Type v₁)) (α : P ⟶ Q) (x : (yoneda_evaluation C).obj P) :
  ((yoneda_evaluation C).map α x).down = α.2.app Q.1 (P.2.map α.1 x.down) := rfl

/--
The "Yoneda pairing" functor, which sends `X : Cᵒᵖ` and `F : Cᵒᵖ ⥤ Type`
to `yoneda.op.obj X ⟶ F`, functorially in both `X` and `F`.
-/
def yoneda_pairing : Cᵒᵖ × (Cᵒᵖ ⥤ Type v₁) ⥤ Type (max u₁ v₁) :=
functor.prod yoneda.op (𝟭 (Cᵒᵖ ⥤ Type v₁)) ⋙ functor.hom (Cᵒᵖ ⥤ Type v₁)

@[simp] lemma yoneda_pairing_map
  (P Q : Cᵒᵖ × (Cᵒᵖ ⥤ Type v₁)) (α : P ⟶ Q) (β : (yoneda_pairing C).obj P) :
  (yoneda_pairing C).map α β = yoneda.map α.1.unop ≫ β ≫ α.2 := rfl

/--
The Yoneda lemma asserts that that the Yoneda pairing
`(X : Cᵒᵖ, F : Cᵒᵖ ⥤ Type) ↦ (yoneda.obj (unop X) ⟶ F)`
is naturally isomorphic to the evaluation `(X, F) ↦ F.obj X`.

See https://stacks.math.columbia.edu/tag/001P.
-/
def yoneda_lemma : yoneda_pairing C ≅ yoneda_evaluation C :=
{ hom :=
  { app := λ F x, ulift.up ((x.app F.1) (𝟙 (unop F.1))),
    naturality' :=
    begin
      intros X Y f, ext, dsimp,
      erw [category.id_comp, ←functor_to_types.naturality],
      simp only [category.comp_id, yoneda_obj_map],
    end },
  inv :=
  { app := λ F x,
    { app := λ X a, (F.2.map a.op) x.down,
      naturality' :=
      begin
        intros X Y f, ext, dsimp,
        rw [functor_to_types.map_comp_apply]
      end },
    naturality' :=
    begin
      intros X Y f, ext, dsimp,
      rw [←functor_to_types.naturality, functor_to_types.map_comp_apply]
    end },
  hom_inv_id' :=
  begin
    ext, dsimp,
    erw [←functor_to_types.naturality,
         obj_map_id],
    simp only [yoneda_map_app, quiver.hom.unop_op],
    erw [category.id_comp],
  end,
  inv_hom_id' :=
  begin
    ext, dsimp,
    rw [functor_to_types.map_id_apply]
  end }.

variables {C}

/--
The isomorphism between `yoneda.obj X ⟶ F` and `F.obj (op X)`
(we need to insert a `ulift` to get the universes right!)
given by the Yoneda lemma.
-/
@[simp] def yoneda_sections (X : C) (F : Cᵒᵖ ⥤ Type v₁) :
  (yoneda.obj X ⟶ F) ≅ ulift.{u₁} (F.obj (op X)) :=
(yoneda_lemma C).app (op X, F)

/--
We have a type-level equivalence between natural transformations from the yoneda embedding
and elements of `F.obj X`, without any universe switching.
-/
def yoneda_equiv {X : C} {F : Cᵒᵖ ⥤ Type v₁} : (yoneda.obj X ⟶ F) ≃ F.obj (op X) :=
(yoneda_sections X F).to_equiv.trans equiv.ulift

lemma yoneda_equiv_naturality {X Y : C} {F : Cᵒᵖ ⥤ Type v₁} (f : yoneda.obj X ⟶ F) (g : Y ⟶ X) :
  F.map g.op (yoneda_equiv f) = yoneda_equiv (yoneda.map g ≫ f) :=
begin
  change (f.app (op X) ≫ F.map g.op) (𝟙 X) = f.app (op Y) (𝟙 Y ≫ g),
  rw ← f.naturality,
  dsimp,
  simp,
end

@[simp]
lemma yoneda_equiv_apply {X : C} {F : Cᵒᵖ ⥤ Type v₁} (f : yoneda.obj X ⟶ F) :
  yoneda_equiv f = f.app (op X) (𝟙 X) :=
rfl

@[simp]
lemma yoneda_equiv_symm_app_apply {X : C} {F : Cᵒᵖ ⥤ Type v₁} (x : F.obj (op X))
  (Y : Cᵒᵖ) (f : Y.unop ⟶ X) :
  (yoneda_equiv.symm x).app Y f = F.map f.op x :=
rfl

/--
When `C` is a small category, we can restate the isomorphism from `yoneda_sections`
without having to change universes.
-/
def yoneda_sections_small {C : Type u₁} [small_category C] (X : C)
  (F : Cᵒᵖ ⥤ Type u₁) :
  (yoneda.obj X ⟶ F) ≅ F.obj (op X) :=
yoneda_sections X F ≪≫ ulift_trivial _

@[simp]
lemma yoneda_sections_small_hom {C : Type u₁} [small_category C] (X : C)
  (F : Cᵒᵖ ⥤ Type u₁) (f : yoneda.obj X ⟶ F) :
  (yoneda_sections_small X F).hom f = f.app _ (𝟙 _) :=
rfl

@[simp]
lemma yoneda_sections_small_inv_app_apply {C : Type u₁} [small_category C] (X : C)
  (F : Cᵒᵖ ⥤ Type u₁) (t : F.obj (op X)) (Y : Cᵒᵖ) (f : Y.unop ⟶ X) :
  ((yoneda_sections_small X F).inv t).app Y f = F.map f.op t :=
rfl

end category_theory


-- import topology.sheaves.sheaf
-- import sort
-- import algebra.category.Group.limits
-- import oc

-- section

-- open category_theory Top Top.sheaf topological_space finset
-- open opposite

-- variable (X : Top)

-- variable {X}
-- variable (𝓕 : sheaf Ab X)
-- variable (𝔘 : oc X)

-- local notation `ι ` := 𝔘.ι
-- local notation `𝓕.obj` := 𝓕.1.obj
-- local notation `𝓕.map` := 𝓕.1.map

-- @[ext] structure simplex (n : ℕ) extends finset ι :=
-- (card_eq : to_finset.card = n.succ)

-- attribute [simp] simplex.card_eq

-- namespace simplex

-- variables {𝔘}

-- def nth {n : ℕ} (σ : simplex 𝔘 n) (m : fin n.succ) : ι :=
-- σ.to_finset.order_emb_of_fin σ.2 m

-- instance {n : ℕ} : has_mem ι (simplex 𝔘 n) :=
-- { mem := λ i σ, i ∈ σ.to_finset }

-- lemma nth_mem {n : ℕ} (σ : simplex 𝔘 n) (m : fin n.succ) :
--   σ.nth m ∈ σ :=
-- σ.to_finset.order_emb_of_fin_mem σ.card_eq m

-- def zero_from (i : ι) : simplex 𝔘 0 :=
-- { to_finset := {i},
--   card_eq := rfl }

-- variables {n : ℕ} (hn : 0 < n)

-- def ignore (σ : simplex 𝔘 n) (m : fin n.succ) : simplex 𝔘 n.pred :=
-- { to_finset := σ.1.erase_nth σ.2 m,
--   card_eq := (nat.succ_pred_eq_of_pos hn).symm ▸ σ.1.erase_nth_card _ m }

-- lemma mem_ignore (σ : simplex 𝔘 n) (m : fin n.succ) (i : ι) :
--   i ∈ σ.ignore hn m ↔ i ∈ σ ∧ i ≠ σ.nth m :=
-- begin
--   split,
--   { intros hi,
--     change i ∈ simplex.to_finset _ at hi,
--     unfold ignore at hi,
--     dsimp only at hi,
--     rw mem_erase_nth at hi,
--     refine ⟨hi.2, hi.1⟩, },
--   { intros hi,
--     change i ∈ simplex.to_finset _,
--     unfold ignore,
--     dsimp only,
--     rw mem_erase_nth,
--     refine ⟨hi.2, hi.1⟩, },
-- end

-- def ignore₂ (σ : simplex 𝔘 n.succ) (m : fin n.succ.succ) (m' : fin n.succ) : simplex 𝔘 n.pred :=
-- (σ.ignore (nat.zero_lt_succ _) m).ignore hn m'

-- lemma ignore_subset (σ : simplex 𝔘 n) (m : fin n.succ) :
--   (σ.ignore hn m).to_finset ⊆ σ.to_finset := λ x hx,
-- begin
--   change x ∈ finset.erase _ _ at hx,
--   rw finset.mem_erase at hx,
--   exact hx.2,
-- end

-- lemma ignore₂_subset (σ : simplex 𝔘 n.succ) (m : fin n.succ.succ) (m' : fin n.succ) :
--   (σ.ignore₂ hn m m').to_finset ⊆ σ.to_finset :=
-- subset.trans ((σ.ignore (nat.zero_lt_succ _) m).ignore_subset hn m') $ σ.ignore_subset _ _

-- lemma ignore₂_to_finset_case1 (σ : simplex 𝔘 n.succ) (m : fin n.succ.succ) (m' : fin n.succ)
--   (hmm' : m'.1 < m.1) :
--   (σ.ignore₂ hn m m').to_finset =
--   σ.to_finset \
--   { σ.1.order_emb_of_fin σ.2 m,
--     σ.1.order_emb_of_fin σ.2 ⟨m'.1, lt_trans m'.2 (lt_add_one n.succ)⟩ } :=
-- begin
--   unfold ignore₂ ignore,
--   dsimp,
--   ext i,
--   split,
--   { intros hi,
--     erw [mem_erase_nth, σ.to_finset.erase_order_emb_of_fin'_eq σ.2 m] at hi,
--     unfold erase_order_emb_of_fin' at hi,
--     simp only [rel_embedding.coe_fn_mk, function.embedding.coe_fn_mk, ne.def, if_pos hmm', mem_erase_nth] at hi,
--     rw [mem_sdiff, mem_insert, mem_singleton, not_or_distrib],
--     tauto },
--   { intros hi,
--     erw [mem_erase_nth, σ.to_finset.erase_order_emb_of_fin'_eq σ.2 m, mem_erase_nth],
--     rw [mem_sdiff, mem_insert, mem_singleton, not_or_distrib] at hi,
--     refine ⟨_, hi.2.1, hi.1⟩,
--     convert hi.2.2,
--     unfold erase_order_emb_of_fin',
--     simp only [rel_embedding.coe_fn_mk, function.embedding.coe_fn_mk, ne.def, if_pos hmm', mem_erase_nth],
--     refl, }
-- end

-- lemma ignore₂_to_finset_case2 (σ : simplex 𝔘 n.succ) (m : fin n.succ.succ) (m' : fin n.succ)
--   (hmm' : m.1 ≤ m'.1) :
--   (σ.ignore₂ hn m m').to_finset =
--   σ.to_finset \
--   { σ.to_finset.order_emb_of_fin σ.2 m,
--     σ.to_finset.order_emb_of_fin σ.2 ⟨m'.1.succ, nat.succ_lt_succ m'.2⟩ } :=
-- begin
--   have ineq : ¬ m'.1 < m.1,
--   { rwa not_lt },
--   unfold ignore₂ ignore,
--   dsimp,
--   ext i,
--   split,
--   { intros hi,
--     erw [mem_erase_nth, σ.to_finset.erase_order_emb_of_fin'_eq σ.2 m] at hi,
--     unfold erase_order_emb_of_fin' at hi,
--     simp only [rel_embedding.coe_fn_mk, function.embedding.coe_fn_mk, ne.def, if_neg ineq, mem_erase_nth] at hi,
--     rw [mem_sdiff, mem_insert, mem_singleton, not_or_distrib],
--     tauto },
--   { intros hi,
--     erw [mem_erase_nth, σ.to_finset.erase_order_emb_of_fin'_eq σ.2 m, mem_erase_nth],
--     rw [mem_sdiff, mem_insert, mem_singleton, not_or_distrib] at hi,
--     refine ⟨_, hi.2.1, hi.1⟩,
--     convert hi.2.2,
--     unfold erase_order_emb_of_fin',
--     simp only [rel_embedding.coe_fn_mk, function.embedding.coe_fn_mk, ne.def, if_neg ineq, mem_erase_nth],
--     refl, }
-- end

-- lemma ignore₂_eq_ignore₂.aux (σ : simplex 𝔘 n.succ) (m : fin n.succ.succ) (m' : fin n.succ)
--   (hmm' : m.1 ≤ m'.1) :
--   (σ.ignore₂ hn m m').to_finset =
--   (σ.ignore₂ hn ⟨m'.1.succ, nat.succ_lt_succ m'.2⟩ ⟨m.1, by linarith [m'.2]⟩).to_finset :=
-- begin
--   rw [ignore₂_to_finset_case2 _ _ _ _ hmm', ignore₂_to_finset_case1],
--   { ext i,
--     split;
--     { intros hi,
--       rw [mem_sdiff, mem_insert, mem_singleton, not_or_distrib] at hi ⊢,
--       tauto, } },
--   { dsimp only,
--     exact lt_of_le_of_lt hmm' (lt_add_one _), },
-- end

-- lemma ignore₂_eq_ignore₂ (σ : simplex 𝔘 n.succ) (m : fin n.succ.succ) (m' : fin n.succ)
--   (hmm' : m.1 ≤ m'.1) :
--   (σ.ignore₂ hn m m') =
--   (σ.ignore₂ hn ⟨m'.1.succ, nat.succ_lt_succ m'.2⟩ ⟨m.1, by linarith [m'.2]⟩) :=
-- by rw [simplex.ext_iff, ignore₂_eq_ignore₂.aux]

-- def face {n : ℕ} (σ : simplex 𝔘 n) : opens X :=
-- ⨅ (i : ι) (H : i ∈ σ.to_finset), 𝔘.cover i

-- lemma face0 (σ : simplex 𝔘 0) :
--   σ.face = 𝔘.cover (σ.nth 0) :=
-- begin
--   unfold face,
--   have eq1 : σ.to_finset = {σ.nth 0},
--   { rcases card_eq_one.mp σ.2 with ⟨a, eq1⟩,
--     have := σ.nth_mem 0,
--     change _ ∈ σ.to_finset at this,
--     rw eq1 at *,
--     rw mem_singleton at this,
--     rw this },
--   rw [eq1, finset.infi_singleton],
-- end

-- lemma face1 (σ : simplex 𝔘 1) :
--   σ.face = 𝔘.cover (σ.nth 0) ⊓ 𝔘.cover (σ.nth ⟨1, one_lt_two⟩) :=
-- begin
--   rcases card_eq_two.mp σ.2 with ⟨a, b, ineq, eq1⟩,
--   have mem1 : (_ ∈ σ.to_finset) := σ.nth_mem 0,
--   have mem2 : (_ ∈ σ.to_finset) := σ.nth_mem ⟨1, one_lt_two⟩,
--   have ineq2 : σ.nth 0 ≠ σ.nth ⟨1, one_lt_two⟩,
--   { intro rid,
--     unfold simplex.nth at rid,
--     replace rid := (σ.to_finset.order_emb_of_fin σ.2).inj' rid,
--     rw subtype.ext_iff_val at rid,
--     change 0 = 1 at rid,
--     linarith, },
--   rw [eq1, mem_insert, mem_singleton] at mem1 mem2,
--   unfold face,
--   rw [eq1, finset.infi_insert, finset.infi_singleton],
--   cases mem1;
--   cases mem2;
--   rw [mem1, mem2] at *;
--   tauto <|> exact inf_comm,
-- end

-- def subset₀ {n : ℕ} (σ : simplex 𝔘 n) (m : fin n.succ) :
--   σ.face ⟶ (simplex.zero_from 𝔘 (σ.nth m)).face := hom_of_le $ λ p hp,
-- begin
--   rw [opens.mem_coe] at hp ⊢,
--   rw face0,
--   change _ ∈ (infi _) at hp,
--   have := (infi_le _ : ∀ _,  σ.face ≤ _),
--   specialize this ((simplex.zero_from 𝔘 (σ.nth m)).nth 0),
--   simp only [le_infi_iff] at this,
--   refine this _ hp,
--   have : _ ∈ {_} := (simplex.zero_from 𝔘 (σ.nth m)).nth_mem 0,
--   rw mem_singleton at this,
--   rw this,
--   apply simplex.nth_mem,
-- end

-- def der {n : ℕ} (hn : 0 < n) (σ : simplex 𝔘 n) (m : fin n.succ) :
--   σ.face ⟶ (σ.ignore hn m).face := hom_of_le $ λ p hp,
-- begin
--   rw [opens.mem_coe] at hp ⊢,
--   rcases hp with ⟨S, ⟨oS, hS⟩, p_mem⟩,
--   refine ⟨S, ⟨oS, λ x x_mem, _⟩, p_mem⟩,
--   specialize hS x_mem,
--   simp only [subtype.val_eq_coe, set.Inf_eq_sInter, set.sInter_image, set.mem_range,
--     set.Inter_exists, set.Inter_Inter_eq', set.mem_Inter, opens.mem_coe] at hS ⊢,
--   intros i,
--   specialize hS i,
--   rcases hS with ⟨w, ⟨hw1, hw2⟩, hx⟩,
--   refine ⟨w, ⟨hw1, _⟩, hx⟩,
--   intros y hy,
--   specialize hw2 hy,
--   simp only [subtype.val_eq_coe, set.Inf_eq_sInter, set.sInter_image, set.mem_range, exists_prop,
--     set.mem_Inter, opens.mem_coe, and_imp, forall_apply_eq_imp_iff'] at hw2 ⊢,
--   intros hi2,
--   apply hw2,
--   apply simplex.ignore_subset,
--   exact hi2,
-- end

-- def dder {n : ℕ} (hn : 0 < n) (σ : simplex 𝔘 n.succ) (m : fin n.succ.succ) (m' : fin n.succ) :
--   σ.face ⟶ (σ.ignore₂ hn m m').face :=
-- der (nat.zero_lt_succ _) σ m ≫ der _ (σ.ignore _ m) m'

-- section refinement

-- variables {A B : X.oc} (h : A ⟶ B) (inj : function.injective h.func)

-- include inj
-- def refine (σ : simplex A n) : simplex B n :=
-- { to_finset := finset.image h.func σ.to_finset,
--   card_eq := begin
--     rw [← σ.2, finset.card_image_of_inj_on],
--     apply function.injective.inj_on,
--     assumption,
--   end }

-- -- lemma refine_self (σ : simplex A n) :
-- --   σ.refine (𝟙 A) = σ :=
-- -- begin
-- --   ext i,
-- --   split,
-- --   { intros hi,
-- --     unfold simplex.refine at hi,
-- --     dsimp only at hi,
-- --     change i ∈ finset.image id _ at hi,
-- --     rw finset.mem_image at hi,
-- --     rcases hi with ⟨a, ha, rfl⟩,
-- --     exact ha },
-- --   { intros hi,
-- --     unfold simplex.refine,
-- --     dsimp only,
-- --     change i ∈ finset.image id _,
-- --     rw finset.mem_image,
-- --     refine ⟨i, hi, rfl⟩, },
-- -- end

-- -- lemma refine_comp {n : ℕ} {A B D : X.oc} (r1 : A ⟶ B) (r2 : B ⟶ D) (σ : simplex A n) :
-- --   σ.refine (r1 ≫ r2) = (σ.refine r1).refine r2 :=
-- -- begin
-- --   ext d,
-- --   split;
-- --   intros hd;
-- --   unfold simplex.refine at hd ⊢;
-- --   dsimp only at hd ⊢;
-- --   rw finset.mem_image at hd ⊢,
-- --   { rcases hd with ⟨a, ha, rfl⟩,
-- --     refine ⟨r1.func a, _, rfl⟩,
-- --     rw finset.mem_image,
-- --     exact ⟨a, ha, rfl⟩, },
-- --   { rcases hd with ⟨b, hb, rfl⟩,
-- --     rw finset.mem_image at hb,
-- --     rcases hb with ⟨a, ha, rfl⟩,
-- --     exact ⟨a, ha, rfl⟩, },
-- -- end

-- -- lemma refine_ignore {n : ℕ} (hn : 0 < n) {A B : oc X} (h : A ⟶ B) (inj : function.injective h.func) (σ : simplex A n) (m : fin n.succ) :
-- --   (σ.refine h inj).ignore hn m = (σ.ignore hn m).refine h inj :=
-- -- begin
-- --   ext i,
-- --   split,
-- --   { rintros (hi : i ∈ simplex.ignore hn (simplex.refine h inj σ) m),
-- --     rw simplex.mem_ignore at hi,
-- --     rcases hi with ⟨h1, h2⟩,
-- --     change _ ∈ simplex.to_finset _ at h1,
-- --     unfold simplex.refine at h1 ⊢,
-- --     dsimp only at h1 ⊢,
-- --     rw finset.mem_image at h1 ⊢,
-- --     rcases h1 with ⟨a, ha, rfl⟩,
-- --     refine ⟨a, _, rfl⟩,
-- --     change a ∈ simplex.ignore hn σ m,
-- --     rw simplex.mem_ignore,
-- --     refine ⟨ha, _⟩,
-- --     contrapose! h2,
-- --     rw [simplex.refine_nth, h2] },
-- --   { rintros hi,
-- --     erw simplex.mem_ignore,
-- --     change i ∈ simplex.to_finset _ ∧ _,
-- --     unfold simplex.refine at hi,
-- --     dsimp only at hi,
-- --     rw finset.mem_image at hi,
-- --     rcases hi with ⟨a, ha, rfl⟩,
-- --     erw simplex.mem_ignore at ha,
-- --     rcases ha with ⟨h1, h2⟩,
-- --     refine ⟨_, _⟩,
-- --     { change _ ∈ simplex.to_finset _,
-- --       unfold simplex.refine,
-- --       dsimp only,
-- --       rw finset.mem_image,
-- --       exact ⟨a, h1, rfl⟩, },
-- --     { contrapose! h2,
-- --       rw simplex.refine_nth at h2,
-- --       exact h.strict_mono.injective h2, } },
-- -- end

-- end refinement

-- end simplex

-- end


import category_theory.limits.has_limits
import category_theory.limits.is_limit
import category_theory.limits.types
import category_theory.yoneda
import category_theory.whiskering

universes u v

noncomputable theory

open category_theory
open category_theory.limits

variables {C : Type u}  [category.{v} C]
variables {I : Type v} [small_category I] -- [is_cofiltered I]
variables (X Y : C)
variables (S : I ⥤ C) [has_limit S]

def hom_as_cone_map : S.op ⋙ yoneda.obj Y ⋙ ulift_functor ⟶
  (category_theory.functor.const Iᵒᵖ).obj (ulift_functor.obj ((yoneda.obj Y).obj (opposite.op (limit S)))) :=
{ app := λ i, ulift_functor.map (as_hom (λ a, ((limit.cone S).π.app i.unop) ≫ a)),
  naturality' := begin
    intros i j ji,
    ext f,
    tidy,
    have h₁ : as_hom (category_struct.comp (limit.π S j.unop)) (S.map ji.unop ≫ f) =
      (limit.π S j.unop) ≫ (S.map ji.unop ≫ f) := by refl,
    have h₂ : as_hom (category_struct.comp (limit.π S j.unop ≫ S.map ji.unop)) f =
      (limit.π S j.unop ≫ S.map ji.unop) ≫ f := by refl,
    suffices h : (limit.π S j.unop) ≫ (S.map ji.unop) = (limit.π S i.unop),
    { rw ← h,
      rw h₁,
      rw h₂,
      simp only [category_theory.limits.limit.w, category_theory.limits.limit.w_assoc, eq_self_iff_true] },
    { simp only [category_theory.limits.limit.w, eq_self_iff_true] },
  end, }

def hom_as_cone : cocone (S.op ⋙ yoneda.obj Y ⋙ ulift_functor) :=
{ X := ulift_functor.obj ((yoneda.obj Y).obj (opposite.op (limit S))),
  ι := hom_as_cone_map Y S, }

def can_map_from_colim_of_homs_to_hom_from_limit :
  colimit (S.op ⋙ yoneda.obj Y ⋙ ulift_functor) ⟶ ulift_functor.obj ((yoneda.obj Y).obj (opposite.op (limit S))) :=
  colimit.desc (S.op ⋙ yoneda.obj Y ⋙ ulift_functor) (hom_as_cone Y S)

theorem can_is_injective (hI : ∀ i : I, epi ((limit.cone S).π.app i)) [is_cofiltered I] :
  function.injective (can_map_from_colim_of_homs_to_hom_from_limit Y S) :=
begin
  intros a b hab,
  obtain ⟨i, a', ha⟩ := types.jointly_surjective' a,
  obtain ⟨j, b', hb⟩ := types.jointly_surjective' b,
  rw ← ha,
  rw ← hb,
  have hIopfiltered : is_filtered Iᵒᵖ := category_theory.is_filtered_op_of_is_cofiltered I,
  obtain ⟨k, ki, kj, t⟩ := hIopfiltered.to_is_filtered_or_empty.cocone_objs i j,
  rw types.filtered_colimit.colimit_eq_iff,
  use k,
  use ki,
  use kj,
  let pi := limit.π S i.unop,
  let pj := limit.π S j.unop,
  let pk := limit.π S k.unop,
  -- have hi : epi pi := hI i.unop,
  -- have hj : epi pj := hI j.unop,
  have hk : epi pk := hI k.unop,
  have hcani : pi ≫ a'.down = (can_map_from_colim_of_homs_to_hom_from_limit Y S a).down,
  { unfold can_map_from_colim_of_homs_to_hom_from_limit,
    tidy },
  have hcanj : pj ≫ b'.down = (can_map_from_colim_of_homs_to_hom_from_limit Y S b).down,
  { unfold can_map_from_colim_of_homs_to_hom_from_limit,
    tidy },
  have hik : pi = pk ≫ (S.map ki.unop) := by tidy,
  have hjk : pj = pk ≫ (S.map kj.unop) := by tidy,
  have hpij : pi ≫ a'.down = pj ≫ b'.down,
  { rw hcani,
    rw hcanj,
    exact congr_arg ulift.down hab },
  rw hik at hpij,
  rw hjk at hpij,
  simp only [quiver.hom.unop_op,
    category_theory.ulift_functor_map,
    category_theory.functor.comp_map,
    ulift.up_inj,
    category_theory.functor.op_map,
    category_theory.yoneda_obj_map],
  simp only [category.assoc'] at hpij,
  exact hk.left_cancellation _ _ hpij,
end


import combinatorics.simple_graph.connectivity data.finset data.setoid.basic
import graph_theory.contraction graph_theory.pushforward graph_theory.basic graph_theory.walk
open finset classical function simple_graph.Walk

variables {V V' : Type*} [fintype V] [decidable_eq V] [fintype V'] [decidable_eq V']
variables {G G₁ G₂ : simple_graph V}
variables [decidable_rel G.adj] [decidable_rel G₁.adj] [decidable_rel G₂.adj]
variables {a : V} {A B X Y Z : finset V} {e : G.dart}
variables {f : V → V'} {hf : G.adapted f}

namespace simple_graph
namespace menger

structure AB_walk (G : simple_graph V) (A B : finset V) extends Walk G :=
  (ha : a ∈ A) (hb : b ∈ B)

noncomputable instance : decidable_eq (AB_walk G A B) := by { classical, apply_instance }

variables {P : finset (AB_walk G A B)}

namespace AB_walk

def minimal (p : AB_walk G A B) : Prop :=
p.to_Walk.init ∩ B = ∅ ∧ p.to_Walk.tail ∩ A = ∅

noncomputable def lift (f : V → V') (hf : adapted f G) (A B : finset V) :
  AB_walk (map f G) (A.image f) (B.image f) → AB_walk G A B :=
begin
  rintro ⟨p,ha,hb⟩,
  choose a h₂ h₃ using mem_image.mp ha,
  choose b h₅ h₆ using mem_image.mp hb,
  let γ := Walk.pull_Walk_aux f hf p a b h₃ h₆,
  rw ←γ.2.1 at h₂, rw ←γ.2.2.1 at h₅, exact ⟨γ,h₂,h₅⟩
end

def push (f : V → V') (A B : finset V) :
  AB_walk G A B → AB_walk (map f G) (A.image f) (B.image f) :=
begin
  intro p, refine ⟨Walk.push_Walk f p.to_Walk, _, _⟩,
  rw Walk.push_Walk_a, exact mem_image_of_mem f p.ha,
  rw Walk.push_Walk_b, exact mem_image_of_mem f p.hb,
end

lemma push_lift : left_inverse (push f A B) (lift f hf A B) :=
by { rintro ⟨p,ha,hb⟩, simp [lift,push], exact Walk.pull_Walk_push }

lemma lift_inj : injective (lift f hf A B) :=
left_inverse.injective push_lift

noncomputable def trim_aux (p : AB_walk G A B) :
  {q : AB_walk G A B // q.minimal ∧ q.to_Walk.range ⊆ p.to_Walk.range} :=
begin
  rcases p with ⟨p₁, p₁a, p₁b⟩,
  have h₁ : (p₁.range ∩ A).nonempty := ⟨p₁.a, by simp [p₁a]⟩,
  rcases p₁.after A h₁ with ⟨p₂, p₂a, p₂b, p₂r, p₂i, -, p₂t⟩,
  have h₂ : (p₂.range ∩ B).nonempty := by { refine ⟨p₂.b, _⟩, simp, rwa p₂b },
  rcases p₂.until B h₂ with ⟨p₃, p₃a, p₃b, p₃r, p₃i, -, p₃t⟩,
  refine ⟨⟨p₃, p₃a.symm ▸ p₂a, p₃b⟩, ⟨by simp [p₃i], _⟩, p₃r.trans p₂r⟩,
  have : p₃.tail ∩ A ⊆ p₂.tail ∩ A := inter_subset_inter_right p₃t,
  rw ←subset_empty, apply this.trans, rw p₂t, refl
end

noncomputable def trim (p : AB_walk G A B) : AB_walk G A B := p.trim_aux.val

lemma trim_minimal {p : AB_walk G A B} : p.trim.minimal := p.trim_aux.prop.1

lemma trim_range {p : AB_walk G A B} : p.trim.to_Walk.range ⊆ p.to_Walk.range := p.trim_aux.prop.2

noncomputable def massage_aux (h : G₂ ≤ G₁) (p : AB_walk G₂ A X) :
  {q : AB_walk G₁ A X // q.minimal ∧ q.to_Walk.range ⊆ p.to_Walk.range} :=
begin
  let p' := p.trim, rcases p'.to_Walk.transport (transportable_to_of_le h) with ⟨q,qa,qb,qr,qi,qt⟩,
  refine ⟨⟨q, qa.symm ▸ p'.ha, qb.symm ▸ p'.hb⟩, _, _⟩,
  { rw [minimal,qi,qt], exact trim_minimal },
  { rw [qr], exact trim_range }
end

noncomputable def massage (h : G₂ ≤ G₁) (p : AB_walk G₂ A X) : AB_walk G₁ A X :=
(p.massage_aux h).val

end AB_walk

def pw_disjoint (P : finset (AB_walk G A B)) : Prop :=
∀ ⦃γ₁ γ₂ : P⦄, (γ₁.val.to_Walk.range ∩ γ₂.val.to_Walk.range).nonempty → γ₁ = γ₂

namespace pw_disjoint

lemma le_A (dis : pw_disjoint P) : P.card ≤ A.card :=
begin
  let φ : P → A := λ p, ⟨p.1.1.a, p.1.ha⟩,
  have : injective φ := by { rintro p₁ p₂ h, simp at h, apply dis, use p₁.1.1.a, simp, simp [h] },
  simp_rw [←fintype.card_coe], convert fintype.card_le_of_injective φ this,
end

lemma le_B (dis : pw_disjoint P) : P.card ≤ B.card :=
begin
  let φ : P → B := λ p, ⟨p.val.b, p.val.hb⟩,
  have : injective φ := by { rintro p₁ p₂ h, apply dis, use p₁.val.b, simp at h, simp, simp [h] },
  simp_rw [←fintype.card_coe], convert fintype.card_le_of_injective φ this,
end

end pw_disjoint

def separates (G : simple_graph V) (A B : finset V) (X : finset V) : Prop :=
  ∀ γ : AB_walk G A B, (γ.to_Walk.range ∩ X).nonempty

namespace separates

lemma self : separates G A B A :=
  λ γ, ⟨γ.a, mem_inter.mpr ⟨Walk.start_mem_range,γ.ha⟩⟩

lemma symm : separates G A B X → separates G B A X :=
begin
  rintro h ⟨p,pa,pb⟩, let q : AB_walk G A B := by { use p.reverse; simpa only },
  specialize h q, simp only [reverse_range] at h, exact h
end

lemma comm : separates G A B X ↔ separates G B A X :=
⟨separates.symm,separates.symm⟩

end separates

@[ext] structure separator (G : simple_graph V) (A B : finset V) extends finset V :=
  (sep : separates G A B to_finset)

namespace separator

abbreviation card (X : separator G A B) : ℕ := X.to_finset.card

instance nonempty : nonempty (separator G A B) :=
⟨⟨A,separates.self⟩⟩

def symm : separator G A B → separator G B A :=
λ ⟨X, sep⟩, ⟨X, sep.symm⟩

@[simp] lemma card_symm {X : separator G A B} : X.symm.card = X.card :=
by { cases X, simp only [symm] }

def comm : separator G A B ≃ separator G B A :=
{ to_fun := symm,
  inv_fun := symm,
  left_inv := λ ⟨X,sep⟩, by simp only [symm],
  right_inv := λ ⟨X,sep⟩, by simp only [symm] }

end separator

def is_cut_set_size (G : simple_graph V) [decidable_rel G.adj] (A B : finset V) (n : ℕ) : Prop :=
∃ X : separator G A B, X.card = n

noncomputable instance : decidable_pred (is_cut_set_size G A B) :=
by { classical, apply_instance }

noncomputable def min_cut (G : simple_graph V) [decidable_rel G.adj] (A B : finset V) : ℕ :=
@nat.find (is_cut_set_size G A B) _ ⟨A.card, ⟨A, separates.self⟩, rfl⟩

namespace min_cut

lemma symm : min_cut G A B = min_cut G B A :=
begin
  simp_rw min_cut, congr' 1, ext n, split;
  { rintro ⟨X,h⟩, refine ⟨X.symm,_⟩, rw [separator.card_symm], exact h }
end

lemma spec : is_cut_set_size G A B (min_cut G A B) :=
by apply nat.find_spec

noncomputable def set (G : simple_graph V) [decidable_rel G.adj] (A B : finset V) :
  {X : separator G A B // X.card = min_cut G A B} :=
subtype_of_exists (spec)

lemma le {X : separator G A B} : min_cut G A B ≤ X.card :=
nat.find_le ⟨X, rfl⟩

lemma le' (sep : separates G A B X) : min_cut G A B ≤ X.card :=
nat.find_le ⟨⟨X,sep⟩, rfl⟩

end min_cut

def is_menger (G : simple_graph V) [decidable_rel G.adj] : Prop :=
∀ A B : finset V, ∃ P : finset (AB_walk G A B), pw_disjoint P ∧ P.card = min_cut G A B

lemma path_le_cut (dis : pw_disjoint P) (sep : separates G A B X) : P.card ≤ X.card :=
begin
  let φ : Π γ : P, γ.val.to_Walk.range ∩ X := λ γ, by { choose z hz using sep γ, exact ⟨z,hz⟩ },
  let ψ : P → X := λ γ, ⟨_, mem_of_mem_inter_right (φ γ).prop⟩,
  have h₁ : ∀ γ, (ψ γ).val ∈ γ.val.to_Walk.range := λ γ, let z := φ γ in (mem_inter.mp z.2).1,
  have h₂ : injective ψ := λ γ γ' h, dis ⟨_, mem_inter_of_mem (h₁ γ) (by { rw h, exact (h₁ γ') })⟩,
  simp_rw [←fintype.card_coe], convert fintype.card_le_of_injective ψ h₂
end

lemma upper_bound (dis : pw_disjoint P) : P.card ≤ min_cut G A B :=
by { obtain ⟨⟨X,h₁⟩,h₂⟩ := min_cut.set G A B, rw ←h₂, exact path_le_cut dis h₁ }

lemma bot_iff_no_edge : fintype.card G.dart = 0 ↔ G = ⊥ :=
begin
  split; intro h,
  { ext x y, simp, intro h₁, exact is_empty_iff.mp (fintype.card_eq_zero_iff.mp h) ⟨⟨_,_⟩,h₁⟩ },
  { simp_rw h, apply fintype.card_eq_zero_iff.mpr, exact (is_empty_iff.mpr dart.is_adj) }
end

lemma bot_separates_iff : separates ⊥ A B X ↔ (A ∩ B) ⊆ X :=
begin
  split; intro h,
  { rintros z hz, rw [mem_inter] at hz, let γ : AB_walk ⊥ A B := ⟨Walk.nil _, hz.1, hz.2⟩,
    choose z h₁ using h γ, simp at h₁, rw ←h₁.1, exact h₁.2 },
  { rintro ⟨⟨a,b,γ⟩,ha,hb⟩, cases γ, swap, exfalso, exact γ_h,
    simp at ha hb ⊢, use a, simp, split, exact Walk.start_mem_range,
    apply h, simp, exact ⟨ha,hb⟩ }
end

lemma bot_min_cut : min_cut ⊥ A B = (A ∩ B).card :=
begin
  apply (nat.find_eq_iff _).mpr, split,
  { use A ∩ B, rw [bot_separates_iff], refl },
  { rintro n hn ⟨X,rfl⟩, have := card_le_of_subset (bot_separates_iff.mp X.sep),
    change (A ∩ B).card ≤ X.card at this, linarith }
end

noncomputable def bot_path_set (A B : finset V) :
  {P : finset (AB_walk ⊥ A B) // pw_disjoint P ∧ P.card = (A ∩ B).card} :=
begin
  let φ : A ∩ B → AB_walk ⊥ A B := λ z, let h := mem_inter.mp z.prop in ⟨⟨walk.nil⟩,h.1,h.2⟩,
  have φ_inj : injective φ := λ _ _ h, by { simp only [φ] at h, ext, exact h.1 },
  refine ⟨image φ univ, _, _⟩,
  { rintro ⟨⟨γ₁,h₁,h₂⟩,h₃⟩ ⟨⟨γ₂,h₄,h₅⟩,h₆⟩ h₇,
    have nil₁ : γ₁ = Walk.nil γ₁.a := by { cases γ₁, cases γ₁_p, refl, exfalso, exact γ₁_p_h },
    have nil₂ : γ₂ = Walk.nil γ₂.a := by { cases γ₂, cases γ₂_p, refl, exfalso, exact γ₂_p_h },
    simp at h₇ ⊢, rw [nil₁,nil₂] at h₇ ⊢, cases h₇ with z h₇, simp at h₇, rw [←h₇.1,←h₇.2] },
  { rw [card_image_of_injective univ φ_inj, card_univ],
    convert fintype.card_of_finset (A ∩ B) _, intro z, simp, split,
    { rintros ⟨h₁,h₂⟩, exact set.mem_sep h₁ h₂ },
    { rintros h₁, exact h₁ } }
end

lemma bot_is_menger : is_menger (⊥ : simple_graph V) :=
by { rintro A B, rw bot_min_cut, exact (bot_path_set A B).exists_of_subtype }

lemma AB_lift_dis (P' : finset (AB_walk (map f G) (A.image f) (B.image f))) :
  pw_disjoint P' → pw_disjoint (P'.image (AB_walk.lift f hf A B)) :=
begin
  rintro hP' ⟨γ₁,h₁⟩ ⟨γ₂,h₂⟩ h, simp at h ⊢, choose z h using h,
  choose γ'₁ h'₁ h''₁ using mem_image.mp h₁,
  choose γ'₂ h'₂ h''₂ using mem_image.mp h₂,
  have h₃ := congr_arg (AB_walk.push f A B) h''₁, rw AB_walk.push_lift at h₃,
  have h₄ := congr_arg (AB_walk.push f A B) h''₂, rw AB_walk.push_lift at h₄,
  suffices : γ'₁ = γ'₂, { rw [←h''₁,←h''₂,this] },
  have := @hP' ⟨_,h'₁⟩ ⟨_,h'₂⟩, simp at this, apply this,
  simp [h₃,h₄,AB_walk.push,Walk.push_range], use f z, rw mem_inter at h ⊢, split,
  exact mem_image_of_mem f h.1, exact mem_image_of_mem f h.2
end

def minus (G : simple_graph V) (e : G.dart) : simple_graph V :=
G.delete_edges {e.edge}

infix `-` := minus

noncomputable instance : decidable_rel (G-e).adj := by { classical, apply_instance }

lemma minus_le {e : G.dart} : G-e ≤ G := λ x y h, h.1

lemma minus_lt_edges {e : G.dart} : fintype.card (G-e).dart < fintype.card G.dart :=
begin
  let φ : (G-e).dart → G.dart := λ e, ⟨⟨_,_⟩,e.is_adj.1⟩,
  have φ_inj : injective φ := by { rintro e₁ e₂ h, simp [φ] at h, exact e₁.ext e₂ h },
  suffices : e ∉ set.range φ, refine fintype.card_lt_of_injective_of_not_mem φ φ_inj this,
  intro he, rw set.mem_range at he, choose e' he using he, rcases e' with ⟨⟨x,y⟩,he'⟩,
  replace he := (dart.ext_iff _ _).mp he, replace he := prod.ext_iff.mp he,
  simp only at he, cases he, substs x y,
  simp [minus] at he', simp [dart.edge,sym2] at he', apply he'.2, refl
end

lemma sep_AB_of_sep₂_AX ⦃e : G.dart⦄ (ex_in_X : e.fst ∈ X) (ey_in_X : e.snd ∈ X) :
  separates G A B X → separates (G-e) A X Z → separates G A B Z :=
by {
  rintro X_sep_AB Z_sep₂_AX γ,
  rcases γ.to_Walk.until X (X_sep_AB γ) with ⟨δ,δ_a,δ_b,δ_range,δ_init,-⟩,
  have : δ.transportable_to (G-e) := by {
    revert δ_init, refine Walk.rec₀ _ _ δ,
    { simp [Walk.transportable_to,Walk.edges] },
    { rintro e' p h ih h₁ e'' h₂,
      have h₃ : p.init ∩ X = ∅ :=
      by { apply subset_empty.mp, rw [←h₁], apply inter_subset_inter_right,
        rw [Walk.init_cons], apply subset_union_right },
      simp at h₂, cases h₂,
      { subst e'', simp at h₁, simp [minus,e'.is_adj],
        have : e'.fst ∉ X :=
        by { rw [inter_distrib_right, union_eq_empty_iff] at h₁, intro h,
          apply not_nonempty_empty, rw ←h₁.1,
          exact ⟨e'.fst, by simp only [h, singleton_inter_of_mem, mem_singleton]⟩ },
        intro h', apply this, rw [dart.edge,sym2.mk_eq_mk_iff] at h',
        cases h'; { rw h', assumption } },
      { exact ih h₃ e'' h₂ }
    }
  },
  rcases δ.transport this with ⟨ζ,ζ_a,ζ_b,ζ_range,-,-⟩,
  rcases Z_sep₂_AX ⟨ζ, by { rw [ζ_a,δ_a], exact γ.ha }, by { rw [ζ_b], exact δ_b }⟩ with ⟨z,hz⟩,
  rw ←ζ_range at δ_range, rw mem_inter at hz,
  exact ⟨z, mem_inter.mpr ⟨mem_of_subset δ_range hz.1, hz.2⟩⟩,
}

lemma massage_eq {h : G₂ ≤ G₁} {P : finset (AB_walk G₂ A B)} {p₁ p₂ : P} :
  pw_disjoint P → ((p₁.val.massage h).to_Walk.range ∩ (p₂.val.massage h).to_Walk.range).nonempty →
  p₁ = p₂ :=
begin
  rintro hP h, apply hP, rcases h with ⟨z,hz⟩, use z, simp at hz ⊢, split,
  { apply (p₁.val.massage_aux h).prop.2, exact hz.1 },
  { apply (p₂.val.massage_aux h).prop.2, exact hz.2 }
end

lemma massage_disjoint {h : G₂ ≤ G₁} {P : finset (AB_walk G₂ A B)} :
  pw_disjoint P → pw_disjoint (image (AB_walk.massage h) P) :=
begin
  rintro h₁ ⟨p₁,hp₁⟩ ⟨p₂,hp₂⟩ h, apply subtype.ext, dsimp,
  choose q₁ hq₁ hq₁' using mem_image.mp hp₁, choose q₂ hq₂ hq₂' using mem_image.mp hp₂,
  rw [←hq₁',←hq₂'], apply congr_arg, let γ₁ : P := ⟨q₁,hq₁⟩, let γ₂ : P := ⟨q₂,hq₂⟩,
  suffices : γ₁ = γ₂, { simp only [subtype.mk_eq_mk] at this, exact this }, apply massage_eq h₁,
  rw [hq₁',hq₂'], exact h
end

lemma massage_card {h : G₂ ≤ G₁} {P : finset (AB_walk G₂ A B)} :
  pw_disjoint P → (image (AB_walk.massage h) P).card = P.card :=
begin
  rintro hP, apply card_image_of_inj_on, rintro p₁ hp₁ p₂ hp₂ he,
  let q₁ : P := ⟨p₁,hp₁⟩, let q₂ : P := ⟨p₂,hp₂⟩, suffices : q₁ = q₂, simp at this, exact this,
  apply massage_eq hP, rw he, simp
end

lemma meet_sub_X (X_sep_AB : separates G A B X) (p : AB_walk G A X) (q : AB_walk G B X)
  (hp : p.minimal) (hq : q.minimal) : p.to_Walk.range ∩ q.to_Walk.range ⊆ X :=
begin
  rcases p with ⟨p,pa,pb⟩, rcases q with ⟨q,qa,qb⟩, dsimp,
  rintro x hx, rw mem_inter at hx, cases hx with hx₁ hx₂, by_contra,

  rcases p.until {x} ⟨x, by simp [hx₁]⟩ with ⟨p', p'a, p'b, p'r, p'i, p'i2, p't⟩, simp at p'b,
  have h₁ : p'.range ∩ X = ∅ :=
  by { rw Walk.range_eq_init_union_last, rw inter_distrib_right, rw union_eq_empty_iff, split,
    { exact subset_empty.mp ((inter_subset_inter_right p'i2).trans (subset_empty.mpr hp.1)) },
    { rw p'b, exact singleton_inter_of_not_mem h } },

  rcases q.until {x} ⟨x, by simp [hx₂]⟩ with ⟨q', q'a, q'b, q'r, q'i, q'i2, q't⟩, simp at q'b,
  have h₁ : q'.range ∩ X = ∅ :=
  by { rw Walk.range_eq_init_union_last, rw inter_distrib_right, rw union_eq_empty_iff, split,
    { exact subset_empty.mp ((inter_subset_inter_right q'i2).trans (subset_empty.mpr hq.1)) },
    { rw q'b, exact singleton_inter_of_not_mem h } },

  let γ : AB_walk G A B :=
  ⟨Walk.append p' q'.reverse (by simp [p'b,q'b]), by simp [p'a,pa], by simp [q'a,qa]⟩,
  choose z hz using X_sep_AB γ, rw [range_append,reverse_range,inter_distrib_right] at hz,
  rw mem_union at hz, cases hz; { have := ne_empty_of_mem hz, contradiction }
end

noncomputable def endpoint (P : finset (AB_walk G A B))
  (P_dis : pw_disjoint P) (P_eq : P.card = B.card) : P ≃ B :=
begin
  let φ : P → B := λ p, let q := p.val in ⟨q.b,q.hb⟩,
  apply equiv.of_bijective φ, rw fintype.bijective_iff_injective_and_card, split,
  { rintro p₁ p₂ h, apply P_dis, use p₁.val.b, simp at h ⊢, simp [h]  },
  { simp, exact P_eq },
end

noncomputable def sep_cleanup {e : G.dart} (ex_in_X : e.fst ∈ X) (ey_in_X : e.snd ∈ X)
  (X_eq_min : X.card = min_cut G A B) (X_sep_AB : separates G A B X)
  (ih : ∃ (P : finset (AB_walk (G-e) A X)), pw_disjoint P ∧ P.card = min_cut (G-e) A X) :
  {P : finset (AB_walk G A X) // pw_disjoint P ∧ P.card = X.card ∧ ∀ p : P, p.val.minimal} :=
begin
  choose P h₁ h₂ using ih, use image (AB_walk.massage minus_le) P, refine ⟨_,_,_⟩,
  { exact massage_disjoint h₁ },
  { apply (massage_card h₁).trans, apply le_antisymm h₁.le_B,
    rcases min_cut.set (G-e) A X with ⟨⟨Z,Z_sep₂_AB⟩,Z_eq_min⟩,
    rw [X_eq_min,h₂,←Z_eq_min], apply min_cut.le',
    exact sep_AB_of_sep₂_AX ex_in_X ey_in_X X_sep_AB Z_sep₂_AB },
  { intro p, choose p' hp'₁ hp'₂ using mem_image.mp p.prop,
    have := (p'.massage_aux minus_le).prop.1, simp [AB_walk.massage] at hp'₂, rw hp'₂ at this,
    simp, exact this }
end

noncomputable def stitch (X_sep_AB : separates G A B X)
  (P : finset (AB_walk G A X)) (P_dis: pw_disjoint P) (P_eq_X: P.card = X.card)
  (Q : finset (AB_walk G B X)) (Q_dis: pw_disjoint Q) (Q_eq_X: Q.card = X.card)
  (hP : ∀ p : P, p.val.minimal) (hQ : ∀ q : Q, q.val.minimal) :
  {R : finset (AB_walk G A B) // pw_disjoint R ∧ R.card = X.card} :=
begin
  let φ : X ≃ P := (endpoint P P_dis P_eq_X).symm,
  let ψ : X ≃ Q := (endpoint Q Q_dis Q_eq_X).symm,

  have φxb : ∀ x : X, (φ x).val.b = x.val :=
  by { intro x, set γ := φ x,
    have : x = φ.symm γ := by simp only [equiv.symm_symm, equiv.apply_symm_apply],
    rw this, refl },

  have ψxb : ∀ x : X, (ψ x).val.b = x.val :=
  by { intro x, set γ := ψ x,
    have : x = ψ.symm γ := by simp only [equiv.symm_symm, equiv.apply_symm_apply],
    rw this, refl },

  let Ψ : X → AB_walk G A B :=
  by { intro x, set γ := φ x with hγ, set δ := ψ x with hδ,
    have γbx : γ.val.b = x := φxb x, have δbx : δ.val.b = x := ψxb x,
    set ζ := δ.val.to_Walk.reverse, refine ⟨Walk.append γ.val.to_Walk ζ _, _, _⟩,
    { rw [γbx,←δbx,reverse_a] },
    { rw [append_a], exact γ.val.ha },
    { rw [append_b,reverse_b], exact δ.val.ha } },

  set R := image Ψ univ,

  have Ψ_inj : injective Ψ :=
  by {
    have : ∀ x : X, (Ψ x).to_Walk.range ∩ X = {x} :=
    by { intro,
      simp only [range_append, reverse_range],
      simp_rw range_eq_init_union_last, simp_rw inter_distrib_right,
      simp only [union_assoc],
      rw [(hP (φ x)).1, (hQ (ψ x)).1, φxb, ψxb],
      simp only [subtype.val_eq_coe,singleton_inter_of_mem,coe_mem,empty_union,union_idempotent] },
    rintro x y h, ext, apply singleton_inj.mp, rw [← this x, ← this y, h] },

  have l₁ : ∀ x y z, z ∈ (φ x).val.to_Walk.range ∩ (ψ y).val.to_Walk.range → x = y :=
  by {
    intros x y z hz,
    have z_in_X : z ∈ X := meet_sub_X X_sep_AB (φ x) (ψ y) (hP (φ x)) (hQ (ψ y)) hz,
    rw mem_inter at hz,
    have z_is_x : z = x := by {
      apply mem_singleton.mp, convert ← mem_inter.mpr ⟨hz.1,z_in_X⟩,
      rw [range_eq_init_union_last, inter_distrib_right, φxb, (hP (φ x)).1],
      simp only [subtype.val_eq_coe, singleton_inter_of_mem, coe_mem, empty_union], },
    have z_is_y : z = y := by {
      apply mem_singleton.mp, convert ← mem_inter.mpr ⟨hz.2,z_in_X⟩,
      rw [range_eq_init_union_last, inter_distrib_right, ψxb, (hQ (ψ y)).1],
      simp only [subtype.val_eq_coe, singleton_inter_of_mem, coe_mem, empty_union] },
    ext, exact z_is_x.symm.trans z_is_y },

  have R_dis : pw_disjoint R :=
  by {
    rintro ⟨γ₁, hγ₁⟩ ⟨γ₂, hγ₂⟩ h_dis,
    choose x hx using mem_image.mp hγ₁, replace hx := hx.2, subst hx,
    choose y hy using mem_image.mp hγ₂, replace hy := hy.2, subst hy,
    suffices : x = y, subst this,
    simp only [inter_distrib_left, inter_distrib_right, subtype.val_eq_coe, range_append,
      reverse_range, union_assoc] at h_dis,
    choose z hz using h_dis, simp only [mem_union] at hz,
    cases hz, { apply φ.left_inv.injective, apply P_dis, use z, exact hz },
    cases hz, { exact l₁ x y z hz },
    cases hz, { rw inter_comm at hz, exact (l₁ y x z hz).symm },
    { apply ψ.left_inv.injective, apply Q_dis, use z, exact hz }
  },

  refine ⟨R, R_dis, _⟩, rw finset.card_image_of_injective _ Ψ_inj, convert fintype.card_coe X
end

lemma sep_of_sep_in_merge : separates (G/e) (image (merge_edge e) A) (image (merge_edge e) B) Y →
  separates G A B (Y ∪ {e.snd}) :=
begin
  rintro Y_sep γ,
  choose z hz using Y_sep (γ.push (merge_edge e) A B),
  rw [mem_inter,AB_walk.push,Walk.push_range,mem_image] at hz,
  choose x hx₁ hx₂ using hz.1,
  by_cases x = e.snd; simp [merge_edge,h] at hx₂,
  { use x, simp, split, exact hx₁, right, exact h },
  { use x, simp, split, exact hx₁, left, rw hx₂, exact hz.2 }
end

lemma step_1 (h_contract : is_menger (G/e))
  (too_small : ∀ P : finset (AB_walk G A B), pw_disjoint P → P.card < min_cut G A B) :
  ∃ X : finset V, e.fst ∈ X ∧ e.snd ∈ X ∧ separates G A B X ∧ X.card = min_cut G A B :=
begin
  let A₁ := image (merge_edge e) A, let B₁ := image (merge_edge e) B,
  obtain ⟨Y, Y_eq_min₁⟩ := min_cut.set (G/e) A₁ B₁, let X := Y.to_finset ∪ {e.snd},

  have Y_lt_min : Y.card < min_cut G A B :=
  by {
    choose P₁ P₁_dis P₁_eq_min₁ using h_contract A₁ B₁,
    rw [Y_eq_min₁, ←P₁_eq_min₁, ←card_image_of_injective P₁ AB_walk.lift_inj],
    apply too_small, { apply AB_lift_dis, exact P₁_dis }, { exact merge_edge_adapted }
  },

  have X_sep_AB : separates G A B X := sep_of_sep_in_merge Y.sep,

  refine ⟨X, _, _, X_sep_AB, _⟩,

  { rw [mem_union], left, by_contradiction,
    suffices : separates G A B Y.to_finset, by { exact not_lt_of_le (min_cut.le' this) Y_lt_min },
    intro p, choose z hz using Y.sep (p.push (merge_edge e) A B), use z,
    rw mem_inter at hz ⊢, rcases hz with ⟨hz₁,hz₂⟩, refine ⟨_,hz₂⟩,
    rw [AB_walk.push,Walk.push_range,mem_image] at hz₁, choose x hx₁ hx₂ using hz₁,
    by_cases x = e.snd; simp [merge_edge,h] at hx₂,
    { rw [←hx₂] at hz₂, contradiction },
    { rwa [←hx₂] } },
  { rw [mem_union,mem_singleton], right, refl },
  { refine le_antisymm _ (min_cut.le' X_sep_AB),
    exact (card_union_le _ _).trans (nat.succ_le_of_lt Y_lt_min) }
end

lemma induction_step (e : G.dart) : is_menger (G/e) → is_menger (G-e) → is_menger G :=
begin
  intros h_contract h_minus A B,

  apply not_imp_self.mp, intro too_small, push_neg at too_small, replace too_small :
    ∀ P : finset (AB_walk G A B), pw_disjoint P → P.card < min_cut G A B :=
  by { intros P h, exact lt_of_le_of_ne (upper_bound h) (too_small P h) },

  choose X ex_in_X ey_in_X X_sep_AB X_eq_min using step_1 h_contract too_small,

  rcases sep_cleanup ex_in_X ey_in_X X_eq_min X_sep_AB (h_minus A X) with ⟨P,hP⟩,
  let X_eq_min' : X.card = min_cut G B A := X_eq_min.trans min_cut.symm,
  rcases sep_cleanup ex_in_X ey_in_X X_eq_min' X_sep_AB.symm (h_minus B X) with ⟨Q,hQ⟩,
  rw ←X_eq_min, apply subtype.exists_of_subtype,

  exact stitch X_sep_AB P hP.1 hP.2.1 Q hQ.1 hQ.2.1 hP.2.2 hQ.2.2
end

lemma lower_bound_aux (n : ℕ) : ∀ (G : simple_graph V) [decidable_rel G.adj],
  by exactI fintype.card G.dart ≤ n → is_menger G :=
begin
  induction n with n ih; intros G G_dec hG,
  { have : G = ⊥ := by { apply bot_iff_no_edge.mp, exact nat.le_zero_iff.mp hG, apply_instance },
    simp_rw this, exact bot_is_menger },
  { resetI, by_cases (fintype.card G.dart = 0),
    { apply ih, rw h, linarith },
    { cases not_is_empty_iff.mp (h ∘ fintype.card_eq_zero_iff.mpr) with e, apply induction_step e,
      { exact ih _ (nat.le_of_lt_succ (nat.lt_of_lt_of_le contract_edge.fewer_edges hG)) },
      { exact ih _ (nat.le_of_lt_succ (nat.lt_of_lt_of_le minus_lt_edges hG)) } } }
end

theorem menger : is_menger G :=
begin
  apply lower_bound_aux (fintype.card G.dart), apply le_of_eq, convert rfl
end

end menger
end simple_graph


import group_theory.group_action.support
import phase0.struct_perm

/-!
# Supports
-/

open cardinal equiv mul_action quiver
open_locale cardinal

noncomputable theory

universe u

namespace con_nf
variables [params.{u}] {α : type_index}

/-- A support condition is an atom or a near-litter together with an extended type index. -/
@[derive [inhabited]]
def support_condition (α : type_index) : Type u := (atom ⊕ near_litter) × extended_index α

/-- The "identity" equivalence between `(atom ⊕ near_litter) × extended_index α` and
`support_condition α`. -/
def to_condition : (atom ⊕ near_litter) × extended_index α ≃ support_condition α := equiv.refl _

/-- The "identity" equivalence between `support_condition α` and
`(atom ⊕ near_litter) × extended_index α`. -/
def of_condition : support_condition α ≃ (atom ⊕ near_litter) × extended_index α := equiv.refl _

/-- There are `μ` support conditions. -/
@[simp] lemma mk_support_condition (α : type_index) : #(support_condition α) = #μ :=
begin
  simp only [support_condition, mk_prod, mk_sum, mk_atom, lift_id, mk_near_litter],
  rw add_eq_left (κ_regular.aleph_0_le.trans κ_le_μ) le_rfl,
  exact mul_eq_left (κ_regular.aleph_0_le.trans κ_le_μ)
    (le_trans (mk_extended_index α) $ le_of_lt $ lt_trans Λ_lt_κ κ_lt_μ) (mk_ne_zero _),
end

namespace struct_perm

instance mul_action_support_condition : mul_action (struct_perm α) (support_condition α) :=
{ smul := λ π c, ⟨derivative c.snd π • c.fst, c.snd⟩,
  one_smul := by { rintro ⟨atoms | Ns, A⟩; unfold has_smul.smul; simp },
  mul_smul := begin
    rintro π₁ π₂ ⟨atoms | Ns, A⟩; unfold has_smul.smul;
    rw derivative_mul; dsimp; rw mul_smul,
  end }

instance mul_action_support_condition' {B : le_index α} {β : type_index} {γ : type_index}
  {hγ : γ < β}
  (A : path (B : type_index) β) :
  mul_action (struct_perm ((lt_index.mk' hγ (B.path.comp A)) : le_index α).index)
    (support_condition γ) :=
struct_perm.mul_action_support_condition

instance mul_action_support_condition_lt_index
  {β γ : type_index} {hγ : γ < β} (A : path α β) :
  mul_action (struct_perm (lt_index.mk' hγ A)) (support_condition γ) :=
struct_perm.mul_action_support_condition

instance mul_action_support_condition_lt_index'
  {β γ : type_index} {hγ : γ < β} (A : path α β) :
  mul_action (struct_perm (lt_index.mk' hγ A : le_index α).index) (support_condition γ) :=
struct_perm.mul_action_support_condition

@[simp] lemma smul_to_condition (π : struct_perm α) (x : (atom ⊕ near_litter) × extended_index α) :
  π • to_condition x = to_condition ⟨derivative x.2 π • x.1, x.2⟩ := rfl

end struct_perm

variables (G : Type*) (α) {τ : Type*} [has_smul G (support_condition α)] [has_smul G τ]

structure support (x : τ) :=
(carrier : set (support_condition α))
(small : small carrier)
(supports : supports G carrier x)

/-- An element of `τ` is *supported* if it has some support. -/
def supported (x : τ) : Prop := nonempty $ support α G x

instance support.set_like (x : τ) : set_like (support α G x) (support_condition α) :=
{ coe := support.carrier,
  coe_injective' := λ s t h, by { cases s, cases t, congr' } }

@[simp] lemma support.carrier_eq_coe {x : τ} {s : support α G x} : s.carrier = s := rfl

/-- There are at most `μ` supports for a given `x : τ`. -/
lemma mk_support_le (x : τ) : #(support α G x) ≤ #μ :=
begin
  transitivity #{s : set μ // small s},
  transitivity #{S : set (support_condition α) // small S},
  { refine ⟨⟨λ s, ⟨s.carrier, s.small⟩, λ s t h, _⟩⟩,
    simpa only [subtype.mk_eq_mk, support.carrier_eq_coe, set_like.coe_set_eq] using h },
  { convert le_of_eq
      (mk_subtype_of_equiv _ (equiv.set.congr (cardinal.eq.mp (mk_support_condition α)).some)),
    ext s,
    refine ⟨small.image, λ h, _⟩,
    rw ← symm_apply_apply (equiv.set.congr (cardinal.eq.mp $ mk_support_condition α).some) s,
    exact h.image },
  { rw ← mk_subset_mk_lt_cof μ_strong_limit.2,
    exact mk_subtype_mono (λ s hs, lt_of_lt_of_le hs κ_le_μ_cof) }
end

end con_nf