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

! This file was ported from Lean 3 source module category_theory.path_category
! leanprover-community/mathlib commit c6dd521ebdce53bb372c527569dd7c25de53a08b
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.CategoryTheory.EqToHom
import Mathlib.CategoryTheory.Quotient
import Mathlib.Combinatorics.Quiver.Path

/-!
# The category paths on a quiver.
When `C` is a quiver, `paths C` is the category of paths.

## When the quiver is itself a category
We provide `path_composition : paths C ⥤ C`.

We check that the quotient of the path category of a category by the canonical relation
(paths are related if they compose to the same path) is equivalent to the original category.
-/

universe v₁ v₂ u₁ u₂

namespace CategoryTheory

section

/-- A type synonym for the category of paths in a quiver.
-/
def Paths (V : Type u₁) : Type u₁ := V
#align category_theory.paths CategoryTheory.Paths

instance (V : Type u₁) [Inhabited V] : Inhabited (Paths V) := ⟨(default : V)⟩

variable (V : Type u₁) [Quiver.{v₁ + 1} V]

namespace Paths

instance categoryPaths : Category.{max u₁ v₁} (Paths V) where
  Hom := fun X Y : V => Quiver.Path X Y
  id X := Quiver.Path.nil
  comp f g := Quiver.Path.comp f g
#align category_theory.paths.category_paths CategoryTheory.Paths.categoryPaths

variable {V}

/-- The inclusion of a quiver `V` into its path category, as a prefunctor.
-/
@[simps]
def of : V ⥤q Paths V where
  obj X := X
  map f := f.toPath
#align category_theory.paths.of CategoryTheory.Paths.of

attribute [local ext] Functor.ext

/-- Any prefunctor from `V` lifts to a functor from `paths V` -/
def lift {C} [Category C] (φ : V ⥤q C) : Paths V ⥤ C where
  obj := φ.obj
  map {X} {Y} f :=
    @Quiver.Path.rec V _ X (fun Y _ => φ.obj X ⟶ φ.obj Y) (𝟙 <| φ.obj X)
      (fun _ f ihp => ihp ≫ φ.map f) Y f
  map_id X := by rfl
  map_comp f g := by
    induction' g with _ _ g' p ih _ _ _
    · rw [Category.comp_id]
      rfl
    · have : f ≫ Quiver.Path.cons g' p = (f ≫ g').cons p := by apply Quiver.Path.comp_cons
      rw [this]
      simp only at ih ⊢
      rw [ih, Category.assoc]
#align category_theory.paths.lift CategoryTheory.Paths.lift

@[simp]
theorem lift_nil {C} [Category C] (φ : V ⥤q C) (X : V) :
    (lift φ).map Quiver.Path.nil = 𝟙 (φ.obj X) := rfl
#align category_theory.paths.lift_nil CategoryTheory.Paths.lift_nil

@[simp]
theorem lift_cons {C} [Category C] (φ : V ⥤q C) {X Y Z : V} (p : Quiver.Path X Y) (f : Y ⟶ Z) :
    (lift φ).map (p.cons f) = (lift φ).map p ≫ φ.map f := rfl
#align category_theory.paths.lift_cons CategoryTheory.Paths.lift_cons

@[simp]
theorem lift_toPath {C} [Category C] (φ : V ⥤q C) {X Y : V} (f : X ⟶ Y) :
    (lift φ).map f.toPath = φ.map f := by
  dsimp [Quiver.Hom.toPath, lift]
  simp
#align category_theory.paths.lift_to_path CategoryTheory.Paths.lift_toPath

theorem lift_spec {C} [Category C] (φ : V ⥤q C) : of ⋙q (lift φ).toPrefunctor = φ := by
  fapply Prefunctor.ext
  · rintro X
    rfl
  · rintro X Y f
    rcases φ with ⟨φo, φm⟩
    dsimp [lift, Quiver.Hom.toPath]
    simp only [Category.id_comp]
#align category_theory.paths.lift_spec CategoryTheory.Paths.lift_spec

theorem lift_unique {C} [Category C] (φ : V ⥤q C) (Φ : Paths V ⥤ C)
    (hΦ : of ⋙q Φ.toPrefunctor = φ) : Φ = lift φ := by
  subst_vars
  fapply Functor.ext
  · rintro X
    rfl
  · rintro X Y f
    dsimp [lift]
    induction' f with _ _ p f' ih
    · simp only [Category.comp_id]
      apply Functor.map_id
    · simp only [Category.comp_id, Category.id_comp] at ih ⊢
      -- porting note: Had to do substitute `p.cons f'` and `f'.toPath` by their fully qualified
      -- versions in this `have` clause (elsewhere too).
      have : Φ.map (Quiver.Path.cons p f') = Φ.map p ≫ Φ.map (Quiver.Hom.toPath f') := by
        convert Functor.map_comp Φ p (Quiver.Hom.toPath f')
      rw [this, ih]
#align category_theory.paths.lift_unique CategoryTheory.Paths.lift_unique

/-- Two functors out of a path category are equal when they agree on singleton paths. -/
@[ext]
theorem ext_functor {C} [Category C] {F G : Paths V ⥤ C} (h_obj : F.obj = G.obj)
    (h : ∀ (a b : V) (e : a ⟶ b), F.map e.toPath =
        eqToHom (congr_fun h_obj a) ≫ G.map e.toPath ≫ eqToHom (congr_fun h_obj.symm b)) :
    F = G := by
  fapply Functor.ext
  · intro X
    rw [h_obj]
  · intro X Y f
    induction' f with Y' Z' g e ih
    · erw [F.map_id, G.map_id, Category.id_comp, eqToHom_trans, eqToHom_refl]
    · erw [F.map_comp g (Quiver.Hom.toPath e), G.map_comp g (Quiver.Hom.toPath e), ih, h]
      simp only [Category.id_comp, eqToHom_refl, eqToHom_trans_assoc, Category.assoc]
#align category_theory.paths.ext_functor CategoryTheory.Paths.ext_functor

end Paths

variable (W : Type u₂) [Quiver.{v₂ + 1} W]

-- A restatement of `prefunctor.map_path_comp` using `f ≫ g` instead of `f.comp g`.
@[simp]
theorem Prefunctor.mapPath_comp' (F : V ⥤q W) {X Y Z : Paths V} (f : X ⟶ Y) (g : Y ⟶ Z) :
    F.mapPath (f ≫ g) = (F.mapPath f).comp (F.mapPath g) :=
  Prefunctor.mapPath_comp _ _ _
#align category_theory.prefunctor.map_path_comp' CategoryTheory.Prefunctor.mapPath_comp'

end

section

variable {C : Type u₁} [Category.{v₁} C]

open Quiver

-- porting note:
-- This def was originally marked `@[simp]`, but the meaning is different in lean4: lean4#2042
-- So, the `@[simp]` was removed, and the two equational lemmas below added instead.
/-- A path in a category can be composed to a single morphism. -/
def composePath {X : C} : ∀ {Y : C} (_ : Path X Y), X ⟶ Y
  | _, .nil => 𝟙 X
  | _, .cons p e => composePath p ≫ e
#align category_theory.compose_path CategoryTheory.composePath

@[simp] lemma composePath_nil {X : C} : composePath (Path.nil : Path X X) = 𝟙 X := rfl

@[simp] lemma composePath_cons {X Y Z : C} (p : Path X Y) (e : Y ⟶ Z) :
  composePath (p.cons e) = composePath p ≫ e := rfl

@[simp]
theorem composePath_toPath {X Y : C} (f : X ⟶ Y) : composePath f.toPath = f := Category.id_comp _
#align category_theory.compose_path_to_path CategoryTheory.composePath_toPath

@[simp]
theorem composePath_comp {X Y Z : C} (f : Path X Y) (g : Path Y Z) :
    composePath (f.comp g) = composePath f ≫ composePath g := by
  induction' g with Y' Z' g e ih
  · simp
  · simp [ih]
#align category_theory.compose_path_comp CategoryTheory.composePath_comp

@[simp]
-- porting note: TODO get rid of `(id X : C)` somehow?
theorem composePath_id {X : Paths C} : composePath (𝟙 X) = 𝟙 (id X : C) := rfl
#align category_theory.compose_path_id CategoryTheory.composePath_id

@[simp]
theorem composePath_comp' {X Y Z : Paths C} (f : X ⟶ Y) (g : Y ⟶ Z) :
    composePath (f ≫ g) = composePath f ≫ composePath g :=
  composePath_comp f g
#align category_theory.compose_path_comp' CategoryTheory.composePath_comp'

variable (C)

/-- Composition of paths as functor from the path category of a category to the category. -/
@[simps]
def pathComposition : Paths C ⥤ C where
  obj X := X
  map f := composePath f
#align category_theory.path_composition CategoryTheory.pathComposition

-- TODO: This, and what follows, should be generalized to
-- the `hom_rel` for the kernel of any functor.
-- Indeed, this should be part of an equivalence between congruence relations on a category `C`
-- and full, essentially surjective functors out of `C`.
/-- The canonical relation on the path category of a category:
two paths are related if they compose to the same morphism. -/
@[simp]
def pathsHomRel : HomRel (Paths C) := fun _ _ p q =>
  (pathComposition C).map p = (pathComposition C).map q
#align category_theory.paths_hom_rel CategoryTheory.pathsHomRel

/-- The functor from a category to the canonical quotient of its path category. -/
@[simps]
def toQuotientPaths : C ⥤ Quotient (pathsHomRel C) where
  obj X := Quotient.mk X
  map f := Quot.mk _ f.toPath
  map_id X := Quot.sound (Quotient.CompClosure.of _ _ _ (by simp))
  map_comp f g := Quot.sound (Quotient.CompClosure.of _ _ _ (by simp))
#align category_theory.to_quotient_paths CategoryTheory.toQuotientPaths

/-- The functor from the canonical quotient of a path category of a category
to the original category. -/
@[simps!]
def quotientPathsTo : Quotient (pathsHomRel C) ⥤ C :=
  Quotient.lift _ (pathComposition C) fun _ _ _ _ w => w
#align category_theory.quotient_paths_to CategoryTheory.quotientPathsTo

/-- The canonical quotient of the path category of a category
is equivalent to the original category. -/
def quotientPathsEquiv : Quotient (pathsHomRel C) ≌ C where
  functor := quotientPathsTo C
  inverse := toQuotientPaths C
  unitIso :=
    NatIso.ofComponents
      (fun X => by cases X; rfl)
      (Quot.ind $ fun f => by
        apply Quot.sound
        apply Quotient.CompClosure.of
        simp [Category.comp_id, Category.id_comp, pathsHomRel])
  counitIso := NatIso.ofComponents (fun X => Iso.refl _) (fun f => by simp [Quot.liftOn_mk])
  functor_unitIso_comp X := by
    cases X
    simp only [pathsHomRel, pathComposition_obj, pathComposition_map, Functor.id_obj,
               quotientPathsTo_obj, Functor.comp_obj, toQuotientPaths_obj_as,
               NatIso.ofComponents_hom_app, Iso.refl_hom, quotientPathsTo_map, Category.comp_id]
    rfl
#align category_theory.quotient_paths_equiv CategoryTheory.quotientPathsEquiv

end

end CategoryTheory


import SciLean
-- import SciLean.Mechanics

-- import Lean.Meta.Tactic

set_option synthInstance.maxHeartbeats 5000000
set_option synthInstance.maxSize 2048

open SciLean

abbrev V := (ℝ^(3:ℕ)) × (ℝ^(3:ℕ))

def ε : ℝ := 0.001
instance : Fact (ε≠0) := Fact.mk (by native_decide)

abbrev parm2 (l₁ l₂ : ℝ) (Ω : V) : V :=
  let e : ℝ^(3:ℕ) := ⟨0,-1,0⟩
  let Δx₁ := rotate3d Ω.1 (l₁ * e)
  let Δx₂ := rotate3d Ω.2 (l₂ * e)
  (Δx₁, Δx₁ + Δx₂)

abbrev parm (l : ℝ) (Ω : ℝ^(3:ℕ)) : ℝ^(3:ℕ) :=
  have e : ℝ^(3:ℕ) := ⟨0,-1,0⟩
  εrotate ε Ω (l * e)

@[simp]
theorem pair_add {X Y} [Add X] [Add Y] (x x' : X) (y y' : Y) : (x, y) + (x', y') = (x + x', y + y') := by simp[HAdd.hAdd, Add.add] done

def L2 (m₁ m₂ : ℝ) (l₁ l₂ : ℝ) (Ω ω : V) :=
  let g : ℝ := 9.81
  let x := parm2 l₁ l₂ Ω
  let v := ω -- δ (λ t : ℝ => parm l₁ l₂ (Ω + t * ω)) 0 1
    -- rewrite_by (simp[parm])
  1/(2*m₁) * ∥v.1∥² - m₁ * g * x.1.y +
  1/(2*m₂) * ∥v.2∥² - m₂ * g * x.2.y

def g : ℝ := 9.81

-- example (x : Float) : x + 0.1 = 0.1 + x := by simp

def L (m : ℝ) (l : ℝ) (Ω ω : ℝ^(3:ℕ)) : ℝ :=
  -- let g : ℝ := 9.81
  let e : ℝ^(3:ℕ) := ⟨0,-1,0⟩
  let x := parm l Ω
  let v := δ (λ t : ℝ => parm l (Ω + t * ω)) 0 1
    rewrite_by (simp[parm])
  m/2 * ∥v∥² - m * g * x.y
argument Ω
  isSmooth, diff,
  hasAdjDiff, adjDiff
argument ω
  isSmooth, diff, hasAdjDiff, adjDiff

-- argument ω
--   isSmooth, diff, hasAdjDiff, adjDiff

#check Nat

example : IsSmooth (λ ω dω Ω => εrotate.arg_ω.diff ε ω dω Ω) := by apply εrotate.arg_ω.diff.arg_ω.isSmooth

example (dω Ω) : IsSmooth (λ ω => εrotate.arg_ω.diff ε ω dω Ω) := by infer_instance

#check εrotate.arg_ω.diff.arg_ω.isSmooth

#print L.arg_Ω.adjDiff

def momentum (m : ℝ) (l : ℝ) (Ω ω : ℝ^(3:ℕ)) : ℝ^(3:ℕ) :=
  (δ† (λ ω' => L m l Ω ω') ω 1)
  rewrite_by
    simp

function_properties εrotate.arg_ω.diff (ε : ℝ) [Fact (ε≠0)] (ω dω x : ℝ^(3:ℕ)) : ℝ^(3:ℕ)
argument dω
  inv by simp[εrotate.arg_ω.diff]

def velocity (m : ℝ) (l : ℝ) (Ω ω' : ℝ^(3:ℕ)) : ℝ^(3:ℕ) :=
  ((λ ω => momentum m l Ω ω)⁻¹ ω')
  rewrite_by
    simp[momentum]
    simp[L.arg_ω.adjDiff]

def solver (m l : ℝ) (steps : Nat) : Impl (ode_solve (LagrangianSystem (L m l))) :=
by

  conv in (L _ _) =>
    simp [L, L', parm]
    { pattern (differential _); rmlamlet; enter [θ, ω]; simp }  -- autodiff

  simp -- Lagrangian is in a nice form now

  conv =>
    pattern (LagrangianSystem _); whnf

  simp

  --------------------- mass matrix ---------------------------------
  conv =>   -- autograd par1
    repeat' (enter [1]; pattern (gradient _))
    simp [gradient]
    pattern (differential _)
    rmlamlet
    repeat' (ext x);
    simp

  conv =>   -- autograd part2
    pattern (comp dual _)
    ext x; simp
    pattern (dual _)
    rmlamlet
    simp

  conv =>  -- autodiff
    repeat' enter [1]; pattern (differential _)
    rmlamlet
    repeat' (ext x)
    simp

  .

  ------- potential forces ----
  conv =>   -- autograd par1
    repeat' (enter [1]; pattern (gradient _))
    simp [gradient]
    pattern (differential _)
    rmlamlet
    repeat' (ext x);
    simp

  conv =>   -- autograd part2
    pattern (comp dual _)
    ext x; simp
    pattern (dual _)
    rmlamlet
    simp

  .

  ------- geometry forces ----
  conv =>  -- autodiff
    repeat' enter [1]; pattern (differential _)
    rmlamlet
    repeat' (ext x)
    simp

  conv =>   -- autograd par1
    repeat' (enter [1]; pattern (gradient _))
    simp [gradient]
    pattern (differential _)
    rmlamlet
    repeat' (ext x);
    simp

  conv =>   -- autograd part2
    pattern (comp dual _)
    ext x; simp
    pattern (dual _)
    rmlamlet
    simp

  .

  ------- TODO: invert ------

  ------- TODO: ode_solve --------

  admit


import data.nat.choose
import data.finset

import config
import etv

open_locale classical
noncomputable theory

namespace config

variables {α : Type*} [linear_order α] (C : config α)

lemma has_cap2_cup2 {S : finset α} (hS : 1 < S.card) :
  C.has_ncap 2 S ∧ C.has_ncup 2 S :=
begin
  set l := S.sort (≤) with eq_l,
  have hl : 2 ≤ l.length := by rw eq_l; simp; exact hS,
  rcases list.take_head2 hl with ⟨a, b, t, eq_ab⟩,
  have sorted := finset.sort_sorted_lt S, rw ←eq_l at sorted,
  have a_lt_b : a < b :=
    by rw eq_ab at sorted; simp at sorted; tauto,
  have a_in_S : a ∈ l := by rw eq_ab; simp,
  rw eq_l at a_in_S, simp at a_in_S,
  have b_in_S : b ∈ l := by rw eq_ab; simp,
  rw eq_l at b_in_S, simp at b_in_S,

  split,
  { use [[a, b]], simp [config.ncap], tauto },
  { use [[a, b]], simp [config.ncap], tauto },
end

theorem binom_eq (a b : ℕ) :
  (a + b + 2).choose (a + 1) =
  (a + b + 1).choose a + (a + b + 1).choose (a + 1) :=
rfl

theorem cap_cup (a b : ℕ)
  (S : finset α) (hS : nat.choose (a+b) a < S.card) :
  C.has_ncap (a+2) S ∨ C.has_ncup (b+2) S :=
begin
  revert a b S hS, refine nat.pincer_recursion _ _ _,
  -- case b = 0
  { simp, intros a S hS, right, exact (C.has_cap2_cup2 hS).right },
  -- case a = 0
  { simp, intros a S hS, left, exact (C.has_cap2_cup2 hS).left },
  -- diagonal induction
  { intros a b,
    repeat {rw a.succ_eq_add_one}, repeat {rw b.succ_eq_add_one},
    set sz_ab1 := (a + (b + 1)).choose a with eq_sz_ab1,
    set sz_a1b := ((a + 1) + b).choose (a + 1) with eq_sz_a1b,
    set sz_a1b1 := ((a + 1) + (b + 1)).choose (a + 1) with eq_sz_a1b1,
    have eq_sz : sz_a1b1 = sz_ab1 + sz_a1b :=
      by rw [eq_sz_ab1, eq_sz_a1b, eq_sz_a1b1]; ring_nf,
    -- numerical details now not relevant
    clear eq_sz_ab1 eq_sz_a1b eq_sz_a1b1,
    ring_nf, intros hab1 ha1b S hS,

    set is_start_of_cap : α → Prop :=
      λ p, ∃ c, C.cap c ∧ c.in S ∧ c.length = a + 2 ∧ p ∈ c.head'
      with def_is_start_of_cap,
    set T := finset.filter is_start_of_cap S with def_T,
    have eq_card : (S \ T).card + T.card = S.card := begin
      apply finset.card_sdiff_add_card_eq_card,
      rw def_T, exact S.filter_subset is_start_of_cap,
    end,
    have sz_cases : sz_ab1 < (S \ T).card ∨ sz_a1b < T.card :=
      by by_contra'; linarith,
    cases sz_cases,
    -- case sz_ab1 < (S \ T).card
    { cases hab1 (S \ T) sz_cases with hcap hcup,
      rcases hcap with ⟨c, ⟨c_cap, c_length⟩, c_in⟩,
      { have c_nnil : c ≠ [] :=
          by intro eq_c; subst eq_c; cases c_length,
        rcases list.take_head c_nnil with ⟨ch, ct, eq_c⟩,
        have h : ch ∈ S \ T := by apply c_in; rw eq_c; simp,
        rw def_T at h, simp at h, cases h with c_in_S h,
        have f := h c_in_S c c_cap _ c_length, rw eq_c at f, simp at f,
        exfalso, exact f,
        refine list.in_superset _ c_in, simp, },
      { right,
        exact has_ncup_supset (finset.sdiff_subset S T) hcup }, },
    -- case sz_a1b < T.card
    cases ha1b T sz_cases with hcap hcup,
    { left, refine has_ncap_supset _ hcap,
      rw def_T, simp, },
    { rcases hcup with ⟨cl, ⟨cl_cup, cl_length⟩, cl_in_T⟩,
      have cl_sz2 : 2 ≤ cl.length := by rw cl_length; simp,
      rcases list.take_last2 cl_sz2 with ⟨p, q, cl', eq_cl⟩, clear cl_sz2,
      have q_in_T : q ∈ T := by refine cl_in_T q _; rw eq_cl; simp,
      rw def_T at q_in_T; simp at q_in_T,
      cases q_in_T with q_in_S q_st, simp [def_is_start_of_cap] at q_st,
      rcases q_st with ⟨cr, cr_cap, cr_in_S, cr_length, cr_head⟩,
      have cr_sz2 : 2 ≤ cr.length := by rw cr_length; simp,
      rcases list.take_head2 cr_sz2 with ⟨q, r, cr', eq_cr⟩, clear cr_sz2,
      rw eq_cr at cr_head, simp at cr_head, subst cr_head,
      by_cases hpqr : C.cup3 p q r,
      { right, use cl ++ [r], refine ⟨⟨_, _⟩, _⟩,
        { rw eq_cl, simp, rw ←eq_cl,
          rw eq_cr at cr_cap, simp [config.cap] at cr_cap, tauto },
        { simp, rw cl_length },
        { simp, split,
          refine list.in_superset _ cl_in_T, rw def_T, simp,
          rw eq_cr at cr_in_S, simp at cr_in_S, tauto, }, },
      { left, use p :: cr, refine ⟨⟨_, _⟩, _⟩,
        { rw eq_cr, simp, rw ←eq_cr,
          rw eq_cl at cl_cup, simp [config.cup] at cl_cup, tauto },
        { simp, rw cr_length },
        { simp, rw eq_cl at cl_in_T, simp at cl_in_T, tauto, }, }, }, },
end

end config


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

import tactic.linarith.lemmas
import tactic.ring

/-!
# Datatypes for `linarith`

Some of the data structures here are used in multiple parts of the tactic.
We split them into their own file.

This file also contains a few convenient auxiliary functions.
-/

declare_trace linarith

open native

namespace linarith

/-- A shorthand for tracing when the `trace.linarith` option is set to true. -/
meta def linarith_trace {α} [has_to_tactic_format α] (s : α) : tactic unit :=
tactic.when_tracing `linarith (tactic.trace s)

/--
A shorthand for tracing the types of a list of proof terms
when the `trace.linarith` option is set to true.
-/
meta def linarith_trace_proofs (s : string := "") (l : list expr) : tactic unit :=
tactic.when_tracing `linarith $ do
  tactic.trace s, l.mmap tactic.infer_type >>= tactic.trace

/-! ### Linear expressions -/

/--
A linear expression is a list of pairs of variable indices and coefficients,
representing the sum of the products of each coefficient with its corresponding variable.

Some functions on `linexp` assume that `n : ℕ` occurs at most once as the first element of a pair,
and that the list is sorted in decreasing order of the first argument.
This is not enforced by the type but the operations here preserve it.
-/
@[reducible]
def linexp : Type := list (ℕ × ℤ)

namespace linexp
/--
Add two `linexp`s together componentwise.
Preserves sorting and uniqueness of the first argument.
-/
meta def add : linexp → linexp → linexp
| [] a := a
| a [] := a
| (a@(n1,z1)::t1) (b@(n2,z2)::t2) :=
  if n1 < n2 then b::add (a::t1) t2
  else if n2 < n1 then a::add t1 (b::t2)
  else let sum := z1 + z2 in if sum = 0 then add t1 t2 else (n1, sum)::add t1 t2

/-- `l.scale c` scales the values in `l` by `c` without modifying the order or keys. -/
def scale (c : ℤ) (l : linexp) : linexp :=
if c = 0 then []
else if c = 1 then l
else l.map $ λ ⟨n, z⟩, (n, z*c)

/--
`l.get n` returns the value in `l` associated with key `n`, if it exists, and `none` otherwise.
This function assumes that `l` is sorted in decreasing order of the first argument,
that is, it will return `none` as soon as it finds a key smaller than `n`.
-/
def get (n : ℕ) : linexp → option ℤ
| [] := none
| ((a, b)::t) :=
  if a < n then none
  else if a = n then some b
  else get t

/--
`l.contains n` is true iff `n` is the first element of a pair in `l`.
-/
def contains (n : ℕ) : linexp → bool := option.is_some ∘ get n

/--
`l.zfind n` returns the value associated with key `n` if there is one, and 0 otherwise.
-/
def zfind (n : ℕ) (l : linexp) : ℤ :=
match l.get n with
| none := 0
| some v := v
end

/-- `l.vars` returns the list of variables that occur in `l`. -/
def vars (l : linexp) : list ℕ :=
l.map prod.fst

/--
Defines a lex ordering on `linexp`. This function is performance critical.
-/
def cmp : linexp → linexp → ordering
| [] [] := ordering.eq
| [] _ := ordering.lt
| _ [] := ordering.gt
| ((n1,z1)::t1) ((n2,z2)::t2) :=
  if n1 < n2 then ordering.lt
  else if n2 < n1 then ordering.gt
  else if z1 < z2 then ordering.lt
  else if z2 < z1 then ordering.gt
  else cmp t1 t2

end linexp

/-! ### Inequalities -/

/-- The three-element type `ineq` is used to represent the strength of a comparison between
terms. -/
@[derive decidable_eq, derive inhabited]
inductive ineq : Type
| eq | le | lt

namespace ineq

/--
`max R1 R2` computes the strength of the sum of two inequalities. If `t1 R1 0` and `t2 R2 0`,
then `t1 + t2 (max R1 R2) 0`.
-/
def max : ineq → ineq → ineq
| lt a := lt
| a lt := lt
| le a := le
| a le := le
| eq eq := eq

/-- `ineq` is ordered `eq < le < lt`. -/
def cmp : ineq → ineq → ordering
| eq eq := ordering.eq
| eq _ := ordering.lt
| le le := ordering.eq
| le lt := ordering.lt
| lt lt := ordering.eq
| _ _ := ordering.gt

/-- Prints an `ineq` as the corresponding infix symbol. -/
def to_string : ineq → string
| eq := "="
| le := "≤"
| lt := "<"

/-- Finds the name of a multiplicative lemma corresponding to an inequality strength. -/
meta def to_const_mul_nm : ineq → name
| lt := ``mul_neg
| le := ``mul_nonpos
| eq := ``mul_eq

instance : has_to_string ineq := ⟨ineq.to_string⟩

meta instance : has_to_format ineq := ⟨λ i, ineq.to_string i⟩

end ineq

/-! ### Comparisons with 0 -/

/--
The main datatype for FM elimination.
Variables are represented by natural numbers, each of which has an integer coefficient.
Index 0 is reserved for constants, i.e. `coeffs.find 0` is the coefficient of 1.
The represented term is `coeffs.sum (λ ⟨k, v⟩, v * Var[k])`.
str determines the strength of the comparison -- is it < 0, ≤ 0, or = 0?
-/
@[derive inhabited]
structure comp : Type :=
(str : ineq)
(coeffs : linexp)

/-- `c.vars` returns the list of variables that appear in the linear expression contained in `c`. -/
def comp.vars : comp → list ℕ :=
linexp.vars ∘ comp.coeffs

/-- `comp.coeff_of c a` projects the coefficient of variable `a` out of `c`. -/
def comp.coeff_of (c : comp) (a : ℕ) : ℤ :=
c.coeffs.zfind a

/-- `comp.scale c n` scales the coefficients of `c` by `n`. -/
def comp.scale (c : comp) (n : ℕ) : comp :=
{ c with coeffs := c.coeffs.scale n }

/--
`comp.add c1 c2` adds the expressions represented by `c1` and `c2`.
The coefficient of variable `a` in `c1.add c2`
is the sum of the coefficients of `a` in `c1` and `c2`.
 -/
meta def comp.add (c1 c2 : comp) : comp :=
⟨c1.str.max c2.str, c1.coeffs.add c2.coeffs⟩

/-- `comp` has a lex order. First the `ineq`s are compared, then the `coeff`s. -/
meta def comp.cmp : comp → comp → ordering
| ⟨str1, coeffs1⟩ ⟨str2, coeffs2⟩ :=
  match str1.cmp str2 with
  | ordering.lt := ordering.lt
  | ordering.gt := ordering.gt
  | ordering.eq := coeffs1.cmp coeffs2
  end

/--
A `comp` represents a contradiction if its expression has no coefficients and its strength is <,
that is, it represents the fact `0 < 0`.
 -/
meta def comp.is_contr (c : comp) : bool := c.coeffs.empty ∧ c.str = ineq.lt

meta instance comp.to_format : has_to_format comp :=
⟨λ p, to_fmt p.coeffs ++ to_string p.str ++ "0"⟩

/-! ### Parsing into linear form -/

/-! ### Control -/

/--
A preprocessor transforms a proof of a proposition into a proof of a different propositon.
The return type is `list expr`, since some preprocessing steps may create multiple new hypotheses,
and some may remove a hypothesis from the list.
A "no-op" preprocessor should return its input as a singleton list.
-/
meta structure preprocessor : Type :=
(name : string)
(transform : expr → tactic (list expr))

/--
Some preprocessors need to examine the full list of hypotheses instead of working item by item.
As with `preprocessor`, the input to a `global_preprocessor` is replaced by, not added to, its
output.
-/
meta structure global_preprocessor : Type :=
(name : string)
(transform : list expr → tactic (list expr))

/--
Some preprocessors perform branching case splits. A `branch` is used to track one of these case
splits. The first component, an `expr`, is the goal corresponding to this branch of the split,
given as a metavariable. The `list expr` component is the list of hypotheses for `linarith`
in this branch. Every `expr` in this list should be type correct in the context of the associated
goal.
-/
meta def branch : Type := expr × list expr

/--
Some preprocessors perform branching case splits.
A `global_branching_preprocessor` produces a list of branches to run.
Each branch is independent, so hypotheses that appear in multiple branches should be duplicated.
The preprocessor is responsible for making sure that each branch contains the correct goal
metavariable.
-/
meta structure global_branching_preprocessor : Type :=
(name : string)
(transform : list expr → tactic (list branch))

/--
A `preprocessor` lifts to a `global_preprocessor` by folding it over the input list.
-/
meta def preprocessor.globalize (pp : preprocessor) : global_preprocessor :=
{ name := pp.name,
  transform := list.mfoldl (λ ret e, do l' ← pp.transform e, return (l' ++ ret)) [] }

/--
A `global_preprocessor` lifts to a `global_branching_preprocessor` by producing only one branch.
-/
meta def global_preprocessor.branching (pp : global_preprocessor) : global_branching_preprocessor :=
{ name := pp.name,
  transform := λ l, do g ← tactic.get_goal, singleton <$> prod.mk g <$> pp.transform l }

/--
`process pp l` runs `pp.transform` on `l` and returns the result,
tracing the result if `trace.linarith` is on.
-/
meta def global_branching_preprocessor.process (pp : global_branching_preprocessor)
  (l : list expr) :
  tactic (list branch) :=
do l ← pp.transform l,
   when (l.length > 1) $
     linarith_trace format!"Preprocessing: {pp.name} has branched, with branches:",
   l.mmap' $ λ l, tactic.set_goals [l.1] >>
     linarith_trace_proofs (to_string format!"Preprocessing: {pp.name}") l.2,
   return l

meta instance preprocessor_to_gb_preprocessor :
  has_coe preprocessor global_branching_preprocessor :=
⟨global_preprocessor.branching ∘ preprocessor.globalize⟩

meta instance global_preprocessor_to_gb_preprocessor :
  has_coe global_preprocessor global_branching_preprocessor :=
⟨global_preprocessor.branching⟩

/--
A `certificate_oracle` is a function `produce_certificate : list comp → ℕ → tactic (rb_map ℕ ℕ)`.
`produce_certificate hyps max_var` tries to derive a contradiction from the comparisons in `hyps`
by eliminating all variables ≤ `max_var`.
If successful, it returns a map `coeff : ℕ → ℕ` as a certificate.
This map represents that we can find a contradiction by taking the sum  `∑ (coeff i) * hyps[i]`.

The default `certificate_oracle` used by `linarith` is
`linarith.fourier_motzkin.produce_certificate`.
-/
meta def certificate_oracle : Type :=
list comp → ℕ → tactic (rb_map ℕ ℕ)

/-- A configuration object for `linarith`. -/
meta structure linarith_config : Type :=
(discharger : tactic unit := `[ring])
(restrict_type : option Type := none)
(restrict_type_reflect : reflected _ restrict_type . tactic.apply_instance)
(exfalso : bool := tt)
(transparency : tactic.transparency := reducible)
(split_hypotheses : bool := tt)
(split_ne : bool := ff)
(preprocessors : option (list global_branching_preprocessor) := none)
(oracle : option certificate_oracle := none)

/--
`cfg.update_reducibility reduce_semi` will change the transparency setting of `cfg` to
`semireducible` if `reduce_semi` is true. In this case, it also sets the discharger to `ring!`,
since this is typically needed when using stronger unification.
-/
meta def linarith_config.update_reducibility (cfg : linarith_config) (reduce_semi : bool) :
  linarith_config :=
if reduce_semi then { cfg with transparency := semireducible, discharger := `[ring!] }
else cfg

/-!
### Auxiliary functions

These functions are used by multiple modules, so we put them here for accessibility.
-/

open tactic

/--
`get_rel_sides e` returns the left and right hand sides of `e` if `e` is a comparison,
and fails otherwise.
This function is more naturally in the `option` monad, but it is convenient to put in `tactic`
for compositionality.
 -/
meta def get_rel_sides : expr → tactic (expr × expr)
| `(%%a < %%b) := return (a, b)
| `(%%a ≤ %%b) := return (a, b)
| `(%%a = %%b) := return (a, b)
| `(%%a ≥ %%b) := return (a, b)
| `(%%a > %%b) := return (a, b)
| _ := tactic.failed

/--
`parse_into_comp_and_expr e` checks if `e` is of the form `t < 0`, `t ≤ 0`, or `t = 0`.
If it is, it returns the comparison along with `t`.
 -/
meta def parse_into_comp_and_expr : expr → option (ineq × expr)
| `(%%e < 0) := (ineq.lt, e)
| `(%%e ≤ 0) := (ineq.le, e)
| `(%%e = 0) := (ineq.eq, e)
| _ := none

/--
`mk_single_comp_zero_pf c h` assumes that `h` is a proof of `t R 0`.
It produces a pair `(R', h')`, where `h'` is a proof of `c*t R' 0`.
Typically `R` and `R'` will be the same, except when `c = 0`, in which case `R'` is `=`.
If `c = 1`, `h'` is the same as `h` -- specifically, it does *not* change the type to `1*t R 0`.
-/
meta def mk_single_comp_zero_pf (c : ℕ) (h : expr) : tactic (ineq × expr) :=
do tp ← infer_type h,
  some (iq, e) ← return $ parse_into_comp_and_expr tp,
  if c = 0 then
    do e' ← mk_app ``zero_mul [e], return (ineq.eq, e')
  else if c = 1 then return (iq, h)
  else
    do tp ← (prod.snd <$> (infer_type h >>= get_rel_sides)) >>= infer_type,
       c ← tp.of_nat c,
       cpos ← to_expr ``(%%c > 0),
       (_, ex) ← solve_aux cpos `[norm_num, done],
       e' ← mk_app iq.to_const_mul_nm [h, ex],
       return (iq, e')

end linarith


/-
Copyright (c) 2018 Bruno Bentzen. All rights reserved.
Released under the Apache License 2.0 (see "License");
Author: Bruno Bentzen
-/

import .soundness

open prf classical

variables {σ : nat}

def is_consist (Γ : ctx σ) := Γ ⊬ₛ₅ ⊥

lemma consist_not_of_not_prf {Γ : ctx σ} {p : form σ} :
  (Γ ⊬ₛ₅ p) → is_consist (Γ ⸴ ~p) :=
λ hnp hc, hnp (mp dne (deduction hc))

lemma not_prf_of_consist_not {Γ : ctx σ} {p : form σ} :
  is_consist (Γ ⸴ ~p) → (Γ ⊬ₛ₅ p) :=
λ h c, h (conv_deduction (prf.mp prf.dni c))

/- other notable properties of consistency -/

lemma consist_of_not_prf {Γ : ctx σ} {p : form σ} :
  (Γ ⊬ₛ₅ p) → is_consist Γ :=
λ nhp nc, nhp (ex_falso nc)

lemma inconsist_to_neg_consist {Γ : ctx σ} {p : form σ} :
  is_consist Γ → ¬is_consist (Γ ⸴ p) → is_consist (Γ ⸴ ~p) :=
begin
  intros c nc hp, apply c, apply mp,
    apply deduction, apply by_contradiction nc,
    apply mp dne, exact (deduction hp),
end

lemma inconsist_of_neg_to_consist {Γ : ctx σ} {p : form σ} :
  is_consist Γ → ¬is_consist (Γ ⸴ ~p) → is_consist (Γ ⸴ p) :=
begin
  intros c nc hp, apply c, apply mp,
  { apply deduction (by_contradiction nc) },
  { exact deduction hp },
end

lemma consist_fst {Γ : ctx σ} {p : form σ} :
  is_consist (Γ ⸴ p) → is_consist Γ :=
λ hc hn, hc (weak hn)

/- consistent context extensions -/

lemma consist_ext {Γ : ctx σ} {p : form σ} :
  is_consist Γ → (Γ ⊬ₛ₅ ~p) → is_consist (Γ ⸴ p) :=
by intros c np hn; apply np (deduction hn)

lemma inconsist_ext_to_inconsist {Γ : ctx σ} {p : form σ} :
    ((¬is_consist (Γ ⸴ p)) ∧ ¬is_consist(Γ ⸴ ~p)) → ¬is_consist (Γ) :=
begin
  intros h nc, cases h,
  have h₁ : ((Γ ⸴ p) ⊢ₛ₅ ⊥) := by_contradiction h_left,
  have h₂ : ((Γ ⸴ ~p) ⊢ₛ₅ ⊥) := by_contradiction h_right,
  apply nc, apply mp (deduction h₁),
    apply mp dne (deduction h₂)
end

lemma consist_to_consist_ext {Γ : ctx σ} {p : form σ} :
    is_consist (Γ) → (is_consist (Γ ⸴ p) ∨ is_consist (Γ ⸴ ~p)) :=
begin
  intro c, apply classical.by_contradiction, intro h,
  apply absurd c, apply inconsist_ext_to_inconsist,
  apply (decidable.not_or_iff_and_not _ _).1, apply h,
  repeat {apply (prop_decidable _)}
end

lemma pos_consist_mem {Γ : ctx σ} {p : form σ} :
  p ∈ Γ → is_consist (Γ) → (~p) ∉ Γ :=
λ hp hc hnp, hc (mp (ax hnp) (ax hp))

lemma neg_consist_mem {Γ : ctx σ} {p : form σ} :
  (~p) ∈ Γ → is_consist (Γ) → p ∉ Γ :=
λ hnp hc hp, hc (mp (ax hnp) (ax hp))

lemma pos_inconsist_ext {Γ : ctx σ} {p : form σ} (c : is_consist Γ) :
  p ∈ Γ → ¬is_consist (Γ ⸴ p) → (~p) ∈ Γ :=
begin
  intros hp hn,
  exfalso, apply c,
  apply mp, apply deduction (by_contradiction hn),
  apply ax hp
end

lemma neg_inconsist_ext {Γ : ctx σ} {p : form σ} (c : is_consist Γ) :
  (~p) ∈ Γ → ¬is_consist (Γ ⸴ ~p) → p ∈ Γ :=
begin
  intros hp hn,
  exfalso, apply c,
  apply mp, apply deduction (by_contradiction hn),
  apply ax hp
end

/- context extensions of subcontexts -/

lemma sub_preserves_consist {Γ Δ : ctx σ} :
  is_consist Γ → is_consist Δ → Δ ⊆ Γ → is_consist (Γ ⊔ Δ) :=
by intros c1 c2 s nc; apply c1; exact (subctx_contr s nc)

lemma subctx_inherits_consist {Γ Δ : ctx σ} {p : form σ} :
  is_consist Γ → is_consist Δ → Γ ⊆ Δ → is_consist (Δ ⸴ p) → is_consist (Γ ⸴ p) :=
by intros c1 c2 s c nc; apply c; apply conv_deduction; apply subctx_ax s (deduction nc)

lemma inconsist_sub {Γ Δ : ctx σ} {p : form σ} (c : is_consist Γ) :
  ¬is_consist (Δ ⸴ p) → Δ ⊆ Γ → ¬is_consist (Γ ⸴ p) :=
begin
  unfold is_consist, intros h s c, apply c,
  apply subctx_ax, apply set.insert_subset_insert s,
  apply classical.by_contradiction h
end

/- contradictions & interpretations -/

lemma tt_to_const {Γ : ctx σ} {M : model} {w ∈ M.wrlds} :
  (w ⊩⦃M⦄ Γ) = tt → is_consist Γ :=
begin
  intros h hin,
  cases (sndnss hin),
  apply bot_is_insatisf,
  apply exists.intro,
  refine (m M w _ h),
  repeat {assumption},
end


import combinatorics.simple_graph.coloring

--OUTPUT 1
theorem bipartite_iff_two_colorable {V : Type*} (G : simple_graph V) [fintype V] : (G.colorable 2) ↔ (∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B)) :=
begin
    split, --To Prove: colorable 2 <-> exists A B h : (A ⊕ B) = V, G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B) : Prop,
    --Towards the first implication
    intro H,
    --H : ∃f : V → fin 2, ∀x y, x ≠ y → (f x = 0 ∧ f y = 1) ∨ (f x = 1 ∧ f y = 0)
    cases H with f H,
    use (A : Type*) (B : Type*) (h : (A ⊕ B) = V) (a : A) (b : B) (e : a ≠ b),
    rw subtype.mk_coe_fn_mk_eq_mk,
    have h1 : a.1 ≠ b.1, from subtype.ne.mp e,
    have h2 :  f a.1 = 0 ∧ f b.1 = 1, from (H a.1 b.1 h1).left,
    have h3 :  f a.1 = 1 ∧ f b.1 = 0, from (H a.1 b.1 h1).right,
    cases h2.left with H1,
    {rw [H1, h2.right]},
    cases h3.left with H2,
    {rw [H2, h3.right]},

    --Towards the second implication
    intro H0,
    cases H0 with A B h H0,
    have K0 : G ≤ complete_graph (V), from complete_graph_closure (cast (congr_arg _ h) H0),
    have K1 : fintype (V), from set.fintype_of_fintype (finset.univ : finset V),
    --Need an isomorphism that preserves the colorability property
    let t : V → fin 2 := λ x, (match (x : A) with
    | ⟨x, h1⟩ := 0
    end : fin 2),
    use t,
    intro x, assume y, assume H1,
    cases x with x h1,
    cases y with y h2,
    rw fin.eq_iff_veq at H1,
    cases H1,
    exfalso,
    suffices : x = y, from this,
    apply setoid.to_eq,
    rw [h1, h2],
    have K2 : fintype A, from set.fintype_of_fintype (finset.univ : finset A),
    have K3 : fintype B, from set.fintype_of_fintype (finset.univ : finset B),
    have K4 : fintype (A ⊕ B), from fintype.sum K2 K3,
    rw [← fin.coe_sum_eq_sum, ← fin.coe_sum_eq_sum, ← set.card_sum K2 K3, ← set.card_sum K0 K1 ]
end

--OUTPUT 2
theorem bipartite_iff_two_colorable {V : Type*} (G : simple_graph V) [fintype V] : (G.colorable 2) ↔ (∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B)) := ⟨begin
  assume h_c,
  let h_col : (∃ (A B : set V) (h : (A ⊕ B) = V),
    ∀ (a b : V), (a,b) ∈ G.e ↔ a ∈ A ∧ b ∈ B ∨ a ∈ B ∧ b ∈ A), from ⟨_, _, _, begin
      assume a b,
      have h1 : (a,b) ∈ G.e ↔ ¬(a ∈ A ∧ b ∈ A) ∧ ¬(b ∈ B ∧ a ∈ B), from begin
        rw ← not_iff_not_of_iff,
        suffices : (a,b) ∈ G.e ↔ ¬((a,b) ∉ G.e),
          rw disjoint_iff_not_mem_of_disjoint_union,
          rw ← this,
          rw ← not_iff_not_of_iff,
          rw ← h_c.2 a b,
        rw ← not_iff_not_of_iff,
        exact iff_refl _,
      end,
      split,
      assume h3,
      rw (h1 h3).2.2,
      rw (h1 h3).1.1,
    end⟩,
  let A := h_col.1,
  let B := h_col.2,
  let h : (A ⊕ B) = V := h_col.3,
  let G_cp : (complete_bipartite_graph A B), from (⟨_, begin
    assume a b,
    rw [h_col.4 a b, mem_Union],
    rw mem_Union,
    split,
    exact ⟨_, rfl⟩,
    exact ⟨_, rfl⟩,
  end⟩ : simple_graph (A ⊕ B)),
  exact ⟨_, _, _, by rw eq_cast_iff_eq_cast h ; exact G_cp⟩,
end

--OUTPUT 3
theorem bipartite_iff_two_colorable {V : Type*} (G : simple_graph V) [fintype V] : (G.colorable 2) ↔ (∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B)) :=
begin
 assume h1 : G.colorable 2,
 let ⟨f, hf⟩ := h1,
 let A := f.preimage (λx, x = 1),
 let B := f.preimage (λx, x = 0),
 let ha : (∀ a ∈ A, ∀ b ∈ B, G.adj a b) :=
 begin
  assume a ha ⟨b, hb, hb1⟩,
  from have h : (f a ≠ f b), from hf a ha b hb,
  have h2 : (f a = 0 ∨ f a = 1), from nat.eq_zero_or_eq_one_of_ne_zero (assume h3 : f a = 0, h h3),
  or.elim h2
  (assume h4 : f a = 0, have h4' : (f a = 0 ∧ f b = 1), from and.intro (eq.symm h4) hb1, by contradiction)
  (assume h4 : f a = 1, have h4' : (f a = 1 ∧ f b = 0), from and.intro (eq.symm h4) hb1, by contradiction)
 end,
 let hb : (∀ a ∈ A, ∀ b ∈ B, G.adj b a) :=
 begin
  assume a ha ⟨b, hb, hb1⟩,
  from have h : (f a ≠ f b), from hf b hb a ha,
  have h2 : (f a = 0 ∨ f a = 1), from nat.eq_zero_or_eq_one_of_ne_zero (assume h3 : f a = 0, h h3),
  or.elim h2
  (assume h4 : f a = 0, have h4' : (f a = 0 ∧ f b = 1), from and.intro (eq.symm h4) hb1, by contradiction)
  (assume h4 : f a = 1, have h4' : (f a = 1 ∧ f b = 0), from and.intro (eq.symm h4) hb1, by contradiction)
 end,
 let hc : (∀ a ∈ A, ∀ a' ∈ A, ~ G.adj a a') :=
 begin
  assume a ha a' ha',
  have h1 : (f a = f a'), from by {have h2 : (f a ≠ f a'), from assume h3 : f a = f a', hf a ha a' ha' h3, have h4 : (f a = 0 ∨ f a = 1) ∧ (f a' = 0 ∨ f a' = 1), from and.intro (nat.eq_zero_or_eq_one_of_ne_zero (assume h5 : f a = 0, h2 h5)) (nat.eq_zero_or_eq_one_of_ne_zero (assume h5 : f a' = 0, h2 h5)), or.elim (and.right h4) (λ h6, or.elim (and.left h4) (λ h7, have (f a = 0 ∧ f a' = 0), from and.intro h7 h6, by contradiction)) (λ h6, or.elim (and.left h4) (λ h7, have (f a = 1 ∧ f a' = 1), from and.intro h7 h6, by contradiction))},
  suffices : (a = a'), from begin dsimp at h1,
  have h1' : (f a = 1 ∧ f a' = 1), from (have h1' : (f a = 1), by {dsimp at h1, assumption}, have h1'' : (f a' = 1), from (eq.symm h1), have h1''' : (f a = f a'), from eq.trans h1' h1'', by {have h2 : (f a ≠ f a'), from assume h3 : f a = f a', hf a ha a' ha' h3, have h4 : (f a = 0 ∨ f a = 1) ∧ (f a' = 0 ∨ f a' = 1), from and.intro (nat.eq_zero_or_eq_one_of_ne_zero (assume h5 : f a = 0, h2 h5)) (nat.eq_zero_or_eq_one_of_ne_zero (assume h5 : f a' = 0, h2 h5)), or.elim (and.right h4) (λ h6, or.elim (and.left h4) (λ h7, have (f a = 0 ∧ f a' = 0), from and.intro h7 h6, by contradiction)) (λ h6, or.elim (and.left h4) (λ h7, have (f a = 1 ∧ f a' = 1), from and.intro h7 h6, by contradiction)))}),
  have h1'' : (f a = 1 ∨ f a = 0), from (nat.eq_zero_or_eq_one_of_ne_zero (assume h2 : f a = 0, by {have h3 : (f a = 0 ∧ f a' = 1), from and.intro h2 (and.right h1'), have h4 : (f a ≠ f a'), from hf a ha a' ha' (eq.trans h2 (eq.symm h1')), have h5 : (f a = 0 ∨ f a = 1) ∧ (f a' = 0 ∨ f a' = 1), from and.intro (nat.eq_zero_or_eq_one_of_ne_zero (assume h6 : f a = 0, h4 h6)) (nat.eq_zero_or_eq_one_of_ne_zero (assume h6 : f a' = 0, h4 h6)), or.elim (and.right h5) (λ h6, or.elim (and.left h5) (λ h7, have (f a = 0 ∧ f a' = 0), from and.intro h7 h6, by contradiction)) (λ h6, or.elim (and.left h5) (λ h7, have (f a = 1 ∧ f a' = 1), from and.intro h7 h6, by contradiction)))}), or.elim (nat.eq_zero_or_eq_one_of_ne_zero (assume h2 : f a' = 0, by {have h3 : (f a = 1 ∧ f a' = 0), from and.intro (and.left h1') h2, have h4 : (f a ≠ f a'), from hf a ha a' ha' (eq.trans (eq.symm h1') h2), have h5 : (f a = 0 ∨ f a = 1) ∧ (f a' = 0 ∨ f a' = 1), from and.intro (nat.eq_zero_or_eq_one_of_ne_zero (assume h6 : f a = 0, h4 h6)) (nat.eq_zero_or_eq_one_of_ne_zero (assume h6 : f a' = 0, h4 h6)), or.elim (and.right h5) (λ h6, or.elim (and.left h5) (λ h7, have (f a = 0 ∧ f a' = 0), from and.intro h7 h6, by contradiction)) (λ h6, or.elim (and.left h5) (λ h7, have (f a = 1 ∧ f a' = 1), from and.intro h7 h6, by contradiction)))}))),
  or.elim h1'' (λ h1''', have h : (f a = 1 ∧ f a = 1), from and.intro h1''' h1', by contradiction) (λ h1''', have h : (f a = 0 ∧ f a = 1), from and.intro h1''' h1', by contradiction)},
  from eq.trans (eq.symm (hf a ha a ha')) h1
 end,
 let hd : (∀ a ∈ B, ∀ a' ∈ B, ~ G.adj a a') :=
 begin
  assume a hb a
end --Needs more than 2000 tokens!

--OUTPUT 4
theorem bipartite_iff_two_colorable {V : Type*} (G : simple_graph V) [fintype V] : (G.colorable 2) ↔ (∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B)) :=
begin
  have h1 : ∀ (w : V) (U : Type*) (h1 : (V ⊕ U) = V), (w ∈ (cast (congr_arg _ h1) (complete_bipartite_graph V U))) ∨ (w ∉ (cast (congr_arg _ h1) (complete_bipartite_graph V U))), from assume w U h1, or.inr (ne.symm (by {obviously})),
  have h2 : ∀ (w : V) (A B : Type*) (h1 : (A ⊕ B) = V), (w ∈ (cast (congr_arg _ h1) (complete_bipartite_graph A B))) ∨ (w ∉ (cast (congr_arg _ h1) (complete_bipartite_graph A B))), from assume w A B h1, or.inr (ne.symm (by {obviously})),
  have h3 : ∀ (U : Type*) (h1 : (V ⊕ U) = V), (1 ≤ (cast (congr_arg _ h1) (complete_bipartite_graph V U))), from assume U h1, by obviously,
  have h4 : ∀ (A B : Type*) (h1 : (A ⊕ B) = V), (1 ≤ (cast (congr_arg _ h1) (complete_bipartite_graph A B))), from assume A B h1, by obviously,
  split,
    assume hcolor, exists.elim (G.perfect_marking_2 hcolor) (λ W hW, exists.elim hW (λ hW1 hW2,
    have h5 : ∀ (w : V), (w ∈ W ∧ w ∈ W) → ((w ∈ W ∧ w ∈ W) ∧ (w ∈ W ∧ w ∈ W)), from assume w hw, ⟨hw,hw⟩,
    have h6 : ∀ (a b : V) (h1 : a ∈ W), ∀ (h2 : b ∈ W), (a ≠ b) → (W.filter (λ w, ¬ ((w = a) ∨ (w = b))) ≠ ∅), from assume a b h1 h2 hab,
      have h7 : ∀ (w : V), (w ∈ W ∧ w ∉ W) ∨ ((w ∉ W) ∧ (w ∉ W)) ∨ (w ∈ W ∧ w ∈ W), from assume w, or.inr (or.inr (by {obviously})),
      have h8 : ∀ (w : V), (w = a ∨ w = b) → (¬ (w ∈ W ∧ w ∈ W)), from assume w,
        assume h9, have h10 : w ∈ W, from h5 w (and.left h9), h7 w,

      have h9 : ∀ (w : V), (w = a ∨ w = b) → (¬ (w ∈ W ∧ w ∈ W)), from assume w,
        assume h9, have h10 : w ∈ W, from h5 w (and.right h9), h7 w,

      have h10 : ∀ (w : V), w ∈ W → (w = a ∨ w = b), from assume w hw,
        obtain (h11 : (w ∈ W ∧ w ∈ W)) (h12 : (¬ (w = a ∨ w = b))), from (hW1 w).elim hw,
        have h13 : (w ∈ W ∧ w ∈ W), from and.right (h5 w h11), h7 w,
      have h11 : ∀ (w : V), w ∈ W → (w = a ∨ w = b), from assume w hw,
        obtain (h11 : (w ∈ W ∧ w ∉ W)) (h12 : (¬ (w = a ∨ w = b))), from (hW1 w).elim hw,
        have h13 : (w ∉ W ∧ w ∉ W), from and.right (h7 w), h7 w,
      have h12 : set.finite W, from fintype.of_finset (set.to_finset W),
      let h13 := (set.finite.equiv_univ W).symm.trans (set.filter.univ),
      have h14 : set.filter (λ (w : V), ¬ (w = a ∨ w = b)) W = univ, from set.filter_eq_univ (assume (w : V), assume h15 : (λ (w : V), ¬ (w = a ∨ w = b)) w,
        obtain (h16 : (w ∈ W ∧ w ∈ W)) (h17 : (¬ (w = a ∨ w = b))), from ⟨and.left h15,and.right h15⟩,
        have h18 : w ∈ W, from and.left h16,
        have h19 : (w = a ∨ w = b), from h10 w h18, absurd h19 h17),
      have h15 : set.filter (λ (w : V), ¬ (w = a ∨ w = b)) W = univ, from set.filter_eq_univ (assume (w : V), assume h15 : (λ (w : V), ¬ (w = a ∨ w = b)) w,
        obtain (h16 : (w ∈ W ∧ w ∉ W)) (h17 : (¬ (w = a ∨ w = b))), from ⟨and.left h15,and.right h15⟩,
        have h18 : w ∈ W, from and.left h16,
        have h19 : w = a ∨ w = b, from h11 w h18, absurd h19 h17),

      have h16 : set.filter (λ (w : V), ¬ (w = a ∨ w = b)) W = univ, from set.ext (assume x,
        iff.intro

          (assume h17, have h18 : x ∈ (λ (w : V), ¬ (w = a ∨ w = b)) w, from h17,
            h13 h18)
          (assume h18, h13.elim h18)
      ),
      have h17 : set.filter (λ (w : V), ¬ (w = a ∨ w = b)) W ≠ ∅, from set.ne_empty_of_mem hW2,
      have h18 : ∃ (w : V), (w ∈ W ∧ w ∈ W), from by {
        have h19 : set.finite (set.filter (λ (w : V), ¬ (w = a ∨ w = b)) W), from
          have h19 : set.finite W, from fintype.of_finset (set.to_finset W),
          show set.finite (set.filter (λ (w : V), ¬ (w = a ∨ w = b)) W), from set.finite.of_finite_image h19
            (λ (w : V), ¬ (w = a ∨ w = b)) (λ (w : V), (λ (x : V), ¬ (w = a ∨ w = b)) x) h16,
        have h20 : (set.filter (λ (w : V), ¬ (w = a ∨ w = b)) W) ≠ ∅, from h17,
        let h21 := (set.finite.not_empty h19 h20).elim,
        show ∃ (w : V), (w ∈ W ∧ w ∈ W), from exists.elim h21 (λ x hx,
          have h22 : x ∈ W, from hx,
          have h23 : x ∈ W, from hx,
          ⟨h22,h23⟩),
      },
      let h19 := set.finite.not_empty h12 (or.inl h18),
      have h20 : (W.filter (λ (w : V), ¬ w = a ∧ ¬ w = b)) ≠ ∅, from h19.elim (λ x
end --Needs more than 2000 tokens!

--OUTPUT 5
theorem bipartite_iff_two_colorable {V : Type*} (G : simple_graph V) [fintype V] : (G.colorable 2) ↔ (∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B)) :=
begin
  split,
  assume (h1 : G.colorable 2),
  have h2 : ∃ (A : set V), ∀ (x : G.V), x ∈ A ∨ x ∉ A, from by {
    use G.arrow red,
    assume (x : V),
    cases  classical.em (G.arrow red x) with h3 h3,
      use or.inl h3,
      use or.inr (not_not.mpr h3),
  },
  have h3 : ∃ (A : set V), ∀ (x : G.V), x ∈ A ∨ ¬ (x ∈ A), from
    (exists_congr $ λ A, forall_congr $ λ x, forall_congr $ λ h, or_congr not_not_if h),
  have h4 : ∃ (A : set V), ∀ (x : G.V), (x ∈ A) ∨ (x ∉ A), from by {
    have h5 := exists_prop (h2),
    have h6 := exists_prop (h3),
    from exists_prop (exists_congr (λ A, forall_congr (λ x, forall_congr (λ h, or_congr not_not_if h)) (h5) (h6))),
  },
  have h5 : ∃ (A : set V), (A = (G.arrow red)) ∨ (A = (G.arrow blue)), from by {
    cases h4 with A h4,
    have h5 : ∀ x, ¬ (x ∈ A), from by {
      assume x,
      assume h6 : x ∈ A,
      have h7 : x ∈ (G.arrow red) ∨ x ∈ (G.arrow blue), from by {
        show x ∈ A ∨ x ∉ A, from (h4 x).resolve_right (not.mpr h6),
      },
      have h8 : ¬ (x ∈ (G.arrow red) ∧ x ∈ (G.arrow blue)), from by {
        assume h9 : x ∈ (G.arrow red) ∧ x ∈ (G.arrow blue),
        show false, from G.no_monochromatic_edge h9.left h9.right,
      },
      show false, from or_iff_not_imp_left.mpr h8 h7,
    },
    have h6 : ∀ x, (x ∈ A) = (x ∈ (G.arrow red)), from by {
      assume x,
      apply propext,
      show iff (x ∈ A) ((x ∈ (G.arrow red))), from iff.intro (
        assume h6 : x ∈ A,
        show x ∈ (G.arrow red), from by {
          have h7 : (x ∈ A) ∨ (¬ (x ∈ A)), from (h4 x),
          cases h7 with h7 h7,
            show x ∈ (G.arrow red), from h7,
            have h8 : x ∈ (G.arrow red) ∨ x ∈ (G.arrow blue) := (h4 x).resolve_right h7,
            cases h8 with h9 h8,
              exact h9,
              have h10 : x ∈ (G.arrow red) ∧ x ∈ (G.arrow blue), from and.intro h9 h8,
              show false, from G.no_monochromatic_edge h9 h8,
      }
      ) (begin
        assume h6 : x ∈ (G.arrow red),
        show x ∈ A, from by {
          have h7 : x ∉ A := h5 x,
          show x ∈ A, from (h4 x).resolve_left h6 h7,
        end
      end),
    },
    have h6a : (G.arrow red) ⊆ A, from by {
      assume x,
      assume h6 : x ∈ (G.arrow red),
      show x ∈ A, from by {
        have h7 : x ∈ A := h6a x h6,
        exact h7,
      }
    },
    have h6b : A ⊆ (G.arrow red), from by {
      assume x,
      assume h6 : x ∈ A,
      show x ∈ (G.arrow red), from by {
        have h7 : x ∈ (G.arrow red) := h6a x h6,
        exact h7,
      }
    },
    have h7 : A = (G.arrow red), from set.eq_of_subset_of_subset h6a h6b,
    have h8 : ∀ x, (x ∈ A) = (x ∈ (G.arrow blue)), from by {
      assume x,
      apply propext,
      show iff (x ∈ A) ((x ∈ (G.arrow blue))), from iff.intro (
        assume h6 : x ∈ A,
        show x ∈ (G.arrow blue), from by {
          have h7 : (x ∈ A) ∨ (¬ (x ∈ A)), from (h4 x),
          cases h7 with h7 h7,
            have h8 : x ∈ (G.arrow red) ∨ x ∈ (G.arrow blue) := (h4 x).resolve_left h7,
            cases h8 with h8 h9,
              have h10 : x ∈ (G.arrow red) ∧ x ∈ (G.arrow blue), from and.intro h8 h9,
              show false, from G.no_monochromatic_edge h8 h9,
              exact h9,
            have h8 : x ∉ (G.arrow red), from by {
              assume h9 : x ∈ (G.arrow red),
              show false, from G.no_monochromatic_edge h9 h7,
            },
            show x ∈ (G.arrow blue), from by {
              have h9 : x ∈ (G.arrow blue), from (h4 x).resolve_right h7 h8,
              exact h9,
            }
      }
      ) (begin
        assume h6 : x ∈ (G.arrow blue),
        show x ∈ A, from by {
          have h7 : x ∉ A := h5 x,
          have h8 : x ∉ (G.arrow red), from by {
            assume h9 : x ∈ (G.arrow red),
            show false, from G.no_monochromatic_edge h9 h6,
          },
          have h9 : x ∈ A, from (h4 x).resolve_right h8 h6,
          have h10 : false, from G.no_monochromatic_edge h9 h6,
          show x ∈ A, from h10
        end
      end),
    },
    have h8a : (G.arrow blue) ⊆ A, from by {
      assume x,
      assume h8 : x ∈ (G.arrow blue),
      show x ∈ A, from by {
        have h9 : x ∈ A := h8a x h8,
        exact h9,
      }
    },
    have h8b : A ⊆ (G.arrow blue), from by {
      assume x,
      assume h8 : x ∈ A,
      show x ∈ (G.arrow blue), from by {
        have h9 : x ∈ (G.arrow blue) := h8a x h8,
        exact h9,
      }
    },
    have h9 : A = (G.arrow blue), from set.eq_of_subset_of_subset h8a h8b,
    have h10 : (G.arrow red) ∪ (G.arrow blue) = V, from by {
      have h11 : (G.arrow red) ∪ (G.arrow blue) ⊆ V, from by {
        assume x,
        assume h12 : x ∈ (G.arrow red) ∨ x ∈ (G.arrow blue),
        show x ∈ V, from by {
          cases h12 with h13 h13,
            show x ∈ V, from G.vertex_set
end --Needs more than 2000 tokens!

--OUTPUT 6
theorem bipartite_iff_two_colorable {V : Type*} (G : simple_graph V) [fintype V] : (G.colorable 2) ↔ (∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B)) :=
begin
    split,
    assume (c : G.V → fin 2),
    let A : set V := { v | c v = 0 },
        B : set V := { v | c v = 1 },
    have h1 : (A ⊆ G.V) ∧ (B ⊆ G.V), from by {split, apply set.subset_of_forall_mem_of_forall_mem_union_right,
                      intros x hx, exact hx,
                      apply set.subset_of_forall_mem_of_forall_mem_union_left,
                      intros x hx, exact hx,
                      },
    have h2 : (A ⊕ B) = G.V, from by finish,
    apply exists.intro A, apply exists.intro B, apply exists.intro h2,
    let f1 : A ↪ G.V := ⟨λ x, mem_stack A B x, λ _ _ _, rfl⟩,
        f2 : B ↪ G.V := ⟨λ x, mem_stack B A x, λ _ _ _, rfl⟩,
    let f : A + B → V := cast (congr_arg _ h2),
        f' : V → A + B := cast (congr_arg _ (eq.symm h2)),
    have h3 : injective f, from by { intros x y, ext, sorry },
    have h4 : injective f', from by { intros x y, ext, sorry },
    have h5 : is_inj_on f A, from by { apply is_inj_on.injective h3, intros x y, ext, sorry },
    have h6 : is_inj_on f B, from by { apply is_inj_on.injective h3, intros x y, ext, sorry },
    have h7 : f1 = f, from by { apply set.ext, intros x hx, show _, ext, sorry },
    have h8 : f2 = f, from by { apply set.ext, intros x hx, show _, ext, sorry },
    show G ≤ cast (congr_arg _ h2) (complete_bipartite_graph A B), from by {
      rw ← eq_complete_bipartite_graph, sorry,
    },
    assume (A B : Type*) (h : (A ⊕ B) = G.V) (h1 : G ≤ complete_bipartite_graph A B),
    let f1 : A ↪ G.V := ⟨λ x, mem_stack A B x, λ _ _ _, rfl⟩,
        f2 : B ↪ G.V := ⟨λ x, mem_stack B A x, λ _ _ _, rfl⟩,
    let f : A + B → V := cast (congr_arg _ h),
        f' : V → A + B := cast (congr_arg _ (eq.symm h)),
    have h3 : injective f, from by { intros x y, ext, sorry },
    have h4 : injective f', from by { intros x y, ext, sorry },
    have h5 : is_inj_on f A, from by { apply is_inj_on.injective h3, intros x y, ext, sorry },
    have h6 : is_inj_on f B, from by { apply is_inj_on.injective h3, intros x y, ext, sorry },
    have h7 : f1 = f, from by { apply set.ext, intros x hx, show _, ext, sorry },
    have h8 : f2 = f, from by { apply set.ext, intros x hx, show _, ext, sorry },
    show G.colorable 2, from by {
        rw ← eq_complete_bipartite_graph at h1,
        show G.colorable 2, from by {
            assume x,
            sorry,
        },
    },
end

--OUTPUT 7
theorem bipartite_iff_two_colorable {V : Type*} (G : simple_graph V) [fintype V] : (G.colorable 2) ↔ (∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B)) :=
begin
  split,
  { assume h : G.colorable 2,
    choose (A B : Type*) (h1 : (A ⊕ B) = V) (h2 : G ≤ cast (congr_arg _ h1) (complete_bipartite_graph A B)) using h,
    use [A,B,h1,h2], },
  { assume h : ∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B),
    rcases h with ⟨A,B,h,h2⟩,
    have h3 : G ⊆ cast (congr_arg _ h) (complete_bipartite_graph A B), from h2,
    have h4 : ∀ (a b) : A × B, (a,b) ∈ G → (cast (congr_arg _ h) (complete_bipartite_graph A B)) a b, from by {
      assume a b,
      assume h : (a,b) ∈ G,
      rw ← h3 at h,
      exact h, },
    have h5 : (colorable 2 G), from ⟨A, B, h4⟩,
    exact h5, },
end

--OUTPUT 8
theorem bipartite_iff_two_colorable {V : Type*} (G : simple_graph V) [fintype V] : (G.colorable 2) ↔ (∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B)) := by sorry

--[ALTERNATIVE]

theorem bipartite_iff_two_colorable' {V : Type*} (G : simple_graph V) [fintype V] : (G.colorable 2) ↔ (∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B)) :=
begin
  split,
  { intro h,
    obtain ⟨f, hf⟩ : ∃ f : V → fin 2, ∀ v w ∈ V, ∃ c d ∈ fin 2, v ≠ w ∧ (v, w) ∉ G.E ∧ f v = c ∧ f w = d, from h,
    obtain ⟨A, B, h2⟩ : ∃ A B : Type u, (A ⊕ B) = V, from ⟨{
      v : V | (f v) = 0
    }, {
      v : V | (f v) = 1
    }, by {
      sorry
    }⟩,
    use A,
    use B,
    use h2,
    show G ≤ cast (congr_arg _ h2) (complete_bipartite_graph A B), from sorry
  },
  { rintro ⟨A, B, h2, h3⟩,
    obtain ⟨f, hf⟩ : ∃ f : V → fin 2, ∀ v w, (v, w) ∉ G.E → f v ≠ f w, from sorry,
    use f,
    obtain h4 : ∀ v : V, v ∈ A → f v = 0, from by sorry,
    obtain h5 : ∀ v : V, v ∈ B → f v = 1, from by sorry,
    have h6 : ∀ v w ∈ V, (v, w) ∉ G.E → f v ≠ f w, from sorry,
    assume v w h2 h3,
    obtain ⟨c, d, h7, h8, h9, h10⟩ : ∃ c d ∈ fin 2, v ≠ w ∧ (v, w) ∉ G.E ∧ f v = c ∧ f w = d, from sorry,
    show (v, w) ∉ G.E → f v ≠ f w, from sorry
  }
end

--OUTPUT 9
theorem bipartite_iff_two_colorable {V : Type*} (G : simple_graph V) [fintype V] : (G.colorable 2) ↔ (∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B)) :=
begin
  apply iff.intro,
  {
    assume h1 : G.colorable 2,
    show ∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B), from by {
      let A : Type* := { x : V | (⟨ (h1 x).left, (h1 x).right ⟩ : fin 2) = (⟨ 0, 1 ⟩ : fin 2)  },
      have h2 : ∀ x y : V, (⟨ (h1 x).left, (h1 x).right ⟩ : fin 2) = (⟨ (h1 y).left, (h1 y).right ⟩ : fin 2) → x = y, from by {
        assume x y : V, assume h2 : (⟨ (h1 x).left, (h1 x).right ⟩ : fin 2) = (⟨ (h1 y).left, (h1 y).right ⟩ : fin 2),
        have h3 : (h1 x).left = (h1 y).left, from fin.eq_of_veq h2.left,
        have h4 : (h1 x).right = (h1 y).right, from fin.eq_of_veq h2.right,
        show x = y, from h1.injective h3 h4,
      },
      have h3 : ∀ x : V, (⟨ (h1 x).left, (h1 x).right ⟩ : fin 2) = (⟨ 0, 1 ⟩ : fin 2) , from by {assume x : V, rw fin.eq_iff, norm_num},
      have h4 : A = {a : V | (⟨ (h1 a).left, (h1 a).right ⟩ : fin 2) = ( 0 : fin 1) }, from subset.antisymm (set.subset.trans h3 (set.subset.refl A))
        (set.subset.trans (set.image_univ _) (set.image_le_iff_le_of_injective h2)) ,
      let B : Type* := { x : V | (⟨ (h1 x).left, (h1 x).right ⟩ : fin 2) = (⟨ 1, 0 ⟩ : fin 2)  },
      have h5 : ∀ x : V, (⟨ (h1 x).left, (h1 x).right ⟩ : fin 2) = (⟨ 1, 0 ⟩ : fin 2) , from by {assume x : V, rw fin.eq_iff, norm_num,},
      have h6 : B = {b : V | (⟨ (h1 b).left, (h1 b).right ⟩ : fin 2) = ( 0 : fin 1) }, from subset.antisymm (set.subset.trans h5 (set.subset.refl B))
        (set.subset.trans (set.image_univ _) (set.image_le_iff_le_of_injective h2)),
      have h7 : A ⊕ B = V, from funext (assume x : V,
      begin
        have h8 : ((h1 x).right) + ((h1 x).left) = 1 + 0, from by {rw fin.eq_iff, refl},
        have h9 : ((h1 x).left) + ((h1 x).right) = 0 + 1, from by {rw fin.eq_iff, refl},
        rw [← fin.add_comm (h1 x).left  (h1 x).right, fin.add_comm (h1 x).right (h1 x).left, ← fin.add_comm 0 1, ← fin.add_comm 1 0],
        simp,
      end),
      have h8 : G ≤ cast (congr_arg _ h7) (complete_bipartite_graph A B), from by {
        apply partial_order.le_trans,
        apply set.image_le_iff_le_of_injective h2,
        show G ≤ _, from finset.image_le_iff_le_of_injective h2 h1.edges,
      },
      show ∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B), from ⟨A,B,h7,h8⟩,
    },
  },
  {
    assume h1 : ∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B),
    show G.colorable 2, from by {
      cases h1 with (A B) (h) (h1),
      use (λ x : V, ⟨ x ∈ A, x ∈ B ⟩ : V → fin 2),
      split,
      {
        assume u v,
        assume h2_1 : (u ∈ A) = (v ∈ A),
        assume h2_2 : (u ∈ B) = (v ∈ B),
        have h2_3 : u ∈ A, from (eq.mp h2_1 (decidable.true_iff_true.mp (decidable.is_true _))),
        have h2_4 : u ∈ B, from (eq.mp h2_2 (decidable.true_iff_true.mp (decidable.is_true _))),
        have h2_5 : v ∈ A, from (eq.mp h2_1 (decidable.true_iff_true.mp (decidable.is_true _))),
        have h2_6 : v ∈ B, from (eq.mp h2_2 (decidable.true_iff_true.mp (decidable.is_true _))),
        show u = v, from decidable.by_cases
        (assume h3 : u = v, h3)
        (assume h3 : u ≠ v, by {
          have h4 : G.has_edge u v, from h1.elim_left h3,
          have h5 : complete_bipartite_graph A B.has_edge u v, from cast_edges h2_3 h2_6,
          show false, from h4 h5,
        }),
      },
      {
        assume u v,
        assume h2_1 : (u ∈ A) = (v ∈ A),
        assume h2_2 : (u ∈ B) = (v ∈ B),
        have h2_3 : u ∈ A, from (eq.mp h2_1 (decidable.true_iff_false.mp (decidable.is_true _))),
        have h2_4 : u ∈ B, from (eq.mp h2_2 (decidable.true_iff_false.mp (decidable.is_true _))),
        have h2_5 : v ∈ A, from (eq.mp h2_1 (decidable.true_iff_false.mp (decidable.is_true _))),
        have h2_6 : v ∈ B, from (eq.mp h2_2 (decidable.true_iff_false.mp (decidable.is_true _))),
        show u = v, from decidable.by_cases
        (assume h3 : u = v, h3)
        (assume h3 : u ≠ v, by {
          have h4 : G.has_edge u v, from h1.elim_left h3,
          have h5 : complete_bipartite_graph A B.has_edge u v, from cast_edges h2_3 h2_6,
          show false, from h4 h5,
        }),
      },
      {
        assume u v,
        assume h2_1 : (u ∈ A) = (v ∈ A),
        assume h2_2 : (u ∈ B) = (v ∈ B),
        have h2_3 : u ∈ A, from (eq.mp h2_1 (
end --Needs more than 2000 tokens!

--OUTPUT 10
theorem bipartite_iff_two_colorable {V : Type*} (G : simple_graph V) [fintype V] : (G.colorable 2) ↔ (∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B)) :=
begin
  split,
  {
    assume h,
    have h1 : ∃ (f : V → fin 2), G.vertex_coloring f, from ⟨h.f,h.h⟩,
    have h2 : ∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B), from by {
      have h3 : ∃ (A B : Type*) (h : (A ⊕ B) = V), ∃ (f : V → (A ⊕ B)) (hf : bijective f), f ⁻¹' A ∈ G.vertex_coloring 2 ∧ f ⁻¹' B ∈ G.vertex_coloring 2, from by {
        have h4 : ∃ (f : V → fin 2), ∀ (x y : V), (f x = f y) ↔ ¬(G.edge x y), from by {
          have h5 : ∃ (f : V → ℕ), ∀ (x y : V), (f x = f y) ↔ ¬(G.edge x y), from by {
            have h6 : ∃ (A : Type*) (h : A = V), ∃ (f : V → A), bijective f, from by {
              apply (@h6 ℕ),
              apply (@h4 ℕ),
              apply (h1.f),
            },
            obtain (A : Type*) (h : A = V) (f : V → A) (hf : bijective f), from h6,
            show ∃ (f : V → ℕ), ∀ (x y : V), (f x = f y) ↔ ¬(G.edge x y), from by {
              use nat_embedding ∘ f,
              assume x y,
              show (nat_embedding (f x) = nat_embedding (f y)) ↔ ¬(G.edge x y), from by {
                have h7 : (f x = f y) ↔ ¬(G.edge x y), from by {
                  apply hf.injective,
                  rw hf.right,
                },
                rw [nat_embedding_injective,nat_embedding_injective],
                exact h7,
              }
            }
          },
          obtain (f : V → ℕ) (hf : ∀ (x y : V), (f x = f y) ↔ ¬(G.edge x y)), from h5,
          use fin.of_nat ∘ f,
          assume x y,
          show (fin.of_nat (f x) = fin.of_nat (f y)) ↔ ¬(G.edge x y), from by {
            rw [fin.of_nat_injective,fin.of_nat_injective],
            exact hf _ _,
          }
        },
        have h5 : ∃ (f : V → fin 2), ∀ (x y : V), (f x = f y) ↔ ¬(G.edge x y), from by {
          obtain (f : V → fin 2) (hf : ∀ (x y : V), (f x = f y) ↔ ¬(G.edge x y)), from h4,
          show ∃ (f : V → fin 2), ∀ (x y : V), (f x = f y) ↔ ¬(G.edge x y), from by {
            use f,
            exact hf,
          }
        },
        obtain (f : V → fin 2) (hf : ∀ (x y : V), (f x = f y) ↔ ¬(G.edge x y)), from h5,
        show ∃ (A B : Type*) (h : (A ⊕ B) = V), ∃ (f : V → (A ⊕ B)) (hf : bijective f), f ⁻¹' A ∈ G.vertex_coloring 2 ∧ f ⁻¹' B ∈ G.vertex_coloring 2, from by {
          have h6 : ∃ (f : V → fin 2), bijective f, from ⟨f,hf.injective,hf.surjective⟩,
          obtain (f : V → fin 2) (hf : bijective f), from h6,
          show ∃ (A B : Type*) (h : (A ⊕ B) = V), ∃ (f : V → (A ⊕ B)) (hf : bijective f), f ⁻¹' A ∈ G.vertex_coloring 2 ∧ f ⁻¹' B ∈ G.vertex_coloring 2, from by {
            use (fin 2),
            use (fin.elim_left f)⁻¹' fin.zero,
            use (fin.elim_left f)⁻¹' fin.succ fin.zero,
            use (by exact (f.elim_left)).injective,
            use (by exact (f.elim_left)).surjective,
            use id,
            use (by {
              rw [fin.elim_left_injective,id.def,fin.elim_left_injective,id.def],
              exact hf.injective,
            }),
            use (by {
              rw [fin.elim_left_injective,id.def,fin.elim_left_injective,id.def],
              exact hf.surjective,
            }),
          }
        },
        obtain (A B : Type*) (h : (A ⊕ B) = V)  (f : V → (A ⊕ B)) (hf : bijective f) (h1 : (f ⁻¹' A) ∈ G.vertex_coloring 2) (h2 : (f ⁻¹' B) ∈ G.vertex_coloring 2), from h3,
        show ∃ (A B : Type*) (h : (A ⊕ B) = V), ∃ (f : V → (A ⊕ B)) (hf : bijective f), f ⁻¹' A ∈ G.vertex_coloring 2 ∧ f ⁻¹' B ∈ G.vertex_coloring 2, from by {
          use A,
          use B,
          use h.symm,
          use f⁻¹,
          use bijective.inv hf,
          use h1,
          use h2,
        }
      },
      obtain (A B : Type*) (h : (A ⊕ B) = V) (f : V → (A ⊕ B)) (hf : bijective f) (h1 : (f ⁻¹' A) ∈ G.vertex_coloring 2) (h2 : (f ⁻¹' B) ∈ G.vertex_coloring 2), from h3,
      show ∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B), from by {
        use A,
        use B,
        use h,
        have h3 : ∀ x y, G.edge x y ↔ (complete_bipartite_graph A B).edge (f x) (f y), from by {
          assume x y,
          have (A ⊕ B) ≃ V, from by {apply equiv.set.symm,exact h},
          have h4 : V ≃ A ⊕ B, from by {apply equiv.set,exact h},
          have h5 : ∀ x y, G.edge x y ↔ (complete_bipartite_graph A B).edge (f (h4 x)) (f (h4 y)), from by {
            assume x y,
            rw [h4.symm.left,h4.symm.left],
          },
          show G.edge x y ↔ (complete_bipartite_graph A B).edge (f x) (f y), from by {
            apply h5,
          }

end --Needs more than 2000 tokens!

/- FEW SHOT PROMPTS TO CODEX(START)
/--`theorem`
Power Set is Closed under Intersection
Let $S$ be a set.

Let $\powerset S$ be the power set of $S$.

Then:
:$\forall A, B \in \powerset S: A \cap B \in \powerset S$
`proof`
Let $A, B \in \powerset S$.

Then by the definition of power set, $A \subseteq S$ and $B \subseteq S$.

From Intersection is Subset we have that $A \cap B \subseteq A$.

It follows from Subset Relation is Transitive that $A \cap B \subseteq S$.

Thus $A \cap B \in \powerset S$ and closure is proved.
{{qed}}
-/
theorem power_set_intersection_closed {α : Type*} (S : set α) : ∀ A B ∈ 𝒫 S, (A ∩ B) ∈ 𝒫 S :=
begin
  assume (A : set α) (hA : A ∈ 𝒫 S) (B : set α) (hB : B ∈ 𝒫 S),
  have h1 : (A ⊆ S) ∧ (B ⊆ S), from by {split,apply set.subset_of_mem_powerset,exact hA,apply set.subset_of_mem_powerset,exact hB},
  have h2 : (A ∩ B) ⊆ A, from by apply set.inter_subset_left,
  have h3 : (A ∩ B) ⊆ S, from by {apply set.subset.trans h2 h1.left},
  show (A ∩ B) ∈  𝒫 S, from by {apply set.mem_powerset h3},
end

/--`theorem`
Square of Sum
 :$\forall x, y \in \R: \paren {x + y}^2 = x^2 + 2 x y + y^2$
`proof`
Follows from the distribution of multiplication over addition:

{{begin-eqn}}
{{eqn | l = \left({x + y}\right)^2
      | r = \left({x + y}\right) \cdot \left({x + y}\right)
}}
{{eqn | r = x \cdot \left({x + y}\right) + y \cdot \left({x + y}\right)
      | c = Real Multiplication Distributes over Addition
}}
{{eqn | r = x \cdot x + x \cdot y + y \cdot x + y \cdot y
      | c = Real Multiplication Distributes over Addition
}}
{{eqn | r = x^2 + 2xy + y^2
      | c =
}}
{{end-eqn}}
{{qed}}
-/
theorem square_of_sum (x y : ℝ) : (x + y)^2 = (x^2 + 2*x*y + y^2) :=
begin
  calc (x + y)^2 = (x+y)*(x+y) : by rw sq
  ... = x*(x+y) + y*(x+y) : by rw add_mul
  ... = x*x + x*y + y*x + y*y : by {rw [mul_comm x (x+y),mul_comm y (x+y)], rw [add_mul,add_mul], ring}
  ... = x^2 + 2*x*y + y^2 : by {repeat {rw ← sq}, rw mul_comm y x, ring}
end

/--`theorem`
Identity of Group is Unique
Let $\struct {G, \circ}$ be a group. Then there is a unique identity element $e \in G$.
`proof`
From Group has Latin Square Property, there exists a unique $x \in G$ such that:
:$a x = b$

and there exists a unique $y \in G$ such that:
:$y a = b$

Setting $b = a$, this becomes:

There exists a unique $x \in G$ such that:
:$a x = a$

and there exists a unique $y \in G$ such that:
:$y a = a$

These $x$ and $y$ are both $e$, by definition of identity element.
{{qed}}
-/
theorem group_identity_unique {G : Type*} [group G] : ∃! e : G, ∀ a : G, e * a = a ∧ a * e = a :=
begin
  have h1 : ∀ a b : G, ∃! x : G, a * x = b, from by {
    assume a b : G, use a⁻¹ * b, obviously, },
  have h2 : ∀ a b : G, ∃! y : G, y * a = b, from by {
    assume a b : G, use b * a⁻¹, obviously, },

  have h3 : ∀ a : G, ∃! x : G, a * x = a, from
    assume a : G, h1 a a,
  have h4 : ∀ a : G, ∃! y : G, y * a = a, from
    assume a : G, h2 a a,

  have h5 : ∀ a : G, classical.some (h3 a).exists = (1 : G), from assume a :G,
    exists_unique.unique (h3 a) (classical.some_spec (exists_unique.exists (h3 a)))
    (mul_one a),
  have h6 : ∀ a : G, classical.some (h4 a).exists = (1 : G), from assume a : G,
    exists_unique.unique (h4 a) (classical.some_spec (exists_unique.exists (h4 a))) (one_mul a),

  show ∃! e : G, ∀ a : G, e * a = a ∧ a * e = a, from by {
    use (1 : G),
    have h7 : ∀ e : G, (∀ a : G, e * a = a ∧ a * e = a) → e = 1, from by {
      assume (e : G) (hident : ∀ a : G, e * a = a ∧ a * e = a),
      have h8 : ∀ a : G, e = classical.some (h3 a).exists, from assume (a : G),
        exists_unique.unique (h3 a) (hident a).right
        (classical.some_spec (exists_unique.exists (h3 a))),
      have h9 : ∀ a : G, e = classical.some (h4 a).exists, from assume (a : G),
        exists_unique.unique (h4 a) (hident a).left
        (classical.some_spec (exists_unique.exists (h4 a))),
      show e = (1 : G), from eq.trans (h9 e) (h6 _),
    },
    exact ⟨by obviously, h7⟩,
  }
end

/--`theorem`
Bipartite Graph is two colorable
Let $G$ be a graph. Then $G$ is 2-colorable if and only if $G$ is bipartite.
`proof`
Let $G$ be a 2-colorable graph, which means we can color every vertex either red or blue, and no edge will have both endpoints colored the same color. Let $A$ denote the subset of vertices colored red, and let $B$ denote the subset of vertices colored blue. Since all vertices of $A$ are red, there are no edges within $A$, and similarly for $B$. This implies that every edge has one endpoint in $A$ and the other in $B$, which means $G$ is bipartite.

Conversely, suppose $G$ is bipartite, that is, we can partition the vertices into two subsets $V_{1}, V_{2}$ every edge has one endpoint in $V_{1}$ and the other in $V_{2}$. Then coloring every vertex of $V_{1}$ red and every vertex of $V_{2}$ blue yields a valid coloring, so $G$ is 2-colorable.

QED

-/
theorem  bipartite_iff_two_colorable {V : Type*} (G : simple_graph V) [fintype V] : (G.colorable 2) ↔ (∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B)) :=
FEW SHOT PROMPTS TO CODEX(END)-/


/-
Copyright (c) 2018 Reid Barton All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Reid Barton, Scott Morrison, David Wärn
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.category_theory.epi_mono
import Mathlib.PostPort

universes v u l u₂

namespace Mathlib

namespace category_theory

/-- A `groupoid` is a category such that all morphisms are isomorphisms. -/
class groupoid (obj : Type u) extends category obj where
  inv : {X Y : obj} → (X ⟶ Y) → (Y ⟶ X)
  inv_comp' :
    autoParam (∀ {X Y : obj} (f : X ⟶ Y), inv f ≫ f = 𝟙)
      (Lean.Syntax.ident Lean.SourceInfo.none (String.toSubstring "Mathlib.obviously")
        (Lean.Name.mkStr (Lean.Name.mkStr Lean.Name.anonymous "Mathlib") "obviously") [])
  comp_inv' :
    autoParam (∀ {X Y : obj} (f : X ⟶ Y), f ≫ inv f = 𝟙)
      (Lean.Syntax.ident Lean.SourceInfo.none (String.toSubstring "Mathlib.obviously")
        (Lean.Name.mkStr (Lean.Name.mkStr Lean.Name.anonymous "Mathlib") "obviously") [])

@[simp] theorem groupoid.inv_comp {obj : Type u} [c : groupoid obj] {X : obj} {Y : obj}
    (f : X ⟶ Y) : groupoid.inv f ≫ f = 𝟙 :=
  sorry

@[simp] theorem groupoid.comp_inv {obj : Type u} [c : groupoid obj] {X : obj} {Y : obj}
    (f : X ⟶ Y) : f ≫ groupoid.inv f = 𝟙 :=
  sorry

/--
A `large_groupoid` is a groupoid
where the objects live in `Type (u+1)` while the morphisms live in `Type u`.
-/
/--
def large_groupoid (C : Type (u + 1)) := groupoid C

A `small_groupoid` is a groupoid
where the objects and morphisms live in the same universe.
-/
def small_groupoid (C : Type u) := groupoid C

protected instance is_iso.of_groupoid {C : Type u} [groupoid C] {X : C} {Y : C} (f : X ⟶ Y) :
    is_iso f :=
  is_iso.mk (groupoid.inv f)

/-- In a groupoid, isomorphisms are equivalent to morphisms. -/
def groupoid.iso_equiv_hom {C : Type u} [groupoid C] (X : C) (Y : C) : (X ≅ Y) ≃ (X ⟶ Y) :=
  equiv.mk iso.hom (fun (f : X ⟶ Y) => as_iso f) sorry sorry

/-- A category where every morphism `is_iso` is a groupoid. -/
def groupoid.of_is_iso {C : Type u} [category C] (all_is_iso : {X Y : C} → (f : X ⟶ Y) → is_iso f) :
    groupoid C :=
  groupoid.mk fun (X Y : C) (f : X ⟶ Y) => inv f

/-- A category where every morphism has a `trunc` retraction is computably a groupoid. -/
def groupoid.of_trunc_split_mono {C : Type u} [category C]
    (all_split_mono : {X Y : C} → (f : X ⟶ Y) → trunc (split_mono f)) : groupoid C :=
  groupoid.of_is_iso
    fun (X Y : C) (f : X ⟶ Y) =>
      trunc.rec_on_subsingleton (all_split_mono f)
        fun (a : split_mono f) =>
          trunc.rec_on_subsingleton (all_split_mono (retraction f))
            fun (a_1 : split_mono (retraction f)) => is_iso.of_mono_retraction

protected instance induced_category.groupoid {C : Type u} (D : Type u₂) [groupoid D] (F : C → D) :
    groupoid (induced_category D F) :=
  groupoid.mk fun (X Y : induced_category D F) (f : X ⟶ Y) => groupoid.inv f

end Mathlib


import analysis.topology.topological_space
import analysis.topology.continuity
import analysis.topology.topological_structures

open tactic expr
variables {X : Type*} {Y : Type*} {Z : Type*} {W : Type*}
          {f f₁ f₂ : X → Y} {g : Y → Z} {h : Z → W}
variables [topological_space X] [topological_space Y]
          [topological_space Z] [topological_space W]

-- Finish a goal of the form continuous (f ∘ g ∘ ... ) given all functions are continuous.
meta def contcomp : tactic unit :=
do `(continuous %%e) ← target <|> fail "goal has to be of the form 'continuous _'",

  -- if the goal is to show that the expression e is continuous, check if it is an assumption
  assumption <|>

  -- if e is not continuous by assumption, check if it is of the form 'f ∘ g' for some f and g
  do `(%%outer ∘ %%inner) ← return e <|> fail "not continuous by assumption, and not a compsition",

    -- assert that the outer function is continuous, if not, rotate the goal away
    outer_continuous ← to_expr ``(continuous %%outer),
    outer_is_continuous ← assert "h_outer_cont" outer_continuous,
    contcomp <|> rotate 1,

    -- assert that the inner function is continuous, if not, rotate the goal away
    inner_continuous ← to_expr ``(continuous %%inner),
    inner_is_continuous ← assert "h_inner_cont" inner_continuous,
    contcomp <|> rotate 1,

    -- knowing that inner and outer function are continuous, apply the theorem continuous.comp
    -- which shows that the composite is continuous
    cont_comp ← to_expr ``(continuous.comp %%inner_is_continuous %%outer_is_continuous),
    exact cont_comp

example (_ : continuous f) (_ : continuous g) (_ : continuous h) :
continuous (h ∘ g ∘ f) :=
by contcomp

example (_ : continuous f₁) (_ : continuous f₂) [add_monoid Y] :
  continuous (λ x, f₁ x + f₂ x) :=
sorry

example (_ : continuous f) (_ : continuous g) [add_monoid Y] :
  continuous (λ x, g $ f x) :=
by contcomp


/-
Copyright (c) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import algebra.category.Module.monoidal
import algebra.category.Algebra.basic
import category_theory.monoidal.Mon_

/-!
# `Mon_ (Module R) ≌ Algebra R`

The category of internal monoid objects in `Module R`
is equivalent to the category of "native" bundled `R`-algebras.

Moreover, this equivalence is compatible with the forgetful functors to `Module R`.
-/

universes v u

open category_theory
open linear_map

open_locale tensor_product
local attribute [ext] tensor_product.ext

namespace Module

variables {R : Type u} [comm_ring R]

namespace Mon_Module_equivalence_Algebra

@[simps]
instance (A : Mon_ (Module.{u} R)) : ring A.X :=
{ one := A.one (1 : R),
  mul := λ x y, A.mul (x ⊗ₜ y),
  one_mul := λ x, by { convert linear_map.congr_fun A.one_mul ((1 : R) ⊗ₜ x), simp, },
  mul_one := λ x, by { convert linear_map.congr_fun A.mul_one (x ⊗ₜ (1 : R)), simp, },
  mul_assoc := λ x y z, by convert linear_map.congr_fun A.mul_assoc ((x ⊗ₜ y) ⊗ₜ z),
  left_distrib := λ x y z,
  begin
    convert A.mul.map_add (x ⊗ₜ y) (x ⊗ₜ z),
    rw ←tensor_product.tmul_add,
    refl,
  end,
  right_distrib := λ x y z,
  begin
    convert A.mul.map_add (x ⊗ₜ z) (y ⊗ₜ z),
    rw ←tensor_product.add_tmul,
    refl,
  end,
  ..(by apply_instance : add_comm_group A.X) }

instance (A : Mon_ (Module.{u} R)) : algebra R A.X :=
{ map_zero' := A.one.map_zero,
  map_one' := rfl,
  map_mul' := λ x y,
  begin
    have h := linear_map.congr_fun A.one_mul.symm (x ⊗ₜ (A.one y)),
    rwa [monoidal_category.left_unitor_hom_apply, ←A.one.map_smul] at h,
  end,
  commutes' := λ r a,
  begin dsimp,
    have h₁ := linear_map.congr_fun A.one_mul (r ⊗ₜ a),
    have h₂ := linear_map.congr_fun A.mul_one (a ⊗ₜ r),
    exact h₁.trans h₂.symm,
  end,
  smul_def' := λ r a, by { convert (linear_map.congr_fun A.one_mul (r ⊗ₜ a)).symm, simp, },
  ..A.one }

@[simp] lemma algebra_map (A : Mon_ (Module.{u} R)) (r : R) : algebra_map R A.X r = A.one r := rfl

/--
Converting a monoid object in `Module R` to a bundled algebra.
-/
@[simps]
def functor : Mon_ (Module.{u} R) ⥤ Algebra R :=
{ obj := λ A, Algebra.of R A.X,
  map := λ A B f,
  { to_fun := f.hom,
    map_one' := linear_map.congr_fun f.one_hom (1 : R),
    map_mul' := λ x y, linear_map.congr_fun f.mul_hom (x ⊗ₜ y),
    commutes' := λ r, linear_map.congr_fun f.one_hom r,
    ..(f.hom.to_add_monoid_hom) }, }.

/--
Converting a bundled algebra to a monoid object in `Module R`.
-/
@[simps]
def inverse_obj (A : Algebra.{u} R) : Mon_ (Module.{u} R) :=
{ X := Module.of R A,
  one := algebra.linear_map R A,
  mul := @algebra.lmul' R A _ _ _,
  one_mul' :=
  begin
    ext x,
    dsimp only [Algebra.id_apply, tensor_product.mk_apply,
      algebra.linear_map_apply, linear_map.compr₂_apply, function.comp_app,
      ring_hom.map_one, Module.monoidal_category.hom_apply, Algebra.coe_comp,
      Module.monoidal_category.left_unitor_hom_apply],
    rw [algebra.lmul'_apply, monoidal_category.left_unitor_hom_apply, ← algebra.smul_def]
  end,
  mul_one' :=
  begin
    ext x,
    dsimp only [Algebra.id_apply, tensor_product.mk_apply, algebra.linear_map_apply,
      linear_map.compr₂_apply, function.comp_app, Module.monoidal_category.hom_apply,
      Algebra.coe_comp],
    rw [algebra.lmul'_apply, Module.monoidal_category.right_unitor_hom_apply,
        ← algebra.commutes, ← algebra.smul_def]
  end,
  mul_assoc' :=
  begin
    ext x y z,
    dsimp only [Algebra.id_apply, tensor_product.mk_apply, linear_map.compr₂_apply,
      function.comp_app, Module.monoidal_category.hom_apply,
      Algebra.coe_comp, monoidal_category.associator_hom_apply],
    simp only [algebra.lmul'_apply, mul_assoc]
  end }

/--
Converting a bundled algebra to a monoid object in `Module R`.
-/
@[simps]
def inverse : Algebra.{u} R ⥤ Mon_ (Module.{u} R) :=
{ obj := inverse_obj,
  map := λ A B f,
  { hom := f.to_linear_map,
    one_hom' :=
      by { ext, dsimp, simp only [ring_hom.map_one, alg_hom.map_one] },
    mul_hom' :=
      by { ext, dsimp, simp only [algebra.lmul'_apply, ring_hom.map_mul, alg_hom.map_mul] } } }.

end Mon_Module_equivalence_Algebra

open Mon_Module_equivalence_Algebra

/--
The category of internal monoid objects in `Module R`
is equivalent to the category of "native" bundled `R`-algebras.
-/
def Mon_Module_equivalence_Algebra : Mon_ (Module.{u} R) ≌ Algebra R :=
{ functor := functor,
  inverse := inverse,
  unit_iso := nat_iso.of_components
    (λ A,
    { hom := { hom := { to_fun := id, map_add' := λ x y, rfl, map_smul' := λ r a, rfl, },
               mul_hom' := by { ext, dsimp at *,
                                simp only [algebra.lmul'_apply, Mon_.X.ring_mul] } },
      inv := { hom := { to_fun := id, map_add' := λ x y, rfl, map_smul' := λ r a, rfl, },
               mul_hom' := by { ext, dsimp at *,
                                simp only [algebra.lmul'_apply, Mon_.X.ring_mul]} } })
    (by tidy),
  counit_iso := nat_iso.of_components (λ A,
  { hom :=
    { to_fun := id,
      map_zero' := rfl,
      map_add' := λ x y, rfl,
      map_one' := (algebra_map R A).map_one,
      map_mul' := λ x y, algebra.lmul'_apply,
      commutes' := λ r, rfl, },
    inv :=
    { to_fun := id,
      map_zero' := rfl,
      map_add' := λ x y, rfl,
      map_one' := (algebra_map R A).map_one.symm,
      map_mul' := λ x y, algebra.lmul'_apply.symm,
      commutes' := λ r, rfl } }) (by { intros, refl }), }.

/--
The equivalence `Mon_ (Module R) ≌ Algebra R`
is naturally compatible with the forgetful functors to `Module R`.
-/
def Mon_Module_equivalence_Algebra_forget :
  Mon_Module_equivalence_Algebra.functor ⋙ forget₂ (Algebra.{u} R) (Module.{u} R) ≅
    Mon_.forget (Module.{u} R):=
nat_iso.of_components (λ A,
{ hom :=
  { to_fun := id,
    map_add' := λ x y, rfl,
    map_smul' := λ c x, rfl },
  inv :=
  { to_fun := id,
    map_add' := λ x y, rfl,
    map_smul' := λ c x, rfl }, }) (by tidy)

end Module