import data.finmap
import data.quot
import tactic.basic
import tactic.linarith

universes u v

namespace tactic.interactive
setup_tactic_parser
open tactic

meta def check_types : tactic unit :=
-- meta def check_types (pat : parse texpr) : tactic unit :=
-- do es ← tactic.match_target pat,
--    trace es
do `(%%x = %%y) ← target,
   trace!"{x} : {infer_type x}",
   trace!"{y} : {infer_type y}"

-- example : 1 = 2 :=
-- begin
--   -- check_types _ = _,
--   -- check_types λ (t : Type u) (x y : t), x = y,
-- end

end tactic.interactive

namespace sigma

lemma fst_comp_map {α α'} {β : α → Sort*} {β' : α' → Sort*}
  (f : α → α') (g : ∀ x, β x → β' (f x)) :
  fst ∘ map f g = f ∘ fst :=
by ext ⟨a,b⟩; refl

end sigma

@[reducible]
def finmap' (α : Type u) (β : Type v) := finmap (λ _ : α, β)

namespace finmap

variables {α : Type u}
  {β : α → Type v}
variables
  [decidable_eq α]
  [∀ x, decidable_eq $ β x]
  {m : finmap β}

lemma insert_eq_self_of_lookup_eq {x : α} {y : β x}
  (h : m.lookup x = some y) : m.insert x y = m :=
begin
  ext1 k, by_cases h' : k = x; [subst h', skip];
  simp [lookup_insert,*],
end

lemma insert_lookup_of_eq {x x' : α} {y : β x}
  (h : x = x') : (m.insert x y).lookup x' = some (h.rec y) :=
by subst h; rw lookup_insert

protected def map {γ : α → Type*} (f : ∀ x, β x → γ x) (m : finmap β) : finmap γ :=
-- list.to_finmap $ list.map _ $ m.to_list
{ entries := m.entries.map $ sigma.map id f,
  nodupkeys :=
  begin
    induction h : m.entries using quot.induction_on,
    simp only [multiset.coe_map, multiset.coe_nodupkeys, multiset.quot_mk_to_coe''],
    rw [list.nodupkeys,list.keys,list.map_map,sigma.fst_comp_map,function.comp.left_id],
    have := m.nodupkeys, simp [h,list.nodupkeys,list.nodup] at this,
    exact this,
  end }

lemma lookup_insert_eq_ite  {x x' : α} {y : β x} :
  lookup x' (insert x y m) =
  if h : x' = x then some (h.symm.rec y) else lookup x' m :=
by split_ifs; [subst h, skip]; simp *

lemma lookup_insert_eq_ite' {β} (m : finmap' α β) {x x' : α} {y : β} :
  lookup x' (insert x y m) =
  if x' = x then some y else lookup x' m :=
by split_ifs; [subst h, skip]; simp *

lemma map_lookup_insert_eq_ite {γ} {x x' : α} {y : β x} (f : ∀ a, β a → γ) :
  f _ <$> lookup x' (insert x y m) =
  if h : x' = x then some (f _ y) else f _ <$> lookup x' m :=
by split_ifs; [subst h, skip]; simp *

variables {γ : Type u} {F : Type u → Type v}
  [functor F] [is_lawful_functor F]
open function functor

lemma map_injective_of_injective
  [nonempty α] (f : α → γ)
  (h : injective f) :
  injective (map f : F α → F γ) :=
begin
  intros x y h₀,
  have h₂ := congr_arg (map (inv_fun f)) h₀,
  simp only [map_map,inv_fun_comp h,map_id,id] at h₂,
  exact h₂
end

end finmap

@[derive decidable_eq]
inductive bdd
| var : ℕ → bdd
| nand : bdd → bdd → bdd

abbreviation ptr := unsigned
open bdd

@[derive decidable_eq]
inductive bdd_impl (s : Type) : Type
| var (v : ℕ) : s → bdd_impl
| nand : bdd_impl → bdd_impl → s → bdd_impl

variables {s : Type}

inductive bdd_impl.subtree (t : bdd_impl s) : bdd_impl s → Prop
| refl : bdd_impl.subtree t
| step_left (p) (t₀ : bdd_impl s)
            (t₁ : bdd_impl s) :
  bdd_impl.subtree t₀ →
  bdd_impl.subtree (bdd_impl.nand t₀ t₁ p)
| step_right (p) (t₀ : bdd_impl s)
             (t₁ : bdd_impl s) :
  bdd_impl.subtree t₁ →
  bdd_impl.subtree (bdd_impl.nand t₀ t₁ p)

namespace bdd_impl.subtree
open bdd_impl
lemma trans {t₀ t₁ : bdd_impl s} (ha : subtree t₀ t₁) : Π {t₂}, subtree t₁ t₂ → subtree t₀ t₂
| _ (subtree.refl t₁) := ha
| _ (subtree.step_left  p ta₂ tb₂ ha₂) := subtree.step_left p _ _ (trans ha₂)
| _ (subtree.step_right p ta₂ tb₂ hb₂) := subtree.step_right p _ _ (trans hb₂)

lemma sizeof_le_sizeof_of_subtree {t₀ : bdd_impl s} : Π {t₁}, subtree t₀ t₁ → sizeof t₀ ≤ sizeof t₁
| _ (subtree.refl _) := le_refl _
| _ (subtree.step_left p ta tb h) :=
  le_trans (sizeof_le_sizeof_of_subtree h)
    (le_of_lt $ by well_founded_tactics.default_dec_tac)
| _ (subtree.step_right p ta tb h) :=
  le_trans (sizeof_le_sizeof_of_subtree h)
    (le_of_lt $ by well_founded_tactics.default_dec_tac)

lemma antisymm {t₀ t₁ : bdd_impl s} (ha : subtree t₀ t₁) (hb : subtree t₁ t₀) : t₀ = t₁ :=
begin
  induction ha generalizing hb,
  { refl },
  all_goals
  { specialize ha_ih (trans (subtree.step_left _ _ _ $ subtree.refl _) hb) <|>
      specialize ha_ih (trans (subtree.step_right _ _ _ $ subtree.refl _) hb),
    cases hb; clear hb,
    { refl },
    all_goals
    { replace ha_a := sizeof_le_sizeof_of_subtree ha_a,
      replace hb_a := sizeof_le_sizeof_of_subtree hb_a,
      simp [sizeof,has_sizeof.sizeof,bdd_impl.sizeof] at ha_a hb_a,
      have : 1 + bdd_impl.sizeof _ ha_t₀ ≤ bdd_impl.sizeof _ ha_t₀,
      { linarith },
      apply absurd this, simp } },
end

lemma subtree_of_subtree_of_to_spec_eq_to_spec {p₀ p₁} {ta tb : bdd_impl s}
  (h₂ : subtree (bdd_impl.nand ta tb p₀) (bdd_impl.nand ta tb p₁)) :
  p₀ = p₁ :=
begin
  generalize_hyp h : bdd_impl.nand p₀ ta tb = t at h₂,
  generalize_hyp h' : bdd_impl.nand p₁ ta tb = t' at h₂,
  induction t' generalizing p₀ ta tb t,
  { cases h', },
  cases h₂,
  { injection h', injection h, subst_vars },
  {
    specialize t'_ih_a _ _ h', },
  {  },
  induction h₂,
  { subst h', injection h, },
  { apply h₂_ih, },
  suffices : t = bdd_impl.nand p₁ ta tb,
  { subst t, injection this },
  let p := p₁,
  induction h₂,
  { refl },
  -- all_goals
  { specialize h₂_ih (trans (subtree.step_left _ _ _ $ subtree.refl _) _),
      -- specialize ha_ih (trans (subtree.step_right _ _ _ $ subtree.refl _) hb),
    cases hb; clear hb,
    { refl },
    all_goals
    { replace ha_a := sizeof_le_sizeof_of_subtree ha_a,
      replace hb_a := sizeof_le_sizeof_of_subtree hb_a,
      simp [sizeof,has_sizeof.sizeof,bdd_impl.sizeof] at ha_a hb_a,
      have : 1 + bdd_impl.sizeof ha_t₀ ≤ bdd_impl.sizeof ha_t₀,
      { linarith },
      apply absurd this, simp } },
 --  -- have h := h₂,
 --  suffices : subtree (bdd_impl.nand p₁ ta tb) (bdd_impl.nand p₀ ta' tb'),
 --  { subst_vars, have := bdd_impl.subtree.antisymm h₂ this,
 --    injection this },
 --  cases h₂,
 --  { exact h₂ },
 --  { subst ta', induction ta,
 --    { cases h₂_a },
 --    {
 --      -- generalize_hyp : (bdd_impl.nand p₀ (bdd_impl.nand ta_p ta_a ta_a_1) tb) at h₂_a,
 --      -- cases h₂_a,
 --      have := subtree.step_left _ _ _ h₂_a,
 --  } },
 --  -- clear h,
 --  { induction ta' generalizing ta tb p₀, cases h₂_a,

 --    -- generalize_hyp ha : bdd_impl.nand p₀ (bdd_impl.nand ta_p ta_a ta_a_1) tb = t at h₀_a,
 --    cases h₂_a,
 --    { exact ta'_ih_a rfl h₂ (bdd_impl.subtree.subtree_of_eq h₀.symm) },
 --    { subst ta, specialize ta'_ih_a _ h₂ h₂_a_a, },
 --    rw ← h₀ at h₂_a,

 -- },
 --  -- induction h₀,
end

lemma subtree_of_eq {t₀ t₁ : bdd_impl s} (h : t₀ = t₁) : t₀.subtree t₁ :=
h ▸ subtree.refl _
-- lemma ext {t₀ t₁ : bdd_impl} (h : ∀ x, subtree x t₀ ↔ subtree x t₁) : t₀ = t₁

end bdd_impl.subtree

def bdd_impl.ssubtree (t t' : bdd_impl s) : Prop :=
t.subtree t' ∧ t ≠ t'

namespace bdd_impl.ssubtree
open bdd_impl
lemma trans {t₀ t₁ t₂ : bdd_impl s} (ha : ssubtree t₀ t₁) (hb : ssubtree t₁ t₂) : ssubtree t₀ t₂ :=
have hc : subtree t₀ t₂, from ha.1.trans hb.1,
⟨ hc, λ h₁,
  have hc' : subtree t₂ t₀, from h₁ ▸ subtree.refl _,
  have ha' : subtree t₁ t₀, from hb.1.trans hc',
  ha.2 $ ha.1.antisymm ha' ⟩

lemma irrefl (t₀ : bdd_impl s) : ¬ ssubtree t₀ t₀ :=
λ h, h.2 rfl

lemma antisymm {t₀ t₁ : bdd_impl s} (ha : ssubtree t₀ t₁) (hb : ssubtree t₁ t₀) : false :=
ha.2 $ ha.1.antisymm hb.1

end bdd_impl.ssubtree

def trivial_impl : Π (d : bdd), bdd_impl ℕ
| (var v) := bdd_impl.var v 0
| (nand l r) := bdd_impl.nand (trivial_impl l) (trivial_impl r) 0

@[simp]
def ptr_addr : bdd_impl s → s
| (bdd_impl.var _ p) := p
| (bdd_impl.nand _ _ p) := p

@[simp]
def bdd_impl.to_spec : bdd_impl s → bdd
| (bdd_impl.var v _) := var v
| (bdd_impl.nand l r _) := nand (bdd_impl.to_spec l) (bdd_impl.to_spec r)

@[simp]
def bdd_impl.to_spec_trivial_impl (d : bdd) : (trivial_impl d).to_spec = d :=
begin
  induction d; simp [trivial_impl,bdd_impl.to_spec,*],
end

-- @[simp]
-- def bdd_impl.trivial_impl_to_spec (d : bdd_impl) : trivial_impl d.to_spec = d :=
-- begin
--   induction d; simp [trivial_impl,bdd_impl.to_spec,*],
-- end

-- #exit
def with_repr {α} (d : bdd) (f : Π {s} (d' : bdd_impl s), d'.to_spec = d → α)
  (h : ∀ s s' t t' h h', @f s t h = @f s' t' h') : α := f (trivial_impl d) (bdd_impl.to_spec_trivial_impl d)

structure bdd.package (p : Π {s}, bdd_impl s → Prop) :=
(val : bdd)
(repr : trunc (Σ' {s} (t : bdd_impl s), t.to_spec = val ∧ p t))
-- ← this `trunc` could have a special implementation

def bdd_impl' (s) (d : bdd) := { t : bdd_impl s // t.to_spec = d }

def max_sharing (t : bdd_impl s) : Prop :=
∀ {d} {t' : bdd_impl' s d} {t'' : bdd_impl' s d},
  t'.1.subtree t →
  t''.1.subtree t →
  t' = t''

structure nondup (s : Type) :=
(table : finmap' bdd (bdd_impl s))
(shared : ∀ (t : bdd_impl s) (t' : bdd_impl s),
  table.lookup t.to_spec = some t →
  t'.subtree t →
  table.lookup t'.to_spec = some t')
(consistent : ∀ {d t}, table.lookup d = some t → t.to_spec = d)

def intl_bdd (d : bdd) (tbl : nondup s) := { t : bdd_impl s // tbl.table.lookup d = some t }

namespace nondup

lemma intl_bdd_of_subtree {d : bdd} {tbl : nondup s} (it : intl_bdd d tbl) (t : bdd_impl s)
  (h : t.subtree it.val) : tbl.table.lookup t.to_spec = some t :=
begin
  apply tbl.shared _ _ _ h,
  convert it.2, apply tbl.consistent it.2,
end

variables (tbl : nondup s)

def mem (d : bdd) (tbl : nondup s) := d ∈ tbl.table

instance : has_mem bdd (nondup s) := ⟨ mem ⟩

def lookup (d : bdd) : option (intl_bdd d tbl) :=
match finmap.lookup d tbl.table, rfl : Π x, finmap.lookup d tbl.table = x → _ with
| none, h := none
| (some val), h := some ⟨val, h⟩
end

set_option pp.proofs true

lemma lookup_iff_map {d : bdd} (x : option (intl_bdd d tbl)) : lookup tbl d = x ↔ tbl.table.lookup d = subtype.val <$> x :=
begin
  rw [lookup],
  generalize : lookup._proof_1 tbl d = h, revert h,
  suffices : ∀ (y) (h : finmap.lookup d tbl.table = y),
    lookup._match_1 tbl d y h = x ↔ y = subtype.val <$> x,
    from this _,
  intros, cases y; rw lookup._match_1; cases x; simp,
  split; intros h; subst h; cases x, refl,
end

def bdd_impl'.var (v : ℕ) (p : s) : bdd_impl' s (var v) :=
⟨ bdd_impl.var v p, rfl ⟩

def bdd_impl'.nand {d d'} (t : bdd_impl' s d) (t' : bdd_impl' s d') (p : s) : bdd_impl' s (nand d d') :=
⟨ bdd_impl.nand t.val t'.val p, by simp [t.2,t'.2] ⟩

-- #check subtype.mk.inj_eq

lemma subtree_of_subtree_of_to_spec_eq_to_spec {p₀ p₁} {ta tb ta' tb' : bdd_impl s}
  (h₀ : ta = ta')
  (h₁ : tb = tb')
  (h₂ : subtree (bdd_impl.nand ta tb p₀) (bdd_impl.nand ta' tb' p₁)) :
  p₀ = p₁ :=
begin
  -- have h := h₂,
  suffices : subtree (bdd_impl.nand ta tb p₁) (bdd_impl.nand ta' tb' p₀),
  { subst_vars, have := bdd_impl.subtree.antisymm h₂ this,
    injection this },
  cases h₂,
  { exact h₂ },
  { subst ta', induction ta,
    { cases h₂_a },
    {
      -- generalize_hyp : (bdd_impl.nand p₀ (bdd_impl.nand ta_p ta_a ta_a_1) tb) at h₂_a,
      -- cases h₂_a,
      have := subtree.step_left _ _ _ h₂_a,
  } },
  -- clear h,
  { induction ta' generalizing ta tb p₀, cases h₂_a,

    -- generalize_hyp ha : bdd_impl.nand p₀ (bdd_impl.nand ta_p ta_a ta_a_1) tb = t at h₀_a,
    cases h₂_a,
    { exact ta'_ih_a rfl h₂ (bdd_impl.subtree.subtree_of_eq h₀.symm) },
    { subst ta, specialize ta'_ih_a _ h₂ h₂_a_a, },
    rw ← h₀ at h₂_a,

 },
  -- induction h₀,
end

lemma subtree_of_subtree_of_to_spec_eq_to_spec' {t₀ t₁ : bdd_impl s}
  (h₀ : subtree t₀ t₁)
  (h₁ : t₀.to_spec = t₁.to_spec) :
  t₀ = t₁ :=
begin
  induction t₁ generalizing t₀,
  { cases h₀, refl },
  { cases t₀, cases h₁,
    rw [bdd_impl.to_spec,bdd_impl.to_spec] at h₁,
    injection h₁, specialize t₁_ih_a _ h_1,
    specialize t₁_ih_a_1 _ h_2,
 }
end

-- lemma boo (t t' : bdd_impl s)
--     finmap.lookup (bdd_impl.to_spec t) (finmap.insert (bdd_impl.to_spec d) d tbl.table) = some t →
--     subtree t' t → finmap.lookup (bdd_impl.to_spec t') (finmap.insert (bdd_impl.to_spec d) d tbl.table) = some t'

lemma lookup_insert {s : Type}
  (tbl : nondup s)
  (d : bdd_impl s)
  (hd : ∀ (d' : bdd_impl s),
          subtree d' d →
          (d' ≠ d ↔
             finmap.lookup (bdd_impl.to_spec d') tbl.table = some d'))
  (t t' : bdd_impl s)
  (h₀ : finmap.lookup (bdd_impl.to_spec t)
            (tbl.table.insert (bdd_impl.to_spec d) d ) =
          some t)
  (h₁ : subtree t' t) :
  finmap.lookup (bdd_impl.to_spec t')
      (tbl.table.insert (bdd_impl.to_spec d) d) =
    some t' :=
begin
  classical,
  by_cases bdd_impl.to_spec d = bdd_impl.to_spec t,
  { rw [h,finmap.lookup_insert] at h₀,
    injection h₀, subst d, clear h h₀,
    have hd' := hd _ h₁,
    by_cases t' = t,
    { rw [h,finmap.lookup_insert] },
    { have h' := hd'.mp h,
      rwa [finmap.lookup_insert_eq_ite',if_neg],
      intro hh,
      -- specialize hd _ (subtree.refl _),
      replace hd := mt (hd t (subtree.refl _)).mpr (not_not_intro rfl),
      rw [← hh,h'] at hd,
      apply h,
      admit } },
  { have hd' := mt (hd d (subtree.refl _)).mpr (not_not_intro rfl),
    rw finmap.lookup_insert_of_ne at ⊢ h₀,
    apply tbl.shared _ _ h₀ h₁,
    { intro h, admit },
    { intro h, rw ← h at hd', }, }
end

lemma insert_consistent {s : Type} {d_1 : bdd}
  (tbl : nondup s)
  (d : bdd_impl s)
  (hd : ∀ (d' : bdd_impl s),
          subtree d' d →
          (d' ≠ d ↔
             finmap.lookup (bdd_impl.to_spec d') tbl.table = some d'))
  {t : bdd_impl s}
  (h₀ : finmap.lookup d_1 (tbl.table.insert (bdd_impl.to_spec d) d) = some t) :
  bdd_impl.to_spec t = d_1 :=
begin
  rw finmap.lookup_insert_eq_ite' at h₀, split_ifs at h₀,
  { cc },
  { exact tbl.consistent h₀, }
end

def insert (d : bdd_impl s) (p : s)
  -- (h : d.to_spec ∉ s.table )
  (hd : ∀ d', bdd_impl.subtree d' d → (d' ≠ d ↔ tbl.table.lookup d'.to_spec = some d')) : nondup s :=
⟨ tbl.table.insert d.to_spec d,
lookup_insert _ _ hd, λ _ _, insert_consistent tbl d hd ⟩

-- def insert_nand (d : bdd_impl s) (p : s)
--   -- (h : d.to_spec ∉ s.table )
--   (hd : ∀ d', bdd_impl.subtree d' d → (d' ≠ d ↔ tbl.table.lookup d'.to_spec = some d')) : nondup s :=

-- def insert' {v : ℕ} (p : s)
--   (h : var v ∉ tbl.table ) : nondup s :=
-- ⟨ tbl.table.insert (var v) (bdd_impl.var v p), _, _ ⟩

def insert_var {v : ℕ} (p : s)
  (h : var v ∉ tbl) : nondup s :=
⟨ tbl.table.insert (var v) (bdd_impl.var v p),
  begin
    introv ht hh,
    replace h : ∀ tt, ¬ tbl.table.lookup (var v) = some tt,
    { introv ht', apply h, change _ ∈ tbl.table,
      rw [finmap.mem_iff], exact ⟨_,ht'⟩ },
    rw finmap.lookup_insert_eq_ite', split_ifs with h₀,
    -- rw finmap.lookup_insert_eq_ite' at ht, split_ifs at ht,
    classical,
    by_cases h₁ : t = t',
    { rw [h₁,h₀,finmap.lookup_insert] at ht,
      injection ht, },
    { rw finmap.lookup_insert_eq_ite' at ht, split_ifs at ht,
      { admit },
      -- have h' := h (bdd_impl.var v p),
      { specialize h t', rw ← h₀ at h,
        have hh' := tbl.shared _ _ ht hh,
        exact absurd hh' h },
      { intro h₂, rw [h₂,finmap.lookup_insert] at ht, }},
    -- { rw finmap.lookup_insert_of_ne at ht,
    --   -- have h' := h (bdd_impl.var v p),
    --   { specialize h t', rw ← h₀ at h,
    --     have hh' := tbl.shared _ _ ht hh,
    --     exact absurd hh' h },
    --   { intro h₂, rw [h₂,finmap.lookup_insert] at ht, }},
  end, sorry ⟩

def insert_nand {d d' : bdd} (t : intl_bdd d tbl) (t' : intl_bdd d' tbl) (p : s)
  (h : nand d d' ∉ tbl) : nondup s :=
⟨ tbl.table.insert (nand d d') (bdd_impl.nand t.1 t'.1 p), _, _ ⟩

-- def insert {d d' : bdd} (t : intl_bdd d tbl) (t' : intl_bdd d' tbl) (p : ptr)
--   (h : nand d d' ∉ tbl.table ) : nondup s :=
-- ⟨ tbl.table.insert (nand d d') (bdd_impl.nand t.1 t'.1 p),
-- begin
--   intros d₀ t₀ d₁ t₁ h₀ h₁,
--   rw finmap.lookup_insert_eq_ite at h₀, split_ifs at h₀ with h',
--   { subst h', dsimp [] at h₀,
--     cases h₀, cases t₁, dsimp at h₁,
--     cases h₁,
--     { have : d₁ = (nand d d'),
--       { rw [← t₁_property,bdd_impl.to_spec,t.val.property,t'.val.property], },
--       subst this, rw [finmap.lookup_insert], refl },
--     { have : d₁ ≠ (nand d d'),
--       { intro h', subst h', apply h, -- rw ← t₁_property,
--         rw finmap.mem_iff, split,
--         apply s.inv t.val ⟨t₁_val,t₁_property⟩ t.property h₁_a, },
--       rw [finmap.lookup_insert_of_ne _ this],
--       apply s.inv t.val ⟨t₁_val,t₁_property⟩ t.property h₁_a },
--     { have : d₁ ≠ (nand d d'),
--       { intro h', subst h', apply h, -- rw ← t₁_property,
--         rw finmap.mem_iff, split,
--         apply s.inv t'.val ⟨t₁_val,t₁_property⟩ t'.property h₁_a, },
--       rw [finmap.lookup_insert_of_ne _ this],
--       apply s.inv t'.val ⟨t₁_val,t₁_property⟩ t'.property h₁_a } },
--   { have := s.inv t₀ t₁ h₀ h₁,
--     rwa finmap.lookup_insert_of_ne,
--     intro h₂, apply h, rw ← h₂, simp [finmap.mem_iff],
--     exact ⟨_,this⟩ }
-- end ⟩

-- def insert_nand_others {d d'} (t : bdd_impl' d) (p : s) (h) (d₂)
--   (x : intl_bdd d₂ tbl) : intl_bdd d₂ (tbl.insert t p h) :=
-- ⟨ x.1, begin
--          dsimp [insert]; rw [finmap.lookup_insert_of_ne],
--          { apply x.property },
--          { intro h', rw ← h' at h, apply h,
--            rw finmap.mem_iff, exact ⟨_,x.2⟩ }
--        end  ⟩

def intl_var {d d'} (t : intl_bdd d s) (t' : intl_bdd d' s) (p : ptr) (h) :
  intl_bdd (nand d d') (s.insert t t' p h) :=

def intl_nand {d d'} (t : intl_bdd d s) (t' : intl_bdd d' s) (p : ptr) (h) :
  intl_bdd (nand d d') (s.insert t t' p h) :=
⟨ bdd_impl'.nand t.1 t'.1 p, by rw [insert,finmap.lookup_insert] ⟩

def M (s d) :=
Σ' (s' : nondup) (x : intl_bdd d s'), ∀ d', intl_bdd d' s → intl_bdd d' s'

def id' {s} : ∀ d', intl_bdd d' s → intl_bdd d' s := λ _, id

def M.pure {d} (x : intl_bdd d s) : M s d :=
⟨s, x, id'⟩

section
variable {s}

def M.bind {d d'} (x : M s d) (f : ∀ s', intl_bdd d s' → (∀ d, intl_bdd d s → intl_bdd d s') → M s' d') : M s d' :=
match x with
| ⟨s',b,g⟩ :=
  match f s' b g with
  | ⟨s'',c,h⟩ := ⟨s'',c,λ _, h _ ∘ g _⟩
  end
end
-- #exit
theorem M.pure_bind {d} (x : intl_bdd d s)
  (f : ∀ s', intl_bdd d s' → (∀ d, intl_bdd d s → intl_bdd d s') → M s' d) :
  M.bind (M.pure s x) f = f _ x (λ _, id) :=
begin
  rw [M.pure,M.bind,M.bind._match_1],
  rcases f s x id' with ⟨a,b,c⟩, refl
end

theorem M.bind_pure {d} (x : M s d) :
  M.bind x (λ s' a f, M.pure _ a) = x :=
begin
  rcases x with ⟨a,b,c⟩, refl,
end

theorem M.bind_bind {d d' d''} (x : M s d)
  (f : ∀ s', intl_bdd d s' → (∀ d, intl_bdd d s → intl_bdd d s') → M s' d')
  (g : ∀ s', intl_bdd d' s' → (∀ d, intl_bdd d s → intl_bdd d s') → M s' d'') :
  M.bind (M.bind x f) g = M.bind x (λ s' a h, M.bind (f s' a h) (λ s'' b h', g _ b (λ _, h' _ ∘ h _))) :=
begin
  rcases x with ⟨a,b,c⟩,
  simp [M.bind,M.bind._match_1],
  rcases (f a b c) with ⟨a₁,b₁,c₁⟩,
  simp [M.bind,M.bind._match_1],
  rcases (g a₁ b₁ (λ _, c₁ _ ∘ c _)) with ⟨a₂,b₂,c₂⟩,
  refl
end

end

def mk_var (p : ptr) (v : ℕ) : M s (var v) :=
match lookup s (var v), rfl : ∀ x, lookup s (var v) = x → _ with
| none, h := _
| (some val), h := ⟨s,val,λ _, id⟩
end

def mk_nand (p : ptr) : Π {d}, intl_bdd d s → Π {d'}, intl_bdd d' s → M s (nand d d')
| d t d' t' :=
  match lookup s (nand d d'), rfl : ∀ x, lookup s (nand d d') = x → _ with
  | none, h :=
    have nand d d' ∉ s.table, by { simp [lookup_iff_map] at h, simp [finmap.mem_iff,h], },
    ⟨_, insert_nand s t t' p this, insert_nand_others _ _ _ _ _⟩
  | (some val), h := ⟨_,val,λ _, id⟩
  end

def mk_nand' (p : ptr) {d d'} (t : intl_bdd d s) (t' : intl_bdd d' s) : M s (nand d d') :=
mk_nand s p t t'

end nondup
open nondup

def share_common : Π (d : bdd_impl) (s : nondup), M s d.to_spec
| (bdd_impl.var p v) s := ⟨_, _⟩
| (bdd_impl.nand p l r) s :=
M.bind (share_common l s) $ λ s' l' f₀,
M.bind (share_common r s') $ λ s'' r' f₁,
nondup.mk_nand' s'' p (f₁ _ l') r'


/-
Copyright (c) 2022 Yaël Dillies. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yaël Dillies
-/
import order.category.BoundedLattice
import order.hom.complete_lattice

/-!
# The category of complete lattices

This file defines `CompleteLattice`, the category of complete lattices.
-/

universes u

open category_theory

/-- The category of complete lattices. -/
def CompleteLattice := bundled complete_lattice

namespace CompleteLattice

instance : has_coe_to_sort CompleteLattice Type* := bundled.has_coe_to_sort
instance (X : CompleteLattice) : complete_lattice X := X.str

/-- Construct a bundled `CompleteLattice` from a `complete_lattice`. -/
def of (α : Type*) [complete_lattice α] : CompleteLattice := bundled.of α

@[simp] lemma coe_of (α : Type*) [complete_lattice α] : ↥(of α) = α := rfl

instance : inhabited CompleteLattice := ⟨of punit⟩

instance : bundled_hom @complete_lattice_hom :=
{ to_fun := λ _ _ _ _, coe_fn,
  id := @complete_lattice_hom.id,
  comp := @complete_lattice_hom.comp,
  hom_ext := λ X Y _ _, by exactI fun_like.coe_injective }
instance : large_category.{u} CompleteLattice := bundled_hom.category complete_lattice_hom
instance : concrete_category CompleteLattice := bundled_hom.concrete_category complete_lattice_hom

instance has_forget_to_BoundedLattice : has_forget₂ CompleteLattice BoundedLattice :=
{ forget₂ := { obj := λ X, BoundedLattice.of X,
               map := λ X Y, complete_lattice_hom.to_bounded_lattice_hom },
  forget_comp := rfl }

/-- Constructs an isomorphism of complete lattices from an order isomorphism between them. -/
@[simps] def iso.mk {α β : CompleteLattice.{u}} (e : α ≃o β) : α ≅ β :=
{ hom := e,
  inv := e.symm,
  hom_inv_id' := by { ext, exact e.symm_apply_apply _ },
  inv_hom_id' := by { ext, exact e.apply_symm_apply _ } }

/-- `order_dual` as a functor. -/
@[simps] def dual : CompleteLattice ⥤ CompleteLattice :=
{ obj := λ X, of (order_dual X), map := λ X Y, complete_lattice_hom.dual }

/-- The equivalence between `CompleteLattice` and itself induced by `order_dual` both ways. -/
@[simps functor inverse] def dual_equiv : CompleteLattice ≌ CompleteLattice :=
equivalence.mk dual dual
  (nat_iso.of_components (λ X, iso.mk $ order_iso.dual_dual X) $ λ X Y f, rfl)
  (nat_iso.of_components (λ X, iso.mk $ order_iso.dual_dual X) $ λ X Y f, rfl)

end CompleteLattice

lemma CompleteLattice_dual_comp_forget_to_BoundedLattice :
  CompleteLattice.dual ⋙ forget₂ CompleteLattice BoundedLattice =
    forget₂ CompleteLattice BoundedLattice ⋙ BoundedLattice.dual := rfl


import category_theory.preadditive
import category_theory.abelian.exact
import algebra.homology.exact
import category_theory.limits.preserves.shapes.terminal
import category_theory.limits.shapes.zero_morphisms

namespace category_theory
namespace limits

open category_theory.limits

variables {C : Type*} [category C] [has_zero_morphisms C]

open_locale zero_object

lemma is_zero_iff_id_eq_zero {X : C} : is_zero X ↔ 𝟙 X = 0 :=
begin
  split,
  { exact λ h, h.eq_of_src _ _, },
  { intro e, split; intro Y; use 0; intro f,
    { rw [← cancel_epi (𝟙 _), e, comp_zero, zero_comp], apply_instance },
    { rw [← cancel_mono (𝟙 _), e, comp_zero, zero_comp], apply_instance }, }
end

lemma is_zero_of_mono {X Y : C} (f : X ⟶ Y) [mono f] (h : is_zero Y) : is_zero X :=
by rw [is_zero_iff_id_eq_zero, ← cancel_mono f, zero_comp, h.eq_of_tgt (𝟙 _ ≫ f)]

lemma is_zero_of_epi {X Y : C} (f : X ⟶ Y) [epi f] (h : is_zero X) : is_zero Y :=
by rw [is_zero_iff_id_eq_zero, ← cancel_epi f, comp_zero, h.eq_of_src (f ≫ 𝟙 Y)]

lemma is_zero_of_top_le_bot [has_zero_object C] (X : C)
  (h : (⊤ : subobject X) ≤ ⊥) : is_zero X :=
{ unique_to := λ Y,
  begin
    use 0, intro f,
    rw [← cancel_epi ((⊤ : subobject X).arrow), ← subobject.of_le_arrow h],
    simp only [subobject.bot_arrow, comp_zero, zero_comp],
  end,
  unique_from := λ Y,
  begin
    use 0, intro f,
    rw ← subobject.bot_factors_iff_zero,
    exact subobject.factors_of_le f h (subobject.top_factors f),
  end }

-- inline this
lemma is_zero_of_iso_of_zero {C : Type*} [category C] [has_zero_morphisms C]
  {X : C} (hX : is_zero X) {Y : C} (h : X ≅ Y) : is_zero Y :=
hX.of_iso h.symm

lemma is_zero_of_exact_zero_zero {C : Type*} [category C] [abelian C]
  {X Y Z : C} (h : exact (0 : X ⟶ Y) (0 : Y ⟶ Z)) : is_zero Y :=
is_zero_of_top_le_bot _
begin
  rw abelian.exact_iff_image_eq_kernel at h,
  rw [← @kernel_subobject_zero _ _ _ Y Z, ← @image_subobject_zero _ _ _ _ X Y, h],
end

lemma exact_of_is_zero {C : Type*} [category C] [abelian C]
  {X Y Z : C} (hY : is_zero Y) (f : X ⟶ Y) (g : Y ⟶ Z) : exact f g :=
by simp only [abelian.exact_iff, is_zero.eq_zero_of_tgt hY f,
  is_zero.eq_zero_of_tgt hY (kernel.ι g), zero_comp, eq_self_iff_true, and_self]

lemma is_zero_iff_exact_zero_zero {C : Type*} [category C] [abelian C]
  {X Y Z : C} : is_zero Y ↔ exact (0 : X ⟶ Y) (0 : Y ⟶ Z) :=
⟨λ h, exact_of_is_zero h 0 0, is_zero_of_exact_zero_zero⟩

lemma is_zero_of_exact_zero_zero' {C : Type*} [category C] [abelian C]
  {X Y Z : C} (f : X ⟶ Y) (g : Y ⟶ Z) (h : exact f g) (hf : f = 0) (hg : g = 0) : is_zero Y :=
by { rw [hf, hg] at h, exact is_zero_of_exact_zero_zero h }

lemma is_zero_of_exact_is_zero_is_zero {C : Type*} [category C] [abelian C] {X Y Z : C}
  (f : X ⟶ Y) (g : Y ⟶ Z) (h : exact f g) (hX : is_zero X) (hZ : is_zero Z) : is_zero Y :=
is_zero_of_exact_zero_zero' f g h (hX.eq_of_src f _) (hZ.eq_of_tgt g _)

lemma is_zero_cokernel_of_epi {C : Type*} [category C] [abelian C] {X Y : C}
  (f : X ⟶ Y) [epi f] : is_zero (cokernel f) :=
begin
  have h1 : cokernel.π f = 0, by rwa ← abelian.epi_iff_cokernel_π_eq_zero,
  have h2 : exact (cokernel.π f) 0 := category_theory.exact_epi_zero (cokernel.π f),
  exact is_zero_of_exact_zero_zero' (cokernel.π f) 0 h2 h1 rfl,
end

lemma epi_iff_is_zero_cokernel {C : Type*} [category C] [abelian C] {X Y : C}
  (f : X ⟶ Y) : epi f ↔ is_zero (cokernel f) :=
begin
  split,
  { introsI, apply is_zero_cokernel_of_epi },
  { intros h,
    rw abelian.epi_iff_cokernel_π_eq_zero,
    apply h.eq_of_tgt }
end

lemma is_zero_kernel_of_mono {C : Type*} [category C] [abelian C] {X Y : C}
  (f : X ⟶ Y) [mono f] : is_zero (kernel f) :=
begin
  have h1 : kernel.ι f = 0, by rwa ← abelian.mono_iff_kernel_ι_eq_zero,
  have h2 : exact 0 (kernel.ι f) := category_theory.exact_zero_mono (kernel.ι f),
  exact is_zero_of_exact_zero_zero' 0 (kernel.ι f) h2 rfl h1
end

lemma mono_iff_is_zero_kernel {C : Type*} [category C] [abelian C] {X Y : C}
  (f : X ⟶ Y) : mono f ↔ is_zero (kernel f) :=
begin
  split,
  { introsI, apply is_zero_kernel_of_mono },
  { intros h,
    rw abelian.mono_iff_kernel_ι_eq_zero,
    apply h.eq_of_src }
end

noncomputable def image_iso_of_eq [category C] [abelian C] {A B : C} {f f' : A ⟶ B} (h : f = f') : image f ≅ image f' :=
eq_to_iso (by rw h)

noncomputable def image.is_iso_comp {𝓐 : Type*} [category 𝓐] [abelian 𝓐] {A B C : 𝓐} {f : A ⟶ B} [is_iso f] (g : B ⟶ C) : image (f ≫ g) ≅ image g :=
{ hom := image.lift (({ I := _,
  m := image.ι _,
  m_mono := infer_instance,
  e := f ≫ factor_thru_image g,
  fac' := by simp only [category.assoc, image.fac]} : mono_factorisation _)),
  inv := image.lift (({ I := _,
  m := image.ι _,
  m_mono := infer_instance,
  e := (inv f) ≫ factor_thru_image (f ≫ g),
  fac' := by simp only [category.assoc, image.fac, is_iso.inv_hom_id_assoc]} : mono_factorisation _)) }

lemma is_iso_of_is_zero_of_is_zero {𝓐 : Type*} [category 𝓐] [abelian 𝓐] {a b : 𝓐} (ha : is_zero a) (hb : is_zero b)
  (f : a ⟶ b) : is_iso f :=
begin
  rw is_zero.eq_zero_of_src ha f,
  apply (is_iso_zero_equiv a b).symm.to_fun,
  exact ⟨is_zero.eq_of_src ha (𝟙 a) 0, is_zero.eq_of_src hb (𝟙 b) 0⟩,
end

lemma obj_is_zero_of_iso {𝓐 : Type*} [category 𝓐] [abelian 𝓐] {𝓑 : Type*} [category 𝓑] [abelian 𝓑] {F G : 𝓐 ⥤ 𝓑}
  (h : F ≅ G) {a : 𝓐} (ha : is_zero (F.obj a)) : is_zero (G.obj a) :=
is_zero_of_iso_of_zero ha (h.app a)

lemma map_is_iso_of_iso_of_map_is_iso {𝓐 : Type*} [category 𝓐] [abelian 𝓐] {𝓑 : Type*} [category 𝓑] [abelian 𝓑] {F G : 𝓐 ⥤ 𝓑}
  (h : F ≅ G) {a₁ a₂ : 𝓐} (f : a₁ ⟶ a₂) (ha : is_iso (F.map f)) : is_iso (G.map f) :=
begin
  rw ← nat_iso.naturality_1 h,
  exact is_iso.comp_is_iso,
end

@[simp] lemma epi_comp_iso_iff_epi {V : Type*} [category V] {A B C : V} (e : A ≅ B) (f : B ⟶ C) :
  epi (e.hom ≫ f) ↔ epi f :=
begin
  split,
  { rintro ⟨h⟩,
    constructor,
    intros Z s t h2,
    apply h,
    simp [h2], },
  { rintro ⟨h⟩,
    constructor,
    intros Z s t h2,
    apply h,
    simpa using h2,
  },
end

@[simp] lemma epi_iso_comp_iff_epi {V : Type*} [category V] {A B C : V} (f : A ⟶ B) (e : B ≅ C) :
  epi (f ≫ e.hom) ↔ epi f :=
begin
  split,
  { introI h,
    constructor,
    intros Z s t h2,
    suffices : e.inv ≫ s = e.inv ≫ t,
      simpa,
    rw ← cancel_epi (f ≫ e.hom),
    simpa using h2, },
  { introI h,
    constructor,
    intros Z s t h2,
    simp only [category.assoc] at h2,
    rw cancel_epi at h2,
    rwa cancel_epi at h2, },
end

lemma is_iso_iff_is_iso_comp_left {V : Type*} [category V] {A B C : V} (f : A ⟶ B) {e : B ⟶ C}
  [is_iso f] : is_iso (f ≫ e) ↔ is_iso e :=
begin
  split,
  { introI h, exact is_iso.of_is_iso_comp_left f e },
  { introI h, exact is_iso.comp_is_iso },
end

lemma is_iso_iff_is_iso_comp_right {V : Type*} [category V] {A B C : V} {f : A ⟶ B} (g : B ⟶ C)
  [is_iso g] : is_iso (f ≫ g) ↔ is_iso f :=
begin
  split,
  { introI, exact is_iso.of_is_iso_comp_right f g},
  { introI h, exact is_iso_of_op (f ≫ g), },
end

@[simp] lemma epi_comp_is_iso_iff_epi {V : Type*} [category V] {A B C : V} (e : A ⟶ B) (f : B ⟶ C)
  [is_iso e] : epi (e ≫ f) ↔ epi f :=
epi_comp_iso_iff_epi (as_iso e) f

@[simp] lemma epi_is_iso_comp_iff_epi {V : Type*} [category V] {A B C : V} (f : A ⟶ B) (e : B ⟶ C)
  [is_iso e] : epi (f ≫ e) ↔ epi f :=
epi_iso_comp_iff_epi f (as_iso e)

lemma zero_of_epi_comp_zero {V : Type*} [category V] [abelian V]
  {A B C : V} {f : A ⟶ B} {g : B ⟶ C} (w : f ≫ g = 0) [epi f] : g = 0 :=
(preadditive.epi_iff_cancel_zero f).mp infer_instance C g w

@[simp] lemma comp_mono_zero_iff {V : Type*} [category V] [abelian V]
  {A B C : V} {f : A ⟶ B} {g : B ⟶ C} [mono g] : f ≫ g = 0 ↔ f = 0 :=
⟨(preadditive.mono_iff_cancel_zero g).1 infer_instance A f, λ f, f.symm ▸ zero_comp⟩

lemma epi_of_epi_of_comp_epi_of_mono {V : Type*} [category V] [abelian V]
  {A B C : V} (f : A ⟶ B) (g : B ⟶ C) [epi (f ≫ g)] [mono g] : epi f :=
begin
  haveI foo : is_iso g,
  { rw is_iso_iff_mono_and_epi,
    refine ⟨infer_instance, _⟩,
    apply epi_of_epi f,
  },
  simp * at *,
end

lemma is_zero_initial {C : Type*} [category C] [abelian C] : is_zero (⊥_ C) :=
is_zero_of_iso_of_zero (is_zero_zero _) $
{ hom := 0,
  inv := 0 }

lemma is_zero_terminal {C : Type*} [category C] [abelian C] : is_zero (⊤_ C) :=
is_zero_of_iso_of_zero (is_zero_zero _) $
{ hom := 0,
  inv := 0 }

universes v u₁ u₂

class preserves_zero_objects {C D : Type*} [category C] [has_zero_morphisms C]
  [category D] [has_zero_morphisms D] (F : C ⥤ D) : Prop :=
(preserves : ∀ (X : C), is_zero X → is_zero (F.obj X))

instance preserves_zero_of_preserves_initial {C : Type u₁} {D : Type u₂}
  [category.{v} C] [abelian C] [category.{v} D] [abelian D] (F : C ⥤ D)
  [preserves_colimit (functor.empty C) F] :
  preserves_zero_objects F := preserves_zero_objects.mk $ λ X hX,
begin
  have e : X ≅ ⊥_ _ := hX.iso is_zero_initial,
  replace e : F.obj X ≅ F.obj ⊥_ _ := F.map_iso e,
  apply is_zero_of_iso_of_zero _ e.symm,
  have : F.obj ⊥_ _ ≅ ⊥_ _,
  { apply_with limits.preserves_initial.iso { instances := ff }, assumption },
  apply is_zero_of_iso_of_zero _ this.symm,
  exact is_zero_initial,
end

-- sanity check
example {C : Type u₁} {D : Type u₂}
  [category.{v} C] [abelian C] [category.{v} D] [abelian D] (F : C ⥤ D)
  [preserves_colimits F] : preserves_zero_objects F := infer_instance

instance preserves_zero_of_preserves_terminal {C : Type u₁} {D : Type u₂}
  [category.{v} C] [abelian C] [category.{v} D] [abelian D] (F : C ⥤ D)
  [preserves_limit (functor.empty C) F] :
  preserves_zero_objects F := preserves_zero_objects.mk $ λ X hX,
begin
  have e : X ≅ ⊤_ _ := hX.iso is_zero_terminal,
  replace e : F.obj X ≅ F.obj ⊤_ _ := F.map_iso e,
  apply is_zero_of_iso_of_zero _ e.symm,
  have : F.obj ⊤_ _ ≅ ⊤_ _,
  { apply_with limits.preserves_terminal.iso { instances := ff }, assumption },
  apply is_zero_of_iso_of_zero _ this.symm,
  exact is_zero_terminal,
end

-- sanity check
example {C : Type u₁} {D : Type u₂}
  [category.{v} C] [abelian C] [category.{v} D] [abelian D] (F : C ⥤ D)
  [preserves_limits F] : preserves_zero_objects F := infer_instance

lemma is_zero_of_preserves {C D : Type*} [category C] [has_zero_morphisms C]
  [category D] [has_zero_morphisms D] {X : C} (F : C ⥤ D)
  [preserves_zero_objects F] (e : is_zero X) : is_zero (F.obj X) :=
preserves_zero_objects.preserves _ e

lemma is_zero_biprod {C : Type u₁} [category.{v} C] [abelian C] (X Y : C)
  (hX : is_zero X) (hY : is_zero Y) : is_zero (biprod X Y) :=
begin
  constructor,
  { intro W, use 0, intro f, ext, simp, apply hX.eq_of_src, simp, apply hY.eq_of_src },
  { intro W, use 0, intro f, ext, simp, apply hX.eq_of_tgt, simp, apply hY.eq_of_tgt }
end

end limits

end category_theory


import data.real.irrational
import topology.basic
import algebra.order.floor

--OUTPUT 1
theorem irrational_orbit_dense {α : ℝ} (hα_irrat : irrational α) : closure ((λ m : ℤ, int.fract (α * ↑m)) '' (@set.univ ℤ)) = set.Icc 0 1 :=
begin
  have h1 : ∀ i j : ℤ, i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j),
  from by auto [int.fract_eq_iff, hα_irrat, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff
end --Needs more than 2000 tokens!

--OUTPUT 2
theorem irrational_orbit_dense {α : ℝ} (hα_irrat : irrational α) : closure ((λ m : ℤ, int.fract (α * ↑m)) '' (@set.univ ℤ)) = set.Icc 0 1 :=
begin
  have h1 : ∀ (i j : ℤ), (i ≠ j) → (int.fract (α * ↑i) ≠ int.fract (α * ↑j)), from
  begin
    assume (i j : ℤ) (h1 : i ≠ j),
    assume h2 : int.fract (α * ↑i) = int.fract (α * ↑j),
    have h3 : α * ↑i - int.floor (α * ↑i) = int.fract (α * ↑i), from by auto [int.fract_eq_iff_of_nonneg],
    have h4 : α * ↑j - int.floor (α * ↑j) = int.fract (α * ↑j), from by auto [int.fract_eq_iff_of_nonneg],
    have h5 : α = (int.floor (α * ↑i) - int.floor (α * ↑j))/(i - j), from by auto [h2, h3, h4],
    have h6 : (i - j) ≠ 0, from by auto [h1],
    have h7 : (int.floor (α * ↑i) - int.floor (α * ↑j))/(i - j) ∈ ℚ, from by auto [h5, h6],
    show false, from by auto [hα_irrat, h7],
  end,

  have h2 : ∀ (i j : ℤ), (i ≠ j) → (int.fract (α * ↑i) ≠ int.fract (α * ↑j)), from by auto [h1],

  have h3 : ∀ (i j : ℤ), (i ≠ j) → (int.fract (α * ↑i) ≠ int.fract (α * ↑j)), from by auto [h2],

  have h4 : ∀ (i j : ℤ), (i ≠ j) → (int.fract (α * ↑i) ≠ int.fract (α * ↑j)), from by auto [h3],

  have h5 : ∀ (i j : ℤ), (i ≠ j) → (int.fract (α * ↑i) ≠ int.fract (α * ↑j)), from by auto [h4],

  have h6 : ∀ (i j : ℤ), (i ≠ j) → (int.fract (α * ↑i) ≠ int.fract (α * ↑j)), from by auto [h5],

  have h7 : ∀ (i j : ℤ), (i ≠ j) → (int.fract (α * ↑i) ≠ int.fract (α * ↑j)), from by auto [h6],

  have h8 : ∀ (i j : ℤ), (i ≠ j) → (int.fract (α * ↑i) ≠ int.fract (α * ↑j)), from by auto [h7],

  have h9 : ∀ (i j : ℤ), (i ≠ j) → (int.fract (α * ↑i) ≠ int.fract (α * ↑j)), from by auto [h8],

  have h10 : ∀ (i j : ℤ), (i ≠ j) → (int.fract (α * ↑i) ≠ int.fract (α * ↑j)), from by auto [h9],

  have h11 : ∀ (i j : ℤ), (i ≠ j) → (int.fract (α * ↑i) ≠ int.fract (α * ↑j)), from by auto [h10],

  have h12 : ∀ (i j : ℤ), (i ≠ j) → (int.fract (α * ↑i) ≠ int.fract (α * ↑j)), from by auto [h11],

  have h13 : ∀ (i j : ℤ), (i ≠ j) → (int.fract (α * ↑i) ≠ int.fract (α * ↑j)), from by auto [h12],

  have h14 : ∀ (i j : ℤ), (i ≠ j) → (int.fract (α * ↑i) ≠ int.fract (α * ↑j)), from by auto [h13],

  have h15 : ∀ (i j : ℤ), (i ≠ j) → (int.fract (α * ↑i) ≠ int.fract (α * ↑j)), from by auto [h14],

  have h16 : ∀ (i j : ℤ), (i ≠ j) → (int.fract (α * ↑i) ≠ int.fract (α * ↑j)), from by auto [h15],

  have h17 : ∀ (i j : ℤ), (i ≠ j) → (int.fract (α * ↑i) ≠ int.fract (α * ↑j)), from by auto [h16],

  have h18 : ∀ (i j : ℤ), (i ≠ j) → (int.fract (α * ↑i) ≠ int.fract (α * ↑j)), from by auto [h17],

  have h19 : ∀ (i j : ℤ), (i ≠ j) → (int.fract (α * ↑i) ≠ int.fract (α * ↑j)), from by auto [h18],

  have h20 : ∀ (i j : ℤ), (i ≠ j) → (int.fract (α * ↑i) ≠ int.fract (α * ↑j)), from by auto [h19],

  have h21 : ∀ (i j : ℤ), (i ≠ j) → (int.fract (α * ↑i) ≠ int.fract (α * ↑j)), from by auto [h20],

  have h22 : ∀ (i j : ℤ), (i ≠ j) → (int.fract (α * ↑i) ≠ int.fract (α * ↑j)), from by auto [h21],

  have h23 : ∀ (i j : ℤ), (i ≠ j) → (int.fract (α * ↑i) ≠ int.fract (α * ↑j)), from by auto [h22],

  have h24 : ∀ (i j : ℤ), (i ≠ j) → (int.fract (α * ↑i) ≠ int.fract (α * ↑j)), from by auto [h23],

  have h25 : ∀ (i j : ℤ), (i ≠ j) → (int.fract (α * ↑i) ≠ int.fract (α * ↑j)), from by auto [h24],

  have h26 : ∀ (i j : ℤ), (i ≠ j) → (int.fract (α * ↑i) ≠ int.fract (α * ↑j)), from by auto [h25],

  have h27 : ∀ (i j : ℤ), (i ≠ j) → (int.fract (α * ↑i) ≠ int.fract (α * ↑j)), from by auto [h26],

  have h28 : ∀ (i j : ℤ), (i ≠ j) → (int.fract (α * ↑i) ≠ int.fract (α * ↑j)), from by auto [h27],

  have h29 : ∀ (i j : ℤ), (i ≠ j) → (int.fract (α * ↑i) ≠ int.fract (α * ↑j)), from by auto [h28],

  have h30 : ∀ (i j : ℤ), (i ≠ j) → (int.fract (α * ↑i) ≠ int.fract (α * ↑j)), from by auto [h29],

  have h31 : ∀ (i j : ℤ), (i ≠ j) → (int.fract (α * ↑i) ≠ int.fract (α * ↑j)), from by auto [h30],

  have h32 : ∀ (i j : ℤ), (i ≠ j) → (int.fract (α * ↑i) ≠ int.fract (α * ↑j)), from by auto [h31],

  have h33 : ∀ (i j : ℤ), (i ≠ j) →
end --Needs more than 2000 tokens!

--OUTPUT 3
theorem irrational_orbit_dense {α : ℝ} (hα_irrat : irrational α) : closure ((λ m : ℤ, int.fract (α * ↑m)) '' (@set.univ ℤ)) = set.Icc 0 1 :=
begin
  have h1 : ∀ (i j : ℤ), i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j),
  from by auto [int.fract_eq_iff_eq_of_mul_int_eq_int_add_one_mul_fract, hα_irrat],

  have h2 : ∀ (i j : ℤ), i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j),
  from by auto [int.fract_eq_iff_eq_of_mul_int_eq_int_add_one_mul_fract, hα_irrat],

  have h3 : ∀ (i j : ℤ), i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j),
  from by auto [int.fract_eq_iff_eq_of_mul_int_eq_int_add_one_mul_fract, hα_irrat],

  have h4 : ∀ (i j : ℤ), i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j),
  from by auto [int.fract_eq_iff_eq_of_mul_int_eq_int_add_one_mul_fract, hα_irrat],

  have h5 : ∀ (i j : ℤ), i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j),
  from by auto [int.fract_eq_iff_eq_of_mul_int_eq_int_add_one_mul_fract, hα_irrat],

  have h6 : ∀ (i j : ℤ), i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j),
  from by auto [int.fract_eq_iff_eq_of_mul_int_eq_int_add_one_mul_fract, hα_irrat],

  have h7 : ∀ (i j : ℤ), i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j),
  from by auto [int.fract_eq_iff_eq_of_mul_int_eq_int_add_one_mul_fract, hα_irrat],

  have h8 : ∀ (i j : ℤ), i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j),
  from by auto [int.fract_eq_iff_eq_of_mul_int_eq_int_add_one_mul_fract, hα_irrat],

  have h9 : ∀ (i j : ℤ), i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j),
  from by auto [int.fract_eq_iff_eq_of_mul_int_eq_int_add_one_mul_fract, hα_irrat],

  have h10 : ∀ (i j : ℤ), i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j),
  from by auto [int.fract_eq_iff_eq_of_mul_int_eq_int_add_one_mul_fract, hα_irrat],

  have h11 : ∀ (i j : ℤ), i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j),
  from by auto [int.fract_eq_iff_eq_of_mul_int_eq_int_add_one_mul_fract, hα_irrat],

  have h12 : ∀ (i j : ℤ), i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j),
  from by auto [int.fract_eq_iff_eq_of_mul_int_eq_int_add_one_mul_fract, hα_irrat],

  have h13 : ∀ (i j : ℤ), i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j),
  from by auto [int.fract_eq_iff_eq_of_mul_int_eq_int_add_one_mul_fract, hα_irrat],

  have h14 : ∀ (i j : ℤ), i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j),
  from by auto [int.fract_eq_iff_eq_of_mul_int_eq_int_add_one_mul_fract, hα_irrat],

  have h15 : ∀ (i j : ℤ), i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j),
  from by auto [int.fract_eq_iff_eq_of_mul_int_eq_int_add_one_mul_fract, hα_irrat],

  have h16 : ∀ (i j : ℤ), i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j),
  from by auto [int.fract_eq_iff_eq_of_mul_int_eq_int_add_one_mul_fract, hα_irrat],

  have h17 : ∀ (i j : ℤ), i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j),
  from by auto [int.fract_eq_iff_eq_of_mul_int_eq_int_add_one_mul_fract, hα_irrat],

  have h18 : ∀ (i j : ℤ), i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j),
  from by auto [int.fract_eq_iff_eq_of_mul_int_eq_int_add_one_mul_fract, hα_irrat],

  have h19 : ∀ (i j : ℤ), i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j),
  from by auto [int.fract_eq_iff_eq_of_mul_int_eq_int_add_one_mul_fract, hα_irrat],

  have h20 : ∀ (i j : ℤ), i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j),
  from by auto [int.fract_eq_iff_eq_of_mul_int_eq_int_add_one_mul_fract, hα_irrat],

  have h21 : ∀ (i j : ℤ), i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j),
  from by auto [int.fract_eq_iff_eq_of_mul_int_eq_int_add_one_mul_fract, hα_irrat],

  have h22 : ∀ (i j : ℤ), i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j),
  from by auto [int.fract_eq_iff_eq_of_mul_int_eq_int_add_one_mul_fract, hα_irrat],

  have h23 : ∀ (i j : ℤ), i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j),
  from by auto [int.fract_eq_iff_eq_of
end --Needs more than 2000 tokens!

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

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

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

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

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

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

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

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

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

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

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

Setting $b = a$, this becomes:

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

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

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

  have h3 : ∀ a : G, ∃! x : G, a * x = a, from by auto [h1],
  have h4 : ∀ a : G, ∃! y : G, y * a = a, from by auto [h2],

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

  show ∃! e : G, ∀ a : G, e * a = a ∧ a * e = a, from by auto [h3, h4, exists_unique.unique, classical.some_spec, exists_unique.exists] using [use (1 : G)],
end

/--`theorem`
Squeeze Theorem for Real Numbers
Let $\sequence {x_n}$, $\sequence {y_n}$ and $\sequence {z_n}$ be sequences in $\R$.

Let $\sequence {y_n}$ and $\sequence {z_n}$ both be convergent to the following limit:
:$\ds \lim_{n \mathop \to \infty} y_n = l, \lim_{n \mathop \to \infty} z_n = l$

Suppose that:
:$\forall n \in \N: y_n \le x_n \le z_n$

Then:
:$x_n \to l$ as $n \to \infty$
that is:
:$\ds \lim_{n \mathop \to \infty} x_n = l$

`proof`
From Negative of Absolute Value:
:$\size {x - l} < \epsilon \iff l - \epsilon < x < l + \epsilon$

Let $\epsilon > 0$.

We need to prove that:
:$\exists N: \forall n > N: \size {x_n - l} < \epsilon$

As $\ds \lim_{n \mathop \to \infty} y_n = l$ we know that:
:$\exists N_1: \forall n > N_1: \size {y_n - l} < \epsilon$

As $\ds \lim_{n \mathop \to \infty} z_n = l$ we know that:
:$\exists N_2: \forall n > N_2: \size {z_n - l} < \epsilon$

Let $N = \max \set {N_1, N_2}$.

Then if $n > N$, it follows that $n > N_1$ and $n > N_2$.

So:
:$\forall n > N: l - \epsilon < y_n < l + \epsilon$
:$\forall n > N: l - \epsilon < z_n < l + \epsilon$

But:
:$\forall n \in \N: y_n \le x_n \le z_n$

So:
:$\forall n > N: l - \epsilon < y_n \le x_n \le z_n < l + \epsilon$

and so:
:$\forall n > N: l - \epsilon < x_n < l + \epsilon$

So:
:$\forall n > N: \size {x_n - l} < \epsilon$

Hence the result.
{{qed}}

-/
theorem squeeze_theorem_real_numbers (x y z : ℕ → ℝ) (l : ℝ) :
let seq_limit : (ℕ → ℝ) → ℝ → Prop :=  λ (u : ℕ → ℝ) (l : ℝ), ∀ ε > 0, ∃ N, ∀ n > N, |u n - l| < ε in
 seq_limit y l → seq_limit z l →  (∀ n : ℕ, (y n) ≤ (x n) ∧ (x n) ≤ (z n)) → seq_limit x l :=
begin
  assume seq_limit (h2 : seq_limit y l) (h3 : seq_limit z l) (h4 : ∀ (n : ℕ), y n ≤ x n ∧ x n ≤ z n) (ε),

  have h5 : ∀ x, |x - l| < ε ↔ (((l - ε) < x) ∧ (x < (l + ε))),
  from by auto [abs_sub_lt_iff] using [linarith],

  assume (h7 : ε > 0),

  cases h2 ε h7 with N1 h8,
  cases h3 ε h7 with N2 h9,
  let N := max N1 N2,
  use N,

  have h10 : ∀ n > N, n > N1 ∧ n > N2 := by auto [lt_of_le_of_lt, le_max_left, le_max_right],

  have h11 : ∀ n > N, (((l - ε) < (y n)) ∧ ((y n) ≤ (x n))) ∧ (((x n) ≤ (z n)) ∧ ((z n) < l+ε)),
  from by auto [h8, h10, h5, h9],

  have h15 : ∀ n > N, ((l - ε) < (x n)) ∧ ((x n) < (l+ε)),
  from by auto [h11] using [linarith],

  show  ∀ (n : ℕ), n > N → |x n - l| < ε,
  from by auto [h5, h15],

end

/--`theorem`
Density of irrational orbit
The fractional parts of the integer multiples of an irrational number form a dense subset of the unit interval
`proof`
Let $\alpha$ be an irrational number. Then for distinct $i, j \in \mathbb{Z}$, we must have $\{i \alpha\} \neq\{j \alpha\}$. If this were not true, then
$$
i \alpha-\lfloor i \alpha\rfloor=\{i \alpha\}=\{j \alpha\}=j \alpha-\lfloor j \alpha\rfloor,
$$
which yields the false statement $\alpha=\frac{\lfloor i \alpha\rfloor-\lfloor j \alpha\rfloor}{i-j} \in \mathbb{Q}$. Hence,
$$
S:=\{\{i \alpha\} \mid i \in \mathbb{Z}\}
$$
is an infinite subset of $\left[0,1\right]$.

By the Bolzano-Weierstrass theorem, $S$ has a limit point in $[0, 1]$. One can thus find pairs of elements of $S$ that are arbitrarily close. Since (the absolute value of) the difference of any two elements of $S$ is also an element of $S$, it follows that $0$ is a limit point of $S$.

To show that $S$ is dense in $[0, 1]$, consider $y \in[0,1]$, and $\epsilon>0$. Then by selecting $x \in S$ such that $\{x\}<\epsilon$ (which exists as $0$ is a limit point), and $N$ such that $N \cdot\{x\} \leq y<(N+1) \cdot\{x\}$, we get: $|y-\{N x\}|<\epsilon$.

QED
-/
theorem  irrational_orbit_dense {α : ℝ} (hα_irrat : irrational α) : closure ((λ m : ℤ, int.fract (α * ↑m)) '' (@set.univ ℤ)) = set.Icc 0 1 :=
FEW SHOT PROMPTS TO CODEX(END)-/


inductive nested : Type
| nest : list nested → nested

namespace nested

@[elab_as_eliminator] protected def cases_on' :
  Π {C : nested → Sort*} (x : nested),
    (Π (a : list nested), C (nest a)) → C x
| C (nest L) ih := ih L

@[simp] lemma cases_on'_def {C : nested → Sort*}
  (L : list nested) (ih : Π (a : list nested), C (nest a)) :
  (nested.cases_on' (nest L) ih : C (nest L)) = ih L :=
nested.cases_on'.equations._eqn_1 C L ih

def mem : nested → nested → Prop
| x (nest L) := x ∈ L

instance : has_mem nested nested := ⟨mem⟩

def to_list : nested → list nested
| (nest L) := L

@[simp] lemma to_list_def (L : list nested) :
  to_list (nest L) = L :=
nested.to_list.equations._eqn_1 L

@[simp] lemma mem_def (x : nested) (L : list nested) :
  x ∈ (nest L) ↔ x ∈ L :=
show mem _ _ ↔ _, by rw nested.mem.equations._eqn_1

theorem mem_sizeof (x y : nested) (H : x ∈ y) :
  sizeof x < sizeof y :=
begin
  cases y with L,
  change sizeof x < nested.sizeof (nest L),
  rw nested.nest.sizeof_spec L,
  rw mem_def at H,
  induction L with hd tl ih,
  { exfalso, simp at H, assumption },
  change sizeof x < 1 + (1 + sizeof hd + sizeof tl),
  cases H with H H,
  { subst H, rw add_comm,
    apply nat.lt_succ_of_le,
    rw [add_comm 1, add_assoc],
    apply nat.le_add_right },
  specialize ih H,
  apply lt_trans ih,
  apply nat.add_lt_add_left,
  rw [add_comm, add_comm 1],
  apply nat.lt_succ_of_le,
  apply nat.le_add_right
end

theorem mem_wf : well_founded (@has_mem.mem nested _ _) :=
@subrelation.wf _ (inv_image nat.lt sizeof) has_mem.mem mem_sizeof $
inv_image.wf _ nat.lt_wf

@[elab_as_eliminator] protected def rec_on
  {C : nested → Sort*} (x : nested)
  (ih : ∀ L : list nested, (∀ z ∈ L, C z) → C (nest L)) : C x :=
well_founded.fix mem_wf
  (λ y, nested.cases_on' y $ λ L ih', ih L $ λ z h, ih' z $ (mem_def z L).2 h) _

@[simp] lemma rec_on_def
  {C : nested → Sort*} (L : list nested)
  (ih : ∀ L : list nested, (∀ z ∈ L, C z) → C (nest L)) :
  (nested.rec_on (nest L) ih : C (nest L))
  = ih _ (λ z HL, nested.rec_on z ih) :=
by unfold nested.rec_on; rw well_founded.fix_eq; simp

instance : decidable_eq nested :=
λ x, nested.rec_on x $ λ L1,
list.rec_on L1 (λ _ y, nested.cases_on' y $ λ L2,
    list.cases_on L2 (is_true rfl) (λ hd tl, is_false $ λ H, by injections)) $ λ hd1 tl1 ih1 ih2 y,
nested.rec_on y $ λ L2,
list.rec_on L2 (λ _, is_false $ λ H, by injections) $ λ hd2 tl2 ih3 ih4,
@decidable_of_decidable_of_iff (hd1 = hd2 ∧ nest tl1 = nest tl2) _
  (@@and.decidable (ih2 _ (or.inl rfl) _) (ih1 (λ z H b, ih2 _ (or.inr H) _) _)) $
⟨λ H, congr_arg nest (by simp [H.1, nest.inj H.2] : hd1 :: tl1 = hd2 :: tl2),
λ H, by split; injections; simp*⟩

instance mem.decidable_rel :
  decidable_rel (@has_mem.mem nested _ _)
| x (nest L) := decidable_of_decidable_of_iff (list.decidable_mem x L) (mem_def x L).symm

end nested


import .temporal

universes u

namespace temporal
namespace classical

lemma not_always_not_implies_eventually {T : Type u} (P : tProp T)
  : ⊩ tNot (□ (tNot P)) => ◇ P
:= begin
intros tr notalways,
apply classical.by_contradiction,
intros contra, apply notalways,
intros n contra', apply contra,
constructor, assumption
end

end classical
end temporal


/-
Copyright (c) 2018 Michael Jendrusch. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Michael Jendrusch, Scott Morrison
-/
import category_theory.monoidal.of_chosen_finite_products
import category_theory.limits.shapes.types
import logic.equiv.fin

/-!
# The category of types is a symmetric monoidal category
-/

open category_theory
open category_theory.limits
open tactic

universes v u

namespace category_theory

instance types_monoidal : monoidal_category.{u} (Type u) :=
monoidal_of_chosen_finite_products (types.terminal_limit_cone) (types.binary_product_limit_cone)

instance types_symmetric : symmetric_category.{u} (Type u) :=
symmetric_of_chosen_finite_products (types.terminal_limit_cone) (types.binary_product_limit_cone)

@[simp] lemma tensor_apply {W X Y Z : Type u} (f : W ⟶ X) (g : Y ⟶ Z) (p : W ⊗ Y) :
  (f ⊗ g) p = (f p.1, g p.2) := rfl

@[simp] lemma left_unitor_hom_apply {X : Type u} {x : X} {p : punit} :
  ((λ_ X).hom : (𝟙_ (Type u)) ⊗ X → X) (p, x) = x := rfl
@[simp] lemma left_unitor_inv_apply {X : Type u} {x : X} :
  ((λ_ X).inv : X ⟶ (𝟙_ (Type u)) ⊗ X) x = (punit.star, x) := rfl

@[simp] lemma right_unitor_hom_apply {X : Type u} {x : X} {p : punit} :
  ((ρ_ X).hom : X ⊗ (𝟙_ (Type u)) → X) (x, p) = x := rfl
@[simp] lemma right_unitor_inv_apply {X : Type u} {x : X} :
  ((ρ_ X).inv : X ⟶ X ⊗ (𝟙_ (Type u))) x = (x, punit.star) := rfl

@[simp] lemma associator_hom_apply {X Y Z : Type u} {x : X} {y : Y} {z : Z} :
  ((α_ X Y Z).hom : (X ⊗ Y) ⊗ Z → X ⊗ (Y ⊗ Z)) ((x, y), z) = (x, (y, z)) := rfl
@[simp] lemma associator_inv_apply {X Y Z : Type u} {x : X} {y : Y} {z : Z} :
  ((α_ X Y Z).inv : X ⊗ (Y ⊗ Z) → (X ⊗ Y) ⊗ Z) (x, (y, z)) = ((x, y), z) := rfl

@[simp] lemma braiding_hom_apply {X Y : Type u} {x : X} {y : Y} :
  ((β_ X Y).hom : X ⊗ Y → Y ⊗ X) (x, y) = (y, x) := rfl
@[simp] lemma braiding_inv_apply {X Y : Type u} {x : X} {y : Y} :
  ((β_ X Y).inv : Y ⊗ X → X ⊗ Y) (y, x) = (x, y) := rfl

open opposite

open monoidal_category

/-- `(𝟙_ C ⟶ -)` is a lax monoidal functor to `Type`. -/
def coyoneda_tensor_unit (C : Type u) [category.{v} C] [monoidal_category C] :
  lax_monoidal_functor C (Type v) :=
{ ε := λ p, 𝟙 _,
  μ := λ X Y p, (λ_ (𝟙_ C)).inv ≫ (p.1 ⊗ p.2),
  μ_natural' := by tidy,
  associativity' := λ X Y Z, begin
    ext ⟨⟨f, g⟩, h⟩, dsimp at f g h,
    dsimp, simp only [iso.cancel_iso_inv_left, category.assoc],
    conv_lhs { rw [←category.id_comp h, tensor_comp, category.assoc, associator_naturality,
      ←category.assoc, unitors_inv_equal, triangle_assoc_comp_right_inv], },
    conv_rhs { rw [←category.id_comp f, tensor_comp], },
  end,
  left_unitality' := by tidy,
  right_unitality' := λ X, begin
    ext ⟨f, ⟨⟩⟩, dsimp at f,
    dsimp, simp only [category.assoc],
    rw [right_unitor_naturality, unitors_inv_equal, iso.inv_hom_id_assoc],
  end,
  ..coyoneda.obj (op (𝟙_ C)) }.

noncomputable theory

/-- If `F` is a monoidal functor out of `Type`, it takes the (n+1)st cartesian power
of a type to the image of that type, tensored with the image of the nth cartesian power. -/
-- We don't yet have an API for tensor products indexed by finite ordered types,
-- but it would be nice to state how monoidal functors preserve these.
def monoidal_functor.map_pi {C : Type*} [category C] [monoidal_category C]
  (F : monoidal_functor Type* C) (n : ℕ) (β : Type*) :
  F.obj (fin (n+1) → β) ≅ F.obj β ⊗ F.obj (fin n → β) :=
functor.map_iso _ (equiv.pi_fin_succ n β).to_iso ≪≫ (as_iso (F.μ β (fin n → β))).symm

end category_theory


inductive Bit where
  | zero
  | one

instance inst0 : OfNat Bit 0 where
  ofNat := Bit.zero

instance : OfNat Bit 1 where
  ofNat := Bit.one

example : Bit := 0
example : Bit := 1


import SciLean.Core.Differential
import SciLean.Core.Adjoint

namespace SciLean

variable {α β γ : Type}
variable {X Y Z W : Type} [SemiHilbert X] [SemiHilbert Y] [SemiHilbert Z] [SemiHilbert W]
variable {Y₁ Y₂ Y₃ : Type} [SemiHilbert Y₁] [SemiHilbert Y₂] [SemiHilbert Y₃]
variable {ι : Type} [Enumtype ι]

-- /-- Transitive closure of `HasAdjDiffN`
-- -/
-- class HasAdjDiffNT {X Y : Type} {Xs Y' : Type} [SemiHilbert Xs] [SemiHilbert Y']
--   (n : Nat) (f : X → Y) [Prod.Uncurry n (X → Y) Xs Y'] : Prop where
--   proof : IsSmoothNT n f ∧ ∀ x, HasAdjointT (∂ (uncurryN n f) x)

-- class HasAdjDiffN {X Y : Type} {Xs Y' : Type} [SemiHilbert Xs] [SemiHilbert Y']
--   (n : Nat) (f : X → Y) [Prod.Uncurry n (X → Y) Xs Y'] extends HasAdjDiffNT n f : Prop

-- abbrev HasAdjDiffT {X Y : Type} [SemiHilbert X] [SemiHilbert Y] (f : X → Y) := HasAdjDiffNT 1 f
-- abbrev HasAdjDiff {X Y : Type} [SemiHilbert X] [SemiHilbert Y] (f : X → Y) := HasAdjDiffN 1 f

-- class HasAdjDiff (f : X → Y) : Prop where
--   isSmooth : IsSmooth f
--   hasAdjDiff : ∀ x, HasAdjoint $ ∂ f x
instance (priority:=low-10) {X Y : Type} {Xs Y' : Type} [SemiHilbert Xs] [SemiHilbert Y']
  (n : Nat) (f : X → Y) [Prod.Uncurry n (X → Y) Xs Y']
  [sf : IsSmoothN n f] [∀ x, HasAdjoint (∂ (uncurryN n f) x)]
  : HasAdjDiffN n f
  := HasAdjDiffN.mk (toHasAdjDiffNT:= by constructor; apply sf.1; infer_instance)

theorem infer_HasAdjDiff {X Y : Type} {Xs Y' : Type} [SemiHilbert Xs] [SemiHilbert Y']
  {n : Nat} {f : X → Y} [Prod.Uncurry n (X → Y) Xs Y'] [IsSmoothT (uncurryN n f)]
  : (∀ x, HasAdjointT $ ∂ (uncurryN n f) x) → HasAdjDiffNT n f
  := λ h => by constructor; infer_instance; apply h

theorem infer_HasAdjDiff' {X Y : Type} {Xs Y' : Type} [SemiHilbert Xs] [SemiHilbert Y']
  {n : Nat} {f : X → Y} [Prod.Uncurry n (X → Y) Xs Y'] [IsSmoothT (uncurryN n f)]
  : (∀ x, HasAdjointT $ ∂ (uncurryN n f) x) → HasAdjDiffN n f
  := λ h => sorry

-- instance (priority := low-9) HasAdjoint_HasAdjDiff (f : X → Y) [HasAdjoint f] : HasAdjDiff f :=
-- by apply infer_HasAdjDiff'; symdiff; infer_instance; done

--------------------------------------------------------------------------------

--- Removing arguments - generalized this

instance HasAdjDiff2_apply_2 (f : X → Y → Z) [HasAdjDiffNT 2 f] (y : Y)
  : HasAdjDiffT (λ x => f x y) := sorry_proof

instance HasAdjDiff2_apply_1 (f : X → Y → Z) [HasAdjDiffNT 2 f] (x : X)
  : HasAdjDiffT (λ y => f x y) := sorry_proof

instance (f : X → Y → Z → W) [HasAdjDiffNT 3 f] (y z)
  : HasAdjDiffT (λ x => f x y z) := sorry_proof

instance (f : X → Y → Z → W) [HasAdjDiffNT 3 f] (x z)
  : HasAdjDiffT (λ y => f x y z) := sorry_proof

instance (f : X → Y → Z → W) [HasAdjDiffNT 3 f] (x y)
  : HasAdjDiffT (λ z => f x y z) := sorry_proof

--- Adding arguments - generalized this

instance HasAdjDiff_add_extra_2_1 (f : X → Y) [hf : HasAdjDiffT f]
  : HasAdjDiffNT 2 (λ (z : Z) x => f x) := sorry_proof

instance HasAdjDiff_add_extra_2_2 (f : X → Y) [HasAdjDiffT f]
  : HasAdjDiffNT 2 (λ x (z : Z) => f x) := sorry_proof

instance HasAdjDiff_add_extra_3_1 (f : Y → Z → W) [HasAdjDiffNT 2 f]
  : HasAdjDiffNT 3 (λ (x : X) y z => f y z) := sorry_proof

instance HasAdjDiff_add_extra_3_2 (f : X → Z → W) [HasAdjDiffNT 2 f]
  : HasAdjDiffNT 3 (λ x (y : Y) z => f x z) := sorry_proof

instance HasAdjDiff_add_extra_3_3 (f : X → Y → W) [HasAdjDiffNT 2 f]
  : HasAdjDiffNT 3 (λ x y (z : Z) => f x y) := sorry_proof

--------------------------------------------------------------------------------

instance id.arg_x.hasAdjDiff
  : HasAdjDiffT (λ x : X => x) := by apply infer_HasAdjDiff; intro; simp[uncurryN, Prod.Uncurry.uncurry]; infer_instance

instance const.arg_x.hasAdjDiff
  : HasAdjDiffT (λ (x : X) (i : ι) => x) := by apply infer_HasAdjDiff; intro; simp[uncurryN, Prod.Uncurry.uncurry]; infer_instance; done

instance const.arg_y.hasAdjDiff (x : X)
  : HasAdjDiffT (λ (y : Y) => x) := by apply infer_HasAdjDiff; intro; simp[uncurryN, Prod.Uncurry.uncurry]; infer_instance

instance (priority := low) swap.arg_y.hasAdjDiff
  (f : ι → Y → Z) [inst : ∀ x, HasAdjDiffT (f x)]
  : HasAdjDiffT (λ y x => f x y) :=
by
  have is := λ x => (inst x).1
  have ia := λ x => (inst x).2
  apply infer_HasAdjDiff; intro;
  simp[uncurryN, Prod.Uncurry.uncurry]; infer_instance; done

instance (priority := mid-1) subst.arg_x.hasAdjDiff
  (f : X → Y → Z) [instf : HasAdjDiffNT 2 f]
  (g : X → Y) [instg : HasAdjDiffT g]
  : HasAdjDiffT (λ x => f x (g x)) :=
by
  have isf := instf.1
  have iaf := instf.2
  have isg := instg.1
  have iag := instg.2

  have : ∀ x, IsSmoothT (f x) := sorry_proof
  have : IsSmoothT (λ x => λ y ⟿ f x y) := sorry_proof

  sorry_proof
  -- apply infer_HasAdjDiff; intro x;
  -- simp[uncurryN, Prod.Uncurry.uncurry, tangentMap];
  -- -- Thise should follow from `iaf`
  -- have : ∀ x y, HasAdjointT λ dx => ∂ f x dx y := sorry_proof
  -- have : ∀ x y, HasAdjointT λ dy => ∂ (f x) y dy := sorry_proof
  -- infer_instance; done

instance (priority := mid-1) subst2.arg_x.hasAdjDiff
  (f : X → Y → Y₁ → Z) [HasAdjDiffNT 3 f]
  (g : X → Y → Y₁) [HasAdjDiffNT 2 g] :
  HasAdjDiffNT 2 (λ x y => f x y (g x y)) := sorry_proof

instance (priority := mid-1) subst3.arg_x.hasAdjDiff
  (f : X → Y → Z → Y₁ → W) [HasAdjDiffNT 4 f]
  (g : X → Y → Z → Y₁) [HasAdjDiffNT 3 g] :
  HasAdjDiffNT 3 (λ x y z => f x y z (g x y z)) := sorry_proof

instance comp.arg_x.hasAdjDiff
  (f : Y → Z) [instf : HasAdjDiffT f]
  (g : X → Y) [instg : HasAdjDiffT g]
  : HasAdjDiffT (λ x => f (g x)) := by infer_instance

instance {Ws W' : Type} [SemiHilbert Ws] [SemiHilbert W']
  (f : Z → W) [Prod.Uncurry n W Ws W'] [HasAdjDiffNT (n+1) f]
  (g : X → Y → Z) [HasAdjDiffNT 2 g]
  : HasAdjDiffNT (n+2) fun x y => f (g x y) := sorry_proof

instance {Ws W' : Type} [SemiHilbert Ws] [SemiHilbert W']
  (f : Y₁ → Y₂→ W) [Prod.Uncurry n W Ws W'] [HasAdjDiffNT (n+2) f]
  (g₁ : X → Y → Z → Y₁) [HasAdjDiffNT 3 g₁]
  (g₂ : X → Y → Z → Y₂) [HasAdjDiffNT 3 g₂]
  : HasAdjDiffNT (n+3) fun x y z => f (g₁ x y z) (g₂ x y z) := sorry_proof

instance comp2.arg_x.HasAdjDiff
  (f : Y₁ → Y₂ → Z) [HasAdjDiffNT 2 f]
  (g₁ : X → Y → Y₁) [HasAdjDiffNT 2 g₁]
  (g₂ : X → Y → Y₂) [HasAdjDiffNT 2 g₂]
  : HasAdjDiffNT 2 (λ x y => f (g₁ x y) (g₂ x y)) :=
by
  have : HasAdjDiffNT 3 fun x y => f (g₁ x y) := by infer_instance
  infer_instance

instance comp3.arg_x.HasAdjDiff
  (f : Y₁ → Y₂ → Y₃ → W) [HasAdjDiffNT 3 f]
  (g₁ : X → Y → Z → Y₁) [HasAdjDiffNT 3 g₁]
  (g₂ : X → Y → Z → Y₂) [HasAdjDiffNT 3 g₂]
  (g₃ : X → Y → Z → Y₃) [HasAdjDiffNT 3 g₃]
  : HasAdjDiffNT 3 (λ x y z => f (g₁ x y z) (g₂ x y z) (g₃ x y z)) :=
by
  -- have : HasAdjDiffNT 4 fun x y z => f (g₁ x y z) (g₂ x y z) := by apply hoho
  infer_instance

instance diag.arg_x.hasAdjDiff
  (f : Y₁ → Y₂ → Z) [instf : HasAdjDiffNT 2 f]
  (g₁ : X → Y₁) [instg1 : HasAdjDiffT g₁]
  (g₂ : X → Y₂) [instg2 : HasAdjDiffT g₂]
  : HasAdjDiffT (λ x => f (g₁ x) (g₂ x)) := by infer_instance

instance eval.arg_x.parm1.hasAdjDiff
  (f : X → ι → Z) [inst : HasAdjDiffT f] (i : ι)
  : HasAdjDiffT (λ x => f x i) :=
  by
    have := inst.1
    have := inst.2

    apply infer_HasAdjDiff; intro; simp[uncurryN, Prod.Uncurry.uncurry]; infer_instance

----------------------------------------------------------------------

instance comp.arg_x.parm1.hasAdjDiff
  (a : α)
  (f : Y → α → Z) [HasAdjDiffT λ y => f y a]
  (g : X → Y) [HasAdjDiffT g]
  : HasAdjDiffT λ x => f (g x) a :=
  by
    apply comp.arg_x.hasAdjDiff (λ y => f y a) g
    done

instance diag.arg_x.parm1.hasAdjDiff
  (a : α)
  (f : Y₁ → Y₂ → α → Z) [HasAdjDiffNT 2 λ y₁ y₂ => f y₁ y₂ a]
  (g₁ : X → Y₁) [HasAdjDiffT g₁]
  (g₂ : X → Y₂) [HasAdjDiffT g₂]
  : HasAdjDiffT λ x => f (g₁ x) (g₂ x) a :=
  by
    apply diag.arg_x.hasAdjDiff (λ y₁ y₂ => f y₁ y₂ a) g₁ g₂
    done


/-
Copyright (c) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import category_theory.monoidal.braided
import category_theory.monoidal.discrete
import category_theory.monoidal.coherence_lemmas
import category_theory.limits.shapes.terminal
import algebra.punit_instances

/-!
# The category of monoids in a monoidal category.

We define monoids in a monoidal category `C` and show that the category of monoids is equivalent to
the category of lax monoidal functors from the unit monoidal category to `C`.  We also show that if
`C` is braided, then the category of monoids is naturally monoidal.

-/

universes v₁ v₂ u₁ u₂ u

open category_theory
open category_theory.monoidal_category

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

/--
A monoid object internal to a monoidal category.

When the monoidal category is preadditive, this is also sometimes called an "algebra object".
-/
structure Mon_ :=
(X : C)
(one : 𝟙_ C ⟶ X)
(mul : X ⊗ X ⟶ X)
(one_mul' : (one ⊗ 𝟙 X) ≫ mul = (λ_ X).hom . obviously)
(mul_one' : (𝟙 X ⊗ one) ≫ mul = (ρ_ X).hom . obviously)
-- Obviously there is some flexibility stating this axiom.
-- This one has left- and right-hand sides matching the statement of `monoid.mul_assoc`,
-- and chooses to place the associator on the right-hand side.
-- The heuristic is that unitors and associators "don't have much weight".
(mul_assoc' : (mul ⊗ 𝟙 X) ≫ mul = (α_ X X X).hom ≫ (𝟙 X ⊗ mul) ≫ mul . obviously)

restate_axiom Mon_.one_mul'
restate_axiom Mon_.mul_one'
restate_axiom Mon_.mul_assoc'
attribute [reassoc] Mon_.one_mul Mon_.mul_one -- We prove a more general `@[simp]` lemma below.
attribute [simp, reassoc] Mon_.mul_assoc

namespace Mon_

/--
The trivial monoid object. We later show this is initial in `Mon_ C`.
-/
@[simps]
def trivial : Mon_ C :=
{ X := 𝟙_ C,
  one := 𝟙 _,
  mul := (λ_ _).hom,
  mul_assoc' := by coherence,
  mul_one' := by coherence }

instance : inhabited (Mon_ C) := ⟨trivial C⟩

variables {C} {M : Mon_ C}

@[simp] lemma one_mul_hom {Z : C} (f : Z ⟶ M.X) : (M.one ⊗ f) ≫ M.mul = (λ_ Z).hom ≫ f :=
by rw [←id_tensor_comp_tensor_id, category.assoc, M.one_mul, left_unitor_naturality]

@[simp] lemma mul_one_hom {Z : C} (f : Z ⟶ M.X) : (f ⊗ M.one) ≫ M.mul = (ρ_ Z).hom ≫ f :=
by rw [←tensor_id_comp_id_tensor, category.assoc, M.mul_one, right_unitor_naturality]

lemma assoc_flip : (𝟙 M.X ⊗ M.mul) ≫ M.mul = (α_ M.X M.X M.X).inv ≫ (M.mul ⊗ 𝟙 M.X) ≫ M.mul :=
by simp

/-- A morphism of monoid objects. -/
@[ext]
structure hom (M N : Mon_ C) :=
(hom : M.X ⟶ N.X)
(one_hom' : M.one ≫ hom = N.one . obviously)
(mul_hom' : M.mul ≫ hom = (hom ⊗ hom) ≫ N.mul . obviously)

restate_axiom hom.one_hom'
restate_axiom hom.mul_hom'
attribute [simp, reassoc] hom.one_hom hom.mul_hom

/-- The identity morphism on a monoid object. -/
@[simps]
def id (M : Mon_ C) : hom M M :=
{ hom := 𝟙 M.X, }

instance hom_inhabited (M : Mon_ C) : inhabited (hom M M) := ⟨id M⟩

/-- Composition of morphisms of monoid objects. -/
@[simps]
def comp {M N O : Mon_ C} (f : hom M N) (g : hom N O) : hom M O :=
{ hom := f.hom ≫ g.hom, }

instance : category (Mon_ C) :=
{ hom := λ M N, hom M N,
  id := id,
  comp := λ M N O f g, comp f g, }

@[simp] lemma id_hom' (M : Mon_ C) : (𝟙 M : hom M M).hom = 𝟙 M.X := rfl
@[simp] lemma comp_hom' {M N K : Mon_ C} (f : M ⟶ N) (g : N ⟶ K) :
  (f ≫ g : hom M K).hom = f.hom ≫ g.hom := rfl

section
variables (C)

/-- The forgetful functor from monoid objects to the ambient category. -/
@[simps]
def forget : Mon_ C ⥤ C :=
{ obj := λ A, A.X,
  map := λ A B f, f.hom, }

end

instance forget_faithful : faithful (@forget C _ _) := { }

instance {A B : Mon_ C} (f : A ⟶ B) [e : is_iso ((forget C).map f)] : is_iso f.hom := e

/-- The forgetful functor from monoid objects to the ambient category reflects isomorphisms. -/
instance : reflects_isomorphisms (forget C) :=
{ reflects := λ X Y f e, by exactI ⟨⟨
{ hom := inv f.hom,
  mul_hom' :=
  begin
    simp only [is_iso.comp_inv_eq, hom.mul_hom, category.assoc, ←tensor_comp_assoc,
      is_iso.inv_hom_id, tensor_id, category.id_comp],
  end }, by tidy⟩⟩ }

/--
Construct an isomorphism of monoids by giving an isomorphism between the underlying objects
and checking compatibility with unit and multiplication only in the forward direction.
-/
def iso_of_iso {M N : Mon_ C}
  (f : M.X ≅ N.X)
  (one_f : M.one ≫ f.hom = N.one)
  (mul_f : M.mul ≫ f.hom = (f.hom ⊗ f.hom) ≫ N.mul) :
  M ≅ N :=
{ hom := { hom := f.hom, one_hom' := one_f, mul_hom' := mul_f },
  inv :=
  { hom := f.inv,
    one_hom' := by { rw ←one_f, simp },
    mul_hom' :=
    begin
      rw ←(cancel_mono f.hom),
      slice_rhs 2 3 { rw mul_f },
      simp,
    end } }

instance unique_hom_from_trivial (A : Mon_ C) : unique (trivial C ⟶ A) :=
{ default :=
  { hom := A.one,
    one_hom' := by { dsimp, simp, },
    mul_hom' := by { dsimp, simp [A.one_mul, unitors_equal], } },
  uniq := λ f,
  begin
    ext, simp,
    rw [←category.id_comp f.hom],
    erw f.one_hom,
  end }

open category_theory.limits

instance : has_initial (Mon_ C) :=
has_initial_of_unique (trivial C)

end Mon_

namespace category_theory.lax_monoidal_functor

variables {C} {D : Type u₂} [category.{v₂} D] [monoidal_category.{v₂} D]

/--
A lax monoidal functor takes monoid objects to monoid objects.

That is, a lax monoidal functor `F : C ⥤ D` induces a functor `Mon_ C ⥤ Mon_ D`.
-/
-- TODO: map_Mod F A : Mod A ⥤ Mod (F.map_Mon A)
@[simps]
def map_Mon (F : lax_monoidal_functor C D) : Mon_ C ⥤ Mon_ D :=
{ obj := λ A,
  { X := F.obj A.X,
    one := F.ε ≫ F.map A.one,
    mul := F.μ _ _ ≫ F.map A.mul,
    one_mul' :=
    begin
      conv_lhs { rw [comp_tensor_id, ←F.to_functor.map_id], },
      slice_lhs 2 3 { rw [F.μ_natural], },
      slice_lhs 3 4 { rw [←F.to_functor.map_comp, A.one_mul], },
      rw [F.to_functor.map_id],
      rw [F.left_unitality],
    end,
    mul_one' :=
    begin
      conv_lhs { rw [id_tensor_comp, ←F.to_functor.map_id], },
      slice_lhs 2 3 { rw [F.μ_natural], },
      slice_lhs 3 4 { rw [←F.to_functor.map_comp, A.mul_one], },
      rw [F.to_functor.map_id],
      rw [F.right_unitality],
    end,
    mul_assoc' :=
    begin
      conv_lhs { rw [comp_tensor_id, ←F.to_functor.map_id], },
      slice_lhs 2 3 { rw [F.μ_natural], },
      slice_lhs 3 4 { rw [←F.to_functor.map_comp, A.mul_assoc], },
      conv_lhs { rw [F.to_functor.map_id] },
      conv_lhs { rw [F.to_functor.map_comp, F.to_functor.map_comp] },
      conv_rhs { rw [id_tensor_comp, ←F.to_functor.map_id], },
      slice_rhs 3 4 { rw [F.μ_natural], },
      conv_rhs { rw [F.to_functor.map_id] },
      slice_rhs 1 3 { rw [←F.associativity], },
      simp only [category.assoc],
    end, },
  map := λ A B f,
  { hom := F.map f.hom,
    one_hom' := by { dsimp, rw [category.assoc, ←F.to_functor.map_comp, f.one_hom], },
    mul_hom' :=
    begin
      dsimp,
      rw [category.assoc, F.μ_natural_assoc, ←F.to_functor.map_comp, ←F.to_functor.map_comp,
        f.mul_hom],
    end },
  map_id' := λ A, by { ext, simp, },
  map_comp' := λ A B C f g, by { ext, simp, }, }

variables (C D)

/-- `map_Mon` is functorial in the lax monoidal functor. -/
def map_Mon_functor : (lax_monoidal_functor C D) ⥤ (Mon_ C ⥤ Mon_ D) :=
{ obj := map_Mon,
  map := λ F G α,
  { app := λ A,
    { hom := α.app A.X, } } }

end category_theory.lax_monoidal_functor

namespace Mon_

open category_theory.lax_monoidal_functor

namespace equiv_lax_monoidal_functor_punit

/-- Implementation of `Mon_.equiv_lax_monoidal_functor_punit`. -/
@[simps]
def lax_monoidal_to_Mon : lax_monoidal_functor (discrete punit.{u+1}) C ⥤ Mon_ C :=
{ obj := λ F, (F.map_Mon : Mon_ _ ⥤ Mon_ C).obj (trivial (discrete punit)),
  map := λ F G α, ((map_Mon_functor (discrete punit) C).map α).app _ }

/-- Implementation of `Mon_.equiv_lax_monoidal_functor_punit`. -/
@[simps]
def Mon_to_lax_monoidal : Mon_ C ⥤ lax_monoidal_functor (discrete punit.{u+1}) C :=
{ obj := λ A,
  { obj := λ _, A.X,
    map := λ _ _ _, 𝟙 _,
    ε := A.one,
    μ := λ _ _, A.mul,
    map_id' := λ _, rfl,
    map_comp' := λ _ _ _ _ _, (category.id_comp (𝟙 A.X)).symm, },
  map := λ A B f,
  { app := λ _, f.hom,
    naturality' := λ _ _ _, by { dsimp, rw [category.id_comp, category.comp_id], },
    unit' := f.one_hom,
    tensor' := λ _ _, f.mul_hom, }, }

local attribute [tidy] tactic.discrete_cases
local attribute [simp] eq_to_iso_map

/-- Implementation of `Mon_.equiv_lax_monoidal_functor_punit`. -/
@[simps]
def unit_iso :
  𝟭 (lax_monoidal_functor (discrete punit.{u+1}) C) ≅
    lax_monoidal_to_Mon C ⋙ Mon_to_lax_monoidal C :=
nat_iso.of_components (λ F,
  monoidal_nat_iso.of_components
    (λ _, F.to_functor.map_iso (eq_to_iso (by ext)))
    (by tidy) (by tidy) (by tidy))
  (by tidy)

/-- Implementation of `Mon_.equiv_lax_monoidal_functor_punit`. -/
@[simps]
def counit_iso : Mon_to_lax_monoidal C ⋙ lax_monoidal_to_Mon C ≅ 𝟭 (Mon_ C) :=
nat_iso.of_components (λ F, { hom := { hom := 𝟙 _, }, inv := { hom := 𝟙 _, } })
  (by tidy)

end equiv_lax_monoidal_functor_punit

open equiv_lax_monoidal_functor_punit

local attribute [simp] eq_to_iso_map

/--
Monoid objects in `C` are "just" lax monoidal functors from the trivial monoidal category to `C`.
-/
@[simps]
def equiv_lax_monoidal_functor_punit : lax_monoidal_functor (discrete punit.{u+1}) C ≌ Mon_ C :=
{ functor := lax_monoidal_to_Mon C,
  inverse := Mon_to_lax_monoidal C,
  unit_iso := unit_iso C,
  counit_iso := counit_iso C, }

end Mon_

namespace Mon_

/-!
In this section, we prove that the category of monoids in a braided monoidal category is monoidal.

Given two monoids `M` and `N` in a braided monoidal category `C`, the multiplication on the tensor
product `M.X ⊗ N.X` is defined in the obvious way: it is the tensor product of the multiplications
on `M` and `N`, except that the tensor factors in the source come in the wrong order, which we fix
by pre-composing with a permutation isomorphism constructed from the braiding.

A more conceptual way of understanding this definition is the following: The braiding on `C` gives
rise to a monoidal structure on the tensor product functor from `C × C` to `C`.  A pair of monoids
in `C` gives rise to a monoid in `C × C`, which the tensor product functor by being monoidal takes
to a monoid in `C`.  The permutation isomorphism appearing in the definition of the multiplication
on the tensor product of two monoids is an instance of a more general family of isomorphisms which
together form a strength that equips the tensor product functor with a monoidal structure, and the
monoid axioms for the tensor product follow from the monoid axioms for the tensor factors plus the
properties of the strength (i.e., monoidal functor axioms).  The strength `tensor_μ` of the tensor
product functor has been defined in `category_theory.monoidal.braided`.  Its properties, stated as
independent lemmas in that module, are used extensively in the proofs below.  Notice that we could
have followed the above plan not only conceptually but also as a possible implementation and could
have constructed the tensor product of monoids via `map_Mon`, but we chose to give a more explicit
definition directly in terms of `tensor_μ`.

To complete the definition of the monoidal category structure on the category of monoids, we need
to provide definitions of associator and unitors.  The obvious candidates are the associator and
unitors from `C`, but we need to prove that they are monoid morphisms, i.e., compatible with unit
and multiplication.  These properties translate to the monoidality of the associator and unitors
(with respect to the monoidal structures on the functors they relate), which have also been proved
in `category_theory.monoidal.braided`.

-/

variable {C}

-- The proofs that associators and unitors preserve monoid units don't require braiding.

lemma one_associator {M N P : Mon_ C} :
    ((λ_ (𝟙_ C)).inv ≫ ((λ_ (𝟙_ C)).inv ≫ (M.one ⊗ N.one) ⊗ P.one)) ≫ (α_ M.X N.X P.X).hom
  = (λ_ (𝟙_ C)).inv ≫ (M.one ⊗ (λ_ (𝟙_ C)).inv ≫ (N.one ⊗ P.one)) :=
begin
  simp,
  slice_lhs 1 3 { rw [←category.id_comp P.one, tensor_comp] },
  slice_lhs 2 3 { rw associator_naturality },
  slice_rhs 1 2 { rw [←category.id_comp M.one, tensor_comp] },
  slice_lhs 1 2 { rw [←left_unitor_tensor_inv] },
  rw ←(cancel_epi (λ_ (𝟙_ C)).inv),
  slice_lhs 1 2 { rw [left_unitor_inv_naturality] },
  simp only [category.assoc],
end

lemma one_left_unitor {M : Mon_ C} :
  ((λ_ (𝟙_ C)).inv ≫ (𝟙 (𝟙_ C) ⊗ M.one)) ≫ (λ_ M.X).hom = M.one :=
by { slice_lhs 2 3 { rw left_unitor_naturality }, simp }

lemma one_right_unitor {M : Mon_ C} :
  ((λ_ (𝟙_ C)).inv ≫ (M.one ⊗ 𝟙 (𝟙_ C))) ≫ (ρ_ M.X).hom = M.one :=
by { slice_lhs 2 3 { rw [right_unitor_naturality, ←unitors_equal] }, simp }

variable [braided_category C]

lemma Mon_tensor_one_mul (M N : Mon_ C) :
    ((λ_ (𝟙_ C)).inv ≫ (M.one ⊗ N.one) ⊗ 𝟙 (M.X ⊗ N.X)) ≫
    tensor_μ C (M.X, N.X) (M.X, N.X) ≫ (M.mul ⊗ N.mul)
  = (λ_ (M.X ⊗ N.X)).hom :=
begin
  rw [←category.id_comp (𝟙 (M.X ⊗ N.X)), tensor_comp],
  slice_lhs 2 3 { rw [←tensor_id, tensor_μ_natural] },
  slice_lhs 3 4 { rw [←tensor_comp, one_mul M, one_mul N] },
  symmetry,
  exact tensor_left_unitality C M.X N.X,
end

lemma Mon_tensor_mul_one (M N : Mon_ C) :
    (𝟙 (M.X ⊗ N.X) ⊗ (λ_ (𝟙_ C)).inv ≫ (M.one ⊗ N.one)) ≫
    tensor_μ C (M.X, N.X) (M.X, N.X) ≫ (M.mul ⊗ N.mul)
  = (ρ_ (M.X ⊗ N.X)).hom :=
begin
  rw [←category.id_comp (𝟙 (M.X ⊗ N.X)), tensor_comp],
  slice_lhs 2 3 { rw [←tensor_id, tensor_μ_natural] },
  slice_lhs 3 4 { rw [←tensor_comp, mul_one M, mul_one N] },
  symmetry,
  exact tensor_right_unitality C M.X N.X,
end

lemma Mon_tensor_mul_assoc (M N : Mon_ C) :
    (tensor_μ C (M.X, N.X) (M.X, N.X) ≫ (M.mul ⊗ N.mul) ⊗ 𝟙 (M.X ⊗ N.X)) ≫
    tensor_μ C (M.X, N.X) (M.X, N.X) ≫
    (M.mul ⊗ N.mul)
  = (α_ (M.X ⊗ N.X) (M.X ⊗ N.X) (M.X ⊗ N.X)).hom ≫
    (𝟙 (M.X ⊗ N.X) ⊗ tensor_μ C (M.X, N.X) (M.X, N.X) ≫ (M.mul ⊗ N.mul)) ≫
    tensor_μ C (M.X, N.X) (M.X, N.X) ≫
    (M.mul ⊗ N.mul) :=
begin
  rw [←category.id_comp (𝟙 (M.X ⊗ N.X)), tensor_comp],
  slice_lhs 2 3 { rw [←tensor_id, tensor_μ_natural] },
  slice_lhs 3 4 { rw [←tensor_comp, mul_assoc M, mul_assoc N, tensor_comp, tensor_comp] },
  slice_lhs 1 3 { rw [tensor_associativity] },
  slice_lhs 3 4 { rw [←tensor_μ_natural] },
  slice_lhs 2 3 { rw [←tensor_comp, tensor_id] },
  simp only [category.assoc],
end

lemma mul_associator {M N P : Mon_ C} :
    (tensor_μ C (M.X ⊗ N.X, P.X) (M.X ⊗ N.X, P.X) ≫
      (tensor_μ C (M.X, N.X) (M.X, N.X) ≫ (M.mul ⊗ N.mul) ⊗ P.mul)) ≫
    (α_ M.X N.X P.X).hom
  = ((α_ M.X N.X P.X).hom ⊗ (α_ M.X N.X P.X).hom) ≫
    tensor_μ C (M.X, N.X ⊗ P.X) (M.X, N.X ⊗ P.X) ≫
    (M.mul ⊗ tensor_μ C (N.X, P.X) (N.X, P.X) ≫ (N.mul ⊗ P.mul)) :=
begin
  simp,
  slice_lhs 2 3 { rw [←category.id_comp P.mul, tensor_comp] },
  slice_lhs 3 4 { rw [associator_naturality] },
  slice_rhs 3 4 { rw [←category.id_comp M.mul, tensor_comp] },
  slice_lhs 1 3 { rw associator_monoidal },
  simp only [category.assoc],
end

lemma mul_left_unitor {M : Mon_ C}:
    (tensor_μ C (𝟙_ C, M.X) (𝟙_ C, M.X) ≫ ((λ_ (𝟙_ C)).hom ⊗ M.mul)) ≫ (λ_ M.X).hom
  = ((λ_ M.X).hom ⊗ (λ_ M.X).hom) ≫ M.mul :=
begin
  rw [←(category.comp_id (λ_ (𝟙_ C)).hom), ←(category.id_comp M.mul), tensor_comp],
  slice_lhs 3 4 { rw left_unitor_naturality },
  slice_lhs 1 3 { rw ←left_unitor_monoidal },
  simp only [category.assoc, category.id_comp],
end

lemma mul_right_unitor {M : Mon_ C} :
    (tensor_μ C (M.X, 𝟙_ C) (M.X, 𝟙_ C) ≫ (M.mul ⊗ (λ_ (𝟙_ C)).hom)) ≫ (ρ_ M.X).hom
  = ((ρ_ M.X).hom ⊗ (ρ_ M.X).hom) ≫ M.mul :=
begin
  rw [←(category.id_comp M.mul), ←(category.comp_id (λ_ (𝟙_ C)).hom), tensor_comp],
  slice_lhs 3 4 { rw right_unitor_naturality },
  slice_lhs 1 3 { rw ←right_unitor_monoidal },
  simp only [category.assoc, category.id_comp],
end

instance Mon_monoidal : monoidal_category (Mon_ C) :=
{ tensor_obj := λ M N,
  { X := M.X ⊗ N.X,
    one := (λ_ (𝟙_ C)).inv ≫ (M.one ⊗ N.one),
    mul := tensor_μ C (M.X, N.X) (M.X, N.X) ≫ (M.mul ⊗ N.mul),
    one_mul' := Mon_tensor_one_mul M N,
    mul_one' := Mon_tensor_mul_one M N,
    mul_assoc' := Mon_tensor_mul_assoc M N },
  tensor_hom := λ M N P Q f g,
  { hom := f.hom ⊗ g.hom,
    one_hom' :=
    begin
      dsimp,
      slice_lhs 2 3 { rw [←tensor_comp, hom.one_hom f, hom.one_hom g] },
    end,
    mul_hom' :=
    begin
      dsimp,
      slice_rhs 1 2 { rw [tensor_μ_natural] },
      slice_lhs 2 3 { rw [←tensor_comp, hom.mul_hom f, hom.mul_hom g, tensor_comp] },
      simp only [category.assoc],
    end },
  tensor_id' := by { intros, ext, apply tensor_id },
  tensor_comp' := by { intros, ext, apply tensor_comp },
  tensor_unit := trivial C,
  associator := λ M N P, iso_of_iso (α_ M.X N.X P.X) one_associator mul_associator,
  associator_naturality' := by { intros, ext, dsimp, apply associator_naturality },
  left_unitor := λ M, iso_of_iso (λ_ M.X) one_left_unitor mul_left_unitor,
  left_unitor_naturality' := by { intros, ext, dsimp, apply left_unitor_naturality },
  right_unitor := λ M, iso_of_iso (ρ_ M.X) one_right_unitor mul_right_unitor,
  right_unitor_naturality' := by { intros, ext, dsimp, apply right_unitor_naturality },
  pentagon' := by { intros, ext, dsimp, apply pentagon },
  triangle' := by { intros, ext, dsimp, apply triangle } }

end Mon_

/-!
Projects:
* Check that `Mon_ Mon ≌ CommMon`, via the Eckmann-Hilton argument.
  (You'll have to hook up the cartesian monoidal structure on `Mon` first, available in #3463)
* Check that `Mon_ Top ≌ [bundled topological monoids]`.
* Check that `Mon_ AddCommGroup ≌ Ring`.
  (We've already got `Mon_ (Module R) ≌ Algebra R`, in `category_theory.monoidal.internal.Module`.)
* Can you transport this monoidal structure to `Ring` or `Algebra R`?
  How does it compare to the "native" one?
* Show that when `C` is braided, the forgetful functor `Mon_ C ⥤ C` is monoidal.
* Show that when `F` is a lax braided functor `C ⥤ D`, the functor `map_Mon F : Mon_ C ⥤ Mon_ D`
  is lax monoidal.
-/


import smt.veriT

example {x y : ℤ} (h1 : ((x - y) = (x + (- y) + 1)))
 : false :=
begin
  veriT,
end


import category_theory.preadditive
import category_theory.arrow

-- TODO : generalize to comma categories?

namespace category_theory

variables {A : Type*} [category A] [preadditive A]

local attribute [simp] preadditive.comp_nsmul preadditive.nsmul_comp
    preadditive.comp_zsmul preadditive.zsmul_comp

instance arrow.has_zero (P Q : arrow A) : has_zero (P ⟶ Q) :=
⟨arrow.hom_mk (show 0 ≫ Q.hom = P.hom ≫ 0, by simp)⟩
instance arrow.has_add (P Q : arrow A) : has_add (P ⟶ Q) :=
⟨λ f g, arrow.hom_mk (show (f.left + g.left) ≫ Q.hom = P.hom ≫ (f.right + g.right), by simp)⟩
instance arrow.has_neg (P Q : arrow A) : has_neg (P ⟶ Q) :=
⟨λ f, arrow.hom_mk (show (-f.left) ≫ Q.hom = P.hom ≫ (-f.right), by simp)⟩
instance arrow.has_sub (P Q : arrow A) : has_sub (P ⟶ Q) :=
⟨λ f g, arrow.hom_mk (show (f.left - g.left) ≫ Q.hom = P.hom ≫ (f.right - g.right), by simp)⟩
instance arrow.has_nsmul (P Q : arrow A) : has_smul ℕ (P ⟶ Q) :=
⟨λ n f, arrow.hom_mk (show (n • f.left) ≫ Q.hom = P.hom ≫ (n • f.right), by simp)⟩
instance arrow.has_zsmul (P Q : arrow A) : has_smul ℤ (P ⟶ Q) :=
⟨λ n f, arrow.hom_mk (show (n • f.left) ≫ Q.hom = P.hom ≫ (n • f.right), by simp)⟩
.
@[simp] lemma arrow.has_add_left {P Q : arrow A} (f g : P ⟶ Q) :
  (f + g).left = f.left + g.left := rfl
@[simp] lemma arrow.has_add_right {P Q : arrow A} (f g : P ⟶ Q) :
  (f + g).right = f.right + g.right := rfl
@[simp] lemma arrow.has_neg_left {P Q : arrow A} (f : P ⟶ Q) :
  (-f).left = -(f.left) := rfl
@[simp] lemma arrow.has_neg_right {P Q : arrow A} (f : P ⟶ Q) :
  (-f).right = -(f.right) := rfl
@[simp] lemma arrow.has_sub_left {P Q : arrow A} (f g : P ⟶ Q) :
  (f - g).left = f.left - g.left := rfl
@[simp] lemma arrow.has_sub_right {P Q : arrow A} (f g : P ⟶ Q) :
  (f - g).right = f.right - g.right := rfl

instance arrow.add_comm_group (P Q : arrow A) : add_comm_group (P ⟶ Q) :=
{ add_assoc := λ f g h, by ext; apply add_assoc,
  zero_add := λ f, by ext; apply zero_add,
  add_zero := λ f, by ext; apply add_zero,
  add_left_neg := λ f, by ext; apply add_left_neg,
  add_comm := λ f g, by ext; apply add_comm,
  ..arrow.has_add P Q,
  ..arrow.has_zero P Q,
  ..arrow.has_neg P Q,
  ..arrow.has_nsmul P Q,
  ..arrow.has_zsmul P Q }
.
instance arrow.preadditive : preadditive (arrow A) :=
⟨infer_instance, by { introv P, ext; apply preadditive.add_comp },
  by { introv P, ext; apply preadditive.comp_add }⟩

end category_theory