universe u v

theorem eqLitOfSize0 {α : Type u} (a : Array α) (hsz : a.size = 0) : a = #[] :=
a.toArrayLitEq 0 hsz

theorem eqLitOfSize1 {α : Type u} (a : Array α) (hsz : a.size = 1) : a = #[a.getLit 0 hsz (ofDecideEqTrue rfl)] :=
a.toArrayLitEq 1 hsz

theorem eqLitOfSize2 {α : Type u} (a : Array α) (hsz : a.size = 2) : a = #[a.getLit 0 hsz (ofDecideEqTrue rfl), a.getLit 1 hsz (ofDecideEqTrue rfl)] :=
a.toArrayLitEq 2 hsz

theorem eqLitOfSize3 {α : Type u} (a : Array α) (hsz : a.size = 3) :
  a = #[a.getLit 0 hsz (ofDecideEqTrue rfl), a.getLit 1 hsz (ofDecideEqTrue rfl), a.getLit 2 hsz (ofDecideEqTrue rfl)] :=
a.toArrayLitEq 3 hsz

/-
Matcher for the following patterns
```
| #[]           => _
| #[a₁]         => _
| #[a₁, a₂, a₃] => _
| a             => _
``` -/
def matchArrayLit {α : Type u} (C : Array α → Sort v) (a : Array α)
    (h₁ : Unit →      C #[])
    (h₂ : ∀ a₁,       C #[a₁])
    (h₃ : ∀ a₁ a₂ a₃, C #[a₁, a₂, a₃])
    (h₄ : ∀ a,        C a)
    : C a :=
if h : a.size = 0 then
  @Eq.rec _ _ (fun x _ => C x) (h₁ ()) _ (a.toArrayLitEq 0 h).symm
else if h : a.size = 1 then
  @Eq.rec _ _ (fun x _ => C x) (h₂ (a.getLit 0 h (ofDecideEqTrue rfl))) _ (a.toArrayLitEq 1 h).symm
else if h : a.size = 3 then
  @Eq.rec _ _ (fun x _ => C x) (h₃ (a.getLit 0 h (ofDecideEqTrue rfl)) (a.getLit 1 h (ofDecideEqTrue rfl)) (a.getLit 2 h (ofDecideEqTrue rfl))) _ (a.toArrayLitEq 3 h).symm
else
  h₄ a

/- Equational lemmas that should be generated automatically. -/
theorem matchArrayLit.eq1 {α : Type u} (C : Array α → Sort v)
    (h₁ : Unit →      C #[])
    (h₂ : ∀ a₁,       C #[a₁])
    (h₃ : ∀ a₁ a₂ a₃, C #[a₁, a₂, a₃])
    (h₄ : ∀ a,        C a)
    : matchArrayLit C #[] h₁ h₂ h₃ h₄ = h₁ () :=
rfl

theorem matchArrayLit.eq2 {α : Type u} (C : Array α → Sort v)
    (h₁ : Unit →      C #[])
    (h₂ : ∀ a₁,       C #[a₁])
    (h₃ : ∀ a₁ a₂ a₃, C #[a₁, a₂, a₃])
    (h₄ : ∀ a,        C a)
    (a₁ : α)
    : matchArrayLit C #[a₁] h₁ h₂ h₃ h₄ = h₂ a₁ :=
rfl

theorem matchArrayLit.eq3 {α : Type u} (C : Array α → Sort v)
    (h₁ : Unit →      C #[])
    (h₂ : ∀ a₁,       C #[a₁])
    (h₃ : ∀ a₁ a₂ a₃, C #[a₁, a₂, a₃])
    (h₄ : ∀ a,        C a)
    (a₁ a₂ a₃ : α)
    : matchArrayLit C #[a₁, a₂, a₃] h₁ h₂ h₃ h₄ = h₃ a₁ a₂ a₃ :=
rfl


/-
Copyright (c) 2020 Gabriel Ebner, Simon Hudon. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Gabriel Ebner, Simon Hudon
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.tactic.ext
import Mathlib.Lean3Lib.data.stream
import Mathlib.data.list.basic
import Mathlib.data.list.range
import Mathlib.PostPort

universes u_1

namespace Mathlib

/-!
# Additional instances and attributes for streams
-/

protected instance stream.inhabited {α : Type u_1} [Inhabited α] : Inhabited (stream α) :=
  { default := stream.const Inhabited.default }

namespace stream

/-- `take s n` returns a list of the `n` first elements of stream `s` -/
def take {α : Type u_1} (s : stream α) (n : ℕ) : List α := list.map s (list.range n)

theorem length_take {α : Type u_1} (s : stream α) (n : ℕ) : list.length (take s n) = n := sorry

/-- Use a state monad to generate a stream through corecursion -/
def corec_state {σ : Type u_1} {α : Type u_1} (cmd : state σ α) (s : σ) : stream α :=
  corec prod.fst (state_t.run cmd ∘ prod.snd) (state_t.run cmd s)

end Mathlib


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

import tactic.core
import mathematica
import data.complex.exponential
import data.real.pi
import tactic.interactive_expr

/-!

This demo shows how we can mimic a Mathematica notebook from within Lean.

The syntax here is somewhat hackish; better syntax will be possible in Lean 4.

A section of Mathematica code is entered between `begin_mm_block` and `end_mm_block`.
Mathematica commands are entered in quotes `""`, with each line terminated by a semicolon `;`
corresponding to a `shift-enter` in the standard notebook frontend.
Lean expressions can be inserted as antiquotes between quoted Mathematica expressions.
For parsing reasons, compound Lean expressions must appear in parentheses `()`.

The evaluation of these commands will happen sequentially in the same Mathematica environment.

By default, the output of a line will be translated to a Lean expression and traced.
To display the output as an image instead,
prefix the line with `as image`.

Since Mathematica has no access to Lean's definitional reduction, it is sometimes necessary
to unfold definitions before sending them to Mathematica.
You can begin the block with `begin_mm_block (unfolding f g)` to unfold `f` and `g`
in all antiquoted Lean expressions.

-/

reserve notation `begin_mm_block`
reserve notation `end_mm_block`
reserve notation `as`
reserve notation `image`
reserve notation `unfolding`

@[sym_to_expr]
meta def pi_to_expr : mathematica.sym_trans_expr_rule :=
⟨"Pi", `(real.pi)⟩

@[sym_to_expr]
meta def null_to_expr : mathematica.sym_trans_expr_rule :=
⟨"Null", `(())⟩

/-!
This section develops the widgets for displaying results from Mathematica as images.
-/

section
open widget

meta def component.stateless' {π α} (view : π → list (html α)) : component π α :=
component.with_should_update (λ _ _, tt) $ component.pure view

meta def url_component (src : string) : component tactic_state empty :=
component.stateless' $ λ ts,
  [h "h1" [] ["Mathematica output"],
    h "img" [attr.val "src" src] []
  ]

meta def expr_widget (src : expr) : tactic (component tactic_state empty) :=
do s ← tactic.pp src,
  return $ component.stateless' $ λ ts,
    [h "h1" [] ["Mathematica output"],
    h "p" [] [s]
  ]

end

/-!
This section develops the parser for Mathematica blocks.
-/

section
setup_tactic_parser
open tactic

meta inductive command_comp
| cmd : string → command_comp
| antiquot : expr → command_comp

meta def command_comp.to_string : command_comp → string
| (command_comp.cmd s) := "command: " ++ s
| (command_comp.antiquot s) := "antiquot: " ++ to_string s

meta instance : has_repr command_comp :=
⟨command_comp.to_string⟩

meta def parse_string_component : lean.parser string :=
do s ← parser.pexpr 10000,
   to_expr s >>= ↑(eval_expr string)

meta def parse_antiquote : lean.parser pexpr :=
parser.pexpr 10000

meta def parse_component : lean.parser command_comp :=
do pe ← parser.pexpr 10000,
   e ← to_expr pe,
   tpe ← infer_type e,
   if tpe = `(string) then do  s ← eval_expr' string e, return $ command_comp.cmd s
   else return $ command_comp.antiquot e

meta def parse_cmd_list_aux : lean.parser $ list command_comp :=
tk ";" >> return  [] <|>
do c ← parse_component, cs ← parse_cmd_list_aux, return (c::cs)

meta def parse_cmd_list : lean.parser $ bool × pos × list command_comp :=
do pos ← cur_pos,
   is_img ← option.is_some <$> (tk "as" >> tk "image")?,
   prod.mk is_img <$> prod.mk pos <$> parse_cmd_list_aux

/-!
This section translates, evaluates, and displays the result of a parsed Mathematica command.
-/

meta def command_comp.translate (to_unfold : list name) : command_comp → tactic string
| (command_comp.cmd s) := return s
| (command_comp.antiquot p) :=
  do s ← mathematica.form_of_expr <$> dunfold to_unfold p {fail_if_unchanged := ff},
     return $ "Activate[LeanForm[" ++ s ++ "]]"

meta def execute_list (to_unfold : list name) (is_img : bool) (l : list command_comp) : tactic pexpr :=
do l ← l.mmap (command_comp.translate to_unfold), --tactic.trace $ string.join l,
   let cmd := if is_img then "MakeDataUrlFromImage[" ++ string.join l ++ "]" else string.join l,
   s ← mathematica.execute_global cmd >>= parse_mmexpr_tac,
   mathematica.pexpr_of_mmexpr mathematica.trans_env.empty s

meta def string_of_pos_comp (to_unfold : list name) :
  bool × pos × list command_comp → tactic (pos × (string ⊕ expr))
| ⟨is_img, p, c⟩ :=
do e ← execute_list to_unfold is_img c >>= to_expr,
   prod.mk p <$> if is_img then  sum.inl <$> eval_expr string e else return (sum.inr e)

meta def make_widget (to_unfold : list name) (p : bool × pos × list command_comp) :
  tactic $ pos × (widget.component tactic_state empty) :=
do (loc, data) ← string_of_pos_comp to_unfold p,
match data with
| sum.inl s := return $ ⟨loc, url_component s⟩
| sum.inr e := prod.mk loc <$> expr_widget e
end

@[user_command] meta def parse_mm_block (_ : parse (tk "begin_mm_block")) : lean.parser unit :=
do to_unfold ← (tk "(" >> tk "unfolding" >> ident* <* tk ")")?,
   l ← parse_cmd_list*,
   tk "end_mm_block",
   l ← l.mmap (λ e, make_widget (to_unfold.get_or_else []) e),
   l.mmap' $ λ ⟨⟨ln, c⟩, w⟩, save_widget ⟨ln, c - ("begin_mm_block".length - 1)⟩  w
end

/-!
In this example we show a Mathematica block with three image plots.
Put the cursor on the first characters of the `as image` lines to see the output.

In the second line, we plot a Lean function given as a lambda expression.
In the third, we plot a Lean definition, that we have marked to unfold at the beginning.
-/

open real
noncomputable def f : ℝ → ℝ := λ x, sin x + cos x

begin_mm_block (unfolding f)

as image
"Plot3D[x^2-y, {x,-3,3}, {y,-3,3}]";

as image
"Plot["(λ y, (sin y)^2 - y^2)"[x], {x,-10,10}]";

as image
"Plot["f"[y], {y,-2,2}]";

end_mm_block

/-!
This example gets output from Mathematica as expressions instead of images.

First, we define a symbol `MyPoly` as a Lean expression and factor it.

Then we directly factor a Lean expression.

Uncommenting the `pp` line above shows that we really are seeing full Lean expressions in the output.
-/

-- set_option pp.all true

constants y z : ℝ

begin_mm_block

"MyPoly ="(z^2-2*z+1);
"Factor[MyPoly]";

"Factor["(y^10-z^10)"]";

end_mm_block


import category_theory.category
import category_theory.colimit_lemmas
import .definitions

open category_theory
open category_theory.category
local notation f ` ∘ `:80 g:80 := g ≫ f
local notation t ` @> `:90 X:90 := t.app X

universes v u

namespace homotopy_theory.cylinder

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

-- Homotopy with respect to a given cylinder functor.
structure homotopy {x y : C} (f₀ f₁ : x ⟶ y) :=
(H : I.obj x ⟶ y)
(Hi₀ : H ∘ i 0 @> x = f₀)
(Hi₁ : H ∘ i 1 @> x = f₁)

-- The constant homotopy on a map.
def homotopy.refl {x y : C} (f : x ⟶ y) : homotopy f f :=
by refine { H := f ∘ p @> x, Hi₀ := _, Hi₁ := _ };
   rw [←assoc]; dsimp; simp

-- The image of a homotopy under a map.
def homotopy.congr_left {x y y' : C} (g : y ⟶ y') {f₀ f₁ : x ⟶ y} (H : homotopy f₀ f₁) :
  homotopy (g ∘ f₀) (g ∘ f₁) :=
{ H := g ∘ H.H,
  Hi₀ := by rw [←assoc, H.Hi₀],
  Hi₁ := by rw [←assoc, H.Hi₁] }

-- The precomposition of a homotopy by a map.
def homotopy.congr_right {x' x y : C} (g : x' ⟶ x) {f₀ f₁ : x ⟶ y} (H : homotopy f₀ f₁) :
  homotopy (f₀ ∘ g) (f₁ ∘ g) :=
{ H := H.H ∘ I &> g,
  Hi₀ := by erw [←assoc, ←(i _).naturality]; simp; erw H.Hi₀,
  Hi₁ := by erw [←assoc, ←(i _).naturality]; simp; erw H.Hi₁ }

-- Annoying equality stuff.
-- If we rewrite the starting point of the homotopy by an equality, it doesn't change H.
lemma homotopy.eq_rec_on_left {x y : C} {f₀ f₀' f₁ : x ⟶ y} (H : homotopy f₀ f₁)
  (e : f₀ = f₀') : (eq.rec_on e H : homotopy f₀' f₁).H = H.H :=
by cases e; refl

section rel
variables {a x y : C} (j : a ⟶ x) {f₀ f₁ : x ⟶ y}

-- The property of a homotopy leaving fixed a subspace, or more
-- generally the "image" of any map j : A → X. In order for the
-- homotopy to be rel u, we must first have f₀ ∘ j = f₁ ∘ j. This
-- condition is not encoded in the type.
def homotopy.is_rel (H : homotopy f₀ f₁) : Prop :=
H.H ∘ I &> j = f₀ ∘ j ∘ p @> a

variables {j}
lemma agree_of_is_rel {H : homotopy f₀ f₁} (h : H.is_rel j) : f₀ ∘ j = f₁ ∘ j :=
calc
  f₀ ∘ j
    = (f₀ ∘ j) ∘ (p @> a ∘ i 1 @> a) : by simp
... = f₀ ∘ j ∘ p @> a ∘ i 1 @> a     : by rw assoc
... = H.H ∘ I &> j ∘ i 1 @> a        : by unfold homotopy.is_rel at h; simp [h]
... = H.H ∘ (I &> j ∘ i 1 @> a)      : by simp
... = H.H ∘ (i 1 @> x ∘ j)           : by erw ←(i 1).naturality; refl
... = f₁ ∘ j                         : by simp; erw H.Hi₁

lemma homotopy.refl_is_rel {f : x ⟶ y} : (homotopy.refl f).is_rel j :=
show f ∘ p @> x ∘ I &> j = f ∘ j ∘ p @> a,
by erw [←assoc, ←assoc, p.naturality]; refl

lemma homotopy.congr_left_is_rel {f₀ f₁ : x ⟶ y} {H : homotopy f₀ f₁}
  {z} (g : y ⟶ z) (h : H.is_rel j) : (H.congr_left g).is_rel j :=
begin
  unfold homotopy.is_rel at ⊢ h, dsimp [homotopy.congr_left] { iota := tt },
  rw [←assoc, h], simp
end

lemma homotopy.congr_right_is_rel {f₀ f₁ : x ⟶ y} {H : homotopy f₀ f₁}
  {x'} {j' : a ⟶ x'} (g : x' ⟶ x) (h : H.is_rel (g ∘ j')) : (H.congr_right g).is_rel j' :=
begin
  unfold homotopy.is_rel at ⊢ h, dsimp [homotopy.congr_right] { iota := tt },
  rw [←assoc, ←I.map_comp, h], simp
end

-- In practice, `a` is initial and `I` preserves initial objects.
lemma homotopy.is_rel_initial (Iai : Is_initial_object.{v} (I.obj a))
  (H : homotopy f₀ f₁) : H.is_rel j :=
Iai.uniqueness _ _

end rel

section dir
-- A technical contrivance to let us abstract over the direction of a
-- homotopy.
def homotopy_dir (ε : endpoint) {x y : C} (fε fεv : x ⟶ y) : Type v :=
match ε with
| 0 := homotopy fε fεv
| 1 := homotopy fεv fε
end

def homotopy_dir.H {ε} {x y : C} {fε fεv : x ⟶ y} (H : homotopy_dir ε fε fεv) :
  I.obj x ⟶ y :=
match ε, H with
| 0, H := homotopy.H H
| 1, H := homotopy.H H
end

lemma homotopy_dir.Hiε {ε} {x y : C} {fε fεv : x ⟶ y} (H : homotopy_dir ε fε fεv) :
  H.H ∘ i ε @> x = fε :=
match ε, H with
| 0, H := homotopy.Hi₀ H
| 1, H := homotopy.Hi₁ H
end

lemma homotopy_dir.Hiεv {ε} {x y : C} {fε fεv : x ⟶ y} (H : homotopy_dir ε fε fεv) :
  H.H ∘ i ε.v @> x = fεv :=
match ε, H with
| 0, H := homotopy.Hi₁ H
| 1, H := homotopy.Hi₀ H
end

def homotopy_dir.mk (ε : endpoint) {x y : C} {fε fεv : x ⟶ y}
  (H : I.obj x ⟶ y) (Hiε : H ∘ i ε @> x = fε) (Hiεv : H ∘ i ε.v @> x = fεv) :
  homotopy_dir ε fε fεv :=
match ε, H, Hiε, Hiεv with
| 0, H, Hiε, Hiεv := { H := H, Hi₀ := Hiε, Hi₁ := Hiεv }
| 1, H, Hiε, Hiεv := { H := H, Hi₀ := Hiεv, Hi₁ := Hiε }
end

end dir

-- The homotopy relation with respect to the given cylinder functor.
def homotopic {x y : C} (f₀ f₁ : x ⟶ y) : Prop := nonempty (homotopy f₀ f₁)

notation f₀ ` ≃ `:50 f₁:50 := homotopic f₀ f₁

@[refl] lemma homotopic.refl {x y : C} (f : x ⟶ y) : f ≃ f :=
⟨homotopy.refl f⟩

lemma homotopic.congr_left {x y y' : C} (g : y ⟶ y') {f₀ f₁ : x ⟶ y} (h : f₀ ≃ f₁) :
  g ∘ f₀ ≃ g ∘ f₁ :=
let ⟨H⟩ := h in ⟨H.congr_left g⟩

lemma homotopic.congr_right {x' x y : C} (g : x' ⟶ x) {f₀ f₁ : x ⟶ y} (h : f₀ ≃ f₁) :
  f₀ ∘ g ≃ f₁ ∘ g :=
let ⟨H⟩ := h in ⟨H.congr_right g⟩

-- The relation of being homotopic rel a fixed map j : A → X.
def homotopic_rel {a x y : C} (j : a ⟶ x) (f₀ f₁ : x ⟶ y) : Prop :=
∃ H : homotopy f₀ f₁, H.is_rel j

notation f₀ ` ≃ `:50 f₁:50 ` rel `:50 j:50 := homotopic_rel j f₀ f₁

@[refl] lemma homotopic_rel.refl {a x y : C} {j : a ⟶ x} (f : x ⟶ y) : f ≃ f rel j :=
⟨homotopy.refl f, homotopy.refl_is_rel⟩

lemma homotopic_rel.congr_left {a x y y' : C} {j : a ⟶ x} (g : y ⟶ y') {f₀ f₁ : x ⟶ y} :
  f₀ ≃ f₁ rel j → g ∘ f₀ ≃ g ∘ f₁ rel j :=
assume ⟨H, h⟩, ⟨H.congr_left g, homotopy.congr_left_is_rel g h⟩

lemma homotopic_rel.congr_right {a x' x y : C} {j' : a ⟶ x'} (g : x' ⟶ x) {f₀ f₁ : x ⟶ y} :
  f₀ ≃ f₁ rel (g ∘ j') → f₀ ∘ g ≃ f₁ ∘ g rel j' :=
assume ⟨H, h⟩, ⟨H.congr_right g, homotopy.congr_right_is_rel g h⟩

lemma homotopic_rel.forget_rel {a x y : C} {j : a ⟶ x} {f₀ f₁ : x ⟶ y} : f₀ ≃ f₁ rel j → f₀ ≃ f₁ :=
assume ⟨H, h⟩, ⟨H⟩

lemma homotopic_rel_initial {a x y : C} (Iai : Is_initial_object.{v} (I.obj a))
  (j : a ⟶ x) (f₀ f₁ : x ⟶ y) : (f₀ ≃ f₁ rel j) = (f₀ ≃ f₁) :=
propext $ iff.intro
  (assume ⟨H, _⟩, ⟨H⟩)
  (assume ⟨H⟩, ⟨H, H.is_rel_initial Iai⟩)

end homotopy_theory.cylinder


import Mathlib.Tactic.Basic
import Mathlib.Tactic.Cases
import Mathlib.Init.Data.Nat.Basic

/-!
## Structures

Lean provides a convenient syntax for defining records, or _structures_ as they are
also called. These are essentially nonrecursive, single-constructor inductive types,
but with some syntactic sugar.

The definition below introduces a structure called `rgb` with three fields of type
Nat called `red`, `green`, and `blue`:
-/
structure rgb where
  (red green blue : ℕ)
  deriving Repr
/-!
The additional `deriving Repr` clause tells Lean to automatically generate a
`repr` function for this structure so that `#eval` can print the structure.

This definition has roughly the same effect as the following commands:
-/
inductive rgb₁ : Type
| mk : ℕ → ℕ → ℕ → rgb₁

def rgb₁.red : rgb₁ → ℕ
| (rgb₁.mk r _ _) => r

def rgb₁.green : rgb₁ → ℕ
| (rgb₁.mk _ g _) => g

def rgb₁.blue : rgb₁ → ℕ
| (rgb₁.mk _ _ b) => b

/-!
We can define a new structure as the extension of an existing structure. The
definition below extends `rgb` with a fourth field, called `alpha`:
-/
structure rgba extends rgb where
  (alpha : ℕ)
  deriving Repr
/-!
The general syntax to define structures is
```lean
structure structure-name (params₁ : type₁) . . . (paramsₖ : typeₖ )
  [extends structure₁, . . ., structureₘ] where
  [constructor ::]
  <fields>
```
Where each fields is either
```
(field-names₁ : field-type₁) ... (field-namesₙ : field-typeₙ)
```
Or one field per line where you can drop the parens:
```
  field-names₁ : field-type₁
  ...
  field-namesₙ : field-typeₙ
```
So `rgb` can also be defined like this:
-/
structure rgb₂ where
  red : ℕ
  green : ℕ
  blue : ℕ
/-!
The parameters `params₁, . . . , paramsₖ` are effectively additional fields, but unlike
the fields `field-names₁, . . . , field-namesₙ`, they are also stored in the type, as
arguments to the type constructor (structure-name).

Values can be created using a variety of syntaxes:
-/
def black : rgb := rgb.mk 0 0 0
/-!
Notice the structure has a default constructor named 'mk'.  You can rename this by
providing a name before the fields followed by `::` then the fields, for example:
-/
structure rgb₃ where
  foo :: (red green blue : ℕ)
  deriving Repr

#eval rgb₃.foo 1 2 3 -- { red := 1, green := 2, blue := 3 }
/-!

The special brackets `⟨ ... ⟩` is general notation that means call the default constructor,
and in this case there is only one contructor, so it knows what to do:
-/
def red : rgb := ⟨255, 0, 0⟩
def red₃ : rgb₃ := ⟨255, 0, 0⟩
/-!
You can also construct object using an object syntax where you name the fields:
-/
def green  : rgb := { red := 0, green := 255, blue := 0 }

def blue  : rgb := { black with blue := 255 }

def yellow := { red := 255, green := 255, blue := 0 : rgb }

def semitransparent_red : rgba := { red with alpha := 0x7f }
/-!

Notice that the `with` clause allows you to copy the values from another object and override
just a subset of fields that you want to change and this works with base types
as shown in `semitransparent_red`.

Values can be also extracted using dot notation:
-/
#eval yellow.green   -- 255
/-!
Next, we define an operation called shuffle:
-/
def shuffle (c : rgb) := {
  c with
    red := c.green,
    green := c.blue,
    blue := c.red
}

#eval shuffle yellow  -- { red := 255, green := 0, blue := 255 }
/-!
Applying shuffle three times in a row is the same as not applying it at all:
-/
lemma shuffle_shuffle_shuffle (c : rgb) :
  shuffle (shuffle (shuffle c)) = c := by
    cases c
    rfl

/-!
The proof relies on the `cases` tactic, a close relative of `induction`. It performs a
case distinction on its argument, but it does not generate induction hypotheses.
For `rgb`, the invocation `cases c` transforms a goal `⊢ P[c]` into a subgoal
`r g b : ℕ ⊢ P[rgb.mk r g b]`. We could also have used `induction c`.

In a structured proof, we can use `match` expressions to perform a case distinction.
For example:
-/
lemma shuffle_shuffle_shuffle₂ (c : rgb) :
  shuffle (shuffle (shuffle c)) = c :=
  match c with
  | rgb.mk _ _ _ => Eq.refl _

/-!
Recall from [Section 2.4](../BackwardProofs/Equality.lean.md) that `Eq.refl` is the property
`∀a, a = a`.
-/


import data.fintype.basic
import category_theory.Fintype

open_locale classical

universe u

-- This is an awkward hybrid: we should state the induction principle for unbundled fintype
-- and then if it is necessary provide an interface for using it with `Fintype`.

lemma Fintype.induction_empty_sum {P : Fintype.{u} → Prop}
  (of_equiv : ∀ {α β : Fintype.{u}}, α ≃ β → P α → P β)
  (h_empty : P (Fintype.of pempty))
  (h_option : ∀ {α : Fintype.{u}}, P α → P (Fintype.of (α ⊕ (punit : Type u))))
  (α : Fintype.{u}) : P α :=
begin
  let Q : Π (α : Type u) [fintype α], Prop := λ a h, P ⟨a,h⟩,
  have H := @fintype.induction_empty_option' Q _ _ _ α α.str,
  { cases α, exact H },
  { introsI α β _ e h,
    haveI : fintype α := fintype.of_equiv _ e.symm,
    let e' : Fintype.of α ≃ Fintype.of β := e,
    apply of_equiv e',
    convert h },
  { assumption },
  { introsI α _ h,
    let e : option α ≃ α ⊕ (punit : Type u) := equiv.option_equiv_sum_punit _,
    let e' : Fintype.of (option α) ≃ Fintype.of (α ⊕ punit) := e,
    apply of_equiv e'.symm,
    exact h_option h }
end


/-
Copyright (c) 2018 Kenny Lau. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kenny Lau, Mario Carneiro, Johan Commelin, Amelia Livingston, Anne Baanen
-/
import ring_theory.localization.away
import ring_theory.localization.fraction_ring
import ring_theory.localization.integer
import ring_theory.unique_factorization_domain

/-!
# Numerator and denominator in a localization

## Implementation notes

-- See `src/ring_theory/localization/basic.lean` for a design overview.

-- ## Tags
-- localization, ring localization, commutative ring localization, characteristic predicate,
-- commutative ring, field of fractions
-- -/
-- variables {R : Type*} [comm_ring R] (M : submonoid R) {S : Type*} [comm_ring S]
-- variables [algebra R S] {P : Type*} [comm_ring P]

-- namespace is_fraction_ring

-- open is_localization

-- section num_denom

-- variables (A : Type*) [comm_ring A] [is_domain A] [unique_factorization_monoid A]
-- variables {K : Type*} [field K] [algebra A K] [is_fraction_ring A K]

-- lemma exists_reduced_fraction (x : K) :
--   ∃ (a : A) (b : non_zero_divisors A),
--   (∀ {d}, d ∣ a → d ∣ b → is_unit d) ∧ mk' K a b = x :=
-- begin
--   obtain ⟨⟨b, b_nonzero⟩, a, hab⟩ := exists_integer_multiple (non_zero_divisors A) x,
--   obtain ⟨a', b', c', no_factor, rfl, rfl⟩ :=
--     unique_factorization_monoid.exists_reduced_factors' a b
--       (mem_non_zero_divisors_iff_ne_zero.mp b_nonzero),
--   obtain ⟨c'_nonzero, b'_nonzero⟩ := mul_mem_non_zero_divisors.mp b_nonzero,
--   refine ⟨a', ⟨b', b'_nonzero⟩, @no_factor, _⟩,
--   refine mul_left_cancel₀
--     (is_fraction_ring.to_map_ne_zero_of_mem_non_zero_divisors b_nonzero) _,
--   simp only [subtype.coe_mk, ring_hom.map_mul, algebra.smul_def] at *,
--   erw [←hab, mul_assoc, mk'_spec' _ a' ⟨b', b'_nonzero⟩],
-- end

-- /-- `f.num x` is the numerator of `x : f.codomain` as a reduced fraction. -/
-- noncomputable def num (x : K) : A :=
-- classical.some (exists_reduced_fraction A x)

-- /-- `f.num x` is the denominator of `x : f.codomain` as a reduced fraction. -/
-- noncomputable def denom (x : K) : non_zero_divisors A :=
-- classical.some (classical.some_spec (exists_reduced_fraction A x))

-- lemma num_denom_reduced (x : K) {d} : d ∣ num A x → d ∣ denom A x → is_unit d :=
-- (classical.some_spec (classical.some_spec (exists_reduced_fraction A x))).1

-- @[simp] lemma mk'_num_denom (x : K) : mk' K (num A x) (denom A x) = x :=
-- (classical.some_spec (classical.some_spec (exists_reduced_fraction A x))).2

-- variables {A}

-- lemma num_mul_denom_eq_num_iff_eq {x y : K} :
--   x * algebra_map A K (denom A y) = algebra_map A K (num A y) ↔ x = y :=
-- ⟨λ h, by simpa only [mk'_num_denom] using eq_mk'_iff_mul_eq.mpr h,
--  λ h, eq_mk'_iff_mul_eq.mp (by rw [h, mk'_num_denom])⟩

-- lemma num_mul_denom_eq_num_iff_eq' {x y : K} :
--   y * algebra_map A K (denom A x) = algebra_map A K (num A x) ↔ x = y :=
-- ⟨λ h, by simpa only [eq_comm, mk'_num_denom] using eq_mk'_iff_mul_eq.mpr h,
--  λ h, eq_mk'_iff_mul_eq.mp (by rw [h, mk'_num_denom])⟩

-- lemma num_mul_denom_eq_num_mul_denom_iff_eq {x y : K} :
--   num A y * denom A x = num A x * denom A y ↔ x = y :=
-- ⟨λ h, by simpa only [mk'_num_denom] using mk'_eq_of_eq h,
--  λ h, by rw h⟩

-- lemma eq_zero_of_num_eq_zero {x : K} (h : num A x = 0) : x = 0 :=
-- num_mul_denom_eq_num_iff_eq'.mp (by rw [zero_mul, h, ring_hom.map_zero])

-- lemma is_integer_of_is_unit_denom {x : K} (h : is_unit (denom A x : A)) : is_integer A x :=
-- begin
--   cases h with d hd,
--   have d_ne_zero : algebra_map A K (denom A x) ≠ 0 :=
--     is_fraction_ring.to_map_ne_zero_of_mem_non_zero_divisors (denom A x).2,
--   use ↑d⁻¹ * num A x,
--   refine trans _ (mk'_num_denom A x),
--   rw [map_mul, map_units_inv, hd],
--   apply mul_left_cancel₀ d_ne_zero,
--   rw [←mul_assoc, mul_inv_cancel d_ne_zero, one_mul, mk'_spec']
-- end

-- lemma is_unit_denom_of_num_eq_zero {x : K} (h : num A x = 0) : is_unit (denom A x : A) :=
-- num_denom_reduced A x (h.symm ▸ dvd_zero _) dvd_rfl

-- end num_denom

-- -- variables (S)
universes u v

-- -- section away

-- -- variables {A : Type u} [decidable_eq A]
-- -- variables [cancel_comm_monoid_with_zero A] [normalization_monoid A] [unique_factorization_monoid A]
-- -- variables [dec_dvd : decidable_rel (has_dvd.dvd : A → A → Prop)]
-- -- variable {x : A}
-- -- variable (hx : irreducible x)
-- -- open multiplicity unique_factorization_monoid

-- -- end away

section away

open multiplicity unique_factorization_monoid is_localization

variables {A : Type u} [comm_ring A] [is_domain A] [decidable_eq A] [normalization_monoid A] [unique_factorization_monoid A]
variables [dec_dvd : decidable_rel (has_dvd.dvd : A → A → Prop)]
variable (x : A)

-- variable (n : ℕ)

-- #where

include dec_dvd

lemma uno_remarkable (a₀ : A) (h : a₀ ≠ 0) [nontrivial A] (hx : irreducible x) :
  ∃ n : ℕ, ∃ a : A, ¬ x ∣ a ∧ a₀ = x ^ n * a :=
begin
  let n := (normalized_factors a₀).count (normalize x),
  obtain ⟨a, ha1, ha2⟩ := (@exists_eq_pow_mul_and_not_dvd A _ _ x a₀
    (ne_top_iff_finite.mp (part_enat.ne_top_iff.mpr _))),
  simp_rw [← (multiplicity_eq_count_normalized_factors hx h).symm] at ha1,
  use [n, a, ha2, ha1],
  use [n, (multiplicity_eq_count_normalized_factors hx h)],
end

-- lemma due_remarkable (a : A) (m n : ℕ) :
--   (mk' B a ⟨x^n, (submonoid.mem_powers_iff (x^n) x).mpr ⟨n, rfl⟩⟩) =
--   (mk' B (a * x^m) ⟨x^(n), (submonoid.mem_powers_iff (x^n) x).mpr ⟨n, rfl⟩⟩) :=
-- begin
-- sorry
-- end

-- include x

-- noncomputable def inv_self.unit : Bˣ :=
--   ⟨away.inv_self x, algebra_map _ _ x, by {rw mul_comm, exact away.mul_inv_self _},
--     away.mul_inv_self _⟩

variables (B : Type v) [comm_ring B] [algebra A B] [is_localization.away x B]
variable (hx' : irreducible x)

noncomputable def self_as_unit : Bˣ :=
  ⟨algebra_map _ _ x, away.inv_self x, away.mul_inv_self _,
    by {rw mul_comm, exact away.mul_inv_self _}⟩

lemma due_remarkable' (a : A) (b : B) (m d : ℤ) :
  (((self_as_unit x B ^ (m - d)) : Bˣ ) : B) * mk' B a (1 : submonoid.powers x) = b ↔
  (((self_as_unit x B ^ m) : Bˣ) : B) * mk' B a (1 : submonoid.powers x) =
    (((self_as_unit x B ^ d) : Bˣ) : B) * b := by {simp only [zpow_sub, units.coe_mul,
    mul_comm (((self_as_unit x B ^ m) : Bˣ) : B) _,  mul_assoc, units.inv_mul_eq_iff_eq_mul]}

lemma aux (d : ℕ) : (((self_as_unit x B)^(d : ℤ) : Bˣ) : B) = (algebra_map A B x)^d :=
  by {simp only [self_as_unit, zpow_coe_nat, units.coe_pow, units.coe_mk]}

include hx'

lemma exists_reduced_fraction (b : B) (hb : b ≠ 0) :
  ∃ (a : A) (n : ℤ), ¬ x ∣ a ∧
  (((self_as_unit x B)^n : Bˣ) : B) * mk' B a (1 : submonoid.powers x) = b :=
  -- (mk' B a (1 : (submonoid.powers x))) * (((away.inv_self x) : Bˣ ) : B)= b :=
  -- (∀ {d}, d ∣ a → d ∣ b → is_unit d) ∧ mk' K a b = x :=
begin
  obtain ⟨⟨a₀, y⟩, H⟩ := is_localization.surj (submonoid.powers x) b,
  obtain ⟨d, hy⟩ := (submonoid.mem_powers_iff y.1 x).mp y.2,
    have ha₀ : a₀ ≠ 0,
    { --have : (y : A) ≠ 0,
      -- rw coe_zero,
      -- by_contra,
      have h_inj := @is_localization.injective A _ (submonoid.powers x) B _ _ _
        (powers_le_non_zero_divisors_of_no_zero_divisors (hx'.ne_zero)),
      haveI := @is_domain_of_le_non_zero_divisors B _ A _ _ _ (submonoid.powers x) _
       (powers_le_non_zero_divisors_of_no_zero_divisors hx'.ne_zero),
      simp only [map_zero, ← subtype.val_eq_coe, ← hy, map_pow] at H,
      apply ((injective_iff_map_eq_zero' (algebra_map A B)).mp (h_inj) a₀).mpr.mt,
      rw ← H,
      apply mul_ne_zero hb,
      apply pow_ne_zero,
      apply @is_localization.to_map_ne_zero_of_mem_non_zero_divisors
        A _ (submonoid.powers x) B _ _ _ _ _ x _,
      apply powers_le_non_zero_divisors_of_no_zero_divisors (hx'.ne_zero),
      exact mem_non_zero_divisors_iff_ne_zero.mpr hx'.ne_zero,
    },
    simp only [← subtype.val_eq_coe, ← hy] at H,--needed?
    obtain ⟨m, a, hyp1, hyp2⟩ := uno_remarkable x a₀ ha₀ hx',
    use a,
    use m - d,
    rw due_remarkable' x B a b m d, --replace?
    rw [aux x B d, mul_comm _ b, ← map_pow, H, hyp2, aux x B m,
      map_mul, map_pow],
    -- rw [due_remarkable' x B a b m d, aux x B d, mul_comm _ b, ← map_pow, H, hyp2, aux x B m,
    --   map_mul, map_pow],
    exact ⟨hyp1, (congr_arg _ (is_localization.mk'_one _ _))⟩,
end

end away


-- Copyright 2022-2023 VMware, Inc.
-- SPDX-License-Identifier: BSD-2-Clause

import .relational
import .incremental

open zset

variables {A B C: Type}.
variables [decidable_eq A] [decidable_eq B] [decidable_eq C].

def distinct_H_at (i d: Z[A]) : A → ℤ :=
  λ x, if 0 < i x ∧ (i + d) x ≤ 0
       then -1 else
        if i x ≤ 0 ∧ 0 < (i + d) x
        then 1 else 0.

def distinct_H (i d: Z[A]) : Z[A] :=
  dfinsupp.mk (i.support ∪ d.support)
    (λ x, distinct_H_at i d x).

@[simp]
lemma distinct_H_apply (i d: Z[A]) (x: A) :
  distinct_H i d x = distinct_H_at i d x :=
begin
  unfold distinct_H, simp,
  push_neg,
  intros h, cases h with h1 h2,
  simp [distinct_H_at], rw [h1, h2],
  rw [if_neg, if_neg]; simp,
end

def distinct_incremental : stream Z[A] → stream Z[A] :=
  λ d, (↑² distinct_H) (z⁻¹ (I d)) d.

theorem distinct_incremental_ok :
  (↑↑ distinct)^Δ = @distinct_incremental A _ :=
begin
  funext d,
  unfold incremental distinct_incremental,
  unfold D,
  conv_lhs {
    congr, { rw integral_unfold, skip}, { skip }
  },
  rw<- lifting_time_invariant, swap, simp,
  repeat { rw<- integral_time_invariant },
  ext t a, unfold lifting2, simp,
  generalize hi : I (z⁻¹ d) t = i,
  generalize hd : d t = d_t,
  clear hi hd d t,
  unfold distinct_H_at,
  simp,
  -- canonicalize the tests a little bit so splitting produces fewer cases
  rw (add_comm (i a) (d_t a)),
  repeat { rw <- ite_ite },
  split_ifs; refl <|> { exfalso, omega },
end

@[simp]
lemma flatmap_incremental (f: A → Z[B]) :
  ↑↑(zset.flatmap f)^Δ = ↑↑(zset.flatmap f) :=
begin
  apply lti_incremental,
  apply lifting_lti,
  apply flatmap_linear,
end

@[simp]
lemma map_incremental (f: A → B) :
  ↑↑(zset.map f)^Δ = ↑↑(zset.map f) :=
  flatmap_incremental _.

@[simp]
lemma lifting_map_incremental {A B} [decidable_eq A] [decidable_eq B] (f: A → B) :
  ↑↑(↑↑(zset.map f))^Δ = ↑↑(↑↑(zset.map f)) :=
begin
  rw lti_incremental,
  apply lifting_lti,
  intros x y, rw lifting_linear, apply map_linear,
end

@[simp]
lemma map_incremental_unfolded (f: A → B) (s: stream Z[A]) :
  D (↑↑(zset.map f) (I s)) = ↑↑(zset.map f) s :=
begin
  conv_rhs {
    rw<- map_incremental,
  },
  rw incremental_unfold,
end

theorem equi_join_incremental (π1: A → C) (π2: B → C) :
  ↑²(equi_join π1 π2)^Δ2 =
    times_incremental ↑²(equi_join π1 π2) :=
begin
  rw (bilinear_incremental (↑²(equi_join π1 π2))),
  { rw lifting2_time_invariant,
    refl, },
  { apply lifting_bilinear,
    apply equi_join_bilinear,
  },
end

@[simp]
lemma filter_incremental (p: A → Prop) [decidable_pred p] :
  ↑↑(filter p)^Δ = ↑↑(filter p) :=
begin
  apply lti_incremental,
  apply lifting_lti,
  apply filter_linear,
end


/-
Copyright (c) 2022 Jujian Zhang. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Jujian Zhang, Eric Wieser

! This file was ported from Lean 3 source module ring_theory.graded_algebra.radical
! leanprover-community/mathlib commit f1944b30c97c5eb626e498307dec8b022a05bd0a
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.RingTheory.GradedAlgebra.HomogeneousIdeal

/-!

This file contains a proof that the radical of any homogeneous ideal is a homogeneous ideal

## Main statements

* `ideal.is_homogeneous.is_prime_iff`: for any `I : ideal A`, if `I` is homogeneous, then
  `I` is prime if and only if `I` is homogeneously prime, i.e. `I ≠ ⊤` and if `x, y` are
  homogeneous elements such that `x * y ∈ I`, then at least one of `x,y` is in `I`.
* `ideal.is_prime.homogeneous_core`: for any `I : ideal A`, if `I` is prime, then
  `I.homogeneous_core 𝒜` (i.e. the largest homogeneous ideal contained in `I`) is also prime.
* `ideal.is_homogeneous.radical`: for any `I : ideal A`, if `I` is homogeneous, then the
  radical of `I` is homogeneous as well.
* `homogeneous_ideal.radical`: for any `I : homogeneous_ideal 𝒜`, `I.radical` is the the
  radical of `I` as a `homogeneous_ideal 𝒜`

## Implementation details

Throughout this file, the indexing type `ι` of grading is assumed to be a
`linear_ordered_cancel_add_comm_monoid`. This might be stronger than necessary but cancelling
property is strictly necessary; for a counterexample of how `ideal.is_homogeneous.is_prime_iff`
fails for a non-cancellative set see `counterexample/homogeneous_prime_not_prime.lean`.

## Tags

homogeneous, radical
-/

open GradedRing DirectSum SetLike Finset

open BigOperators

variable {ι σ A : Type _}

variable [CommRing A]

variable [LinearOrderedCancelAddCommMonoid ι]

variable [SetLike σ A] [AddSubmonoidClass σ A] {𝒜 : ι → σ} [GradedRing 𝒜]

include A

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
theorem Ideal.IsHomogeneous.isPrime_of_homogeneous_mem_or_mem {I : Ideal A} (hI : I.Homogeneous 𝒜)
    (I_ne_top : I ≠ ⊤)
    (homogeneous_mem_or_mem :
      ∀ {x y : A}, Homogeneous 𝒜 x → Homogeneous 𝒜 y → x * y ∈ I → x ∈ I ∨ y ∈ I) :
    Ideal.IsPrime I :=
  ⟨I_ne_top, by
    intro x y hxy
    by_contra rid
    obtain ⟨rid₁, rid₂⟩ := not_or_distrib.mp rid
    classical
      /-
        The idea of the proof is the following :
        since `x * y ∈ I` and `I` homogeneous, then `proj i (x * y) ∈ I` for any `i : ι`.
        Then consider two sets `{i ∈ x.support | xᵢ ∉ I}` and `{j ∈ y.support | yⱼ ∉ J}`;
        let `max₁, max₂` be the maximum of the two sets, then `proj (max₁ + max₂) (x * y) ∈ I`.
        Then, `proj max₁ x ∉ I` and `proj max₂ j ∉ I`
        but `proj i x ∈ I` for all `max₁ < i` and `proj j y ∈ I` for all `max₂ < j`.
        `  proj (max₁ + max₂) (x * y)`
        `= ∑ {(i, j) ∈ supports | i + j = max₁ + max₂}, xᵢ * yⱼ`
        `= proj max₁ x * proj max₂ y`
        `  + ∑ {(i, j) ∈ supports \ {(max₁, max₂)} | i + j = max₁ + max₂}, xᵢ * yⱼ`.
        This is a contradiction, because both `proj (max₁ + max₂) (x * y) ∈ I` and the sum on the
        right hand side is in `I` however `proj max₁ x * proj max₂ y` is not in `I`.
        -/
      set set₁ := (decompose 𝒜 x).support.filterₓ fun i => proj 𝒜 i x ∉ I with set₁_eq
      set set₂ := (decompose 𝒜 y).support.filterₓ fun i => proj 𝒜 i y ∉ I with set₂_eq
      have nonempty :
        ∀ x : A, x ∉ I → ((decompose 𝒜 x).support.filterₓ fun i => proj 𝒜 i x ∉ I).Nonempty :=
        by
        intro x hx
        rw [filter_nonempty_iff]
        contrapose! hx
        simp_rw [proj_apply] at hx
        rw [← sum_support_decompose 𝒜 x]
        exact Ideal.sum_mem _ hx
      set max₁ := set₁.max' (Nonempty x rid₁) with max₁_eq
      set max₂ := set₂.max' (Nonempty y rid₂) with max₂_eq
      have mem_max₁ : max₁ ∈ set₁ := max'_mem set₁ (Nonempty x rid₁)
      have mem_max₂ : max₂ ∈ set₂ := max'_mem set₂ (Nonempty y rid₂)
      replace hxy : proj 𝒜 (max₁ + max₂) (x * y) ∈ I := hI _ hxy
      have mem_I : proj 𝒜 max₁ x * proj 𝒜 max₂ y ∈ I :=
        by
        set antidiag :=
          ((decompose 𝒜 x).support ×ˢ (decompose 𝒜 y).support).filterₓ fun z : ι × ι =>
            z.1 + z.2 = max₁ + max₂ with
          ha
        have mem_antidiag : (max₁, max₂) ∈ antidiag :=
          by
          simp only [add_sum_erase, mem_filter, mem_product]
          exact ⟨⟨mem_of_mem_filter _ mem_max₁, mem_of_mem_filter _ mem_max₂⟩, rfl⟩
        have eq_add_sum :=
          calc
            proj 𝒜 (max₁ + max₂) (x * y) = ∑ ij in antidiag, proj 𝒜 ij.1 x * proj 𝒜 ij.2 y := by
              simp_rw [ha, proj_apply, DirectSum.decompose_mul, DirectSum.coe_mul_apply 𝒜]
            _ =
                proj 𝒜 max₁ x * proj 𝒜 max₂ y +
                  ∑ ij in antidiag.erase (max₁, max₂), proj 𝒜 ij.1 x * proj 𝒜 ij.2 y :=
              (add_sum_erase _ _ mem_antidiag).symm

        rw [eq_sub_of_add_eq eq_add_sum.symm]
        refine' Ideal.sub_mem _ hxy (Ideal.sum_mem _ fun z H => _)
        rcases z with ⟨i, j⟩
        simp only [mem_erase, Prod.mk.inj_iff, Ne.def, mem_filter, mem_product] at H
        rcases H with ⟨H₁, ⟨H₂, H₃⟩, H₄⟩
        have max_lt : max₁ < i ∨ max₂ < j :=
          by
          rcases lt_trichotomy max₁ i with (h | rfl | h)
          · exact Or.inl h
          · refine' False.elim (H₁ ⟨rfl, add_left_cancel H₄⟩)
          · apply Or.inr
            have := add_lt_add_right h j
            rw [H₄] at this
            exact lt_of_add_lt_add_left this
        cases max_lt
        · -- in this case `max₁ < i`, then `xᵢ ∈ I`; for otherwise `i ∈ set₁` then `i ≤ max₁`.
          have not_mem : i ∉ set₁ := fun h =>
            lt_irrefl _ ((max'_lt_iff set₁ (Nonempty x rid₁)).mp max_lt i h)
          rw [set₁_eq] at not_mem
          simp only [not_and, Classical.not_not, Ne.def, mem_filter] at not_mem
          exact Ideal.mul_mem_right _ I (not_mem H₂)
        · -- in this case  `max₂ < j`, then `yⱼ ∈ I`; for otherwise `j ∈ set₂`, then `j ≤ max₂`.
          have not_mem : j ∉ set₂ := fun h =>
            lt_irrefl _ ((max'_lt_iff set₂ (Nonempty y rid₂)).mp max_lt j h)
          rw [set₂_eq] at not_mem
          simp only [not_and, Classical.not_not, Ne.def, mem_filter] at not_mem
          exact Ideal.mul_mem_left I _ (not_mem H₃)
      have not_mem_I : proj 𝒜 max₁ x * proj 𝒜 max₂ y ∉ I :=
        by
        have neither_mem : proj 𝒜 max₁ x ∉ I ∧ proj 𝒜 max₂ y ∉ I :=
          by
          rw [mem_filter] at mem_max₁ mem_max₂
          exact ⟨mem_max₁.2, mem_max₂.2⟩
        intro rid
        cases homogeneous_mem_or_mem ⟨max₁, SetLike.coe_mem _⟩ ⟨max₂, SetLike.coe_mem _⟩ mem_I
        · apply neither_mem.1 h
        · apply neither_mem.2 h
      exact not_mem_I mem_I⟩
#align ideal.is_homogeneous.is_prime_of_homogeneous_mem_or_mem Ideal.IsHomogeneous.isPrime_of_homogeneous_mem_or_mem

theorem Ideal.IsHomogeneous.isPrime_iff {I : Ideal A} (h : I.Homogeneous 𝒜) :
    I.IsPrime ↔
      I ≠ ⊤ ∧
        ∀ {x y : A},
          SetLike.Homogeneous 𝒜 x → SetLike.Homogeneous 𝒜 y → x * y ∈ I → x ∈ I ∨ y ∈ I :=
  ⟨fun HI => ⟨ne_of_apply_ne _ HI.ne_top, fun x y hx hy hxy => Ideal.IsPrime.mem_or_mem HI hxy⟩,
    fun ⟨I_ne_top, homogeneous_mem_or_mem⟩ =>
    h.isPrime_of_homogeneous_mem_or_mem I_ne_top @homogeneous_mem_or_mem⟩
#align ideal.is_homogeneous.is_prime_iff Ideal.IsHomogeneous.isPrime_iff

theorem Ideal.IsPrime.homogeneousCore {I : Ideal A} (h : I.IsPrime) :
    (I.homogeneousCore 𝒜).toIdeal.IsPrime :=
  by
  apply (Ideal.homogeneousCore 𝒜 I).Homogeneous.isPrime_of_homogeneous_mem_or_mem
  · exact ne_top_of_le_ne_top h.ne_top (Ideal.toIdeal_homogeneousCore_le 𝒜 I)
  rintro x y hx hy hxy
  have H := h.mem_or_mem (Ideal.toIdeal_homogeneousCore_le 𝒜 I hxy)
  refine' H.imp _ _
  · exact Ideal.mem_homogeneousCore_of_homogeneous_of_mem hx
  · exact Ideal.mem_homogeneousCore_of_homogeneous_of_mem hy
#align ideal.is_prime.homogeneous_core Ideal.IsPrime.homogeneousCore

theorem Ideal.IsHomogeneous.radical_eq {I : Ideal A} (hI : I.Homogeneous 𝒜) :
    I.radical = infₛ { J | J.Homogeneous 𝒜 ∧ I ≤ J ∧ J.IsPrime } :=
  by
  rw [Ideal.radical_eq_infₛ]
  apply le_antisymm
  · exact infₛ_le_infₛ fun J => And.right
  · refine' infₛ_le_infₛ_of_forall_exists_le _
    rintro J ⟨HJ₁, HJ₂⟩
    refine' ⟨(J.homogeneous_core 𝒜).toIdeal, _, J.to_ideal_homogeneous_core_le _⟩
    refine' ⟨HomogeneousIdeal.isHomogeneous _, _, HJ₂.homogeneous_core⟩
    refine' hI.to_ideal_homogeneous_core_eq_self.symm.trans_le (Ideal.homogeneousCore_mono _ HJ₁)
#align ideal.is_homogeneous.radical_eq Ideal.IsHomogeneous.radical_eq

theorem Ideal.IsHomogeneous.radical {I : Ideal A} (h : I.Homogeneous 𝒜) : I.radical.Homogeneous 𝒜 :=
  by
  rw [h.radical_eq]
  exact Ideal.IsHomogeneous.inf fun _ => And.left
#align ideal.is_homogeneous.radical Ideal.IsHomogeneous.radical

/-- The radical of a homogenous ideal, as another homogenous ideal. -/
def HomogeneousIdeal.radical (I : HomogeneousIdeal 𝒜) : HomogeneousIdeal 𝒜 :=
  ⟨I.toIdeal.radical, I.Homogeneous.radical⟩
#align homogeneous_ideal.radical HomogeneousIdeal.radical

@[simp]
theorem HomogeneousIdeal.coe_radical (I : HomogeneousIdeal 𝒜) :
    I.radical.toIdeal = I.toIdeal.radical :=
  rfl
#align homogeneous_ideal.coe_radical HomogeneousIdeal.coe_radical


import unitb.code.syntax

section finite

open nat

parameters (σ : Type) {lbl : Type}

private def pred := σ → Prop

parameters {σ}

def control_nodes : Π {p q : pred}, code lbl p q → ℕ
  | ._ ._ (code.skip _) := 0
  | ._ ._ (code.action _ _ _ _) := 1
  | ._ ._ (@code.seq ._ ._ p q r c₀ c₁) := control_nodes c₀ + control_nodes c₁
  | ._ ._ (@code.if_then_else ._ ._ c pa pb q _ _ c₀ c₁) :=
     control_nodes c₀ + control_nodes c₁ + 1
  | ._ ._ (@code.while ._ ._ p inv q _ c b) :=
     control_nodes b + 1

def to_fin : Π {p q : pred} {c : code lbl p q}, current c → fin (control_nodes c)
  | ._ ._ ._ (current.action _ _ _ _) := ⟨0,zero_lt_one⟩
  | ._ ._ ._ (current.seq_left p q r c₀ c₁ pc) := fin.nest (to_fin pc)
  | ._ ._ ._ (current.seq_right p q r c₀ c₁ pc) := fin.shift (to_fin pc)
  | ._ ._ ._ (current.ite_cond p t pa pb _ q c₀ c₁) :=
    (fin.max : fin (succ $ _ + _))
  | ._ ._ ._ (current.ite_left p t pa pb q _ c₀ c₁ pc) :=
    (fin.nest $ fin.nest $ to_fin pc : fin (control_nodes c₀ + control_nodes c₁ + 1))
  | ._ ._ ._ (current.ite_right p t pa pb q _ c₀ c₁ pc) :=
    (fin.nest $ fin.shift $ to_fin pc : fin (control_nodes c₀ + control_nodes c₁ + 1))
  | ._ ._ ._ (current.while_cond p inv q _ w c) :=
    (fin.max : fin (control_nodes c + 1))
  | ._ ._ ._ (current.while_body p inv q _ w c pc) :=
    (fin.nest $ to_fin pc : fin (control_nodes c + 1))

def from_fin : Π {p q} (c : code lbl p q), fin (control_nodes c) → current c
  | ._ ._ (code.skip _) ⟨_,P⟩ := by cases (nat.not_lt_zero _ P)
  | ._ ._ (code.action p q _ l) _ := current.action p q _ l
  | ._ ._ (@code.seq ._ ._ p q r c₀ c₁) m :=
    match fin.split m with
     | (sum.inl n) := seq_left  c₁ $ from_fin c₀ n
     | (sum.inr n) := seq_right c₀ $ from_fin c₁ n
    end
  | ._ ._ (@code.if_then_else ._ ._ p pa pb q ds t c₀ c₁) n :=
    match (fin.split n : fin (control_nodes c₀ + control_nodes c₁) ⊕ fin 1) with
     | (sum.inl n') :=
        match (fin.split n' : fin (control_nodes c₀) ⊕ fin (control_nodes c₁)) with
         | (sum.inl n) := ite_left  _ _ _ c₁ $ from_fin c₀ n
         | (sum.inr n) := ite_right _ _ _ c₀ $ from_fin c₁ n
        end
     | (sum.inr _) := ite_cond p t ds c₀ c₁
    end
  | ._ ._ (@code.while ._ ._ p inv q _ t b) n :=
    match (fin.split n : fin (control_nodes b) ⊕ fin 1) with
     | (sum.inl n') := while_body q _ t $ from_fin b n'
     | (sum.inr _) := while_cond q _ t b
    end

section g_over_constr

lemma from_fin_eq_seq_left
  {p q r : pred}
  {c₀ : code lbl p q} {c₁ : code lbl q r}
  {n : fin (control_nodes c₀ + control_nodes c₁)}
  {k : fin (control_nodes c₀)}
  (Hk : fin.split n = sum.inl k)
:   from_fin (code.seq c₀ c₁) n
  = seq_left c₁ (from_fin c₀ k) :=
by { dunfold from_fin, simp [Hk], refl }

lemma from_fin_eq_seq_right
  {p q r : pred}
  {c₀ : code lbl p q} {c₁ : code lbl q r}
  {n : fin (control_nodes c₀ + control_nodes c₁)}
  {k : fin (control_nodes c₁)}
  (Hk : fin.split n = sum.inr k)
:   from_fin (code.seq c₀ c₁) n
  = seq_right c₀ (from_fin c₁ k) :=
by { dunfold from_fin, simp [Hk], refl }

lemma from_fin_eq_ite_left
  {p t pa pb q : pred}
  {ds : set lbl}
  {c₀ : code lbl pa q} {c₁ : code lbl pb q}
  {n  : fin (control_nodes c₀ + control_nodes c₁ + 1)}
  {k  : fin (control_nodes c₀ + control_nodes c₁)}
  {k' : fin (control_nodes c₀)}
  (Hk : fin.split n = sum.inl k)
  (Hk' : fin.split k = sum.inl k')
:   from_fin (if_then_else p ds t c₀ c₁) n
  = ite_left p t ds c₁ (from_fin c₀ k') :=
begin
  dunfold from_fin, simp [Hk],
  dunfold from_fin._match_2, simp [Hk'],
  refl,
end

lemma from_fin_eq_ite_right
  {p t pa pb q : pred}
  {ds : set lbl}
  {c₀ : code lbl pa q} {c₁ : code lbl pb q}
  {n  : fin (control_nodes c₀ + control_nodes c₁ + 1)}
  {k  : fin (control_nodes c₀ + control_nodes c₁)}
  {k' : fin (control_nodes c₁)}
  (Hk : fin.split n = sum.inl k)
  (Hk' : fin.split k = sum.inr k')
:   from_fin (if_then_else p ds t c₀ c₁) n
  = ite_right p t ds c₀ (from_fin c₁ k') :=
begin
  dunfold from_fin, simp [Hk],
  dunfold from_fin._match_2, simp [Hk'],
  refl,
end

lemma from_fin_eq_ite_cond
  {p t pa pb q : pred}
  {ds : set lbl}
  {c₀ : code lbl pa q} {c₁ : code lbl pb q}
  {n  : fin (control_nodes c₀ + control_nodes c₁ + 1)}
  {k  : fin 1}
  (Hk : fin.split n = sum.inr k)
:   from_fin (if_then_else p ds t c₀ c₁) n
  = ite_cond p t ds c₀ c₁ :=
by { dunfold from_fin, simp [Hk], refl }

lemma from_fin_eq_while_body
  {p t inv q : pred}
  {ds : set lbl}
  {c₀ : code lbl p inv}
  {n  : fin (control_nodes c₀ + 1)}
  {k  : fin $ control_nodes c₀}
  (Hk : fin.split n = sum.inl k)
:   from_fin (while q ds t c₀) n
  = while_body q ds t (from_fin c₀ k) :=
by { dunfold from_fin, simp [Hk], refl }

lemma from_fin_eq_while_cond
  {p t inv q : pred}
  {ds : set lbl}
  {c₀ : code lbl p inv}
  {n  : fin (control_nodes c₀ + 1)}
  {k  : fin 1}
  (Hk : fin.split n = sum.inr k)
:   from_fin (while q ds t c₀) n
  = while_cond q ds t c₀  :=
by { dunfold from_fin, simp [Hk], refl }

end g_over_constr

lemma from_fin_inv {p q} {c : code lbl p q} (n : fin (control_nodes c))
: to_fin (from_fin c n) = n :=
begin
  induction c
  ; dunfold control_nodes at n,
  { apply fin.elim0 n, },
  { dunfold from_fin to_fin
  ; apply fin.eq_of_veq,
    unfold fin.val,
    apply le_antisymm (zero_le _),
    apply le_of_lt_succ,
    apply n.is_lt },
  { destruct fin.split n
    ; intros k Hk,
    { rw [from_fin_eq_seq_left Hk], dunfold to_fin,
      rw [ih_1,fin.nest_eq_iff_eq_split,Hk], },
    { rw [from_fin_eq_seq_right Hk], dunfold to_fin,
      rw [ih_2,fin.shift_eq_iff_eq_split,Hk], }, },
  { destruct fin.split n
    ; intros k Hk,
    destruct fin.split k
    ; intros k' Hk',
    { rw [from_fin_eq_ite_left Hk Hk'], dunfold to_fin,
      simp [ih_1,fin.nest_eq_iff_eq_split,Hk],
      apply congr_arg,
      simp [fin.nest_eq_iff_eq_split,Hk'] },
    { rw [from_fin_eq_ite_right Hk Hk'], dunfold to_fin,
      simp [ih_2,fin.nest_eq_iff_eq_split,Hk],
      apply congr_arg,
      simp [fin.shift_eq_iff_eq_split,Hk'] },
    { rw [from_fin_eq_ite_cond Hk], dunfold to_fin,
      apply fin.split_injective _ n,
      simp [Hk,eq_comm],
      rw [← fin.shift_eq_iff_eq_split,fin.all_eq_zero k],
      apply fin.eq_of_veq, simp [fin.val_shift_zero], refl }, },
  { destruct fin.split n
    ; intros k Hk,
    { rw [from_fin_eq_while_body Hk], dunfold to_fin,
      rw [ih_1,fin.nest_eq_iff_eq_split,Hk], },
    { rw [from_fin_eq_while_cond Hk], dunfold to_fin,
      apply fin.split_injective _ n,
      simp [Hk,eq_comm],
      rw [← fin.shift_eq_iff_eq_split,fin.all_eq_zero k],
      apply fin.eq_of_veq, simp [fin.val_shift_zero], refl, }, }
end

lemma to_fin_inv {p q} {c : code lbl p q} (pc : current c)
: from_fin c (to_fin pc) = pc :=
begin
  induction pc
  ; dunfold to_fin
  ; try { refl },
  { dunfold from_fin, simp [fin.split_nest],
    dunfold from_fin._match_1,
    simp [ih_1] },
  { dunfold from_fin, simp [fin.split_shift],
    dunfold from_fin._match_1,
    simp [ih_1] },
  { dunfold from_fin, simp [fin.shift_zero,fin.split_shift],
    dunfold from_fin._match_2, refl },
  { dunfold from_fin, simp [fin.split_nest],
    dunfold from_fin._match_2,
    simp [fin.split_nest],
    dunfold from_fin._match_3,
    simp [ih_1] },
  { dunfold from_fin, simp [fin.split_nest],
    dunfold from_fin._match_2,
    simp [fin.split_shift],
    dunfold from_fin._match_3,
    simp [ih_1] },
  { dunfold from_fin,
    simp [fin.shift_zero,fin.split_shift],
    refl },
  { dunfold from_fin, simp [fin.split_nest],
    dunfold from_fin._match_4,
    simp [ih_1] },
end

instance current_finite {p q : pred} {c : code lbl p q} : finite (current c) :=
⟨ control_nodes c,
  bijection.mk to_fin (from_fin c) to_fin_inv from_fin_inv ⟩

instance current_sched {p q : pred} {c : code lbl p q} : scheduling.sched (current c) :=
scheduling.sched.fin (by apply_instance)

end finite


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

/-!
# Whiskering

Given a functor `F  : C ⥤ D` and functors `G H : D ⥤ E` and a natural transformation `α : G ⟶ H`,
we can construct a new natural transformation `F ⋙ G ⟶ F ⋙ H`,
called `whisker_left F α`. This is the same as the horizontal composition of `𝟙 F` with `α`.

This operation is functorial in `F`, and we package this as `whiskering_left`. Here
`(whiskering_left.obj F).obj G` is `F ⋙ G`, and
`(whiskering_left.obj F).map α` is `whisker_left F α`.
(That is, we might have alternatively named this as the "left composition functor".)

We also provide analogues for composition on the right, and for these operations on isomorphisms.

At the end of the file, we provide the left and right unitors, and the associator,
for functor composition.
(In fact functor composition is definitionally associative, but very often relying on this causes
extremely slow elaboration, so it is better to insert it explicitly.)
We also show these natural isomorphisms satisfy the triangle and pentagon identities.
-/

namespace category_theory

universes u₁ v₁ u₂ v₂ u₃ v₃ u₄ v₄

section
variables {C : Type u₁} [category.{v₁} C]
          {D : Type u₂} [category.{v₂} D]
          {E : Type u₃} [category.{v₃} E]

/--
If `α : G ⟶ H` then
`whisker_left F α : (F ⋙ G) ⟶ (F ⋙ H)` has components `α.app (F.obj X)`.
-/
@[simps] def whisker_left (F : C ⥤ D) {G H : D ⥤ E} (α : G ⟶ H) : (F ⋙ G) ⟶ (F ⋙ H) :=
{ app := λ X, α.app (F.obj X),
  naturality' := λ X Y f, by rw [functor.comp_map, functor.comp_map, α.naturality] }

/--
If `α : G ⟶ H` then
`whisker_right α F : (G ⋙ F) ⟶ (G ⋙ F)` has components `F.map (α.app X)`.
-/
@[simps] def whisker_right {G H : C ⥤ D} (α : G ⟶ H) (F : D ⥤ E) : (G ⋙ F) ⟶ (H ⋙ F) :=
{ app := λ X, F.map (α.app X),
  naturality' := λ X Y f,
    by rw [functor.comp_map, functor.comp_map, ←F.map_comp, ←F.map_comp, α.naturality] }

variables (C D E)

/--
Left-composition gives a functor `(C ⥤ D) ⥤ ((D ⥤ E) ⥤ (C ⥤ E))`.

`(whiskering_left.obj F).obj G` is `F ⋙ G`, and
`(whiskering_left.obj F).map α` is `whisker_left F α`.
-/
@[simps] def whiskering_left : (C ⥤ D) ⥤ ((D ⥤ E) ⥤ (C ⥤ E)) :=
{ obj := λ F,
  { obj := λ G, F ⋙ G,
    map := λ G H α, whisker_left F α },
  map := λ F G τ,
  { app := λ H,
    { app := λ c, H.map (τ.app c),
      naturality' := λ X Y f, begin dsimp, rw [←H.map_comp, ←H.map_comp, ←τ.naturality] end },
    naturality' := λ X Y f, begin ext, dsimp, rw [f.naturality] end } }

/--
Right-composition gives a functor `(D ⥤ E) ⥤ ((C ⥤ D) ⥤ (C ⥤ E))`.

`(whiskering_right.obj H).obj F` is `F ⋙ H`, and
`(whiskering_right.obj H).map α` is `whisker_right α H`.
-/
@[simps] def whiskering_right : (D ⥤ E) ⥤ ((C ⥤ D) ⥤ (C ⥤ E)) :=
{ obj := λ H,
  { obj := λ F, F ⋙ H,
    map := λ _ _ α, whisker_right α H },
  map := λ G H τ,
  { app := λ F,
    { app := λ c, τ.app (F.obj c),
      naturality' := λ X Y f, begin dsimp, rw [τ.naturality] end },
    naturality' := λ X Y f, begin ext, dsimp, rw [←nat_trans.naturality] end } }

variables {C} {D} {E}

@[simp] lemma whisker_left_id (F : C ⥤ D) {G : D ⥤ E} :
  whisker_left F (nat_trans.id G) = nat_trans.id (F.comp G) :=
rfl
@[simp] lemma whisker_left_id' (F : C ⥤ D) {G : D ⥤ E} :
  whisker_left F (𝟙 G) = 𝟙 (F.comp G) :=
rfl

@[simp] lemma whisker_right_id {G : C ⥤ D} (F : D ⥤ E) :
  whisker_right (nat_trans.id G) F = nat_trans.id (G.comp F) :=
((whiskering_right C D E).obj F).map_id _
@[simp] lemma whisker_right_id' {G : C ⥤ D} (F : D ⥤ E) :
  whisker_right (𝟙 G) F = 𝟙 (G.comp F) :=
((whiskering_right C D E).obj F).map_id _

@[simp] lemma whisker_left_comp (F : C ⥤ D) {G H K : D ⥤ E} (α : G ⟶ H) (β : H ⟶ K) :
  whisker_left F (α ≫ β) = (whisker_left F α) ≫ (whisker_left F β) :=
rfl

@[simp] lemma whisker_right_comp {G H K : C ⥤ D} (α : G ⟶ H) (β : H ⟶ K) (F : D ⥤ E)  :
  whisker_right (α ≫ β) F = (whisker_right α F) ≫ (whisker_right β F) :=
((whiskering_right C D E).obj F).map_comp α β

/--
If `α : G ≅ H` is a natural isomorphism then
`iso_whisker_left F α : (F ⋙ G) ≅ (F ⋙ H)` has components `α.app (F.obj X)`.
-/
def iso_whisker_left (F : C ⥤ D) {G H : D ⥤ E} (α : G ≅ H) : (F ⋙ G) ≅ (F ⋙ H) :=
((whiskering_left C D E).obj F).map_iso α
@[simp] lemma iso_whisker_left_hom (F : C ⥤ D) {G H : D ⥤ E} (α : G ≅ H) :
  (iso_whisker_left F α).hom = whisker_left F α.hom :=
rfl
@[simp] lemma iso_whisker_left_inv (F : C ⥤ D) {G H : D ⥤ E} (α : G ≅ H) :
  (iso_whisker_left F α).inv = whisker_left F α.inv :=
rfl

/--
If `α : G ≅ H` then
`iso_whisker_right α F : (G ⋙ F) ≅ (H ⋙ F)` has components `F.map_iso (α.app X)`.
-/
def iso_whisker_right {G H : C ⥤ D} (α : G ≅ H) (F : D ⥤ E) : (G ⋙ F) ≅ (H ⋙ F) :=
((whiskering_right C D E).obj F).map_iso α
@[simp] lemma iso_whisker_right_hom {G H : C ⥤ D} (α : G ≅ H) (F : D ⥤ E) :
  (iso_whisker_right α F).hom = whisker_right α.hom F :=
rfl
@[simp] lemma iso_whisker_right_inv {G H : C ⥤ D} (α : G ≅ H) (F : D ⥤ E) :
  (iso_whisker_right α F).inv = whisker_right α.inv F :=
rfl

instance is_iso_whisker_left (F : C ⥤ D) {G H : D ⥤ E} (α : G ⟶ H) [is_iso α] :
  is_iso (whisker_left F α) :=
is_iso.of_iso (iso_whisker_left F (as_iso α))
instance is_iso_whisker_right {G H : C ⥤ D} (α : G ⟶ H) (F : D ⥤ E) [is_iso α] :
  is_iso (whisker_right α F) :=
is_iso.of_iso (iso_whisker_right (as_iso α) F)

variables {B : Type u₄} [category.{v₄} B]

local attribute [elab_simple] whisker_left whisker_right

@[simp] lemma whisker_left_twice (F : B ⥤ C) (G : C ⥤ D) {H K : D ⥤ E} (α : H ⟶ K) :
  whisker_left F (whisker_left G α) = whisker_left (F ⋙ G) α :=
rfl

@[simp] lemma whisker_right_twice {H K : B ⥤ C} (F : C ⥤ D) (G : D ⥤ E) (α : H ⟶ K) :
  whisker_right (whisker_right α F) G = whisker_right α (F ⋙ G) :=
rfl

lemma whisker_right_left (F : B ⥤ C) {G H : C ⥤ D} (α : G ⟶ H) (K : D ⥤ E) :
  whisker_right (whisker_left F α) K = whisker_left F (whisker_right α K) :=
rfl
end

namespace functor

universes u₅ v₅

variables {A : Type u₁} [category.{v₁} A]
variables {B : Type u₂} [category.{v₂} B]

/--
The left unitor, a natural isomorphism `((𝟭 _) ⋙ F) ≅ F`.
-/
@[simps] def left_unitor (F : A ⥤ B) : ((𝟭 A) ⋙ F) ≅ F :=
{ hom := { app := λ X, 𝟙 (F.obj X) },
  inv := { app := λ X, 𝟙 (F.obj X) } }

/--
The right unitor, a natural isomorphism `(F ⋙ (𝟭 B)) ≅ F`.
-/
@[simps] def right_unitor (F : A ⥤ B) : (F ⋙ (𝟭 B)) ≅ F :=
{ hom := { app := λ X, 𝟙 (F.obj X) },
  inv := { app := λ X, 𝟙 (F.obj X) } }

variables {C : Type u₃} [category.{v₃} C]
variables {D : Type u₄} [category.{v₄} D]

/--
The associator for functors, a natural isomorphism `((F ⋙ G) ⋙ H) ≅ (F ⋙ (G ⋙ H))`.

(In fact, `iso.refl _` will work here, but it tends to make Lean slow later,
and it's usually best to insert explicit associators.)
-/
@[simps] def associator (F : A ⥤ B) (G : B ⥤ C) (H : C ⥤ D) : ((F ⋙ G) ⋙ H) ≅ (F ⋙ (G ⋙ H)) :=
{ hom := { app := λ _, 𝟙 _ },
  inv := { app := λ _, 𝟙 _ } }

lemma triangle (F : A ⥤ B) (G : B ⥤ C) :
  (associator F (𝟭 B) G).hom ≫ (whisker_left F (left_unitor G).hom) =
    (whisker_right (right_unitor F).hom G) :=
by { ext, dsimp, simp }  -- See note [dsimp, simp].

variables {E : Type u₅} [category.{v₅} E]

variables (F : A ⥤ B) (G : B ⥤ C) (H : C ⥤ D) (K : D ⥤ E)

lemma pentagon :
  (whisker_right (associator F G H).hom K) ≫
    (associator F (G ⋙ H) K).hom ≫
    (whisker_left F (associator G H K).hom) =
  ((associator (F ⋙ G) H K).hom ≫ (associator F G (H ⋙ K)).hom) :=
by { ext, dsimp, simp }

end functor

end category_theory


import for_mathlib.category_theory.triangulated.homological_functor
import for_mathlib.category_theory.shift_op

noncomputable theory

namespace category_theory

open category limits

namespace functor

variables {C₁ C₂ D : Type*} [category C₁] [category C₂] [category D]

section

variables (F : C₁ ⥤ C₂ ⥤ D) {A G : Type*} [add_comm_monoid A]
  [has_shift C₁ A] [has_shift C₂ A]

def shift_swap (a : A) :=
  (shift_functor C₁ a) ⋙ F ≅ F ⋙ (whiskering_left _ _ D).obj (shift_functor C₂ a)

namespace shift_swap

variable (A)

def zero : shift_swap F (0 : A) :=
iso_whisker_right (shift_functor_zero C₁ A) F ≪≫ F.left_unitor ≪≫
  F.right_unitor.symm ≪≫
  iso_whisker_left F ((whiskering_left_id _ _).symm ≪≫
    (whiskering_left _ _ D).map_iso (shift_functor_zero C₂ A).symm)

lemma zero_hom_app_app (X₁ : C₁) (X₂ : C₂) :
  ((zero F A).hom.app X₁).app X₂ =
  (F.map ((shift_functor_zero C₁ A).hom.app X₁)).app X₂ ≫
    (F.obj X₁).map ((shift_functor_zero C₂ A).inv.app X₂) :=
begin
  dsimp only [zero, left_unitor, right_unitor, iso.trans, iso_whisker_right, iso_whisker_left,
    whiskering_right, whiskering_left, iso.symm, nat_trans.comp_app, whiskering_left_id,
    nat_iso.of_components, map_iso, whisker_left, whisker_right],
  erw [id_comp, id_comp, id_comp],
end

lemma zero_inv_app_app (X₁ : C₁) (X₂ : C₂) :
  ((zero F A).inv.app X₁).app X₂ =
  (F.obj X₁).map ((shift_functor_zero C₂ A).hom.app X₂) ≫
  (F.map ((shift_functor_zero C₁ A).inv.app X₁)).app X₂ :=
begin
  dsimp only [zero, left_unitor, right_unitor, iso.trans, iso_whisker_right, iso_whisker_left,
    whiskering_right, whiskering_left, iso.symm, nat_trans.comp_app, whiskering_left_id,
    nat_iso.of_components, map_iso, whisker_left, whisker_right],
  erw [comp_id, comp_id, comp_id],
end

variables {F A}

def add' {a b : A} (e₁ : shift_swap F a) (e₂ : shift_swap F b) (c : A) (h : c = a+b) :
  shift_swap F c :=
iso_whisker_right (shift_functor_add' C₁ a b c h) F ≪≫ functor.associator _ _ _ ≪≫
  iso_whisker_left _ e₂ ≪≫ (functor.associator _ _ _).symm ≪≫
  iso_whisker_right e₁ _ ≪≫ functor.associator _ _ _ ≪≫
  iso_whisker_left F ((whiskering_left _ _ D).map_iso
    (shift_functor_add' C₂ b a c (by rw [h, add_comm])).symm)

def add {a b : A} (e₁ : shift_swap F a) (e₂ : shift_swap F b) :
  shift_swap F (a+b) := add' e₁ e₂ (a+b) rfl

lemma add'_hom_app_app {a b : A} (e₁ : shift_swap F a) (e₂ : shift_swap F b)
  (c : A) (h : c = a+b) (X₁ : C₁) (X₂ : C₂) :
  ((add' e₁ e₂ c h).hom.app X₁).app X₂ =
    (F.map ((shift_functor_add' C₁ a b c h).hom.app X₁)).app X₂ ≫
    (e₂.hom.app (X₁⟦a⟧)).app X₂ ≫ (e₁.hom.app X₁).app (X₂⟦b⟧) ≫
    (F.obj X₁).map ((shift_functor_add' C₂ b a c (by rw [h, add_comm])).inv.app X₂) :=
begin
  dsimp [add'],
  erw [id_comp, id_comp, id_comp],
end

lemma add_hom_app_app {a b : A} (e₁ : shift_swap F a) (e₂ : shift_swap F b)
   (X₁ : C₁) (X₂ : C₂) :
  ((add e₁ e₂).hom.app X₁).app X₂ =
    (F.map ((shift_functor_add C₁ a b).hom.app X₁)).app X₂ ≫
    (e₂.hom.app (X₁⟦a⟧)).app X₂ ≫ (e₁.hom.app X₁).app (X₂⟦b⟧) ≫
    (F.obj X₁).map
      ((shift_functor_add' C₂ b a (a+b) (add_comm a b)).inv.app X₂) :=
begin
  dsimp only [add],
  rw [add'_hom_app_app, shift_functor_add'_eq_shift_functor_add],
end

lemma add'_inv_app_app {a b : A} (e₁ : shift_swap F a) (e₂ : shift_swap F b)
  (c : A) (h : c = a+b) (X₁ : C₁) (X₂ : C₂) :
  ((add' e₁ e₂ c h).inv.app X₁).app X₂ =
    (F.obj X₁).map ((shift_functor_add' C₂ b a c (by rw [h, add_comm])).hom.app X₂) ≫
    (e₁.inv.app X₁).app (X₂⟦b⟧) ≫
    (e₂.inv.app (X₁⟦a⟧)).app X₂ ≫
    (F.map ((shift_functor_add' C₁ a b c h).inv.app X₁)).app X₂ :=
begin
  dsimp [add'],
  erw [comp_id, comp_id, comp_id, assoc, assoc],
end

lemma add_inv_app_app {a b : A} (e₁ : shift_swap F a) (e₂ : shift_swap F b)
  (X₁ : C₁) (X₂ : C₂) :
  ((add e₁ e₂).inv.app X₁).app X₂ =
    (F.obj X₁).map ((shift_functor_add' C₂ b a _ (add_comm a b)).hom.app X₂) ≫
    (e₁.inv.app X₁).app (X₂⟦b⟧) ≫
    (e₂.inv.app (X₁⟦a⟧)).app X₂ ≫
    (F.map ((shift_functor_add C₁ a b).inv.app X₁)).app X₂ :=
begin
  dsimp only [add],
  rw [add'_inv_app_app, shift_functor_add'_eq_shift_functor_add],
end

end shift_swap

variable (A)

class has_shift_swap :=
(iso [] : Π (a : A), F.shift_swap a)
(iso_zero [] : iso 0 = shift_swap.zero F A)
(iso_add [] : ∀ (a b : A), iso (a+b) = shift_swap.add (iso a) (iso b))

variable {A}

def has_shift_swap.iso' [F.has_shift_swap A] (a b c : A) (h : c = a + b) :
  (shift_functor C₁ a) ⋙ F ⋙ (whiskering_left _ _ D).obj (shift_functor C₂ b) ≅
    F ⋙ (whiskering_left _ _ D).obj (shift_functor C₂ c) :=
(functor.associator _ _ _).symm ≪≫ iso_whisker_right (has_shift_swap.iso F a) _ ≪≫
  functor.associator _ _ _ ≪≫ iso_whisker_left _ ((whiskering_left C₂ C₂ D).map_iso (shift_functor_add' C₂ b a c (by rw [h, add_comm])).symm)

namespace has_shift_swap

variable [F.has_shift_swap A]

lemma iso'_hom_app_app (a b c : A) (h : c = a + b) (X₁ : C₁) (X₂ : C₂ ):
  ((iso' F a b c h).hom.app X₁).app X₂ =
    ((iso F a).hom.app X₁).app ((shift_functor C₂ b).obj X₂) ≫
      (F.obj X₁).map ((shift_functor_add' C₂ b a c (by rw [h, add_comm])).inv.app X₂) :=
begin
  dsimp [iso'],
  rw [id_comp, id_comp],
end

lemma iso'_zero_hom_app_app (b : A) (X₁ : C₁) (X₂ : C₂ ):
  ((iso' F 0 b b (zero_add b).symm).hom.app X₁).app X₂ =
    (F.map ((shift_functor_zero C₁ A).hom.app X₁)).app (X₂⟦b⟧) :=
begin
  simp only [iso'_hom_app_app, has_shift_swap.iso_zero,
    shift_swap.zero_hom_app_app, assoc, ← functor.map_comp],
  convert comp_id _,
  convert functor.map_id _ _,
  sorry,
end

lemma iso'_hom_app_app_comp (a b c a' d e : A) (hc : c = a + b) (he : e = a'+a) (hd : d = a'+c)
   (X₁ : C₁) (X₂ : C₂ ) :
  ((iso' F a b c hc).hom.app (X₁⟦a'⟧)).app X₂ ≫ ((iso' F a' c d hd).hom.app X₁).app X₂ =
    (F.map ((shift_functor_add' C₁ a' a e he).inv.app X₁)).app (X₂⟦b⟧) ≫
      ((iso' F e b d (by rw [hd, he, hc, add_assoc])).hom.app X₁).app X₂ :=
begin
  sorry,
end

end has_shift_swap

end

section

variables {C : Type*} [category C] [has_shift C ℤ]
  [preadditive C] [∀ (n : ℤ), (shift_functor C n).additive]

local attribute [instance] has_shift_op_neg_ℤ

@[simps]
def preadditive_yoneda_shift_swap_add_equiv (X₁ X₂ : C) (n : ℤ) :
  (X₂ ⟶ X₁⟦n⟧) ≃+ (X₂⟦-n⟧ ⟶ X₁) :=
{ to_fun := λ f, f⟦-n⟧' ≫ (shift_equiv C n).unit_iso.inv.app X₁,
  inv_fun := λ f, (shift_equiv C n).counit_iso.inv.app X₂ ≫ f⟦n⟧',
  left_inv := λ f, begin
    dsimp only,
    erw [functor.map_comp, ← nat_trans.naturality_assoc,
      (shift_equiv C n).counit_inv_functor_comp, comp_id],
    refl,
  end,
  right_inv := λ f, begin
    dsimp only,
    erw [functor.map_comp, assoc],
    erw (shift_equiv C n).unit_iso.inv.naturality f,
    slice_lhs 1 2 { erw (shift_equiv C n).inverse_counit_inv_comp, },
    erw id_comp,
    refl,
  end,
  map_add' := λ f₁ f₂, by rw [functor.map_add, preadditive.add_comp], }

variable (C)

@[simps]
def preadditive_yoneda_shift_swap (n : ℤ) :
  shift_swap (preadditive_yoneda : C ⥤ _) n :=
nat_iso.of_components (λ X₁, nat_iso.of_components
  (λ X₂, add_equiv.to_AddCommGroup_iso (preadditive_yoneda_shift_swap_add_equiv X₁ X₂.unop n))
  (by tidy)) (by tidy)

-- this would be better with coyoneda instead

def hom_functor_has_shift_swap : (preadditive_yoneda : C ⥤ _).has_shift_swap ℤ :=
{ iso := preadditive_yoneda_shift_swap C,
  iso_zero := begin
    ext X₁ X₂ x,
    dsimp at x,
    rw shift_swap.zero_hom_app_app,
    dsimp only [preadditive_yoneda_shift_swap, nat_iso.of_components,
      preadditive_yoneda_shift_swap_add_equiv, add_equiv.to_AddCommGroup_iso,
      add_equiv.to_add_monoid_hom, add_monoid_hom.coe_mk],
    rw [comp_apply, preadditive_yoneda_map_app_apply],
    erw preadditive_yoneda_obj_map_apply,
    --let y := ((shift_functor_zero Cᵒᵖ ℤ).inv.app X₂).unop,
    --let y' := (shift_functor_zero C ℤ).hom.app (opposite.unop X₂),
    --change _ = y ≫ _,
    sorry,
  end,
  iso_add := sorry, }

end

section

variables (F : C₁ ⥤ C₂ ⥤ D) [has_shift C₁ ℤ] [has_shift C₂ ℤ] [abelian D]
  [preadditive C₁] [has_zero_object C₁] [∀ (n : ℤ), (shift_functor C₁ n).additive]
  [pretriangulated C₁]
  [∀ (Y₂ : C₂), (((whiskering_right _ _ _).obj
    ((evaluation C₂ D).obj Y₂)).obj F).preserves_zero_morphisms]
  [∀ (Y₂ : C₂), (((whiskering_right _ _ _).obj
    ((evaluation C₂ D).obj Y₂)).obj F).is_homological]

lemma is_homological.bifunctor_map_distinguished (T : pretriangulated.triangle C₁)
  (hT : T ∈ dist_triang C₁) (Y₂ : C₂) :
  ((T.short_complex hT).map (((whiskering_right C₁ (C₂ ⥤ D) D).obj
    ((evaluation C₂ D).obj Y₂)).obj F)).exact :=
is_homological.map_distinguished (((whiskering_right _ _ _).obj
  ((evaluation C₂ D).obj Y₂)).obj F) T hT

lemma is_homological.bifunctor_ex₁₂ (T : pretriangulated.triangle C₁)
  (hT : T ∈ dist_triang C₁) (Y₂ : C₂) (n : ℤ) :
  (short_complex.mk ((F.map T.mor₁).app (Y₂⟦n⟧)) ((F.map T.mor₂).app (Y₂⟦n⟧))
    (by simpa only [← nat_trans.comp_app, ← F.map_comp, pretriangulated.triangle.comp_zero₁₂ T hT]
        using (((whiskering_right _ _ _).obj ((evaluation C₂ D).obj _)).obj F).map_zero T.obj₁ T.obj₃)).exact :=
is_homological.map_distinguished (((whiskering_right _ _ _).obj
  ((evaluation C₂ D).obj (Y₂⟦n⟧))).obj F) T hT

variables [F.has_shift_swap ℤ]

def is_homological.bifunctor_δ₁ (T : pretriangulated.triangle C₁) (hT : T ∈ dist_triang C₁)
  (Y₂ : C₂) (n₀ n₁ : ℤ) (h : n₁ = n₀+1) :
  (F.obj T.obj₃).obj (Y₂⟦n₀⟧) ⟶ (F.obj T.obj₁).obj (Y₂⟦n₁⟧) :=
(F.map T.mor₃).app (Y₂⟦n₀⟧) ≫
  ((has_shift_swap.iso' F 1 n₀ n₁ (by rw [h, add_comm])).hom.app T.obj₁).app Y₂

lemma is_homological.bifunctor_comp_δ₁
  (T : pretriangulated.triangle C₁) (hT : T ∈ dist_triang C₁)
  (Y₂ : C₂) (n₀ n₁ : ℤ) (h : n₁ = n₀+1) :
  (F.map T.mor₂).app (Y₂⟦n₀⟧) ≫ is_homological.bifunctor_δ₁ F T hT Y₂ _ _ h = 0 :=
begin
  dsimp only [is_homological.bifunctor_δ₁],
  rw ← assoc,
  convert zero_comp,
  rw [← nat_trans.comp_app, ← F.map_comp, pretriangulated.triangle.comp_zero₂₃ T hT],
  exact (((whiskering_right _ _ _).obj ((evaluation C₂ D).obj _)).obj F).map_zero _ _,
end

lemma is_homological.bifunctor_ex₁₃
  (T : pretriangulated.triangle C₁) (hT : T ∈ dist_triang C₁)
  (Y₂ : C₂) (n₀ n₁ : ℤ) (h : n₁ = n₀+1) :
  (short_complex.mk _ _ (is_homological.bifunctor_comp_δ₁ F T hT Y₂ _ _ h)).exact :=
begin
  refine (short_complex.exact_iff_of_iso _).1 (is_homological.map_distinguished
    (((whiskering_right _ _ _).obj ((evaluation C₂ D).obj (Y₂⟦n₀⟧))).obj F)
    _ ((pretriangulated.rotate_distinguished_triangle T).1 hT)),
  refine short_complex.mk_iso (iso.refl _) (iso.refl _)
    (((has_shift_swap.iso' F 1 n₀ n₁ (by rw [h, add_comm])).app T.obj₁).app Y₂) _ _,
  { dsimp, rw [id_comp, comp_id], },
  { dsimp,
    rw id_comp,
    refl, },
end

def is_homological.bifunctor_δ₁_comp
  (T : pretriangulated.triangle C₁) (hT : T ∈ dist_triang C₁)
  (Y₂ : C₂) (n₀ n₁ : ℤ) (h : n₁ = n₀+1) :
  is_homological.bifunctor_δ₁ F T hT Y₂ _ _ h ≫ (F.map T.mor₁).app (Y₂⟦n₁⟧) = 0 :=
begin
  dsimp only [is_homological.bifunctor_δ₁],
  have eq := congr_app ((has_shift_swap.iso' F 1 n₀ n₁ (by rw [h, add_comm])).hom.naturality T.mor₁) Y₂,
  dsimp at eq,
  rw [assoc, ← eq, ← assoc],
  convert zero_comp,
  rw [← nat_trans.comp_app, ← F.map_comp, pretriangulated.triangle.comp_zero₃₁ T hT],
  exact (((whiskering_right _ _ _).obj ((evaluation C₂ D).obj _)).obj F).map_zero _ _,
end

lemma is_homological.bifunctor_ex₁₁
  (T : pretriangulated.triangle C₁) (hT : T ∈ dist_triang C₁)
  (Y₂ : C₂) (n₀ n₁ : ℤ) (h : n₁ = n₀+1) :
  (short_complex.mk _ _ (is_homological.bifunctor_δ₁_comp F T hT Y₂ _ _ h)).exact :=
begin
  refine (short_complex.exact_iff_of_iso _).1 (is_homological.map_distinguished
    (((whiskering_right _ _ _).obj ((evaluation C₂ D).obj (Y₂⟦n₁⟧))).obj F)
    _ ((pretriangulated.inv_rotate_distinguished_triangle T).2 hT)),
  refine short_complex.mk_iso (preadditive.mul_iso (-1) ((((has_shift_swap.iso' F (-1) n₁ n₀ (by linarith)).app T.obj₃)).app Y₂)) (iso.refl _) (iso.refl _) _ _,
  { dsimp only [preadditive.mul_iso, iso.refl,
      pretriangulated.triangle.inv_rotate, pretriangulated.triangle.mk,
      short_complex.map, whiskering_right, evaluation, functor.comp,
      pretriangulated.triangle.short_complex,
      pretriangulated.candidate_triangle.of_distinguished,
      pretriangulated.candidate_triangle.short_complex,
      is_homological.bifunctor_δ₁],
    have eq := congr_app ((has_shift_swap.iso' F (-1) n₁ n₀ (by linarith)).hom.naturality T.mor₃) Y₂,
    dsimp at eq,
    rw [comp_id, units.coe_neg_one, neg_smul, one_smul],
    nth_rewrite 0 preadditive.neg_comp,
    erw [← reassoc_of eq, ← preadditive.neg_comp, ← preadditive.neg_comp, F.map_comp],
    conv_rhs { rw nat_trans.comp_app, },
    congr' 1,
    { exact (functor.map_neg (((whiskering_right _ _ _).obj
        ((evaluation C₂ D).obj (Y₂⟦n₁⟧))).obj F)).symm, },
    { rw [has_shift_swap.iso'_hom_app_app_comp F (-1) n₁ n₀ 1 n₁ 0 (by linarith)
        (by linarith) (by linarith), has_shift_swap.iso'_zero_hom_app_app,
        ← nat_trans.comp_app, ← F.map_comp,
        ← shift_functor_comp_shift_functor_neg_eq_add'_comp_zero],
      refl, }, },
  { dsimp,
    rw [id_comp, comp_id], },
end

end

end functor

end category_theory


import data.finset.basic
import data.fintype.basic
import .extensionality

namespace extensionality

universe u

instance finset_ext_lemmas (T : Type*) [decidable_eq T] :
  (boolalg_ext_lemmas (finset T) T) :=
{
  simpl_eq := by tidy,
  simpl_lt := by tidy,
  ext_bot := by tidy,
  ext_sdiff := by tidy,
  ext_le := by tidy,
  ext_meet := by tidy,
  ext_join := by simp only [finset.inf_eq_inter, forall_const, iff_self, finset.mem_inter, forall_true_iff],
}

instance finset_ext_lemmas_compl (T : Type*) [fintype T] [decidable_eq T] :
  (boolalg_ext_lemmas_compl (finset T) T) :=
{
  ext_compl := by apply finset.mem_compl
}

instance finset_ext_lemmas_top (T : Type*) [fintype T] [decidable_eq T] :
  (boolalg_ext_lemmas_top (finset T) T) :=
{
  ext_top := by unfold_projs; finish,
}
end extensionality

namespace cleanup
lemma finset_union_sup (T : Type*) [decidable_eq T] (A B : finset T) : (A ∪ B) = (A ⊔ B) := by refl
lemma finset_inter_inf (T : Type*) [decidable_eq T] (A B : finset T) : (A ∩ B) = (A ⊓ B) := by refl
lemma finset_subset_le (T : Type*) [decidable_eq T] (A B : finset T) : (A ⊆ B) = (A ≤ B) := by refl
lemma finset_subset_lt (T : Type*) [decidable_eq T] (A B : finset T) : (A ⊂ B) = (A < B) := by refl
lemma finset_univ_top (T : Type*) [decidable_eq T] [fintype T] : (finset.univ : finset T) = ⊤ := by refl
lemma finset_empt_bot (T : Type*) [decidable_eq T] : (∅ : finset T) = ⊥ := by refl

meta def finset_cleanup : tactic unit :=
  `[simp only [cleanup.finset_union_sup, cleanup.finset_inter_inf, cleanup.finset_subset_le,
    cleanup.finset_subset_lt, cleanup.finset_univ_top, cleanup.finset_empt_bot] at *]
end cleanup


/-
Copyright (c) 2019 Johan Commelin. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johan Commelin, Simon Hudon, Scott Morrison
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.equiv.basic
import Mathlib.control.bifunctor
import Mathlib.PostPort

universes u v w

namespace Mathlib

/-!
# Functor and bifunctors can be applied to `equiv`s.

We define
```lean
def functor.map_equiv (f : Type u → Type v) [functor f] [is_lawful_functor f] :
  α ≃ β → f α ≃ f β
```
and
```lean
def bifunctor.map_equiv (F : Type u → Type v → Type w) [bifunctor F] [is_lawful_bifunctor F] :
  α ≃ β → α' ≃ β' → F α α' ≃ F β β'
```
-/

namespace functor

/-- Apply a functor to an `equiv`. -/
def map_equiv {α : Type u} {β : Type u} (f : Type u → Type v) [Functor f] [is_lawful_functor f] (h : α ≃ β) : f α ≃ f β :=
  equiv.mk (Functor.map ⇑h) (Functor.map ⇑(equiv.symm h)) sorry sorry

@[simp] theorem map_equiv_apply {α : Type u} {β : Type u} (f : Type u → Type v) [Functor f] [is_lawful_functor f] (h : α ≃ β) (x : f α) : coe_fn (map_equiv f h) x = ⇑h <$> x :=
  rfl

@[simp] theorem map_equiv_symm_apply {α : Type u} {β : Type u} (f : Type u → Type v) [Functor f] [is_lawful_functor f] (h : α ≃ β) (y : f β) : coe_fn (equiv.symm (map_equiv f h)) y = ⇑(equiv.symm h) <$> y :=
  rfl

@[simp] theorem map_equiv_refl {α : Type u} (f : Type u → Type v) [Functor f] [is_lawful_functor f] : map_equiv f (equiv.refl α) = equiv.refl (f α) := sorry

end functor

namespace bifunctor

/-- Apply a bifunctor to a pair of `equiv`s. -/
def map_equiv {α : Type u} {β : Type u} {α' : Type v} {β' : Type v} (F : Type u → Type v → Type w) [bifunctor F] [is_lawful_bifunctor F] (h : α ≃ β) (h' : α' ≃ β') : F α α' ≃ F β β' :=
  equiv.mk (bimap ⇑h ⇑h') (bimap ⇑(equiv.symm h) ⇑(equiv.symm h')) sorry sorry

@[simp] theorem map_equiv_apply {α : Type u} {β : Type u} {α' : Type v} {β' : Type v} (F : Type u → Type v → Type w) [bifunctor F] [is_lawful_bifunctor F] (h : α ≃ β) (h' : α' ≃ β') (x : F α α') : coe_fn (map_equiv F h h') x = bimap (⇑h) (⇑h') x :=
  rfl

@[simp] theorem map_equiv_symm_apply {α : Type u} {β : Type u} {α' : Type v} {β' : Type v} (F : Type u → Type v → Type w) [bifunctor F] [is_lawful_bifunctor F] (h : α ≃ β) (h' : α' ≃ β') (y : F β β') : coe_fn (equiv.symm (map_equiv F h h')) y = bimap (⇑(equiv.symm h)) (⇑(equiv.symm h')) y :=
  rfl

@[simp] theorem map_equiv_refl_refl {α : Type u} {α' : Type v} (F : Type u → Type v → Type w) [bifunctor F] [is_lawful_bifunctor F] : map_equiv F (equiv.refl α) (equiv.refl α') = equiv.refl (F α α') := sorry


/-
Copyright (c) 2020 Gabriel Ebner, Simon Hudon. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Gabriel Ebner, Simon Hudon
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.tactic.ext
import Mathlib.Lean3Lib.data.stream
import Mathlib.data.list.basic
import Mathlib.data.list.range
import Mathlib.PostPort

universes u_1

namespace Mathlib

/-!
# Additional instances and attributes for streams
-/

protected instance stream.inhabited {α : Type u_1} [Inhabited α] : Inhabited (stream α) :=
  { default := stream.const Inhabited.default }

namespace stream

/-- `take s n` returns a list of the `n` first elements of stream `s` -/
def take {α : Type u_1} (s : stream α) (n : ℕ) : List α :=
  list.map s (list.range n)

theorem length_take {α : Type u_1} (s : stream α) (n : ℕ) : list.length (take s n) = n := sorry

/-- Use a state monad to generate a stream through corecursion -/
def corec_state {σ : Type u_1} {α : Type u_1} (cmd : state σ α) (s : σ) : stream α :=
  corec prod.fst (state_t.run cmd ∘ prod.snd) (state_t.run cmd s)


import number_theory.bernoulli

--OUTPUT 1
theorem bernoulli_eval_one_add (n : ℕ) (x : ℚ) :
  (polynomial.bernoulli n).eval (1 + x) = (polynomial.bernoulli n).eval x + n * x^(n - 1) :=
begin
  sorry,
end

--OUTPUT 2
theorem bernoulli_eval_one_add (n : ℕ) (x : ℚ) :
  (polynomial.bernoulli n).eval (1 + x) = (polynomial.bernoulli n).eval x + n * x^(n - 1) :=
begin
  have h1 : ∀ m : ℕ, (m < n) → (polynomial.bernoulli m).eval (1 + x) = (polynomial.bernoulli m).eval x + m * x^(m - 1), from sorry,
  have h2 : ∀ m : ℕ, (m < n) → (polynomial.bernoulli m).eval (1 + x) = (polynomial.bernoulli m).eval x + m * x^(m - 1), from sorry,
  have h3 : ∀ m : ℕ, (m < n) → (polynomial.bernoulli m).eval (1 + x) = (polynomial.bernoulli m).eval x + m * x^(m - 1), from sorry,
  have h4 : ∀ m : ℕ, (m < n) → (polynomial.bernoulli m).eval (1 + x) = (polynomial.bernoulli m).eval x + m * x^(m - 1), from sorry,
  have h5 : ∀ m : ℕ, (m < n) → (polynomial.bernoulli m).eval (1 + x) = (polynomial.bernoulli m).eval x + m * x^(m - 1), from sorry,
  have h6 : ∀ m : ℕ, (m < n) → (polynomial.bernoulli m).eval (1 + x) = (polynomial.bernoulli m).eval x + m * x^(m - 1), from sorry,
  have h7 : ∀ m : ℕ, (m < n) → (polynomial.bernoulli m).eval (1 + x) = (polynomial.bernoulli m).eval x + m * x^(m - 1), from sorry,
  have h8 : ∀ m : ℕ, (m < n) → (polynomial.bernoulli m).eval (1 + x) = (polynomial.bernoulli m).eval x + m * x^(m - 1), from sorry,
  have h9 : ∀ m : ℕ, (m < n) → (polynomial.bernoulli m).eval (1 + x) = (polynomial.bernoulli m).eval x + m * x^(m - 1), from sorry,
  have h10 : ∀ m : ℕ, (m < n) → (polynomial.bernoulli m).eval (1 + x) = (polynomial.bernoulli m).eval x + m * x^(m - 1), from sorry,
  have h11 : ∀ m : ℕ, (m < n) → (polynomial.bernoulli m).eval (1 + x) = (polynomial.bernoulli m).eval x + m * x^(m - 1), from sorry,
  have h12 : ∀ m : ℕ, (m < n) → (polynomial.bernoulli m).eval (1 + x) = (polynomial.bernoulli m).eval x + m * x^(m - 1), from sorry,
  have h13 : ∀ m : ℕ, (m < n) → (polynomial.bernoulli m).eval (1 + x) = (polynomial.bernoulli m).eval x + m * x^(m - 1), from sorry,
  have h14 : ∀ m : ℕ, (m < n) → (polynomial.bernoulli m).eval (1 + x) = (polynomial.bernoulli m).eval x + m * x^(m - 1), from sorry,
  have h15 : ∀ m : ℕ, (m < n) → (polynomial.bernoulli m).eval (1 + x) = (polynomial.bernoulli m).eval x + m * x^(m - 1), from sorry,
  have h16 : ∀ m : ℕ, (m < n) → (polynomial.bernoulli m).eval (1 + x) = (polynomial.bernoulli m).eval x + m * x^(m - 1), from sorry,
  have h17 : ∀ m : ℕ, (m < n) → (polynomial.bernoulli m).eval (1 + x) = (polynomial.bernoulli m).eval x + m * x^(m - 1), from sorry,
  have h18 : ∀ m : ℕ, (m < n) → (polynomial.bernoulli m).eval (1 + x) = (polynomial.bernoulli m).eval x + m * x^(m - 1), from sorry,
  have h19 : ∀ m : ℕ, (m < n) → (polynomial.bernoulli m).eval (1 + x) = (polynomial.bernoulli m).eval x + m * x^(m - 1), from sorry,
  have h20 : ∀ m : ℕ, (m < n) → (polynomial.bernoulli m).eval (1 + x) = (polynomial.bernoulli m).eval x + m * x^(m - 1), from sorry,
  have h21 : ∀ m : ℕ, (m < n) → (polynomial.bernoulli m).eval (1 + x) = (polynomial.bernoulli m).eval x + m * x^(m - 1), from sorry,
  have h22 : ∀ m : ℕ, (m < n) → (polynomial.bernoulli m).eval (1 + x) = (polynomial.bernoulli m).eval x + m * x^(m - 1), from sorry,
  have h23 : ∀ m : ℕ, (m < n) → (polynomial.bernoulli m).eval (1 + x) = (polynomial.bernoulli m).eval x + m * x^(m - 1), from sorry,
  have h24 : ∀ m : ℕ, (m < n) → (polynomial.bernoulli m).eval (1 + x) = (polynomial.bernoulli m).eval x + m * x^(m - 1), from sorry,
  have h25 : ∀ m : ℕ, (m < n) → (polynomial.bernoulli m).eval (1 + x) = (polynomial.bernoulli m).eval x + m * x^(m - 1), from sorry,
  have h26 : ∀ m : ℕ, (m < n) → (polynomial.bernoulli m).eval (1 + x) = (polynomial.bernoulli m).eval x + m * x^(m - 1), from sorry,
  have h27 : ∀ m : ℕ, (m < n) → (polynomial.bernoulli m).eval (1 + x) = (polynomial.bernoulli m).eval x + m * x^(m - 1), from sorry,
  have h28 : ∀ m : ℕ, (m < n) → (polynomial.bernoulli m).eval (1 + x) = (polynomial.bernoulli m).eval x + m * x^(m - 1), from sorry,
  have h29 : ∀ m : ℕ, (m < n) → (polynomial.bernoulli m).eval (1 + x) = (polynomial.bernoulli m).eval x + m * x^(m - 1), from sorry,
  have h30 : ∀ m : ℕ, (m < n) → (polynomial.bernoulli m).eval (1 + x) = (polynomial.bernoulli m).eval x + m * x^(m - 1), from sorry,
  have h31 : ∀ m : ℕ, (m < n) → (polynomial.bernoulli m).eval (1 + x) = (polynomial.bernoulli m).eval x + m * x^(m - 1), from sorry,
  have h32 : ∀ m : ℕ, (m < n) → (polynomial.bernoulli m).eval (1 + x) = (polynomial.bernoulli m).eval x + m * x^(m - 1), from sorry,
  have h33 : ∀ m : ℕ,
end --Needs more than 2000 tokens!

--OUTPUT 3
theorem bernoulli_eval_one_add (n : ℕ) (x : ℚ) :
  (polynomial.bernoulli n).eval (1 + x) = (polynomial.bernoulli n).eval x + n * x^(n - 1) :=
begin
  sorry
end

--OUTPUT 4
theorem bernoulli_eval_one_add (n : ℕ) (x : ℚ) :
  (polynomial.bernoulli n).eval (1 + x) = (polynomial.bernoulli n).eval x + n * x^(n - 1) :=
begin
  induction n with d hd,
  {
    show (polynomial.bernoulli 0).eval (1 + x) = (polynomial.bernoulli 0).eval x + 0 * x^(-1),
    {
      rw polynomial.bernoulli,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C,
      rw polynomial.eval_C
end --Needs more than 2000 tokens!

--OUTPUT 5
theorem bernoulli_eval_one_add (n : ℕ) (x : ℚ) :
  (polynomial.bernoulli n).eval (1 + x) = (polynomial.bernoulli n).eval x + n * x^(n - 1) :=
begin
  sorry,
end

--OUTPUT 6
theorem bernoulli_eval_one_add (n : ℕ) (x : ℚ) :
  (polynomial.bernoulli n).eval (1 + x) = (polynomial.bernoulli n).eval x + n * x^(n - 1) :=
begin
  have h1 : ∀ m : ℕ, m < n → (polynomial.bernoulli m).eval (1 + x) = (polynomial.bernoulli m).eval x + m * x^(m - 1), from sorry,
  have h2 : ∀ m : ℕ, (polynomial.bernoulli m).eval (1 + x) = (polynomial.bernoulli m).eval x + m * x^(m - 1), from sorry,
  have h3 : (polynomial.bernoulli n).eval (1 + x) = (polynomial.bernoulli n).eval x + n * x^(n - 1), from sorry,
  show (polynomial.bernoulli n).eval (1 + x) = (polynomial.bernoulli n).eval x + n * x^(n - 1), from sorry,
end

/- 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 sorry,
  have h2 : (A ∩ B) ⊆ A, from sorry,
  have h3 : (A ∩ B) ⊆ S, from sorry,
  show (A ∩ B) ∈  𝒫 S, from sorry,
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 sorry
  ... = x*(x+y) + y*(x+y) : by sorry
  ... = x*x + x*y + y*x + y*y : by sorry
  ... = x^2 + 2*x*y + y^2 : by sorry,
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 sorry,
  have h2 : ∀ a b : G, ∃! y : G, y * a = b, from sorry,

  have h3 : ∀ a : G, ∃! x : G, a * x = a, from sorry,
  have h4 : ∀ a : G, ∃! y : G, y * a = a, from sorry,

  have h5 : ∀ a : G, classical.some (h3 a) = (1 : G), from sorry,
  have h6 : ∀ a : G, classical.some (h4 a) = (1 : G), from sorry,

  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) (h7 : ∀ a : G, e * a = a ∧ a * e = a),
      have h8 : ∀ a : G, e = classical.some (h3 a), from sorry,
      have h9 : ∀ a : G, e = classical.some (h4 a), from sorry,
      show e = (1 : G), from sorry,
    },
    sorry,
  }
end

/--`theorem`
Bernoulli polynomial evaluation
Given a natural number $n$ and a rational $x$, let $B_n (x)$ denote the $n$-th Bernoulli polynomial evaluated at $x$. Then, $$B_n (1 + x) = B_n (x) + n x^{n - 1}$$
`proof`
We apply strong induction on $n$. So, for all $m < d$, we have $B_{m} (1 + x) = B_{m} (x) + m x^{m - 1}$ and we want to show that $$B_{d} (1 + x) = B_{d} (x) + d x^{d - 1}$$
Multiplying both sides by $d + 1$, and using the fact that, for all $l \in \mathbb{N}$, $\sum_{k = 0}^{l} {l + 1 \choose k} B_k = (l + 1) X^l$ (where $B_k$ is the $k$-th Bernoulli number), we get that
$$ (d + 1) (1 + x)^d - (d + 1) x^d = \sum_{l = 0}^{d} {d + 1 \choose l} l x^{l - 1} $$
The conclusion then follows easily.

QED

-/
theorem  bernoulli_eval_one_add (n : ℕ) (x : ℚ) :
  (polynomial.bernoulli n).eval (1 + x) = (polynomial.bernoulli n).eval x + n * x^(n - 1) :=
FEW SHOT PROMPTS TO CODEX(END)-/