import AssertCmd
import Contractome.Utils

-- @[irreducible] def UInt256.size : Nat := 115792089237316195423570985008687907853269984665640564039457584007913129639936
@[irreducible] def UInt256.size : Nat := 2^256
-- attribute [irreducible] UInt32.size

structure UInt256 where
  val : Fin UInt256.size

def UInt256.ofNatCore (n : @& Nat) (h : LT.lt n UInt256.size) : UInt256 := {
  val := { val := n, isLt := h }
}

def UInt256.toNat (n : UInt256) : Nat := n.val.val

instance : Repr UInt256 where
  reprPrec n _ := repr n.toNat

def UInt256.decEq (a b : UInt256) : Decidable (Eq a b) :=
  match a, b with
  | ⟨n⟩, ⟨m⟩ =>
    dite (Eq n m) (fun h => isTrue (h ▸ rfl)) (fun h => isFalse (fun h' => UInt256.noConfusion h' (fun h' => absurd h' h)))

instance : DecidableEq UInt256 := UInt256.decEq

set_option maxRecDepth 2000
instance : Inhabited UInt256 where
  default := UInt256.ofNatCore 0 (by decide)

instance : LT UInt256 where
  lt a b := LT.lt a.val b.val

instance : LE UInt256 where
  le a b := LE.le a.val b.val

def UInt256.decLt (a b : UInt256) : Decidable (LT.lt a b) :=
  match a, b with
  | ⟨n⟩, ⟨m⟩ => inferInstanceAs (Decidable (LT.lt n m))

def UInt256.decLe (a b : UInt256) : Decidable (LE.le a b) :=
  match a, b with
  | ⟨n⟩, ⟨m⟩ => inferInstanceAs (Decidable (LE.le n m))

instance (a b : UInt256) : Decidable (LT.lt a b) := UInt256.decLt a b
instance (a b : UInt256) : Decidable (LE.le a b) := UInt256.decLe a b

instance : Ord UInt256 where
  compare x y := compareOfLessAndEq x y

#check UInt32.ofNat

@[irreducible] theorem ofNat_lt (x: Nat) : x % UInt256.size < UInt256.size := by
  simp [Nat.mod_lt, Nat.zero_lt_succ]

-- attribute [irreducible] Fin.mlt

-- def UInt256.ofNat (n : @& Nat) : UInt256 := ⟨Fin.ofNat n⟩
def UInt256.ofNat (n : @& Nat) : UInt256 := ⟨⟨n % UInt256.size , ofNat_lt n⟩⟩
def UInt256.ofNat' (n : Nat) (h : n < UInt256.size) : UInt256 := ⟨⟨n, h⟩⟩
def UInt256.ofUInt8 (n : UInt8) : UInt256 := ⟨⟨ n.val, by apply (Nat.lt_trans n.val.isLt); decide ⟩⟩
abbrev Nat.toUInt256 := UInt256.ofNat

@[inline] abbrev wrapOp (f : Nat -> Nat -> Nat) :=
  fun (a b : UInt256)  => UInt256.mk ⟨ (f a.val.val b.val.val) % UInt256.size, ofNat_lt (f a.val.val b.val.val) ⟩

def UInt256.add := wrapOp Nat.add
def UInt256.sub (a b : UInt256) : UInt256 := ⟨⟨ (a.val.val + (UInt256.size - b.val.val)) % UInt256.size , ofNat_lt _⟩⟩
def UInt256.mul := wrapOp Nat.mul
def UInt256.div := wrapOp Nat.div
def UInt256.mod := wrapOp Nat.mod

set_option maxRecDepth 2000
def UInt256.ones : UInt256 := ⟨⟨ (2^256) - 1, by decide ⟩⟩
def UInt256.modn (a : UInt256) (n : @& Nat) : UInt256 := ⟨⟨ (a.val.val % n) % UInt256.size, ofNat_lt _ ⟩⟩
def UInt256.land := wrapOp Nat.land
def UInt256.lor := wrapOp Nat.lor
def UInt256.xor := wrapOp Nat.xor
def UInt256.shiftLeft (a b : UInt256) : UInt256 := ⟨⟨ (a.val.val <<< (modn b 256).val.val) % UInt256.size, ofNat_lt _ ⟩⟩
def UInt256.shiftRight (a b : UInt256) : UInt256 := ⟨⟨ (a.val.val >>> (modn b 256).val.val) % UInt256.size, ofNat_lt _ ⟩⟩
def UInt256.toUInt8 (a : UInt256) : UInt8 := a.toNat.toUInt8
def UInt256.toUInt16 (a : UInt256) : UInt16 := a.toNat.toUInt16
def UInt8.toUInt256 (a : UInt8) : UInt256 := a.toNat.toUInt256
def UInt16.toUInt256 (a : UInt16) : UInt256 := a.toNat.toUInt256
def UInt32.toUInt256 (a : UInt32) : UInt256 := a.toNat.toUInt256
def UInt64.toUInt256 (a : UInt64) : UInt256 := a.toNat.toUInt256

instance : OfNat UInt256 n   := ⟨UInt256.ofNat n⟩
instance : Add UInt256       := ⟨UInt256.add⟩
instance : Sub UInt256       := ⟨UInt256.sub⟩
instance : Mul UInt256       := ⟨UInt256.mul⟩
instance : Mod UInt256       := ⟨UInt256.mod⟩
instance : HMod UInt256 Nat UInt256 := ⟨UInt256.modn⟩
instance : Div UInt256       := ⟨UInt256.div⟩

-- def UInt256.bneg (a : UInt256) : UInt256 := a.xor UInt256.ones
def UInt256.complement (a:UInt256) : UInt256 := 0-(a+1)
def UInt256.sneg (a: UInt256) : UInt256 := a.complement + 1
#assert (UInt256.sneg 3) == (0xFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFD : UInt256)
#assert (UInt256.sneg 0xFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFD) == (3 : UInt256)

instance : Complement UInt256 := ⟨UInt256.complement⟩
instance : AndOp UInt256     := ⟨UInt256.land⟩
instance : OrOp UInt256      := ⟨UInt256.lor⟩
instance : Xor UInt256       := ⟨UInt256.xor⟩
instance : ShiftLeft UInt256  := ⟨UInt256.shiftLeft⟩
instance : ShiftRight UInt256 := ⟨UInt256.shiftRight⟩

def UInt256.abs (a : UInt256) : UInt256 :=
  if a >>> 255 == 1 then a.sneg else a

def UInt256.sdiv (a b:UInt256) : UInt256 :=
    let a' := a.abs
    let b' := b.abs
    let r := a' / b'
    let bit : UInt256 := (a ^^^ b) >>> 255
    if bit == 1 then r.sneg else r

def UInt256.smod (a b:UInt256) : UInt256 :=
    let a' := a.abs
    let b' := b.abs
    let r := a' % b'
    let bit : UInt256 := a >>> 255
    if bit == 1 then r.sneg else r

@[simp]
def Nat.half_is_less (n : Nat) : (Nat.succ n) / 2 < (Nat.succ n) := sorry
  --
-- set_option pp.all true
def Nat.powmod_correct (a b N: Nat) : { r : Nat // r = (a.pow b) % N } := match b with
  | 0 => by cases N with | zero => exact ⟨ 1, by simp [Nat.pow, Nat.mod_zero] ⟩
                         | succ N => cases N with
                          | zero => exact ⟨ 0, by simp [Nat.pow]⟩
                          | succ N => exact ⟨ 1, by simp [Nat.pow]; rw [Nat.mod_eq_of_lt (_ : 1 < Nat.succ (Nat.succ N))]; apply Nat.succ_le_succ; apply Nat.succ_le_succ; apply Nat.zero_le ⟩
  | Nat.succ b =>
    if (Nat.succ b) % 2 == 0 then ⟨ powmod_correct ((a * a) % N) ((Nat.succ b) / 2) N , sorry ⟩
    else ⟨ (a * powmod_correct ((a * a) % N) ((Nat.succ b) / 2) N) % N , sorry ⟩
termination_by _ => b
decreasing_by apply Nat.half_is_less

#assert ((123 ^ 123) % 8) == (Nat.powmod_correct 123 123 8).val
#assert  (Nat.powmod_correct 2 2 8).val == ((2 ^ 2) % 8)

def Fin.pow {h : n > 0} (a b : Fin n) : Fin n :=
  let ⟨ val, prop ⟩ := Nat.powmod_correct a b n
  ⟨ val, by subst prop; exact Nat.mod_lt (Nat.pow a.val b.val) h ⟩

-- #eval Fin.pow ⟨ Fin.mk 0xFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF 0xFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF UInt256.size

-- TODO make faster by modding intermediately
def UInt256.pow (a b:UInt256) : UInt256 := ⟨ Fin.pow (h:=by simp) a.val b.val ⟩
#eval UInt256.pow 0xFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF 0xFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF

-- def UInt256.sOfInt (a: Int) := if a
def UInt256.isSpos (a: UInt256) : Bool := if (a >>> 255) == 1 then false else true
def UInt256.slt (a b: UInt256) : Bool :=
  let aS := a.isSpos
  let bS := b.isSpos
  match aS, bS with
  | true, false => false
  | false, true => true
  | _, _ => a < b

#assert (UInt256.slt (UInt256.sneg 1) 5) == true
#assert (UInt256.slt 4 5) == true
#assert (UInt256.slt 5 5) == false
#assert (UInt256.slt 6 5) == false
#assert (UInt256.slt (UInt256.sneg 1) (UInt256.sneg 1)) == false
#assert (UInt256.slt 6 (UInt256.sneg 1)) == false
#assert (UInt256.slt (UInt256.sneg 2) (UInt256.sneg 1)) == true
#assert (UInt256.slt (UInt256.sneg 1) (UInt256.sneg 2)) == false

def UInt256.sgt (a b: UInt256) : Bool := if a == b then false else !UInt256.slt a b

def UInt256.ofBytes! (b: ByteArray) : UInt256 :=
  let bs := ByteArray.mkZeros (256 / 8)
  let destOff := (256 / 8) - b.size
  let bs : ByteArray := ByteArray.copySlice b 0 bs destOff b.size
  -- now we can go byte by byte
  let p1 := (ByteArray.toUInt64LE! $ bs.extract 0 8).toUInt256
  let p2 := (ByteArray.toUInt64LE! $ bs.extract 8 16).toUInt256
  let p3 := (ByteArray.toUInt64LE! $ bs.extract 16 24).toUInt256
  let p4 := (ByteArray.toUInt64LE! $ bs.extract 24 32).toUInt256

  (p1 <<< 192) ||| (p2 <<< 128) ||| (p3 <<< 64) ||| p4

def UInt256.ofBytesL! (l : List UInt8) : UInt256 :=
  let rec aux l (acc: UInt256) := match l with
  | List.cons b bs => aux bs ((acc <<< 8) ||| (UInt256.ofUInt8 b))
  | List.nil => acc
  aux l 0

#assert (UInt256.ofBytes! $ ByteArray.mk $ #[01]) == (1:UInt256)
#assert (UInt256.ofBytes! $ ByteArray.mk $ #[0]) == (0:UInt256)
#assert (UInt256.ofBytes! $ ByteArray.mk $ #[0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff,
0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff,
0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff,
0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff]) == UInt256.ofNat $ UInt256.size - 1
#assert (UInt256.ofBytes! $ ByteArray.mk $ #[0x80, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00]) == UInt256.ofNat $ UInt256.size / 2

#assert (UInt256.ofBytesL! $ [0x80, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00]) == UInt256.ofNat $ UInt256.size / 2

def UInt256.toBytes (b: UInt256) : ByteArray := Id.run do
  let mut ba := ByteArray.mkEmpty 32
  for i in [0:32] do
    ba := ba.push $ UInt256.toUInt8 $ (b <<< (8 * (UInt256.ofNat i))) >>> (8*31)
  ba

#assert (UInt256.ofBytes! (UInt256.toBytes 5)) == (5:UInt256)
#assert (UInt256.ofBytes! (UInt256.toBytes (UInt256.ofNat $ UInt256.size - 1))) == (UInt256.ofNat $ UInt256.size - 1)

def UInt256.toBytesL (b: UInt256) : List UInt8 := Id.run do
  let mut ba := []
  for i in [0:32] do
    ba := List.cons (UInt256.toUInt8 $ (b <<< (8 * (UInt256.ofNat i))) >>> (8*31)) ba
  ba.reverse

#assert (UInt256.ofBytesL! (UInt256.toBytesL 5)) == (5:UInt256)
#assert ((UInt256.toBytesL 5).drop 31).head? == (Option.some (5:UInt8))
#assert (UInt256.ofBytesL! (UInt256.toBytesL (UInt256.ofNat $ UInt256.size - 1))) == (UInt256.ofNat $ UInt256.size - 1)

def UInt256.signextend (byteNum x : UInt256) :=
  if byteNum > 31 then x else
  let bitNum := byteNum*8+7
  let mask := ((1:UInt256) <<< bitNum) - 1
  let isBitSet := (x >>> bitNum) &&& 1 == 1
  if isBitSet then x ||| (~~~ mask) else x &&& mask

#assert (UInt256.signextend 0 0xFF) == (0xFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF : UInt256)
#assert (UInt256.signextend 0 0x7F) == (0x7F : UInt256)

def UInt256.sar (x shiftBy : UInt256) :=
    if x.isSpos then x >>> shiftBy else
    let mask := UInt256.ones <<< (256 - shiftBy)
    (x >>> shiftBy) ||| mask

#assert (UInt256.sar 2 1) == (1 : UInt256)
#assert (UInt256.sar 0xFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0 4) ==
  (0xFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF : UInt256)


lemma add_mul (a b t : mynat) : (a + b) * t = a * t + b * t :=
begin
induction t with k Pk,
repeat { rw mul_zero },
rw add_zero,
refl,

repeat { rw mul_succ },
rw Pk,
simp,
end


import algebra.category.Module.adjunctions
import group_theory.free_abelian_group_finsupp
import algebra.category.Group.adjunctions
import algebra.category.Group.filtered_colimits
import algebra.category.Group.biproducts
import algebra.category.Group.abelian
import category_theory.limits.preserves.shapes.products
import category_theory.limits.preserves.filtered
import category_theory.limits.shapes.terminal
import linear_algebra.free_module.pid
import for_mathlib.AddCommGroup.epi
import algebra.group.ulift

open category_theory

universes u

namespace AddCommGroup

noncomputable theory

@[simps]
def free' : Type u ⥤ AddCommGroup.{u} :=
{ obj := λ X, AddCommGroup.of $ X →₀ ℤ,
  map := λ X Y f, finsupp.map_domain.add_monoid_hom f,
  map_id' := begin
    intros X, ext, dsimp, simp,
  end,
  map_comp' := begin
    intros X Y Z f g, ext, dsimp, simp,
  end } .

@[simps]
def of_iso {A B : Type u} [add_comm_group A] [add_comm_group B]
  (e : A ≃+ B) : of A ≅ of B :=
{ hom := e.to_add_monoid_hom,
  inv := e.symm.to_add_monoid_hom,
  hom_inv_id' := begin
    ext, dsimp, simp,
  end,
  inv_hom_id' := begin
    ext, dsimp, simp,
  end } .

@[simps]
def free_iso_free' : free.{u} ≅ free'.{u} :=
category_theory.nat_iso.of_components
(λ X, of_iso (free_abelian_group.equiv_finsupp X))
begin
  intros X Y f, ext, dsimp, simp,
end

def adj' : free'.{u} ⊣ forget AddCommGroup.{u} :=
AddCommGroup.adj.of_nat_iso_left $ free_iso_free'.{u}

end AddCommGroup

def types.pt {α : Type u} (a : α) : ⊤_ _ ⟶ α :=
λ x, a

def types.punit_iso : (punit : Type u) ≅ ⊤_ _ :=
{ hom := limits.terminal.from _,
  inv := types.pt punit.star }

namespace AddCommGroup

def tunit : AddCommGroup.{u} :=
  AddCommGroup.free'.obj (⊤_ _)

def tunit.lift {A : AddCommGroup.{u}} (e : ⊤_ _ ⟶ (forget _).obj A) :
  tunit ⟶ A :=
(AddCommGroup.adj'.hom_equiv _ _).symm e

-- Do we really not have this?!
def _root_.finsupp.punit_add_equiv (M : Type*) [add_monoid M] :
  ((punit : Type u) →₀ M) ≃+ M :=
{ to_fun := λ f, f punit.star,
  inv_fun := λ m, finsupp.single punit.star m,
  left_inv := λ x, by { ext, dsimp, simp },
  right_inv := λ x, by { dsimp, simp },
  map_add' := λ f g, by simp }

-- Do we really not have this?!
def add_equiv_of_iso (A B : AddCommGroup.{u}) (e : A ≅ B) :
  A ≃+ B :=
{ to_fun := e.hom,
  inv_fun := e.inv,
  left_inv := λ x, by simp,
  right_inv := λ x, by simp,
  map_add' := λ x y, e.hom.map_add _ _ }

def tunit_add_equiv : tunit.{u} ≃+ ℤ :=
add_equiv.trans (add_equiv_of_iso _ _ $ AddCommGroup.free'.map_iso
  types.punit_iso.symm) (finsupp.punit_add_equiv ℤ)

def tunit.gen : tunit.{u} :=
AddCommGroup.adj'.unit.app _ $
  (limits.terminal.from (punit : Type u) : punit → ⊤_ (Type u)) punit.star

open_locale classical

-- Of course this is true without the fintype assumption...
def iso_of_basis {ι : Type u} [fintype ι] {A : AddCommGroup.{u}} (𝓑 : basis ι ℤ A) :
  (∐ (λ i : ι, tunit.{u})) ≅ A :=
begin
  -- This is very messy...
  let e : (∐ (λ i : ι, tunit.{u})) ≅ (⨁ (λ i, tunit.{u})) :=
    (limits.colimit.is_colimit _).cocone_point_unique_up_to_iso
      (limits.biproduct.is_bilimit _).is_colimit,
  refine e ≪≫ _,
  refine biproduct_iso_pi _ ≪≫ _,
  refine AddCommGroup.of_iso _ ≪≫ (AddCommGroup.of_iso 𝓑.repr.to_add_equiv).symm ≪≫
    ⟨add_monoid_hom.id _, add_monoid_hom.id _, by { ext, refl }, by { ext, refl }⟩,
  let q : tunit.{u} ≃+ ℤ := tunit_add_equiv,
  let e : (ι →₀ ℤ) ≃+ (ι → ℤ),
  { fconstructor,
    exact finsupp.equiv_fun_on_fintype,
    exact finsupp.equiv_fun_on_fintype.symm,
    exact finsupp.equiv_fun_on_fintype.left_inverse_symm,
    exact finsupp.equiv_fun_on_fintype.right_inverse_symm,
    intros x y, refl },
  refine add_equiv.trans _ e.symm,
  fconstructor,
  { intros f i, exact q (f i) },
  { intros f i, exact q.symm (f i) },
  { intros f, ext, dsimp, simp },
  { intros f, ext, dsimp, simp },
  { intros f g, ext i, simp, },
end
--as_iso (hom_of_basis 𝓑)

@[derive partial_order]
def index_cat (A : AddCommGroup.{u}) [no_zero_smul_divisors ℤ A] : Type u :=
{ H : add_subgroup A // H.fg } -- Is this the condition we want?

instance nonempty_index_cat (A : AddCommGroup.{u}) [no_zero_smul_divisors ℤ A] :
  nonempty A.index_cat := ⟨⟨⊥, ∅, by simp⟩⟩

instance semilattice_sup_index_cat
  (A : AddCommGroup.{u}) [no_zero_smul_divisors ℤ A] :
  semilattice_sup A.index_cat :=
{ sup := λ I J, ⟨I.1 ⊔ J.1, begin
    obtain ⟨S,hS⟩ := I.2,
    obtain ⟨T,hT⟩ := J.2,
    rw [← hS, ← hT],
    use S ∪ T,
    simp only [finset.coe_union, add_subgroup.closure_union],
  end⟩,
  le_sup_left := λ I J, @le_sup_left (add_subgroup A) _ _ _,
  le_sup_right := λ I J, @le_sup_right (add_subgroup A) _ _ _,
  sup_le := λ I J K h1 h2, @sup_le (add_subgroup A) _ _ _ _ h1 h2,
  ..(infer_instance : partial_order _) }

def diagram (A : AddCommGroup.{u}) [no_zero_smul_divisors ℤ A] :
  A.index_cat ⥤ AddCommGroup.{u} :=
{ obj := λ I, AddCommGroup.of I.1,
  map := λ I J h, add_subgroup.inclusion h.le }

def cocone (A : AddCommGroup.{u}) [no_zero_smul_divisors ℤ A] :
  limits.cocone A.diagram :=
{ X := A,
  ι := { app := λ I, I.1.subtype } }

def is_colimit_cocone (A : AddCommGroup.{u}) [no_zero_smul_divisors ℤ A] :
  limits.is_colimit A.cocone :=
{ desc := λ S,
  { to_fun := λ a, S.ι.app ⟨add_subgroup.closure {a}, {a}, by simp⟩
      ⟨a, add_subgroup.subset_closure rfl⟩,
    map_zero' := add_monoid_hom.map_zero _,
    map_add' := λ x y, begin
      let I : A.index_cat := ⟨add_subgroup.closure {x}, {x}, by simp⟩,
      let J : A.index_cat := ⟨add_subgroup.closure {y}, {y}, by simp⟩,
      let K : A.index_cat := ⟨add_subgroup.closure {x + y}, {x + y}, by simp⟩,
      let IJ : A.index_cat := ⟨add_subgroup.closure {x,y}, {x,y}, by simp⟩,
      let iI : I ⟶ IJ := hom_of_le (add_subgroup.closure_mono $ by simp),
      let iJ : J ⟶ IJ := hom_of_le (add_subgroup.closure_mono $ by simp),
      let iK : K ⟶ IJ := hom_of_le ((add_subgroup.closure_le _).2 _),
      swap,
      { rintro a (rfl : a = _), change x + y ∈ IJ.1, apply IJ.1.add_mem,
        { apply add_subgroup.subset_closure, simp },
        { apply add_subgroup.subset_closure, simp } },
      rw [← S.w iI, ← S.w iJ, ← S.w iK, comp_apply, comp_apply, comp_apply,
        ← add_monoid_hom.map_add],
      refl,
    end },
  fac' := begin
    rintros S J, ext ⟨x,hx⟩,
    let I : A.index_cat := ⟨add_subgroup.closure {x}, {x}, by simp⟩,
    let e : I ⟶ J := hom_of_le ((add_subgroup.closure_le _).2 _),
    { rw comp_apply, dsimp [cocone], rw ← S.w e, refl },
    rintros x (rfl : x = _), exact hx,
  end,
  uniq' := begin
    intros S m hm, ext x, dsimp [cocone] at x ⊢,
    let I : A.index_cat := ⟨add_subgroup.closure {x}, {x}, by simp⟩,
    specialize hm I,
    let y : I.1 := ⟨x, add_subgroup.subset_closure rfl⟩,
    apply_fun (λ e, e y) at hm, exact hm,
  end }

def colimit_comparison (A : AddCommGroup.{u}) [no_zero_smul_divisors ℤ A] :
  limits.colimit A.diagram ≅ A :=
(limits.colimit.is_colimit A.diagram).cocone_point_unique_up_to_iso
  A.is_colimit_cocone

lemma exists_basis_of_index (A : AddCommGroup.{u}) [no_zero_smul_divisors ℤ A]
  (I : A.index_cat) : ∃ (ι : Type u) [fintype ι]
  (𝓑 : basis ι ℤ (AddCommGroup.of I.1)), true :=
begin
  obtain ⟨S,hS⟩ := I.2,
  let e : S → I.1 := λ s, ⟨s,_⟩,
  swap, { rw ← hS, apply add_subgroup.subset_closure, exact s.2 },
  haveI : no_zero_smul_divisors ℤ I.1,
  { constructor, rintros c ⟨x, hx⟩ h, apply_fun (λ e, e.val) at h,
    dsimp at h,
    cases no_zero_smul_divisors.eq_zero_or_eq_zero_of_smul_eq_zero h,
    left, assumption,
    right, ext, assumption },
  obtain ⟨n,B⟩ := @module.free_of_finite_type_torsion_free S ℤ _ _ _ I.1 _ _ _ e _ _,
  { use [ulift (fin n), infer_instance],
    refine ⟨_, trivial⟩,
    apply B.reindex,
    exact equiv.ulift.symm },
  { apply le_antisymm, { intros x hx, trivial },
    rintros ⟨x,hx⟩ -,
    let J := (submodule.span ℤ (set.range e)).to_add_subgroup,
    change _ ∈ J,
    have hJ : J = (J.map I.1.subtype).comap I.1.subtype, -- is this not a lemma?!
    { apply le_antisymm,
      { exact add_subgroup.le_comap_map I.val.subtype J },
      { intros t ht,
        simpa using ht } },
    rw [hJ, add_subgroup.mem_comap], clear hJ,
    dsimp [J],
    convert hx,
    rw [← hS, submodule.span_int_eq_add_subgroup_closure, add_monoid_hom.map_closure], congr' 1,
    ext t,
    split,
    { rintros ⟨t,⟨t,rfl⟩,rfl⟩, exact t.2 },
    { intros ht, refine ⟨⟨t, _⟩, ⟨⟨t, ht⟩, rfl⟩, rfl⟩ } },
end

lemma exists_sigma_iso_of_index (A : AddCommGroup.{u}) [no_zero_smul_divisors ℤ A]
  (I : A.index_cat) : ∃ (ι : Type u) [fintype ι]
  (e : (∐ (λ i : ι, tunit.{u})) ≅ AddCommGroup.of I.1), true :=
begin
  obtain ⟨ι,hι,𝓑,-⟩ := exists_basis_of_index A I,
  resetI,
  use [ι, hι, iso_of_basis 𝓑],
end

lemma exists_biprod_iso_of_index (A : AddCommGroup.{u}) [no_zero_smul_divisors ℤ A]
  (I : A.index_cat) : ∃ (ι : Type u) [fintype ι]
  (e : by exactI (⨁ (λ i : ι, tunit.{u})) ≅ AddCommGroup.of I.1), true :=
begin
  obtain ⟨ι,hι,e,-⟩ := exists_sigma_iso_of_index A I,
  resetI, use [ι, hι],
  use (limits.biproduct.is_bilimit _).is_colimit.cocone_point_unique_up_to_iso
      (limits.colimit.is_colimit _) ≪≫ e,
end

universes u'

lemma is_iso_of_preserves {𝓐 : Type u'} [category.{u} 𝓐] [preadditive 𝓐]
  (F G : AddCommGroup ⥤ 𝓐)
  [F.additive]
  [G.additive]
  [limits.preserves_filtered_colimits F]
  [limits.preserves_filtered_colimits G]
  (η : F ⟶ G)
  [hη : is_iso (η.app tunit)]
  (A : AddCommGroup.{u})
  [no_zero_smul_divisors ℤ A] :
  is_iso (η.app A) :=
begin
  let T := (limits.cocones.precompose (whisker_left A.diagram η)).obj
    (G.map_cocone A.cocone),
  let S := F.map_cocone A.cocone,
  let hS : limits.is_colimit S :=
    limits.is_colimit_of_preserves F A.is_colimit_cocone,
  have : η.app A = hS.desc T,
  { apply hS.hom_ext, intros j, rw hS.fac,
    dsimp, apply η.naturality },
  rw this, clear this,
  suffices : ∀ I : A.index_cat, is_iso (η.app (A.diagram.obj I)),
  { resetI,
    haveI : is_iso (whisker_left A.diagram η),
    { apply_with nat_iso.is_iso_of_is_iso_app { instances := ff },
      intros I, exact this I },
    let hT : limits.is_colimit T :=
      (limits.is_colimit.precompose_hom_equiv (as_iso (whisker_left A.diagram η))
      (G.map_cocone A.cocone)).symm (limits.is_colimit_of_preserves G A.is_colimit_cocone),
    use hT.desc S,
    split,
    { apply hS.hom_ext,
      intros j,
      erw [hS.fac_assoc, hT.fac, category.comp_id] },
    { apply hT.hom_ext,
      intros j,
      erw [hT.fac_assoc, hS.fac, category.comp_id] }
  }, --^ general colimit nonsense..., but I can't find applicable lemmas :-(
  intros I,
  obtain ⟨ι,hι,e,-⟩ := A.exists_biprod_iso_of_index I,
  -- now use the fact that the functors are additive and that there exists some iso with a biproduct
  resetI,
  let eF : F.obj (⨁ λ (i : ι), tunit.{u}) ≅ ⨁ λ (i : ι), F.obj tunit :=
    (limits.is_bilimit_of_preserves F
    (limits.biproduct.is_bilimit (λ i : ι, tunit.{u}))).is_colimit.cocone_point_unique_up_to_iso
    (limits.biproduct.is_bilimit (λ i : ι, F.obj tunit)).is_colimit,
  let eG : G.obj (⨁ λ (i : ι), tunit.{u}) ≅ ⨁ λ (i : ι), G.obj tunit :=
    (limits.is_bilimit_of_preserves G
    (limits.biproduct.is_bilimit (λ i : ι, tunit.{u}))).is_colimit.cocone_point_unique_up_to_iso
    (limits.biproduct.is_bilimit (λ i : ι, G.obj tunit)).is_colimit,
  have : η.app (A.diagram.obj I) =
    F.map e.inv ≫ eF.hom ≫ limits.biproduct.desc
      (λ i, η.app _ ≫ limits.biproduct.ι _ i) ≫ eG.inv ≫ G.map e.hom,
  { rw [← functor.map_iso_inv, iso.eq_inv_comp, ← iso.inv_comp_eq],
    apply limits.biproduct.hom_ext', intros i,
    simp only [functor.map_iso_hom, nat_trans.naturality,
      limits.biproduct.ι_desc_assoc, category.assoc],
    erw [limits.biproduct.ι_desc_assoc, limits.biproduct.ι_desc_assoc],
    dsimp, rw η.naturality_assoc },
  rw this,
  apply_with is_iso.comp_is_iso { instances := ff },
  apply_instance,
  apply_with is_iso.comp_is_iso { instances := ff },
  apply_instance,
  apply_with is_iso.comp_is_iso { instances := ff },
  swap,
  apply_instance,
  use limits.biproduct.desc
      (λ i, inv (η.app _) ≫ limits.biproduct.ι _ i),
  split,
  { ext, simp },
  { ext, simp },
end

def is_tensor_unit (A : AddCommGroup.{u}) : Prop :=
∃ a : A, ∀ (B : AddCommGroup.{u}), function.bijective
  (λ f : A ⟶ B, (f : A → B) a)

def is_tensor_unit.gen {A : AddCommGroup.{u}} (h : A.is_tensor_unit) :
  A := h.some

def is_tensor_unit.as_hom {A B : AddCommGroup.{u}} (h : A.is_tensor_unit)
  (b : B) : A ⟶ B :=
((h.some_spec B).2 b).some

@[simp]
lemma is_tensor_unit.eval_as_hom {A B : AddCommGroup.{u}} (h : A.is_tensor_unit)
  (b : B) : h.as_hom b h.gen = b :=
((h.some_spec B).2 b).some_spec

lemma is_tensor_unit.ext {A B : AddCommGroup.{u}} (h : A.is_tensor_unit)
  (f g : A ⟶ B) (hh : f h.gen = g h.gen) : f = g :=
(h.some_spec B).1 hh

def is_tensor_unit.iso {A B : AddCommGroup.{u}} (hA : A.is_tensor_unit)
  (hB : B.is_tensor_unit) : A ≅ B :=
{ hom := hA.as_hom hB.gen,
  inv := hB.as_hom hA.gen,
  hom_inv_id' := begin
    apply hA.ext,
    simp,
  end,
  inv_hom_id' := begin
    apply hB.ext,
    simp,
  end }

lemma is_tensor_unit_tunit : tunit.{u}.is_tensor_unit :=
begin
  use tunit.gen,
  intros B,
  split,
  { intros f g h,
    dsimp [tunit.gen] at h,
    change (adj'.unit.app _ ≫ (forget _).map f) _ =
      (adj'.unit.app _ ≫ (forget _).map g) _ at h,
    apply_fun adj'.hom_equiv _ _,
    simp only [adjunction.hom_equiv_unit],
    ext t,
    let e := limits.terminal.from (punit : Type u),
    suffices : t = e punit.star,
    { rw this, exact h },
    apply_fun types.punit_iso.inv,
    { simp },
    intros i j h, apply_fun types.punit_iso.hom at h,
    simpa using h },
  { intros t,
    use tunit.lift (types.pt t),
    dsimp only [tunit.lift, types.pt, tunit.gen],
    simp only [adjunction.hom_equiv_counit],
    change (adj'.unit.app _ ≫
      (forget _).map (free'.map (λ (x : ⊤_ Type u), t) ≫ adj'.counit.app B)) _ = _,
    simp only [functor.map_comp, adjunction.unit_naturality_assoc],
    erw adj'.right_triangle_components, refl }
end

lemma is_iso_of_preserves_of_is_tensor_unit {𝓐 : Type u'} [category.{u} 𝓐] [preadditive 𝓐]
  (F G : AddCommGroup ⥤ 𝓐)
  [F.additive]
  [G.additive]
  [limits.preserves_filtered_colimits F]
  [limits.preserves_filtered_colimits G]
  (η : F ⟶ G)
  (U : AddCommGroup)
  (hU : U.is_tensor_unit)
  [hη : is_iso (η.app U)]
  (A : AddCommGroup.{u})
  [no_zero_smul_divisors ℤ A] :
  is_iso (η.app A) :=
begin
  suffices : is_iso (η.app tunit),
  { resetI, apply is_iso_of_preserves },
  let e : tunit ≅ U := is_tensor_unit_tunit.iso hU,
  suffices : η.app tunit = F.map e.hom ≫ η.app U ≫ G.map e.inv,
  { rw this, apply is_iso.comp_is_iso, },
  rw [← η.naturality, ← F.map_comp_assoc, e.hom_inv_id, F.map_id, category.id_comp],
end

end AddCommGroup


/-
Copyright (c) 2020 Yury G. Kudryashov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Yury G. Kudryashov
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.order.conditionally_complete_lattice
import Mathlib.logic.function.conjugate
import Mathlib.order.ord_continuous
import Mathlib.data.equiv.mul_add
import Mathlib.PostPort

universes u_1 u_2 u_3

namespace Mathlib

/-!
# Semiconjugate by `Sup`

In this file we prove two facts about semiconjugate (families of) functions.

First, if an order isomorphism `fa : α → α` is semiconjugate to an order embedding `fb : β → β` by
`g : α → β`, then `fb` is semiconjugate to `fa` by `y ↦ Sup {x | g x ≤ y}`, see
`semiconj.symm_adjoint`.

Second, consider two actions `f₁ f₂ : G → α → α` of a group on a complete lattice by order
isomorphisms. Then the map `x ↦ ⨆ g : G, (f₁ g)⁻¹ (f₂ g x)` semiconjugates each `f₁ g'` to `f₂ g'`,
see `function.Sup_div_semiconj`.  In the case of a conditionally complete lattice, a similar
statement holds true under an additional assumption that each set `{(f₁ g)⁻¹ (f₂ g x) | g : G}` is
bounded above, see `function.cSup_div_semiconj`.

The lemmas come from [Étienne Ghys, Groupes d'homeomorphismes du cercle et cohomologie
bornee][ghys87:groupes], Proposition 2.1 and 5.4 respectively. In the paper they are formulated for
homeomorphisms of the circle, so in order to apply results from this file one has to lift these
homeomorphisms to the real line first.
-/

/-- We say that `g : β → α` is an order right adjoint function for `f : α → β` if it sends each `y`
to a least upper bound for `{x | f x ≤ y}`. If `α` is a partial order, and `f : α → β` has
a right adjoint, then this right adjoint is unique. -/
def is_order_right_adjoint {α : Type u_1} {β : Type u_2} [preorder α] [preorder β] (f : α → β) (g : β → α) :=
  ∀ (y : β), is_lub (set_of fun (x : α) => f x ≤ y) (g y)

theorem is_order_right_adjoint_Sup {α : Type u_1} {β : Type u_2} [complete_lattice α] [preorder β] (f : α → β) : is_order_right_adjoint f fun (y : β) => Sup (set_of fun (x : α) => f x ≤ y) :=
  fun (y : β) => is_lub_Sup (set_of fun (x : α) => f x ≤ y)

theorem is_order_right_adjoint_cSup {α : Type u_1} {β : Type u_2} [conditionally_complete_lattice α] [preorder β] (f : α → β) (hne : ∀ (y : β), ∃ (x : α), f x ≤ y) (hbdd : ∀ (y : β), ∃ (b : α), ∀ (x : α), f x ≤ y → x ≤ b) : is_order_right_adjoint f fun (y : β) => Sup (set_of fun (x : α) => f x ≤ y) :=
  fun (y : β) => is_lub_cSup (hne y) (hbdd y)

theorem is_order_right_adjoint.unique {α : Type u_1} {β : Type u_2} [partial_order α] [preorder β] {f : α → β} {g₁ : β → α} {g₂ : β → α} (h₁ : is_order_right_adjoint f g₁) (h₂ : is_order_right_adjoint f g₂) : g₁ = g₂ :=
  funext fun (y : β) => is_lub.unique (h₁ y) (h₂ y)

theorem is_order_right_adjoint.right_mono {α : Type u_1} {β : Type u_2} [preorder α] [preorder β] {f : α → β} {g : β → α} (h : is_order_right_adjoint f g) : monotone g :=
  fun (y₁ y₂ : β) (hy : y₁ ≤ y₂) =>
    is_lub.mono (h y₁) (h y₂) fun (x : α) (hx : x ∈ set_of fun (x : α) => f x ≤ y₁) => le_trans hx hy

namespace function

/-- If an order automorphism `fa` is semiconjugate to an order embedding `fb` by a function `g`
and `g'` is an order right adjoint of `g` (i.e. `g' y = Sup {x | f x ≤ y}`), then `fb` is
semiconjugate to `fa` by `g'`.

This is a version of Proposition 2.1 from [Étienne Ghys, Groupes d'homeomorphismes du cercle et
cohomologie bornee][ghys87:groupes]. -/
theorem semiconj.symm_adjoint {α : Type u_1} {β : Type u_2} [partial_order α] [preorder β] {fa : α ≃o α} {fb : β ↪o β} {g : α → β} (h : semiconj g ⇑fa ⇑fb) {g' : β → α} (hg' : is_order_right_adjoint g g') : semiconj g' ⇑fb ⇑fa := sorry

theorem semiconj_of_is_lub {α : Type u_1} {G : Type u_3} [partial_order α] [group G] (f₁ : G →* α ≃o α) (f₂ : G →* α ≃o α) {h : α → α} (H : ∀ (x : α), is_lub (set.range fun (g' : G) => coe_fn (coe_fn f₁ g'⁻¹) (coe_fn (coe_fn f₂ g') x)) (h x)) (g : G) : semiconj h ⇑(coe_fn f₂ g) ⇑(coe_fn f₁ g) := sorry

/-- Consider two actions `f₁ f₂ : G → α → α` of a group on a complete lattice by order
isomorphisms. Then the map `x ↦ ⨆ g : G, (f₁ g)⁻¹ (f₂ g x)` semiconjugates each `f₁ g'` to `f₂ g'`.

This is a version of Proposition 5.4 from [Étienne Ghys, Groupes d'homeomorphismes du cercle et
cohomologie bornee][ghys87:groupes]. -/
theorem Sup_div_semiconj {α : Type u_1} {G : Type u_3} [complete_lattice α] [group G] (f₁ : G →* α ≃o α) (f₂ : G →* α ≃o α) (g : G) : semiconj (fun (x : α) => supr fun (g' : G) => coe_fn (coe_fn f₁ g'⁻¹) (coe_fn (coe_fn f₂ g') x)) ⇑(coe_fn f₂ g)
  ⇑(coe_fn f₁ g) :=
  semiconj_of_is_lub f₁ f₂ (fun (x : α) => is_lub_supr) g

/-- Consider two actions `f₁ f₂ : G → α → α` of a group on a conditionally complete lattice by order
isomorphisms. Suppose that each set $s(x)=\{f_1(g)^{-1} (f_2(g)(x)) | g \in G\}$ is bounded above.
Then the map `x ↦ Sup s(x)` semiconjugates each `f₁ g'` to `f₂ g'`.

This is a version of Proposition 5.4 from [Étienne Ghys, Groupes d'homeomorphismes du cercle et
cohomologie bornee][ghys87:groupes]. -/
theorem cSup_div_semiconj {α : Type u_1} {G : Type u_3} [conditionally_complete_lattice α] [group G] (f₁ : G →* α ≃o α) (f₂ : G →* α ≃o α) (hbdd : ∀ (x : α), bdd_above (set.range fun (g : G) => coe_fn (coe_fn f₁ g⁻¹) (coe_fn (coe_fn f₂ g) x))) (g : G) : semiconj (fun (x : α) => supr fun (g' : G) => coe_fn (coe_fn f₁ g'⁻¹) (coe_fn (coe_fn f₂ g') x)) ⇑(coe_fn f₂ g)
  ⇑(coe_fn f₁ g) := sorry


def allPairs (xs : List α) (ys : List β) : List (α × β) :=
  let rec aux
  | [], r => r
  | x::xs, r =>
    let rec aux₂
    | [], r => r
    | y::ys, r => (x, y) :: r
    aux₂ ys (aux xs r)
  aux xs []

def allPairsFixed (xs : List α) (ys : List β) : List (α × β) :=
  let rec aux
  | [], r => r
  | x::xs, r =>
    let rec aux₂
    | [], r => r
    | y::ys, r => aux₂ ys ((x, y) :: r)
    aux₂ ys (aux xs r)
  aux xs []

#eval allPairsFixed [1, 2, 3] ['a', 'b']

example : (allPairsFixed [1, 2, 3] ['a', 'b']) = [(1, 'b'), (1, 'a'), (2, 'b'), (2, 'a'), (3, 'b'), (3, 'a')] :=
  rfl

example : (allPairsFixed (List.iota 3) (List.iota 4) |>.length) = 12 :=
  rfl


/-
This file contains the Tseitin encoding for XOR.
Both the pooled and linear encodigns are included here.

Authors: Cayden Codel, Jeremy Avidgad, Marijn Heule
Carnegie Mellon University
-/

import cnf.literal
import cnf.clause
import cnf.cnf
import cnf.encoding
import cnf.gensym
import xor.xor
import xor.direct_xor

import data.list.basic
import data.nat.basic

universe u

variables {V : Type u} [inhabited V] [decidable_eq V]

open literal
open clause
open cnf
open Xor
open encoding
open gensym

open nat
open list
open list.perm
open assignment
open function

namespace tseitin_xor

variables {l : list (literal V)} {g : gensym V} {k : nat} (hk : k ≥ 3) {v : V} {τ : assignment V}

lemma disjoint_fresh_of_disjoint : disjoint g.stock (clause.vars l) →
  disjoint g.fresh.2.stock (clause.vars ((Pos g.fresh.1) :: (l.drop (k - 1)))) :=
begin
  intro h,
  apply set.disjoint_right.mpr,
  intros v hv,
  simp [clause.vars] at hv,
  rcases hv with rfl | hv,
  { rw var,
    exact fresh_not_mem_fresh_stock g },
  { intro hcon,
    rw set.disjoint_right at h,
    have := vars_subset_of_subset (drop_subset (k - 1) l),
    exact absurd ((fresh_stock_subset g) hcon) (h (this hv)) }
end

lemma drop_len_lt (lit : literal V) (hk : k ≥ 3) :
  length l > k → length (lit :: (l.drop (k - 1))) < length l :=
begin
  intro hl,
  rw length_cons,
  rcases exists_append_of_gt_length hl with ⟨x₁, x₂, rfl, hl₁⟩,
  simp only [hl₁, length_drop, length_append],
  rw [add_comm k x₂.length, nat.add_sub_assoc (nat.sub_le k 1),
      nat.sub_sub_self (le_of_add_le_right hk), add_assoc],
  apply add_lt_add_left,
  exact succ_le_iff.mp hk,
end

variables {p : list (literal V) → list (literal V)} (hp : ∀ l, perm l (p l))

def tseitin_xor : list (literal V) → gensym V → cnf V
| l g :=  if h : length l ≤ k then direct_xor l else
          have length (p (Pos g.fresh.1 :: (l.drop (k - 1)))) < length l,
            from (perm.length_eq (hp (Pos g.fresh.1 :: (l.drop (k - 1))))) ▸
              (drop_len_lt _ hk (not_le.mp h)),
          (direct_xor (l.take (k - 1) ++ [(Neg g.fresh.1)])) ++
          (tseitin_xor (p (Pos g.fresh.1 :: (l.drop (k - 1)))) g.fresh.2)
using_well_founded {
  rel_tac := λ a b, `[exact ⟨_, measure_wf (λ σ, list.length σ.1)⟩],
  dec_tac := tactic.assumption
}

lemma tseitin_base_case : length l ≤ k → tseitin_xor hk hp l g = direct_xor l :=
assume h, by { rw tseitin_xor, simp only [h, if_true] }

theorem mem_tseitin_xor_vars_of_mem_vars
  (hdis : disjoint g.stock (clause.vars l)) :
  v ∈ (clause.vars l) → v ∈ (tseitin_xor hk hp l g).vars :=
begin
  induction l using strong_induction_on_lists with l ih generalizing g,
  by_cases hl : length l ≤ k,
  { rw [tseitin_base_case hk hp hl, vars_direct_xor], exact id },
  { intro h,
    rw tseitin_xor,
    simp [hl],
    rw [← take_append_drop (k - 1) l, clause.vars_append] at h,
    rw cnf.vars_append,
    rcases finset.mem_union.mp h with (h | h),
    { apply finset.mem_union_left,
      rw [vars_direct_xor, clause.vars_append],
      exact finset.mem_union_left _ h },
    { rw not_le at hl,
      have h₁ := drop_len_lt (Pos g.fresh.1) hk hl,
      have h₂ := disjoint_fresh_of_disjoint hdis,
      rw perm.length_eq (hp (Pos g.fresh.1 :: drop (k - 1) l)) at h₁,
      rw vars_perm (hp (Pos g.fresh.1 :: drop (k - 1) l)) at h₂,
      have := ih _ h₁ h₂,
      rw ← clause.vars_perm (hp (Pos g.fresh.1 :: drop (k - 1) l)) at this,
      exact finset.mem_union_right _ (this (mem_vars_cons_of_mem_vars _ h)) } }
end

theorem not_mem_tseitin_xor_vars_of_not_mem_vars_of_not_mem_stock
  (hdis : disjoint g.stock (clause.vars l)) :
  v ∉ (clause.vars l) → v ∉ g.stock → v ∉ (tseitin_xor hk hp l g).vars :=
begin
  induction l using strong_induction_on_lists with l ih generalizing g,
  by_cases hl : length l ≤ k,
  { rw [tseitin_base_case hk hp hl, vars_direct_xor l], tautology },
  { intros hvars hg,
    rw tseitin_xor,
    simp [hl],
    rw cnf.vars_append,
    apply finset.not_mem_union.mpr,
    split,
    { rw [vars_direct_xor, clause.vars_append],
      apply finset.not_mem_union.mpr,
      split,
      { intro hcon,
        have := (vars_subset_of_subset (take_subset (k - 1) l)),
        exact absurd (this hcon) hvars },
      { simp [var],
        intro hcon,
        rw hcon at hg,
        exact absurd (fresh_mem_stock g) hg } },
    { have h₁ := drop_len_lt (Pos g.fresh.1) hk (not_le.mp hl),
      have h₂ := disjoint_fresh_of_disjoint hdis,
      have h₃ : v ∉ clause.vars (Pos g.fresh.1 :: drop (k - 1) l),
      { simp [clause.vars, var],
        rintros (rfl | h),
        { exact hg (fresh_mem_stock g) },
        { exact hvars (vars_subset_of_subset (drop_subset (k - 1) l) h) } },
      have h₄ : v ∉ g.fresh.2.stock,
      { intro hcon,
        exact hg ((fresh_stock_subset g) hcon) },
      rw perm.length_eq (hp (Pos g.fresh.1 :: drop (k - 1) l)) at h₁,
      rw vars_perm (hp (Pos g.fresh.1 :: drop (k - 1) l)) at h₂ h₃,
      exact ih _ h₁ h₂ h₃ h₄ } }
end

lemma tseitin_forward (hdis : disjoint g.stock (clause.vars l)) :
  Xor.eval τ l = tt → ∃ (σ : assignment V),
  (tseitin_xor hk hp l g).eval σ = tt ∧ (eqod τ σ (clause.vars l)) :=
begin
  intro he,
  induction l using strong_induction_on_lists with l ih generalizing g τ,
  by_cases hl : length l ≤ k,
  { use τ, rw [tseitin_base_case hk hp hl, eval_direct_xor_eq_eval_Xor], simp [he] },
  {
    rw [eval_eq_bodd_count_tt,
      ← (take_append_drop (k - 1) l), clause.count_tt_append, bodd_add] at he,

    have hnotmem := set.disjoint_left.mp hdis (g.fresh_mem_stock),
    have h₁ := drop_len_lt (Pos g.fresh.1) hk (not_le.mp hl),
    have h₂ := disjoint_fresh_of_disjoint hdis,
    rw perm.length_eq (hp (Pos g.fresh.1 :: drop (k - 1) l)) at h₁,
    rw vars_perm (hp (Pos g.fresh.1 :: drop (k - 1) l)) at h₂,
    have htakevars := vars_subset_of_subset (take_subset (k - 1) l),
    have hdropvars := vars_subset_of_subset (drop_subset (k - 1) l),

    rw tseitin_xor,
    simp [hl, cnf.eval_append],

    -- Case on the truth value of the last n - k + 1 variables
    -- Note: the proof is symmetric, so any tightening-up can be done in both
    cases hc : bodd (clause.count_tt τ (take (k - 1) l)),
    { rw [hc, bool.bxor_ff_left] at he,
      rcases exists_eqod_and_eq_of_not_mem τ ff hnotmem with ⟨γ, heqod, hg⟩,
      have : bodd (clause.count_tt γ (Pos g.fresh.1 :: drop (k - 1) l)) = tt,
      { simp only [clause.count_tt_cons, literal.eval, hg, cond,
          ← count_tt_eq_of_eqod (eqod_subset hdropvars heqod), he] },
      rw [← eval_eq_bodd_count_tt, eval_eq_of_perm (hp (Pos g.fresh.1 :: drop (k - 1) l))] at this,

      -- Apply the induction hypothesis
      rcases (ih _ h₁ h₂ this) with ⟨γ₂, he₂, hg₂⟩,

      have heqod₂ : eqod (assignment.ite (cnf.vars (tseitin_xor hk hp (p (Pos g.fresh.1 :: (l.drop (k - 1)))) g.fresh.2)) γ₂ γ) γ (clause.vars l),
      { intros v hv,
        by_cases hmem : v ∈ clause.vars (l.drop (k - 1)),
        { have h₃ := mem_vars_cons_of_mem_vars (Pos g.fresh.1) hmem,
          rw vars_perm (hp (Pos g.fresh.1 :: drop (k - 1) l)) at h₃,
          rw [ite_pos (mem_tseitin_xor_vars_of_mem_vars hk hp h₂ h₃), hg₂ v h₃] },
        { have hdis₂ := set.disjoint_right.mp hdis hv,
          have hne : v ≠ g.fresh.1,
          { intro hcon,
            exact (hcon ▸ hdis₂) (fresh_mem_stock g) },
          have : v ∉ clause.vars (Pos g.fresh.1 :: drop (k - 1) l),
          { simp [clause.vars, var],
            rintros (hcon | hcon),
            { exact hne hcon },
            { exact hmem hcon } },
          rw vars_perm (hp (Pos g.fresh.1 :: drop (k - 1) l)) at this,
          have hstock : v ∉ g.fresh.2.stock,
          { intro hcon,
            exact hdis₂ ((fresh_stock_subset g) hcon) },
          rw ite_neg (not_mem_tseitin_xor_vars_of_not_mem_vars_of_not_mem_stock hk hp h₂ this hstock) } },

      use assignment.ite (cnf.vars (tseitin_xor hk hp (p (Pos g.fresh.1 :: (l.drop (k - 1)))) g.fresh.2)) γ₂ γ,
      split,
      { split,
        { simp [eval_direct_xor_eq_eval_Xor, eval_eq_bodd_count_tt,
            clause.count_tt_append, bodd_add, literal.eval, hg],
          have : g.fresh.1 ∈ clause.vars (Pos g.fresh.1 :: (l.drop (k - 1))),
          { exact mem_vars_cons_self _ _ },
          rw vars_perm (hp (Pos g.fresh.1 :: drop (k - 1) l)) at this,
          simp [ite_pos (mem_tseitin_xor_vars_of_mem_vars hk hp h₂ this),
            ← (hg₂ g.fresh.1 this), hg,
            count_tt_eq_of_eqod (eqod_subset htakevars heqod₂),
            ← count_tt_eq_of_eqod (eqod_subset htakevars heqod), hc] },
        { exact he₂ ▸ eval_eq_of_eqod (ite_eqod _ _ _) } },
      { exact eqod.trans heqod (heqod₂.symm) } },
    { simp only [hc, bnot_eq_true_eq_eq_ff, tt_bxor] at he,
        rcases exists_eqod_and_eq_of_not_mem τ tt hnotmem with ⟨γ, heqod, hg⟩,
        have : bodd (clause.count_tt γ (Pos g.fresh.1 :: drop (k - 1) l)) = tt,
        { simp only [clause.count_tt_cons, literal.eval, hg, cond,
            ← count_tt_eq_of_eqod (eqod_subset hdropvars heqod), he, bodd_succ,
            bodd_add, bodd_zero, bool.bnot_ff, bxor_tt_left], },
        rw [← eval_eq_bodd_count_tt, eval_eq_of_perm (hp (Pos g.fresh.1 :: drop (k - 1) l))] at this,

        -- Apply the induction hypothesis
        rcases (ih _ h₁ h₂ this) with ⟨γ₂, he₂, hg₂⟩,

        have heqod₂ : eqod (assignment.ite (cnf.vars (tseitin_xor hk hp (p (Pos g.fresh.1 :: (l.drop (k - 1)))) g.fresh.2)) γ₂ γ) γ (clause.vars l),
        { intros v hv,
          by_cases hmem : v ∈ clause.vars (l.drop (k - 1)),
          { have h₃ := mem_vars_cons_of_mem_vars (Pos g.fresh.1) hmem,
            rw vars_perm (hp (Pos g.fresh.1 :: drop (k - 1) l)) at h₃,
            rw [ite_pos (mem_tseitin_xor_vars_of_mem_vars hk hp h₂ h₃), hg₂ v h₃] },
          { have hdis₂ := set.disjoint_right.mp hdis hv,
            have hne : v ≠ g.fresh.1,
            { intro hcon,
              exact (hcon ▸ hdis₂) (fresh_mem_stock g) },
            have : v ∉ clause.vars (Pos g.fresh.1 :: drop (k - 1) l),
            { simp [clause.vars, var],
              rintros (hcon | hcon),
              { exact hne hcon },
              { exact hmem hcon } },
            rw vars_perm (hp (Pos g.fresh.1 :: drop (k - 1) l)) at this,
            have hstock : v ∉ g.fresh.2.stock,
            { intro hcon,
              exact hdis₂ ((fresh_stock_subset g) hcon) },
            rw ite_neg (not_mem_tseitin_xor_vars_of_not_mem_vars_of_not_mem_stock hk hp h₂ this hstock) } },

        use assignment.ite (cnf.vars (tseitin_xor hk hp (p (Pos g.fresh.1 :: (l.drop (k - 1)))) g.fresh.2)) γ₂ γ,
        split,
        { split,
          { simp [eval_direct_xor_eq_eval_Xor, eval_eq_bodd_count_tt,
              clause.count_tt_append, bodd_add, literal.eval, hg],
            have : g.fresh.1 ∈ clause.vars (Pos g.fresh.1 :: (l.drop (k - 1))),
            { exact mem_vars_cons_self _ _ },
            rw vars_perm (hp (Pos g.fresh.1 :: drop (k - 1) l)) at this,
            simp [ite_pos (mem_tseitin_xor_vars_of_mem_vars hk hp h₂ this),
              ← (hg₂ g.fresh.1 this), hg,
              count_tt_eq_of_eqod (eqod_subset htakevars heqod₂),
              ← count_tt_eq_of_eqod (eqod_subset htakevars heqod), hc] },
          { exact he₂ ▸ eval_eq_of_eqod (ite_eqod _ _ _) } },
        { exact eqod.trans heqod heqod₂.symm } } }
end

lemma tseitin_reverse (hdis : disjoint g.stock (clause.vars l)) :
  cnf.eval τ (tseitin_xor hk hp l g) = tt → Xor.eval τ l = tt :=
begin
  intro he,
  induction l using strong_induction_on_lists with l ih generalizing g,
  by_cases hl : length l ≤ k,
  { rw [tseitin_base_case hk hp hl, eval_direct_xor_eq_eval_Xor] at he, exact he },
  { rw tseitin_xor at he,
    simp [hl, cnf.eval_append] at he,
    rcases he with ⟨hdir, hrec⟩,
    have h₁ := drop_len_lt (Pos g.fresh.1) hk (not_le.mp hl),
    have h₂ := disjoint_fresh_of_disjoint hdis,
    rw perm.length_eq (hp (Pos g.fresh.1 :: drop (k - 1) l)) at h₁,
    rw vars_perm (hp (Pos g.fresh.1 :: drop (k - 1) l)) at h₂,
    have ihred := ih _ h₁ h₂ hrec,
    rw eval_direct_xor_eq_eval_Xor at hdir,
    rw eval_eq_bodd_count_tt at ihred hdir |-,
    rw ← clause.count_tt_perm (hp (Pos g.fresh.1 :: drop (k - 1) l)) at ihred,
    have := congr_arg ((clause.count_tt τ)) (take_append_drop (k - 1) l).symm,
    have := congr_arg bodd this,
    cases hnew : (τ g.fresh.1),
    { simp [clause.count_tt_cons, clause.count_tt_append, hnew, literal.eval] at ihred hdir,
      rw [clause.count_tt_append, bodd_add, hdir, ihred, ff_bxor] at this,
      exact this },
    { simp [clause.count_tt_cons, clause.count_tt_append, hnew, literal.eval] at ihred hdir,
      rw [clause.count_tt_append, bodd_add, hdir, ihred, bxor_ff] at this,
      exact this } }
end

theorem tseitin_xor_encodes_Xor (hdis : disjoint g.stock (clause.vars l)) :
  encodes Xor (tseitin_xor hk hp l g) l :=
begin
  intro τ,
  split,
  { exact tseitin_forward hk hp hdis },
  { rintros ⟨σ, he, heqod⟩,
    rw [← Xor.eval, Xor.eval_eq_of_eqod heqod],
    exact tseitin_reverse hk hp hdis he }
end

def linear_perm (l : list (literal V)) : list (literal V) := l

lemma linear_perm_is_perm : ∀ (l : list (literal V)), l ~ linear_perm l :=
begin
  intro l,
  rw linear_perm
end

def linear_xor (l : list (literal V)) (g : gensym V) : cnf V :=
  tseitin_xor hk linear_perm_is_perm l g

theorem linear_xor_encodes_Xor (hdis : disjoint g.stock (clause.vars l)) :
  encodes Xor (linear_xor hk l g) l :=
tseitin_xor_encodes_Xor hk linear_perm_is_perm hdis

def pooled_perm : list (literal V) → list (literal V)
| []        := []
| (x :: xs) := xs ++ [x]

lemma pooled_perm_is_perm : ∀ (l : list (literal V)), l ~ pooled_perm l :=
begin
  intro l,
  cases l,
  { refl },
  { rw [pooled_perm, ← singleton_append],
    exact perm_append_comm }
end

def pooled_xor (l : list (literal V)) (g : gensym V) : cnf V :=
  tseitin_xor hk pooled_perm_is_perm l g

theorem pooled_xor_encodes_Xor (hdis : disjoint g.stock (clause.vars l)) :
  encodes Xor (pooled_xor hk l g) l :=
tseitin_xor_encodes_Xor hk pooled_perm_is_perm hdis

end tseitin_xor


namespace fol_19

variable U : Type
variable f : U → U → U
variable P : U → Prop

theorem fol_19 : (∀ x, P (f x x)) → (∀ x, ∃ y, P (f x y)) :=
assume h1: ∀ x, P (f x x),
assume t: U,
have h2: P (f t t), from h1 t,
show ∃ y, P (f t y), from exists.intro t h2

end fol_19


namespace xena

inductive xnat
| zero : xnat
| succ : xnat → xnat

open xnat

definition lt : xnat → xnat → Prop
| zero zero := false
| (succ m) zero := false
| zero (succ p) := true
| (succ m) (succ p) := lt m p

notation a < b := lt a b

#print int

theorem inequality_A2 (a b c : xnat) : a < b → b < c → a < c := λ hab hbc, sorry

end xena

#print prod


-- 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.products
import category_theory.limits.preserves

open category_theory category_theory.category

namespace category_theory.limits

universes v u -- declare the `v`'s first; see `category_theory.category` for an explanation

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

variables {J K : Type v} [small_category J] [small_category K]

@[simp] lemma cone.functor_w {F : J ⥤ (K ⥤ C)} (c : cone F) {j j' : J} (f : j ⟶ j') (k : K) :
  (c.π.app j).app k ≫ (F.map f).app k = (c.π.app j').app k :=
by convert ←nat_trans.congr_app (c.π.naturality f).symm k; apply id_comp

@[simp] lemma cocone.functor_w {F : J ⥤ (K ⥤ C)} (c : cocone F) {j j' : J} (f : j ⟶ j') (k : K) :
  (F.map f).app k ≫ (c.ι.app j').app k = (c.ι.app j).app k :=
by convert ←nat_trans.congr_app (c.ι.naturality f) k; apply comp_id

@[simp] def functor_category_limit_cone [has_limits_of_shape J C] (F : J ⥤ K ⥤ C) :
  cone F :=
{ X := F.flip ⋙ lim,
  π :=
  { app := λ j,
    { app := λ k, limit.π (F.flip.obj k) j },
      naturality' := λ j j' f,
        by ext k; convert (limit.w (F.flip.obj k) _).symm using 1; apply id_comp } }

@[simp] def functor_category_colimit_cocone [has_colimits_of_shape J C] (F : J ⥤ K ⥤ C) :
  cocone F :=
{ X := F.flip ⋙ colim,
  ι :=
  { app := λ j,
    { app := λ k, colimit.ι (F.flip.obj k) j },
      naturality' := λ j j' f,
        by ext k; convert (colimit.w (F.flip.obj k) _) using 1; apply comp_id } }

@[simp] def evaluate_functor_category_limit_cone
  [has_limits_of_shape J C] (F : J ⥤ K ⥤ C) (k : K) :
  ((evaluation K C).obj k).map_cone (functor_category_limit_cone F) ≅
    limit.cone (F.flip.obj k) :=
cones.ext (iso.refl _) (by tidy)

@[simp] def evaluate_functor_category_colimit_cocone
  [has_colimits_of_shape J C] (F : J ⥤ K ⥤ C) (k : K) :
  ((evaluation K C).obj k).map_cocone (functor_category_colimit_cocone F) ≅
    colimit.cocone (F.flip.obj k) :=
cocones.ext (iso.refl _) (by tidy)

def functor_category_is_limit_cone [has_limits_of_shape J C] (F : J ⥤ K ⥤ C) :
  is_limit (functor_category_limit_cone F) :=
{ lift := λ s,
  { app := λ k, limit.lift (F.flip.obj k) (((evaluation K C).obj k).map_cone s),
    naturality' := λ k k' f,
      by ext; dsimp; simpa using (s.π.app j).naturality f },
  uniq' := λ s m w,
  begin
    ext1 k,
    exact is_limit.uniq _
      (((evaluation K C).obj k).map_cone s) (m.app k) (λ j, nat_trans.congr_app (w j) k)
  end }

def functor_category_is_colimit_cocone [has_colimits_of_shape.{v} J C] (F : J ⥤ K ⥤ C) :
  is_colimit (functor_category_colimit_cocone F) :=
{ desc := λ s,
  { app := λ k, colimit.desc (F.flip.obj k) (((evaluation K C).obj k).map_cocone s),
    naturality' := λ k k' f,
    begin
      ext,
      rw [←assoc, ←assoc],
      dsimp [functor.flip],
      simpa using (s.ι.app j).naturality f
    end },
  uniq' := λ s m w,
  begin
    ext1 k,
    exact is_colimit.uniq _
      (((evaluation K C).obj k).map_cocone s) (m.app k) (λ j, nat_trans.congr_app (w j) k)
  end }

instance functor_category_has_limits_of_shape
  [has_limits_of_shape J C] : has_limits_of_shape J (K ⥤ C) :=
λ F,
{ cone := functor_category_limit_cone F,
  is_limit := functor_category_is_limit_cone F }

instance functor_category_has_colimits_of_shape
  [has_colimits_of_shape J C] : has_colimits_of_shape J (K ⥤ C) :=
λ F,
{ cocone := functor_category_colimit_cocone F,
  is_colimit := functor_category_is_colimit_cocone F }

instance functor_category_has_limits [has_limits C] : has_limits (K ⥤ C) :=
λ J 𝒥, by resetI; apply_instance

instance functor_category_has_colimits [has_colimits C] : has_colimits (K ⥤ C) :=
λ J 𝒥, by resetI; apply_instance

instance evaluation_preserves_limits_of_shape [has_limits_of_shape J C] (k : K) :
  preserves_limits_of_shape J ((evaluation K C).obj k) :=
λ F, preserves_limit_of_preserves_limit_cone (limit.is_limit _) $
  is_limit.of_iso_limit (limit.is_limit _)
    (evaluate_functor_category_limit_cone F k).symm

instance evaluation_preserves_colimits_of_shape [has_colimits_of_shape J C] (k : K) :
  preserves_colimits_of_shape J ((evaluation K C).obj k) :=
λ F, preserves_colimit_of_preserves_colimit_cocone (colimit.is_colimit _) $
  is_colimit.of_iso_colimit (colimit.is_colimit _)
    (evaluate_functor_category_colimit_cocone F k).symm

instance evaluation_preserves_limits [has_limits C] (k : K) :
  preserves_limits ((evaluation K C).obj k) :=
λ J 𝒥, by resetI; apply_instance

instance evaluation_preserves_colimits [has_colimits C] (k : K) :
  preserves_colimits ((evaluation K C).obj k) :=
λ J 𝒥, by resetI; apply_instance

end category_theory.limits


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

! This file was ported from Lean 3 source module category_theory.monoidal.free.basic
! leanprover-community/mathlib commit 14b69e9f3c16630440a2cbd46f1ddad0d561dee7
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.CategoryTheory.Monoidal.Functor

/-!
# The free monoidal category over a type

Given a type `C`, the free monoidal category over `C` has as objects formal expressions built from
(formal) tensor products of terms of `C` and a formal unit. Its morphisms are compositions and
tensor products of identities, unitors and associators.

In this file, we construct the free monoidal category and prove that it is a monoidal category. If
`D` is a monoidal category, we construct the functor `free_monoidal_category C ⥤ D` associated to
a function `C → D`.

The free monoidal category has two important properties: it is a groupoid and it is thin. The former
is obvious from the construction, and the latter is what is commonly known as the monoidal coherence
theorem. Both of these properties are proved in the file `coherence.lean`.

-/

universe v' u u'

namespace CategoryTheory

open MonoidalCategory

variable {C : Type u}

section

variable (C)

/--
Given a type `C`, the free monoidal category over `C` has as objects formal expressions built from
(formal) tensor products of terms of `C` and a formal unit. Its morphisms are compositions and
tensor products of identities, unitors and associators.
-/
inductive FreeMonoidalCategory : Type u
  | of : C → free_monoidal_category
  | Unit : free_monoidal_category
  | tensor : free_monoidal_category → free_monoidal_category → free_monoidal_category
  deriving Inhabited
#align category_theory.free_monoidal_category CategoryTheory.FreeMonoidalCategory

end

-- mathport name: exprF
local notation "F" => FreeMonoidalCategory

namespace FreeMonoidalCategory

/-- Formal compositions and tensor products of identities, unitors and associators. The morphisms
    of the free monoidal category are obtained as a quotient of these formal morphisms by the
    relations defining a monoidal category. -/
@[nolint has_nonempty_instance]
inductive Hom : F C → F C → Type u
  | id (X) : hom X X
  | α_hom (X Y Z : F C) : hom ((X.tensor Y).tensor Z) (X.tensor (Y.tensor Z))
  | α_inv (X Y Z : F C) : hom (X.tensor (Y.tensor Z)) ((X.tensor Y).tensor Z)
  | l_hom (X) : hom (unit.tensor X) X
  | l_inv (X) : hom X (unit.tensor X)
  | ρ_hom (X : F C) : hom (X.tensor unit) X
  | ρ_inv (X : F C) : hom X (X.tensor unit)
  | comp {X Y Z} (f : hom X Y) (g : hom Y Z) : hom X Z
  | tensor {W X Y Z} (f : hom W Y) (g : hom X Z) : hom (W.tensor X) (Y.tensor Z)
#align category_theory.free_monoidal_category.hom CategoryTheory.FreeMonoidalCategory.Hom

-- mathport name: «expr ⟶ᵐ »
local infixr:10 " ⟶ᵐ " => Hom

/-- The morphisms of the free monoidal category satisfy 21 relations ensuring that the resulting
    category is in fact a category and that it is monoidal. -/
inductive HomEquiv : ∀ {X Y : F C}, (X ⟶ᵐ Y) → (X ⟶ᵐ Y) → Prop
  | refl {X Y} (f : X ⟶ᵐ Y) : hom_equiv f f
  | symm {X Y} (f g : X ⟶ᵐ Y) : hom_equiv f g → hom_equiv g f
  | trans {X Y} {f g h : X ⟶ᵐ Y} : hom_equiv f g → hom_equiv g h → hom_equiv f h
  |
  comp {X Y Z} {f f' : X ⟶ᵐ Y} {g g' : Y ⟶ᵐ Z} :
    hom_equiv f f' → hom_equiv g g' → hom_equiv (f.comp g) (f'.comp g')
  |
  tensor {W X Y Z} {f f' : W ⟶ᵐ X} {g g' : Y ⟶ᵐ Z} :
    hom_equiv f f' → hom_equiv g g' → hom_equiv (f.tensor g) (f'.tensor g')
  | comp_id {X Y} (f : X ⟶ᵐ Y) : hom_equiv (f.comp (Hom.id _)) f
  | id_comp {X Y} (f : X ⟶ᵐ Y) : hom_equiv ((Hom.id _).comp f) f
  |
  assoc {X Y U V : F C} (f : X ⟶ᵐ U) (g : U ⟶ᵐ V) (h : V ⟶ᵐ Y) :
    hom_equiv ((f.comp g).comp h) (f.comp (g.comp h))
  | tensor_id {X Y} : hom_equiv ((Hom.id X).tensor (Hom.id Y)) (Hom.id _)
  |
  tensor_comp {X₁ Y₁ Z₁ X₂ Y₂ Z₂ : F C} (f₁ : X₁ ⟶ᵐ Y₁) (f₂ : X₂ ⟶ᵐ Y₂) (g₁ : Y₁ ⟶ᵐ Z₁)
    (g₂ : Y₂ ⟶ᵐ Z₂) :
    hom_equiv ((f₁.comp g₁).tensor (f₂.comp g₂)) ((f₁.tensor f₂).comp (g₁.tensor g₂))
  | α_hom_inv {X Y Z} : hom_equiv ((Hom.α_hom X Y Z).comp (Hom.α_inv X Y Z)) (Hom.id _)
  | α_inv_hom {X Y Z} : hom_equiv ((Hom.α_inv X Y Z).comp (Hom.α_hom X Y Z)) (Hom.id _)
  |
  associator_naturality {X₁ X₂ X₃ Y₁ Y₂ Y₃} (f₁ : X₁ ⟶ᵐ Y₁) (f₂ : X₂ ⟶ᵐ Y₂) (f₃ : X₃ ⟶ᵐ Y₃) :
    hom_equiv (((f₁.tensor f₂).tensor f₃).comp (Hom.α_hom Y₁ Y₂ Y₃))
      ((Hom.α_hom X₁ X₂ X₃).comp (f₁.tensor (f₂.tensor f₃)))
  | ρ_hom_inv {X} : hom_equiv ((Hom.ρ_hom X).comp (Hom.ρ_inv X)) (Hom.id _)
  | ρ_inv_hom {X} : hom_equiv ((Hom.ρ_inv X).comp (Hom.ρ_hom X)) (Hom.id _)
  |
  ρ_naturality {X Y} (f : X ⟶ᵐ Y) :
    hom_equiv ((f.tensor (Hom.id unit)).comp (Hom.ρ_hom Y)) ((Hom.ρ_hom X).comp f)
  | l_hom_inv {X} : hom_equiv ((Hom.l_hom X).comp (Hom.l_inv X)) (Hom.id _)
  | l_inv_hom {X} : hom_equiv ((Hom.l_inv X).comp (Hom.l_hom X)) (Hom.id _)
  |
  l_naturality {X Y} (f : X ⟶ᵐ Y) :
    hom_equiv (((Hom.id unit).tensor f).comp (Hom.l_hom Y)) ((Hom.l_hom X).comp f)
  |
  pentagon {W X Y Z} :
    hom_equiv
      (((Hom.α_hom W X Y).tensor (Hom.id Z)).comp
        ((Hom.α_hom W (X.tensor Y) Z).comp ((Hom.id W).tensor (Hom.α_hom X Y Z))))
      ((Hom.α_hom (W.tensor X) Y Z).comp (Hom.α_hom W X (Y.tensor Z)))
  |
  triangle {X Y} :
    hom_equiv ((Hom.α_hom X unit Y).comp ((Hom.id X).tensor (Hom.l_hom Y)))
      ((Hom.ρ_hom X).tensor (Hom.id Y))
#align category_theory.free_monoidal_category.hom_equiv CategoryTheory.FreeMonoidalCategory.HomEquiv

/-- We say that two formal morphisms in the free monoidal category are equivalent if they become
    equal if we apply the relations that are true in a monoidal category. Note that we will prove
    that there is only one equivalence class -- this is the monoidal coherence theorem. -/
def setoidHom (X Y : F C) : Setoid (X ⟶ᵐ Y) :=
  ⟨HomEquiv,
    ⟨fun f => HomEquiv.refl f, fun f g => HomEquiv.symm f g, fun f g h hfg hgh =>
      HomEquiv.trans hfg hgh⟩⟩
#align category_theory.free_monoidal_category.setoid_hom CategoryTheory.FreeMonoidalCategory.setoidHom

attribute [instance] setoid_hom

section

open FreeMonoidalCategory.HomEquiv

instance categoryFreeMonoidalCategory : Category.{u} (F C)
    where
  Hom X Y := Quotient (FreeMonoidalCategory.setoidHom X Y)
  id X := ⟦FreeMonoidalCategory.Hom.id _⟧
  comp X Y Z f g :=
    Quotient.map₂ Hom.comp
      (by
        intro f f' hf g g' hg
        exact comp hf hg)
      f g
  id_comp' := by
    rintro X Y ⟨f⟩
    exact Quotient.sound (id_comp f)
  comp_id' := by
    rintro X Y ⟨f⟩
    exact Quotient.sound (comp_id f)
  assoc' := by
    rintro W X Y Z ⟨f⟩ ⟨g⟩ ⟨h⟩
    exact Quotient.sound (assoc f g h)
#align category_theory.free_monoidal_category.category_free_monoidal_category CategoryTheory.FreeMonoidalCategory.categoryFreeMonoidalCategory

instance : MonoidalCategory (F C)
    where
  tensorObj X Y := FreeMonoidalCategory.tensor X Y
  tensorHom X₁ Y₁ X₂ Y₂ :=
    Quotient.map₂ Hom.tensor <| by
      intro _ _ h _ _ h'
      exact hom_equiv.tensor h h'
  tensor_id' X Y := Quotient.sound tensor_id
  tensor_comp' X₁ Y₁ Z₁ X₂ Y₂ Z₂ := by
    rintro ⟨f₁⟩ ⟨f₂⟩ ⟨g₁⟩ ⟨g₂⟩
    exact Quotient.sound (tensor_comp _ _ _ _)
  tensorUnit := FreeMonoidalCategory.unit
  associator X Y Z :=
    ⟨⟦Hom.α_hom X Y Z⟧, ⟦Hom.α_inv X Y Z⟧, Quotient.sound α_hom_inv, Quotient.sound α_inv_hom⟩
  associator_naturality' X₁ X₂ X₃ Y₁ Y₂ Y₃ :=
    by
    rintro ⟨f₁⟩ ⟨f₂⟩ ⟨f₃⟩
    exact Quotient.sound (associator_naturality _ _ _)
  leftUnitor X := ⟨⟦Hom.l_hom X⟧, ⟦Hom.l_inv X⟧, Quotient.sound l_hom_inv, Quotient.sound l_inv_hom⟩
  leftUnitor_naturality' X Y := by
    rintro ⟨f⟩
    exact Quotient.sound (l_naturality _)
  rightUnitor X :=
    ⟨⟦Hom.ρ_hom X⟧, ⟦Hom.ρ_inv X⟧, Quotient.sound ρ_hom_inv, Quotient.sound ρ_inv_hom⟩
  rightUnitor_naturality' X Y := by
    rintro ⟨f⟩
    exact Quotient.sound (ρ_naturality _)
  pentagon' W X Y Z := Quotient.sound pentagon
  triangle' X Y := Quotient.sound triangle

@[simp]
theorem mk'_comp {X Y Z : F C} (f : X ⟶ᵐ Y) (g : Y ⟶ᵐ Z) :
    ⟦f.comp g⟧ = @CategoryStruct.comp (F C) _ _ _ _ ⟦f⟧ ⟦g⟧ :=
  rfl
#align category_theory.free_monoidal_category.mk_comp CategoryTheory.FreeMonoidalCategory.mk'_comp

@[simp]
theorem mk'_tensor {X₁ Y₁ X₂ Y₂ : F C} (f : X₁ ⟶ᵐ Y₁) (g : X₂ ⟶ᵐ Y₂) :
    ⟦f.tensor g⟧ = @MonoidalCategory.tensorHom (F C) _ _ _ _ _ _ ⟦f⟧ ⟦g⟧ :=
  rfl
#align category_theory.free_monoidal_category.mk_tensor CategoryTheory.FreeMonoidalCategory.mk'_tensor

@[simp]
theorem mk'_id {X : F C} : ⟦Hom.id X⟧ = 𝟙 X :=
  rfl
#align category_theory.free_monoidal_category.mk_id CategoryTheory.FreeMonoidalCategory.mk'_id

@[simp]
theorem mk'_α_hom {X Y Z : F C} : ⟦Hom.α_hom X Y Z⟧ = (α_ X Y Z).Hom :=
  rfl
#align category_theory.free_monoidal_category.mk_α_hom CategoryTheory.FreeMonoidalCategory.mk'_α_hom

@[simp]
theorem mk'_α_inv {X Y Z : F C} : ⟦Hom.α_inv X Y Z⟧ = (α_ X Y Z).inv :=
  rfl
#align category_theory.free_monoidal_category.mk_α_inv CategoryTheory.FreeMonoidalCategory.mk'_α_inv

@[simp]
theorem mk'_ρ_hom {X : F C} : ⟦Hom.ρ_hom X⟧ = (ρ_ X).Hom :=
  rfl
#align category_theory.free_monoidal_category.mk_ρ_hom CategoryTheory.FreeMonoidalCategory.mk'_ρ_hom

@[simp]
theorem mk'_ρ_inv {X : F C} : ⟦Hom.ρ_inv X⟧ = (ρ_ X).inv :=
  rfl
#align category_theory.free_monoidal_category.mk_ρ_inv CategoryTheory.FreeMonoidalCategory.mk'_ρ_inv

@[simp]
theorem mk'_l_hom {X : F C} : ⟦Hom.l_hom X⟧ = (λ_ X).Hom :=
  rfl
#align category_theory.free_monoidal_category.mk_l_hom CategoryTheory.FreeMonoidalCategory.mk'_l_hom

@[simp]
theorem mk'_l_inv {X : F C} : ⟦Hom.l_inv X⟧ = (λ_ X).inv :=
  rfl
#align category_theory.free_monoidal_category.mk_l_inv CategoryTheory.FreeMonoidalCategory.mk'_l_inv

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
@[simp]
theorem tensor_eq_tensor {X Y : F C} : X.tensor Y = X ⊗ Y :=
  rfl
#align category_theory.free_monoidal_category.tensor_eq_tensor CategoryTheory.FreeMonoidalCategory.tensor_eq_tensor

@[simp]
theorem unit_eq_unit : FreeMonoidalCategory.unit = 𝟙_ (F C) :=
  rfl
#align category_theory.free_monoidal_category.unit_eq_unit CategoryTheory.FreeMonoidalCategory.unit_eq_unit

section Functor

variable {D : Type u'} [Category.{v'} D] [MonoidalCategory D] (f : C → D)

/- warning: category_theory.free_monoidal_category.project_obj -> CategoryTheory.FreeMonoidalCategory.projectObj is a dubious translation:
lean 3 declaration is
  forall {C : Type.{u2}} {D : Type.{u3}} [_inst_1 : CategoryTheory.Category.{u1, u3} D] [_inst_2 : CategoryTheory.MonoidalCategory.{u1, u3} D _inst_1], (C -> D) -> (CategoryTheory.FreeMonoidalCategory.{u2} C) -> D
but is expected to have type
  forall {C : Type.{u1}} {D : Type.{u2}} [_inst_1 : CategoryTheory.Category.{u3, u2} D] [_inst_2 : CategoryTheory.MonoidalCategory.{u3, u2} D _inst_1], (C -> D) -> (CategoryTheory.FreeMonoidalCategory.{u1} C) -> D
Case conversion may be inaccurate. Consider using '#align category_theory.free_monoidal_category.project_obj CategoryTheory.FreeMonoidalCategory.projectObjₓ'. -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/-- Auxiliary definition for `free_monoidal_category.project`. -/
def projectObj : F C → D
  | free_monoidal_category.of X => f X
  | free_monoidal_category.unit => 𝟙_ D
  | free_monoidal_category.tensor X Y => project_obj X ⊗ project_obj Y
#align category_theory.free_monoidal_category.project_obj CategoryTheory.FreeMonoidalCategory.projectObj

section

open Hom

/- warning: category_theory.free_monoidal_category.project_map_aux -> CategoryTheory.FreeMonoidalCategory.projectMapAux is a dubious translation:
lean 3 declaration is
  forall {C : Type.{u2}} {D : Type.{u3}} [_inst_1 : CategoryTheory.Category.{u1, u3} D] [_inst_2 : CategoryTheory.MonoidalCategory.{u1, u3} D _inst_1] (f : C -> D) {X : CategoryTheory.FreeMonoidalCategory.{u2} C} {Y : CategoryTheory.FreeMonoidalCategory.{u2} C}, (CategoryTheory.FreeMonoidalCategory.Hom.{u2} C X Y) -> (Quiver.Hom.{succ u1, u3} D (CategoryTheory.CategoryStruct.toQuiver.{u1, u3} D (CategoryTheory.Category.toCategoryStruct.{u1, u3} D _inst_1)) (CategoryTheory.FreeMonoidalCategory.projectObj.{u1, u2, u3} C D _inst_1 _inst_2 f X) (CategoryTheory.FreeMonoidalCategory.projectObj.{u1, u2, u3} C D _inst_1 _inst_2 f Y))
but is expected to have type
  PUnit.{max (max (succ (succ u1)) (succ (succ u2))) (succ (succ u3))}
Case conversion may be inaccurate. Consider using '#align category_theory.free_monoidal_category.project_map_aux CategoryTheory.FreeMonoidalCategory.projectMapAuxₓ'. -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/-- Auxiliary definition for `free_monoidal_category.project`. -/
@[simp]
def projectMapAux : ∀ {X Y : F C}, (X ⟶ᵐ Y) → (projectObj f X ⟶ projectObj f Y)
  | _, _, id _ => 𝟙 _
  | _, _, α_hom _ _ _ => (α_ _ _ _).Hom
  | _, _, α_inv _ _ _ => (α_ _ _ _).inv
  | _, _, l_hom _ => (λ_ _).Hom
  | _, _, l_inv _ => (λ_ _).inv
  | _, _, ρ_hom _ => (ρ_ _).Hom
  | _, _, ρ_inv _ => (ρ_ _).inv
  | _, _, comp f g => project_map_aux f ≫ project_map_aux g
  | _, _, hom.tensor f g => project_map_aux f ⊗ project_map_aux g
#align category_theory.free_monoidal_category.project_map_aux CategoryTheory.FreeMonoidalCategory.projectMapAux

/-- Auxiliary definition for `free_monoidal_category.project`. -/
def projectMap (X Y : F C) : (X ⟶ Y) → (projectObj f X ⟶ projectObj f Y) :=
  Quotient.lift (projectMapAux f)
    (by
      intro f g h
      induction' h with
        X Y f X Y f g hfg hfg' X Y f g h _ _ hfg hgh X Y Z f f' g g' _ _ hf hg W X Y Z f g f' g' _ _ hfg hfg'
      · rfl
      · exact hfg'.symm
      · exact hfg.trans hgh
      · simp only [project_map_aux, hf, hg]
      · simp only [project_map_aux, hfg, hfg']
      · simp only [project_map_aux, category.comp_id]
      · simp only [project_map_aux, category.id_comp]
      · simp only [project_map_aux, category.assoc]
      · simp only [project_map_aux, monoidal_category.tensor_id]
        rfl
      · simp only [project_map_aux, monoidal_category.tensor_comp]
      · simp only [project_map_aux, iso.hom_inv_id]
      · simp only [project_map_aux, iso.inv_hom_id]
      · simp only [project_map_aux, monoidal_category.associator_naturality]
      · simp only [project_map_aux, iso.hom_inv_id]
      · simp only [project_map_aux, iso.inv_hom_id]
      · simp only [project_map_aux]
        dsimp [project_obj]
        exact monoidal_category.right_unitor_naturality _
      · simp only [project_map_aux, iso.hom_inv_id]
      · simp only [project_map_aux, iso.inv_hom_id]
      · simp only [project_map_aux]
        dsimp [project_obj]
        exact monoidal_category.left_unitor_naturality _
      · simp only [project_map_aux]
        exact monoidal_category.pentagon _ _ _ _
      · simp only [project_map_aux]
        exact monoidal_category.triangle _ _)
#align category_theory.free_monoidal_category.project_map CategoryTheory.FreeMonoidalCategory.projectMap

end

/-- If `D` is a monoidal category and we have a function `C → D`, then we have a functor from the
    free monoidal category over `C` to the category `D`. -/
def project : MonoidalFunctor (F C) D
    where
  obj := projectObj f
  map := projectMap f
  ε := 𝟙 _
  μ X Y := 𝟙 _
#align category_theory.free_monoidal_category.project CategoryTheory.FreeMonoidalCategory.project

end Functor

end

end FreeMonoidalCategory

end CategoryTheory


/-
Copyright (c) 2021 Chris Hughes. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Chris Hughes
-/
import linear_algebra.basic
import linear_algebra.prod
import linear_algebra.pi
import data.set_like.fintype
import linear_algebra.linear_independent
import tactic.linarith
import algebra.algebra.basic
import ring_theory.noetherian
import ring_theory.jacobson_ideal
import ring_theory.nilpotent
import ring_theory.nakayama

/-!
# Artinian rings and modules

A module satisfying these equivalent conditions is said to be an *Artinian* R-module
if every decreasing chain of submodules is eventually constant, or equivalently,
if the relation `<` on submodules is well founded.

A ring is an *Artinian ring* if it is Artinian as a module over itself.

(Note that we do not assume yet that our rings are commutative,
so perhaps this should be called "left Artinian".
To avoid cumbersome names once we specialize to the commutative case,
we don't make this explicit in the declaration names.)

## Main definitions

Let `R` be a ring and let `M` and `P` be `R`-modules. Let `N` be an `R`-submodule of `M`.

* `is_artinian R M` is the proposition that `M` is a Artinian `R`-module. It is a class,
  implemented as the predicate that the `<` relation on submodules is well founded.

## References

* [M. F. Atiyah and I. G. Macdonald, *Introduction to commutative algebra*][atiyah-macdonald]
* [samuel]

## Tags

Artinian, artinian, Artinian ring, Artinian module, artinian ring, artinian module

-/
open set
open_locale big_operators pointwise

/--
`is_artinian R M` is the proposition that `M` is an Artinian `R`-module,
implemented as the well-foundedness of submodule inclusion.
-/
class is_artinian (R M) [semiring R] [add_comm_monoid M] [module R M] : Prop :=
(well_founded_submodule_lt [] : well_founded ((<) : submodule R M → submodule R M → Prop))

section
variables {R : Type*} {M : Type*} {P : Type*} {N : Type*}
variables [ring R] [add_comm_group M] [add_comm_group P] [add_comm_group N]
variables [module R M] [module R P] [module R N]
open is_artinian
include R

theorem is_artinian_of_injective (f : M →ₗ[R] P) (h : function.injective f)
  [is_artinian R P] : is_artinian R M :=
⟨subrelation.wf
  (λ A B hAB, show A.map f < B.map f,
    from submodule.map_strict_mono_of_injective h hAB)
  (inv_image.wf (submodule.map f) (is_artinian.well_founded_submodule_lt R P))⟩

instance is_artinian_submodule' [is_artinian R M] (N : submodule R M) : is_artinian R N :=
is_artinian_of_injective N.subtype subtype.val_injective

lemma is_artinian_of_le {s t : submodule R M} [ht : is_artinian R t]
   (h : s ≤ t) : is_artinian R s :=
is_artinian_of_injective (submodule.of_le h) (submodule.of_le_injective h)

variable (M)
theorem is_artinian_of_surjective (f : M →ₗ[R] P) (hf : function.surjective f)
  [is_artinian R M] : is_artinian R P :=
⟨subrelation.wf
  (λ A B hAB, show A.comap f < B.comap f,
    from submodule.comap_strict_mono_of_surjective hf hAB)
  (inv_image.wf (submodule.comap f) (is_artinian.well_founded_submodule_lt _ _))⟩
variable {M}

theorem is_artinian_of_linear_equiv (f : M ≃ₗ[R] P)
  [is_artinian R M] : is_artinian R P :=
is_artinian_of_surjective _ f.to_linear_map f.to_equiv.surjective

theorem is_artinian_of_range_eq_ker
  [is_artinian R M] [is_artinian R P]
  (f : M →ₗ[R] N) (g : N →ₗ[R] P)
  (hf : function.injective f)
  (hg : function.surjective g)
  (h : f.range = g.ker) :
  is_artinian R N :=
⟨well_founded_lt_exact_sequence
  (is_artinian.well_founded_submodule_lt _ _)
  (is_artinian.well_founded_submodule_lt _ _)
  f.range
  (submodule.map f)
  (submodule.comap f)
  (submodule.comap g)
  (submodule.map g)
  (submodule.gci_map_comap hf)
  (submodule.gi_map_comap hg)
  (by simp [submodule.map_comap_eq, inf_comm])
  (by simp [submodule.comap_map_eq, h])⟩

instance is_artinian_prod [is_artinian R M]
  [is_artinian R P] : is_artinian R (M × P) :=
is_artinian_of_range_eq_ker
  (linear_map.inl R M P)
  (linear_map.snd R M P)
  linear_map.inl_injective
  linear_map.snd_surjective
  (linear_map.range_inl R M P)

@[instance, priority 100]
lemma is_artinian_of_fintype [fintype M] : is_artinian R M :=
⟨fintype.well_founded_of_trans_of_irrefl _⟩

local attribute [elab_as_eliminator] fintype.induction_empty_option

instance is_artinian_pi {R ι : Type*} [fintype ι] : Π {M : ι → Type*} [ring R]
  [Π i, add_comm_group (M i)], by exactI Π [Π i, module R (M i)],
  by exactI Π [∀ i, is_artinian R (M i)], is_artinian R (Π i, M i) :=
fintype.induction_empty_option
  (begin
    introsI α β e hα M _ _ _ _,
    exact is_artinian_of_linear_equiv
      (linear_equiv.Pi_congr_left R M e)
  end)
  (by { introsI M _ _ _ _, apply_instance })
  (begin
     introsI α _ ih M _ _ _ _,
     exact is_artinian_of_linear_equiv
        (linear_equiv.pi_option_equiv_prod R).symm,
  end)
  ι

/-- A version of `is_artinian_pi` for non-dependent functions. We need this instance because
sometimes Lean fails to apply the dependent version in non-dependent settings (e.g., it fails to
prove that `ι → ℝ` is finite dimensional over `ℝ`). -/
instance is_artinian_pi' {R ι M : Type*} [ring R] [add_comm_group M] [module R M] [fintype ι]
  [is_artinian R M] : is_artinian R (ι → M) :=
is_artinian_pi

end

open is_artinian submodule function

section
variables {R M : Type*} [ring R] [add_comm_group M] [module R M]

theorem is_artinian_iff_well_founded :
  is_artinian R M ↔ well_founded ((<) : submodule R M → submodule R M → Prop) :=
⟨λ h, h.1, is_artinian.mk⟩

variables {R M}

lemma is_artinian.finite_of_linear_independent [nontrivial R] [is_artinian R M]
  {s : set M} (hs : linear_independent R (coe : s → M)) : s.finite :=
begin
  refine classical.by_contradiction (λ hf, (rel_embedding.well_founded_iff_no_descending_seq.1
    (well_founded_submodule_lt R M)).elim' _),
  have f : ℕ ↪ s, from @infinite.nat_embedding s ⟨λ f, hf ⟨f⟩⟩,
  have : ∀ n, (coe ∘ f) '' {m | n ≤ m} ⊆ s,
  { rintros n x ⟨y, hy₁, hy₂⟩, subst hy₂, exact (f y).2 },
  have : ∀ a b : ℕ, a ≤ b ↔
    span R ((coe ∘ f) '' {m | b ≤ m}) ≤ span R ((coe ∘ f) '' {m | a ≤ m}),
  { assume a b,
    rw [span_le_span_iff hs (this b) (this a),
      set.image_subset_image_iff (subtype.coe_injective.comp f.injective),
      set.subset_def],
    simp only [set.mem_set_of_eq],
    exact ⟨λ hab x, le_trans hab, λ h, (h _ (le_refl _))⟩ },
  exact ⟨⟨λ n, span R ((coe ∘ f) '' {m | n ≤ m}),
      λ x y, by simp [le_antisymm_iff, (this _ _).symm] {contextual := tt}⟩,
    begin
      intros a b,
      conv_rhs { rw [gt, lt_iff_le_not_le, this, this, ← lt_iff_le_not_le] },
      simp
    end⟩
end

/-- A module is Artinian iff every nonempty set of submodules has a minimal submodule among them.
-/
theorem set_has_minimal_iff_artinian :
  (∀ a : set $ submodule R M, a.nonempty → ∃ M' ∈ a, ∀ I ∈ a, I ≤ M' → I = M') ↔
  is_artinian R M :=
by rw [is_artinian_iff_well_founded, well_founded.well_founded_iff_has_min']

theorem is_artinian.set_has_minimal [is_artinian R M] (a : set $ submodule R M) (ha : a.nonempty) :
  ∃ M' ∈ a, ∀ I ∈ a, I ≤ M' → I = M' :=
set_has_minimal_iff_artinian.mpr ‹_› a ha

/-- A module is Artinian iff every decreasing chain of submodules stabilizes. -/
theorem monotone_stabilizes_iff_artinian :
  (∀ (f : ℕ →ₘ order_dual (submodule R M)), ∃ n, ∀ m, n ≤ m → f n = f m)
    ↔ is_artinian R M :=
by rw [is_artinian_iff_well_founded];
  exact (well_founded.monotone_chain_condition (order_dual (submodule R M))).symm

theorem is_artinian.monotone_stabilizes [is_artinian R M] (f : ℕ →ₘ order_dual (submodule R M)) :
  ∃ n, ∀ m, n ≤ m → f n = f m :=
monotone_stabilizes_iff_artinian.mpr ‹_› f

/-- If `∀ I > J, P I` implies `P J`, then `P` holds for all submodules. -/
lemma is_artinian.induction [is_artinian R M] {P : submodule R M → Prop}
  (hgt : ∀ I, (∀ J < I, P J) → P I) (I : submodule R M) : P I :=
well_founded.recursion (well_founded_submodule_lt R M) I hgt

/--
For any endomorphism of a Artinian module, there is some nontrivial iterate
with disjoint kernel and range.
-/
theorem is_artinian.exists_endomorphism_iterate_ker_sup_range_eq_top
  [I : is_artinian R M] (f : M →ₗ[R] M) : ∃ n : ℕ, n ≠ 0 ∧ (f ^ n).ker ⊔ (f ^ n).range = ⊤ :=
begin
  obtain ⟨n, w⟩ := monotone_stabilizes_iff_artinian.mpr I
    (f.iterate_range.comp ⟨λ n, n+1, λ n m w, by linarith⟩),
  specialize w ((n + 1) + n) (by linarith),
  dsimp at w,
  refine ⟨n + 1, nat.succ_ne_zero _, _⟩,
  simp_rw [eq_top_iff', mem_sup],
  intro x,
  have : (f^(n + 1)) x ∈ (f ^ ((n + 1) + n + 1)).range,
  { rw ← w, exact mem_range_self _ },
  rcases this with ⟨y, hy⟩,
  use x - (f ^ (n+1)) y,
  split,
  { rw [linear_map.mem_ker, linear_map.map_sub, ← hy, sub_eq_zero, pow_add],
    simp [iterate_add_apply], },
  { use (f^ (n+1)) y,
    simp }
end

/-- Any injective endomorphism of an Artinian module is surjective. -/
theorem is_artinian.surjective_of_injective_endomorphism [is_artinian R M]
  (f : M →ₗ[R] M) (s : injective f) : surjective f :=
begin
  obtain ⟨n, ne, w⟩ := is_artinian.exists_endomorphism_iterate_ker_sup_range_eq_top f,
  rw [linear_map.ker_eq_bot.mpr (linear_map.iterate_injective s n), bot_sup_eq,
    linear_map.range_eq_top] at w,
  exact linear_map.surjective_of_iterate_surjective ne w,
end

/-- Any injective endomorphism of an Artinian module is bijective. -/
theorem is_artinian.bijective_of_injective_endomorphism [is_artinian R M]
  (f : M →ₗ[R] M) (s : injective f) : bijective f :=
⟨s, is_artinian.surjective_of_injective_endomorphism f s⟩

/--
A sequence `f` of submodules of a artinian module,
with the supremum `f (n+1)` and the infinum of `f 0`, ..., `f n` being ⊤,
is eventually ⊤.
-/
lemma is_artinian.disjoint_partial_infs_eventually_top [I : is_artinian R M]
  (f : ℕ → submodule R M) (h : ∀ n, disjoint
    (partial_sups (order_dual.to_dual ∘ f) n) (order_dual.to_dual (f (n+1)))) :
  ∃ n : ℕ, ∀ m, n ≤ m → f m = ⊤  :=
begin
  -- A little off-by-one cleanup first:
  suffices t : ∃ n : ℕ, ∀ m, n ≤ m → order_dual.to_dual f (m+1) = ⊤,
  { obtain ⟨n, w⟩ := t,
    use n+1,
    rintros (_|m) p,
    { cases p, },
    { apply w,
      exact nat.succ_le_succ_iff.mp p }, },

  obtain ⟨n, w⟩ := monotone_stabilizes_iff_artinian.mpr I (partial_sups (order_dual.to_dual ∘ f)),
  exact ⟨n, (λ m p, eq_bot_of_disjoint_absorbs (h m)
    ((eq.symm (w (m + 1) (le_add_right p))).trans (w m p)))⟩
end

universe w
variables {N : Type w} [add_comm_group N] [module R N]

-- TODO: Prove this for artinian modules
-- /--
-- If `M ⊕ N` embeds into `M`, for `M` noetherian over `R`, then `N` is trivial.
-- -/
-- noncomputable def is_noetherian.equiv_punit_of_prod_injective [is_noetherian R M]
--   (f : M × N →ₗ[R] M) (i : injective f) : N ≃ₗ[R] punit.{w+1} :=
-- begin
--   apply nonempty.some,
--   obtain ⟨n, w⟩ := is_noetherian.disjoint_partial_sups_eventually_bot (f.tailing i)
--     (f.tailings_disjoint_tailing i),
--   specialize w n (le_refl n),
--   apply nonempty.intro,
--   refine (f.tailing_linear_equiv i n).symm.trans _,
--   rw w,
--   exact submodule.bot_equiv_punit,
-- end

end

/--
A ring is Artinian if it is Artinian as a module over itself.
-/
class is_artinian_ring (R) [ring R] extends is_artinian R R : Prop

theorem is_artinian_ring_iff {R} [ring R] : is_artinian_ring R ↔ is_artinian R R :=
⟨λ h, h.1, @is_artinian_ring.mk _ _⟩

theorem ring.is_artinian_of_zero_eq_one {R} [ring R] (h01 : (0 : R) = 1) : is_artinian_ring R :=
by haveI := subsingleton_of_zero_eq_one h01;
   haveI := fintype.of_subsingleton (0:R); split;
  apply_instance

theorem is_artinian_of_submodule_of_artinian (R M) [ring R] [add_comm_group M] [module R M]
  (N : submodule R M) (h : is_artinian R M) : is_artinian R N :=
by apply_instance

theorem is_artinian_of_quotient_of_artinian (R) [ring R] (M) [add_comm_group M] [module R M]
  (N : submodule R M) (h : is_artinian R M) : is_artinian R (M ⧸ N) :=
is_artinian_of_surjective M (submodule.mkq N) (submodule.quotient.mk_surjective N)

/-- If `M / S / R` is a scalar tower, and `M / R` is Artinian, then `M / S` is
also Artinian. -/
theorem is_artinian_of_tower (R) {S M} [comm_ring R] [ring S]
  [add_comm_group M] [algebra R S] [module S M] [module R M] [is_scalar_tower R S M]
  (h : is_artinian R M) : is_artinian S M :=
begin
  rw is_artinian_iff_well_founded at h ⊢,
  refine (submodule.restrict_scalars_embedding R S M).well_founded h
end

theorem is_artinian_of_fg_of_artinian {R M} [ring R] [add_comm_group M] [module R M]
  (N : submodule R M) [is_artinian_ring R] (hN : N.fg) : is_artinian R N :=
let ⟨s, hs⟩ := hN in
begin
  haveI := classical.dec_eq M,
  haveI := classical.dec_eq R,
  letI : is_artinian R R := by apply_instance,
  have : ∀ x ∈ s, x ∈ N, from λ x hx, hs ▸ submodule.subset_span hx,
  refine @@is_artinian_of_surjective ((↑s : set M) → R) _ _ _ (pi.module _ _ _)
    _ _ _ is_artinian_pi,
  { fapply linear_map.mk,
    { exact λ f, ⟨∑ i in s.attach, f i • i.1, N.sum_mem (λ c _, N.smul_mem _ $ this _ c.2)⟩ },
    { intros f g, apply subtype.eq,
      change ∑ i in s.attach, (f i + g i) • _ = _,
      simp only [add_smul, finset.sum_add_distrib], refl },
    { intros c f, apply subtype.eq,
      change ∑ i in s.attach, (c • f i) • _ = _,
      simp only [smul_eq_mul, mul_smul],
      exact finset.smul_sum.symm } },
  rintro ⟨n, hn⟩, change n ∈ N at hn,
  rw [← hs, ← set.image_id ↑s, finsupp.mem_span_image_iff_total] at hn,
  rcases hn with ⟨l, hl1, hl2⟩,
  refine ⟨λ x, l x, subtype.ext _⟩,
  change ∑ i in s.attach, l i • (i : M) = n,
  rw [@finset.sum_attach M M s _ (λ i, l i • i), ← hl2,
      finsupp.total_apply, finsupp.sum, eq_comm],
  refine finset.sum_subset hl1 (λ x _ hx, _),
  rw [finsupp.not_mem_support_iff.1 hx, zero_smul]
end

lemma is_artinian_of_fg_of_artinian' {R M} [ring R] [add_comm_group M] [module R M]
  [is_artinian_ring R] (h : (⊤ : submodule R M).fg) : is_artinian R M :=
have is_artinian R (⊤ : submodule R M), from is_artinian_of_fg_of_artinian _ h,
by exactI is_artinian_of_linear_equiv (linear_equiv.of_top (⊤ : submodule R M) rfl)

/-- In a module over a artinian ring, the submodule generated by finitely many vectors is
artinian. -/
theorem is_artinian_span_of_finite (R) {M} [ring R] [add_comm_group M] [module R M]
  [is_artinian_ring R] {A : set M} (hA : finite A) : is_artinian R (submodule.span R A) :=
is_artinian_of_fg_of_artinian _ (submodule.fg_def.mpr ⟨A, hA, rfl⟩)

theorem is_artinian_ring_of_surjective (R) [comm_ring R] (S) [comm_ring S]
  (f : R →+* S) (hf : function.surjective f)
  [H : is_artinian_ring R] : is_artinian_ring S :=
begin
  rw [is_artinian_ring_iff, is_artinian_iff_well_founded] at H ⊢,
  exact order_embedding.well_founded (ideal.order_embedding_of_surjective f hf) H,
end

instance is_artinian_ring_range {R} [comm_ring R] {S} [comm_ring S] (f : R →+* S)
  [is_artinian_ring R] : is_artinian_ring f.range :=
is_artinian_ring_of_surjective R f.range f.range_restrict
  f.range_restrict_surjective

theorem is_artinian_ring_of_ring_equiv (R) [comm_ring R] {S} [comm_ring S]
  (f : R ≃+* S) [is_artinian_ring R] : is_artinian_ring S :=
is_artinian_ring_of_surjective R S f.to_ring_hom f.to_equiv.surjective

namespace is_artinian_ring

open is_artinian

variables {R : Type*} [comm_ring R] [is_artinian_ring R]

lemma is_nilpotent_jacobson_bot : is_nilpotent (ideal.jacobson (⊥ : ideal R)) :=
begin
  let Jac := ideal.jacobson (⊥ : ideal R),
  let f : ℕ →ₘ order_dual (ideal R) := ⟨λ n, Jac ^ n, λ _ _ h, ideal.pow_le_pow h⟩,
  obtain ⟨n, hn⟩ : ∃ n, ∀ m, n ≤ m → Jac ^ n = Jac ^ m := is_artinian.monotone_stabilizes f,
  refine ⟨n, _⟩,
  let J : ideal R := annihilator (Jac ^ n),
  suffices : J = ⊤,
  { have hJ : J • Jac ^ n = ⊥ := annihilator_smul (Jac ^ n),
    simpa only [this, top_smul, ideal.zero_eq_bot] using hJ },
  by_contradiction hJ, change J ≠ ⊤ at hJ,
  rcases is_artinian.set_has_minimal {J' : ideal R | J < J'} ⟨⊤, hJ.lt_top⟩
    with ⟨J', hJJ' : J < J', hJ' : ∀ I, J < I → I ≤ J' → I = J'⟩,
  rcases set_like.exists_of_lt hJJ' with ⟨x, hxJ', hxJ⟩,
  obtain rfl : J ⊔ ideal.span {x} = J',
  { refine hJ' (J ⊔ ideal.span {x}) _ _,
    { rw set_like.lt_iff_le_and_exists,
      exact ⟨le_sup_left, ⟨x, mem_sup_right (mem_span_singleton_self x), hxJ⟩⟩ },
    { exact (sup_le hJJ'.le (span_le.2 (singleton_subset_iff.2 hxJ'))) } },
  have : J ⊔ Jac • ideal.span {x} ≤ J ⊔ ideal.span {x},
    from sup_le_sup_left (smul_le.2 (λ _ _ _, submodule.smul_mem _ _)) _,
  have : Jac * ideal.span {x} ≤ J, --Need version 4 of Nakayamas lemma on Stacks
  { classical, by_contradiction H,
    refine H (smul_sup_le_of_le_smul_of_le_jacobson_bot
      (fg_span_singleton _) le_rfl (hJ' _ _ this).ge),
    exact lt_of_le_of_ne le_sup_left (λ h, H $ h.symm ▸ le_sup_right) },
  have : ideal.span {x} * Jac ^ (n + 1) ≤ ⊥,
    calc ideal.span {x} * Jac ^ (n + 1) = ideal.span {x} * Jac * Jac ^ n :
      by rw [pow_succ, ← mul_assoc]
    ... ≤ J * Jac ^ n : mul_le_mul (by rwa mul_comm) (le_refl _)
    ... = ⊥ : by simp [J],
  refine hxJ (mem_annihilator.2 (λ y hy, (mem_bot R).1 _)),
  refine this (mul_mem_mul (mem_span_singleton_self x) _),
  rwa [← hn (n + 1) (nat.le_succ _)]
end

end is_artinian_ring


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

/-!
# Preservation of zero objects and zero morphisms

We define the class `preserves_zero_morphisms` and show basic properties.

## Main results

We provide the following results:
* Left adjoints and right adjoints preserve zero morphisms;
* full functors preserve zero morphisms;
* if both categories involved have a zero object, then a functor preserves zero morphisms if and
  only if it preserves the zero object;
* functors which preserve initial or terminal objects preserve zero morphisms.

-/

universes v₁ v₂ u₁ u₂

noncomputable theory

open category_theory
open category_theory.limits

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

section zero_morphisms
variables [has_zero_morphisms C] [has_zero_morphisms D]

/-- A functor preserves zero morphisms if it sends zero morphisms to zero morphisms. -/
class preserves_zero_morphisms (F : C ⥤ D) : Prop :=
(map_zero' : ∀ (X Y : C), F.map (0 : X ⟶ Y) = 0 . obviously)

@[simp]
protected lemma map_zero (F : C ⥤ D) [preserves_zero_morphisms F] (X Y : C) :
  F.map (0 : X ⟶ Y) = 0 :=
preserves_zero_morphisms.map_zero' _ _

lemma zero_of_map_zero (F : C ⥤ D) [preserves_zero_morphisms F] [faithful F] {X Y : C}
  (f : X ⟶ Y) (h : F.map f = 0) : f = 0 :=
F.map_injective $ h.trans $ eq.symm $ F.map_zero _ _

lemma map_eq_zero_iff (F : C ⥤ D) [preserves_zero_morphisms F] [faithful F] {X Y : C} {f : X ⟶ Y} :
  F.map f = 0 ↔ f = 0 :=
⟨F.zero_of_map_zero _, by { rintro rfl, exact F.map_zero _ _ }⟩

@[priority 100]
instance preserves_zero_morphisms_of_is_left_adjoint (F : C ⥤ D) [is_left_adjoint F] :
  preserves_zero_morphisms F :=
{ map_zero' := λ X Y, let adj := adjunction.of_left_adjoint F in
  begin
    calc F.map (0 : X ⟶ Y) = F.map 0 ≫ F.map (adj.unit.app Y) ≫ adj.counit.app (F.obj Y) : _
    ... = F.map 0 ≫ F.map ((right_adjoint F).map (0 : F.obj X ⟶ _)) ≫ adj.counit.app (F.obj Y) : _
    ... = 0 : _,
    { rw adjunction.left_triangle_components, exact (category.comp_id _).symm },
    { simp only [← category.assoc, ← F.map_comp, zero_comp] },
    { simp only [adjunction.counit_naturality, comp_zero] }
  end }

@[priority 100]
instance preserves_zero_morphisms_of_is_right_adjoint (G : C ⥤ D) [is_right_adjoint G] :
  preserves_zero_morphisms G :=
{ map_zero' := λ X Y, let adj := adjunction.of_right_adjoint G in
  begin
    calc G.map (0 : X ⟶ Y) = adj.unit.app (G.obj X) ≫ G.map (adj.counit.app X) ≫ G.map 0 : _
    ... = adj.unit.app (G.obj X) ≫ G.map ((left_adjoint G).map (0 : _ ⟶ G.obj X)) ≫ G.map 0 : _
    ... = 0 : _,
    { rw adjunction.right_triangle_components_assoc },
    { simp only [← G.map_comp, comp_zero] },
    { simp only [adjunction.unit_naturality_assoc, zero_comp] }
  end }

@[priority 100]
instance preserves_zero_morphisms_of_full (F : C ⥤ D) [full F] : preserves_zero_morphisms F :=
{ map_zero' := λ X Y, calc
  F.map (0 : X ⟶ Y) = F.map (0 ≫ (F.preimage (0 : F.obj Y ⟶ F.obj Y))) : by rw zero_comp
                ... = 0 : by rw [F.map_comp, F.image_preimage, comp_zero] }

end zero_morphisms

section zero_object
variables [has_zero_object C] [has_zero_object D]

open_locale zero_object

variables [has_zero_morphisms C] [has_zero_morphisms D] (F : C ⥤ D)

/-- A functor that preserves zero morphisms also preserves the zero object. -/
@[simps] def map_zero_object [preserves_zero_morphisms F] : F.obj 0 ≅ 0 :=
{ hom := 0,
  inv := 0,
  hom_inv_id' := by rw [← F.map_id, id_zero, F.map_zero, zero_comp],
  inv_hom_id' := by rw [id_zero, comp_zero] }

variables {F}

lemma preserves_zero_morphisms_of_map_zero_object (i : F.obj 0 ≅ 0) : preserves_zero_morphisms F :=
{ map_zero' := λ X Y, calc
  F.map (0 : X ⟶ Y) = F.map (0 : X ⟶ 0) ≫ F.map 0 : by rw [← functor.map_comp, comp_zero]
                ... = F.map 0 ≫ (i.hom ≫ i.inv) ≫ F.map 0
                        : by rw [iso.hom_inv_id, category.id_comp]
                ... = 0 : by simp only [zero_of_to_zero i.hom, zero_comp, comp_zero] }

@[priority 100]
instance preserves_zero_morphisms_of_preserves_initial_object
  [preserves_colimit (functor.empty.{v₁} C) F] : preserves_zero_morphisms F :=
preserves_zero_morphisms_of_map_zero_object $ (F.map_iso has_zero_object.zero_iso_initial).trans $
  (preserves_initial.iso F).trans has_zero_object.zero_iso_initial.symm

@[priority 100]
instance preserves_zero_morphisms_of_preserves_terminal_object
  [preserves_limit (functor.empty.{v₁} C) F] : preserves_zero_morphisms F :=
preserves_zero_morphisms_of_map_zero_object $ (F.map_iso has_zero_object.zero_iso_terminal).trans $
    (preserves_terminal.iso F).trans has_zero_object.zero_iso_terminal.symm

end zero_object

end category_theory.functor