import Duper.Tactic
import Duper.TPTP

-- set_option trace.Meta.debug true
-- set_option trace.Prover.saturate true
-- set_option trace.Prover.debug true
-- set_option pp.all true
-- set_option pp.rawOnError true

axiom a : Nat
axiom b : Nat
axiom c : Nat
axiom d : Nat
axiom zero : Nat
axiom one : Nat
axiom div : Nat → Nat → Nat
axiom mul : Nat → Nat → Nat
axiom add : Nat → Nat → Nat
axiom inv : Nat → Nat
axiom f : Nat → Nat
axiom g : Nat → Nat
axiom h : Nat → Nat
axiom p : Nat → Prop
axiom q : Prop
axiom isZero : Nat → Prop

theorem test0000 (one : Nat) (isZero : Nat → Prop) (div mul add : Nat → Nat → Nat)
(div_self : ∀ x, ¬ isZero x → div x x = one)
(add_mul : ∀ (x y z : Nat), mul (add x y) z = add (mul x z) (mul y z))
(div_def : ∀ (x y : Nat), ¬ isZero y → div x y = mul x (inv y)) :
∀ (x y : Nat), ¬ isZero y → div (add x y) y = add (div x y) one := by duper
#print axioms test0000

-- Contradiction found. Time: 647ms
theorem test0018 (a1 a2 a3 a4 a5 a6 : Nat)
(h1 :
f (f (f (f (f (f (f (f a5))))))) = d ∨
f (f (f (f (f (f (f a4)))))) = d ∨
f (f (f (f (f (f a3))))) = d ∨
f (f (f (f (f a2)))) = d ∨
f (f (f (f a1))) = d ∨
f (f (f a)) = d ∨ f (f b) = d ∨ f c = d)
(h2 : f (f (f (f (f (f (f (f a5))))))) ≠ d)
(h2 : f (f (f (f (f (f (f a4)))))) ≠ d)
(h2 : f (f (f (f (f (f a3))))) ≠ d)
(h2 : f (f (f (f (f a2)))) ≠ d)
(h2 : f (f (f (f a1))) ≠ d)
(h2 : f (f (f a)) ≠ d)
(h3 : f (f b) ≠ d)
(h4 : f c ≠ d)
: False := by duper

#print test0018

theorem test00008
(div_self : ∀ x, x ≠ zero → mul x (inv x) = one)
(add_mul : ∀ (x y z : Nat), mul (add x y) z = add (mul x z) (mul y z)) :
∀ (x y : Nat), y ≠ zero → mul (add x y) (inv y) = add (mul x (inv y)) one := by duper

theorem test00008'
(div_self : ∀ x, x ≠ zero → div x x = one)
(add_mul : ∀ (x y z : Nat), mul (add x y) z = add (mul x z) (mul y z))
(div_def : ∀ (x y : Nat), y ≠ zero → div x y = mul x (inv y)) :
∀ (x y : Nat), y ≠ zero → mul (add x y) (inv y) = add (mul x (inv y)) one := by duper

theorem test
(div_self : ∀ x, div x x = one)
(add_mul : ∀ (x y z : Nat), mul (add x y) z = add (mul x z) (mul y z))
(div_def : ∀ (x y : Nat), div x y = mul x (inv y)) :
∀ (x y : Nat), div (add x y) y = add (div x y) one := by duper

-- #print test
-- #print axioms test

example --(h : ∃ x, x ≠ c ∨ a = b)
(h : ¬ ∃ x, x = f a ∨ ∀ x, ∃ y, y = f a ∧ x = b)-- (h :  c = b ∧ a = b)
: False := by duper

set_option trace.Meta.debug true in
theorem test00
(ax1 : a ≠ a ∨ ¬ (∀ x : Nat, x = x) ∨ b ≠ b)
: False := by duper

#print test00

theorem test0
(ax1 : f a = b → f c ≠ b)
(ax2 : ¬ ∃ x, f x ≠ b ∧ c = c)
: False := by duper

#print test0

theorem test1
(div_self : ∀ x, f x = a)
(div_self : ∀ x, f x ≠ a)
: False := by duper

#print test1

theorem test1'
(div_self : ∀ x y z : Nat, f x ≠ f x ∨ g y ≠ g y ∨ h z ≠ h z)
: False := by duper

theorem test2
: ∀ (x : Nat), x = x := by duper

#print test2

theorem puzzle1 {ι : Type} (johanna : ι) (bill : ι) (peanuts : ι)
  (food : ι → Prop) (alive : ι → Prop)
  (likes : ι → ι → Prop) (eats : ι → ι → Prop) (was_killed_by : ι → ι → Prop)
  (h1 : ∀ x, food x → likes johanna x)
  (h2 : ∀ x, (∃ y, eats y x ∧ ¬ was_killed_by y x) → food x)
  (h3 : eats bill peanuts)
  (h4 : alive bill)
  (h5 : ∀ y, alive y → ∀ x, ¬ was_killed_by y x) :
likes johanna peanuts := by duper

#print puzzle1

#print axioms puzzle1

/- Leaving this test commented out because we expect it to time out
set_option maxHeartbeats 10000 in
theorem puzzle2 {ι : Type} (Tarr : ι) (Fether : ι)
  (Doctor : ι → Prop) (Peculiar : ι → Prop) (Sane : ι → Prop)
  (bestFriend : ι → ι) (Special : ι → Prop)
  (h4 : ∀x, Peculiar x = (Sane x = ¬ Doctor x))
  (h5 : ∀x, Special x = (∀y, ¬ Doctor y = (Sane y = Peculiar x)))
  (h7 : ∀x, ∀y, (Sane x = Special y) → (Sane (bestFriend x) = ¬ Doctor y))
  (h8 : Sane Tarr = ∀x, Doctor x → Sane x)
  (h10 : Sane Fether = ∀x, Doctor x → ¬ Sane x)
  (h12 : Sane Fether = Sane Tarr) :
False := by duper
-/

-- Time 29717ms
theorem test0011 (one : Nat) (div mul add : Nat → Nat → Nat)
(div_self : ∀ x, div x x = one)
(add_mul : ∀ (x y z : Nat), mul (add x y) z = add (mul x z) (mul y z))
(div_def : ∀ (x y : Nat), div x y = mul x (inv y)) :
∀ (x y : Nat), div (add x y) y = add (div x y) one := by duper
#print test0011
#print axioms test0011

--###############################################################################################################################
--Clausifying prop inequality tests
theorem propInequalityTest1 {p : Prop} {q : Prop} (h : p ≠ q) : p ∨ q :=
  by duper

theorem propInequalityTest2 {p : Prop} {q : Prop} (h : p ≠ q) : ¬p ∨ ¬q :=
  by duper

#print propInequalityTest1 -- clause 4 uses clausify_prop_inequality2
#print axioms propInequalityTest1
#print propInequalityTest2 -- clause 3 uses clausify_prop_inequality1
#print axioms propInequalityTest2

--###############################################################################################################################
--Iff clausification tests
theorem iffClausificationTest1 {p : Prop} {q : Prop} (h : p ↔ q) : (p → q) ∧ (q → p) :=
  by duper

theorem iffClausificationTest2 {p : Prop} {q : Prop} (h : ¬(p ↔ q)) : (p → ¬q) ∧ (q → ¬p) :=
  by duper

#print iffClausificationTest1
#print iffClausificationTest2
#print axioms iffClausificationTest1
#print axioms iffClausificationTest2
--###############################################################################################################################
--Aside from being an interesting thing to prove on its own, the barber_paradox tests rely on the first case of Iff clausification and
--on the soundness of ClausifyPropEq's reconstructed proofs
/-
List of problems pertaining to the barber paradox:
- Duper is unable to synthesize the type "Inhabited person" unless it is given an argument of that type or an argument of type person
- General issues with using duper in larger tactic-style proofs (mdata isn't handled properly)
-/

set_option trace.Meta.debug true in
theorem barber_paradox1 {person : Type} {person_inhabited : Inhabited person} {shaves : person → person → Prop}
  (h : ∃ b : person, ∀ p : person, (shaves b p ↔ (¬ shaves p p))) : False :=
  by duper

theorem barber_paradox2 {person : Type} {shaves : person → person → Prop} {b : person}
  (h : ∀ p : person, (shaves b p ↔ (¬shaves p p))) : False :=
  by duper

theorem barber_paradox3 {person : Type} {shaves : person → person → Prop} {b : person}
  (h1 : ∀ p : person, (shaves b p ↔ (¬ shaves p p))) (h2 : shaves b b ∨ ¬ shaves b b) : False :=
  by duper

theorem barber_paradox4 {person : Type} {person_inhabited : Inhabited person} {shaves : person → person → Prop}
  (h : ∃ b : person, ∀ p : person, (shaves b p → (¬ shaves p p)) ∧ ((¬ shaves p p) → shaves b p)) : False :=
  by duper

theorem barber_paradox5 {person : Type} {shaves : person → person → Prop} {b : person}
  (h : shaves b b ↔ ¬shaves b b) : False :=
  by duper

#print barber_paradox1
#print axioms barber_paradox1
#print axioms barber_paradox2
#print axioms barber_paradox3
#print axioms barber_paradox4
#print axioms barber_paradox5

--inline tests are to expose the issues that arise when we try to call duper in the midst of a larger tactic-style proof
theorem barber_paradox_inline0 {person : Type} {person_inhabited : Inhabited person} {shaves : person → person → Prop}
  (h : ∃ b : person, ∀ p : person, (shaves b p → (¬ shaves p p)) ∧ ((¬ shaves p p) → shaves b p)) : False := by
  cases h with
  | intro b h' =>
    duper

theorem barber_paradox_inline1 {person : Type} {shaves : person → person → Prop}
  (h : ∃ b : person, ∀ p : person, (shaves b p ↔ (¬ shaves p p))) : False := by
  cases h with
  | intro b h' =>
    duper

theorem barber_paradox_inline2 {person : Type} {shaves : person → person → Prop}
  (h : ∃ b : person, ∀ p : person, (shaves b p ↔ (¬ shaves p p))) : False := by
  cases h with
  | intro b h' =>
    have h'_b := h' b
    duper

theorem barber_paradox_inline3 {person : Type} {shaves : person → person → Prop}
  (h : ∃ b : person, ∀ p : person, (shaves b p ↔ (¬ shaves p p))) : False := by
  cases h with
  | intro b h' =>
    have h'_b := h' b
    clear h'
    duper

#print barber_paradox_inline0
#print axioms barber_paradox_inline0
#print axioms barber_paradox_inline1
#print axioms barber_paradox_inline2
#print axioms barber_paradox_inline3

--###############################################################################################################################
-- syntacticTautologyDeletion2 and elimResolvedLit tests
/-
Prover becomes saturated as expected, but the point is just to confirm that trace.Simp.debug is printing that the correct clause is being removed
for the correct reason

theorem syntacticTautologyDeletionTest {t : Type} (a : t) (b : t) (c : t)
  (h : a = b ∨ a = c ∨ b ≠ a) : False := by duper
-/

theorem elimResolvedLitTest {t : Type} (a : t) (b : t) (c : t)
  (h : a = b ∨ a = c ∨ b ≠ b) : a = b ∨ a = c := by duper

theorem elimResolvedLitTest2 {t : Type} (a : t) (b : t) (c : t)
  (h : b ≠ b ∨ a = b ∨ a ≠ a ∨ a = c ∨ b ≠ b ∨ c ≠ c) : a = b ∨ a = c := by duper

theorem elimResolvedLitTest3 {t : Type} (a : t) (b : t) (c : t)
  (h : a ≠ a ∨ b ≠ b ∨ c ≠ c) : a = a ∨ b = b ∨ c = c := by duper

#print elimResolvedLitTest
#print axioms elimResolvedLitTest
#print axioms elimResolvedLitTest2
#print axioms elimResolvedLitTest3

--###############################################################################################################################
-- equalityFactoring tests (Trying to test each equality_factoring_soundness theorem)

theorem equalityFactoringTest1 {α : Type} (s t u v : α)
  (h1 : s = t ∨ s = v) : t ≠ v ∨ s = v :=
  by duper

theorem equalityFactoringTest2 {α : Type} (s t u v : α)
  (h1 : s = t ∨ u = s) : t ≠ u ∨ u = s :=
  by duper

theorem equalityFactoringTest3 {α : Type} (s t v : α)
  (h1 : s = t ∨ t = v) : s ≠ v ∨ t = v :=
  by duper

/-
  Note to self: The only difference between equalityFactoringTest3 and equalityFactoringTest4 is the order of s t and v as arguments. This fact influences
  something in how they are compared to each other in Order.lean (I think it has an effect on VarBalance), which is why equalityFactoringTest3 uses
  equality_factoring_soundness2 and equalityFactoringTest4 uses equality_factoring_soundness4
-/
theorem equalityFactoringTest4 {α : Type} (v t s : α)
  (h1 : s = t ∨ t = v) : s ≠ v ∨ t = v :=
  by duper

theorem equalityFactoringTest5 {α : Type} (s t u v : α)
  (h1 : s = t ∨ u = t) : s ≠ u ∨ u = t :=
  by duper

#print equalityFactoringTest1 -- This proof uses equality_factoring_soundness1 (in the commit where this test is added, it is used in clause 5)
#print equalityFactoringTest2 -- This proof uses equality_factoring_soundness2 (in the commit where this test is added, it is used in clause 13)
#print equalityFactoringTest3 -- This proof uses equality_factoring_soundness2 (again) (in the commit where this test is added, it is used in clause 5)
#print equalityFactoringTest4 -- This proof uses equality_factoring_soundness3 (in the commit where this test is added, it is used in clause 5)
#print equalityFactoringTest5 -- This proof uses equality_factoring_soundness4 (in the commit where this test is added, it is used in clause 5)

#print axioms equalityFactoringTest1
#print axioms equalityFactoringTest2
#print axioms equalityFactoringTest3
#print axioms equalityFactoringTest4
#print axioms equalityFactoringTest5

--###############################################################################################################################
-- This test previously failed due to a bug in how we removed clauses
theorem removeClausesTest {α : Type} [Inhabited α] (x y : α) (c : α → Prop)
  (h1 : ∀ a b : α, a = b) : c x = c y := by duper

--###############################################################################################################################
theorem COM002_2_test (state : Type) (follows fails : state → state → Prop) (p3 p6 : state)
  (h0 : ∀ (Start_state Goal_state : state), ¬(fails Goal_state Start_state ∧ follows Goal_state Start_state))
  (h1 : follows p6 p3) : ¬fails p6 p3 := by duper

theorem COM002_2_test2 (state label statement : Type) (p8 : state) (loop : label) (goto : label → statement)
  (follows fails : state → state → Prop) (labels : label → state → Prop) (has : state → statement → Prop)
  (h0 : ∀ s1 s2 : state, ∀ l1 : label, ¬(fails s1 s2 ∧ has s2 (goto l1) ∧ labels l1 s1))
  (h1 : has p8 (goto loop)) : ∀ s1 : state, ¬(fails s1 p8 ∧ labels loop s1) := by duper

/- Saturates because the goal is "False" rather than anything coherent, but the final active set is:
[fails p3 #0 = True ∨ fails #0 p3 = True,
 fails #2 #1 = False ∨ has #1 (goto #0) = False ∨ labels #0 #2 = False,
 has p3 (goto #0) = False ∨ labels #0 p3 = False,
 has p3 (goto #1) = False ∨ labels #1 #0 = False ∨ fails p3 #0 = True,
 fails p3 #1 = True ∨ has p3 (goto #0) = False ∨ labels #0 #1 = False,
 has #1 (goto #0) = False ∨ labels #0 p3 = False ∨ fails #1 p3 = True,
 fails #1 p3 = True ∨ has #1 (goto #0) = False ∨ labels #0 p3 = False,
 has #2 (goto #1) = False ∨ labels #1 p3 = False ∨ has p3 (goto #0) = False ∨ labels #0 #2 = False,
 fails p3 p3 = True]

theorem COM002_2_test3 (state label statement : Type) (p3 : state) (goto : label → statement)
  (follows fails : state → state → Prop) (labels : label → state → Prop) (has : state → statement → Prop)
  (h0 : ∀ s1 s2 : state, ∀ l1 : label, ¬(fails s1 s2 ∧ has s2 (goto l1) ∧ labels l1 s1))
  (h1 : ∀ s : state, fails p3 s ∨ fails s p3) : False := by duper
-/

--###############################################################################################################################
tptp KRS003_1 "../TPTP-v8.0.0/Problems/KRS/KRS003_1.p"
  by duper

#print axioms KRS003_1

tptp PUZ012_1 "../TPTP-v8.0.0/Problems/PUZ/PUZ012_1.p"
  by duper

#print PUZ012_1
--###############################################################################################################################
-- Tests that (in the current commit at least) use positive simplify reflect
set_option trace.Rule.simplifyReflect true in
tptp NUN004_5 "../TPTP-v8.0.0/Problems/NUN/NUN004_5.p"
  by duper

set_option trace.Rule.simplifyReflect true in
tptp ITP209_2 "../TPTP-v8.0.0/Problems/ITP/ITP209_2.p"
  by duper

--###############################################################################################################################
-- Example from super
theorem super_test (p q : i → i → Prop) (a b c d : i) :
  (∀x y z, p x y ∧ p y z → p x z) →
  (∀x y z, q x y ∧ q y z → q x z) →
  (∀x y, q x y → q y x) →
  (∀x y, p x y ∨ q x y) →
  p a b ∨ q c d :=
by duper

--###############################################################################################################################
-- Miscellaneous tests
example (h : ∀ a, ∀ b, ∀ c, ∃ d, f a = b ∧ g c = d) :
  ∀ a, ∀ b, ∀ c, ∃ d, f a = b ∧ g c = d := by duper

-- Checks that duper can handle existential quantification where the variable doesn't appear in the body
example (h : ∃ y : Nat, False) : False := by duper
example (h : (∃ y : Nat, True) = False) : False := by duper

-- Checks that duper can handle universal quantification where the variable doesn't appear in the body
example (h : ∀ y : Nat, False) : False := by duper
example (h : (∀ y : Nat, True) = False) : False := by duper

--###############################################################################################################################
-- Tests for providing facts to duper
theorem add_assoc : ∀ x : Nat, ∀ y : Nat, ∀ z : Nat, (x + y) + z = x + (y + z) := sorry
theorem one_add_one_eq_two : 1 + 1 = 2 := by simp
theorem two_add_two_eq_four : 2 + 2 = 4 := by simp

theorem test_duper_with_fact : 1 + 1 = 2 := by duper [one_add_one_eq_two]
theorem test_duper_with_facts : 1 + 1 + 1 + 1 = 4 := by duper [one_add_one_eq_two, two_add_two_eq_four, add_assoc]

--###############################################################################################################################
-- Hoist tests (note: forallHoist and existsHoist are only truly tested if identBoolHoist is diabled)

set_option trace.Print_Proof true in
theorem eqHoistTest (a b : Nat) (f : Prop → Prop) (h : f (a = b)) : ∃ p : Prop, f p :=
  by duper

set_option trace.Print_Proof true in
theorem neHoistTest (a b : Nat) (f : Prop → Prop) (h : f (a ≠ b)) : ∃ p : Prop, f p :=
  by duper

set_option trace.Print_Proof true in
theorem existsHoistTest1 (f : Prop → Nat) : f (∃ (x : Nat), x = Nat.zero) = f True := by duper

set_option trace.Print_Proof true in
set_option trace.Rule.existsHoist true in
theorem existsHoistTest2 (f : Prop → Nat) : ∀ y : Nat, f (∃ x : Nat, x = y) = f True := by duper

set_option trace.Print_Proof true in
set_option trace.Rule.existsHoist true in
theorem existsHoistTest3 (f : Prop → Nat) (h : ∀ z : Nat, ∀ y : Nat, f (∃ x : Nat, (x = y ∧ x = z)) ≠ f True) : False := by duper

set_option trace.Print_Proof true in
theorem existsHoistTest4 (f : Prop → Nat)
  (h : ∀ x : Nat, f (∃ y : Nat, ∀ a : Nat, ∃ b : Nat, x = y ↔ a = b) ≠ f True) : False := by duper

set_option trace.Print_Proof true in
theorem existsHoistTest5 (f : Prop → Nat)
  (h : ∀ x : Nat, ∃ y : Nat, f ((∃ z : Nat, z = x) ∧ (∃ z : Nat, z = y)) ≠ f True) : False := by duper

set_option trace.Print_Proof true in
set_option trace.Rule.existsHoist true in
theorem existsHoistTest6 (f : Prop → Nat) : ∀ y : Nat, f (∃ x : Nat, 0 = 0) = f True := by duper

set_option trace.Print_Proof true in
set_option trace.Rule.existsHoist true in
theorem existsHoistTest7 (f : Prop → Nat) : ∀ y : Nat, f (∃ x : Nat, y = y) = f True := by duper

set_option trace.Print_Proof true in
theorem forallHoistTest1 (f : Prop → Nat) : f (∀ (x : Nat), x ≠ Nat.zero) = f False := by duper

set_option trace.Print_Proof true in
theorem forallHoistTest2 (f : Prop → Nat)
  (h : ∀ x : Nat, f (∀ y : Nat, x = y) ≠ f False) : False := by duper

set_option trace.Print_Proof true in
theorem forallHoistTest3 (f : Prop → Nat)
  (h : ∃ x : Nat, f (∀ y : Nat, x = y) ≠ f False) : False := by duper

set_option trace.Print_Proof true in
theorem forallHoistTest4 (f : Prop → Nat)
  (h : ∀ x : Nat, ∀ y : Nat, f (∀ z : Nat, x = z ↔ y = z) ≠ f False) : False := by duper

set_option trace.Print_Proof true in
theorem forallHoistTest5 (f : Prop → Nat)
  (h : ∀ x : Nat, ∃ y : Nat, f (∀ z : Nat, x = z ∧ y = z) ≠ f False) : False := by duper

--###############################################################################################################################
-- Tests that were previously in bugs.lean
example (f : Prop → Nat) :
  f (∀ (x : Nat), x ≠ Nat.zero) = f False := by duper

example (f : Prop → Nat) :
  f (f (∀ (x : Nat), x ≠ Nat.zero) = f False) = f True := by duper

example (f g : Nat → Nat) (h : ∀ a, ∃ d, f a = d) :
  ∀ a, ∃ d, f a = d := by duper

set_option trace.Meta.debug true in
example : ((∀ (f : Nat → Nat) (x : Nat), f x = f x) = True) := by duper

example : ((∃ (A B : Type) (f : B → A) (x : B), f x = f x) = True) :=
  by duper

example : ∃ (A : Type) (B : A → Type) (f : ∀ (a : A), B a) (x : A), (f x = f x) = True :=
  by duper

example (A : Type) (x : A) : (∃ x : A, x = x) := by duper

example (x : Type u) (f g : Type u → Type v) (H : f = g) : f x = g x :=
  by duper

example (x y z : Type u) (f g : Type u → Type u → Type u → Type v) (H : f = g) : f x y z = g x y z :=
  by duper

tptp PUZ137_8 "../TPTP-v8.0.0/Problems/PUZ/PUZ137_8.p"
  by duper

tptp PUZ031_1_modified "../TPTP-v8.0.0/Problems/PUZ/PUZ031_1.p" by
  have inhabited_plant : Inhabited plant := sorry
  have inhabited_snail : Inhabited snail := sorry
  have inhabited_grain : Inhabited grain := sorry
  have inhabited_bird : Inhabited bird := sorry
  have inhabited_fox : Inhabited fox := sorry
  have inhabited_wolf : Inhabited wolf := sorry
  have inhabited_animal : Inhabited animal := sorry
  have inhabited_caterpillar : Inhabited caterpillar := sorry
  duper
  -- If these instances are not provided, duper will fail

tptp SEU123 "../TPTP-v8.0.0/Problems/SEU/SEU123+1.p"
  by duper

set_option trace.Rule.superposition true in
tptp SEU139 "../TPTP-v8.0.0/Problems/SEU/SEU139+1.p"
  by duper

/- BoolSimp tests -/

theorem boolSimpRule26TestDep₁ (a b y z r : Prop) (dep : a → Prop) (h : ((x : a) → b → dep x → (dep x ∨ y ∨ z)) = r) : r :=
  by duper

theorem boolSimpRule27TestDep₁ (a b c y z r : Prop) (f : a ∧ b ∧ c → Prop) (h : ((x : a ∧ b ∧ c) → (y ∨ f x ∨ c ∨ z)) = r) : r :=
  by duper

/- Negative BoolSimp tests -/

namespace NegativeBoolSimpTests

axiom f.{u} : Sort u → Nat

def neg₁ : (f (Nat → Nat) = f (Nat → Nat)) := by duper

-- A positive example
def pos₁ : (f (Nat → False) = f False) := by duper

axiom g.{u} : ∀ (α : Sort u), α → Nat

def neg₂ : g (Nat → True) (fun _ => True.intro) = g (Nat → True) (fun _ => True.intro) :=
  by duper

def neg3 : g (True → True) (fun _ => True.intro) = g (True → True) (fun _ => True.intro) :=
  by duper

end NegativeBoolSimpTests

/- ClauseStreamHeap tests -/

tptp MGT008 "../TPTP-v8.0.0/Problems/MGT/MGT008+1.p"
  by duper

example (f : Nat → Nat → Nat → Nat → Nat → Nat → Nat → Nat)
  (g : Nat → Nat → Nat → Nat → Nat → Nat)
  (inertia : TPTP.iota → TPTP.iota → TPTP.iota → Prop)
  (goodInertia goodChance : TPTP.iota → Prop)
  (organization: TPTP.iota → TPTP.iota → Prop)
  -- good inertia implies good survival chance
  (dummy: ∀ (Y T2 I2 P2 : TPTP.iota), organization Y T2 ∧ inertia Y I2 T2 ∧ goodInertia I2 → goodChance P2)
  : ∃ x : Nat,
       f (g x x x x x) (g x 1 x x x) (g x x x x x) (g x 1 x x x) (g x x x x x) (g x 1 x x x) (g x x x x x)
     = f (g 1 x x x x) (g x x x x x) (g x 1 x x x) (g x x x x x) (g x 1 x x x) (g x x x x x) (g x 1 x x x) :=
  by duper

example
(inertia : TPTP.iota → TPTP.iota → TPTP.iota → Prop)
(goodInertia goodChance : TPTP.iota → Prop)
(dummy: TPTP.iota → TPTP.iota → TPTP.iota → TPTP.iota → Prop)
(organization: TPTP.iota → TPTP.iota → Prop)
(h1: ∀ (X T : TPTP.iota), organization X T → ∃ I, inertia X I T)
(h2: ∀ (Y I2 T2 : TPTP.iota),
-- good size implies good inertia
  organization Y T2 → inertia Y I2 T2 →
    goodInertia I2)
-- good inertia implies good survival chance
(h3: ∀ (Y T2 I2 P2 : TPTP.iota),
  (((organization Y T2 ∧ inertia Y I2 T2))) ∧
      goodInertia I2 →
    goodChance P2)
-- to show: good size implies good survival chance
(h4: ¬∀ (X Y P1 P2 S2 T1 T2 : TPTP.iota),
    organization Y T2 → dummy X P1 T1 S2 →
      goodChance P2) : False := by duper


import seplog.a_lang
import utils             -- join, pairmap/alist things
import data.finmap
import order.basic
import logic.function.basic

section heaps
  open TypeDecl open Val

  -- Memory addresses are just represented as integers
  @[derive decidable_eq]
  structure Address := (val: ℤ)

  def to_z (a:Address): ℤ := a.val

  /-
   - Bijection which can be used to transport lemmas about integers
   -/
  def bij_address: equiv Address ℤ :=
    { to_fun := to_z,
      inv_fun := Address.mk,
      left_inv := by {rintro ⟨n⟩, refl},
      right_inv := by {intro n, refl}}

  lemma to_z_inj: function.injective to_z := bij_address.injective

  def val2loc: Π {t}, option (Val (gPtr t)) → option (Address)
   | _ (some (pPtr _ p)) := p >>= (λ i, some ⟨i⟩)
   | _ none              := none

  def str_address (a: Address): string := to_string a.val

  instance: has_to_string Address := ⟨str_address⟩
  instance: has_repr Address      := ⟨str_address⟩
  instance: has_zero Address      := ⟨Address.mk 0⟩
  instance: has_one Address       := ⟨Address.mk 1⟩
  instance: has_add Address       := ⟨λ x y, ⟨x.val + y.val⟩⟩

  -- Heap is a map from address to Go values
  @[derive decidable_eq]
  structure Heap :=
    (vals: finmap (λ _: Address, Σ dt: TypeDecl, Val dt))

  /-
   - Bijection which can be used to transport lemmas about finmaps
   -/
  def bij_heap : equiv Heap
                      (finmap (λ _: Address, Σ dt: TypeDecl, Val dt)) :=
    { to_fun    := λ h, h.vals,
      inv_fun   := Heap.mk,
      left_inv  := by {rintro ⟨n⟩, refl},
      right_inv := by {intro n, refl}}

  @[simp]
  def Heap.emp : Heap := ⟨∅⟩
  instance: has_emptyc Heap := ⟨Heap.emp⟩
  instance: inhabited Heap := ⟨Heap.emp⟩

  def Heap.singleton  {dt: TypeDecl} (a: Address) (v: Val dt): Heap:=
    ⟨finmap.singleton a ⟨dt, v⟩⟩

  def Heap.lookup  {t: TypeDecl} (h: Heap)
                   (p: Address): option (Val t)
      := h.vals.lookup p >>= λ ⟨_,v⟩, as_type v t

  def Heap.update (s: Heap) {t: TypeDecl}
                  (v: Val t) (key: Address): Heap :=
      ⟨s.vals.insert key ⟨t,v⟩⟩

  def Heap.erase (h: Heap)(p: Address): Heap := ⟨h.vals.erase p ⟩

  @[simp]
  def Heap.disjoint (a: Heap) (b:Heap): Prop := a.vals.disjoint b.vals
  notation x ` # ` e  := (Heap.disjoint x e) -- **

  def Heap.append  (a b: Heap): Heap :=
    ⟨a.vals.union b.vals⟩
  instance heap_append: has_append (Heap):= ⟨Heap.append⟩

  instance: decidable_linear_order Address :=
    decidable_linear_order.lift to_z to_z_inj

  /-
   - Inserts into an unused address. Returns updated Heap and the fresh address.
   - Because pointers default to zero, we make the minimum value equal to 1 so
   - that nothing gets accidentally pointed to.
   -/
  def Heap.insert (s: Heap) (t: TypeDecl) (v: Val t): Heap × Address :=
    let p := (s.vals.keys.max.elim 1 (λ a, a+1)) in
        (@Heap.update s t v p, p)

  meta def str_heap (h: Heap): string := show_finmap h.vals

  meta instance: has_to_string Heap:= ⟨str_heap⟩
  meta instance: has_repr Heap:= ⟨str_heap⟩

  lemma emp_disjoint: ∀ h: Heap, ∅ # h := begin
    intros, simp, apply finmap.disjoint_empty,
  end

end heaps

section stores

  @[derive decidable_eq]
  structure Store :=
    (vals: finmap (λ _: string, Σ dt: TypeDecl, Val dt))

  /-
   - Bijection which can be used to transport lemmas about finmaps
   -/
  def bij_store: equiv Store
                       (finmap (λ _: string, Σ dt: TypeDecl, Val dt)) :=
  { to_fun    := λ h, h.vals,
    inv_fun   := Store.mk,
    left_inv  := by {rintro ⟨n⟩, refl},
    right_inv := by {intro n, refl}}

  def Store.emp: Store := ⟨∅⟩
  instance: has_emptyc Store := ⟨Store.emp⟩
  instance: inhabited  Store := ⟨Store.emp⟩

  def Store.singleton  {dt: TypeDecl} (a: string)
                      (v: Val dt): Store:=
    ⟨finmap.singleton a ⟨dt, v⟩⟩

  def Store.update  (s: Store) {t: TypeDecl}
                    (v: Val t) (key: string) : Store :=
      ⟨s.vals.insert key ⟨t,v⟩⟩

  def Store.updates: Store → list (string × Σ t, Val t) →  Store
   | s []                  := s
   | s ((a,⟨typ, val⟩)::t) := @Store.update (Store.updates s t) typ val a

  def Store.from_list (l: list (string × Σ t, Val t)): Store :=
    Store.updates ∅ l

  def Store.lookup  {t: TypeDecl} (h: Store)
                   (p: string): option (Val t)
      := h.vals.lookup p >>= λ ⟨_,v⟩, as_type v t

  meta def str_store (h: Store): string := show_finmap h.vals

  meta instance: has_to_string Store := ⟨str_store⟩
  meta instance: has_repr Store      := ⟨str_store⟩

end stores


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

/-!
# Preadditive monoidal categories

> THIS FILE IS SYNCHRONIZED WITH MATHLIB4.
> Any changes to this file require a corresponding PR to mathlib4.

A monoidal category is `monoidal_preadditive` if it is preadditive and tensor product of morphisms
is linear in both factors.
-/

noncomputable theory
open_locale classical

namespace category_theory

open category_theory.limits
open category_theory.monoidal_category

variables (C : Type*) [category C] [preadditive C] [monoidal_category C]

/--
A category is `monoidal_preadditive` if tensoring is additive in both factors.

Note we don't `extend preadditive C` here, as `abelian C` already extends it,
and we'll need to have both typeclasses sometimes.
-/
class monoidal_preadditive : Prop :=
(tensor_zero' : ∀ {W X Y Z : C} (f : W ⟶ X), f ⊗ (0 : Y ⟶ Z) = 0 . obviously)
(zero_tensor' : ∀ {W X Y Z : C} (f : Y ⟶ Z), (0 : W ⟶ X) ⊗ f = 0 . obviously)
(tensor_add' : ∀ {W X Y Z : C} (f : W ⟶ X) (g h : Y ⟶ Z), f ⊗ (g + h) = f ⊗ g + f ⊗ h . obviously)
(add_tensor' : ∀ {W X Y Z : C} (f g : W ⟶ X) (h : Y ⟶ Z), (f + g) ⊗ h = f ⊗ h + g ⊗ h . obviously)

restate_axiom monoidal_preadditive.tensor_zero'
restate_axiom monoidal_preadditive.zero_tensor'
restate_axiom monoidal_preadditive.tensor_add'
restate_axiom monoidal_preadditive.add_tensor'
attribute [simp] monoidal_preadditive.tensor_zero monoidal_preadditive.zero_tensor

variables {C} [monoidal_preadditive C]

local attribute [simp] monoidal_preadditive.tensor_add monoidal_preadditive.add_tensor

instance tensor_left_additive (X : C) : (tensor_left X).additive := {}
instance tensor_right_additive (X : C) : (tensor_right X).additive := {}
instance tensoring_left_additive (X : C) : ((tensoring_left C).obj X).additive := {}
instance tensoring_right_additive (X : C) : ((tensoring_right C).obj X).additive := {}

/-- A faithful additive monoidal functor to a monoidal preadditive category
ensures that the domain is monoidal preadditive. -/
lemma monoidal_preadditive_of_faithful {D} [category D] [preadditive D] [monoidal_category D]
  (F : monoidal_functor D C) [faithful F.to_functor] [F.to_functor.additive] :
  monoidal_preadditive D :=
{ tensor_zero' := by { intros, apply F.to_functor.map_injective, simp [F.map_tensor], },
  zero_tensor' := by { intros, apply F.to_functor.map_injective, simp [F.map_tensor], },
  tensor_add' := begin
    intros,
    apply F.to_functor.map_injective,
    simp only [F.map_tensor, F.to_functor.map_add, preadditive.comp_add, preadditive.add_comp,
      monoidal_preadditive.tensor_add],
  end,
  add_tensor' := begin
    intros,
    apply F.to_functor.map_injective,
    simp only [F.map_tensor, F.to_functor.map_add, preadditive.comp_add, preadditive.add_comp,
      monoidal_preadditive.add_tensor],
  end, }

open_locale big_operators

lemma tensor_sum {P Q R S : C} {J : Type*} (s : finset J) (f : P ⟶ Q) (g : J → (R ⟶ S)) :
  f ⊗ ∑ j in s, g j = ∑ j in s, f ⊗ g j :=
begin
  rw ←tensor_id_comp_id_tensor,
  let tQ := (((tensoring_left C).obj Q).map_add_hom : (R ⟶ S) →+ _),
  change _ ≫ tQ _ = _,
  rw [tQ.map_sum, preadditive.comp_sum],
  dsimp [tQ],
  simp only [tensor_id_comp_id_tensor],
end

lemma sum_tensor {P Q R S : C} {J : Type*} (s : finset J) (f : P ⟶ Q) (g : J → (R ⟶ S)) :
  (∑ j in s, g j) ⊗ f = ∑ j in s, g j ⊗ f :=
begin
  rw ←tensor_id_comp_id_tensor,
  let tQ := (((tensoring_right C).obj P).map_add_hom : (R ⟶ S) →+ _),
  change tQ _ ≫ _ = _,
  rw [tQ.map_sum, preadditive.sum_comp],
  dsimp [tQ],
  simp only [tensor_id_comp_id_tensor],
end

variables {C}

-- In a closed monoidal category, this would hold because
-- `tensor_left X` is a left adjoint and hence preserves all colimits.
-- In any case it is true in any preadditive category.
instance (X : C) : preserves_finite_biproducts (tensor_left X) :=
{ preserves := λ J _, by exactI
  { preserves := λ f,
    { preserves := λ b i, is_bilimit_of_total _ begin
      dsimp,
      simp only [←tensor_comp, category.comp_id, ←tensor_sum, ←tensor_id, is_bilimit.total i],
    end } } }

instance (X : C) : preserves_finite_biproducts (tensor_right X) :=
{ preserves := λ J _, by exactI
  { preserves := λ f,
    { preserves := λ b i, is_bilimit_of_total _ begin
      dsimp,
      simp only [←tensor_comp, category.comp_id, ←sum_tensor, ←tensor_id, is_bilimit.total i],
    end } } }

variables [has_finite_biproducts C]

/-- The isomorphism showing how tensor product on the left distributes over direct sums. -/
def left_distributor {J : Type} [fintype J] (X : C) (f : J → C) :
  X ⊗ (⨁ f) ≅ ⨁ (λ j, X ⊗ f j) :=
(tensor_left X).map_biproduct f

@[simp]
lemma left_distributor_hom {J : Type} [fintype J] (X : C) (f : J → C) :
  (left_distributor X f).hom = ∑ j : J, (𝟙 X ⊗ biproduct.π f j) ≫ biproduct.ι _ j :=
begin
  ext, dsimp [tensor_left, left_distributor],
  simp [preadditive.sum_comp, biproduct.ι_π, comp_dite],
end

@[simp]
lemma left_distributor_inv {J : Type} [fintype J] (X : C) (f : J → C) :
  (left_distributor X f).inv = ∑ j : J, biproduct.π _ j ≫ (𝟙 X ⊗ biproduct.ι f j) :=
begin
  ext, dsimp [tensor_left, left_distributor],
  simp [preadditive.comp_sum, biproduct.ι_π_assoc, dite_comp],
end

lemma left_distributor_assoc {J : Type} [fintype J] (X Y : C) (f : J → C) :
   (as_iso (𝟙 X) ⊗ left_distributor Y f) ≪≫ left_distributor X _ =
     (α_ X Y (⨁ f)).symm ≪≫ left_distributor (X ⊗ Y) f ≪≫ biproduct.map_iso (λ j, α_ X Y _) :=
begin
  ext,
  simp only [category.comp_id,  category.assoc, eq_to_hom_refl,
    iso.trans_hom, iso.symm_hom, as_iso_hom, comp_zero, comp_dite,
    preadditive.sum_comp, preadditive.comp_sum,
    tensor_sum, id_tensor_comp, tensor_iso_hom, left_distributor_hom,
    biproduct.map_iso_hom, biproduct.ι_map, biproduct.ι_π,
    finset.sum_dite_irrel, finset.sum_dite_eq', finset.sum_const_zero],
  simp only [←id_tensor_comp, biproduct.ι_π],
  simp only [id_tensor_comp, tensor_dite, comp_dite],
  simp only [category.comp_id, comp_zero, monoidal_preadditive.tensor_zero, eq_to_hom_refl,
    tensor_id, if_true, dif_ctx_congr, finset.sum_congr, finset.mem_univ, finset.sum_dite_eq'],
  simp only [←tensor_id, associator_naturality, iso.inv_hom_id_assoc],
end

/-- The isomorphism showing how tensor product on the right distributes over direct sums. -/
def right_distributor {J : Type} [fintype J] (X : C) (f : J → C) :
  (⨁ f) ⊗ X ≅ ⨁ (λ j, f j ⊗ X)  :=
(tensor_right X).map_biproduct f

@[simp]
lemma right_distributor_hom {J : Type} [fintype J] (X : C) (f : J → C) :
  (right_distributor X f).hom = ∑ j : J, (biproduct.π f j ⊗ 𝟙 X) ≫ biproduct.ι _ j :=
begin
  ext, dsimp [tensor_right, right_distributor],
  simp [preadditive.sum_comp, biproduct.ι_π, comp_dite],
end

@[simp]
lemma right_distributor_inv {J : Type} [fintype J] (X : C) (f : J → C) :
  (right_distributor X f).inv = ∑ j : J, biproduct.π _ j ≫ (biproduct.ι f j ⊗ 𝟙 X) :=
begin
  ext, dsimp [tensor_right, right_distributor],
  simp [preadditive.comp_sum, biproduct.ι_π_assoc, dite_comp],
end

lemma right_distributor_assoc {J : Type} [fintype J] (X Y : C) (f : J → C) :
   (right_distributor X f ⊗ as_iso (𝟙 Y)) ≪≫ right_distributor Y _ =
     α_ (⨁ f) X Y ≪≫ right_distributor (X ⊗ Y) f ≪≫ biproduct.map_iso (λ j, (α_ _ X Y).symm) :=
begin
  ext,
  simp only [category.comp_id, category.assoc, eq_to_hom_refl, iso.symm_hom,
    iso.trans_hom, as_iso_hom, comp_zero, comp_dite, preadditive.sum_comp, preadditive.comp_sum,
    sum_tensor, comp_tensor_id, tensor_iso_hom, right_distributor_hom,
    biproduct.map_iso_hom, biproduct.ι_map, biproduct.ι_π,
    finset.sum_dite_irrel, finset.sum_dite_eq', finset.sum_const_zero, finset.mem_univ, if_true],
  simp only [←comp_tensor_id, biproduct.ι_π, dite_tensor, comp_dite],
  simp only [category.comp_id, comp_tensor_id, eq_to_hom_refl, tensor_id, comp_zero,
    monoidal_preadditive.zero_tensor,
    if_true, dif_ctx_congr, finset.mem_univ, finset.sum_congr, finset.sum_dite_eq'],
  simp only [←tensor_id, associator_inv_naturality, iso.hom_inv_id_assoc]
end

lemma left_distributor_right_distributor_assoc
  {J : Type*} [fintype J] (X Y : C) (f : J → C) :
  (left_distributor X f ⊗ as_iso (𝟙 Y)) ≪≫ right_distributor Y _ =
    α_ X (⨁ f) Y ≪≫ (as_iso (𝟙 X) ⊗ right_distributor Y _) ≪≫ left_distributor X _ ≪≫
      biproduct.map_iso (λ j, (α_ _ _ _).symm) :=
begin
  ext,
  simp only [category.comp_id, category.assoc, eq_to_hom_refl, iso.symm_hom,
    iso.trans_hom, as_iso_hom, comp_zero, comp_dite, preadditive.sum_comp, preadditive.comp_sum,
    sum_tensor, tensor_sum, comp_tensor_id, tensor_iso_hom,
    left_distributor_hom, right_distributor_hom,
    biproduct.map_iso_hom, biproduct.ι_map, biproduct.ι_π,
    finset.sum_dite_irrel, finset.sum_dite_eq', finset.sum_const_zero, finset.mem_univ, if_true],
  simp only [←comp_tensor_id, ←id_tensor_comp_assoc, category.assoc, biproduct.ι_π,
    comp_dite, dite_comp, tensor_dite, dite_tensor],
  simp only [category.comp_id, category.id_comp, category.assoc, id_tensor_comp,
    comp_zero, zero_comp, monoidal_preadditive.tensor_zero, monoidal_preadditive.zero_tensor,
    comp_tensor_id, eq_to_hom_refl, tensor_id,
    if_true, dif_ctx_congr, finset.sum_congr, finset.mem_univ, finset.sum_dite_eq'],
  simp only [associator_inv_naturality, iso.hom_inv_id_assoc]
end

end category_theory


/-
Copyright (c) 2022 Arthur Paulino. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Arthur Paulino, Gabriel Ebner
-/

import Lean

open Lean.Elab.Tactic

namespace Mathlib.Tactic

/--
`use e₁, e₂, ⋯` applies the tactic `refine ⟨e₁, e₂, ⋯, ?_⟩` and then tries
to close the goal with `trivial` (which may or may not close it). It's
useful, for example, to advance on existential goals, for which terms as
well as proofs of some claims about them are expected.

Examples:

```lean
example : ∃ x : Nat, x = x := by use 42

example : ∃ x : Nat, ∃ y : Nat, x = y := by use 42, 42

example : ∃ x : String × String, x.1 = x.2 := by use ("forty-two", "forty-two")
```
-/
macro "use " es:term,+ : tactic =>
  `(tactic|(refine ⟨$es,*, ?_⟩; try trivial))


/-
Copyright (c) 2019 Simon Hudon. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author(s): Simon Hudon
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.tactic.basic
import Mathlib.data.equiv.basic
import Mathlib.PostPort

universes u v u₀ u₁ v₀ v₁

namespace Mathlib

/-!
# Monad

## Attributes

 * ext
 * functor_norm
 * monad_norm

## Implementation Details

Set of rewrite rules and automation for monads in general and
`reader_t`, `state_t`, `except_t` and `option_t` in particular.

The rewrite rules for monads are carefully chosen so that `simp with
functor_norm` will not introduce monadic vocabulary in a context where
applicatives would do just fine but will handle monadic notation
already present in an expression.

In a context where monadic reasoning is desired `simp with monad_norm`
will translate functor and applicative notation into monad notation
and use regular `functor_norm` rules as well.

## Tags

functor, applicative, monad, simp

-/

theorem map_eq_bind_pure_comp (m : Type u → Type v) [Monad m] [is_lawful_monad m] {α : Type u}
    {β : Type u} (f : α → β) (x : m α) : f <$> x = x >>= pure ∘ f :=
  eq.mpr (id (Eq._oldrec (Eq.refl (f <$> x = x >>= pure ∘ f)) (bind_pure_comp_eq_map f x)))
    (Eq.refl (f <$> x))

/-- run a `state_t` program and discard the final state -/
def state_t.eval {m : Type u → Type v} [Functor m] {σ : Type u} {α : Type u} (cmd : state_t σ m α)
    (s : σ) : m α :=
  prod.fst <$> state_t.run cmd s

/-- reduce the equivalence between two state monads to the equivalence between
their respective function spaces -/
def state_t.equiv {m₁ : Type u₀ → Type v₀} {m₂ : Type u₁ → Type v₁} {α₁ : Type u₀} {σ₁ : Type u₀}
    {α₂ : Type u₁} {σ₂ : Type u₁} (F : (σ₁ → m₁ (α₁ × σ₁)) ≃ (σ₂ → m₂ (α₂ × σ₂))) :
    state_t σ₁ m₁ α₁ ≃ state_t σ₂ m₂ α₂ :=
  equiv.mk (fun (_x : state_t σ₁ m₁ α₁) => sorry) (fun (_x : state_t σ₂ m₂ α₂) => sorry) sorry sorry

/-- reduce the equivalence between two reader monads to the equivalence between
their respective function spaces -/
def reader_t.equiv {m₁ : Type u₀ → Type v₀} {m₂ : Type u₁ → Type v₁} {α₁ : Type u₀} {ρ₁ : Type u₀}
    {α₂ : Type u₁} {ρ₂ : Type u₁} (F : (ρ₁ → m₁ α₁) ≃ (ρ₂ → m₂ α₂)) :
    reader_t ρ₁ m₁ α₁ ≃ reader_t ρ₂ m₂ α₂ :=
  equiv.mk (fun (_x : reader_t ρ₁ m₁ α₁) => sorry) (fun (_x : reader_t ρ₂ m₂ α₂) => sorry) sorry
    sorry

end Mathlib


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

import .stream
-- for prod.has_zero
import algebra.group.prod
import tactic.omega.main
import tactic.linarith
import tactic.split_ifs

/-!
# DBSP operators

We define the DBSP core constructs (lifting, delay, and fixpoints) and the
associated properties of causality, time invariance, and strict causality.

This file defines properties over `stream a` that only depend on the existence
of an arbitrary "zero" element `0 : a`. This zero need not have particular
properties.

NOTE: paper implicitly assumes groups throughout, here we are able to weaken
that assumption.
-/

universes u v.

/-- An operator is a function between streams. -/
@[reducible]
def operator (a b: Type u) : Type u := stream a → stream b.
/-- An operator2 is a function on two streams.

This is isomorphic to `operator (a × b) c`, but in Lean this is easier to use;
there may be a better way to use the uncurried version to avoid defining this
specially. -/
@[reducible]
def operator2 (a b c: Type u) : Type u := stream a → stream b → stream c.

/-- ↑↑f turns an ordinary function into an operator by pointwise lifting.

The paper uses ↑f for this notion, but that means a different notion (also
called lift) in mathlib.
 -/
def lifting {a b: Type} (f: a → b) : operator a b :=
  λ s, λ n, f (s n).
-- lifting binds very tightly (similar to ⁻¹), so that ↑↑f x is (↑↑f) x
prefix `↑↑`:std.prec.max := lifting.

@[simp]
lemma lifting_eq {a b: Type} (f: a → b) (s: stream a) (n: ℕ) :
  ↑↑f s n = f (s n) := rfl.

/-- Lift a curried function. See [lifting]. -/
def lifting2 {a b c: Type} (f: a → b → c) : operator2 a b c :=
  λ s1 s2, λ n, f (s1 n) (s2 n).

@[simp]
lemma lifting2_apply {a b c: Type} (f: a → b → c)
  (s1: stream a) (s2: stream b) (n: ℕ) :
  lifting2 f s1 s2 n = f (s1 n) (s2 n) := rfl.

@[simp]
lemma lifting_id {a: Type} :
  lifting (λ (x:a), x) = id := rfl.

prefix `↑²`:std.prec.max := lifting2.

variables {a : Type} [has_zero a].
variables {b : Type} [has_zero b].
variables {c : Type} [has_zero c].

-- this is moderately dangerous because ↑ is actually recursive, so without a
-- type from the environment this can lift to `operator (stream a) (stream b)`
-- (with an arbitrary number of streams).
instance stream_lift : has_lift (a → b) (operator a b) := ⟨lifting⟩.

/-
note that we will overload 0 for
- 0 : ℕ
- 0 : a (the group element)
- 0 : stream a (which is just [λ _, (0:a)])
-/

/--
Product of two streams as a single stream.

This is part of how multi-argument streams are formalized, which is more
explicit than in the paper.
-/
def sprod {a b: Type} : stream a × stream b → stream (a × b) :=
  λ s, λ n, (s.1 n, s.2 n).

@[reducible]
instance sprod_coe : has_coe (stream a × stream b) (stream (a × b)) :=
  ⟨ λ ⟨s1, s2⟩ n, (s1 n, s2 n) ⟩.

@[simp]
lemma sprod_apply (s: stream a × stream b) (n: ℕ) :
  (sprod s) n = (s.1 n, s.2 n) := rfl.

@[simp]
lemma sprod_coe_unfold (s: stream a × stream b) (n: ℕ) :
  (↑s : stream (a × b)) n = (s.1 n, s.2 n) :=
begin
  cases s with s1 s2,
  refl,
end

/-- Convert a curried [operator2] into an ordinary [operator] over a tuple. -/
def uncurry_op (T: operator2 a b c) : operator (a × b) c :=
  λ s, T (↑↑prod.fst s) (↑↑prod.snd s).

lemma uncurry_op_intro (T: operator2 a b c) (s1: stream a) (s2: stream b) :
  T s1 s2 = uncurry_op T (s1, s2) := by { funext t, refl }.

theorem lifting_distributivity {a b c: Type} (f: a → b) (g: b → c) :
  lifting (g ∘ f) = lifting g ∘ lifting f := rfl.

theorem lifting_comp {a b c: Type} (f: a → b) (g: b → c) (s: stream a) :
  ↑↑ (λ x, g (f x)) s = ↑↑ g (↑↑ f s) := rfl.

theorem lifting2_comp {a b c d e: Type}
  (f: a → c) (g: b → d) (T: c → d → e)
  (s1: stream a) (s2: stream b) :
  ↑² (λ x y, T (f x) (g y)) s1 s2 = ↑²T (↑↑f s1) (↑↑g s2) := rfl.

theorem lifting2_comp' {a b c d e: Type}
  (f: a → c) (g: b → d) (T: c → d → e) :
  ↑² (λ x y, T (f x) (g y)) = λ s1 s2, ↑²T (↑↑f s1) (↑↑g s2) := rfl.

/-- The delay operator `z⁻¹` is a fundamental DBSP operator that shifts a stream over by one time
step. For `t=0` it inserts a zero element, which is the main reason a `0 : a`
(expressed with `has_zero a` here) is required.
-/
def delay : operator a a :=
  λ (s: stream a), λ t, if t = 0 then 0 else s (t - 1).

notation `z⁻¹` := delay.

/-- Time invariance intuitively expresses that an operator does not depend on
the exact time, only the sequence. It is expressed by saying that `S ∘ z⁻¹ = z⁻¹
∘ S`, that is, that the operator commutes with delay (see [time_invariant_comp]
for a proof that this definition equals that one).

Essentially all operators considered in DBSP are time invariant (although this
may not be strictly necessary).
 -/
def time_invariant (S: operator a b) :=
  ∀ s, S (z⁻¹ s) = z⁻¹ (S s).

/-- Show [time_invariant] is equivalent to the definition in the paper.

The definition of [time_invariant] is easier to use in Lean since it can be used
directly as a rewrite, whereas composed functions don't appear syntactically in
proofs. -/
lemma time_invariant_comp (S: operator a b) :
  time_invariant S ↔ S ∘ z⁻¹ = z⁻¹ ∘ S :=
begin
  split; intros h,
  { funext s, simp, rw h, },
  { intros s, apply (congr_fun h s), },
end

/-- Characterizes time invariance for lifted operators: they must satisfy the
"zero preservation property", namely `f 0 = 0`. This arises because the delay
inserts a 0 at `z⁻¹ (S ↑↑f) 0`, and the function must do the same in `S (z⁻¹ (↑↑
f)) 0`. -/
theorem lifting_time_invariance (f: a → b) :
  time_invariant (lifting f) ↔ f 0 = 0 :=
begin
  unfold time_invariant,
  split,
  { intro h,
    have heq := congr_fun (h 0) 0,
    simp [delay, lifting] at heq,
    assumption,
   },
  { intros h0 s,
    funext t,
    simp [delay, lifting],
    split_ifs; clarify,
  },
end

lemma lifting_time_invariant (f: a → b) :
  f 0 = 0 → time_invariant (↑↑ f) :=
 (lifting_time_invariance f).mpr.

-- delay by definition produces 0 at time t
@[simp]
lemma delay_t_0 (s: stream a) : z⁻¹ s 0 = 0
:= rfl.

@[simp]
lemma delay_0 : z⁻¹ (0 : stream a) = 0 :=
begin
  funext t, unfold delay, simp,
end

@[simp]
lemma delay_succ (s: stream a) (n: ℕ) : z⁻¹ s n.succ = s n
:= rfl.

lemma delay_sub_1 (s: stream a) (n: ℕ) :
  0 < n → z⁻¹ s n = s (n-1) :=
begin
  intros h,
  unfold delay, rw if_neg, omega,
end

lemma delay_eq_at (s1 s2: stream a) (t: ℕ) :
  (0 < t → s1 (t-1) = s2 (t-1)) →
  z⁻¹ s1 t = z⁻¹ s2 t :=
begin
  intros heq,
  unfold delay, split_ifs, simp,
  apply heq, omega,
end

lemma time_invariant_0_0 (S: operator a b) :
  time_invariant S → S 0 0 = 0 :=
begin
  intros hti,
  unfold time_invariant at hti,
  have h := congr_fun (hti 0) 0,
  simp at h,
  assumption,
end

-- time_invariant definition applied to a specific s and t
lemma time_invariant_t {S: operator a b} (h: time_invariant S) :
  ∀ s t, S (delay s) t = delay (S s) t :=
begin
  unfold time_invariant at h,
  intros s t,
  have heq := congr_fun (h s) t,
  assumption,
end

-- this is zero-preservation over zero streams
lemma time_invariant_zpp (S: operator a b) :
  time_invariant S → S 0 = 0 :=
begin
  intros hti,
  funext t,
  change ((0: stream b) t) with (0: b),
  induction t,
  { apply time_invariant_0_0, assumption, },
  { rw<- delay_0,
    rw (time_invariant_t hti), simp,
    assumption,
  }
end

lemma lift_time_invariant (f: a → b) :
  f 0 = 0 →
  time_invariant ↑↑f :=
begin
  intros hzpp s,
  funext t; simp,
  unfold delay, split_ifs,
  { apply hzpp },
  { simp }
end

lemma delay_time_invariant : time_invariant (@delay a _) :=
  by { intros s, refl }.

theorem lifting2_time_invariant (f: a → b → c) :
  time_invariant (uncurry_op (↑² f)) ↔ f 0 0 = 0 :=
begin
  split,
  { intros h,
    apply (congr_fun (h 0) 0), },
  { intros h0 s,
    funext t,
    simp [delay, lifting2, uncurry_op],
    split_ifs; clarify,
   }
end

/-- A causal operator intuitively depends at time `t` only on previous inputs.
Note that an operator can use its input at time `t` itself; imagine all
operators operate synchronously, and we compute all of them before emitting the
output. The formal definition says that if two streams agree up to time t, then
S must return the same result at time t for both.
-/
def causal (S: operator a b) :=
  ∀ (s s': stream a), ∀ t, s ==t== s' → S s t = S s' t.

@[simp]
theorem lifting_causal (f: a → b) : causal (lifting f) :=
begin
  intros s s' t hpre,
  simp [lifting],
  rw (hpre t),
  omega,
end

theorem delay_causal : causal (@delay a _) :=
begin
  intros s s' t hpre,
  simp [causal, delay],
  rw hpre,
  omega,
end

-- composition of two causal operators is causal
theorem causal_comp_causal
  (S1: operator a b) (h1: causal S1)
  (S2: operator b c) (h2: causal S2) :
  causal (λ s, S2 (S1 s)) :=
begin
  intros s1 s2 n heq, simp,
  apply h2,
  intros i hle,
  apply h1,
  intros j hle_j, apply heq, omega,
end

lemma causal_respects_agree_upto (S: operator a b) (h: causal S)
  (s1 s2: stream a) (n: ℕ) :
  s1 ==n== s2 →
  S s1 ==n== S s2 :=
begin
  intros heq n hle,
  apply h,
  intros _ hle', apply heq, omega,
end

lemma causal_to_agree (S: operator a b) :
  causal S ↔ (∀ s1 s2 n, s1 ==n== s2 → S s1 ==n== S s2) :=
begin
  split,
  { intros s1 s2 n h,
    apply causal_respects_agree_upto; assumption, },
  intros heq_n,
  intros s1 s2 t hagree,
  apply (heq_n _ _ t),
  { intros i, apply hagree, },
  omega,
end

-- More convenient definition of causal for two-argument operators. `causal
-- (uncurry_op T)` is a convenient way to re-use the definition of causal, but
-- this is easier to use for the curried operator directly.
lemma causal2 (T: operator2 a b c) :
  causal (uncurry_op T) ↔
  (∀ s1 s1' s2 s2' n, s1 ==n== s1' → s2 ==n== s2' →
                      T s1 s2 n = T s1' s2' n) :=
begin
  split,
  { intros hcausal,
    intros _ _ _ _ _ h1 h2,
    have h := hcausal (sprod (s1, s2)) (sprod (s1', s2')) n,
    unfold uncurry_op sprod at h, simp at h,
    apply h,
    { intros i hle, simp,
      rw [h1, h2]; try { omega },
      split; refl,
    },
  },
  { intros h, intros _ _ _ heq,
    unfold uncurry_op sprod at ⊢,
    apply h,
    { intros i hle, simp,
      rw heq, omega, },
    { intros i hle, simp,
      rw heq, omega, },
  },
end

lemma causal2_agree (T: operator2 a b c) :
  causal (uncurry_op T) →
  (∀ s1 s1' s2 s2' n, s1 ==n== s1' → s2 ==n== s2' →
                      T s1 s2 ==n== T s1' s2') :=
begin
  rw causal2, introv hcausal heq1 heq2,
  intros m hle,
  apply hcausal,
  apply agree_upto_weaken, assumption, omega,
  apply agree_upto_weaken, assumption, omega,
end

theorem uncurry_op_lifting {d:Type} [add_comm_group d] (f: c → d) (t: stream a → stream b → stream c) :
  uncurry_op (λ (x: stream a) (y: stream b), ↑↑f (t x y)) = ↑↑f ∘ uncurry_op t :=
begin
  funext xy t, simp [uncurry_op],
end

-- causal (uncurry_op T) can be weakened to a specific fixed first argument
lemma causal_uncurry_op_fixed (T: operator2 a b b) :
  causal (uncurry_op T) →
  ∀ s, causal (T s) :=
begin
  intros hcausal,
  intros s s' n heq,
  rw causal2 at hcausal,
  apply hcausal, refl,
end

lemma lifting_lifting2_comp {d: Type} [has_zero d] (f: c → d) (g: a → b → c) :
  ∀ s1 s2, ↑↑f (↑²g s1 s2) = ↑²(λ x y, f (g x y)) s1 s2 :=
begin
  intros s1 s2, funext t, simp,
end

lemma uncurry_op_lifting2 (f: a → b → c) :
  uncurry_op (↑²f) = ↑ (λ (xy: a × b), f xy.1 xy.2) := rfl.

/-- Strictly causal. Similar to [causal], a strictly causal (or simply _strict_)
operator depends only on past inputs; unlike causal, a strict operator at time
`n` can depend only on `t < n` and not `n` itself. -/
def strict (S: operator a b) :=
  ∀ (s s': stream a), ∀ t, (∀ i < t, s i = s' i) → S s t = S s' t.

/-- Strictly causal operators have a unique output at time 0 (because they
aren't allowed to depend on the input at time 0), but it need not actually be 0.
That requirement can come from [time_invariant].
-/
theorem strict_unique_zero (S: operator a b) (h: strict S) :
  ∀ s s', S s 0 = S s' 0 :=
begin
  intros s s',
  apply h,
  intros i hcontra,
  by_contradiction,
  apply nat.not_lt_zero, assumption,
end

theorem strict_causal_to_causal (S: operator a b) : strict S → causal S :=
begin
  intros hstrict,
  intros s s' t hpre,
  apply hstrict,
  intros i hlt,
  apply hpre, omega,
end

theorem delay_strict : strict (@delay a _) :=
begin
  intros s s' t hpre,
  simp [causal, delay],
  split_ifs; try { simp <|> assumption },
  apply hpre, omega,
end

theorem causal_strict_strict
  (F: operator a b) (hstrict: strict F)
  (T: operator b c) (hcausal: causal T) :
  strict (λ α, T (F α)) :=
begin
  intros s1 s2 n hagree,
  simp,
  apply hcausal,
  intros i hle,
  apply hstrict,
  intros j hjle,
  apply hagree, omega,
end

theorem strict_causal_strict
  (F: operator a b) (hcausal: causal F)
  (T: operator b c) (hstrict: strict T) :
  strict (λ α, T (F α)) :=
begin
  intros s1 s2 n hagree,
  simp,
  apply hstrict,
  intros i hle,
  apply hcausal,
  intros j hjle,
  apply hagree, omega,
end

/- To construct the fixpoint of F, we first define nth F n, which is F (F ... (F
0)) with (n+1) copies of F. The fixpoint [fix] turns out to be `nth F n n` - the nth
iterate is correct up to time n. -/
private def nth (F: operator a a) : ℕ → stream a
-- We apply F at the bottom so that fix F 0 is given by F rather than being
-- forced to be (0 : a). This seems to generalize the paper, which doesn't
-- consider such operators! (The assumption that everything is time invariant
-- forces operators to have F 0 0 = 0, as proven in [time_invariant_0_0].)
| nat.zero := F 0
| (nat.succ n) := F (nth n).

@[simp]
lemma nth_0 (F: operator a a) : nth F 0 = F 0 := rfl.

@[simp]
lemma nth_succ (F: operator a a) (n: ℕ) : nth F n.succ = F (nth F n) := rfl.

/-- `fix (α, F α)` for a [strict] operator `F` is a fundamental operator that
implements a form of recursion. It is a fixpoint in that `fix F` is a solution
to `α = F(α)`.  When `F` is [strict], this recursion is well-defined: `fix F = F
(fix F)` (see [fix_eq]), and the solution is unique (see [fix_unique]).

Note that in this formalization, `fix F` always produces _some_ stream; however,
if F is not strict, then it need not satisfy `fix F = F (fix F)`.
 -/
def fix (F: operator a a) : stream a :=
  λ t, nth F t t.

@[simp]
lemma fix_0 (F: operator a a) : fix F 0 = F 0 0 := rfl.

lemma strict_zpp_zero (S: operator a b) (hstrict: strict S) (hzpp: S 0 0 = 0) :
  ∀ s, S s 0 = 0 :=
begin
  intros s,
  calc S s 0 = S 0 0 : by {
    apply strict_unique_zero,
    assumption,
  }
        ... = 0 : by apply hzpp,
end

lemma strict_agree_at_next (S: operator a b) (hstrict: strict S) :
  ∀ s s' n, agree_upto n s s' → S s n.succ = S s' n.succ :=
begin
  unfold agree_upto,
  intros s s' n hagree,
  apply hstrict,
  intros i hlt,
  apply hagree, omega,
end

lemma agree_upto_strict_extend (S: operator a b) (hstrict: strict S) (s s': stream a) :
  ∀ n, s ==n== s' → S s ==n.succ== S s' :=
begin
  intros n hagree,
  intros t hle,
  apply hstrict,
  intros i hlt,
  apply hagree, omega,
end

/-
We don't actually use this characterization of strictness, but it might help
build intuition.
-/
lemma strict_as_agree_upto (S: operator a b) :
  strict S ↔ ((∀ s s', S s ==0== S s') ∧ ∀ s s' n, s ==n== s' → S s ==n.succ== S s') :=
begin
  unfold strict,
  split,
  { intros hstrict,
    split,
    { intros s s',
      rw agree_upto_0,
      apply hstrict,
      intros i hlt0,
      exfalso,
      apply (nat.not_lt_zero _ hlt0), },
    { intros s s' n hagree,
      apply agree_upto_strict_extend; assumption, }
  },
  { intros h,
    cases h with h_zpp h_agree_extend,
    intros s s' t hagree,
    have h: (t = 0 ∨ 0 < t) := by omega,
    cases h,
    { subst t, apply h_zpp, omega, },
    { apply (h_agree_extend _ _ (t-1)),
      intros i hle,
      apply hagree, omega, omega,
     }
  }
end

lemma delay_succ_upto (s1 s2: stream a) (n: ℕ) :
  s1 ==n== s2 →
  delay s1 ==n.succ== delay s2 :=
begin
  intros heqn,
  unfold agree_upto,
  intros t,
  intros hle,
  unfold delay,
  rw heqn; omega,
end

private lemma and_wlog2 {p1 p2: Prop} (h2: p2) (h21: p2 → p1) :
  p1 ∧ p2 := ⟨h21 h2, h2⟩ .

private lemma nth_fix_agree_aux (F: operator a a)  (hstrict: strict F) (n: ℕ) :
  nth F n ==n== fix F ∧ fix F ==n== F (fix F) :=
begin
  induction n with n,
  { rw [agree_upto_0, agree_upto_0],
    split,
    { refl, },
    { unfold fix, simp [nth],
      apply strict_unique_zero, assumption, }
  },
  change (nth F n.succ) with (F (nth F n)),
  cases n_ih with h_fix h_unfold,
  have h : F (nth F n) ==n.succ== F (fix F) := by {
    apply (agree_upto_strict_extend _ hstrict),
    exact h_fix,
  },
  apply and_wlog2,
  { apply agree_upto_extend,
    { exact h_unfold, },
    { simp [fix, nth],
      apply (strict_agree_at_next _ hstrict),
      exact h_fix,
     }
  },
  { intros h2,
    -- BUG: prove by reflexivity to instantiate the n argument to agree_upto
    -- (Lean seems to ignore the n in the first relation)
    calc F (nth F n) ==n.succ== F (nth F n) : by apply (agree_refl n.succ)
        ... ==n.succ== F (fix F) : by assumption
        ... ==n.succ== fix F : by { symmetry, assumption },
  },
end

-- The key characterization of fix F.
theorem fix_eq (F: operator a a) (hstrict: strict F) :
  fix F = F (fix F) :=
begin
  funext t,
  have h := nth_fix_agree_aux _ hstrict t,
  cases h with _ h_unfold,
  apply h_unfold, omega,
end

-- We show two solutions α to α = F(α) are equal, from which obviously
-- they are all equal to fix F, which is one such solution from [fix_eq]
--
-- Users will typically want the special case of [fix_unique], which is written
-- in terms of our particular solution [fix].
protected theorem fixpoints_unique (F: operator a a) (hstrict: strict F)
  (α β: stream a) :
  -- α and β are two possible solutions
  α = F α → β = F β →
  α = β :=
begin
  intros hα hβ,
  rw agree_everywhere_eq, intros n,
  induction n with n,
  { rw hα, rw hβ,
    rw agree_upto_0,
    apply strict_unique_zero, assumption, },
  { rw hα, rw hβ,
    apply agree_upto_strict_extend, assumption,
    assumption, }
end

theorem fix_unique (F: operator a a) (hstrict: strict F)
  (α: stream a) (h_fix: α = F α) :
  α = fix F :=
begin
  apply (fixpoints_unique _ hstrict α (fix F)),
  { assumption },
  { apply fix_eq, assumption, }
end

section fix2.

def fix2 (F: operator (stream a) (stream a)) : stream (stream a) :=
  λ n t, nth F t n t.

def causal_nested (Q: operator (stream a) (stream b)) :=
  ∀ (s s': stream (stream a)),
    ∀ n t, ∀ (heq: ∀ n' ≤ n, ∀ t' (hle_t': t' ≤ t), s n' t' = s' n' t'),
    Q s n t = Q s' n t.

def strict2 (Q: operator (stream a) (stream b)) :=
  ∀ (s s': stream (stream a)),
    ∀ n t, ∀ (heq: ∀ n' ≤ n, ∀ t' (hle_t': t' < t), s n' t' = s' n' t'),
    Q s n t = Q s' n t.

theorem strict2_is_causal_nested (Q: operator (stream a) (stream b)) :
  strict2 Q → causal_nested Q :=
begin
  unfold strict2 causal_nested, intros hstrict,
  intros,
  apply hstrict, intros, apply heq; omega,
end

meta def tauto_omega := `[tauto {closer := `[omega]}].

lemma strict2_agree_0 (F: operator (stream a) (stream b)) (hstrict: strict2 F) :
  ∀ s s' n, F s n 0 = F s' n 0 :=
begin
  intros, apply hstrict,
  intros,
  have hcontra : ¬(t' < 0) := by omega,
  contradiction,
end

lemma strict2_eq_0 (F: operator (stream a) (stream b)) (hstrict: strict2 F) :
  ∀ s n, F s n 0 = F 0 n 0 :=
begin
  intros, apply (strict2_agree_0 _ hstrict),
end

def agree_upto2 (t: ℕ) (s1 s2: stream (stream a)) :=
  ∀ n, ∀ t' (hle: t' ≤ t), s1 n t' = s2 n t'.
local notation (name := agree2) s1 ` ==` t `== ` s2:35 := agree_upto2 t s1 s2.

lemma agree_upto2_symm (t: ℕ) (s1 s2: stream (stream a)) :
  s1 ==t== s2 →
  s2 ==t== s1 :=
begin
  unfold agree_upto2, intros,
  finish,
end

lemma agree_upto2_trans (t: ℕ) (s1 s2 s3: stream (stream a)) :
  s1 ==t== s2 →
  s2 ==t== s3 →
  s1 ==t== s3 :=
begin
  unfold agree_upto2, intros,
  transitivity (s2 n t'); finish,
end

lemma agree_upto2_0 (s1 s2: stream (stream a)) :
  s1 ==0== s2 ↔ (∀ n, s1 n 0 = s2 n 0) :=
begin
  unfold agree_upto2,
  split; introv h; clarify,
end

lemma agree_upto2_extend (t: ℕ) (s s': stream (stream a)) :
  s ==t== s' →
  (∀ n, s n t.succ = s' n t.succ) →
  s ==t.succ== s' :=
begin
  intros hagree heqn,
  unfold agree_upto2, intros,
  have ht': (t' ≤ t ∨ t' = t.succ) := by omega,
  cases ht',
  { tauto_omega, },
  subst ht', tauto_omega,
end

lemma agree_upto2_strict_extend (S: operator (stream a) (stream b))
  (hstrict: strict2 S) (s s': stream (stream a)) :
  ∀ t, s ==t== s' →
  S s ==t.succ== S s' :=
begin
  introv hagree,
  unfold agree_upto2, intros,
  apply hstrict,
  intros n' _ t'' _,
  have h1 : t'' ≤ t := by omega,
  apply hagree, finish,
end

lemma strict_agree2_at_next (S: operator (stream a) (stream b)) (hstrict: strict2 S) :
  ∀ s s' t, s ==t== s' → ∀ n, S s n t.succ = S s' n t.succ :=
begin
  unfold agree_upto2,
  intros s s' t hagree n,
  apply hstrict,
  intros, apply hagree, omega,
end

private lemma nth_fix2_agree_aux (F: operator (stream a) (stream a))  (hstrict: strict2 F) (t: ℕ) :
  nth F t ==t== fix2 F ∧ fix2 F ==t== F (fix2 F) :=
begin
  induction t with t,
  { rw [agree_upto2_0, agree_upto2_0],
    split,
    { intros, unfold fix2,
    },
    { intros, unfold fix2, simp,
      apply (strict2_agree_0 _ hstrict),
    },
  },
  change (nth F t.succ) with (F (nth F t)),
  cases t_ih with h_fix h_unfold,
  have h : F (nth F t) ==t.succ== F (fix2 F) := by {
    apply agree_upto2_strict_extend; assumption,
  },
  apply and_wlog2,
  { apply agree_upto2_extend,
    { exact h_unfold, },
    { intros n,
      simp [fix2, nth],
      apply (strict_agree2_at_next _ hstrict),
      exact h_fix,
     }
  },
  { intros h2,
    apply agree_upto2_trans, assumption,
    apply agree_upto2_symm, assumption, },
end

theorem fix2_eq (F: operator (stream a) (stream a)) (hstrict: strict2 F) :
  fix2 F = F (fix2 F) :=
begin
  funext n t,
  have h := nth_fix2_agree_aux _ hstrict t,
  cases h with _ h_unfold,
  apply h_unfold, omega,
end

theorem agree2_everywhere_eq (s1 s2: stream (stream a)) :
  (∀ t, s1 ==t== s2) → s1 = s2 :=
begin
  intros heq,
  funext n t,
  apply (heq t), omega,
end

protected theorem fixpoints2_unique (F: operator (stream a) (stream a)) (hstrict: strict2 F)
  (α β: stream (stream a)) :
  -- α and β are two possible solutions
  α = F α → β = F β →
  α = β :=
begin
  intros hα hβ,
  apply agree2_everywhere_eq, intros n,
  induction n with n,
  { rw hα, rw hβ,
    intros n t' hle,
    have ht : t' = 0 := by omega, subst ht,
    apply strict2_agree_0, assumption, },
  { rw hα, rw hβ,
    apply agree_upto2_strict_extend, assumption,
    assumption, }
end

theorem fix2_unique (F: operator (stream a) (stream a)) (hstrict: strict2 F)
  (α: stream (stream a)) (h_fix: α = F α) :
  α = fix2 F :=
begin
  apply (fixpoints2_unique _ hstrict α (fix2 F)),
  { assumption },
  { apply fix2_eq, assumption, }
end

end fix2.

theorem lifting_delay_strict2 :
  strict2 (↑↑ (@delay a _)) :=
begin
  unfold strict2, introv heq,
  unfold delay, simp,
  split_ifs; try { refl },
  apply heq; omega,
end

@[simp]
theorem causal_nested_const (c: stream (stream b)) :
  causal_nested (λ (x: stream (stream a)), c) :=
begin
  unfold causal_nested, intros, refl,
end

theorem causal_nested_id :
  causal_nested (λ (x: stream (stream a)), x) :=
begin
  unfold causal_nested, intros, apply heq; omega
end

theorem causal_nested_comp
  (Q1: operator (stream b) (stream c))
  (Q2: operator (stream a) (stream b)) :
  causal_nested Q1 → causal_nested Q2 →
  causal_nested (λ s, Q1 (Q2 s)) :=
begin
  intros h1 h2,
  unfold causal_nested, intros,
  apply h1, intros,
  apply h2, intros,
  apply heq; omega,
end

@[simp]
theorem causal_nested_lifting
  (Q: operator a b) :
  causal Q →
  causal_nested (↑↑Q) :=
begin
  intros h,
  unfold causal_nested, intros, simp,
  rw h,
  intros t' hle,
  apply heq; omega,
end

theorem feedback_ckt_body_strict
  (F: operator b b) (hstrict: strict F)
  (T: operator2 a b b) (hcausal: causal (uncurry_op T)) (s: stream a) :
  strict (λ α, T s (F α)) :=
begin
  apply causal_strict_strict,
  { apply hstrict, },
  { apply causal_uncurry_op_fixed, assumption, },
end

lemma feedback_ckt_unfold
  (F: operator b b) (hstrict: strict F)
  (T: operator2 a b b) (hcausal: causal (uncurry_op T)) (s: stream a) :
  fix (λ α, T s (F α)) = T s (F (fix (λ α, T s (F α)))) :=
begin
  apply fix_eq,
  apply feedback_ckt_body_strict; assumption,
end

theorem feedback_ckt_causal
  (F: operator b b) (hstrict: strict F)
  (T: operator2 a b b) (hcausal: causal (uncurry_op T)) :
  causal (λ s, fix (λ α, T s (F α))) :=
begin
  have h := hcausal,
  rw causal_to_agree,
  rw causal2 at h,
  have h2 := causal2_agree _ hcausal,
  introv heq,
  induction n with n,
  { rw [feedback_ckt_unfold _ hstrict _ hcausal s1,
        feedback_ckt_unfold _ hstrict _ hcausal s2],
    rw agree_upto_0,
    apply h, assumption,
    rw agree_upto_0,
    apply strict_unique_zero, assumption,
   },
  { rw [feedback_ckt_unfold _ hstrict _ hcausal s1,
        feedback_ckt_unfold _ hstrict _ hcausal s2],
    apply h2, assumption,
    apply agree_upto_strict_extend, assumption,
    apply n_ih,
    apply agree_upto_weaken1, assumption, },
end

-- #lint only doc_blame simp_nf


open Classical

universe u
variable (α : Type u)

class HasEq (α : Type u) where
  Eq : α → α → Prop
infix:50 " ＝ "  => HasEq.Eq

class HasIn (α : Type u) where
  In : α → α → Prop
infix:50 " ∈ "  => HasIn.In

class HasSubset (α : Type u) where
  Subset : α → α → Prop
infix:50 " ⊂ "  => HasSubset.Subset
infix:50 " ⊆ "  => HasSubset.Subset

class HasUnion (α : Type u) where
  Union : α → α → α
infix:50 " ∪ "  => HasUnion.Union

class HasInter (α : Type u) where
  Inter : α → α → α
infix:50 " ∩ "  => HasInter.Inter

class HasUnionAll (α : Type u) where
  UnionAll : α → α
notation " ⋃ "  => HasUnionAll.UnionAll

class HasInterAll (α : Type u) where
  InterAll : α → α
notation " ⋂ "  => HasInterAll.InterAll

class HasProduct (α : Type u) where
  Product : α → α → α
infix:50 " ✕ "  => HasProduct.Product

class HasPow  (α : Sort u) where
  Pow : α → α
notation "𝒫" => HasPow.Pow

class HasDiff  (α : Type u) where
  Diff : α → α → α
infix:50 " ＼ "  => HasDiff.Diff

axiom Class : Type u
axiom Class.In : Class → Class → Prop
axiom Class.Eq : Class → Class → Prop

instance : HasEq Class where
  Eq := Class.Eq
notation:50 X " ≠ " Y => ¬ (X ＝ Y)

instance : HasIn Class where
  In := Class.In
notation:50 X " ∉ " Y => ¬ X ∈ Y

def isSet (X : Class) : Prop := ∃(Y:Class), X ∈ Y

def isProper (X : Class) : Prop := ¬ (isSet X)
class ProperClass (X : Class) where
  isProper : isProper X

-- 1. AxiomExtensionality
axiom AxiomExtensionality :
  ∀X Y: Class, (X＝Y ↔ ∀z, (z ∈ X ↔ z ∈ Y))

def ClassSubset (X Y : Class) : Prop :=
  ∀z:Class, z ∈ X → z ∈ Y
instance : HasSubset Class where
  Subset := ClassSubset

-- 2. AxiomUniverse
axiom AxiomUniverse :
  ∃U : Class, ∀x: Class, (x∈U ↔ ∃X: Class,(x∈X))
noncomputable def U: Class :=
  choose AxiomUniverse

-- Set Type
theorem AllSetInU {x : Class}: isSet x ↔ x∈U := by {
  apply Iff.intro;
  {exact fun ⟨y, h⟩ => (choose_spec AxiomUniverse x).2 ⟨y, h⟩;}
  {exact fun h => (choose_spec AxiomUniverse x).1 h;}
}

class Set (X : Class) where
  isSet : isSet X
  inU   : X ∈ U
def Set.mk₁ {X Y: Class} (h: X ∈ Y): Set X :=
  Set.mk ⟨Y, h⟩ (AllSetInU.1 ⟨Y, h⟩)
def Set.mk₂ {X: Class} (hx: X ∈ U): Set X :=
  Set.mk (AllSetInU.2 hx) hx

-- 3. AxiomDifference
axiom AxiomDifference :
  ∀X Y: Class, ∃Z: Class,
    ∀u: Class, (u∈Z ↔ (u ∈ X ∧ u ∉ Y))
noncomputable def Diff (X Y: Class): Class :=
  choose (AxiomDifference X Y)
noncomputable instance : HasDiff Class where
  Diff := Diff

-- intersection
noncomputable def IntersectionClass_mk' (X Y: Class) :=
  X ＼ (X ＼ Y)
theorem IntersectionClassExists:
  ∀X Y: Class, ∃Z: Class,
    ∀z: Class, ((z ∈ Z) ↔ (z ∈ X) ∧ (z ∈ Y)) := by {
  intro X Y;
  let inter :=  X ＼ (X ＼ Y);
  sorry;
}
noncomputable def IntersectionClass_mk (X Y: Class) :=
  choose (IntersectionClassExists X Y)
noncomputable instance : HasInter Class where
  Inter := IntersectionClass_mk

-- union
theorem UnionClassExists:
  ∀X Y: Class, ∃Z: Class,
    ∀z: Class, ((z ∈ Z) ↔ (z ∈ X) ∨ (z ∈ Y)) := by {
  intro X Y;
  let union := U ＼ ((U ＼ X) ∩ (U ＼ Y));
  sorry;
}
noncomputable def UnionClass_mk (X Y: Class) :=
  choose (UnionClassExists X Y)
noncomputable instance : HasUnion Class where
  Union := UnionClass_mk

-- empty class
noncomputable def EmptyClass_mk' : Class :=
  U ＼ U
theorem EmptyClassExists:
  ∃Z: Class, ∀u: Class, (¬ u ∈ Z) := by {
  let emp := EmptyClass_mk';
  exists emp;
  sorry;
}
noncomputable def EmptyClass_mk : Class :=
  choose EmptyClassExists
notation " ø " => EmptyClass_mk

-- 4. AxiomPair
axiom AxiomPair :
  ∀x y: Class, x ∈ U → y ∈ U
    → ∃z: Class,
      (z∈U) ∧ (∀u: Class, (u∈z ↔ (u ＝ x ∨ u ＝ y)))
noncomputable def Pair_mk (X Y: Class) [hx: Set X] [hy: Set Y] : Class :=
  choose (AxiomPair X Y hx.2 hy.2)
noncomputable def Pair_def (X Y: Class) [hx: Set X] [hy: Set Y] :=
  choose_spec (AxiomPair X Y hx.2 hy.2)
noncomputable def Pair_is_Set (X Y: Class) [Set X] [Set Y] : Set (Pair_mk X Y) :=
  Set.mk₂ (Pair_def X Y).1
notation "{"x","y"}" => Pair_mk x y
notation "{"x","y"}s" => Pair_is_Set x y

-- singleton def
theorem SingletonSetExists (X: Class) [hx: Set X]:
  ∃z: Class,
    (z∈U) ∧ (∀u: Class, (u∈z ↔ (u ＝ X))) := by {
  exists (Pair_mk X X);
  sorry;
}
noncomputable def Singleton_mk (X: Class) [Set X]: Class :=
  choose (SingletonSetExists X)
noncomputable def Singleton_def (X: Class) [Set X]:
  ((Singleton_mk X) ∈ U) ∧ (∀u: Class, (u ∈ (Singleton_mk X) ↔ (u ＝ X))) :=
  choose_spec (SingletonSetExists X)
noncomputable def Singleton_is_Set (X: Class) [Set X]: Set (Singleton_mk X) :=
  Set.mk₂ (Singleton_def X).1
notation "{"x"}" => Singleton_mk x
notation "{"x"}s" => Singleton_is_Set x

-- ordered pair
noncomputable def OrdPair_mk (X Y: Class) [Set X] [Set Y] : Class :=
  @Pair_mk {X} {X, Y} {X}s {X, Y}s
noncomputable def OrdPair_def (X Y: Class) [Set X] [Set Y] :=
  @Pair_def {X} {X, Y} {X}s {X, Y}s
noncomputable def OrdPair_is_Set (X Y: Class) [Set X] [Set Y] : Set (OrdPair_mk X Y) :=
  @Pair_is_Set {X} {X, Y} {X}s {X, Y}s
notation "＜"x","y"＞" => OrdPair_mk x y
notation "＜"x","y"＞s" => OrdPair_is_Set x y

-- ordered triple
noncomputable def OrdTriple_mk (X Y Z: Class) [Set X] [Set Y] [Set Z] : Class :=
  @OrdPair_mk ＜X, Y＞ Z ＜X, Y＞s _
notation "＜"x","y","z"＞" => OrdTriple_mk x y z

-- 5. AxiomProduct
axiom AxiomProduct :
  ∀X Y: Class, ∃Z: Class,
    ∀z: Class, (z∈Z ↔ ∃x y: Class, ∃hx: x ∈ X,∃hy: y ∈ Y,
      (z ＝ (@OrdPair_mk x y (Set.mk₁ hx) (Set.mk₁ hy))))
noncomputable def ProductClass_mk (X Y: Class) : Class :=
  choose (AxiomProduct X Y)
noncomputable instance : HasProduct Class where
  Product := ProductClass_mk

-- Relation type
def isRelation (R : Class) : Prop :=
  ∀z: Class, z∈R ↔ ∃x y: Class, ∃_: Set x, ∃_: Set y,
    (z ＝ ＜x, y＞)
class Relation (R : Class) where
  isRelation: isRelation R

-- Function type
def isFunction (F : Class) [Relation F] : Prop :=
  ∀x x' y y': Class, ∀_: Set x, ∀_: Set x', ∀_: Set y, ∀_: Set y',
    ＜x, y＞ ∈ F → ＜x', y'＞ ∈ F → x ＝x' → y ＝ y'
class Function (F : Class) extends Relation F where
  isFunction : isFunction F

-- 6. AxiomInversion
axiom AxiomInversion :
  ∀X: Class, ∃Y: Class,
    ∀z: Class, (z ∈ Y)
      ↔ (∃x y: Class, ∃_: Set x, ∃_: Set y, ∃_:＜x,y＞ ∈ X,
        (z ＝ (＜y, x＞)))

theorem RelInvExists (R: Class):
  ∃RelInv_R: Class,
    ∀z: Class, (z ∈ RelInv_R)
      ↔ (∃x y: Class, ∃_: Set x, ∃_: Set y, ∃_:＜x,y＞ ∈ R,
        (z ＝ (＜y, x＞))) := AxiomInversion R
noncomputable def RelInv (R: Class): Class :=
  choose (AxiomInversion R)

-- 7. AxiomDomain
axiom AxiomDomain :
  ∀X: Class, ∃D: Class,
    ∀x: Class, ∀_: Set x,
      (x∈D ↔ ∃y: Class, ∃_: Set y, (＜x, y＞ ∈ X))

noncomputable def Dom (X: Class): Class :=
  choose (AxiomDomain X)
noncomputable def Rng (X: Class) [Relation X]: Class :=
  choose (AxiomDomain (RelInv X))

-- 8. AxiomMembership
axiom AxiomMembership :
  ∃E: Class,
    ∀x y: Class, ∀_: Set x, ∀_: Set y,
      (＜x, y＞ ∈ E ↔ x∈y)

-- class E
noncomputable def E: Class := choose AxiomMembership

-- Image type
theorem ImageClassExists (R X: Class) [hR: Relation R]:
  ∃Im: Class, ∀y: Class, ∀_: Set y,
    ((y ∈ Im)
      ↔ (∃x: Class, ∃(hx:x ∈ X), ((@OrdPair_mk x y (Set.mk₁ hx) _)∈ R))) := by {
  have : Relation (R ∩ (X ✕ U)) := sorry;
  let im := Rng (R ∩ (X ✕ U));
  exists im;
  sorry;
}
noncomputable def Im (R X: Class) [Relation R]: Class :=
  choose (ImageClassExists R X)

-- PowerClass
noncomputable def PowerClass_mk' (X : Class) : Class :=
  Diff U (Dom ((RelInv E) ∩ (U ✕ (Diff U X))))

theorem PowerClassExists (X : Class):
  ∃PX: Class,
    ∀z: Class, ∀_: Set z,
      z ∈ PX ↔ (z ⊂ X) := by {
  let px := Diff U (Dom ((RelInv E) ∩ (U ✕ (Diff U X))));
  exists px;
  sorry;
}

noncomputable def PowerClass_mk (X : Class) : Class :=
  choose (PowerClassExists X)
noncomputable instance : HasPow Class where
  Pow := PowerClass_mk

-- 9. AxiomCycle
axiom AxiomCycle :
  ∀X: Class, ∃Y: Class, ∀u v w: Class,
    ∃_: Set u, ∃_: Set v, ∃_: Set w,
      ＜u,v,w＞ ∈ X ↔ ＜w,u,v＞ ∈ Y
-- 10. AxiomReplacement
axiom AxiomReplacement :
  ∀F x: Class, ∀(hF: Function F), ∀(_: Set x),
    isSet (@Im F x hF.1)

-- 11. AxiomUnion
axiom AxiomUnion:
  ∀x: Class, (Set x) → ∃Z: Class,
    (Z ∈ U) ∧ (∀z: Class, z∈Z ↔ (∃y: Class, y∈x → z∈y))

noncomputable def UnionSet_mk (x: Class) [hx: Set x]: Class :=
  choose (AxiomUnion x hx)
-- 12. AxiomPowerSet
axiom AxiomPowerSet :
  ∀x: Class, Set x → isSet (𝒫 x)
-- 13. AxiomInfinity
axiom AxiomInfinity :
  ∃x: Class, (x∈U)
    ∧ ((ø∈x) ∧ ∀n: Class,
      ((hn: n ∈ x) → (n ∪ (@Singleton_mk n (Set.mk₁ hn))) ∈ x))

-- 14. AxiomFoundation
axiom AxiomFoundation :
  ∀x: Class, Set x
    → ¬ x＝ø → (∃y: Class, y∈x ∧ (∀z: Class, z∈y → z∉x))

-- 15. AxiomGlobalChoice
axiom AxiomGlobalChoice:
  ∃F: Class,∃_: Function F,∀x: Class, ∀_: Set x,
    (¬ x＝ø → (∃y: Class,∃hy: y∈x,
      (@Pair_mk x y _ (Set.mk₁ hy)) ∈ F))


import category_theory.limits.concrete_category
import category_theory.limits.preserves.limits

noncomputable theory

universes v u w

open category_theory

namespace category_theory

namespace limits

section
variables {J : Type w} (G : discrete J ⥤ Type (max w v))

@[simps]
def concrete.coproduct_cocone : cocone G :=
{ X := Σ (j : J), G.obj ⟨j⟩,
  ι := discrete.nat_trans begin
    rintros ⟨j⟩ x,
    exact ⟨j, x⟩,
  end, }

@[simps]
def concrete.coproduct_cocone_is_colimit :
  is_colimit (concrete.coproduct_cocone G) :=
{ desc := λ s x, s.ι.app ⟨x.1⟩ x.2,
  fac' := λ s, by { rintro ⟨j⟩, refl, },
  uniq' := λ s m hm, begin
    ext1 x,
    rcases x with ⟨j, y⟩,
    exact congr_fun (hm ⟨j⟩) y,
  end, }

@[simps]
lemma concrete.coproduct_iso : (concrete.coproduct_cocone G).X ≅ colimit G :=
is_colimit.cocone_point_unique_up_to_iso (concrete.coproduct_cocone_is_colimit G)
    (colimit.is_colimit _)

end

variables {C : Type u} [category.{v} C] [concrete_category.{(max w v)} C]
  {J : Type w} (F : J → C) [has_coproduct F]

@[simp]
def concrete.coproduct_map :
  (Σ (j : J), (forget C).obj (F j)) → (forget C).obj (sigma_obj F) :=
λ a, (forget C).map (sigma.ι F a.1) a.2

@[reassoc]
lemma concrete.coproduct_cocone_compat (j : discrete J) :
  (concrete.coproduct_cocone (discrete.functor F ⋙ forget C)).ι.app j ≫
    (concrete.coproduct_iso (discrete.functor F ⋙ forget C)).hom =
    colimit.ι (discrete.functor F ⋙ forget C) j :=
begin
  sorry,
end

lemma concrete.coproduct_map_bijective [hF : preserves_colimit (discrete.functor F) (forget C)] :
  function.bijective (concrete.coproduct_map F) :=
begin
  rw ← is_iso_iff_bijective,
  convert is_iso.of_iso (concrete.coproduct_iso (discrete.functor F ⋙ forget C) ≪≫
    (preserves_colimit_iso (forget C) (discrete.functor F)).symm),
  apply (concrete.coproduct_cocone_is_colimit (discrete.functor F ⋙ forget C)).hom_ext,
  intro j,
  dsimp only [iso.trans],
  rw [concrete.coproduct_cocone_compat_assoc],
  rw ← cancel_mono ((preserves_colimit_iso (forget C) (discrete.functor F)).symm.inv),
  simp only [category.assoc, iso.hom_inv_id, category.comp_id],
--  rintro ⟨j⟩,
--  dsimp only [iso.trans],
--  simp only [concrete.coproduct_map, concrete.coproduct_cocone_ι, id.def, discrete.nat_trans_app, forget_map_eq_coe, iso.symm_hom],
  sorry,
end

end limits

end category_theory


/-
Copyright (c) 2020 Adam Topaz. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Adam Topaz
-/
import category_theory.monad.basic
import category_theory.monoidal.End
import category_theory.monoidal.Mon_
import category_theory.category.Cat

/-!

# The equivalence between `Monad C` and `Mon_ (C ⥤ C)`.

A monad "is just" a monoid in the category of endofunctors.

# Definitions/Theorems

1. `to_Mon` associates a monoid object in `C ⥤ C` to any monad on `C`.
2. `Monad_to_Mon` is the functorial version of `to_Mon`.
3. `of_Mon` associates a monad on `C` to any monoid object in `C ⥤ C`.
4. `Monad_Mon_equiv` is the equivalence between `Monad C` and `Mon_ (C ⥤ C)`.

-/

namespace category_theory
open category

universes v u -- morphism levels before object levels. See note [category_theory universes].
variables {C : Type u} [category.{v} C]

namespace Monad
local attribute [instance, reducible] endofunctor_monoidal_category

/-- To every `Monad C` we associated a monoid object in `C ⥤ C`.-/
@[simps]
def to_Mon : monad C → Mon_ (C ⥤ C) := λ M,
{ X := (M : C ⥤ C),
  one := M.η,
  mul := M.μ,
  one_mul' := by { ext, simp }, -- `obviously` provides this, but slowly
  mul_one' := by { ext, simp }, -- `obviously` provides this, but slowly
  mul_assoc' := by { ext, dsimp, simp [M.assoc] } }

variable (C)
/-- Passing from `Monad C` to `Mon_ (C ⥤ C)` is functorial. -/
@[simps]
def Monad_to_Mon : monad C ⥤ Mon_ (C ⥤ C) :=
{ obj := to_Mon,
  map := λ _ _ f, { hom := f.to_nat_trans },
  map_id' := by { intros X, refl }, -- `obviously` provides this, but slowly
  map_comp' := by { intros X Y Z f g, refl, } }
variable {C}

/-- To every monoid object in `C ⥤ C` we associate a `Monad C`. -/
@[simps]
def of_Mon : Mon_ (C ⥤ C) → monad C := λ M,
{ to_functor := M.X,
  η' := M.one,
  μ' := M.mul,
  left_unit' := λ X, by { rw [←M.one.id_hcomp_app, ←nat_trans.comp_app, M.mul_one], refl },
  right_unit' := λ X, by { rw [←M.one.hcomp_id_app, ←nat_trans.comp_app, M.one_mul], refl },
  assoc' := λ X, by { rw [←nat_trans.hcomp_id_app, ←nat_trans.comp_app], simp } }

variable (C)
/-- Passing from `Mon_ (C ⥤ C)` to `Monad C` is functorial. -/
@[simps]
def Mon_to_Monad : Mon_ (C ⥤ C) ⥤ monad C :=
{ obj := of_Mon,
  map := λ _ _ f,
  { app_η' := begin
      intro X,
      erw [←nat_trans.comp_app, f.one_hom],
      refl,
    end,
    app_μ' := begin
      intro X,
      erw [←nat_trans.comp_app, f.mul_hom], -- `finish` closes this goal
      simpa only [nat_trans.naturality, nat_trans.hcomp_app, assoc, nat_trans.comp_app, of_Mon_μ],
    end,
    ..f.hom } }

namespace Monad_Mon_equiv
variable {C}

/-- Isomorphism of functors used in `Monad_Mon_equiv` -/
@[simps {rhs_md := semireducible}]
def counit_iso : Mon_to_Monad C ⋙ Monad_to_Mon C ≅ 𝟭 _ :=
{ hom := { app := λ _, { hom := 𝟙 _ } },
  inv := { app := λ _, { hom := 𝟙 _ } },
  hom_inv_id' := by { ext, simp }, -- `obviously` provides these, but slowly
  inv_hom_id' := by { ext, simp } }

/-- Auxiliary definition for `Monad_Mon_equiv` -/
@[simps]
def unit_iso_hom : 𝟭 _ ⟶ Monad_to_Mon C ⋙ Mon_to_Monad C :=
{ app := λ _, { app := λ _, 𝟙 _ } }

/-- Auxiliary definition for `Monad_Mon_equiv` -/
@[simps]
def unit_iso_inv : Monad_to_Mon C ⋙ Mon_to_Monad C ⟶ 𝟭 _ :=
{ app := λ _, { app := λ _, 𝟙 _ } }

/-- Isomorphism of functors used in `Monad_Mon_equiv` -/
@[simps]
def unit_iso : 𝟭 _ ≅ Monad_to_Mon C ⋙ Mon_to_Monad C :=
{ hom := unit_iso_hom,
  inv := unit_iso_inv,
  hom_inv_id' := by { ext, simp }, -- `obviously` provides these, but slowly
  inv_hom_id' := by { ext, simp } }

end Monad_Mon_equiv

open Monad_Mon_equiv

/-- Oh, monads are just monoids in the category of endofunctors (equivalence of categories). -/
@[simps]
def Monad_Mon_equiv : (monad C) ≌ (Mon_ (C ⥤ C)) :=
{ functor := Monad_to_Mon _,
  inverse := Mon_to_Monad _,
  unit_iso := unit_iso,
  counit_iso := counit_iso,
  functor_unit_iso_comp' := by { intros X, ext, dsimp, simp } } -- `obviously`, slowly

-- Sanity check
example (A : monad C) {X : C} : ((Monad_Mon_equiv C).unit_iso.app A).hom.app X = 𝟙 _ := rfl

end Monad
end category_theory


/-
Copyright (c) 2018 Patrick Massot. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Patrick Massot, Johannes Hölzl

Completion of topological groups:
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.topology.uniform_space.completion
import Mathlib.topology.algebra.uniform_group
import Mathlib.PostPort

universes u u_1 v

namespace Mathlib

protected instance uniform_space.completion.has_zero {α : Type u} [uniform_space α] [HasZero α] :
    HasZero (uniform_space.completion α) :=
  { zero := ↑0 }

protected instance uniform_space.completion.has_neg {α : Type u} [uniform_space α] [Neg α] :
    Neg (uniform_space.completion α) :=
  { neg := uniform_space.completion.map fun (a : α) => -a }

protected instance uniform_space.completion.has_add {α : Type u} [uniform_space α] [Add α] :
    Add (uniform_space.completion α) :=
  { add := uniform_space.completion.map₂ Add.add }

protected instance uniform_space.completion.has_sub {α : Type u} [uniform_space α] [Sub α] :
    Sub (uniform_space.completion α) :=
  { sub := uniform_space.completion.map₂ Sub.sub }

-- TODO: switch sides once #1103 is fixed

theorem uniform_space.completion.coe_zero {α : Type u} [uniform_space α] [HasZero α] : ↑0 = 0 := rfl

namespace uniform_space.completion

theorem coe_neg {α : Type u_1} [uniform_space α] [add_group α] [uniform_add_group α] (a : α) :
    ↑(-a) = -↑a :=
  Eq.symm (map_coe uniform_continuous_neg a)

theorem coe_sub {α : Type u_1} [uniform_space α] [add_group α] [uniform_add_group α] (a : α)
    (b : α) : ↑(a - b) = ↑a - ↑b :=
  Eq.symm (map₂_coe_coe a b Sub.sub uniform_continuous_sub)

theorem coe_add {α : Type u_1} [uniform_space α] [add_group α] [uniform_add_group α] (a : α)
    (b : α) : ↑(a + b) = ↑a + ↑b :=
  Eq.symm (map₂_coe_coe a b Add.add uniform_continuous_add)

protected instance sub_neg_monoid {α : Type u_1} [uniform_space α] [add_group α]
    [uniform_add_group α] : sub_neg_monoid (completion α) :=
  sub_neg_monoid.mk Add.add sorry 0 sorry sorry Neg.neg Sub.sub

protected instance add_group {α : Type u_1} [uniform_space α] [add_group α] [uniform_add_group α] :
    add_group (completion α) :=
  add_group.mk sub_neg_monoid.add sorry sub_neg_monoid.zero sorry sorry sub_neg_monoid.neg
    sub_neg_monoid.sub sorry

protected instance uniform_add_group {α : Type u_1} [uniform_space α] [add_group α]
    [uniform_add_group α] : uniform_add_group (completion α) :=
  uniform_add_group.mk (uniform_continuous_map₂ Sub.sub)

protected instance is_add_group_hom_coe {α : Type u_1} [uniform_space α] [add_group α]
    [uniform_add_group α] : is_add_group_hom coe :=
  is_add_group_hom.mk

theorem is_add_group_hom_extension {α : Type u_1} [uniform_space α] [add_group α]
    [uniform_add_group α] {β : Type v} [uniform_space β] [add_group β] [uniform_add_group β]
    [complete_space β] [separated_space β] {f : α → β} [is_add_group_hom f] (hf : continuous f) :
    is_add_group_hom (completion.extension f) :=
  (fun (hf : uniform_continuous f) => is_add_group_hom.mk) (uniform_continuous_of_continuous hf)

theorem is_add_group_hom_map {α : Type u_1} [uniform_space α] [add_group α] [uniform_add_group α]
    {β : Type v} [uniform_space β] [add_group β] [uniform_add_group β] {f : α → β}
    [is_add_group_hom f] (hf : continuous f) : is_add_group_hom (completion.map f) :=
  is_add_group_hom_extension (continuous.comp (continuous_coe β) hf)

protected instance add_comm_group {α : Type u} [uniform_space α] [add_comm_group α]
    [uniform_add_group α] : add_comm_group (completion α) :=
  add_comm_group.mk add_group.add sorry add_group.zero sorry sorry add_group.neg add_group.sub sorry
    sorry

end Mathlib


variables {p q : Prop} (hp : p) (hq : q)

section
  include hp hq

  example : p ∧ q ∧ p :=
  begin
    apply and.intro hp,
    exact and.intro hq hp
  end
end


import grid utils data.vector2 tactic.elide

open utils

namespace matrix

structure matrix (m n : ℕ) (α : Type) :=
  (g  : vec_grid₀ α)
  (hr : g.r = m)
  (hc : g.c = n)

section ext

variables {m n : ℕ} {α : Type} {m₁ m₂ : matrix m n α}

theorem ext_iff : m₁.g = m₂.g ↔ m₁ = m₂ :=
  by cases m₁; rcases m₂; simp

@[ext] theorem ext : m₁.g = m₂.g → m₁ = m₂ := ext_iff.1

end ext

section operations

variables {m n o p : ℕ} {α β γ δ : Type}

open relative_grid grid

lemma matrix_nonempty {m₁ : matrix m n α} : m * n > 0 :=
  by rcases m₁ with ⟨⟨⟨_, _, _, _⟩, _⟩, _, _⟩; finish

def matrix_string [has_to_string α] (m : matrix m n α) :=
  grid_str m.g

instance matrix_repr [has_to_string α] : has_repr (matrix m n α) :=
  ⟨matrix_string⟩

instance matrix_to_string [has_to_string α] : has_to_string (matrix m n α) :=
  ⟨matrix_string⟩

instance matrix_functor : functor (matrix m n) := {
  map := λα β f m,
    ⟨f <$> m.g, by rw [vec_grid₀_fmap_r, m.hr], by rw [vec_grid₀_fmap_c, m.hc]⟩
}

instance matrix_functor_law : is_lawful_functor (matrix m n) := {
  id_map := λα ⟨⟨⟨r, c, h, d⟩, o⟩, hr, hc⟩, by simp [(<$>), vector.map_id],
  comp_map := λα β γ f h ⟨⟨⟨r, c, h, d⟩, o⟩, hr, hc⟩, by simp [(<$>)]
}

def m₁ : matrix 5 2 ℕ :=
  matrix.mk
    (vec_grid₀.mk ⟨5, 2, dec_trivial, ⟨[1, 3, 4, 5, 7, 8, 9, 10, 11, 12], dec_trivial⟩⟩ ⟨5, 1⟩)
    rfl rfl

def m₂ : matrix 2 3 ℕ :=
  matrix.mk
    (vec_grid₀.mk ⟨2, 3, dec_trivial, ⟨[2, 2, 2, 2, 2, 2], dec_trivial⟩⟩ ⟨0, 0⟩)
    rfl rfl

instance [has_add α] : has_add (matrix m n α) := {
  add := λm₁ m₂,
    ⟨⟨⟨m, n, @matrix_nonempty _ _ _ m₁,
      begin
        rcases m₁ with ⟨⟨⟨g₁r, g₁c, g₁h, g₁d⟩, g₁o⟩, hr₁, hc₁⟩,
        rcases m₂ with ⟨⟨⟨g₂r, g₂c, g₂h, g₂d⟩, g₂o⟩, hr₂, hc₂⟩,
        simp at hr₁ hc₁ hr₂ hc₂, substs hc₁ hr₁ hc₂ hr₂,
        exact vector.zip_with (+) g₁d g₂d
      end⟩, ⟨0, 0⟩⟩, rfl, rfl⟩
}

def transpose (m₁ : matrix m n α) : matrix n m α :=
  ⟨(vec_grid₀_of_fgrid₀ ⟨
      n, m, mul_comm m n ▸ @matrix_nonempty _ _ _ m₁,
      ⟨m₁.g.o.y, m₁.g.o.x⟩,
      λx y, abs_data m₁.g ⟨
        ⟨y.1,
        begin
          cases y with y h, simp at h, simp [expand_gtr, grid.bl],
          have : ↑(rows (m₁.g)) = ↑m,
            by rcases m₁ with ⟨⟨⟨_, _, _, _⟩, _⟩, h₁, h₂⟩; substs h₁ h₂; simp [rows],
          rw this, exact h
        end⟩,
        ⟨x.1,
        begin
          cases x with x h, simp at h, simp [expand_gtr, grid.bl],
          have : ↑(cols (m₁.g)) = ↑n,
            by rcases m₁ with ⟨⟨⟨_, _, _, _⟩, _⟩, h₁, h₂⟩; substs h₁ h₂; simp [cols],
          rw this, exact h
        end⟩⟩⟩), by simp, by simp⟩

theorem transpose_transpose_id (m₁ : matrix m n α) :
  transpose (transpose m₁) = m₁ :=
begin
  rcases m₁ with ⟨⟨g, ⟨_, _⟩⟩, h₁, h₂⟩, subst h₁, subst h₂,
  unfold transpose, congr' 1,
  ext _; try { simp }, rw gen_aof_eq_gen,
  apply list.ext_le _ _,
    {
      repeat { rw length_generate_eq_size },
      simp [size, rows, cols]
    },
    {
      intros n h₁ h₂, rw nth_le_generate_f₀,
      simp [abs_data_eq_nth_v₀', tl, bl, vector.nth_eq_nth_le, vector.to_list],
      rw [← option.some_inj, ← list.nth_le_nth, nth_vecgrid_of_fgrid],
      have : |↑n % ↑g.c| + g.c * |↑n / ↑g.c| < list.length g.data.val,
        by rw [mul_comm, mod_add_div_coe]; rw generate_eq_data at h₂; exact h₂,
      simp [length_generate_eq_size, size] at h₂,
      have rpos : g.r > 0, from (gt_and_gt_of_mul_gt g.h).1,
      have cpos : g.c > 0, from (gt_and_gt_of_mul_gt g.h).2,
      have nltcr : n < g.r * g.c, by simp [rows, cols, *] at h₂; assumption,
      have h₃ : ↑(n / g.c) < ↑g.r,
        by rwa [int.coe_nat_lt_coe_nat_iff, nat.div_lt_iff_lt_mul _ _ cpos],
      rw nth_generate_f₀,
      simp [abs_data_eq_nth_v₀', vector.nth_eq_nth_le, list.nth_le_nth this, vector.to_list],
      rw [← with_bot.some_eq_coe], simp [generate_eq_data],
      congr,
        {
          have rnezero : g.r ≠ 0, by intros contra; rw contra at rpos; linarith,
          rw ← int.coe_nat_eq_coe_nat_iff, simp,
          repeat { rw int.nat_abs_of_nonneg; try { apply int.coe_zero_le } },
          rw @int.add_mul_div_right _ _ g.r (by simpa),
          norm_cast, rw nat.div_div_eq_div_mul, rw mul_comm g.c g.r,
          simp[@nat.div_eq_of_lt n (g.r * g.c) nltcr],
          norm_cast,
          have h₄ : (0 : ℤ) ≤ ↑(n / g.c), by simp,
          rw @int.mod_eq_of_lt ↑(n / g.c) ↑g.r h₄ h₃, rw mul_comm,
          apply int.mod_add_div
        },
        {
          rw length_generate_eq_size, simp [size, cols, rows],
          rw [add_comm],
          have h₄ : |↑n / ↑g.c| < g.r, by norm_cast at *; exact h₃,
          have h₅ : |↑n % ↑g.c| < g.c,
            begin
              rw [← int.coe_nat_lt_coe_nat_iff, int.nat_abs_of_nonneg],
              apply @int.mod_lt_of_pos ↑n ↑g.c (by norm_cast; exact cpos),
              have cnezero : g.c ≠ 0, by intros contra; rw contra at cpos; linarith,
              exact int.mod_nonneg _ (by simp [cnezero])
            end,
          exact linearize_array h₄ h₅
        }
    }
end

end operations

end matrix


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

import for_mathlib.dold_kan.functoriality_pseudoabelian
import for_mathlib.dold_kan.equivalence

/-!

# Functoriality of the Dold-Kan correspondence for abelian categories

-/

noncomputable theory

open category_theory
open category_theory.category
open category_theory.idempotents
open algebraic_topology

variables {A : Type*} [category A] [abelian A]
variables {B : Type*} [category B] [abelian B]

namespace category_theory

namespace abelian

namespace dold_kan

/-- Given an additive functor `F : A ⥤ B` between abelian categories,
this is the functoriality isomorphism between the two functors
`simplicial_object A ⥤ chain_complex B ℕ` obtained by
using the functors induced by `F` and the functor `N` in `A` or in `B`. -/
@[simps]
def functoriality_N (F : A ⥤ B) [functor.additive F]:
  (simplicial_object.whiskering A B).obj F ⋙ N ≅
  N ⋙ functor.map_homological_complex F (complex_shape.down ℕ) :=
begin
  calc (simplicial_object.whiskering A B).obj F ⋙ N
    ≅ (simplicial_object.whiskering A B).obj F ⋙ idempotents.dold_kan.N :
      iso_whisker_left _ comparison_N
  ... ≅ idempotents.dold_kan.N ⋙ functor.map_homological_complex F (complex_shape.down ℕ) :
    idempotents.dold_kan.functoriality_N F
  ... ≅ N ⋙ functor.map_homological_complex F (complex_shape.down ℕ) :
    iso_whisker_right comparison_N.symm _,
end

/- TODO: Compare this isomorphism with the mostly obvious natural transformation that
can be constructed from the original definition of the normalized Moore complex using kernels.

lemma compatibility_N_app (F : A ⥤ B) [functor.additive F]
  (X : simplicial_object A) :
  ((functoriality_N F).inv.app X) ≫
    ((inclusion_of_Moore_complex B).app (((simplicial_object.whiskering A B).obj F).obj X)) =
    (functor.map_homological_complex F (complex_shape.down ℕ)).map
      ((inclusion_of_Moore_complex A).app X) ≫
    eq_to_hom (congr_obj (map_alternating_face_map_complex F) X) := sorry
-/

end dold_kan

end abelian

end category_theory


import tactic
import algebra.ring.prod

noncomputable theory

variables {σ R S T : Type} [comm_ring R] [comm_ring S] [comm_ring T]

constant mv_polynomial (R : Type) [comm_ring R] (σ : Type) : Type

@[instance] constant mv_polynomial.comm_ring : comm_ring (mv_polynomial R σ)

namespace mv_polynomial

constant C : R →+* mv_polynomial R σ

constant X : σ → mv_polynomial R σ

constant eval₂ (f : R →+* S) (x : σ → S) : mv_polynomial R σ →+* S

@[simp] constant eval₂_comp_X (f : R →+* S) (x : σ → S) : eval₂ f x ∘ X = x

@[simp] constant eval₂_comp_C (f : R →+* S) (x : σ → S) : (eval₂ f x).comp C = f

@[simp] constant eval₂_X (f : R →+* S) (x : σ → S) (i : σ): eval₂ f x (X i) = x i

@[simp] constant eval₂_C (f : R →+* S) (x : σ → S) (r : R) : eval₂ f x (C r) = f r

@[ext] constant hom_ext {f g : mv_polynomial R σ →+* S} (h1 : f ∘ X = g ∘ X)
  (h2 : f.comp C = g.comp C) : f = g

def map (f : R →+* S) : mv_polynomial R σ →+* mv_polynomial S σ :=
eval₂ (C.comp f) X

@[ext] lemma sum.hom_ext {α β γ : Type} {f g : α ⊕ β → γ}
  (h1 : f ∘ sum.inl = g ∘ sum.inl)
  (h1 : f ∘ sum.inr = g ∘ sum.inr) : f = g :=
begin
  ext x, cases x; simp [function.funext_iff, *] at *,
end

@[simp] lemma sum.elim_comp_inl {α β γ : Type} {f : α  → γ} {g : β → γ} :
  sum.elim f g ∘ sum.inl = f :=
begin
  ext x, simp,
end

@[simp] lemma sum.elim_comp_inr {α β γ : Type} {f : α  → γ} {g : β → γ} :
  sum.elim f g ∘ sum.inr = g :=
begin
  ext x, simp,
end

example {α β : Type} : mv_polynomial R (α ⊕ β) ≃+* mv_polynomial (mv_polynomial R α) β :=
ring_equiv.of_hom_inv
  (eval₂ (C.comp C) (sum.elim (C ∘ X) X))
  (eval₂ (eval₂ C (X ∘ sum.inl)) (X ∘ sum.inr))
  begin
    ext; simp,
  end
  begin
    ext; simp,
  end
  -- (hom_ext (sum.hom_ext begin
  --   rw [ring_hom.coe_comp, ← function.comp.assoc _ _ sum.inl,
  --     function.comp.assoc _ _ X, eval₂_comp_X, function.comp.assoc,
  --     sum.elim_comp_inl, ← function.comp.assoc,
  --     ← ring_hom.coe_comp, eval₂_comp_C, eval₂_comp_X],
  --   refl
  -- end
  -- begin
  --   rw [ring_hom.coe_comp,
  --     function.comp.assoc _ _ X, eval₂_comp_X, function.comp.assoc,
  --     sum.elim_comp_inr, eval₂_comp_X],
  --   refl
  -- end)
  -- begin
  --   rw [ring_hom.comp_assoc, eval₂_comp_C, ← ring_hom.comp_assoc,
  --     eval₂_comp_C, eval₂_comp_C, ring_hom.id_comp]
  -- end)
  -- (hom_ext
  --   begin
  --     rw [ring_hom.coe_comp, function.comp.assoc _ _ X,
  --       eval₂_comp_X, ← function.comp.assoc, eval₂_comp_X, sum.elim_comp_inr],
  --    refl,
  --   end
  --   (hom_ext begin
  --     rw [ring_hom.id_comp, ring_hom.comp_assoc, eval₂_comp_C,
  --       ring_hom.coe_comp, function.comp.assoc, eval₂_comp_X,
  --       ← function.comp.assoc, eval₂_comp_X, sum.elim_comp_inl]
  --   end begin
  --     rw [ring_hom.comp_assoc _ (eval₂ _ _), eval₂_comp_C,
  --       ring_hom.comp_assoc, eval₂_comp_C, eval₂_comp_C,
  --       ring_hom.id_comp],
  --   end))

end mv_polynomial