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

--OUTPUT 1
theorem irrational_orbit_dense {α : ℝ} (hα_irrat : irrational α) : closure ((λ m : ℤ, int.fract (α * ↑m)) '' (@set.univ ℤ)) = set.Icc 0 1 :=
begin
  have h1 : ∀ (i j : ℤ), i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j), from by {
    assume i j h,
    assume h2 : int.fract (α * ↑i) = int.fract (α * ↑j),
    have h3 : α * ↑i - ↑(int.floor (α * ↑i)) = α * ↑j - ↑(int.floor (α * ↑j)), from by {
      rw h2,
    },
    have h4 : α = (int.floor (α * ↑i) - int.floor (α * ↑j)) / (i - j), from by {
      rw [← int.cast_add, ← int.cast_mul, ← int.cast_sub, ← int.cast_mul, ← int.cast_sub, ← int.cast_mul, ← int.cast_sub, ← int.cast_mul, ← int.cast_sub, ← int.cast_mul, ← int.cast_sub, ← int.cast_mul, ← int.cast_sub, ← int.cast_mul, ← int.cast_sub, ← int.cast_mul, ← int.cast_sub, ← int.cast_mul, ← int.cast_sub, ← int.cast_mul, ← int.cast_sub, ← int.cast_mul, ← int.cast_sub, ← int.cast_mul, ← int.cast_sub, ← int.cast_mul, ← int.cast_sub, ← int.cast_mul, ← int.cast_sub, ← int.cast_mul, ← int.cast_sub, ← int.cast_mul, ← int.cast_sub, ← int.cast_mul, ← int.cast_sub, ← int.cast_mul, ← int.cast_sub, ← int.cast_mul, ← int.cast_sub, ← int.cast_mul, ← int.cast_sub, ← int.cast_mul, ← int.cast_sub, ← int.cast_mul, ← int.cast_sub, ← int.cast_mul, ← int.cast_sub, ← int.cast_mul, ← int.cast_sub, ← int.cast_mul, ← int.cast_sub, ← int.cast_mul, ← int.cast_sub, ← int.cast_mul, ← int.cast_sub, ← int.cast_mul, ← int.cast_sub, ← int.cast_mul, ← int.cast_sub, ← int.cast_mul, ← int.cast_sub, ← int.cast_mul, ← int.cast_sub, ← int.cast_mul, ← int.cast_sub, ← int.cast_mul, ← int.cast_sub, ← int.cast_mul, ← int.cast_sub, ← int.cast_mul, ← int.cast_sub, ← int.cast_mul, ← int.cast_sub, ← int.cast_mul, ← int.cast_sub, ← int.cast_mul, ← int.cast_sub, ← int.cast_mul, ← int.cast_sub, ← int.cast_mul, ← int.cast_sub, ← int.cast_mul, ← int.cast_sub, ← int.cast_mul, ← int.cast_sub, ← int.cast_mul, ← int.cast_sub, ← int.cast_mul, ← int.cast_sub, ← int.cast_mul, ← int.cast_sub, ← int.cast_mul, ← int.cast_sub, ← int.cast_mul, ← int.cast_sub, ← int.cast_mul, ← int.cast_sub, ← int.cast_mul, ← int.cast_sub, ← int.cast_mul, ← int.cast_sub, ← int.cast_mul, ← int.cast_sub, ← int.cast_mul, ← int.cast_sub, ← int.cast_mul, ← int.cast_sub, ← int.cast_mul, ← int.cast_sub, ← int.cast_mul, ← int.cast_sub, ← int.cast_mul, ← int.cast_sub, ← int.cast_mul, ← int.cast_sub, ← int.cast_mul, ← int.cast_sub, ← int.cast_mul, ← int.cast_sub, ← int.cast_mul, ← int.cast_sub, ← int.cast_mul, ← int.cast_sub, ← int.cast_mul, ← int.cast_sub, ← int.cast_mul, ← int.cast_sub, ← int.cast_mul, ← int.cast_sub, ← int.cast_mul, ← int.cast_sub, ← int.cast_mul, ← int.cast_sub, ← int.cast_mul, ← int.cast_sub, ← int.cast_mul, ← int.cast_sub, ← int.cast_mul, ← int.cast_sub, ← int.cast_mul, ← int.cast_sub, ← int.cast_mul, ← int.cast_sub, ← int.cast_mul, ← int.cast_sub, ← int.cast_mul, ← int.cast_sub, ← int.cast_mul, ← int.cast_sub, ← int.cast_mul, ← int.cast_sub, ← int.cast_mul, ← int.cast_sub, ← int.cast_mul, ← int.cast_sub, ← int.cast_mul, ← int.cast_sub, ← int.cast_mul, ← int.cast_sub, ← int.cast_mul, ← int.cast_sub, ← int.cast_mul, ← int.cast_sub, ← int.cast_mul, ← int.cast_sub, ← int.cast_mul, ← int.cast_sub, ← int.cast_mul, ← int.cast_sub, ← int.cast_mul, ← int.cast_sub, ← int.cast_mul, ← int.cast_sub, ← int.cast_mul, ← int.cast_sub, ← int.cast_mul, ← int.cast_sub, ← int.cast_mul, ← int.cast_sub, ← int.cast_mul, ← int.cast_sub, ← int.cast_mul, ← int.cast_sub, ← int.cast_mul, ← int.cast_sub, ← int.cast_mul, ← int.cast_sub, ← int.cast_mul, ← int.cast_sub, ← int.cast_mul, ← int.cast_sub, ← int.cast_mul, ← int.cast_sub, ← int.cast_mul, ← int.cast_sub, ← int.cast_mul, ← int.cast_sub, ← int.cast_mul, ← int.cast_sub, ← int.cast_mul, ← int.cast_sub, ← int.cast_mul, ← int.cast_sub, ← int.cast_mul, ← int.cast_sub, ← int.cast_mul, ← int.cast_sub, ← int.cast_mul, ← int.cast_sub, ← int.cast_mul, ← int.cast_sub, ← int.cast_mul, ← int.cast_sub, ← int.cast_mul, ← int.cast
end --Needs more than 2000 tokens!

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

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

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

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

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

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

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

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

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

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

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

Setting $b = a$, this becomes:

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

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

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

  have h3 : ∀ a : G, ∃! x : G, a * x = a, from
    assume a : G, h1 a a,
  have h4 : ∀ a : G, ∃! y : G, y * a = a, from
    assume a : G, h2 a a,

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

  show ∃! e : G, ∀ a : G, e * a = a ∧ a * e = a, from by {
    use (1 : G),
    have h7 : ∀ e : G, (∀ a : G, e * a = a ∧ a * e = a) → e = 1, from by {
      assume (e : G) (hident : ∀ a : G, e * a = a ∧ a * e = a),
      have h8 : ∀ a : G, e = classical.some (h3 a).exists, from assume (a : G),
        exists_unique.unique (h3 a) (hident a).right
        (classical.some_spec (exists_unique.exists (h3 a))),
      have h9 : ∀ a : G, e = classical.some (h4 a).exists, from assume (a : G),
        exists_unique.unique (h4 a) (hident a).left
        (classical.some_spec (exists_unique.exists (h4 a))),
      show e = (1 : G), from eq.trans (h9 e) (h6 _),
    },
    exact ⟨by obviously, h7⟩,
  }
end

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

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

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

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

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

Let $\epsilon > 0$.

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

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

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

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

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

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

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

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

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

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

Hence the result.
{{qed}}

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

  have h5 : ∀ x, |x - l| < ε ↔ (((l - ε) < x) ∧ (x < (l + ε))),
  from by
  {
    intro x0,
    have h6 : |x0 - l| < ε ↔ ((x0 - l) < ε) ∧ ((l - x0) < ε),
    from abs_sub_lt_iff, rw h6,
    split,
    rintro ⟨ S_1, S_2 ⟩,
    split; linarith,
    rintro ⟨ S_3, S_4 ⟩,
    split; linarith,
    },

  assume (h7 : ε > 0),
  cases h2 ε h7 with N1 h8,
  cases h3 ε h7 with N2 h9,

  let N := max N1 N2,
  use N,

  have h10 : ∀ n > N, n > N1 ∧ n > N2 := by {
    assume n h,
    split,
    exact lt_of_le_of_lt (le_max_left N1 N2) h,
    exact lt_of_le_of_lt (le_max_right N1 N2) h,
  },

  have h11 : ∀ n > N, (((l - ε) < (y n)) ∧ ((y n) ≤ (x n))) ∧ (((x n) ≤ (z n)) ∧ ((z n) < l+ε)),
  from by {
    intros n h12,
    split,
    {

      have h13 := (h8 n (h10 n h12).left), rw h5 (y n) at h13,
      split,
      exact h13.left,
      exact (h4 n).left,
    },
    {
      have h14 := (h9 n (h10 n h12).right),rw h5 (z n) at h14,
      split,
      exact (h4 n).right,
      exact h14.right,
    },

  },

  have h15 : ∀ n > N, ((l - ε) < (x n)) ∧ ((x n) < (l+ε)),
  from by {
    intros n1 h16, cases (h11 n1 h16);
    split; linarith,
  },

  show  ∀ (n : ℕ), n > N → |x n - l| < ε,
  from by {
    intros n h17,
    cases h5 (x n) with h18 h19,
    apply h19, exact h15 n h17,
  },
end

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

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

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

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


import defs

noncomputable theory
open nat finset function filter asymptotics
open_locale topological_space interval big_operators filter asymptotics arithmetic_function

-- h and h' are errors
variables {α : Type*} {f : α → ℝ} {g : α → ℝ} {h : α → ℝ} {h' : α → ℝ} {k : α → ℝ} {l : filter α}

namespace squarefree_sums

lemma is_Ot_comm : is_Ot f g h l ↔ is_Ot g f h l :=
begin
  unfold is_Ot,
  split,
  rintros ⟨c, hc⟩,
  use c,
  unfold is_O_with,
  unfold is_O_with at hc,
  simp,
  simp at hc,
  conv {
    congr,
    funext,
    rw real.norm_eq_abs,
    rw abs_sub_comm,
    rw ← real.norm_eq_abs,
  },
  exact hc,

  rintros ⟨c, hc⟩,
  use c,
  unfold is_O_with,
  unfold is_O_with at hc,
  simp,
  simp at hc,
  conv {
    congr,
    funext,
    rw real.norm_eq_abs,
    rw abs_sub_comm,  -- No norm_sub_comm?
    rw ← real.norm_eq_abs,
  },
  exact hc,
end

-- If f = g + O(h) and g = k + O(h) then f = k + O(h)
theorem is_Ot_trans_same_error :
is_Ot f g h l → is_Ot g k h l → is_Ot f k h l :=
begin
  unfold is_Ot,
  unfold is_O_with,
  rintros ⟨c, hc⟩,
  rintros ⟨d, hd⟩,
  use (c + d),
  simp at hc,
  simp at hd,
  rw eventually_iff_exists_mem,
  rw eventually_iff_exists_mem at hc,
  rw eventually_iff_exists_mem at hd,
  rcases hc with ⟨v, hv, hv'⟩,
  rcases hd with ⟨w, hw, hw'⟩,
  let V := v ∩ w,
  have hV : V ∈ l, simp [hv, hw],
  use V, split, exact hV,
  intros y hy,
  have hy_v : y ∈ v, calc y ∈ V : hy ... ⊆ v : by simp,
  have hy_w : y ∈ w, calc y ∈ V : hy ... ⊆ w : by simp,
  specialize hv' y hy_v,
  specialize hw' y hy_w,
  rw [real.norm_eq_abs, real.norm_eq_abs] at hv',
  rw [real.norm_eq_abs, real.norm_eq_abs] at hw',
  rw [real.norm_eq_abs, real.norm_eq_abs],
  simp,
  transitivity,
  exact abs_sub_le (f y) (g y) (k y),
  transitivity,
  exact add_le_add hv' hw',
  apply le_of_eq,
  ring,
end

lemma ughugh {a b : ℝ} :
a < 0 → 0 ≤ b → a * b ≤ 0 :=
begin
  intros ha hb,
  rw mul_nonpos_iff,
  right,
  split,
  exact le_of_lt ha,
  exact hb,
end

lemma is_O_with_abs {c : ℝ} :
is_O_with c f h l → is_O_with (|c|) f h l :=
begin
  unfold is_O_with,
  rw eventually_iff_exists_mem,
  rw eventually_iff_exists_mem,
  rintros ⟨v, hv, hv'⟩,
  use v, simp [hv],
  intros y hy,
  specialize hv' y hy,
  rw real.norm_eq_abs,
  rw real.norm_eq_abs,
  rw real.norm_eq_abs at hv',
  rw real.norm_eq_abs at hv',
  by_cases hc : 0 ≤ c,
    rw abs_of_nonneg hc,
    exact hv',

    push_neg at hc,
    have boo : c * |h y| ≤ 0, exact ughugh hc (abs_nonneg (h y)),
    have : 0 ≤ |f y|, exact abs_nonneg (f y),
    have : |f y| ≤ 0, calc |f y| ≤ c * |h y| : hv' ... ≤ 0 : boo,
    have : |f y| = 0, linarith,
    rw this,
    rw ← abs_mul,
    exact abs_nonneg (c * h y),
end

-- Can replace the error with a bigger error
theorem is_Ot_bigger_error :
is_Ot f g h l → asymptotics.is_O h h' l → is_Ot f g h' l :=
begin
  rintros ⟨c, hc⟩,
  intros hh',
  rw is_O_iff_is_O_with at hh',
  rcases hh' with ⟨c', hc'⟩,
  unfold is_Ot,
  use |c| * c',
  exact is_O_with.trans (is_O_with_abs hc) hc' (abs_nonneg c),
end

theorem is_Ot_trans_bigger_error_left :
is_Ot f g h l → is_Ot g k h' l → is_O h h' l → is_Ot f k h' l :=
begin
  intros hfg hgk hhh',
  exact is_Ot_trans_same_error (is_Ot_bigger_error hfg hhh') hgk,
end

theorem is_Ot_trans_bigger_error_right :
is_Ot f g h' l → is_Ot g k h l → is_O h h' l → is_Ot f k h' l :=
begin
  intros hfg hgk hhh',
  exact is_Ot_trans_same_error hfg (is_Ot_bigger_error hgk hhh'),
end

lemma is_Ot.congr
(hfg : f = g) :
is_Ot f g h l
:=
begin
  unfold is_Ot,
  use 0,
  unfold is_O_with,
  simp [hfg],
end

end squarefree_sums


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

universes u v

namespace rbmap
variables {α : Type u} {β : Type v} {lt : α → α → Prop}

/- Auxiliary instances -/
private def rbmap_lt_is_swo {α : Type u} {β : Type v} {lt : α → α → Prop}
  [is_strict_weak_order α lt] : is_strict_weak_order (α × β) (rbmap_lt lt) :=
{ irrefl       := λ _, irrefl_of lt _,
  trans        := λ _ _ _ h₁ h₂, trans_of lt h₁ h₂,
  incomp_trans := λ _ _ _ h₁ h₂, incomp_trans_of lt h₁ h₂ }

private def rbmap_lt_dec {α : Type u} {β : Type v} {lt : α → α → Prop} [h : decidable_rel lt] :
  decidable_rel (@rbmap_lt α β lt) :=
λ a b, h a.1 b.1

local attribute [instance] rbmap_lt_is_swo rbmap_lt_dec

/- Helper lemmas for reusing rbtree results. -/

private lemma to_rbtree_mem {k : α} {m : rbmap α β lt} : k ∈ m → ∃ v : β, rbtree.mem (k, v) m :=
begin
  cases m with n p; cases n; intros h,
  { exact false.elim h },
  all_goals { existsi n_val.2, exact h }
end

private lemma eqv_entries_of_eqv_keys {k₁ k₂ : α} (v₁ v₂ : β) :
  k₁ ≈[lt] k₂ → (k₁, v₁) ≈[rbmap_lt lt] (k₂, v₂) :=
id

private lemma eqv_keys_of_eqv_entries {k₁ k₂ : α} {v₁ v₂ : β} :
  (k₁, v₁) ≈[rbmap_lt lt] (k₂, v₂) → k₁ ≈[lt] k₂ :=
id

private lemma eqv_entries [is_irrefl α lt] (k : α) (v₁ v₂ : β) : (k, v₁) ≈[rbmap_lt lt] (k, v₂) :=
and.intro (irrefl_of lt k) (irrefl_of lt k)

private lemma to_rbmap_mem [is_strict_weak_order α lt] {k : α} {v : β} {m : rbmap α β lt} :
  rbtree.mem (k, v) m → k ∈ m :=
begin
  cases m with n p; cases n; intros h,
  { exact false.elim h },
  { simp [has_mem.mem, rbmap.mem],
    exact @rbtree.mem_of_mem_of_eqv _ _ _ ⟨rbnode.red_node n_lchild n_val n_rchild, p⟩ _ _ h
      (eqv_entries _ _ _) },
  { simp [has_mem.mem, rbmap.mem],
    exact @rbtree.mem_of_mem_of_eqv _ _ _ ⟨rbnode.black_node n_lchild n_val n_rchild, p⟩ _ _ h
      (eqv_entries _ _ _) }
end

private lemma to_rbtree_mem' [is_strict_weak_order α lt] {k : α} {m : rbmap α β lt} (v : β) :
  k ∈ m → rbtree.mem (k, v) m :=
begin
  intro h,
  cases to_rbtree_mem h with v' hm,
  apply rbtree.mem_of_mem_of_eqv hm,
  apply eqv_entries
end

lemma eq_some_of_to_value_eq_some {e : option (α × β)} {v : β} :
  to_value e = some v → ∃ k, e = some (k, v) :=
begin
  cases e with val; simp [to_value, false_implies_iff],
  { cases val, simp, intro h, subst v, constructor, refl }
end

lemma eq_none_of_to_value_eq_none {e : option (α × β)} : to_value e = none → e = none :=
by cases e; simp [to_value, false_implies_iff]

/- Lemmas -/

lemma not_mem_mk_rbmap : ∀ (k : α), k ∉ mk_rbmap α β lt :=
by simp [has_mem.mem, mk_rbmap, mk_rbtree, rbmap.mem]

lemma not_mem_of_empty {m : rbmap α β lt} (k : α) : m.empty = tt → k ∉ m :=
by cases m with n p; cases n;
  simp [has_mem.mem, mk_rbmap, mk_rbtree, rbmap.mem, rbmap.empty, rbtree.empty, false_implies_iff]

lemma mem_of_mem_of_eqv [is_strict_weak_order α lt] {m : rbmap α β lt} {k₁ k₂ : α} :
  k₁ ∈ m → k₁ ≈[lt] k₂ → k₂ ∈ m :=
begin
  intros h₁ h₂,
  have h₁ := to_rbtree_mem h₁, cases h₁ with v h₁,
  exact to_rbmap_mem (rbtree.mem_of_mem_of_eqv h₁ (eqv_entries_of_eqv_keys v v h₂))
end

section decidable

variables [decidable_rel lt]

lemma not_mem_of_find_entry_none [is_strict_weak_order α lt] {k : α} {m : rbmap α β lt} :
  m.find_entry k = none → k ∉ m :=
begin
  cases m with t p, cases t; simp [find_entry],
  { intros, simp [has_mem.mem, rbmap.mem] },
  all_goals { intro h, exact rbtree.not_mem_of_find_none h, }
end

lemma not_mem_of_find_none [is_strict_weak_order α lt] {k : α} {m : rbmap α β lt} :
  m.find k = none → k ∉ m :=
begin
  simp [find], intro h,
  have := eq_none_of_to_value_eq_none h,
  exact not_mem_of_find_entry_none this
end

lemma mem_of_find_entry_some [is_strict_weak_order α lt] {k₁ : α} {e : α × β} {m : rbmap α β lt} :
  m.find_entry k₁ = some e → k₁ ∈ m :=
begin
  cases m with t p, cases t; simp [find_entry, false_implies_iff],
  all_goals { intro h, exact rbtree.mem_of_find_some h }
end

lemma mem_of_find_some [is_strict_weak_order α lt] {k : α} {v : β} {m : rbmap α β lt} :
  m.find k = some v → k ∈ m :=
begin
  simp [find], intro h,
  have := eq_some_of_to_value_eq_some h,
  cases this with _ he,
  exact mem_of_find_entry_some he
end

lemma find_entry_eq_find_entry_of_eqv [is_strict_weak_order α lt] {m : rbmap α β lt} {k₁ k₂ : α} :
  k₁ ≈[lt] k₂ → m.find_entry k₁ = m.find_entry k₂ :=
begin
  intro h, cases m with t p, cases t; simp [find_entry],
  all_goals { apply rbtree.find_eq_find_of_eqv, apply eqv_entries_of_eqv_keys, assumption }
end

lemma find_eq_find_of_eqv [is_strict_weak_order α lt] {k₁ k₂ : α} (m : rbmap α β lt) :
  k₁ ≈[lt] k₂ → m.find k₁ = m.find k₂ :=
begin intro h, simp [find], apply congr_arg, apply find_entry_eq_find_entry_of_eqv, assumption end

lemma find_entry_correct [is_strict_weak_order α lt] (k : α) (m : rbmap α β lt) :
  k ∈ m ↔ (∃ e, m.find_entry k = some e ∧ k ≈[lt] e.1) :=
begin
  apply iff.intro; cases m with t p,
  { intro h,
    have h   := to_rbtree_mem h, cases h with v h₁,
    have hex := iff.mp (rbtree.find_correct _ _) h₁, cases hex with e h₂,
    existsi e, cases t; simp [find_entry] at ⊢ h₂,
    { simp [rbtree.find, rbnode.find] at h₂, cases h₂ },
    { cases h₂ with h₂₁ h₂₂, split,
      { have := rbtree.find_eq_find_of_eqv ⟨rbnode.red_node t_lchild t_val t_rchild, p⟩
          (eqv_entries k v t_val.2),
        rw [←this], exact h₂₁ },
      { cases e, apply eqv_keys_of_eqv_entries h₂₂ } },
    { cases h₂ with h₂₁ h₂₂, split,
      { have := rbtree.find_eq_find_of_eqv ⟨rbnode.black_node t_lchild t_val t_rchild, p⟩
          (eqv_entries k v t_val.2),
        rw [←this], exact h₂₁ },
      { cases e, apply eqv_keys_of_eqv_entries h₂₂ } } },
  { intro h, cases h with e h,
    cases h with h₁ h₂, cases t; simp [find_entry] at h₁,
    { contradiction },
    all_goals { exact to_rbmap_mem (rbtree.mem_of_find_some h₁) } }
end

lemma eqv_of_find_entry_some [is_strict_weak_order α lt] {k₁ k₂ : α} {v : β} {m : rbmap α β lt} :
  m.find_entry k₁ = some (k₂, v) → k₁ ≈[lt] k₂ :=
begin
  cases m with t p, cases t; simp [find_entry, false_implies_iff],
  all_goals { intro h, exact eqv_keys_of_eqv_entries (rbtree.eqv_of_find_some h) }
end

lemma eq_of_find_entry_some [is_strict_total_order α lt] {k₁ k₂ : α} {v : β} {m : rbmap α β lt} :
  m.find_entry k₁ = some (k₂, v) → k₁ = k₂ :=
λ h, suffices k₁ ≈[lt] k₂, from eq_of_eqv_lt this,
     eqv_of_find_entry_some h

lemma find_correct [is_strict_weak_order α lt] (k : α) (m : rbmap α β lt) :
  k ∈ m ↔ ∃ v, m.find k = some v :=
begin
  apply iff.intro,
  { intro h,
    have := iff.mp (find_entry_correct k m) h,
    cases this with e h, cases h with h₁ h₂,
    existsi e.2, simp [find, h₁, to_value] },
  { intro h,
    cases h with v h,
    simp [find] at h,
    have h := eq_some_of_to_value_eq_some h,
    cases h with k' h,
    have heqv := eqv_of_find_entry_some h,
    exact iff.mpr (find_entry_correct k m) ⟨(k', v), ⟨h, heqv⟩⟩ }
end

lemma constains_correct [is_strict_weak_order α lt] (k : α) (m : rbmap α β lt) :
  k ∈ m ↔ m.contains k = tt :=
begin
  apply iff.intro,
  { intro h,
    have h := iff.mp (find_entry_correct k m) h,
    cases h with e h, cases h with h₁ h₂,
    simp [contains, h₁, option.is_some] },
  { simp [contains],
    intro h,
    generalize he : find_entry m k = e,
    cases e,
    { simp [he, option.is_some] at h, contradiction },
    { exact mem_of_find_entry_some he } }
end

lemma mem_insert_of_incomp [is_strict_weak_order α lt] {k₁ k₂ : α} (m : rbmap α β lt) (v : β) :
  (¬ lt k₁ k₂ ∧ ¬ lt k₂ k₁) → k₁ ∈ m.insert k₂ v :=
λ h, to_rbmap_mem (rbtree.mem_insert_of_incomp m (eqv_entries_of_eqv_keys v v h))

lemma mem_insert [is_strict_weak_order α lt] (k : α) (m : rbmap α β lt) (v : β) :
  k ∈ m.insert k v :=
to_rbmap_mem (rbtree.mem_insert (k, v) m)

lemma mem_insert_of_equiv [is_strict_weak_order α lt] {k₁ k₂ : α} (m : rbmap α β lt) (v : β) :
  k₁ ≈[lt] k₂ → k₁ ∈ m.insert k₂ v :=
mem_insert_of_incomp m v

lemma mem_insert_of_mem [is_strict_weak_order α lt] {k₁ : α} {m : rbmap α β lt} (k₂ : α) (v : β) :
  k₁ ∈ m → k₁ ∈ m.insert k₂ v :=
λ h, to_rbmap_mem (rbtree.mem_insert_of_mem (k₂, v) (to_rbtree_mem' v h))

lemma equiv_or_mem_of_mem_insert [is_strict_weak_order α lt] {k₁ k₂ : α} {v : β}
  {m : rbmap α β lt} : k₁ ∈ m.insert k₂ v → k₁ ≈[lt] k₂ ∨ k₁ ∈ m :=
λ h, or.elim (rbtree.equiv_or_mem_of_mem_insert (to_rbtree_mem' v h))
  (λ h, or.inl (eqv_keys_of_eqv_entries h))
  (λ h, or.inr (to_rbmap_mem h))

lemma incomp_or_mem_of_mem_ins [is_strict_weak_order α lt] {k₁ k₂ : α} {v : β} {m : rbmap α β lt} :
  k₁ ∈ m.insert k₂ v → (¬ lt k₁ k₂ ∧ ¬ lt k₂ k₁) ∨ k₁ ∈ m :=
equiv_or_mem_of_mem_insert

lemma eq_or_mem_of_mem_ins [is_strict_total_order α lt] {k₁ k₂ : α} {v : β} {m : rbmap α β lt} :
  k₁ ∈ m.insert k₂ v → k₁ = k₂ ∨ k₁ ∈ m :=
λ h, suffices k₁ ≈[lt] k₂ ∨ k₁ ∈ m, by simp [eqv_lt_iff_eq] at this; assumption,
  incomp_or_mem_of_mem_ins h

lemma find_entry_insert_of_eqv [is_strict_weak_order α lt] (m : rbmap α β lt) {k₁ k₂ : α} (v : β) :
  k₁ ≈[lt] k₂ → (m.insert k₁ v).find_entry k₂ = some (k₁, v) :=
begin
  intro h,
  generalize h₁ : m.insert k₁ v = m',
  cases m' with t p, cases t,
  { have := mem_insert k₁ m v, rw [h₁] at this, apply absurd this, apply not_mem_mk_rbmap },
  all_goals { simp [find_entry], rw [←h₁, insert], apply rbtree.find_insert_of_eqv,
    apply eqv_entries_of_eqv_keys _ _ h }
end

lemma find_entry_insert [is_strict_weak_order α lt] (m : rbmap α β lt) (k : α) (v : β) :
  (m.insert k v).find_entry k = some (k, v) :=
find_entry_insert_of_eqv m v (refl k)

lemma find_insert_of_eqv [is_strict_weak_order α lt] (m : rbmap α β lt) {k₁ k₂ : α} (v : β) :
  k₁ ≈[lt] k₂ → (m.insert k₁ v).find k₂ = some v :=
begin
  intro h,
  have := find_entry_insert_of_eqv m v h,
  simp [find, this, to_value]
end

lemma find_insert [is_strict_weak_order α lt] (m : rbmap α β lt) (k : α) (v : β) :
  (m.insert k v).find k = some v :=
find_insert_of_eqv m v (refl k)

lemma find_entry_insert_of_disj [is_strict_weak_order α lt] {k₁ k₂ : α} (m : rbmap α β lt) (v : β) :
  lt k₁ k₂ ∨ lt k₂ k₁ → (m.insert k₁ v).find_entry k₂ = m.find_entry k₂ :=
begin
  intro h,
  have h' : ∀ {v₁ v₂ : β}, (rbmap_lt lt) (k₁, v₁) (k₂, v₂) ∨ (rbmap_lt lt) (k₂, v₂) (k₁, v₁) :=
    λ _ _, h,
  generalize h₁ : m = m₁,
  generalize h₂ : insert m₁ k₁ v = m₂,
  rw [←h₁] at h₂ ⊢, rw [←h₂],
  cases m₁ with t₁ p₁; cases t₁; cases m₂ with t₂ p₂; cases t₂,
  { rw [h₂, h₁] },
  iterate 2
  { rw [h₂],
    conv { to_lhs, simp [find_entry] },
    rw [←h₂, insert, rbtree.find_insert_of_disj _ h', h₁],
    refl },
  any_goals { simp [insert] at h₂,
    exact absurd h₂ (rbtree.insert_ne_mk_rbtree m (k₁, v)) },
  any_goals
  { rw [h₂, h₁], simp [find_entry], rw [←h₂, ←h₁, insert, rbtree.find_insert_of_disj _ h'],
    apply rbtree.find_eq_find_of_eqv, apply eqv_entries }
end

lemma find_entry_insert_of_not_eqv [is_strict_weak_order α lt] {k₁ k₂ : α} (m : rbmap α β lt)
  (v : β) : ¬ k₁ ≈[lt] k₂ → (m.insert k₁ v).find_entry k₂ = m.find_entry k₂ :=
begin
  intro hn,
  have he : lt k₁ k₂ ∨ lt k₂ k₁,
  { simp [strict_weak_order.equiv, decidable.not_and_iff_or_not, decidable.not_not_iff] at hn,
    assumption },
  apply find_entry_insert_of_disj _ _ he
end

lemma find_entry_insert_of_ne [is_strict_total_order α lt] {k₁ k₂ : α} (m : rbmap α β lt) (v : β) :
  k₁ ≠ k₂ → (m.insert k₁ v).find_entry k₂ = m.find_entry k₂ :=
begin
  intro h,
  have : ¬ k₁ ≈[lt] k₂ := λ h', h (eq_of_eqv_lt h'),
  apply find_entry_insert_of_not_eqv _ _ this
end

lemma find_insert_of_disj [is_strict_weak_order α lt] {k₁ k₂ : α} (m : rbmap α β lt) (v : β) :
  lt k₁ k₂ ∨ lt k₂ k₁ → (m.insert k₁ v).find k₂ = m.find k₂ :=
begin intro h, have := find_entry_insert_of_disj m v h, simp [find, this] end

lemma find_insert_of_not_eqv [is_strict_weak_order α lt] {k₁ k₂ : α} (m : rbmap α β lt) (v : β) :
  ¬ k₁ ≈[lt] k₂ → (m.insert k₁ v).find k₂ = m.find k₂ :=
begin intro h, have := find_entry_insert_of_not_eqv m v h, simp [find, this] end

lemma find_insert_of_ne [is_strict_total_order α lt] {k₁ k₂ : α} (m : rbmap α β lt) (v : β) :
  k₁ ≠ k₂ → (m.insert k₁ v).find k₂ = m.find k₂ :=
begin intro h, have := find_entry_insert_of_ne m v h, simp [find, this] end

end decidable

lemma mem_of_min_eq [is_strict_total_order α lt] {k : α} {v : β} {m : rbmap α β lt} :
  m.min = some (k, v) → k ∈ m :=
λ h, to_rbmap_mem (rbtree.mem_of_min_eq h)

lemma mem_of_max_eq [is_strict_total_order α lt] {k : α} {v : β} {m : rbmap α β lt} :
  m.max = some (k, v) → k ∈ m :=
λ h, to_rbmap_mem (rbtree.mem_of_max_eq h)

lemma eq_leaf_of_min_eq_none {m : rbmap α β lt} :
  m.min = none → m = mk_rbmap α β lt :=
rbtree.eq_leaf_of_min_eq_none

lemma min_is_minimal [is_strict_weak_order α lt] {k : α} {v : β} {m : rbmap α β lt} :
  m.min = some (k, v) → ∀ {k'}, k' ∈ m → k ≈[lt] k' ∨ lt k k' :=
λ h k' hm, or.elim (rbtree.min_is_minimal h (to_rbtree_mem' v hm))
  (λ h, or.inl (eqv_keys_of_eqv_entries h))
  (λ h, or.inr h)

lemma max_is_maximal [is_strict_weak_order α lt] {k : α} {v : β} {m : rbmap α β lt} :
  m.max = some (k, v) → ∀ {k'}, k' ∈ m → k ≈[lt] k' ∨ lt k' k :=
λ h k' hm, or.elim (rbtree.max_is_maximal h (to_rbtree_mem' v hm))
  (λ h, or.inl (eqv_keys_of_eqv_entries h))
  (λ h, or.inr h)

lemma min_is_minimal_of_total [is_strict_total_order α lt] {k : α} {v : β} {m : rbmap α β lt} :
  m.min = some (k, v) → ∀ {k'}, k' ∈ m → k = k' ∨ lt k k' :=
λ h k' hm,
  match min_is_minimal h hm with
  | or.inl h := or.inl (eq_of_eqv_lt h)
  | or.inr h := or.inr h
  end

lemma max_is_maximal_of_total [is_strict_total_order α lt] {k : α} {v : β} {m : rbmap α β lt} :
  m.max = some (k, v) → ∀ {k'}, k' ∈ m → k = k' ∨ lt k' k :=
λ h k' hm,
  match max_is_maximal h hm with
  | or.inl h := or.inl (eq_of_eqv_lt h)
  | or.inr h := or.inr h
  end

end rbmap


@[derive decidable_eq]
inductive horner : list int → Type
| cnst : int → horner []
| lift (x : int) {xs : list int} : horner xs → horner (x :: xs)
| mult {x : int} {xs : list int} : horner xs → horner (x :: xs) → horner (x :: xs)

run_cmd mk_simp_attr `horner_calc

namespace horner

def sizeof' : Π {xs : list int}, horner xs → nat
| [] (cnst _) := 1
| (_ :: _) (lift _ a) := 1 + sizeof' a
| (_ :: _) (mult a₀ a₁) := 1 + sizeof' a₀ + sizeof' a₁

lemma sizeof_pos' : ∀ {xs : list int} (a : horner xs), 0 < sizeof' a
| [] (cnst _) := nat.zero_lt_one
| (_ :: _) (lift _ a) := by { unfold sizeof', apply nat.lt_add_right, exact nat.zero_lt_one }
| (_ :: _) (mult a₀ a₁) := by { unfold sizeof', apply nat.lt_add_right, apply nat.lt_add_right, exact nat.zero_lt_one }

instance (xs : list int) : has_sizeof (horner xs) := ⟨sizeof'⟩

@[horner_calc, reducible]
def zero : Π {xs : list int}, horner xs
| [] := cnst 0
| (_ :: _) := lift _ zero

@[horner_calc, reducible]
def one : Π {xs : list int}, horner xs
| [] := cnst 1
| (_ :: _) := lift _ one

@[horner_calc, reducible]
def add : Π {xs : list int}, horner xs → horner xs → horner xs
| [] (cnst a) (cnst b) := cnst (a + b)
| (x :: xs) (lift _ a) (lift _ b) := lift x (add a b)
| (x :: xs) (lift _ a) (mult b₀ b₁) := mult (add a b₀) b₁
| (x :: xs) (mult a₀ a₁) (lift _ b) := mult (add a₀ b) a₁
| (x :: xs) (mult a₀ a₁) (mult b₀ b₁) := mult (add a₀ b₀) (add a₁ b₁)

@[horner_calc, reducible]
def neg : Π {xs : list int}, horner xs → horner xs
| [] (cnst a) := cnst (-a)
| (x :: xs) (lift _ a) := lift x (neg a)
| (x :: xs) (mult a₀ a₁) := mult (neg a₀) (neg a₁)

@[horner_calc, reducible]
def sub {xs : list int} (a b : horner xs) := add a (neg b)

@[horner_calc, reducible]
def shl {x : int} {xs : list int} : horner (x :: xs) → horner (x :: xs) := mult zero

@[horner_calc, reducible]
def mul : Π {xs : list int}, horner xs → horner xs → horner xs
| [] (cnst a) (cnst b) := cnst (a * b)
| (x :: xs) (lift _ a) (lift _ b) := lift x (mul a b)
| (x :: xs) (lift _ a) (mult b₀ b₁) :=
  have sizeof b₁ < sizeof (mult b₀ b₁),
  begin
  unfold sizeof,
  unfold has_sizeof.sizeof,
  unfold sizeof',
  apply nat.lt_add_of_pos_left,
  apply nat.lt_add_right,
  apply nat.zero_lt_one,
  end,
  mult (mul a b₀) (mul (lift x a) b₁)
| (x :: xs) (mult a₀ a₁) b :=
  have sizeof (lift x a₀) < sizeof (mult a₀ a₁),
  begin
  unfold sizeof,
  unfold has_sizeof.sizeof,
  unfold sizeof',
  apply nat.lt_add_of_pos_right,
  apply sizeof_pos',
  end,
  have sizeof a₁ < sizeof (mult a₀ a₁),
  begin
  unfold sizeof,
  unfold has_sizeof.sizeof,
  unfold sizeof',
  apply nat.lt_add_of_pos_left,
  apply nat.lt_add_right,
  apply nat.zero_lt_one,
  end,
  add (mul (lift x a₀) b) (shl $ mul a₁ b)

@[horner_calc, reducible]
def is_zero : Π {xs : list int}, horner xs → Prop
| [] (cnst a) := a = 0
| (_ :: _) (lift _ a) := is_zero a
| (_ :: _) (mult a₀ a₁) := is_zero a₀ ∧ is_zero a₁

@[horner_calc, reducible]
def equiv {xs : list int} (a b : horner xs) : Prop := is_zero (sub a b)

instance is_zero.decidable : Π {xs : list int} (a : horner xs), decidable (is_zero a)
| [] (cnst a) := eq.decidable a 0
| (_ :: _) (lift _ a) := is_zero.decidable a
| (_ :: _) (mult a₀ a₁) := @and.decidable _ _ (is_zero.decidable a₀) (is_zero.decidable a₁)

instance equiv.decidable {xs : list int} (a b : horner xs) : decidable (equiv a b) := is_zero.decidable _

def eval : Π {xs : list int}, horner xs → int
| [] (cnst a) := a
| (x :: xs) (lift _ a) := eval a
| (x :: xs) (mult a₀ a₁) := eval a₀ + x * eval a₁

theorem eval_cnst (a : int) : eval (cnst a) = a := rfl

theorem eval_lift (x : int) {xs : list int} (a : horner xs) : eval (lift x a) = eval a := rfl

theorem eval_mult {x : int} {xs : list int} (a₀ : horner xs) (a₁ : horner (x :: xs)) : eval (mult a₀ a₁) = eval a₀ + x * eval a₁ := rfl

theorem eval_zero : ∀ (xs : list int), eval (zero : horner xs) = 0
| [] := rfl
| (_ :: xs) := eval_zero xs

theorem eval_one : ∀ (xs : list int), eval (one : horner xs) = 1
| [] := rfl
| (_ :: xs) := eval_one xs

theorem eval_neg : ∀ {xs : list int} (a : horner xs), eval (neg a) = - eval a
| [] (cnst _) := rfl
| (x :: xs) (lift _ a) := eval_neg a
| (x :: xs) (mult a₀ a₁) :=
  by { unfold neg, unfold eval, rw neg_add, rw neg_mul_eq_mul_neg, congr, exact eval_neg a₀, exact eval_neg a₁ }

theorem eval_add : ∀ {xs : list int} (a b : horner xs), eval (add a b) = eval a + eval b
| [] (cnst _) (cnst _) := rfl
| (x :: xs) (lift _ a) (lift _ b) := eval_add a b
| (x :: xs) (lift _ a) (mult b₀ b₁) :=
  by { unfold add, unfold eval, rw eval_add a b₀, ac_refl }
| (x :: xs) (mult a₀ a₁) (lift _ b) :=
  by { unfold add, unfold eval, rw eval_add a₀ b, ac_refl }
| (x :: xs) (mult a₀ a₁) (mult b₀ b₁) :=
  by { unfold add, unfold eval, rw eval_add a₀ b₀, rw eval_add a₁ b₁, rw mul_add x, ac_refl }

theorem eval_sub {xs : list int} (a b : horner xs) : eval (sub a b) = eval a - eval b :=
by rw [eval_add, eval_neg, sub_eq_add_neg]

theorem eval_shl (x : int) {xs : list int} (a : horner (x :: xs)) : eval (shl a) = x * eval a :=
by rw [eval_mult, eval_zero, zero_add]

theorem eval_mul : ∀ {xs : list int} (a b : horner xs), eval (mul a b) = eval a * eval b
| [] (cnst _) (cnst _) := rfl
| (x :: xs) (lift _ a) (lift _ b) :=
  begin
  unfold mul,
  unfold eval,
  exact eval_mul a b,
  end
| (_ :: _) (lift x a) (mult b₀ b₁) :=
  have sizeof b₁ < sizeof (mult b₀ b₁),
  begin
  unfold sizeof,
  unfold has_sizeof.sizeof,
  unfold sizeof',
  apply nat.lt_add_of_pos_left,
  apply nat.lt_add_right,
  apply nat.zero_lt_one,
  end,
  begin
  unfold mul,
  unfold eval,
  rw eval_mul a b₀,
  rw eval_mul (lift x a) b₁,
  rw eval_lift x a,
  rw mul_add,
  ac_refl,
  end
| (x :: _) (mult a₀ a₁) b :=
  have sizeof (lift x a₀) < sizeof (mult a₀ a₁),
  begin
  unfold sizeof,
  unfold has_sizeof.sizeof,
  unfold sizeof',
  apply nat.lt_add_of_pos_right,
  apply sizeof_pos',
  end,
  have sizeof a₁ < sizeof (mult a₀ a₁),
  begin
  unfold sizeof,
  unfold has_sizeof.sizeof,
  unfold sizeof',
  apply nat.lt_add_of_pos_left,
  apply nat.lt_add_right,
  apply nat.zero_lt_one,
  end,
  begin
  unfold mul,
  unfold eval,
  rw eval_add,
  rw eval_shl,
  rw eval_mul (lift x a₀) b,
  rw eval_lift,
  rw eval_mul a₁ b,
  rw add_mul,
  ac_refl,
  end

theorem eval_zero_of_is_zero : Π {xs : list int} {a : horner xs}, is_zero a → eval a = 0
| [] (cnst a) h := h
| (_ :: _) (lift _ a) h :=
  have is_zero a, from h,
  eval_zero_of_is_zero this
| (x :: _) (mult a₀ a₁) h :=
  show eval a₀ + x * eval a₁ = 0,
  by rw [eval_zero_of_is_zero h.left, eval_zero_of_is_zero h.right, zero_add, mul_zero]

theorem eval_eq_of_equiv {xs : list int} {a b : horner xs} : equiv a b → eval a = eval b :=
begin
intro h,
have h : eval (sub a b) = 0,
from eval_zero_of_is_zero h,
rw eval_sub at h,
exact eq_of_sub_eq_zero h,
end

end horner

class int_ring (xs : list int) (a : int) :=
(expr : horner xs)
(eval : expr.eval = a)

namespace int_ring

@[priority 0]
instance cnst (a : int) : int_ring [] a :=
{ expr := horner.cnst a
, eval := rfl
}

instance lift (x : int) (xs : list int) (a : int) [int_ring xs a] : int_ring (x :: xs) a :=
{ expr := horner.lift x (int_ring.expr xs a)
, eval := by rw [horner.eval_lift, int_ring.eval xs a]
}

instance var (x : int) (xs : list int) : int_ring (x :: xs) x :=
{ expr := horner.mult horner.zero horner.one
, eval := by rw [horner.eval_mult, horner.eval_zero, horner.eval_one, zero_add, mul_one]
}

instance add (xs : list int) (a b : int) [int_ring xs a] [int_ring xs b] : int_ring xs (a + b) :=
{ expr := horner.add (int_ring.expr xs a) (int_ring.expr xs b)
, eval := by rw [horner.eval_add, int_ring.eval xs a, int_ring.eval xs b]
}

instance mul (xs : list int) (a b : int) [int_ring xs a] [int_ring xs b] : int_ring xs (a * b) :=
{ expr := horner.mul (int_ring.expr xs a) (int_ring.expr xs b)
, eval := by rw [horner.eval_mul, int_ring.eval xs a, int_ring.eval xs b]
}

instance neg (xs : list int) (a : int) [int_ring xs a] : int_ring xs (-a) :=
{ expr := horner.neg (int_ring.expr xs a)
, eval := by rw [horner.eval_neg, int_ring.eval xs a]
}

instance sub (xs : list int) (a b : int) [int_ring xs a] [int_ring xs b] : int_ring xs (a - b) :=
{ expr := horner.sub (int_ring.expr xs a) (int_ring.expr xs b)
, eval := by rw [horner.eval_sub, int_ring.eval xs a, int_ring.eval xs b]
}

protected theorem eq (xs : list int) {a b : int} [int_ring xs a] [int_ring xs b] : horner.equiv (int_ring.expr xs a) (int_ring.expr xs b) →  a = b :=
begin
intro h,
rw ← int_ring.eval xs a,
rw ← int_ring.eval xs b,
exact horner.eval_eq_of_equiv h,
end

end int_ring

meta def int_refl_default : tactic unit :=
`[unfold int_ring.expr, trace_state, simp only [] with horner_calc, trace_state, repeat { apply and.intro }, all_goals { simp }]

theorem int_refl (xs : list int) {a b : int} [int_ring xs a] [int_ring xs b] (h : horner.equiv (int_ring.expr xs a) (int_ring.expr xs b) . int_refl_default) : a = b :=
begin
rw ← int_ring.eval xs a,
rw ← int_ring.eval xs b,
exact horner.eval_eq_of_equiv h,
end

namespace tactic
open interactive

meta def interactive.int_refl : parse types.texpr → tactic unit :=
λ lst, do {
  `(@eq int %%lhs %%rhs) ← target,
  lhi ← to_expr ``(int_ring %%lst %%lhs) >>= mk_instance,
  rhi ← to_expr ``(int_ring %%lst %%rhs) >>= mk_instance,
  to_expr ``(@int_ring.eq %%lst %%lhs %%rhs %%lhi %%rhi) >>= apply,
  unfold_projs_target,
  `[simp only with horner_calc],
  repeat (do {
    `(and %%l %%r) ← target,
    to_expr ``(and.intro) >>= apply,
    skip
  }),
  all_goals reflexivity
}

end tactic


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


import algebraic_topology.cech_nerve

universes v u

noncomputable theory

open_locale simplicial

namespace category_theory

open category_theory.limits

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

namespace simplicial_object

variables [∀ (n : ℕ) (f : arrow C),
  has_wide_pullback.{0} f.right (λ i : fin (n+1), f.left) (λ i, f.hom)]

section
open simplex_category opposite limits.wide_pullback

lemma hom_ext (X : simplicial_object.augmented C) (F : arrow C)
  (f g : X ⟶ F.augmented_cech_nerve) (hl : f.left.app (op [0]) = g.left.app (op [0]))
  (hr : f.right = g.right) :
  f = g :=
begin
  apply (cech_nerve_equiv X F).symm.injective,
  dsimp only [cech_nerve_equiv_symm_apply],
  ext1,
  { simp only [equivalence_right_to_left_left],
    rw hl },
  { exact hr }
end

-- move this
@[simps]
def augmented_cech_nerve.left_obj_zero_iso (F : arrow C) :
  F.augmented_cech_nerve.left.obj (op [0]) ≅ F.left :=
{ hom := π _ 0,
  inv := lift F.hom (λ _, 𝟙 _) (λ _, category.id_comp _),
  hom_inv_id' :=
  begin
    ext,
    { rw [category.assoc, lift_π, category.id_comp, category.comp_id],
      congr' 2, dsimp at j ⊢, exact subsingleton.elim _ _ },
    { simp only [π_arrow, category.id_comp, limits.wide_pullback.lift_base, category.assoc], }
  end,
  inv_hom_id' := lift_π _ _ _ _ _ }
.

-- move this
lemma augmented_cech_nerve.left_map_comp_obj_zero_iso
  (F : arrow C) (n : simplex_category) (i : (fin (n.len+1))) :
  F.augmented_cech_nerve.left.map (n.const i).op ≫ (augmented_cech_nerve.left_obj_zero_iso F).hom =
  wide_pullback.π _ i :=
begin
  rw [← iso.eq_comp_inv],
  dsimp only [arrow.augmented_cech_nerve_left, arrow.cech_nerve_map,
    augmented_cech_nerve.left_obj_zero_iso_inv],
  ext1 ⟨j⟩,
  { rw [limits.wide_pullback.lift_π, category.assoc, limits.wide_pullback.lift_π, category.comp_id],
    cases i, refl },
  { rw [limits.wide_pullback.lift_base, category.assoc, limits.wide_pullback.lift_base,
      limits.wide_pullback.π_arrow], }
end
.

@[simp]
lemma equivalence_left_to_right_left_app_zero_comp_π
  (X : simplicial_object.augmented C) (F : arrow C) (G : augmented.to_arrow.obj X ⟶ F) (i) :
  (equivalence_left_to_right X F G).left.app (op [0]) ≫ limits.wide_pullback.π _ i =
  G.left :=
begin
  dsimp only [equivalence_left_to_right_left_app, unop_op],
  rw [limits.wide_pullback.lift_π, simplex_category.hom_zero_zero ([0].const i),
    op_id, X.left.map_id, category.id_comp],
end
.

end

end simplicial_object

end category_theory


/-
Copyright (c) 2018 Andreas Swerdlow. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Andreas Swerdlow
-/
import deprecated.subring
import algebra.group_with_zero.power

/-!
# Unbundled subfields (deprecated)

This file is deprecated, and is no longer imported by anything in mathlib other than other
deprecated files, and test files. You should not need to import it.

This file defines predicates for unbundled subfields. Instead of using this file, please use
`subfield`, defined in `field_theory.subfield`, for subfields of fields.

## Main definitions

`is_subfield (S : set F) : Prop` : the predicate that `S` is the underlying set of a subfield
of the field `F`. The bundled variant `subfield F` should be used in preference to this.

## Tags

is_subfield
-/
variables {F : Type*} [field F] (S : set F)

/-- `is_subfield (S : set F)` is the predicate saying that a given subset of a field is
the set underlying a subfield. This structure is deprecated; use the bundled variant
`subfield F` to model subfields of a field. -/
structure is_subfield extends is_subring S : Prop :=
(inv_mem : ∀ {x : F}, x ∈ S → x⁻¹ ∈ S)

lemma is_subfield.div_mem {S : set F} (hS : is_subfield S) {x y : F} (hx : x ∈ S) (hy : y ∈ S) :
  x / y ∈ S :=
by { rw div_eq_mul_inv, exact hS.to_is_subring.to_is_submonoid.mul_mem hx (hS.inv_mem hy) }

lemma is_subfield.pow_mem {a : F} {n : ℤ} {s : set F} (hs : is_subfield s) (h : a ∈ s) :
  a ^ n ∈ s :=
begin
  cases n,
  { rw zpow_of_nat, exact hs.to_is_subring.to_is_submonoid.pow_mem h },
  { rw zpow_neg_succ_of_nat, exact hs.inv_mem (hs.to_is_subring.to_is_submonoid.pow_mem h) },
end

lemma univ.is_subfield : is_subfield (@set.univ F) :=
{ inv_mem := by intros; trivial,
  ..univ.is_submonoid,
  ..is_add_subgroup.univ_add_subgroup }

lemma preimage.is_subfield {K : Type*} [field K]
  (f : F →+* K) {s : set K} (hs : is_subfield s) : is_subfield (f ⁻¹' s) :=
{ inv_mem := λ a (ha : f a ∈ s), show f a⁻¹ ∈ s,
    by { rw [f.map_inv],
         exact hs.inv_mem ha },
  ..f.is_subring_preimage hs.to_is_subring }

lemma image.is_subfield {K : Type*} [field K]
  (f : F →+* K) {s : set F} (hs : is_subfield s) : is_subfield (f '' s) :=
{ inv_mem := λ a ⟨x, xmem, ha⟩, ⟨x⁻¹, hs.inv_mem xmem, ha ▸ f.map_inv _⟩,
  ..f.is_subring_image hs.to_is_subring }

lemma range.is_subfield {K : Type*} [field K]
  (f : F →+* K) : is_subfield (set.range f) :=
by { rw ← set.image_univ, apply image.is_subfield _ univ.is_subfield }

namespace field

/-- `field.closure s` is the minimal subfield that includes `s`. -/
def closure : set F :=
{ x | ∃ y ∈ ring.closure S, ∃ z ∈ ring.closure S, y / z = x }

variables {S}

theorem ring_closure_subset : ring.closure S ⊆ closure S :=
λ x hx, ⟨x, hx, 1, ring.closure.is_subring.to_is_submonoid.one_mem, div_one x⟩

lemma closure.is_submonoid : is_submonoid (closure S) :=
{ mul_mem := by rintros _  _ ⟨p, hp, q, hq, hq0, rfl⟩ ⟨r, hr, s, hs, hs0, rfl⟩;
    exact ⟨p * r,
          is_submonoid.mul_mem ring.closure.is_subring.to_is_submonoid hp hr,
          q * s,
          is_submonoid.mul_mem ring.closure.is_subring.to_is_submonoid hq hs,
          (div_mul_div_comm _ _ _ _).symm⟩,
  one_mem := ring_closure_subset $ is_submonoid.one_mem ring.closure.is_subring.to_is_submonoid }

lemma closure.is_subfield : is_subfield (closure S) :=
have h0 : (0:F) ∈ closure S, from ring_closure_subset $
  ring.closure.is_subring.to_is_add_subgroup.to_is_add_submonoid.zero_mem,
{ add_mem := begin
    intros a b ha hb,
    rcases (id ha) with ⟨p, hp, q, hq, rfl⟩,
    rcases (id hb) with ⟨r, hr, s, hs, rfl⟩,
    classical, by_cases hq0 : q = 0, by simp [hb, hq0], by_cases hs0 : s = 0, by simp [ha, hs0],
    exact ⟨p * s + q * r, is_add_submonoid.add_mem
      ring.closure.is_subring.to_is_add_subgroup.to_is_add_submonoid
      (ring.closure.is_subring.to_is_submonoid.mul_mem hp hs)
      (ring.closure.is_subring.to_is_submonoid.mul_mem hq hr), q * s,
        ring.closure.is_subring.to_is_submonoid.mul_mem hq hs,
      (div_add_div p r hq0 hs0).symm⟩
  end,
  zero_mem := h0,
  neg_mem := begin
    rintros _ ⟨p, hp, q, hq, rfl⟩,
    exact ⟨-p, ring.closure.is_subring.to_is_add_subgroup.neg_mem hp, q, hq, neg_div q p⟩
  end,
  inv_mem := begin
    rintros _ ⟨p, hp, q, hq, rfl⟩,
    exact ⟨q, hq, p, hp, (inv_div _ _).symm⟩
  end,
  ..closure.is_submonoid }

theorem mem_closure {a : F} (ha : a ∈ S) : a ∈ closure S :=
ring_closure_subset $ ring.mem_closure ha

theorem subset_closure : S ⊆ closure S :=
λ _, mem_closure

theorem closure_subset {T : set F} (hT : is_subfield T) (H : S ⊆ T) : closure S ⊆ T :=
by rintros _ ⟨p, hp, q, hq, hq0, rfl⟩; exact hT.div_mem (ring.closure_subset hT.to_is_subring H hp)
  (ring.closure_subset hT.to_is_subring H hq)

theorem closure_subset_iff {s t : set F} (ht : is_subfield t) : closure s ⊆ t ↔ s ⊆ t :=
⟨set.subset.trans subset_closure, closure_subset ht⟩

theorem closure_mono {s t : set F} (H : s ⊆ t) : closure s ⊆ closure t :=
closure_subset closure.is_subfield $ set.subset.trans H subset_closure

end field

lemma is_subfield_Union_of_directed {ι : Type*} [hι : nonempty ι]
  {s : ι → set F} (hs : ∀ i, is_subfield (s i))
  (directed : ∀ i j, ∃ k, s i ⊆ s k ∧ s j ⊆ s k) :
  is_subfield (⋃i, s i) :=
{ inv_mem := λ x hx, let ⟨i, hi⟩ := set.mem_Union.1 hx in
    set.mem_Union.2 ⟨i, (hs i).inv_mem hi⟩,
  to_is_subring := is_subring_Union_of_directed (λ i, (hs i).to_is_subring) directed }

lemma is_subfield.inter {S₁ S₂ : set F} (hS₁ : is_subfield S₁) (hS₂ : is_subfield S₂) :
  is_subfield (S₁ ∩ S₂) :=
{ inv_mem := λ x hx, ⟨hS₁.inv_mem hx.1, hS₂.inv_mem hx.2⟩,
  ..is_subring.inter hS₁.to_is_subring hS₂.to_is_subring }

lemma is_subfield.Inter {ι : Sort*} {S : ι → set F} (h : ∀ y : ι, is_subfield (S y)) :
  is_subfield (set.Inter S) :=
{ inv_mem := λ x hx, set.mem_Inter.2 $ λ y, (h y).inv_mem $ set.mem_Inter.1 hx y,
  ..is_subring.Inter (λ y, (h y).to_is_subring) }


/-
Copyright (c) 2019 Seul Baek. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Seul Baek
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.tactic.omega.clause
import Mathlib.tactic.omega.nat.form
import Mathlib.PostPort

namespace Mathlib

/-
DNF transformation.
-/

namespace omega

namespace nat

@[simp] def dnf_core : preform → List clause :=
  sorry

theorem exists_clause_holds_core {v : ℕ → ℕ} {p : preform} : preform.neg_free p →
  preform.sub_free p →
    preform.holds v p → ∃ (c : clause), ∃ (H : c ∈ dnf_core p), clause.holds (fun (x : ℕ) => ↑(v x)) c := sorry

def term.vars_core (is : List ℤ) : List Bool :=
  list.map (fun (i : ℤ) => ite (i = 0) false tt) is

/-- Return a list of bools that encodes which variables have nonzero coefficients -/
def term.vars (t : term) : List Bool :=
  term.vars_core (prod.snd t)

def bools.or : List Bool → List Bool → List Bool :=
  sorry

/-- Return a list of bools that encodes which variables have nonzero coefficients in any one of the input terms -/
def terms.vars : List term → List Bool :=
  sorry

def nonneg_consts_core : ℕ → List Bool → List term :=
  sorry

def nonneg_consts (bs : List Bool) : List term :=
  nonneg_consts_core 0 bs

def nonnegate : clause → clause :=
  sorry

/-- DNF transformation -/
def dnf (p : preform) : List clause :=
  list.map nonnegate (dnf_core p)

theorem holds_nonneg_consts_core {v : ℕ → ℤ} (h1 : ∀ (x : ℕ), 0 ≤ v x) (m : ℕ) (bs : List Bool) (t : term) (H : t ∈ nonneg_consts_core m bs) : 0 ≤ term.val v t := sorry

theorem holds_nonneg_consts {v : ℕ → ℤ} {bs : List Bool} : (∀ (x : ℕ), 0 ≤ v x) → ∀ (t : term), t ∈ nonneg_consts bs → 0 ≤ term.val v t :=
  fun (ᾰ : ∀ (x : ℕ), 0 ≤ v x) =>
    idRhs (∀ (t : term), t ∈ nonneg_consts_core 0 bs → 0 ≤ term.val (fun (x : ℕ) => v x) t)
      (holds_nonneg_consts_core ᾰ 0 bs)

theorem exists_clause_holds {v : ℕ → ℕ} {p : preform} : preform.neg_free p →
  preform.sub_free p → preform.holds v p → ∃ (c : clause), ∃ (H : c ∈ dnf p), clause.holds (fun (x : ℕ) => ↑(v x)) c := sorry

theorem exists_clause_sat {p : preform} : preform.neg_free p → preform.sub_free p → preform.sat p → ∃ (c : clause), ∃ (H : c ∈ dnf p), clause.sat c := sorry

theorem unsat_of_unsat_dnf (p : preform) : preform.neg_free p → preform.sub_free p → clauses.unsat (dnf p) → preform.unsat p :=
  fun (hnf : preform.neg_free p) (hsf : preform.sub_free p) (h1 : clauses.unsat (dnf p)) =>
    id fun (h2 : preform.sat p) => h1 (exists_clause_sat hnf hsf h2)


namespace hidden
universe u

-------------------------------------------------------------------------------
inductive list (A:Type) : Type
| Nil {} : list -- Brez {} moramo konstruktorju Nil vedno podati tip A
| Cons : A -> list -> list -- Cons tip A ugotovi iz tipa prvega elementa

namespace list
-- Dopolnite definicije in dokažitve trditve za sezname iz vaj 3. Uporabljate -- lahko notacijo x :: xs, [] in ++ (namesto @), vendar bodite pozorni na
-- oklepaje.

notation x `::` xs := Cons x xs
notation `[]` := Nil

def join {A} : list A -> list A -> list A := sorry

notation xs `++` ys := join xs ys

theorem join_nil {A} (xs: list A) :
  xs ++ [] = xs
:=
begin
  sorry
end

end list
-------------------------------------------------------------------------------

-- Podobno kot za sezname, napišite tip za drevesa in dokažite trditve iz
-- vaj 3. Če po definiciji tipa `tree` odprete `namespace tree` lahko
-- uporabljate konstruktorje brez predpone, torej `Empty` namesto
-- `tree.Empty`.

end hidden


import Mathlib.Algebra.Ring.Basic
import Etch.C
import Etch.Op
import Etch.Basic

--notation "𝟚"  => Bool

-- marked irreducible later
def Var (_ : Type _) := String
abbrev ArrayVar (α : Type _) := Var (ℕ → α)
def Var.mk : String → Var α := id
def Var.toString : Var α → String := id
instance : Coe String (Var α) := ⟨Var.mk⟩

inductive E : Type → Type 1
| call {α} (op : Op α) (args : (i : Fin op.arity) → E (op.argTypes i)) : E α
| var    : (v : Var α) → E α
| access : Var (ℕ → α) → E ℕ → E α
| intLit : ℕ → E ℕ
| strLit : String → E String

def E.v (α) (v : String) : E α := E.var v
abbrev Var.expr := @E.var
abbrev Var.access := @E.access

structure HeapContext where
  store : Var α → α
  heap {α : Type _} : Var (ℕ → α) → ℕ → α

def E.eval (c : HeapContext) : E α → α
| call f args => f.spec (λ i => (args i).eval c)
| var v => c.store v
| access arr arg => c.heap arr (arg.eval c)
| intLit x => x
| strLit x => x

instance : OfNat Bool (nat_lit 0) := ⟨ false ⟩
instance : OfNat Bool (nat_lit 1) := ⟨ .true ⟩
instance : Inhabited (E α) := ⟨.var "UNREACHABLE"⟩
instance [Tagged α] [Add α] : Add (E α) := ⟨ λ a b => E.call .add ![a, b] ⟩
instance [Tagged α] [Sub α] : Sub (E α) := ⟨ λ a b => E.call .sub ![a, b] ⟩
instance [Tagged α] [Mul α] : Mul (E α) := ⟨ λ a b => E.call .mul ![a, b] ⟩
instance [Tagged α] [HDiv α α β] : HDiv (E α) (E α) (E β) := ⟨ fun a b => E.call .div ![a, b] ⟩
instance [Tagged α] [Div α] : Div (E α) := ⟨ HDiv.hDiv ⟩
instance : Neg (E Bool) := ⟨ fun a => E.call .neg ![a] ⟩
instance [Tagged α] [OfNat α (nat_lit 0)] : OfNat (E α) (nat_lit 0) := ⟨ E.call .zero ![] ⟩
instance [Tagged α] [OfNat α (nat_lit 1)] : OfNat (E α) (nat_lit 1) := ⟨ E.call .one ![] ⟩
instance : OfNat (E ℕ) n := ⟨ .intLit n ⟩
instance : Coe ℕ (E ℕ) := ⟨ .intLit ⟩
instance : Coe String (E String) := ⟨ .strLit ⟩
--def E.ext (f : String) : E Unit := E.call (O.voidCall f) ![]

def E.compile : E α → Expr
| @call _ op args => Expr.call op.opName $ List.ofFn λ i => E.compile (args i)
| access base i => Expr.index (Expr.var base.toString) [i.compile]
| var v => Expr.var v.toString
| intLit x => Expr.lit x
| strLit x => Expr.lits x

infixr:40 " << " => λ a b => E.call Op.lt ![a, b]
infixr:40 " >> " => λ a b => E.call Op.lt ![b, a]
infixr:40 " <ᵣ " => λ a b => E.call Op.ofBool ![E.call Op.lt ![a, b]]
infixr:40 " >ᵣ " => λ a b => E.call Op.ofBool ![E.call Op.lt ![b, a]]
infixr:40 " == " => λ a b => E.call Op.eq ![a, b]
infixr:40 " != " => λ a b => E.call Op.neg ![(E.call Op.eq ![a, b])]
infixr:40 " <= " => λ a b => E.call Op.le ![a, b]
infixr:40 " >= " => λ a b => E.call Op.le ![b, a]

inductive P
| seq    : P → P → P
| while  : E Bool → P → P
| branch : E Bool → P → P → P
| skip   : P
| decl   [TaggedC α] : Var α → E α → P
| store_var : Var α → E α → P
| store_mem : Var (ℕ → α) → E ℕ → E α → P

-- needs to come after P to avoid injectivity_lemma issue
attribute [irreducible] Var

instance : Inhabited P := ⟨.skip⟩

abbrev Var.store_var := @P.store_var
abbrev Var.store_mem := @P.store_mem
abbrev Var.decl := @P.decl

def P.if1 := λ c t => P.branch c t P.skip
infixr:10 ";;" => P.seq

def P.compile : P → Stmt
| seq a b => Stmt.seq a.compile b.compile
| .while cond body => Stmt.while cond.compile body.compile
| branch c a b => Stmt.conde c.compile a.compile b.compile
| skip => Stmt.noop
| @decl _ taggedC var e => Stmt.decl taggedC.tag var.toString e.compile
| store_var var e => Stmt.store (Expr.var var.toString) e.compile
| store_mem v l r => Stmt.store (Expr.index (Expr.var v.toString) [l.compile]) r.compile

def Name := List ℕ
def Name.toString : Name → String := "_".intercalate ∘ List.map ToString.toString
def Name.fresh (n : Name) (new : ℕ) : Name := new :: n
def Name.freshen (n : Name) : Name := n.fresh 0
def emptyName : Name := []

def Var.fresh (v : Var α) (n : Name) : Var α := Var.mk (v.toString ++ n.toString)

structure S (ι : Type _) (α : Type _) where
  σ     : Type
  -- next_weak/next_strict?
  -- upto/past ?
  skip  : σ → E ι → P -- skip _ s i : if current index < i, must advance; may advance to first index ≥ i.
  succ  : σ → E ι → P -- succ _ s i : if current index ≤ i, must advance; may advance to first index > i.
  value : σ → α
  ready : σ → E Bool
  index : σ → E ι
  valid : σ → E Bool
  init  : Name → P × σ

infixr:25 " →ₛ " => S

instance {ι α} [Inhabited α] : Inhabited (ι →ₛ α) where
  default := {
    σ     := Unit
    skip  := fun _ _ => default
    succ  := fun _ _ => default
    value := fun _ => default
    ready := fun _ => 0
    index := fun _ => default
    valid := fun _ => 0
    init  := fun _ => ⟨default, default⟩
  }

section ι

variable {ι : Type} [Tagged ι] [DecidableEq ι]
{α : Type _}

def Var.incr [Tagged α] [Add α] [One α] (v : Var α) : P := v.store_var <| E.var v + 1
def Var.incr_array [Tagged α] [Add α] [One α] (v : Var (ℕ → α)) (ind : E ℕ) : P := v.store_mem ind <| v.access ind + 1

instance : Coe (Var α) (E α) := ⟨E.var⟩

instance : Functor (S ι) where map := λ f s => {s with value := f ∘ s.value }

structure SkipState (ι : Type) [TaggedC ι] where
  tmp : Var ι
  hi  : Var ℕ
  lo  : Var ℕ
  m   : Var ℕ
  notDone : Var Bool

variable [TaggedC ι]

def SkipState.initSimple : SkipState ι × P :=
  let ss : SkipState ι := {
    tmp := "" -- never used
    hi  := "" -- never used
    lo  := "" -- never used
    m   := "" -- never used
    notDone := "" -- never used
  }
  ⟨ss, .skip⟩

def SkipState.initLinear [Zero (E ι)] (n : Name) : SkipState ι × P :=
  let ss : SkipState ι := {
    tmp := .fresh "temp" n
    hi  := "" -- never used
    lo  := "" -- never used
    m   := "" -- never used
    notDone := "" -- never used
  }
  ⟨ss, .decl ss.tmp 0⟩

def SkipState.initBinary [Zero (E ι)] (n : Name) : SkipState ι × P :=
  let ss : SkipState ι := {
    tmp := .fresh "temp" n
    hi  := .fresh "hi" n
    lo  := .fresh "lo" n
    m   := .fresh "m" n
    notDone := .fresh "not_done" n
  }
  ⟨ss, .decl ss.tmp 0;; .decl ss.hi 0;; .decl ss.lo 0;; .decl ss.m 0;; .decl ss.notDone 0⟩

variable
[LT ι] [DecidableLT ι]
(is : ArrayVar ι)

def simpleSkip (pos : Var ℕ) (tgt : E ι) : P :=
  .if1 (is.access pos << tgt) pos.incr

def linearSearchSkip (ss : SkipState ι) (pos : Var ℕ) (max_pos : E ℕ) (tgt : E ι) :=
  ss.tmp.store_var tgt;;
  .while ((pos.expr << max_pos) * (is.access pos << ss.tmp.expr)) $
    pos.incr

def binarySearchSkip (ss : SkipState ι) (pos : Var ℕ) (max_pos : E ℕ) (i : E ι) : P :=
  ss.tmp.store_var i;;
  ss.lo.store_var pos;;
  ss.hi.store_var max_pos;;
  ss.notDone.store_var 1;;
  (.while ((ss.lo.expr <= ss.hi.expr) * ss.notDone) <|
    ss.m.store_var (.call .mid ![ss.lo.expr, ss.hi.expr]) ;;
    .branch (is.access ss.m << ss.tmp.expr)
      (ss.lo.store_var (ss.m + 1))
      (.branch (ss.tmp.expr << is.access ss.m)
        (ss.hi.store_var (ss.m - 1))
        (ss.notDone.store_var 0;; ss.lo.store_var ss.m)));;
  pos.store_var ss.lo

inductive IterMethod | step | linearSearch | binarySearch

def IterMethod.init [Zero (E ι)] : IterMethod → Name → SkipState ι × P
| .step => fun _ => SkipState.initSimple
| .linearSearch => SkipState.initLinear
| .binarySearch => SkipState.initBinary

def IterMethod.skip [TaggedC ι] : IterMethod → ArrayVar ι → SkipState ι → Var ℕ → E ℕ → E ι → P
| .step => fun is _ pos _ => simpleSkip is pos
| .linearSearch => linearSearchSkip
| .binarySearch => binarySearchSkip

-- [lower, upper)
def S.predRange [One α] (lower upper : E ι) : S ι α where
  σ := Var ι
  value   _ := 1
  succ  _ _ := .skip
  ready   _ := 1
  skip  pos := pos.store_var
  index pos := pos
  valid pos := pos.expr << upper
  init  n   := let p := .fresh "pos" n; (p.decl lower, p)

variable [LE ι] [DecidableLE ι]

-- [lower, upper]
def S.predRangeIncl [One α] (lower upper : E ι) : S ι α where
  σ := Var ι
  value   _ := 1
  succ  _ _ := .skip
  ready   _ := 1
  skip  pos := pos.store_var
  index pos := pos
  valid pos := pos.expr <= upper
  init  n   := let p := .fresh "pos" n; (p.decl lower, p)

def S.interval [Zero ι] (h : IterMethod) (pos : Var ℕ) (lower upper : E ℕ) : S ι (E ℕ) where
  σ := Var ℕ × SkipState ι
  value   := fun ⟨pos, _⟩ => pos.expr
  succ    := fun ⟨pos, _⟩ i => .if1 (is.access pos.expr <= i) pos.incr
  skip    := fun ⟨pos, ss⟩ => h.skip is ss pos upper
  ready   := Function.const _ 1
  index   := fun ⟨pos, _⟩ => is.access pos.expr
  valid   := fun ⟨pos, _⟩ => pos.expr << upper
  init  n := let p := pos.fresh n
             let ⟨ss, ssInit⟩ := h.init n
             (p.decl lower ;; ssInit, (p, ss))

-- todo: use instead of zero
--class Bot (α : Type _) := (bot : α)
--notation "⊥"  => Bot.bot
def S.univ [Add ι] [Zero ι] [One ι] [TaggedC ι] (max l : Var ι) : S ι (E ι) where
  value last := last.expr
  succ  last i := .if1 (last.expr <= i) last.incr  -- imprecise but ok
  ready _    := 1
  skip  last := last.store_var
  index last := last.expr
  valid last := last.expr << max.expr
  init  n    := let v := l.fresh n; (v.decl 0, v)

def S.valFilter (f : α → E Bool) (s : ι →ₛ α) : ι →ₛ α :=
{ s with ready := λ p => s.ready p * f (s.value p),
         skip := λ p i =>
           .branch (s.ready p * -(f (s.value p)))
             (s.succ p i;; s.skip p i)
             (s.skip p i) }

def dim : Var ι := "dim"

-- using fmap introduces a universe constraint between α and Type 1 (coming from E ι). this is probably ok anyway
--def S.repl' {α : Type 1} [Zero ι] (last : Var ι) (v : α) : S ι α := (Function.const _ v) <$> (S.univ last)
--def S.repl [Zero ι] (last : Var ι) (v : α) : S ι α := {S.univ last with value := λ _ => v}
def S.function [Zero ι] [Add ι] [One ι] (last : Var ι) (f : E ι → α) : S ι α := f <$> S.univ dim last

structure csr (ι α : Type _) := (i : Var (ℕ → ι)) (v : Var (ℕ → α)) (var : Var ℕ)

def csr.of (name : String) (n : ℕ) (ι := ℕ) : csr ι ℕ :=
  let field {ι} (x : String) : Var ι := Var.mk $ name ++ n.repr ++ x
  { i := field "_crd", v := field "_pos", var := field "_i" }

def csr.level [Zero ι] (h : IterMethod) (vars : csr ι ℕ) (loc : E ℕ) : ι →ₛ (E ℕ) :=
  S.interval vars.i h vars.var (.access vars.v loc) (vars.v.access (loc+1))
-- CSR, but assume pos[i] = i (inherit the position from the previous level)
def csr.inherit [Zero ι] (vars : csr ι ℕ) (loc : E ℕ) : ι →ₛ (E ℕ) :=
  S.interval vars.i .step vars.var loc (loc+1)
def S.level {f} [Functor f] [Zero ι] (h : IterMethod) : csr ι ℕ → f (E ℕ) → f (ι →ₛ (E ℕ)) := Functor.map ∘ csr.level h
def S.leaf  {f} [Functor f] : Var (ℕ → α) → f (E ℕ) → f (E α) := Functor.map ∘ E.access
--def S.leaf' : Var α → E ℕ → E α := E.access
def Contraction (α : Type _) := (ι : Type) × TaggedC ι × S ι α
--structure Contraction (α : Type _) where
--  f : Type _ → Type _
--  h : Functor f
--  v  : f α
--def Contraction {f : Type → Type _ → Type _} (α : Type _) := (ι : Type) × f ι α
--instance : Functor Contraction where map := λ f ⟨F, h, v⟩ => ⟨F, h, f <$> v⟩
instance : Functor Contraction where map := λ f ⟨ι, tᵢ, v⟩ => ⟨ι, tᵢ, f <$> v⟩
def S.contract [inst : TaggedC ι] (s : S ι α) : Contraction α := ⟨_, inst, s⟩

instance [Inhabited α] : Inhabited (Contraction α) := ⟨⟨ℕ, inferInstance, default⟩⟩

end ι

def Fun (ι α : Type _) := E ι → α
infixr:25 " →ₐ "  => Fun -- arbitrarily chosen for ease of typing: \ra
example : (ℕ →ₐ ℕ →ₛ ℕ) = (ℕ →ₐ (ℕ →ₛ ℕ)) := rfl
def Fun.un (h : ι →ₐ α) : E ι → α := h
def Fun.of (h : E ι → α) : ι →ₐ α := h
instance : Functor (Fun ι) where map := λ f v => f ∘ v

def range : ℕ →ₐ E ℕ := id

def seqInit (a : S ι α) (b : S ι β) (n : Name) :=
let (ai, as) := a.init (n.fresh 0);
let (bi, bs) := b.init (n.fresh 1);
(ai ;; bi, (as, bs))


/-
Copyright (c) 2020 Markus Himmel. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Markus Himmel
-/
import category_theory.abelian.exact
import category_theory.types

/-!
# Projective objects and categories with enough projectives

An object `P` is called projective if every morphism out of `P` factors through every epimorphism.

A category `C` has enough projectives if every object admits an epimorphism from some
projective object.

`projective.over X` picks an arbitrary such projective object,
and `projective.π X : projective.over X ⟶ X` is the corresponding epimorphism.

Given a morphism `f : X ⟶ Y`, `projective.left f` is a projective object over `kernel f`,
and `projective.d f : projective.left f ⟶ X` is the morphism `π (kernel f) ≫ kernel.ι f`.
When `C` is abelian `projective.d f` and `f` are exact.
Hence, starting from an epimorphism `P ⟶ X`, where `P` is projective,
we can apply `projective.d` repeatedly to obtain a projective resolution of `X`.
-/

noncomputable theory

open category_theory
open category_theory.limits

universes v u

namespace category_theory
variables {C : Type u} [category.{v} C]

/--
An object `P` is called projective if every morphism out of `P` factors through every epimorphism.
-/
class projective (P : C) : Prop :=
(factors : ∀ {E X : C} (f : P ⟶ X) (e : E ⟶ X) [epi e], ∃ f', f' ≫ e = f)

section

/--
A projective presentation of an object `X` consists of an epimorphism `f : P ⟶ X`
from some projective object `P`.
-/
@[nolint has_inhabited_instance]
structure projective_presentation (X : C) :=
(P : C)
(projective : projective P . tactic.apply_instance)
(f : P ⟶ X)
(epi : epi f . tactic.apply_instance)

variables (C)

/-- A category "has enough projectives" if for every object `X` there is a projective object `P` and
    an epimorphism `P ↠ X`. -/
class enough_projectives : Prop :=
(presentation : ∀ (X : C), nonempty (projective_presentation X))

end

namespace projective

/--
An arbitrarily chosen factorisation of a morphism out of a projective object through an epimorphism.
-/
def factor_thru {P X E : C} [projective P] (f : P ⟶ X) (e : E ⟶ X) [epi e] : P ⟶ E :=
(projective.factors f e).some

@[simp] lemma factor_thru_comp {P X E : C} [projective P] (f : P ⟶ X) (e : E ⟶ X) [epi e] :
  factor_thru f e ≫ e = f :=
(projective.factors f e).some_spec

lemma of_iso {P Q : C} (i : P ≅ Q) (hP : projective P) : projective Q :=
begin
  fsplit,
  introsI E X f e e_epi,
  obtain ⟨f', hf'⟩ := projective.factors (i.hom ≫ f) e,
  exact ⟨i.inv ≫ f', by simp [hf']⟩
end

lemma iso_iff {P Q : C} (i : P ≅ Q) : projective P ↔ projective Q :=
⟨of_iso i, of_iso i.symm⟩

/-- The axiom of choice says that every type is a projective object in `Type`. -/
instance (X : Type u) : projective X :=
{ factors := λ E X' f e epi,
  ⟨λ x, ((epi_iff_surjective _).mp epi (f x)).some,
  by { ext x, exact ((epi_iff_surjective _).mp epi (f x)).some_spec, }⟩ }

instance Type_enough_projectives : enough_projectives (Type u) :=
{ presentation := λ X, ⟨{ P := X, f := 𝟙 X, }⟩, }

instance {P Q : C} [has_binary_coproduct P Q] [projective P] [projective Q] :
  projective (P ⨿ Q) :=
{ factors := λ E X' f e epi, by exactI
  ⟨coprod.desc (factor_thru (coprod.inl ≫ f) e) (factor_thru (coprod.inr ≫ f) e), by tidy⟩, }

instance {β : Type v} (g : β → C) [has_coproduct g] [∀ b, projective (g b)] :
  projective (∐ g) :=
{ factors := λ E X' f e epi, by exactI
  ⟨sigma.desc (λ b, factor_thru (sigma.ι g b ≫ f) e), by tidy⟩, }

instance {P Q : C} [has_zero_morphisms C] [has_binary_biproduct P Q]
  [projective P] [projective Q] :
  projective (P ⊞ Q) :=
{ factors := λ E X' f e epi, by exactI
  ⟨biprod.desc (factor_thru (biprod.inl ≫ f) e) (factor_thru (biprod.inr ≫ f) e), by tidy⟩, }

instance {β : Type v} [decidable_eq β] (g : β → C) [has_zero_morphisms C] [has_biproduct g]
  [∀ b, projective (g b)] : projective (⨁ g) :=
{ factors := λ E X' f e epi, by exactI
  ⟨biproduct.desc (λ b, factor_thru (biproduct.ι g b ≫ f) e), by tidy⟩, }

section enough_projectives
variables [enough_projectives C]

/--
`projective.over X` provides an arbitrarily chosen projective object equipped with
an epimorphism `projective.π : projective.over X ⟶ X`.
-/
def over (X : C) : C :=
(enough_projectives.presentation X).some.P

instance projective_over (X : C) : projective (over X) :=
(enough_projectives.presentation X).some.projective

/--
The epimorphism `projective.π : projective.over X ⟶ X`
from the arbitrarily chosen projective object over `X`.
-/
def π (X : C) : over X ⟶ X :=
(enough_projectives.presentation X).some.f

instance (X : C) : epi (π X) :=
(enough_projectives.presentation X).some.epi

section
variables [has_zero_morphisms C] {X Y : C} (f : X ⟶ Y) [has_kernel f]

/-- When `C` has enough projectives, the object `projective.left f` is
the arbitrarily chosen projective object over `kernel f`. -/
@[derive projective]
def left : C := over (kernel f)

/-- When `C` has enough projectives,
`projective.d f : projective.left f ⟶ X` is the composition
`π (kernel f) ≫ kernel.ι f`.
-/
abbreviation d : left f ⟶ X :=
π (kernel f) ≫ kernel.ι f

end

variables [abelian C]

/--
When `C` is abelian, `projective.d f` and `f` are exact.
-/
lemma exact_d_f {X Y : C} (f : X ⟶ Y) : exact (d f) f :=
(abelian.exact_iff _ _).2 $
  ⟨by simp, zero_of_epi_comp (π _) $ by rw [←category.assoc, cokernel.condition]⟩

end enough_projectives

end projective

end category_theory


/-
Copyright (c) 2017 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Stephen Morgan, Scott Morrison, Johannes Hölzl
-/
import category_theory.epi_mono
import category_theory.functor.fully_faithful
import logic.equiv.basic

/-!
# The category `Type`.

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

In this section we set up the theory so that Lean's types and functions between them
can be viewed as a `large_category` in our framework.

Lean can not transparently view a function as a morphism in this category, and needs a hint in
order to be able to type check. We provide the abbreviation `as_hom f` to guide type checking,
as well as a corresponding notation `↾ f`. (Entered as `\upr `.) The notation is enabled using
`open_locale category_theory.Type`.

We provide various simplification lemmas for functors and natural transformations valued in `Type`.

We define `ulift_functor`, from `Type u` to `Type (max u v)`, and show that it is fully faithful
(but not, of course, essentially surjective).

We prove some basic facts about the category `Type`:
*  epimorphisms are surjections and monomorphisms are injections,
* `iso` is both `iso` and `equiv` to `equiv` (at least within a fixed universe),
* every type level `is_lawful_functor` gives a categorical functor `Type ⥤ Type`
  (the corresponding fact about monads is in `src/category_theory/monad/types.lean`).
-/

namespace category_theory

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

/- The `@[to_additive]` attribute is just a hint that expressions involving this instance can
  still be additivized. -/
@[to_additive category_theory.types]
instance types : large_category (Type u) :=
{ hom     := λ a b, (a → b),
  id      := λ a, id,
  comp    := λ _ _ _ f g, g ∘ f }

lemma types_hom {α β : Type u} : (α ⟶ β) = (α → β) := rfl
lemma types_id (X : Type u) : 𝟙 X = id := rfl
lemma types_comp {X Y Z : Type u} (f : X ⟶ Y) (g : Y ⟶ Z) : f ≫ g = g ∘ f := rfl

@[simp]
lemma types_id_apply (X : Type u) (x : X) : ((𝟙 X) : X → X) x = x := rfl
@[simp]
lemma types_comp_apply {X Y Z : Type u} (f : X ⟶ Y) (g : Y ⟶ Z) (x : X) : (f ≫ g) x = g (f x) := rfl

@[simp]
lemma hom_inv_id_apply {X Y : Type u} (f : X ≅ Y) (x : X) : f.inv (f.hom x) = x :=
congr_fun f.hom_inv_id x
@[simp]
lemma inv_hom_id_apply {X Y : Type u} (f : X ≅ Y) (y : Y) : f.hom (f.inv y) = y :=
congr_fun f.inv_hom_id y

/-- `as_hom f` helps Lean type check a function as a morphism in the category `Type`. -/
-- Unfortunately without this wrapper we can't use `category_theory` idioms, such as `is_iso f`.
abbreviation as_hom {α β : Type u} (f : α → β) : α ⟶ β := f
-- If you don't mind some notation you can use fewer keystrokes:
localized "notation (name := category_theory.as_hom) `↾` f : 200 := category_theory.as_hom f"
  in category_theory.Type -- type as \upr in VScode

section -- We verify the expected type checking behaviour of `as_hom`.
variables (α β γ : Type u) (f : α → β) (g : β → γ)

example : α → γ := ↾f ≫ ↾g
example [is_iso ↾f] : mono ↾f := by apply_instance
example [is_iso ↾f] : ↾f ≫ inv ↾f = 𝟙 α := by simp
end

namespace functor
variables {J : Type u} [category.{v} J]

/--
The sections of a functor `J ⥤ Type` are
the choices of a point `u j : F.obj j` for each `j`,
such that `F.map f (u j) = u j` for every morphism `f : j ⟶ j'`.

We later use these to define limits in `Type` and in many concrete categories.
-/
def sections (F : J ⥤ Type w) : set (Π j, F.obj j) :=
{ u | ∀ {j j'} (f : j ⟶ j'), F.map f (u j) = u j'}
end functor

namespace functor_to_types
variables {C : Type u} [category.{v} C] (F G H : C ⥤ Type w) {X Y Z : C}
variables (σ : F ⟶ G) (τ : G ⟶ H)

@[simp] lemma map_comp_apply (f : X ⟶ Y) (g : Y ⟶ Z) (a : F.obj X) :
  (F.map (f ≫ g)) a = (F.map g) ((F.map f) a) :=
by simp [types_comp]

@[simp] lemma map_id_apply (a : F.obj X) : (F.map (𝟙 X)) a = a :=
by simp [types_id]

lemma naturality (f : X ⟶ Y) (x : F.obj X) : σ.app Y ((F.map f) x) = (G.map f) (σ.app X x) :=
congr_fun (σ.naturality f) x

@[simp] lemma comp (x : F.obj X) : (σ ≫ τ).app X x = τ.app X (σ.app X x) := rfl

variables {D : Type u'} [𝒟 : category.{u'} D] (I J : D ⥤ C) (ρ : I ⟶ J) {W : D}

@[simp] lemma hcomp (x : (I ⋙ F).obj W) :
  (ρ ◫ σ).app W x = (G.map (ρ.app W)) (σ.app (I.obj W) x) :=
rfl

@[simp]

@[simp] lemma hom_inv_id_app_apply (α : F ≅ G) (X) (x) : α.inv.app X (α.hom.app X x) = x :=
congr_fun (α.hom_inv_id_app X) x
@[simp] lemma inv_hom_id_app_apply (α : F ≅ G) (X) (x) : α.hom.app X (α.inv.app X x) = x :=
congr_fun (α.inv_hom_id_app X) x

end functor_to_types

/--
The isomorphism between a `Type` which has been `ulift`ed to the same universe,
and the original type.
-/
def ulift_trivial (V : Type u) : ulift.{u} V ≅ V := by tidy

/--
The functor embedding `Type u` into `Type (max u v)`.
Write this as `ulift_functor.{5 2}` to get `Type 2 ⥤ Type 5`.
-/
def ulift_functor : Type u ⥤ Type (max u v) :=
{ obj := λ X, ulift.{v} X,
  map := λ X Y f, λ x : ulift.{v} X, ulift.up (f x.down) }

@[simp] lemma ulift_functor_map {X Y : Type u} (f : X ⟶ Y) (x : ulift.{v} X) :
  ulift_functor.map f x = ulift.up (f x.down) := rfl

instance ulift_functor_full : full.{u} ulift_functor :=
{ preimage := λ X Y f x, (f (ulift.up x)).down }
instance ulift_functor_faithful : faithful ulift_functor :=
{ map_injective' := λ X Y f g p, funext $ λ x,
    congr_arg ulift.down ((congr_fun p (ulift.up x)) : ((ulift.up (f x)) = (ulift.up (g x)))) }

/--
The functor embedding `Type u` into `Type u` via `ulift` is isomorphic to the identity functor.
 -/
def ulift_functor_trivial : ulift_functor.{u u} ≅ 𝟭 _ :=
nat_iso.of_components ulift_trivial (by tidy)

/-- Any term `x` of a type `X` corresponds to a morphism `punit ⟶ X`. -/
-- TODO We should connect this to a general story about concrete categories
-- whose forgetful functor is representable.
def hom_of_element {X : Type u} (x : X) : punit ⟶ X := λ _, x

lemma hom_of_element_eq_iff {X : Type u} (x y : X) :
  hom_of_element x = hom_of_element y ↔ x = y :=
⟨λ H, congr_fun H punit.star, by cc⟩

/--
A morphism in `Type` is a monomorphism if and only if it is injective.

See <https://stacks.math.columbia.edu/tag/003C>.
-/
lemma mono_iff_injective {X Y : Type u} (f : X ⟶ Y) : mono f ↔ function.injective f :=
begin
  split,
  { intros H x x' h,
    resetI,
    rw ←hom_of_element_eq_iff at ⊢ h,
    exact (cancel_mono f).mp h },
  { exact λ H, ⟨λ Z, H.comp_left⟩ }
end

lemma injective_of_mono {X Y : Type u} (f : X ⟶ Y) [hf : mono f] : function.injective f :=
(mono_iff_injective f).1 hf

/--
A morphism in `Type` is an epimorphism if and only if it is surjective.

See <https://stacks.math.columbia.edu/tag/003C>.
-/
lemma epi_iff_surjective {X Y : Type u} (f : X ⟶ Y) : epi f ↔ function.surjective f :=
begin
  split,
  { rintros ⟨H⟩,
    refine function.surjective_of_right_cancellable_Prop (λ g₁ g₂ hg, _),
    rw [← equiv.ulift.symm.injective.comp_left.eq_iff],
    apply H,
    change ulift.up ∘ (g₁ ∘ f) = ulift.up ∘ (g₂ ∘ f),
    rw hg },
  { exact λ H, ⟨λ Z, H.injective_comp_right⟩ }
end

lemma surjective_of_epi {X Y : Type u} (f : X ⟶ Y) [hf : epi f] : function.surjective f :=
(epi_iff_surjective f).1 hf

section

/-- `of_type_functor m` converts from Lean's `Type`-based `category` to `category_theory`. This
allows us to use these functors in category theory. -/
def of_type_functor (m : Type u → Type v) [_root_.functor m] [is_lawful_functor m] :
  Type u ⥤ Type v :=
{ obj       := m,
  map       := λα β, _root_.functor.map,
  map_id'   := assume α, _root_.functor.map_id,
  map_comp' := assume α β γ f g, funext $ assume a, is_lawful_functor.comp_map f g _ }

variables (m : Type u → Type v) [_root_.functor m] [is_lawful_functor m]

@[simp]
lemma of_type_functor_obj : (of_type_functor m).obj = m := rfl

@[simp]
lemma of_type_functor_map {α β} (f : α → β) :
  (of_type_functor m).map f = (_root_.functor.map f : m α → m β) := rfl

end

end category_theory

-- Isomorphisms in Type and equivalences.

namespace equiv

universe u

variables {X Y : Type u}

/--
Any equivalence between types in the same universe gives
a categorical isomorphism between those types.
-/
def to_iso (e : X ≃ Y) : X ≅ Y :=
{ hom := e.to_fun,
  inv := e.inv_fun,
  hom_inv_id' := funext e.left_inv,
  inv_hom_id' := funext e.right_inv }

@[simp] lemma to_iso_hom {e : X ≃ Y} : e.to_iso.hom = e := rfl
@[simp] lemma to_iso_inv {e : X ≃ Y} : e.to_iso.inv = e.symm := rfl

end equiv

universe u

namespace category_theory.iso
open category_theory

variables {X Y : Type u}

/--
Any isomorphism between types gives an equivalence.
-/
def to_equiv (i : X ≅ Y) : X ≃ Y :=
{ to_fun := i.hom,
  inv_fun := i.inv,
  left_inv := λ x, congr_fun i.hom_inv_id x,
  right_inv := λ y, congr_fun i.inv_hom_id y }

@[simp] lemma to_equiv_fun (i : X ≅ Y) : (i.to_equiv : X → Y) = i.hom := rfl
@[simp] lemma to_equiv_symm_fun (i : X ≅ Y) : (i.to_equiv.symm : Y → X) = i.inv := rfl

@[simp] lemma to_equiv_id (X : Type u) : (iso.refl X).to_equiv = equiv.refl X := rfl
@[simp] lemma to_equiv_comp {X Y Z : Type u} (f : X ≅ Y) (g : Y ≅ Z) :
  (f ≪≫ g).to_equiv = f.to_equiv.trans (g.to_equiv) := rfl

end category_theory.iso

namespace category_theory

/-- A morphism in `Type u` is an isomorphism if and only if it is bijective. -/
lemma is_iso_iff_bijective {X Y : Type u} (f : X ⟶ Y) : is_iso f ↔ function.bijective f :=
iff.intro
  (λ i, (by exactI as_iso f : X ≅ Y).to_equiv.bijective)
  (λ b, is_iso.of_iso (equiv.of_bijective f b).to_iso)

instance : split_epi_category (Type u) :=
{ is_split_epi_of_epi := λ X Y f hf, is_split_epi.mk'
  { section_ := function.surj_inv $ (epi_iff_surjective f).1 hf,
    id' := funext $ function.right_inverse_surj_inv $ (epi_iff_surjective f).1 hf } }

end category_theory

-- We prove `equiv_iso_iso` and then use that to sneakily construct `equiv_equiv_iso`.
-- (In this order the proofs are handled by `obviously`.)

/-- Equivalences (between types in the same universe) are the same as (isomorphic to) isomorphisms
of types. -/
@[simps] def equiv_iso_iso {X Y : Type u} : (X ≃ Y) ≅ (X ≅ Y) :=
{ hom := λ e, e.to_iso,
  inv := λ i, i.to_equiv, }

/-- Equivalences (between types in the same universe) are the same as (equivalent to) isomorphisms
of types. -/
def equiv_equiv_iso {X Y : Type u} : (X ≃ Y) ≃ (X ≅ Y) :=
(equiv_iso_iso).to_equiv

@[simp] lemma equiv_equiv_iso_hom {X Y : Type u} (e : X ≃ Y) :
  equiv_equiv_iso e = e.to_iso := rfl

@[simp] lemma equiv_equiv_iso_inv {X Y : Type u} (e : X ≅ Y) :
  equiv_equiv_iso.symm e = e.to_equiv := rfl


example (A B C D E F G H I J K L : Type)
(f1 : A → B) (f2 : B → E) (f3 : E → D) (f4 : D → A) (f5 : E → F)
(f6 : F → C) (f7 : B → C) (f8 : F → G) (f9 : G → J) (f10 : I → J)
(f11 : J → I) (f12 : I → H) (f13 : E → H) (f14 : H → K) (f15 : I → L)
 : A → L :=
begin
    intro a,
    apply f15,
    apply f11,
    apply f9,
    apply f8,
    apply f5,
    apply f2,
    apply f1,
    exact a,
end


import Lean.Elab
import Mathlib.Tactic.LeftRight
import Mathlib.Tactic.Cases
import Mathlib.Tactic.ApplyFun
import Mathlib.Tactic.Existsi
import Mathlib.Tactic.NormNum
import Mathlib.Tactic.Positivity
import Mathlib.Tactic.Linarith
import Mathlib.Tactic.Polyrith

open Lean hiding Rat mkRat
open Meta Elab Tactic Lean.Parser.Tactic

elab (name := split_goal) "split_goal " : tactic => withMainContext do
  let tgt := (← instantiateMVars (← whnfR (← getMainTarget)))
  match tgt.and?, tgt.iff? with
  | .none, .none => throwError "split_goal only applies to ∧ and ↔ goals"
  | _, _ => evalConstructor default

open private getElimNameInfo in evalCases in
elab (name := eliminate) "eliminate " tgts:(casesTarget,+) usingArg:((" using " ident)?)
  withArg:((" with " (colGt binderIdent)+)?) : tactic => focus do
  let targets ← elabCasesTargets tgts.1.getSepArgs
  let g ← getMainGoal
  g.withContext do
    let elimInfo ← getElimNameInfo usingArg targets (induction := false)
    let targets ← addImplicitTargets elimInfo targets
    let result ← withRef tgts <| ElimApp.mkElimApp elimInfo targets (← g.getTag)
    let elimArgs := result.elimApp.getAppArgs
    let targets ← elimInfo.targetsPos.mapM (instantiateMVars elimArgs[·]!)
    let motive := elimArgs[elimInfo.motivePos]!
    let g ← generalizeTargetsEq g (← inferType motive) targets
    let (targetsNew, g) ← g.introN targets.size
    g.withContext do
      ElimApp.setMotiveArg g motive.mvarId! targetsNew
      g.assign result.elimApp
      let subgoals ← ElimApp.evalNames elimInfo result.alts withArg
         (numEqs := targets.size) (toClear := targetsNew)
      setGoals subgoals.toList

macro "reflexivity" : tactic => `(tactic |rfl)

section

open Lean.Meta Qq Lean.Elab Term
open Lean.Parser.Tactic Mathlib.Meta.NormNum

/--
Normalize numerical expressions. Supports the operations `+` `-` `*` `/` `⁻¹` and `^`
over numerical types such as `ℕ`, `ℤ`, `ℚ`, `ℝ`, `ℂ` and some general algebraic types,
and can prove goals of the form `A = B`, `A ≠ B`, `A < B` and `A ≤ B`, where `A` and `B` are
numerical expressions.
-/
elab (name := numbers) "numbers" loc:(location ?) : tactic =>
  elabNormNum mkNullNode loc (simpOnly := true) (useSimp := false)
end

macro "set_simplify" : tactic => `(tactic | simp only [Set.mem_union, Set.mem_compl_iff, Set.mem_inter_iff, Set.mem_diff] at *)

macro "linarith" : tactic => `(tactic| first | ring1 | linarith)

@[elab_as_elim]
lemma Nat.induction {P : ℕ → Prop} : P 0 → (∀ n, P n → P (n+1)) → (∀ n, P n) :=
  Nat.rec

macro "basic_induction" : tactic =>
  `(tactic| apply Nat.induction)

macro "strong_induction" : tactic =>
  `(tactic| (intro n; refine Nat.strong_induction_on n ?_; clear n))

macro "induction_from_starting_point" : tactic =>
  `(tactic| apply Nat.le_induction)

macro "strong_induction" : tactic =>
  `(tactic| (intro n; refine Nat.strong_induction_on n ?_; clear n))


import verification.misc
import verification.semantics.stream

open_locale classical
noncomputable theory

variables {ι ι' ι'' : Type} {α β γ : Type*}

def Stream.reduced (q : Stream ι α) : Prop :=
∀ ⦃r⦄ (h : q.valid r) (h' : q.ready r), q.index' r ≠ q.index' (q.next r h)

variables [linear_order ι] [linear_order ι'] [linear_order ι'']

-- index ready
@[reducible]
def stream_order (ι : Type) : Type := with_top ι ×ₗ bool

@[simps]
def Stream.to_order (s : Stream ι α) (x : s.σ) : stream_order ι :=
⟨s.index' x, s.ready x⟩

@[simp] lemma Stream.bimap_to_order (s : Stream ι α) (g : α → β) :
  (g <$₂> s).to_order = s.to_order := rfl

lemma valid_of_le_valid {s₁ : Stream ι α} {s₂ : Stream ι β} {x : s₁.σ} {y : s₂.σ}
  (h : s₁.to_order x ≤ s₂.to_order y) (h' : s₂.valid y) : s₁.valid x :=
by { simp [Stream.to_order, h'] at h, rw ← Stream.index'_lt_top_iff, refine lt_of_le_of_lt (prod.lex.fst_le_of_le h) _, simpa, }

lemma valid_of_le_or {a : Stream ι α} {b : Stream ι α} {x : a.σ} {y : b.σ}
  (h : a.valid x ∨ b.valid y) (h' : a.to_order x ≤ b.to_order y) : a.valid x :=
(or_iff_left_of_imp (valid_of_le_valid h')).mp h

def Stream.monotonic (q : Stream ι α) : Prop :=
∀ ⦃r⦄ (h : q.valid r), q.index' r ≤ q.index' (q.next r h)

structure Stream.simple (q : Stream ι α) : Prop :=
(monotonic : q.monotonic)
(reduced : q.reduced)

lemma Stream.monotonic.le_index_iterate {s : Stream ι α} (hs : s.monotonic) (q : s.σ) (n : ℕ) :
  s.index' q ≤ s.index' (s.next'^[n] q) :=
begin
  induction n with n ih generalizing q, { simp, },
  by_cases h : s.valid q, swap,
  { simp [Stream.next'_val_invalid' h], },
  refine (hs h).trans _,
  simpa [Stream.next'_val h] using ih _,
end

lemma Stream.monotonic.index_le_support [add_zero_class α] {q : Stream ι α} (hq : q.monotonic) {x : q.σ} {n : ℕ} :
  ∀ i ∈ (q.eval_steps n x).support, q.index' x ≤ ↑i :=
begin
  induction n with n ih generalizing x,
  { simp, },
  simp only [Stream.eval_steps, ne.def],
  split_ifs, swap, { simp, },
  intros i H,
  rcases (finset.mem_union.mp (finsupp.support_add H)) with H'|H',
  { exact trans (hq _) (ih _ H'), },
  rw finset.mem_singleton.mp (q.eval₀_support _ h H'),
  exact (le_of_eq (Stream.index'_val _)),
end

lemma Stream.simple.index_lt_next {q : Stream ι α} (hq : q.simple) {x : q.σ}
  (hv : q.valid x) (hr : q.ready x) : q.index' x < q.index' (q.next _ hv) :=
by { rw lt_iff_le_and_ne, exact ⟨hq.monotonic hv, hq.reduced hv hr⟩, }

lemma Stream.simple.index_lt_support [add_zero_class α] {q : Stream ι α} (hq : q.simple) {x : q.σ} {n : ℕ}
  (hv : q.valid x) (hr : q.ready x) :
  ∀ i ∈ (q.eval_steps n (q.next x hv)).support, q.index' x < ↑i :=
λ i H, lt_of_lt_of_le (hq.index_lt_next hv hr) (hq.monotonic.index_le_support i H)

@[ext]
structure SimpleStream (ι : Type) [linear_order ι] (α : Type*) extends StreamExec ι α :=
(simple : stream.simple)

instance (ι : Type) [linear_order ι] (α : Type*) : has_coe
  (SimpleStream ι α) (StreamExec ι α) := ⟨SimpleStream.to_StreamExec⟩

def SimpleStream.contract {ι α} [linear_order ι] (s : SimpleStream ι α) :
  StreamExec unit α := contract_stream (s : StreamExec ι α)

lemma SimpleStream.monotonic (s : SimpleStream ι α) : s.stream.monotonic :=
s.simple.monotonic

lemma SimpleStream.reduced (s : SimpleStream ι α) : s.stream.reduced :=
s.simple.reduced

@[simps]
def SimpleStream.bimap (s : SimpleStream ι α) (f : ι ↪o ι') (g : α → β) : SimpleStream ι' β :=
{ s.to_StreamExec.bimap f g with
  simple := {
    reduced := begin
      simp only [StreamExec.bimap],
      intros r hv hr,
      simp_rw Stream.bimap_index'_eq_apply,
      by_contra h,
      exact absurd (option.map_injective f.injective h) (s.reduced hv hr),
    end,
    monotonic := begin
      simp only [StreamExec.bimap],
      intros r hv,
      simp_rw Stream.bimap_index'_eq_apply,
      exact with_top.monotone_map_iff.2 f.monotone (s.monotonic hv)
    end,
  }}

abbreviation irefl {α : Type*} [has_le α] : α ↪o α := rel_embedding.refl _

notation f ` <§₁> `:1 s := s.bimap f id
notation g ` <§₂> `:1 s := s.bimap irefl g

@[simp] lemma SimpleStream.id_bimap (s : SimpleStream ι α) : s.bimap irefl id = s :=
by ext; solve_refl

@[simp] lemma SimpleStream.bimap_bimap (s : SimpleStream ι α)
  (f : ι ↪o ι') (f' : ι' ↪o ι'') (g : α → β) (h : β → γ) :
  (s.bimap f g).bimap f' h = s.bimap (f.trans f') (h ∘ g) :=
by ext; solve_refl

@[simp] lemma SimpleStream.imap (s : SimpleStream ι α) (f : ι ↪o ι') :
  (f <§₁> s).stream = (f <$₁> s.stream) := rfl

@[simp] lemma SimpleStream.imap_stream_eval [add_zero_class α] (s : SimpleStream ι α) (f : ι ↪o ι') (n : ℕ) :
  (f <§₁> s).stream.eval_steps n s.state = (f <$₁> s.stream).eval_steps n s.state := rfl

@[simp] lemma SimpleStream.bifunctor_bimap_valid (s : SimpleStream ι α) (f : ι ↪o ι') (g : α → β) :
  (s.bimap f g).valid ↔ s.valid := iff.rfl

@[simp] lemma SimpleStream.bifunctor_bimap_ready (s : SimpleStream ι α) (f : ι ↪o ι') (g : α → β) :
  (s.bimap f g).ready ↔ s.ready := iff.rfl

@[simp] lemma SimpleStream.bimap_eval [add_comm_monoid α] (s : SimpleStream ι α) (f : ι ↪o ι') :
  (f <§₁> s).eval = (f <$₁> s.to_StreamExec).eval := rfl

namespace primitives

lemma range.reduced {n : ℕ} : (range n).reduced :=
begin
  intros r hv hr,
  unfold Stream.index',
  split_ifs; norm_cast; simp [hv],
end

lemma range.monotonic {n : ℕ} : (range n).monotonic :=
begin
  intros r hv,
  unfold Stream.index',
  split_ifs; try { norm_cast }; simp,
end

@[simps]
def range_simple (n : ℕ) : SimpleStream ℕ ℕ :=
{ range_exec n with simple := ⟨range.monotonic, range.reduced⟩ }

end primitives