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) 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