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

import control.monad.basic
import data.int.basic
import data.stream.defs
import control.uliftable
import tactic.norm_num
import data.bitvec.basic

/-!
# Rand Monad and Random Class

This module provides tools for formulating computations guided by randomness and for
defining objects that can be created randomly.

## Main definitions
  * `rand` monad for computations guided by randomness;
  * `random` class for objects that can be generated randomly;
    * `random` to generate one object;
    * `random_r` to generate one object inside a range;
    * `random_series` to generate an infinite series of objects;
    * `random_series_r` to generate an infinite series of objects inside a range;
  * `io.mk_generator` to create a new random number generator;
  * `io.run_rand` to run a randomized computation inside the `io` monad;
  * `tactic.run_rand` to run a randomized computation inside the `tactic` monad

## Local notation

 * `i .. j` : `Icc i j`, the set of values between `i` and `j` inclusively;

## Tags

random monad io

## References

  * Similar library in Haskell: https://hackage.haskell.org/package/MonadRandom

-/

open list io applicative

universes u v w

/-- A monad to generate random objects using the generator type `g` -/
@[reducible]
def rand_g (g : Type) (α : Type u) : Type u := state (ulift.{u} g) α

/-- A monad to generate random objects using the generator type `std_gen` -/
@[reducible]
def rand := rand_g std_gen

instance (g : Type) : uliftable (rand_g.{u} g) (rand_g.{v} g) :=
@state_t.uliftable' _ _ _ _ _ (equiv.ulift.trans.{u u u u u} equiv.ulift.symm)

open ulift (hiding inhabited)

/-- Generate one more `ℕ` -/
def rand_g.next {g : Type} [random_gen g] : rand_g g ℕ :=
⟨ prod.map id up ∘ random_gen.next ∘ down ⟩

local infix ` .. `:41 := set.Icc

open stream

/-- `bounded_random α` gives us machinery to generate values of type `α` between certain bounds -/
class bounded_random (α : Type u) [preorder α] :=
(random_r : Π g [random_gen g] (x y : α),
              (x ≤ y) → rand_g g (x .. y))

/-- `random α` gives us machinery to generate values of type `α` -/
class random (α : Type u) :=
(random [] : Π (g : Type) [random_gen g], rand_g g α)

/-- shift_31_left = 2^31; multiplying by it shifts the binary
representation of a number left by 31 bits, dividing by it shifts it
right by 31 bits -/
def shift_31_left : ℕ :=
by apply_normed 2^31

namespace rand

open stream

variables (α : Type u)
variables (g : Type) [random_gen g]

/-- create a new random number generator distinct from the one stored in the state -/
def split : rand_g g g := ⟨ prod.map id up ∘ random_gen.split ∘ down ⟩

variables {g}

section random
variables [random α]

export random (random)

/-- Generate a random value of type `α`. -/
def random : rand_g g α :=
random.random α g

/-- generate an infinite series of random values of type `α` -/
def random_series : rand_g g (stream α) :=
do gen ← uliftable.up (split g),
   pure $ stream.corec_state (random.random α g) gen

end random

variables {α}

/-- Generate a random value between `x` and `y` inclusive. -/
def random_r [preorder α] [bounded_random α] (x y : α) (h : x ≤ y) : rand_g g (x .. y) :=
bounded_random.random_r g x y h

/-- generate an infinite series of random values of type `α` between `x` and `y` inclusive. -/
def random_series_r [preorder α] [bounded_random α] (x y : α) (h : x ≤ y) :
  rand_g g (stream (x .. y)) :=
do gen ← uliftable.up (split g),
   pure $ corec_state (bounded_random.random_r g x y h) gen

end rand

namespace io

private def accum_char (w : ℕ) (c : char) : ℕ :=
c.to_nat + 256 * w

/-- create and a seed a random number generator -/
def mk_generator : io std_gen := do
seed ← io.rand 0 shift_31_left,
return $ mk_std_gen seed

variables {α : Type}

/-- Run `cmd` using a randomly seeded random number generator -/
def run_rand (cmd : _root_.rand α) : io α :=
do g ← io.mk_generator,
   return $ (cmd.run ⟨g⟩).1

/-- Run `cmd` using the provided seed. -/
def run_rand_with (seed : ℕ) (cmd : _root_.rand α) : io α :=
return $ (cmd.run ⟨mk_std_gen seed⟩).1

section random
variables [random α]

/-- randomly generate a value of type α -/
def random : io α :=
io.run_rand (rand.random α)

/-- randomly generate an infinite series of value of type α -/
def random_series : io (stream α) :=
io.run_rand (rand.random_series α)

end random

section bounded_random
variables [preorder α] [bounded_random α]

/-- randomly generate a value of type α between `x` and `y` -/
def random_r (x y : α) (p : x ≤ y) : io (x .. y) :=
io.run_rand (bounded_random.random_r _ x y p)

/-- randomly generate an infinite series of value of type α between `x` and `y` -/
def random_series_r (x y : α) (h : x ≤ y) : io (stream $ x .. y) :=
io.run_rand (rand.random_series_r x y h)

end bounded_random

end io

namespace tactic

/-- create a seeded random number generator in the `tactic` monad -/
meta def mk_generator : tactic std_gen := do
tactic.unsafe_run_io @io.mk_generator

/-- run `cmd` using the a randomly seeded random number generator
in the tactic monad -/
meta def run_rand {α : Type u} (cmd : rand α) : tactic α := do
⟨g⟩ ← tactic.up mk_generator,
return (cmd.run ⟨g⟩).1

variables {α : Type u}

section bounded_random
variables [preorder α] [bounded_random α]

/-- Generate a random value between `x` and `y` inclusive. -/
meta def random_r (x y : α) (h : x ≤ y) : tactic (x .. y) :=
run_rand (rand.random_r x y h)

/-- Generate an infinite series of random values of type `α` between `x` and `y` inclusive. -/
meta def random_series_r (x y : α) (h : x ≤ y) : tactic (stream $ x .. y) :=
run_rand (rand.random_series_r x y h)

end bounded_random

section random

variables [random α]

/-- randomly generate a value of type α -/
meta def random : tactic α :=
run_rand (rand.random α)

 /-- randomly generate an infinite series of value of type α -/
meta def random_series : tactic (stream α) :=
run_rand (rand.random_series α)

end random

end tactic

open nat (succ one_add mod_eq_of_lt zero_lt_succ add_one succ_le_succ)

variables {g : Type} [random_gen g]

open nat

namespace fin
variables {n : ℕ} [fact (0 < n)]

/-- generate a `fin` randomly -/
protected def random : rand_g g (fin n) :=
⟨ λ ⟨g⟩, prod.map of_nat' up $ rand_nat g 0 n ⟩

end fin

open nat

instance nat_bounded_random : bounded_random ℕ :=
{ random_r := λ g inst x y hxy,
  do z ← @fin.random g inst (succ $ y - x) _,
     pure ⟨z.val + x, nat.le_add_left _ _,
       by rw ← le_tsub_iff_right hxy; apply le_of_succ_le_succ z.is_lt⟩ }

/-- This `bounded_random` interval generates integers between `x` and
`y` by first generating a natural number between `0` and `y - x` and
shifting the result appropriately. -/
instance int_bounded_random : bounded_random ℤ :=
{ random_r := λ g inst x y hxy,
  do ⟨z,h₀,h₁⟩ ← @bounded_random.random_r ℕ _ _ g inst 0 (int.nat_abs $ y - x) dec_trivial,
     pure ⟨z + x,
       int.le_add_of_nonneg_left (int.coe_nat_nonneg _),
       int.add_le_of_le_sub_right $ le_trans
         (int.coe_nat_le_coe_nat_of_le h₁)
         (le_of_eq $ int.of_nat_nat_abs_eq_of_nonneg (int.sub_nonneg_of_le hxy)) ⟩ }

instance fin_random (n : ℕ) [fact (0 < n)] : random (fin n) :=
{ random := λ g inst, @fin.random g inst _ _ }

instance fin_bounded_random (n : ℕ) : bounded_random (fin n) :=
{ random_r := λ g inst (x y : fin n) p,
    do ⟨r, h, h'⟩ ← @rand.random_r ℕ g inst _ _ x.val y.val p,
       pure ⟨⟨r,lt_of_le_of_lt h' y.is_lt⟩, h, h'⟩ }

/-- A shortcut for creating a `random (fin n)` instance from
a proof that `0 < n` rather than on matching on `fin (succ n)`  -/
def random_fin_of_pos : ∀ {n : ℕ} (h : 0 < n), random (fin n)
| (succ n) _ := fin_random _
| 0 h := false.elim (nat.not_lt_zero _ h)

lemma bool_of_nat_mem_Icc_of_mem_Icc_to_nat (x y : bool) (n : ℕ) :
  n ∈ (x.to_nat .. y.to_nat) → bool.of_nat n ∈ (x .. y) :=
begin
  simp only [and_imp, set.mem_Icc], intros h₀ h₁,
  split;
    [ have h₂ := bool.of_nat_le_of_nat h₀, have h₂ := bool.of_nat_le_of_nat h₁ ];
    rw bool.of_nat_to_nat at h₂; exact h₂,
end

instance : random bool :=
{ random   := λ g inst,
  (bool.of_nat ∘ subtype.val) <$> @bounded_random.random_r ℕ _ _ g inst 0 1 (nat.zero_le _) }

instance : bounded_random bool :=
{ random_r := λ g _inst x y p,
  subtype.map bool.of_nat (bool_of_nat_mem_Icc_of_mem_Icc_to_nat x y) <$>
    @bounded_random.random_r ℕ _ _ g _inst x.to_nat y.to_nat (bool.to_nat_le_to_nat p) }

open_locale fin_fact

/-- generate a random bit vector of length `n` -/
def bitvec.random (n : ℕ) : rand_g g (bitvec n) :=
bitvec.of_fin <$> rand.random (fin $ 2^n)

/-- generate a random bit vector of length `n` -/
def bitvec.random_r {n : ℕ} (x y : bitvec n) (h : x ≤ y) : rand_g g (x .. y) :=
have h' : ∀ (a : fin (2 ^ n)), a ∈ (x.to_fin .. y.to_fin) → bitvec.of_fin a ∈ (x .. y),
begin
  simp only [and_imp, set.mem_Icc], intros z h₀ h₁,
  replace h₀ := bitvec.of_fin_le_of_fin_of_le h₀,
  replace h₁ := bitvec.of_fin_le_of_fin_of_le h₁,
  rw bitvec.of_fin_to_fin at h₀ h₁, split; assumption,
end,
subtype.map bitvec.of_fin h' <$> rand.random_r x.to_fin y.to_fin (bitvec.to_fin_le_to_fin_of_le h)

open nat

instance random_bitvec (n : ℕ) : random (bitvec n) :=
{ random := λ _ inst, @bitvec.random _ inst n }

instance bounded_random_bitvec (n : ℕ) : bounded_random (bitvec n) :=
{ random_r := λ _ inst x y p, @bitvec.random_r _ inst _ _ _ p }


/-
Copyright (c) 2014 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura

! This file was ported from Lean 3 source module init.data.option.basic
! leanprover-community/mathlib commit e611ee5c2bd410148bcd493c58cb17498d667175
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
prelude
import Leanbin.Init.Logic
import Leanbin.Init.Control.Monad
import Leanbin.Init.Control.Alternative

open Decidable

universe u v

namespace Option

/- warning: option.to_monad -> Option.toMonad is a dubious translation:
lean 3 declaration is
  forall {m : Type -> Type} [_inst_1 : Monad.{0, 0} m] [_inst_2 : Alternative.{0, 0} m] {A : Type}, (Option.{0} A) -> (m A)
but is expected to have type
  forall {m : Type.{u_1} -> Type.{u_2}} {_inst_1 : Type.{u_1}} [_inst_2 : Monad.{u_1, u_2} m] [A : Alternative.{u_1, u_2} m], (Option.{u_1} _inst_1) -> (m _inst_1)
Case conversion may be inaccurate. Consider using '#align option.to_monad Option.toMonadₓ'. -/
def toMonad {m : Type → Type} [Monad m] [Alternative m] {A} : Option A → m A
  | none => failure
  | some a => return a
#align option.to_monad Option.toMonad

#print Option.getD /-
def getD {α : Type u} : Option α → α → α
  | some x, _ => x
  | none, e => e
#align option.get_or_else Option.getD
-/

#print Option.isSome /-
def isSome {α : Type u} : Option α → Bool
  | some _ => true
  | none => false
#align option.is_some Option.isSome
-/

#print Option.isNone /-
def isNone {α : Type u} : Option α → Bool
  | some _ => false
  | none => true
#align option.is_none Option.isNone
-/

#print Option.get /-
def get {α : Type u} : ∀ {o : Option α}, isSome o → α
  | some x, h => x
  | none, h => False.ndrec _ <| Bool.false_ne_true h
#align option.get Option.get
-/

def rhoare {α : Type u} : Bool → α → Option α
  | tt, a => none
  | ff, a => some a
#align option.rhoare Option.rhoare

def lhoare {α : Type u} : α → Option α → α
  | a, none => a
  | _, some b => b
#align option.lhoare Option.lhoare

#print Option.bind /-
@[inline]
protected def bind {α : Type u} {β : Type v} : Option α → (α → Option β) → Option β
  | none, b => none
  | some a, b => b a
#align option.bind Option.bind
-/

#print Option.map /-
protected def map {α β} (f : α → β) (o : Option α) : Option β :=
  Option.bind o (some ∘ f)
#align option.map Option.map
-/

#print Option.map_id /-
theorem map_id {α} : (Option.map id : Option α → Option α) = id :=
  funext fun o =>
    match o with
    | none => rfl
    | some x => rfl
#align option.map_id Option.map_id
-/

instance : Monad Option where
  pure := @some
  bind := @Option.bind
  map := @Option.map

protected def orelse {α : Type u} : Option α → Option α → Option α
  | some a, o => some a
  | none, some a => some a
  | none, none => none
#align option.orelse Option.orelse

instance : Alternative Option where
  failure := @none
  orelse := @Option.orelse

end Option

instance (α : Type u) : Inhabited (Option α) :=
  ⟨none⟩

instance {α : Type u} [d : DecidableEq α] : DecidableEq (Option α)
  | none, none => isTrue rfl
  | none, some v₂ => isFalse fun h => Option.noConfusion h
  | some v₁, none => isFalse fun h => Option.noConfusion h
  | some v₁, some v₂ =>
    match d v₁ v₂ with
    | is_true e => isTrue (congr_arg (@some α) e)
    | is_false n => isFalse fun h => Option.noConfusion h fun e => absurd e n


/-
Copyright (c) 2020 Bhavik Mehta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Bhavik Mehta, Alena Gusakov
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.finset.default
import Mathlib.data.fintype.basic
import Mathlib.algebra.geom_sum
import Mathlib.tactic.default
import Mathlib.PostPort

universes u_1 u_2

namespace Mathlib

/-!
# Colex

We define the colex ordering for finite sets, and give a couple of important
lemmas and properties relating to it.

The colex ordering likes to avoid large values - it can be thought of on
`finset ℕ` as the "binary" ordering. That is, order A based on
`∑_{i ∈ A} 2^i`.
It's defined here in a slightly more general way, requiring only `has_lt α` in
the definition of colex on `finset α`. In the context of the Kruskal-Katona
theorem, we are interested in particular on how colex behaves for sets of a
fixed size. If the size is 3, colex on ℕ starts
123, 124, 134, 234, 125, 135, 235, 145, 245, 345, ...

## Main statements
* `colex_hom`: strictly monotone functions preserve colex
* Colex order properties - linearity, decidability and so on.
* `forall_lt_of_colex_lt_of_forall_lt`: if A < B in colex, and everything
  in B is < t, then everything in A is < t. This confirms the idea that
  an enumeration under colex will exhaust all sets using elements < t before
  allowing t to be included.
* `binary_iff`: colex for α = ℕ is the same as binary
  (this also proves binary expansions are unique)

## Notation
We define `<` and `≤` to denote colex ordering, useful in particular when
multiple orderings are available in context.

## Tags
colex, colexicographic, binary

## References
* https://github.com/b-mehta/maths-notes/blob/master/iii/mich/combinatorics.pdf

## Todo
Show the subset ordering is a sub-relation of the colex ordering.
-/

/--
We define this type synonym to refer to the colexicographic ordering on finsets
rather than the natural subset ordering.
-/
def finset.colex (α : Type u_1) :=
  finset α

/--
A convenience constructor to turn a `finset α` into a `finset.colex α`, useful in order to
use the colex ordering rather than the subset ordering.
-/
def finset.to_colex {α : Type u_1} (s : finset α) : finset.colex α :=
  s

@[simp] theorem colex.eq_iff {α : Type u_1} (A : finset α) (B : finset α) : finset.to_colex A = finset.to_colex B ↔ A = B :=
  iff.refl (finset.to_colex A = finset.to_colex B)

/--
`A` is less than `B` in the colex ordering if the largest thing that's not in both sets is in B.
In other words, max (A ▵ B) ∈ B (if the maximum exists).
-/
protected instance finset.colex.has_lt {α : Type u_1} [HasLess α] : HasLess (finset.colex α) :=
  { Less := fun (A B : finset α) => ∃ (k : α), (∀ {x : α}, k < x → (x ∈ A ↔ x ∈ B)) ∧ ¬k ∈ A ∧ k ∈ B }

/-- We can define (≤) in the obvious way. -/
protected instance finset.colex.has_le {α : Type u_1} [HasLess α] : HasLessEq (finset.colex α) :=
  { LessEq := fun (A B : finset.colex α) => A < B ∨ A = B }

theorem colex.lt_def {α : Type u_1} [HasLess α] (A : finset α) (B : finset α) : finset.to_colex A < finset.to_colex B ↔ ∃ (k : α), (∀ {x : α}, k < x → (x ∈ A ↔ x ∈ B)) ∧ ¬k ∈ A ∧ k ∈ B :=
  iff.rfl

theorem colex.le_def {α : Type u_1} [HasLess α] (A : finset α) (B : finset α) : finset.to_colex A ≤ finset.to_colex B ↔ finset.to_colex A < finset.to_colex B ∨ A = B :=
  iff.rfl

/-- If everything in A is less than k, we can bound the sum of powers. -/
theorem nat.sum_pow_two_lt {k : ℕ} {A : finset ℕ} (h₁ : ∀ {x : ℕ}, x ∈ A → x < k) : finset.sum A (pow (bit0 1)) < bit0 1 ^ k := sorry

namespace colex

/-- Strictly monotone functions preserve the colex ordering. -/
theorem hom {α : Type u_1} {β : Type u_2} [linear_order α] [DecidableEq β] [preorder β] {f : α → β} (h₁ : strict_mono f) (A : finset α) (B : finset α) : finset.to_colex (finset.image f A) < finset.to_colex (finset.image f B) ↔ finset.to_colex A < finset.to_colex B := sorry

/-- A special case of `colex_hom` which is sometimes useful. -/
@[simp] theorem hom_fin {n : ℕ} (A : finset (fin n)) (B : finset (fin n)) : finset.to_colex (finset.image (fun (n_1 : fin n) => ↑n_1) A) <
    finset.to_colex (finset.image (fun (n_1 : fin n) => ↑n_1) B) ↔
  finset.to_colex A < finset.to_colex B :=
  hom (fun (x y : fin n) (k : x < y) => k) A B

protected instance has_lt.lt.is_irrefl {α : Type u_1} [HasLess α] : is_irrefl (finset.colex α) Less :=
  is_irrefl.mk
    fun (A : finset.colex α) (h : A < A) =>
      exists.elim h fun (_x : α) (_x : (∀ {x : α}, _x < x → (x ∈ A ↔ x ∈ A)) ∧ ¬_x ∈ A ∧ _x ∈ A) => sorry

theorem lt_trans {α : Type u_1} [linear_order α] {a : finset.colex α} {b : finset.colex α} {c : finset.colex α} : a < b → b < c → a < c := sorry

theorem le_trans {α : Type u_1} [linear_order α] (a : finset.colex α) (b : finset.colex α) (c : finset.colex α) : a ≤ b → b ≤ c → a ≤ c :=
  fun (AB : a ≤ b) (BC : b ≤ c) =>
    or.elim AB (fun (k : a < b) => or.elim BC (fun (t : b < c) => Or.inl (lt_trans k t)) fun (t : b = c) => t ▸ AB)
      fun (k : a = b) => Eq.symm k ▸ BC

protected instance has_lt.lt.is_trans {α : Type u_1} [linear_order α] : is_trans (finset.colex α) Less :=
  is_trans.mk fun (_x _x_1 _x_2 : finset.colex α) => lt_trans

protected instance has_lt.lt.is_asymm {α : Type u_1} [linear_order α] : is_asymm (finset.colex α) Less :=
  Mathlib.is_asymm_of_is_trans_of_is_irrefl

protected instance has_lt.lt.is_strict_order {α : Type u_1} [linear_order α] : is_strict_order (finset.colex α) Less :=
  is_strict_order.mk

theorem lt_trichotomy {α : Type u_1} [linear_order α] (A : finset.colex α) (B : finset.colex α) : A < B ∨ A = B ∨ B < A := sorry

protected instance has_lt.lt.is_trichotomous {α : Type u_1} [linear_order α] : is_trichotomous (finset.colex α) Less :=
  is_trichotomous.mk lt_trichotomy

-- It should be possible to do this computably but it doesn't seem to make any difference for now.

protected instance finset.colex.linear_order {α : Type u_1} [linear_order α] : linear_order (finset.colex α) :=
  linear_order.mk LessEq (partial_order.lt._default LessEq) sorry le_trans sorry sorry (classical.dec_rel LessEq)
    Mathlib.decidable_eq_of_decidable_le Mathlib.decidable_lt_of_decidable_le

protected instance has_lt.lt.is_incomp_trans {α : Type u_1} [linear_order α] : is_incomp_trans (finset.colex α) Less :=
  is_incomp_trans.mk
    fun (A B C : finset.colex α) (ᾰ : ¬A < B ∧ ¬B < A) (ᾰ_1 : ¬B < C ∧ ¬C < B) =>
      and.dcases_on ᾰ
        fun (nAB : ¬A < B) (nBA : ¬B < A) =>
          and.dcases_on ᾰ_1
            fun (nBC : ¬B < C) (nCB : ¬C < B) =>
              eq.mpr
                (id
                  (Eq._oldrec (Eq.refl (¬A < C ∧ ¬C < A))
                    (or.resolve_right (or.resolve_left (lt_trichotomy A B) nAB) nBA)))
                (eq.mpr
                  (id
                    (Eq._oldrec (Eq.refl (¬B < C ∧ ¬C < B))
                      (or.resolve_right (or.resolve_left (lt_trichotomy B C) nBC) nCB)))
                  (eq.mpr (id (Eq._oldrec (Eq.refl (¬C < C ∧ ¬C < C)) (propext (and_self (¬C < C))))) (irrefl C)))

protected instance has_lt.lt.is_strict_weak_order {α : Type u_1} [linear_order α] : is_strict_weak_order (finset.colex α) Less :=
  is_strict_weak_order.mk

protected instance has_lt.lt.is_strict_total_order {α : Type u_1} [linear_order α] : is_strict_total_order (finset.colex α) Less :=
  is_strict_total_order.mk

/-- If {r} is less than or equal to s in the colexicographical sense,
  then s contains an element greater than or equal to r. -/
theorem mem_le_of_singleton_le {α : Type u_1} [linear_order α] {r : α} {s : finset α} : finset.to_colex (singleton r) ≤ finset.to_colex s → ∃ (x : α), ∃ (H : x ∈ s), r ≤ x := sorry

/-- s.to_colex < finset.to_colex {r} iff all elements of s are less than r. -/
theorem lt_singleton_iff_mem_lt {α : Type u_1} [linear_order α] {r : α} {s : finset α} : finset.to_colex s < finset.to_colex (singleton r) ↔ ∀ (x : α), x ∈ s → x < r := sorry

/-- Colex is an extension of the base ordering on α. -/
theorem singleton_lt_iff_lt {α : Type u_1} [linear_order α] {r : α} {s : α} : finset.to_colex (singleton r) < finset.to_colex (singleton s) ↔ r < s := sorry

/--
If A is before B in colex, and everything in B is small, then everything in A is small.
-/
theorem forall_lt_of_colex_lt_of_forall_lt {α : Type u_1} [linear_order α] {A : finset α} {B : finset α} (t : α) (h₁ : finset.to_colex A < finset.to_colex B) (h₂ : ∀ (x : α), x ∈ B → x < t) (x : α) (H : x ∈ A) : x < t := sorry

/-- Colex doesn't care if you remove the other set -/
@[simp] theorem sdiff_lt_sdiff_iff_lt {α : Type u_1} [HasLess α] [DecidableEq α] (A : finset α) (B : finset α) : finset.to_colex (A \ B) < finset.to_colex (B \ A) ↔ finset.to_colex A < finset.to_colex B := sorry

/-- For subsets of ℕ, we can show that colex is equivalent to binary. -/
theorem sum_pow_two_lt_iff_lt (A : finset ℕ) (B : finset ℕ) : finset.sum A (pow (bit0 1)) < finset.sum B (pow (bit0 1)) ↔ finset.to_colex A < finset.to_colex B := sorry


import data.real.basic data.num.lemmas

section

local attribute [semireducible] reflected

meta instance rat.reflect : has_reflect ℚ
| ⟨n, d, _, _⟩ := `(rat.mk_nat %%(reflect n) %%(reflect d))

end

meta def tactic.interactive.intros' : tactic unit :=
`[repeat {intro}, resetI]

attribute [elim_cast] znum.cast_inj
attribute [squash_cast] znum.to_of_int
attribute [squash_cast] znum.cast_zero
attribute [move_cast] znum.cast_add
--TODO

namespace list

theorem filter_perm {α} {p : α → Prop} [decidable_pred p] {l : list α} :
  l ~ l.filter p ++ l.filter (not ∘ p) :=
begin
  induction l with x xs ih,
  { simp },
  { by_cases hx : p x,
    { simp [filter, hx, perm.skip, ih] },
    { calc
      x::xs ~ x::(filter p xs ++ filter (not ∘ p) xs) : perm.skip _ ih
      ... ~ filter p xs ++ x::filter (not ∘ p) xs : perm.symm perm_middle
      ... ~ filter p (x::xs) ++ filter (not ∘ p) (x::xs) : by simp [hx] }}
end

theorem prod_ones {α} [monoid α] {l : list α} :
  (∀ x : α, x ∈ l → x = 1) → l.prod = 1 :=
begin
  intro h,
  induction l with x xs ih,
  { refl },
  { have h1 : x = 1, by { apply h, simp },
    have h2 : prod xs = 1, by { apply ih, intros _ hx, apply h, simp [hx] },
    simp [h1, h2] }
end

theorem sum_zeros {α} [add_monoid α] {l : list α} :
  (∀ x : α, x ∈ l → x = 0) → l.sum = 0 :=
begin
  intro h,
  induction l with x xs ih,
  { refl },
  { have h1 : x = 0, by { apply h, simp },
    have h2 : sum xs = 0, by { apply ih, intros _ hx, apply h, simp [hx] },
    simp [h1, h2] }
end

end list

namespace polya.field

structure dict (α : Type) :=
(val : num → α)

class morph (γ : Type) [discrete_field γ] (α : Type) [discrete_field α] :=
(cast   : has_coe γ α)
(morph_zero : ((0 : γ) : α) = 0)
(morph_one : ((1 : γ) : α) = 1)
(morph_add : ∀ a b : γ, ((a + b : γ) : α) = a + b)
(morph_neg : ∀ a : γ, ((-a : γ) : α) = -a)
(morph_mul : ∀ a b : γ, ((a * b : γ) : α) = a * b)
(morph_inv : ∀ a : γ, ((a⁻¹ : γ) : α) = a⁻¹)
(morph_inj : ∀ a : γ, (a : α) = 0 → a = 0)

namespace morph

variables {α : Type} [discrete_field α]
variables {γ : Type} [discrete_field γ]
variables [morph γ α]
variables {a b : γ}

instance has_coe : has_coe γ α := morph.cast γ α

@[simp, squash_cast] theorem morph_zero' : ((0 : γ) : α) = 0 := by apply morph.morph_zero
@[simp, squash_cast] theorem morph_one'  : ((1 : γ) : α) = 1 := by apply morph.morph_one

@[simp, move_cast] theorem morph_add' : ((a + b : γ) : α) = a + b := by apply morph_add
@[simp, move_cast] theorem morph_neg' : ((-a : γ) : α) = -a       := by apply morph_neg
@[simp, move_cast] theorem morph_mul' : ((a * b : γ) : α) = a * b := by apply morph_mul
@[simp, move_cast] theorem morph_inv' : ((a⁻¹ : γ) : α) = a⁻¹     := by apply morph_inv

@[simp, move_cast] theorem morph_sub : ((a - b : γ) : α) = a - b :=
by rw [sub_eq_add_neg, morph.morph_add, morph.morph_neg, ← sub_eq_add_neg]

@[simp, elim_cast] theorem morph_inj' : (a : α) = b ↔ a = b :=
begin
  apply iff.intro,
  { intro h, apply eq_of_sub_eq_zero,
    apply morph.morph_inj (a - b),
    rw morph.morph_sub,
    apply sub_eq_zero_of_eq,
    apply h },
  { intro h, subst h }
end

@[simp, move_cast] theorem morph_div : ((a / b : γ) : α) = a / b :=
by rw [division_def, morph.morph_mul, morph.morph_inv, ← division_def]

@[simp, move_cast] theorem morph_pow_nat {n : ℕ} : ((a ^ n : γ) : α) = a ^ n :=
begin
  induction n with _ ih,
  { rw [pow_zero, pow_zero, morph.morph_one] },
  { by_cases ha : a = 0,
    { rw [ha, morph.morph_zero, zero_pow, zero_pow],
      { apply morph.morph_zero },
      { apply nat.succ_pos },
      { apply nat.succ_pos }},
    { rw [pow_succ, morph.morph_mul, ih, ← pow_succ] }}
end

@[simp, move_cast] theorem morph_pow {n : ℤ} : ((a ^ n : γ) : α) = a ^ n :=
begin
  cases n,
  { rw [int.of_nat_eq_coe, fpow_of_nat, fpow_of_nat],
    apply morph_pow_nat },
  { rw [int.neg_succ_of_nat_coe, fpow_neg, fpow_neg],
    rw [morph_div, morph.morph_one],
    rw [fpow_of_nat, fpow_of_nat],
    rw morph_pow_nat }
end

@[simp, squash_cast] theorem morph_nat {n : ℕ} : ((n : γ) : α) = (n : α) :=
by { induction n with n ih, { simp }, { simp [ih] } }

@[simp, squash_cast] theorem morph_num {n : num} : ((n : γ) : α) = (n : α) :=
by rw [← num.cast_to_nat, ← num.cast_to_nat, morph_nat, num.cast_to_nat, num.cast_to_nat]

end morph

class const_space (γ : Type) : Type :=
(df : discrete_field γ)
(lt : γ → γ → Prop)
(dec : decidable_rel lt)

namespace const_space

variables {α : Type} [discrete_field α]
variables {γ : Type} [const_space γ]

instance : discrete_field γ := const_space.df γ
instance : has_lt γ := ⟨const_space.lt⟩
instance : decidable_rel ((<) : γ → γ → Prop) := const_space.dec γ

end const_space

@[derive decidable_eq, derive has_reflect]
inductive nterm (γ : Type) [const_space γ] : Type
| atom  {} : num → nterm
| const {} : γ → nterm
| add   {} : nterm → nterm → nterm
| mul   {} : nterm → nterm → nterm
| pow   {} : nterm → znum → nterm

namespace nterm
variables {α : Type} [discrete_field α]
variables {γ : Type} [const_space γ]
variables [morph γ α] {ρ : dict α}

instance : inhabited (nterm γ) := ⟨const 0⟩

def blt :
  nterm γ → nterm γ → bool
| (const a) (const b) := a < b
| (const _) _         := tt
| _         (const _) := ff
| (atom i)  (atom j)  := i < j
| (atom _)  _         := tt
| _         (atom _)  := ff
| (add x y) (add z w) := if y = w then blt x z else blt y w
| (add _ _) _         := tt
| _         (add _ _) := ff
| (mul x y) (mul z w) := if y = w then blt x z else blt y w
| (mul _ _) _         := tt
| _         (mul _ _) := ff
| (pow x n) (pow y m) := if x = y then n < m else blt x y

def lt : nterm γ → nterm γ → Prop := λ x y, blt x y
instance : has_lt (nterm γ) := ⟨lt⟩
instance dec_lt : decidable_rel ((<) : nterm γ → nterm γ → Prop) := by dsimp [has_lt.lt, lt]; apply_instance

def eval (ρ : dict α) : nterm γ → α
| (atom i)  := ρ.val i
| (const c) := ↑c
| (add x y) := eval x + eval y
| (mul x y) := eval x * eval y
| (pow x n) := eval x ^ (n : ℤ)

instance coe_atom : has_coe num (nterm γ) := ⟨atom⟩
instance coe_const: has_coe γ (nterm γ) := ⟨const⟩
instance : has_zero (nterm γ) := ⟨mul (const 1) (const 0)⟩
instance : has_one (nterm γ) := ⟨mul (const 1) (const 1)⟩
instance : has_add (nterm γ) := ⟨add⟩
instance : has_mul (nterm γ) := ⟨mul⟩
instance : has_pow (nterm γ) znum := ⟨pow⟩
instance pow_int : has_pow (nterm γ) ℤ := ⟨λ x n, x.pow (n : znum)⟩
instance pow_nat : has_pow (nterm γ) ℕ := ⟨λ (x : nterm γ) (n : ℕ), x ^ (n : ℤ)⟩

def neg (x : nterm γ) : nterm γ := x * (-1 : γ)
instance : has_neg (nterm γ) := ⟨neg⟩
def sub (x y : nterm γ) : nterm γ := x + (-y)
instance : has_sub (nterm γ) := ⟨sub⟩
def inv (x : nterm γ) : nterm γ := pow x (-1)
instance : has_inv (nterm γ) := ⟨inv⟩
def div (x y : nterm γ) : nterm γ := x * y⁻¹
instance : has_div (nterm γ) := ⟨div⟩

section
variables {x y : nterm γ} {i : num} {c : γ}
@[simp] theorem eval_zero :  eval ρ (0 : nterm γ) = 0       := by sorry
@[simp] theorem eval_one :   eval ρ (1 : nterm γ) = 1       := by sorry
@[simp] theorem eval_atom :  eval ρ (i : nterm γ) = ρ.val i := rfl
@[simp] theorem eval_const : eval ρ (c : nterm γ) = (c : α) := rfl

@[simp] theorem eval_add : eval ρ (x + y) = eval ρ x + eval ρ y := rfl
@[simp] theorem eval_mul : eval ρ (x * y) = eval ρ x * eval ρ y := rfl

@[simp] theorem eval_pow_int {n : ℤ} : eval ρ (x ^ n) = eval ρ x ^ n := by sorry
@[simp] theorem eval_pow_nat {n : ℕ} : eval ρ (x ^ n) = eval ρ x ^ n := eval_pow_int
@[simp] theorem eval_pow {n : znum} : eval ρ (x ^ n) = eval ρ x ^ (n : ℤ) := by sorry

@[simp] theorem eval_neg : (-x).eval ρ = - x.eval ρ :=
calc
eval ρ (-x)
    = eval ρ (neg x) : rfl
... = - eval ρ x     : by simp [neg, morph.morph_neg', morph.morph_one']

@[simp] theorem eval_sub : eval ρ (x - y) = eval ρ x - eval ρ y :=
calc
eval ρ (x - y)
    = eval ρ (sub x y)    : rfl
... = eval ρ x - eval ρ y : by simp [sub, sub_eq_add_neg]

@[simp] theorem eval_inv : eval ρ (x⁻¹) = (eval ρ x)⁻¹ :=
calc
eval ρ (x⁻¹)
    = eval ρ (inv x)        : rfl
... = (eval ρ x) ^ (-1 : ℤ) : by simp [inv, eval]
... = (eval ρ x)⁻¹          : fpow_inv _

@[simp] theorem eval_div : eval ρ (x / y) = eval ρ x / eval ρ y :=
calc
eval ρ (x / y)
    = eval ρ (div x y)    : rfl
... = eval ρ x / eval ρ y : by simp [div, div_eq_mul_inv]

end

meta def to_str [has_to_string γ] : (nterm γ) → string
| (atom i)  := "#" ++ to_string (i : ℕ)
| (const c) := "(" ++ to_string c ++ ")"
| (add x y) := "(" ++ to_str x ++ " + " ++ to_str y ++ ")"
| (mul x y) := "(" ++ to_str x ++ " * " ++ to_str y ++ ")"
| (pow x n) := to_str x ++ " ^ " ++ to_string (n : ℤ)

meta instance [has_to_string γ] : has_to_string (nterm γ) := ⟨to_str⟩
meta instance [has_to_string γ] : has_to_tactic_format (nterm γ) := ⟨λ x, return (to_str x : format)⟩

def sum : list (nterm γ) → nterm γ
| []      := const (0 : γ)
| [x]     := x
| (x::xs) := add (sum xs) x

def prod : list (nterm γ) → nterm γ
| []      := const (1 : γ)
| [x]     := x
| (x::xs) := mul (prod xs) x

theorem eval_sum (xs : list (nterm γ)) :
  (sum xs).eval ρ = list.sum (xs.map (nterm.eval ρ)) :=
begin
  induction xs with x0 xs ih,
  { simp [sum, eval] },
  { cases xs with x1 xs,
    { simp [sum, eval] },
    { simp [sum, eval, ih] }}
end

theorem eval_prod (xs : list (nterm γ)) :
  (prod xs).eval ρ = list.prod (xs.map (nterm.eval ρ)) :=
begin
  induction xs with x0 xs ih,
  { simp [prod, eval] },
  { cases xs with x1 xs,
    { simp [prod, eval] },
    { simp only [prod, list.map_cons, list.prod_cons, eval, ih],
      rw mul_comm }}
end

def scale (a : γ) : nterm γ → nterm γ
| (mul x (const b)) := mul x (const (b * a))
| (const b) := (const (b * a))
| x := mul x (const a)

def coeff : nterm γ → γ
| (mul x (const a)) := a
| (const a) := a
| x := 1

def term : nterm γ → nterm γ
| (mul x (const a)) := x
| (const _) := 1
| x := x

@[simp] theorem eval_scale {a : γ} {x : nterm γ} :
  eval ρ (x.scale a) = eval ρ x * a :=
begin
  cases x,
  case mul : x y {
    cases y,
    case const : b { simp [scale, eval, mul_assoc] },
    repeat { simp [scale, eval] }},
  case const : b { simp [scale, eval] },
  repeat { simp [scale, eval] }
end

theorem eval_term_coeff (x : nterm γ) : eval ρ x = eval ρ x.term * x.coeff :=
begin
  cases x,
  case mul : x y {
    cases y,
    case const : b { simp [term, coeff, eval, mul_assoc] },
    repeat { simp [term, coeff, eval] }},
  case const : b { simp [term, coeff, eval] },
  repeat { simp [term, coeff, eval] }
end

def exp : nterm γ → znum
| (pow _ n) := n
| _ := 1

def mem : nterm γ → nterm γ
| (pow x _) := x
| x := x

theorem eval_mem_exp (x : nterm γ) : eval ρ x = eval ρ (mem x) ^ (exp x : ℤ) :=
begin
  cases x,
  case pow : x n { dsimp [mem, exp, eval], refl },
  repeat { dsimp [mem, exp, eval], rw fpow_one }
end

--theorem eval_mem_zero {x : nterm γ} : eval ρ x = 0 → eval ρ (mem x) = 0 :=
--begin
--  intro h1, cases x,
--  case pow : x n { unfold mem, by_contradiction h2, exact fpow_ne_zero_of_ne_zero h2 _ h1 },
--  repeat { exact h1 },
--end

def pow_mul (n : znum) (x : nterm γ) : nterm γ :=
if n = 0 then
  const 1
else if x.exp * n = 1 then
  x.mem
else
  pow x.mem (x.exp * n)

def pow_div (n : znum) (x : nterm γ) : nterm γ :=
if n = x.exp then
  x.mem
else
  pow x.mem (x.exp / n)

@[simp] theorem eval_pow_mul {n : znum} {x : nterm γ} : eval ρ (pow_mul n x) = eval ρ x ^ (n : ℤ) :=
begin
  unfold pow_mul,
  by_cases h1 : n = 0,
  { simp [eval, h1] },
  { by_cases h2 : x.exp * n = 1,
    { rw [if_neg h1, if_pos h2, eval_mem_exp x],
      rw [← fpow_mul, ← znum.cast_mul, h2],
      simp },
    { rw [if_neg h1, if_neg h2], unfold eval,
      rw [znum.cast_mul, fpow_mul, ← eval_mem_exp]}}
end

@[simp] theorem eval_pow_div {n : znum} {x : nterm γ} : n ∣ x.exp → eval ρ (pow_div n x) ^ (n : ℤ) = eval ρ x :=
begin
  intro h1, cases h1 with d h1,
  unfold pow_div,
  by_cases h2 : n = exp x,
  { rw [if_pos h2, h2, ← eval_mem_exp] },
  { by_cases h3 : n = 0,
    { apply absurd _ h2, have : exp x = 0, { rw h1, simp [h3] }, rw [h3, this] },
    { rw [if_neg h2, h1], unfold eval,
      rw [znum.div_to_int, znum.cast_mul, int.mul_div_cancel_left],
      { rw [← fpow_mul, int.mul_comm, ← znum.cast_mul, ← h1, ← eval_mem_exp] },
      { rw [← znum.cast_zero], exact_mod_cast h3 }}}
end

def nonzero (ρ : dict α) (ts : list (nterm γ)) : Prop := ∀ t ∈ ts, nterm.eval ρ t ≠ 0

theorem nonzero_union {xs ys : list (nterm γ)} :
nonzero ρ (xs ∪ ys) ↔ nonzero ρ xs ∧ nonzero ρ ys :=
begin
  apply iff.intro,
  { intro h1, split; { intros _ h2, apply h1, simp [h2] }},
  { intros h1 t ht, cases h1 with h1 h2, rw list.mem_union at ht, cases ht,
    {apply h1, apply ht}, {apply h2, apply ht}}
end

theorem nonzero_subset {xs ys : list (nterm γ)} :
  xs ⊆ ys → nonzero ρ ys → nonzero ρ xs :=
begin
  intros h1 h2, intros x hx,
  apply h2, apply h1, apply hx
end

theorem nonzero_iff_zero_not_mem (ts : list (nterm γ)) :
nonzero ρ ts ↔ (0 : α) ∉ ts.map (nterm.eval ρ) :=
begin
  apply iff.intro,
  { intro h, simpa using h },
  { intro h, simp at h, apply h }
end

end nterm

set_option trace.app_builder true

@[derive decidable_eq]
inductive Term (γ : Type) [const_space γ] : bool → Type
| zero {} : Term tt
| one {} : Term ff
| sform {} : Term tt → Term ff → γ → Term tt
| pform {} : Term ff → Term tt → znum → znum → Term ff

namespace Term

open nterm

variables {γ : Type} [const_space γ]
variables {α : Type} [discrete_field α]
variables [morph γ α] {ρ : dict α}

--def blt : Π {a b : bool}, Term γ a → Term γ b → bool
--| .(_) .(_) zero            zero            := ff
--| .(_) _    zero            _               := tt
--| .(_) .(_) one             one             := ff
--| .(_) _    one             _               := tt
--| .(_) .(_) (sform x y a)   (sform u v b)   := blt y v ∨ (y = v ∧ blt x u) ∨ (y = v ∧ x = u ∧ a < b)
--| .(_) _    (sform _ _ _)   _               := tt
--| .(_) .(_) (pform x y n m) (pform u v i j) := blt y v ∨ (y = v ∧ blt x u) ∨ (y = v ∧ x = u ∧ (n, m) < (i, j))

def eval (ρ : dict α) : Π {b : bool}, Term γ b → α
| .(tt) zero := 0
| .(ff) one := 1
| .(tt) (sform x y a) := (eval x + eval y ) * a
| .(ff) (pform x y n m) := (eval x * (eval y ^ (n : ℤ))) ^ (m : ℤ)

def to_nterm : Π {b : bool}, Term γ b → nterm γ
| .(tt) zero := (const 0)
| .(ff) one := (const 1)
| .(tt) (sform x y a) := mul (add (to_nterm x) (to_nterm y)) (const a)
| .(ff) (pform x y n m) := nterm.pow (mul (to_nterm x) (nterm.pow (to_nterm y) n)) m

theorem correctness {ρ : dict α} {b : bool} {t : Term γ b} : eval ρ t = nterm.eval ρ (to_nterm t) :=
begin
  induction t with x y a ihx ihy x y n m ihx ihy,
  { simp [to_nterm, eval, nterm.eval] },
  { simp [to_nterm, eval, nterm.eval] },
  { simp [to_nterm, eval, nterm.eval, ihx, ihy] },
  { simp [to_nterm, eval, nterm.eval, ihx, ihy] },
end

def scale : γ → Term γ tt → Term γ tt
| _ zero := zero
| b (sform x y a) := sform x y (a * b)

theorem eval_scale {b : γ} {x : Term γ tt} : eval ρ (scale b x) = eval ρ x * (b : α) :=
begin
  cases x with x y a,
  { simp [scale, eval] },
  { simp [scale, eval, add_mul, mul_assoc] }
end

def add : Term γ tt → Term γ tt → Term γ tt := sorry

end Term

end polya.field


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

/-!
# The empty category

Defines a category structure on `pempty`, and the unique functor `pempty ⥤ C` for any category `C`.
-/

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

namespace category_theory
namespace functor

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

/-- Equivalence between two empty categories. -/
def empty_equivalence : discrete.{w} pempty ≌ discrete.{v} pempty :=
equivalence.mk
{ obj := pempty.elim, map := λ x, x.elim }
{ obj := pempty.elim, map := λ x, x.elim }
(by tidy) (by tidy)

/-- The canonical functor out of the empty category. -/
def empty : discrete.{w} pempty ⥤ C := discrete.functor pempty.elim

variable {C}
/-- Any two functors out of the empty category are isomorphic. -/
def empty_ext (F G : discrete.{w} pempty ⥤ C) : F ≅ G :=
discrete.nat_iso (λ x, pempty.elim x)

/--
Any functor out of the empty category is isomorphic to the canonical functor from the empty
category.
-/
def unique_from_empty (F : discrete.{w} pempty ⥤ C) : F ≅ empty C :=
empty_ext _ _

/--
Any two functors out of the empty category are *equal*. You probably want to use
`empty_ext` instead of this.
-/
lemma empty_ext' (F G : discrete.{w} pempty ⥤ C) : F = G :=
functor.ext (λ x, x.elim) (λ x _ _, x.elim)

end functor

end category_theory


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

import category_theory.localization.construction

/-!

# Predicate for localized categories

In this file, a predicate `L.is_localization W` is introduced for a functor `L : C ⥤ D`
and `W : morphism_property C`: it expresses that `L` identifies `D` with the localized
category of `C` with respect to `W` (up to equivalence).

We introduce a universal property `strict_universal_property_fixed_target L W E` which
states that `L` inverts the morphisms in `W` and that all functors `C ⥤ E` inverting
`W` uniquely factors as a composition of `L ⋙ G` with `G : D ⥤ E`. Such universal
properties are inputs for the constructor `is_localization.mk'` for `L.is_localization W`.

When `L : C ⥤ D` is a localization functor for `W : morphism_property` (i.e. when
`[L.is_localization W]` holds), for any category `E`, there is
an equivalence `functor_equivalence L W E : (D ⥤ E) ≌ (W.functors_inverting E)`
that is induced by the composition with the functor `L`. When two functors
`F : C ⥤ E` and `F' : D ⥤ E` correspond via this equivalence, we shall say
that `F'` lifts `F`, and the associated isomorphism `L ⋙ F' ≅ F` is the
datum that is part of the class `lifting L W F F'`. The functions
`lift_nat_trans` and `lift_nat_iso` can be used to lift natural transformations
and natural isomorphisms between functors.

-/

noncomputable theory

namespace category_theory

open category

variables {C D : Type*} [category C] [category D]
  (L : C ⥤ D) (W : morphism_property C)
  (E : Type*) [category E]

namespace functor

/-- The predicate expressing that, up to equivalence, a functor `L : C ⥤ D`
identifies the category `D` with the localized category of `C` with respect
to `W : morphism_property C`. -/
class is_localization : Prop :=
(inverts : W.is_inverted_by L)
(nonempty_is_equivalence : nonempty (is_equivalence (localization.construction.lift L inverts)))

instance Q_is_localization : W.Q.is_localization W :=
{ inverts := W.Q_inverts,
  nonempty_is_equivalence := begin
    suffices : localization.construction.lift W.Q W.Q_inverts = 𝟭 _,
    { apply nonempty.intro, rw this, apply_instance, },
    apply localization.construction.uniq,
    simpa only [localization.construction.fac],
  end, }

end functor

namespace localization

/-- This universal property states that a functor `L : C ⥤ D` inverts morphisms
in `W` and the all functors `D ⥤ E` (for a fixed category `E`) uniquely factors
through `L`. -/
structure strict_universal_property_fixed_target :=
(inverts : W.is_inverted_by L)
(lift : Π (F : C ⥤ E) (hF : W.is_inverted_by F), D ⥤ E)
(fac : Π (F : C ⥤ E) (hF : W.is_inverted_by F), L ⋙ lift F hF = F)
(uniq : Π (F₁ F₂ : D ⥤ E) (h : L ⋙ F₁ = L ⋙ F₂), F₁ = F₂)

/-- The localized category `W.localization` that was constructed satisfies
the universal property of the localization. -/
@[simps]
def strict_universal_property_fixed_target_Q :
  strict_universal_property_fixed_target W.Q W E :=
{ inverts := W.Q_inverts,
  lift := construction.lift,
  fac := construction.fac,
  uniq := construction.uniq, }

instance : inhabited (strict_universal_property_fixed_target W.Q W E) :=
⟨strict_universal_property_fixed_target_Q _ _⟩

/-- When `W` consists of isomorphisms, the identity satisfies the universal property
of the localization. -/
@[simps]
def strict_universal_property_fixed_target_id (hW : W ⊆ morphism_property.isomorphisms C):
  strict_universal_property_fixed_target (𝟭 C) W E :=
{ inverts := λ X Y f hf, hW f hf,
  lift := λ F hF, F,
  fac := λ F hF, by { cases F, refl, },
  uniq := λ F₁ F₂ eq, by { cases F₁, cases F₂, exact eq, }, }

end localization

namespace functor

lemma is_localization.mk'
  (h₁ : localization.strict_universal_property_fixed_target L W D)
  (h₂ : localization.strict_universal_property_fixed_target L W W.localization) :
  is_localization L W :=
{ inverts := h₁.inverts,
  nonempty_is_equivalence := nonempty.intro
  { inverse := h₂.lift W.Q W.Q_inverts,
    unit_iso := eq_to_iso (localization.construction.uniq _ _
      (by simp only [← functor.assoc, localization.construction.fac, h₂.fac, functor.comp_id])),
    counit_iso := eq_to_iso (h₁.uniq _ _ (by simp only [← functor.assoc, h₂.fac,
      localization.construction.fac, functor.comp_id])),
    functor_unit_iso_comp' := λ X, by simpa only [eq_to_iso.hom, eq_to_hom_app,
      eq_to_hom_map, eq_to_hom_trans, eq_to_hom_refl], }, }

lemma is_localization.for_id (hW : W ⊆ morphism_property.isomorphisms C):
  (𝟭 C).is_localization W :=
is_localization.mk' _ _
  (localization.strict_universal_property_fixed_target_id W _ hW)
  (localization.strict_universal_property_fixed_target_id W _ hW)

end functor

namespace localization

variable [L.is_localization W]

lemma inverts : W.is_inverted_by L := (infer_instance : L.is_localization W).inverts

/-- The isomorphism `L.obj X ≅ L.obj Y` that is deduced from a morphism `f : X ⟶ Y` which
belongs to `W`, when `L.is_localization W`. -/
@[simps]
def iso_of_hom {X Y : C} (f : X ⟶ Y) (hf : W f) : L.obj X ≅ L.obj Y :=
by { haveI : is_iso (L.map f) := inverts L W f hf, exact as_iso (L.map f), }

instance : is_equivalence (localization.construction.lift L (inverts L W)) :=
(infer_instance : L.is_localization W).nonempty_is_equivalence.some

/-- A chosen equivalence of categories `W.localization ≅ D` for a functor
`L : C ⥤ D` which satisfies `L.is_localization W`. This shall be used in
order to deduce properties of `L` from properties of `W.Q`. -/
def equivalence_from_model : W.localization ≌ D :=
(localization.construction.lift L (inverts L W)).as_equivalence

/-- Via the equivalence of categories `equivalence_from_model L W : W.localization ≌ D`,
one may identify the functors `W.Q` and `L`. -/
def Q_comp_equivalence_from_model_functor_iso :
  W.Q ⋙ (equivalence_from_model L W).functor ≅ L := eq_to_iso (construction.fac _ _)

/-- Via the equivalence of categories `equivalence_from_model L W : W.localization ≌ D`,
one may identify the functors `L` and `W.Q`. -/
def comp_equivalence_from_model_inverse_iso :
  L ⋙ (equivalence_from_model L W).inverse ≅ W.Q :=
calc L ⋙ (equivalence_from_model L W).inverse ≅ _ :
  iso_whisker_right (Q_comp_equivalence_from_model_functor_iso L W).symm _
... ≅ W.Q ⋙ ((equivalence_from_model L W).functor ⋙ (equivalence_from_model L W).inverse) :
  functor.associator _ _ _
... ≅ W.Q ⋙ 𝟭 _ : iso_whisker_left _ ((equivalence_from_model L W).unit_iso.symm)
... ≅ W.Q : functor.right_unitor _

lemma ess_surj : ess_surj L :=
⟨λ X, ⟨(construction.obj_equiv W).inv_fun ((equivalence_from_model L W).inverse.obj X),
  nonempty.intro ((Q_comp_equivalence_from_model_functor_iso L W).symm.app _ ≪≫
  (equivalence_from_model L W).counit_iso.app X)⟩⟩

/-- The functor `(D ⥤ E) ⥤ W.functors_inverting E` induced by the composition
with a localization functor `L : C ⥤ D` with respect to `W : morphism_property C`. -/
def whiskering_left_functor : (D ⥤ E) ⥤ W.functors_inverting E :=
full_subcategory.lift _ ((whiskering_left _ _ E).obj L)
  (morphism_property.is_inverted_by.of_comp W L (inverts L W ))

instance : is_equivalence (whiskering_left_functor L W E) :=
begin
  refine is_equivalence.of_iso _ (is_equivalence.of_equivalence
    ((equivalence.congr_left (equivalence_from_model L W).symm).trans
    (construction.whiskering_left_equivalence W E))),
  refine nat_iso.of_components (λ F, eq_to_iso begin
    ext,
    change (W.Q ⋙ (localization.construction.lift L (inverts L W))) ⋙ F = L ⋙ F,
    rw construction.fac,
  end)
  (λ F₁ F₂ τ, begin
    ext X,
    dsimp [equivalence_from_model, whisker_left, construction.whiskering_left_equivalence,
      construction.whiskering_left_equivalence.functor, whiskering_left_functor,
      morphism_property.Q],
    erw [nat_trans.comp_app, nat_trans.comp_app, eq_to_hom_app, eq_to_hom_app,
      eq_to_hom_refl, eq_to_hom_refl, comp_id, id_comp],
    all_goals
    { change (W.Q ⋙ (localization.construction.lift L (inverts L W))) ⋙ _ = L ⋙ _,
      rw construction.fac, },
  end),
end

/-- The equivalence of categories `(D ⥤ E) ≌ (W.functors_inverting E)` induced by
the composition with a localization functor `L : C ⥤ D` with respect to
`W : morphism_property C`. -/
def functor_equivalence : (D ⥤ E) ≌ (W.functors_inverting E) :=
(whiskering_left_functor L W E).as_equivalence

include W

/-- The functor `(D ⥤ E) ⥤ (C ⥤ E)` given by the composition with a localization
functor `L : C ⥤ D` with respect to `W : morphism_property C`. -/
@[nolint unused_arguments]
def whiskering_left_functor' :
  (D ⥤ E) ⥤ (C ⥤ E) := (whiskering_left C D E).obj L

lemma whiskering_left_functor'_eq :
  whiskering_left_functor' L W E =
    localization.whiskering_left_functor L W E ⋙ induced_functor _ := rfl

variable {E}

@[simp]
lemma whiskering_left_functor'_obj
  (F : D ⥤ E) : (whiskering_left_functor' L W E).obj F = L ⋙ F := rfl

instance : full (whiskering_left_functor' L W E) :=
by { rw whiskering_left_functor'_eq, apply_instance, }

instance : faithful (whiskering_left_functor' L W E) :=
by { rw whiskering_left_functor'_eq, apply_instance, }

lemma nat_trans_ext {F₁ F₂ : D ⥤ E} (τ τ' : F₁ ⟶ F₂)
  (h : ∀ (X : C), τ.app (L.obj X) = τ'.app (L.obj X)) : τ = τ' :=
begin
  haveI : category_theory.ess_surj L := ess_surj L W,
  ext Y,
  rw [← cancel_epi (F₁.map (L.obj_obj_preimage_iso Y).hom), τ.naturality, τ'.naturality, h],
end

/-- When `L : C ⥤ D` is a localization functor for `W : morphism_property C` and
`F : C ⥤ E` is a functor, we shall say that `F' : D ⥤ E` lifts `F` if the obvious diagram
is commutative up to an isomorphism. -/
class lifting (F : C ⥤ E) (F' : D ⥤ E) :=
(iso [] : L ⋙ F' ≅ F)

variable {W}

/-- Given a localization functor `L : C ⥤ D` for `W : morphism_property C` and
a functor `F : C ⥤ E` which inverts `W`, this is a choice of functor
`D ⥤ E` which lifts `F`. -/
def lift (F : C ⥤ E) (hF : W.is_inverted_by F) (L : C ⥤ D) [hL : L.is_localization W] :
  D ⥤ E :=
(functor_equivalence L W E).inverse.obj ⟨F, hF⟩

instance lifting_lift (F : C ⥤ E) (hF : W.is_inverted_by F) (L : C ⥤ D)
  [hL : L.is_localization W] : lifting L W F (lift F hF L) :=
⟨(induced_functor _).map_iso ((functor_equivalence L W E).counit_iso.app ⟨F, hF⟩)⟩

/-- The canonical isomorphism `L ⋙ lift F hF L ≅ F` for any functor `F : C ⥤ E`
which inverts `W`, when `L : C ⥤ D` is a localization functor for `W`. -/
@[simps]
def fac (F : C ⥤ E) (hF : W.is_inverted_by F) (L : C ⥤ D) [hL : L.is_localization W] :
  L ⋙ lift F hF L ≅ F :=
lifting.iso _ W _ _

instance lifting_construction_lift (F : C ⥤ D) (hF : W.is_inverted_by F) :
  lifting W.Q W F (construction.lift F hF) :=
⟨eq_to_iso (construction.fac F hF)⟩

variable (W)

/-- Given a localization functor `L : C ⥤ D` for `W : morphism_property C`,
if `(F₁' F₂' : D ⥤ E)` are functors which lifts functors `(F₁ F₂ : C ⥤ E)`,
a natural transformation `τ : F₁ ⟶ F₂` uniquely lifts to a natural transformation `F₁' ⟶ F₂'`. -/
def lift_nat_trans (F₁ F₂ : C ⥤ E) (F₁' F₂' : D ⥤ E) [lifting L W F₁ F₁']
  [h₂ : lifting L W F₂ F₂'] (τ : F₁ ⟶ F₂) : F₁' ⟶ F₂' :=
(whiskering_left_functor' L W E).preimage
  ((lifting.iso L W F₁ F₁').hom ≫ τ ≫ (lifting.iso L W F₂ F₂').inv)

@[simp]
lemma lift_nat_trans_app (F₁ F₂ : C ⥤ E) (F₁' F₂' : D ⥤ E) [lifting L W F₁ F₁']
  [lifting L W F₂ F₂'] (τ : F₁ ⟶ F₂) (X : C) :
  (lift_nat_trans L W F₁ F₂ F₁' F₂' τ).app (L.obj X) =
    (lifting.iso L W F₁ F₁').hom.app X ≫ τ.app X ≫ ((lifting.iso L W F₂ F₂')).inv.app X :=
congr_app (functor.image_preimage (whiskering_left_functor' L W E) _) X

@[simp, reassoc]
lemma comp_lift_nat_trans (F₁ F₂ F₃ : C ⥤ E) (F₁' F₂' F₃' : D ⥤ E)
  [h₁ : lifting L W F₁ F₁'] [h₂ : lifting L W F₂ F₂'] [h₃ : lifting L W F₃ F₃']
  (τ : F₁ ⟶ F₂) (τ' : F₂ ⟶ F₃) :
  lift_nat_trans L W F₁ F₂ F₁' F₂' τ ≫ lift_nat_trans L W F₂ F₃ F₂' F₃' τ' =
  lift_nat_trans L W F₁ F₃ F₁' F₃' (τ ≫ τ') :=
nat_trans_ext L W _ _
  (λ X, by simp only [nat_trans.comp_app, lift_nat_trans_app, assoc, iso.inv_hom_id_app_assoc])

@[simp]
lemma lift_nat_trans_id (F : C ⥤ E) (F' : D ⥤ E) [h : lifting L W F F'] :
  lift_nat_trans L W F F F' F' (𝟙 F) = 𝟙 F' :=
nat_trans_ext L W _ _
  (λ X, by simpa only [lift_nat_trans_app, nat_trans.id_app, id_comp, iso.hom_inv_id_app])

/-- Given a localization functor `L : C ⥤ D` for `W : morphism_property C`,
if `(F₁' F₂' : D ⥤ E)` are functors which lifts functors `(F₁ F₂ : C ⥤ E)`,
a natural isomorphism `τ : F₁ ⟶ F₂` lifts to a natural isomorphism `F₁' ⟶ F₂'`. -/
@[simps]
def lift_nat_iso (F₁ F₂ : C ⥤ E) (F₁' F₂' : D ⥤ E)
  [h₁ : lifting L W F₁ F₁'] [h₂ : lifting L W F₂ F₂']
  (e : F₁ ≅ F₂) : F₁' ≅ F₂' :=
{ hom := lift_nat_trans L W F₁ F₂ F₁' F₂' e.hom,
  inv := lift_nat_trans L W F₂ F₁ F₂' F₁' e.inv, }

namespace lifting

@[simps]
instance comp_right {E' : Type*} [category E'] (F : C ⥤ E) (F' : D ⥤ E) [lifting L W F F']
  (G : E ⥤ E') : lifting L W (F ⋙ G) (F' ⋙ G) :=
⟨iso_whisker_right (iso L W F F') G⟩

@[simps]
instance id : lifting L W L (𝟭 D) :=
⟨functor.right_unitor L⟩

/-- Given a localization functor `L : C ⥤ D` for `W : morphism_property C`,
if `F₁' : D ⥤ E` lifts a functor `F₁ : C ⥤ D`, then a functor `F₂'` which
is isomorphic to `F₁'` also lifts a functor `F₂` that is isomorphic to `F₁`.  -/
@[simps]
def of_isos {F₁ F₂ : C ⥤ E} {F₁' F₂' : D ⥤ E} (e : F₁ ≅ F₂) (e' : F₁' ≅ F₂')
  [lifting L W F₁ F₁'] : lifting L W F₂ F₂' :=
⟨iso_whisker_left L e'.symm ≪≫ iso L W F₁ F₁' ≪≫ e⟩

end lifting

end localization

namespace functor

namespace is_localization

open localization

lemma of_iso {L₁ L₂ : C ⥤ D} (e : L₁ ≅ L₂) [L₁.is_localization W] : L₂.is_localization W :=
begin
  have h := localization.inverts L₁ W,
  rw morphism_property.is_inverted_by.iff_of_iso W e at h,
  let F₁ := localization.construction.lift L₁ (localization.inverts L₁ W),
  let F₂ := localization.construction.lift L₂ h,
  exact
  { inverts := h,
    nonempty_is_equivalence := nonempty.intro
      (is_equivalence.of_iso (lift_nat_iso W.Q W L₁ L₂ F₁ F₂ e) infer_instance), },
end

/-- If `L : C ⥤ D` is a localization for `W : morphism_property C`, then it is also
the case of a functor obtained by post-composing `L` with an equivalence of categories. -/
lemma of_equivalence_target {E : Type*} [category E] (L' : C ⥤ E) (eq : D ≌ E)
  [L.is_localization W] (e : L ⋙ eq.functor ≅ L') : L'.is_localization W :=
begin
  have h : W.is_inverted_by L',
  { rw ← morphism_property.is_inverted_by.iff_of_iso W e,
    exact morphism_property.is_inverted_by.of_comp W L (localization.inverts L W) eq.functor, },
  let F₁ := localization.construction.lift L (localization.inverts L W),
  let F₂ := localization.construction.lift L' h,
  let e' : F₁ ⋙ eq.functor ≅ F₂ := lift_nat_iso W.Q W (L ⋙ eq.functor) L' _ _ e,
  exact
  { inverts := h,
    nonempty_is_equivalence := nonempty.intro (is_equivalence.of_iso e' infer_instance) },
end

end is_localization

end functor

end category_theory


/-
Copyright (c) 2021 Yaël Dillies. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yaël Dillies, Scott Morrison
-/
import data.finset.lattice
import data.multiset.functor

/-!
# Functoriality of `finset`

This file defines the functor structure of `finset`.

## TODO

Currently, all instances are classical because the functor classes want to run over all types. If
instead we could state that a functor is lawful/applicative/traversable... between two given types,
then we could provide the instances for types with decidable equality.
-/

universes u

open function

namespace finset

/-! ### Functor -/

section functor
variables {α β : Type u} [Π P, decidable P]

/-- Because `finset.image` requires a `decidable_eq` instance for the target type, we can only
construct `functor finset` when working classically. -/
instance : functor finset :=
{ map := λ α β f s, s.image f }

instance : is_lawful_functor finset :=
{ id_map := λ α s, image_id,
  comp_map := λ α β γ f g s, image_image.symm }

@[simp] lemma fmap_def {s : finset α} (f : α → β) : f <$> s = s.image f := rfl

end functor

/-! ### Pure -/

instance : has_pure finset := ⟨λ α x, {x}⟩

@[simp] lemma pure_def {α} : (pure : α → finset α) = singleton := rfl

/-! ### Applicative functor -/

section applicative
variables {α β : Type u} [Π P, decidable P]

instance : applicative finset :=
{ seq := λ α β t s, t.sup (λ f, s.image f),
  seq_left := λ α β s t, if t = ∅ then ∅ else s,
  seq_right := λ α β s t, if s = ∅ then ∅ else t,
  .. finset.functor,
  .. finset.has_pure }

@[simp] lemma seq_def (s : finset α) (t : finset (α → β)) : t <*> s = t.sup (λ f, s.image f) := rfl
@[simp] lemma seq_left_def (s : finset α) (t : finset β)  : s <* t = if t = ∅ then ∅ else s := rfl
@[simp] lemma seq_right_def (s : finset α) (t : finset β)  : s *> t = if s = ∅ then ∅ else t := rfl

instance : is_lawful_applicative finset :=
{ seq_left_eq := λ α β s t, begin
    rw [seq_def, fmap_def, seq_left_def],
    obtain rfl | ht := t.eq_empty_or_nonempty,
    { simp_rw [if_pos rfl, image_empty], exact (sup_bot _).symm },
    { ext a,
      rw [if_neg ht.ne_empty, mem_sup],
      refine ⟨λ ha, ⟨const β a, mem_image_of_mem _ ha, mem_image_const_self.2 ht⟩, _⟩,
      rintro ⟨f, hf, ha⟩,
      rw mem_image at hf ha,
      obtain ⟨b, hb, rfl⟩ := hf,
      obtain ⟨_, _, rfl⟩ := ha,
      exact hb }
  end,
  seq_right_eq := λ α β s t, begin
    rw [seq_def, fmap_def, seq_right_def],
    obtain rfl | hs := s.eq_empty_or_nonempty,
    { rw [if_pos rfl, image_empty, sup_empty, bot_eq_empty] },
    { ext a,
      rw [if_neg hs.ne_empty, mem_sup],
      refine ⟨λ ha, ⟨id, mem_image_const_self.2 hs, by rwa image_id⟩, _⟩,
      rintro ⟨f, hf, ha⟩,
      rw mem_image at hf ha,
      obtain ⟨b, hb, rfl⟩ := ha,
      obtain ⟨_, _, rfl⟩ := hf,
      exact hb }
  end,
  pure_seq_eq_map := λ α β f s, sup_singleton,
  map_pure := λ α β f a, image_singleton _ _,
  seq_pure := λ α β s a, sup_singleton'' _ _,
  seq_assoc := λ α β γ s t u, begin
    ext a,
    simp_rw [seq_def, fmap_def],
    simp only [exists_prop, mem_sup, mem_image],
    split,
    { rintro ⟨g, hg, b, ⟨f, hf, a, ha, rfl⟩, rfl⟩,
      exact ⟨g ∘ f, ⟨comp g, ⟨g, hg, rfl⟩, f, hf, rfl⟩, a, ha, rfl⟩ },
    { rintro ⟨c, ⟨_, ⟨g, hg, rfl⟩, f, hf, rfl⟩, a, ha, rfl⟩,
      exact ⟨g, hg, f a, ⟨f, hf, a, ha, rfl⟩, rfl⟩ }
  end,
  .. finset.is_lawful_functor }

instance : is_comm_applicative finset :=
{ commutative_prod := λ α β s t, begin
    simp_rw [seq_def, fmap_def, sup_image, sup_eq_bUnion],
    change s.bUnion (λ a, t.image $ λ b, (a, b)) = t.bUnion (λ b, s.image $ λ a, (a, b)),
    transitivity s.product t;
      [rw product_eq_bUnion, rw product_eq_bUnion_right]; congr; ext; simp_rw mem_image,
  end,
  .. finset.is_lawful_applicative }

end applicative

/-! ### Monad -/

section monad
variables [Π P, decidable P]

instance : monad finset :=
{ bind := λ α β, @sup _ _ _ _,
  .. finset.applicative }

@[simp] lemma bind_def {α β} : (>>=) = @sup (finset α) β _ _ := rfl

instance : is_lawful_monad finset :=
{ bind_pure_comp_eq_map := λ α β f s, sup_singleton'' _ _,
  bind_map_eq_seq := λ α β t s, rfl,
  pure_bind := λ α β t s, sup_singleton,
  bind_assoc :=  λ α β γ s f g, by { convert sup_bUnion _ _, exact sup_eq_bUnion _ _ },
  .. finset.is_lawful_applicative }

end monad

/-! ### Alternative functor -/

section alternative
variables [Π P, decidable P]

instance : alternative finset :=
{ orelse := λ α, (∪),
  failure := λ α, ∅,
  .. finset.applicative }

end alternative

/-! ### Traversable functor -/

section traversable
variables {α β γ : Type u} {F G : Type u → Type u} [applicative F] [applicative G]
  [is_comm_applicative F] [is_comm_applicative G]

/-- Traverse function for `finset`. -/
def traverse [decidable_eq β] (f : α → F β) (s :  finset α) : F (finset β) :=
multiset.to_finset <$> multiset.traverse f s.1

@[simp] lemma id_traverse [decidable_eq α] (s : finset α) : traverse id.mk s = s :=
by { rw [traverse, multiset.id_traverse], exact s.val_to_finset }

open_locale classical

@[simp] lemma map_comp_coe (h : α → β) :
  functor.map h ∘ multiset.to_finset = multiset.to_finset ∘ functor.map h :=
funext $ λ s, image_to_finset

lemma map_traverse (g : α → G β) (h : β → γ) (s : finset α) :
  functor.map h <$> traverse g s = traverse (functor.map h ∘ g) s :=
begin
  unfold traverse,
  simp only [map_comp_coe] with functor_norm,
  rw [is_lawful_functor.comp_map, multiset.map_traverse],
end

end traversable
end finset


/-
Copyright (c) 2021 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import algebra.big_operators.basic
import algebra.big_operators.pi
import category_theory.limits.shapes.biproducts
import category_theory.preadditive.basic
import category_theory.preadditive.additive_functor
import data.matrix.dmatrix
import data.matrix.basic
import category_theory.Fintype
import category_theory.preadditive.single_obj
import algebra.opposites

/-!
# Matrices over a category.

When `C` is a preadditive category, `Mat_ C` is the preadditive category
whose objects are finite tuples of objects in `C`, and
whose morphisms are matrices of morphisms from `C`.

There is a functor `Mat_.embedding : C ⥤ Mat_ C` sending morphisms to one-by-one matrices.

`Mat_ C` has finite biproducts.

## The additive envelope

We show that this construction is the "additive envelope" of `C`,
in the sense that any additive functor `F : C ⥤ D` to a category `D` with biproducts
lifts to a functor `Mat_.lift F : Mat_ C ⥤ D`,
Moreover, this functor is unique (up to natural isomorphisms) amongst functors `L : Mat_ C ⥤ D`
such that `embedding C ⋙ L ≅ F`.
(As we don't have 2-category theory, we can't explicitly state that `Mat_ C` is
the initial object in the 2-category of categories under `C` which have biproducts.)

As a consequence, when `C` already has finite biproducts we have `Mat_ C ≌ C`.

## Future work

We should provide a more convenient `Mat R`, when `R` is a ring,
as a category with objects `n : FinType`,
and whose morphisms are matrices with components in `R`.

Ideally this would conveniently interact with both `Mat_` and `matrix`.

-/

open category_theory category_theory.preadditive
open_locale big_operators classical
noncomputable theory

namespace category_theory

universes w v₁ v₂ u₁ u₂
variables (C : Type u₁) [category.{v₁} C] [preadditive C]

/--
An object in `Mat_ C` is a finite tuple of objects in `C`.
-/
structure Mat_ :=
(ι : Type)
[F : fintype ι]
(X : ι → C)

attribute [instance] Mat_.F

namespace Mat_

variables {C}

/-- A morphism in `Mat_ C` is a dependently typed matrix of morphisms. -/
@[nolint has_nonempty_instance]
def hom (M N : Mat_ C) : Type v₁ := dmatrix M.ι N.ι (λ i j, M.X i ⟶ N.X j)

namespace hom

/-- The identity matrix consists of identity morphisms on the diagonal, and zeros elsewhere. -/
def id (M : Mat_ C) : hom M M := λ i j, if h : i = j then eq_to_hom (congr_arg M.X h) else 0

/-- Composition of matrices using matrix multiplication. -/
def comp {M N K : Mat_ C} (f : hom M N) (g : hom N K) : hom M K :=
λ i k, ∑ j : N.ι, f i j ≫ g j k

end hom

section
local attribute [simp] hom.id hom.comp

instance : category.{v₁} (Mat_ C) :=
{ hom := hom,
  id := hom.id,
  comp := λ M N K f g, f.comp g,
  id_comp' := λ M N f, by simp [dite_comp],
  comp_id' := λ M N f, by simp [comp_dite],
  assoc' := λ M N K L f g h, begin
    ext i k,
    simp_rw [hom.comp, sum_comp, comp_sum, category.assoc],
    rw finset.sum_comm,
  end, }.

lemma id_def (M : Mat_ C) :
  (𝟙 M : hom M M) = λ i j, if h : i = j then eq_to_hom (congr_arg M.X h) else 0 :=
rfl

lemma id_apply (M : Mat_ C) (i j : M.ι) :
  (𝟙 M : hom M M) i j = if h : i = j then eq_to_hom (congr_arg M.X h) else 0 :=
rfl

@[simp] lemma id_apply_self (M : Mat_ C) (i : M.ι) :
  (𝟙 M : hom M M) i i = 𝟙 _ :=
by simp [id_apply]

@[simp] lemma id_apply_of_ne (M : Mat_ C) (i j : M.ι) (h : i ≠ j) :
  (𝟙 M : hom M M) i j = 0 :=
by simp [id_apply, h]

lemma comp_def {M N K : Mat_ C} (f : M ⟶ N) (g : N ⟶ K) :
  (f ≫ g) = λ i k, ∑ j : N.ι, f i j ≫ g j k := rfl

@[simp] lemma comp_apply {M N K : Mat_ C} (f : M ⟶ N) (g : N ⟶ K) (i k) :
  (f ≫ g) i k = ∑ j : N.ι, f i j ≫ g j k := rfl

instance (M N : Mat_ C) : inhabited (M ⟶ N) := ⟨λ i j, (0 : M.X i ⟶ N.X j)⟩

end

instance : preadditive (Mat_ C) :=
{ hom_group := λ M N, by { change add_comm_group (dmatrix M.ι N.ι _), apply_instance, },
  add_comp' := λ M N K f f' g, by { ext, simp [finset.sum_add_distrib], },
  comp_add' := λ M N K f g g', by { ext, simp [finset.sum_add_distrib], }, }

@[simp] lemma add_apply {M N : Mat_ C} (f g : M ⟶ N) (i j) : (f + g) i j = f i j + g i j := rfl

open category_theory.limits

/--
We now prove that `Mat_ C` has finite biproducts.

Be warned, however, that `Mat_ C` is not necessarily Krull-Schmidt,
and so the internal indexing of a biproduct may have nothing to do with the external indexing,
even though the construction we give uses a sigma type.
See however `iso_biproduct_embedding`.
-/
instance has_finite_biproducts : has_finite_biproducts (Mat_ C) :=
{ out := λ n,
  { has_biproduct := λ f,
    has_biproduct_of_total
    { X := ⟨Σ j, (f j).ι, λ p, (f p.1).X p.2⟩,
      π := λ j x y,
      begin
        dsimp at x ⊢,
        refine if h : x.1 = j then _ else 0,
        refine if h' : (@eq.rec (fin n) x.1 (λ j, (f j).ι) x.2 _ h) = y then _ else 0,
        apply eq_to_hom,
        substs h h', -- Notice we were careful not to use `subst` until we had a goal in `Prop`.
      end,
      ι := λ j x y,
      begin
        dsimp at y ⊢,
        refine if h : y.1 = j then _ else 0,
        refine if h' : (@eq.rec _ y.1 (λ j, (f j).ι) y.2 _ h) = x then _ else 0,
        apply eq_to_hom,
        substs h h',
      end,
      ι_π := λ j j',
      begin
        ext x y,
        dsimp,
        simp_rw [dite_comp, comp_dite],
        simp only [if_t_t, dite_eq_ite, dif_ctx_congr, limits.comp_zero, limits.zero_comp,
          eq_to_hom_trans, finset.sum_congr],
        erw finset.sum_sigma,
        dsimp,
        simp only [if_congr, if_true, dif_ctx_congr, finset.sum_dite_irrel, finset.mem_univ,
          finset.sum_const_zero, finset.sum_congr, finset.sum_dite_eq'],
        split_ifs with h h',
        { substs h h',
          simp only [category_theory.eq_to_hom_refl, category_theory.Mat_.id_apply_self], },
        { subst h,
          simp only [id_apply_of_ne _ _ _ h', category_theory.eq_to_hom_refl], },
        { refl, },
      end, }
    begin
      dsimp,
      funext i₁,
      dsimp at i₁ ⊢,
      rcases i₁ with ⟨j₁, i₁⟩,
      -- I'm not sure why we can't just `simp` by `finset.sum_apply`: something doesn't quite match
      convert finset.sum_apply _ _ _ using 1,
      { refl, },
      { apply heq_of_eq,
        symmetry,
        funext i₂,
        rcases i₂ with ⟨j₂, i₂⟩,
        simp only [comp_apply, dite_comp, comp_dite,
          if_t_t, dite_eq_ite, if_congr, if_true, dif_ctx_congr,
          finset.sum_dite_irrel, finset.sum_dite_eq, finset.mem_univ, finset.sum_const_zero,
          finset.sum_congr, finset.sum_dite_eq, finset.sum_apply,
          limits.comp_zero, limits.zero_comp, eq_to_hom_trans, Mat_.id_apply],
        by_cases h : j₁ = j₂,
        { subst h, simp, },
        { simp [h], }, },
    end }}.

end Mat_

namespace functor
variables {C} {D : Type*} [category.{v₁} D] [preadditive D]

local attribute [simp] Mat_.id_apply eq_to_hom_map

/--
A functor induces a functor of matrix categories.
-/
@[simps]
def map_Mat_ (F : C ⥤ D) [functor.additive F] : Mat_ C ⥤ Mat_ D :=
{ obj := λ M, ⟨M.ι, λ i, F.obj (M.X i)⟩,
  map := λ M N f i j, F.map (f i j),
  map_comp' := λ M N K f g, by { ext i k, simp,}, }

/--
The identity functor induces the identity functor on matrix categories.
-/
@[simps]
def map_Mat_id : (𝟭 C).map_Mat_ ≅ 𝟭 (Mat_ C) :=
nat_iso.of_components (λ M, eq_to_iso (by { cases M, refl, }))
(λ M N f, begin
  ext i j,
  cases M, cases N,
  simp [comp_dite, dite_comp],
end)

/--
Composite functors induce composite functors on matrix categories.
-/
@[simps]
def map_Mat_comp {E : Type*} [category.{v₁} E] [preadditive E]
  (F : C ⥤ D) [functor.additive F] (G : D ⥤ E) [functor.additive G] :
  (F ⋙ G).map_Mat_ ≅ F.map_Mat_ ⋙ G.map_Mat_ :=
nat_iso.of_components (λ M, eq_to_iso (by { cases M, refl, }))
(λ M N f, begin
  ext i j,
  cases M, cases N,
  simp [comp_dite, dite_comp],
end)

end functor

namespace Mat_

variables (C)

/-- The embedding of `C` into `Mat_ C` as one-by-one matrices.
(We index the summands by `punit`.) -/
@[simps]
def embedding : C ⥤ Mat_ C :=
{ obj := λ X, ⟨punit, λ _, X⟩,
  map := λ X Y f, λ _ _, f,
  map_id' := λ X, by { ext ⟨⟩ ⟨⟩, simp, },
  map_comp' := λ X Y Z f g, by { ext ⟨⟩ ⟨⟩, simp, }, }

namespace embedding

instance : faithful (embedding C) :=
{ map_injective' := λ X Y f g h, congr_fun (congr_fun h punit.star) punit.star, }

instance : full (embedding C) :=
{ preimage := λ X Y f, f punit.star punit.star, }

instance : functor.additive (embedding C) := {}

end embedding

instance [inhabited C] : inhabited (Mat_ C) := ⟨(embedding C).obj default⟩

open category_theory.limits

variables {C}

/--
Every object in `Mat_ C` is isomorphic to the biproduct of its summands.
-/
@[simps]
def iso_biproduct_embedding (M : Mat_ C) : M ≅ ⨁ (λ i, (embedding C).obj (M.X i)) :=
{ hom := biproduct.lift (λ i j k, if h : j = i then eq_to_hom (congr_arg M.X h) else 0),
  inv := biproduct.desc (λ i j k, if h : i = k then eq_to_hom (congr_arg M.X h) else 0),
  hom_inv_id' :=
  begin
    simp only [biproduct.lift_desc],
    funext i,
    dsimp,
    convert finset.sum_apply _ _ _,
    { dsimp, refl, },
    { apply heq_of_eq,
      symmetry,
      funext j,
      simp only [finset.sum_apply],
      dsimp,
      simp [dite_comp, comp_dite, Mat_.id_apply], }
  end,
  inv_hom_id' :=
  begin
    apply biproduct.hom_ext,
    intro i,
    apply biproduct.hom_ext',
    intro j,
    simp only [category.id_comp, category.assoc,
      biproduct.lift_π, biproduct.ι_desc_assoc, biproduct.ι_π],
    ext ⟨⟩ ⟨⟩,
    simp [dite_comp, comp_dite],
    split_ifs,
    { subst h, simp, },
    { simp [h], },
  end, }.

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

/-- Every `M` is a direct sum of objects from `C`, and `F` preserves biproducts. -/
@[simps]
def additive_obj_iso_biproduct (F : Mat_ C ⥤ D) [functor.additive F] (M : Mat_ C) :
  F.obj M ≅ ⨁ (λ i, F.obj ((embedding C).obj (M.X i))) :=
(F.map_iso (iso_biproduct_embedding M)) ≪≫ (F.map_biproduct _)

variables [has_finite_biproducts D]

@[reassoc] lemma additive_obj_iso_biproduct_naturality (F : Mat_ C ⥤ D) [functor.additive F]
  {M N : Mat_ C} (f : M ⟶ N) :
  F.map f ≫ (additive_obj_iso_biproduct F N).hom =
    (additive_obj_iso_biproduct F M).hom ≫
      biproduct.matrix (λ i j, F.map ((embedding C).map (f i j))) :=
begin
  -- This is disappointingly tedious.
  ext,
  simp only [additive_obj_iso_biproduct_hom, category.assoc, biproduct.lift_π, functor.map_bicone_π,
    biproduct.bicone_π, biproduct.lift_matrix],
  dsimp [embedding],
  simp only [←F.map_comp, biproduct.lift_π, biproduct.matrix_π, category.assoc],
  simp only [←F.map_comp, ←F.map_sum, biproduct.lift_desc, biproduct.lift_π_assoc, comp_sum],
  simp only [comp_def, comp_dite, comp_zero, finset.sum_dite_eq', finset.mem_univ, if_true],
  dsimp,
  simp only [finset.sum_singleton, dite_comp, zero_comp],
  congr,
  symmetry,
  convert finset.sum_fn _ _, -- It's hard to use this as a simp lemma!
  simp only [finset.sum_fn, finset.sum_dite_eq],
  ext,
  simp,
end

@[reassoc] lemma additive_obj_iso_biproduct_naturality' (F : Mat_ C ⥤ D) [functor.additive F]
  {M N : Mat_ C} (f : M ⟶ N) :
  (additive_obj_iso_biproduct F M).inv ≫ F.map f =
    biproduct.matrix (λ i j, F.map ((embedding C).map (f i j)) : _) ≫
      (additive_obj_iso_biproduct F N).inv :=
by rw [iso.inv_comp_eq, ←category.assoc, iso.eq_comp_inv, additive_obj_iso_biproduct_naturality]

/-- Any additive functor `C ⥤ D` to a category `D` with finite biproducts extends to
a functor `Mat_ C ⥤ D`. -/
@[simps]
def lift (F : C ⥤ D) [functor.additive F] : Mat_ C ⥤ D :=
{ obj := λ X, ⨁ (λ i, F.obj (X.X i)),
  map := λ X Y f, biproduct.matrix (λ i j, F.map (f i j)),
  map_id' := λ X, begin
    ext i j,
    by_cases h : i = j,
    { subst h, simp, },
    { simp [h, Mat_.id_apply], },
  end,
  map_comp' := λ X Y Z f g, by { ext i j, simp, }, }.

instance lift_additive (F : C ⥤ D) [functor.additive F] : functor.additive (lift F) := {}

/-- An additive functor `C ⥤ D` factors through its lift to `Mat_ C ⥤ D`. -/
@[simps]
def embedding_lift_iso (F : C ⥤ D) [functor.additive F] : embedding C ⋙ lift F ≅ F :=
nat_iso.of_components (λ X,
  { hom := biproduct.desc (λ P, 𝟙 (F.obj X)),
    inv := biproduct.lift (λ P, 𝟙 (F.obj X)), })
(λ X Y f, begin
  dsimp,
  ext,
  simp only [category.id_comp, biproduct.ι_desc_assoc],
  erw biproduct.ι_matrix_assoc, -- Not sure why this doesn't fire via `simp`.
  simp,
end).

/--
`Mat_.lift F` is the unique additive functor `L : Mat_ C ⥤ D` such that `F ≅ embedding C ⋙ L`.
-/
def lift_unique (F : C ⥤ D) [functor.additive F] (L : Mat_ C ⥤ D) [functor.additive L]
  (α : embedding C ⋙ L ≅ F) :
  L ≅ lift F :=
nat_iso.of_components
  (λ M, (additive_obj_iso_biproduct L M) ≪≫
    (biproduct.map_iso (λ i, α.app (M.X i))) ≪≫
    (biproduct.map_iso (λ i, (embedding_lift_iso F).symm.app (M.X i))) ≪≫
    (additive_obj_iso_biproduct (lift F) M).symm)
(λ M N f, begin
  dsimp only [iso.trans_hom, iso.symm_hom, biproduct.map_iso_hom],
  simp only [additive_obj_iso_biproduct_naturality_assoc],
  simp only [biproduct.matrix_map_assoc, category.assoc],
  simp only [additive_obj_iso_biproduct_naturality'],
  simp only [biproduct.map_matrix_assoc, category.assoc],
  congr,
  ext j k ⟨⟩,
  dsimp, simp,
  exact α.hom.naturality (f j k),
end).

-- TODO is there some uniqueness statement for the natural isomorphism in `lift_unique`?

/-- Two additive functors `Mat_ C ⥤ D` are naturally isomorphic if
their precompositions with `embedding C` are naturally isomorphic as functors `C ⥤ D`. -/
@[ext]
def ext {F G : Mat_ C ⥤ D} [functor.additive F] [functor.additive G]
  (α : embedding C ⋙ F ≅ embedding C ⋙ G) : F ≅ G :=
(lift_unique (embedding C ⋙ G) _ α) ≪≫ (lift_unique _ _ (iso.refl _)).symm

/--
Natural isomorphism needed in the construction of `equivalence_self_of_has_finite_biproducts`.
-/
def equivalence_self_of_has_finite_biproducts_aux [has_finite_biproducts C] :
  embedding C ⋙ 𝟭 (Mat_ C) ≅ embedding C ⋙ lift (𝟭 C) ⋙ embedding C :=
functor.right_unitor _ ≪≫
  (functor.left_unitor _).symm ≪≫
  (iso_whisker_right (embedding_lift_iso _).symm _) ≪≫
  functor.associator _ _ _

/--
A preadditive category that already has finite biproducts is equivalent to its additive envelope.

Note that we only prove this for a large category;
otherwise there are universe issues that I haven't attempted to sort out.
-/
def equivalence_self_of_has_finite_biproducts
  (C : Type (u₁+1)) [large_category C] [preadditive C] [has_finite_biproducts C] :
  Mat_ C ≌ C :=
equivalence.mk -- I suspect this is already an adjoint equivalence, but it seems painful to verify.
  (lift (𝟭 C))
  (embedding C)
  (ext equivalence_self_of_has_finite_biproducts_aux)
  (embedding_lift_iso (𝟭 C))

@[simp] lemma equivalence_self_of_has_finite_biproducts_functor
  {C : Type (u₁+1)} [large_category C] [preadditive C] [has_finite_biproducts C] :
  (equivalence_self_of_has_finite_biproducts C).functor = lift (𝟭 C) :=
rfl

@[simp] lemma equivalence_self_of_has_finite_biproducts_inverse
  {C : Type (u₁+1)} [large_category C] [preadditive C] [has_finite_biproducts C] :
  (equivalence_self_of_has_finite_biproducts C).inverse = embedding C :=
rfl

end Mat_

universe u

/-- A type synonym for `Fintype`, which we will equip with a category structure
where the morphisms are matrices with components in `R`. -/
@[nolint unused_arguments, derive inhabited]
def Mat (R : Type u) := Fintype.{u}

instance (R : Type u) : has_coe_to_sort (Mat R) (Type u) := bundled.has_coe_to_sort

open_locale classical matrix

instance (R : Type u) [semiring R] : category (Mat R) :=
{ hom := λ X Y, matrix X Y R,
  id := λ X, 1,
  comp := λ X Y Z f g, f ⬝ g,
  assoc' := by { intros, simp [matrix.mul_assoc], }, }

namespace Mat

section
variables (R : Type u) [semiring R]

lemma id_def (M : Mat R) :
  𝟙 M = λ i j, if h : i = j then 1 else 0 :=
rfl

lemma id_apply (M : Mat R) (i j : M) :
  (𝟙 M : matrix M M R) i j = if h : i = j then 1 else 0 :=
rfl

@[simp] lemma id_apply_self (M : Mat R) (i : M) :
  (𝟙 M : matrix M M R) i i = 1 :=
by simp [id_apply]

@[simp] lemma id_apply_of_ne (M : Mat R) (i j : M) (h : i ≠ j) :
  (𝟙 M : matrix M M R) i j = 0 :=
by simp [id_apply, h]

lemma comp_def {M N K : Mat R} (f : M ⟶ N) (g : N ⟶ K) :
  (f ≫ g) = λ i k, ∑ j : N, f i j * g j k := rfl

@[simp] lemma comp_apply {M N K : Mat R} (f : M ⟶ N) (g : N ⟶ K) (i k) :
  (f ≫ g) i k = ∑ j : N, f i j * g j k := rfl

instance (M N : Mat R) : inhabited (M ⟶ N) := ⟨λ (i : M) (j : N), (0 : R)⟩

end

variables (R : Type) [ring R]

open opposite

/-- Auxiliary definition for `category_theory.Mat.equivalence_single_obj`. -/
@[simps]
def equivalence_single_obj_inverse : Mat_ (single_obj Rᵐᵒᵖ) ⥤ Mat R :=
{ obj := λ X, Fintype.of X.ι,
  map := λ X Y f i j, mul_opposite.unop (f i j),
  map_id' := λ X, by { ext i j, simp [id_def, Mat_.id_def], split_ifs; refl, }, }

instance : faithful (equivalence_single_obj_inverse R) :=
{ map_injective' := λ X Y f g w, begin
    ext i j,
    apply_fun mul_opposite.unop using mul_opposite.unop_injective,
    exact (congr_fun (congr_fun w i) j),
  end }

instance : full (equivalence_single_obj_inverse R) :=
{ preimage := λ X Y f i j, mul_opposite.op (f i j), }

instance : ess_surj (equivalence_single_obj_inverse R) :=
{ mem_ess_image := λ X,
  ⟨{ ι := X, X := λ _, punit.star }, ⟨eq_to_iso (by { dsimp, cases X, congr, })⟩⟩, }

/-- The categorical equivalence between the category of matrices over a ring,
and the category of matrices over that ring considered as a single-object category. -/
def equivalence_single_obj : Mat R ≌ Mat_ (single_obj Rᵐᵒᵖ) :=
begin
  haveI := equivalence.of_fully_faithfully_ess_surj (equivalence_single_obj_inverse R),
  exact (equivalence_single_obj_inverse R).as_equivalence.symm,
end

instance : preadditive (Mat R) :=
{ add_comp' := by { intros, ext, simp [add_mul, finset.sum_add_distrib], },
  comp_add' := by { intros, ext, simp [mul_add, finset.sum_add_distrib], }, }

-- TODO show `Mat R` has biproducts, and that `biprod.map` "is" forming a block diagonal matrix.

end Mat

end category_theory


/-!

Lean versions used, most recent to oldest:

- `nightly`: 20 Nov. 2022
- `#1844`: https://github.com/leanprover/lean4/pull/1844
- `pre #1811`: right before https://github.com/leanprover/lean4/pull/1811

# `calc`

On mathlib 4, plain (no special indent/padding):
- https://github.com/leanprover-community/mathlib4/search?q=calc

On std 4:
- plain: https://github.com/leanprover/std4/blob/main/Std/Data/Int/Lemmas.lean#L1133-L1139
- padded `_`: https://github.com/leanprover/std4/blob/main/Std/Data/List/Init/Lemmas.lean#L129-L131
-/

variable
  (t1 t2 t3 t4 t5 : Nat)

  (pf12 : t1 = t2)
  (pf23 : t2 < t3)
  (pf34 : t3 = t4)
  (pf45 : t4 < t5)

abbrev longId : Nat → Nat := id
abbrev longerId := longId
abbrev evenLongerId := longId

-- plain
-- nightly ✅ #1844 ✅ pre #1811 ✅
example : t1 < t5 :=
  let p := calc
    t1 = t2 := pf12
    _ < t3 := pf23
    _ = t4 := pf34
    _ < t5 := pf45
  -- dedent terminates the block
  p

-- sensible indentation with padding, rel-ops aligned
-- nightly ✅ #1844 ✅ pre #1811 ✅
example : t1 < t5 :=
  let p := calc
    t1 = t2 := pf12
    _  < t3 := pf23
    _  = t4 := pf34
    _  < t5 := pf45
  -- dedent terminates the block
  p

-- align on rel-ops with arbitrary `_` indentation
-- nightly ✅ #1844 ❌ pre #1811 ✅
example : t1 < t5 :=
  let _ := calc
    t1 = t2 := pf12
     _ < t3 := pf23
     _ = t4 := pf34
     _ < t5 := pf45
  let p := calc
    longId t1 = t2 := pf12
            _ < t3 := pf23
            _ = t4 := pf34
            _ < t5 := pf45
  -- dedent terminates the block
  p

-- align on rel-ops with arbitrary `_` indentation, drifting
-- nightly ✅ #1844 ❌ pre #1811 ✅
example : t1 < t5 :=
  let p := calc
    longId t1 = t2 :=
            pf12 -- error if less indented
            _ < t3 := id
                        pf23 -- error if less indented
            _ = t4 := pf34
            _ < t5 := pf45
  -- dedent terminates the block
  p

-- same-line `calc <first relation>` with normal indent afterwards
-- nightly ✅ #1844 ✅ pre #1811 ✅
example : t1 < t5 :=
  calc t1 = t2 := pf12
    _ < t3 := pf23
    _ = t4 := pf34
    _ < t5 := pf45

-- `calc <first relation LHS>\n<indent><relation and relation RHS>`
-- nightly ✅ #1844 ✅ pre #1811 ✅
example : t1 < t5 :=
  let _ :=
    calc t1
        = t2 := pf12
      _ < t3 := pf23
      _ = t4 := pf34
      _ < t5 := pf45
  -- alternatively
  calc
    t1
      = t2 := pf12
    _ < t3 := pf23
    _ = t4 := pf34
    _ < t5 := pf45

-- `calc <first relation LHS>\n<indent><relation and relation RHS>`
-- nightly ✅ #1844 ✅ pre #1811 ✅
example : t1 < t5 :=
  calc t1 = t2 := pf12
       _  < t3 := pf23
       _  = t4 := pf34
       _  < t5 := pf45

-- `by` with indented sequence of tactics in `calc`-item RHS
-- nightly ❌ #1844 ✅ pre #1811 ✅
example : t1 < t4 :=
  calc
    t1 = t2 := pf12
    _  < t3 := by
      skip
      skip
      exact pf23
    _  = t4 := pf34

-- function application with indented argument in `calc`-item RHS
-- nightly ❌ #1844 ✅ pre #1811 ❌
example : t1 < t4 :=
  calc
    t1 = t2 := pf12
    _  < t3 := id
      pf23
    _  = t4 := id
                pf34

-- vicious `v1`, single line
-- https://github.com/leanprover-community/mathlib/blob/568eb9b432c885f2a2cb8fe3bbfa77467e774da7/archive/100-theorems-list/37_solution_of_cubic.lean#L166-L172
-- nightly ✅ #1844 ✅ pre #1811 ✅
example : t1 < t4 :=
  calc  longId t1
      = longerId t2
        := pf12
    _ < t3
        := id pf23
    _ = t4
        := id pf34

-- vicious `v2`
-- https://github.com/leanprover-community/mathlib/blob/568eb9b432c885f2a2cb8fe3bbfa77467e774da7/archive/100-theorems-list/37_solution_of_cubic.lean#L166-L172
-- nightly ❌ #1844 ✅ pre #1811 ❌
example : t1 < t4 :=
  calc  longId t1
      = longerId t2
        := pf12
    _ < t3
        := id
      pf23
    _ = t4
        := id
            pf34

-- vicious `v3`, single line
-- https://github.com/leanprover-community/mathlib/blob/568eb9b432c885f2a2cb8fe3bbfa77467e774da7/archive/100-theorems-list/37_solution_of_cubic.lean#L176-L181
-- nightly ✅ #1844 ✅ pre #1811 ✅
example : t1 < t4 :=
  calc  longId t1
      = longerId t2 := pf12
    _ < t3
      := id pf23
    _ = t4
      := id pf34

-- vicious `v4`
-- https://github.com/leanprover-community/mathlib/blob/568eb9b432c885f2a2cb8fe3bbfa77467e774da7/archive/100-theorems-list/37_solution_of_cubic.lean#L176-L181
-- nightly ❌ #1844 ✅ pre #1811 ❌
example : t1 < t4 :=
  calc  longId t1
      = longerId t2 := pf12
    _ < t3
      := id
        pf23
    _ = t4
      := id
          pf34

-- playing with `by`
-- nightly ❌ #1844 ✅ pre #1811 ✅
example : t1 < t4 :=
  calc  longId t1
      = longerId t2
        := pf12
    _ < t3 := by
      apply id pf23
    _ = t4 :=
      by
        apply id pf34

-- `@digama0`'s crazy idea
-- nightly ❌ #1844 ❌ pre #1811 ❌
example : t1 < t4 :=
  calc t1
    _ = t2 := pf12
    _ < t3 := pf23
    _ = t4 := pf34


import .basic

namespace polya.field

namespace nterm

namespace sform

variables {α : Type} [discrete_field α]
variables {γ : Type} [const_space γ]
variables [morph γ α] {ρ : dict α}

instance : has_coe (option (nterm γ)) (nterm γ) := ⟨λ x, x.get_or_else (const 0)⟩

private lemma eval_none : eval ρ ((none : option (nterm γ)) : nterm γ) = 0 :=
by apply morph.morph_zero'

private lemma eval_some {x : nterm γ } : eval ρ (some x : nterm γ) = eval ρ x := rfl

local attribute [simp] eval_none
local attribute [simp] eval_some

def to_option : nterm γ → option (nterm γ) | x :=
if x = const 0 then none else some x --TODO

private lemma eval_to_option {x : nterm γ} : eval ρ (to_option x : nterm γ) = eval ρ x :=
begin
  unfold to_option,
  by_cases h1 : x = const 0,
  repeat { simp [eval, h1] }
end

private def add' : option (nterm γ) → nterm γ → nterm γ
| (some x) y := if y.coeff = 0 then x else scale (coeff y) $ add (x.scale y.coeff⁻¹) y.term
| none y := y

private lemma eval_add' {x : option (nterm γ)} {y : nterm γ} : eval ρ (add' x y) = eval ρ (x : nterm γ) + eval ρ y :=
begin
  cases x,
  { simp [add'] },
  { by_cases h1 : y.coeff = 0,
    { rw [eval_term_coeff y, h1], simp [add', h1] },
    { unfold add', rw [if_neg h1, eval_scale], unfold eval, rw eval_scale,
      rw [add_mul, mul_assoc, ← morph.morph_mul', inv_mul_cancel h1, ← eval_term_coeff],
      simp }}
end

local attribute [simp] eval_add'

private def left : nterm γ → option (nterm γ)
| (add x _) := some x
| _ := none

private def right : nterm γ → (nterm γ)
| (add _ x) := x
| x := x

def rest (S : nterm γ) : option (nterm γ) := (left S.term).map (scale S.coeff)

def lead (S : nterm γ) : nterm γ := scale S.coeff (right S.term)

theorem eval_left_right (x : nterm γ) : eval ρ x = eval ρ (left x : nterm γ) + eval ρ (right x) :=
by cases x; simp [left, right, eval]

theorem eval_rest_lead {S : nterm γ} : eval ρ S = eval ρ (rest S : nterm γ) + eval ρ (lead S) :=
begin
  rw [eval_term_coeff, eval_left_right, add_mul],
  congr' 1,
  { unfold rest, cases (term S), repeat { simp [left] }},
  { simp [lead] }
end

@[simp] theorem eval_scale_option {x : option (nterm γ)} {a : γ} : eval ρ (x.map (scale a) : nterm γ) = eval ρ (x : nterm γ) * a :=
by cases x; simp

inductive r : option (nterm γ) → option (nterm γ) → Prop
| none {S : nterm γ} : r none (some S)
| rest {S : nterm γ} : r (rest S) (some S)

namespace wf

private lemma acc_r_none : @acc (option (nterm γ)) r none :=
begin
  apply acc.intro, intros x h, cases h
end

private def g : nterm γ → ℕ
| (add x _) := g x + 1
| (mul x (const _)) := g x
| _ := 0

private def f : option (nterm γ) → ℕ
| (some x) := g x + 1
| none := 0

private lemma g_scale {x : nterm γ} {a : γ} : g (x.scale a) ≤ g x :=
begin
  sorry
end

private lemma f_none {S : nterm γ} : f (none : option (nterm γ)) < f (some S) :=
by { unfold f, linarith }

private lemma f_scale_option {x : option (nterm γ)} {a : γ} : f (x.map (scale a)) ≤ f x :=
by { cases x; simp [f, g_scale] }

private lemma f_rest {S : nterm γ} : f (rest S) < f (some S) :=
begin
  --TODO: simplify proof
  show f (rest S) < g S + 1,
  cases S,
  case add : {
      simp only [rest, term, left, coeff, f, g, option.map_some', add_lt_add_iff_right],
      apply lt_of_le_of_lt, { apply g_scale }, { linarith }},
  case mul : x y {
      cases y, case const : {
        simp only [rest, term, left, coeff, g],
        apply lt_of_le_of_lt,
        { apply f_scale_option },
        { cases x, repeat { simp [left, f, g], linarith }}},
      repeat { simp [rest, term, left, coeff, f], linarith }},
  repeat { simp [rest, term, left, f], linarith }
end

theorem r_wf : @well_founded (option (nterm γ)) r :=
begin
  apply subrelation.wf,
  intros x y h,
  show f x < f y,
  cases h, { apply f_none }, { apply f_rest },
  apply measure_wf
end

meta def rel_tac : tactic unit := `[exact ⟨psigma.lex r (λ _, r), psigma.lex_wf wf.r_wf (λ _, wf.r_wf)⟩]

meta def dec_tac : tactic unit :=
`[apply psigma.lex.left, assumption, done]
<|> `[apply psigma.lex.right, assumption, done]

end wf

private def aux (x y : nterm γ) (s1 s2 s3 : option (nterm γ)) : nterm γ :=
if x.term = y.term then
  if x.coeff + y.coeff = 0 then (s1 : nterm γ)
  else add' s1 (mul x.term (const (x.coeff + y.coeff)))
else if x.term < y.term then --TODO
  add' s2 x
else
  add' s3 y

--set_option pp.all true
private lemma eval_aux {x y : nterm γ} {s1 s2 s3 : option (nterm γ)}
  ( H0 : x.coeff ≠ 0 ∧ y.coeff ≠ 0)
  ( H1 : eval ρ (s2 : nterm γ) = eval ρ (s1 : nterm γ) + eval ρ y )
  ( H2 : eval ρ (s3 : nterm γ) = eval ρ (s1 : nterm γ) + eval ρ x ) :
  eval ρ (aux x y s1 s2 s3) =  eval ρ (s1 : nterm γ) + eval ρ y + eval ρ x :=
begin
  unfold aux,
  by_cases h1 : x.term = y.term,
  { rw [if_pos h1, add_assoc],
    by_cases h2 : x.coeff + y.coeff = 0,
    { rw [if_pos h2],
      have : eval ρ y + eval ρ x = 0,
      { have : coeff x = - coeff y, from eq_neg_of_add_eq_zero h2,
        rw [eval_term_coeff x, eval_term_coeff y, h1],
        rw [this, morph.morph_neg'], ring },
      simp [this] },
    { rw if_neg h2, rw [eval_add'], congr,
      unfold eval, rw [morph.morph_add, mul_add],
      rw [← eval_term_coeff, h1, ← eval_term_coeff, add_comm] }},
  { rw if_neg h1,
    by_cases h2 : x.term < y.term,
    { rw if_pos h2, rw [eval_add'], congr, apply H1 },
    { rw if_neg h2, rw [add_assoc, add_comm (eval ρ y), ← add_assoc, eval_add'], congr, apply H2 }}
end

private def add_option : option (nterm γ) → option (nterm γ) → option (nterm γ)
| (some S) (some T) :=
  have h1 : r (rest S) (some S), from r.rest,
  have h2 : r (rest T) (some T), from r.rest,
  let s1 := (add_option (rest S) (rest T)) in
  let s2 := (add_option (rest S) (some T)) in
  let s3 := (add_option (some S) (rest T)) in
  if (lead S).coeff ≠ 0 ∧ (lead T).coeff ≠ 0 then
    some $ aux (lead S) (lead T) s1 s2 s3
  else
    add S T --should not happen
| none x := x
| x none := x
using_well_founded {
    rel_tac := λ _ _, wf.rel_tac,
    dec_tac := wf.dec_tac,
}

private lemma add_option_def1 {x : option (nterm γ)} :
  add_option none x = x :=
by cases x; unfold add_option

private lemma add_option_def2 {x : option (nterm γ)} :
  add_option x none = x :=
by cases x; unfold add_option

private lemma add_option_def3 : Π {S T : nterm γ},
  (lead S).coeff ≠ 0 ∧ (lead T).coeff ≠ 0 →
  add_option (some S) (some T) =
  some (aux (lead S) (lead T)
    (add_option (rest S) (rest T))
    (add_option (rest S) (some T))
    (add_option (some S) (rest T)) ) :=
begin
  intros S T h0,
  simp [h0, add_option]
end

private lemma eval_add_option : Π (S T : option (nterm γ)),
  eval ρ (add_option S T : nterm γ) = eval ρ (S : nterm γ) + eval ρ (T : nterm γ)
| (some S) (some T) :=
  have h1 : r (rest S) (some S), from r.rest,
  have h2 : r (rest T) (some T), from r.rest,
  let ih1 := eval_add_option (rest S) in
  let ih2 := eval_add_option (some S) (rest T) in
  begin
    by_cases h0 : (lead S).coeff ≠ 0 ∧ (lead T).coeff ≠ 0,
    { rw [eval_some, eval_some, add_option_def3 h0],
      rw [eval_some, eval_aux h0],
      { rw [ih1, add_assoc (eval ρ ↑(rest S)), ← eval_rest_lead],
        rw [add_comm (eval ρ ↑(rest S)), add_assoc, ← eval_rest_lead],
        apply add_comm },
      { rw [ih1, ih1, add_assoc, ← eval_rest_lead], refl },
      { rw [ih2, ih1, add_comm (eval ρ ↑(rest S)), add_assoc, ← eval_rest_lead],
        apply add_comm }},
    { simp [add_option, h0], refl }
  end
| none x := by rw [add_option_def1]; simp
| x none := by rw [add_option_def2]; simp
using_well_founded {
    rel_tac := λ _ _, wf.rel_tac,
    dec_tac := wf.dec_tac,
}

protected def add (x y : nterm γ) : nterm γ :=
add_option (to_option x) (to_option y)

protected theorem eval_add {x y : nterm γ} : eval ρ (sform.add x y) = eval ρ x + eval ρ y :=
by { unfold sform.add, rw [eval_add_option, eval_to_option, eval_to_option] }

end sform

end nterm

end polya.field