import parlang.defs
import parlang.lemmas_state
import parlang.lemmas_exec
import parlang.nonmono

namespace parlang

variables {σ σ₁ σ₂ σ₃ : Type} {ι₁ ι₂ : Type} {τ₁ : ι₁ → Type} {τ₂ : ι₂ → Type} [decidable_eq ι₁] [decidable_eq ι₂]

@[reducible]
def rhl_kernel_assertion := Π n₁:ℕ, state n₁ σ₁ τ₁ → vector bool n₁ → Π n₂:ℕ, state n₂ σ₂ τ₂ → vector bool n₂ → Prop

/-- Relational Hoare logic on kernels.  -/
def rel_hoare_state (P : rhl_kernel_assertion) (k₁ : kernel σ₁ τ₁) (k₂ : kernel σ₂ τ₂)
    (Q : rhl_kernel_assertion) : Prop :=
    ∀ (n₁ n₂ : ℕ) (s₁ s₁' : state n₁ σ₁ τ₁) (s₂ : state n₂ σ₂ τ₂) ac₁ ac₂, P n₁ s₁ ac₁ n₂ s₂ ac₂ → exec_state k₁ ac₁ s₁ s₁' →
    ∃ s₂', exec_state k₂ ac₂ s₂ s₂' ∧ Q n₁ s₁' ac₁ n₂ s₂' ac₂

notation `{* ` P : 1 ` *} ` k₁ : 1 ` ~> ` k₂ : 1 ` {* ` Q : 1 ` *}` := rel_hoare_state P k₁ k₂ Q

namespace rel_hoare

-- lemma seq {P Q R} {k₁ k₁' k₂ k₂' : kernel σ τ} : {* P *} k₁ ~ k₁' {* Q *} → {* Q *} k₂ ~ k₂' {* R *} → {* P *} (k₁ ;; k₂) ~ (k₁' ;; k₂') {* R *} := begin
--     intros h₁ h₂ n s u ac m m' o o' hp hseq₁ hseq₂,
--     cases hseq₁,
--     cases hseq₂,
--     cases hseq₁_hk,
--     cases hseq₂_hk,
--     unfold rel_hoare at h₁ h₂,
--     apply h₂ n _ _ _ _ _ _ _ _ _ hseq₁_hk_a_1 hseq₂_hk_a_1,
-- end

end rel_hoare

/-- Relational Hoare logic on Parlang programs with assertions on memory -/
def rel_hoare_program (init₁ : ℕ → σ₁) (init₂ : ℕ → σ₂) (P : memory τ₁ → memory τ₂ → Prop) (p₁ : program σ₁ τ₁) (p₂ : program σ₂ τ₂) (Q : memory τ₁ → memory τ₂ → Prop) :=
∀ m₁ m₁' m₂, P m₁ m₂ → exec_prog init₁ p₁ m₁ m₁' → ∃ m₂', exec_prog init₂ p₂ m₂ m₂' ∧ Q m₁' m₂'

-- notation `{* ` P : 1 ` *} ` p₁ : 1 ` ~ ` p₂ : 1 ` {* ` Q : 1 ` *}` := rel_hoare_state P p₁ p₂ Q

/-- The initial kernel assertion that holds on state and ac
    TODO: change to a struct to get projections for free?
-/
def initial_kernel_assertion (init₁ : ℕ → σ₁) (init₂ : ℕ → σ₂) (P : memory τ₁ → memory τ₂ → Prop)
(f₁ : memory τ₁ → ℕ) (f₂ : memory τ₂ → ℕ) (m₁ : memory τ₁) (m₂ : memory τ₂)
(n₁) (s₁ : state n₁ σ₁ τ₁) (ac₁ : vector bool n₁) (n₂) (s₂ : state n₂ σ₂ τ₂) (ac₂ : vector bool n₂) :=
s₁.syncable m₁ ∧ s₂.syncable m₂ ∧ n₁ = f₁ m₁ ∧ n₂ = f₂ m₂ ∧
(∀ i : fin n₁, s₁.threads.nth i = { tlocal := init₁ i, shared := m₁, stores := ∅, loads := ∅ }) ∧
(∀ i : fin n₂, s₂.threads.nth i = { tlocal := init₂ i, shared := m₂, stores := ∅, loads := ∅ }) ∧
P m₁ m₂ ∧ all_threads_active ac₁ ∧ all_threads_active ac₂

/- Projections of initial_kernel_assertion -/
section

    def initial_kernel_assertion_left_thread_state {init₁ : ℕ → σ₁} {init₂ : ℕ → σ₂} {P : memory τ₁ → memory τ₂ → Prop}
    {f₁ : memory τ₁ → ℕ} {f₂ : memory τ₂ → ℕ} {m₁ : memory τ₁} {m₂ : memory τ₂}
    {n₁} {s₁ : state n₁ σ₁ τ₁} {ac₁ : vector bool n₁} {n₂} {s₂ : state n₂ σ₂ τ₂} {ac₂ : vector bool n₂}
    (i : initial_kernel_assertion init₁ init₂ P f₁ f₂ m₁ m₂ n₁ s₁ ac₁ n₂ s₂ ac₂) := i.right.right.right.right.left

    def initial_kernel_assertion.right_thread_state {init₁ : ℕ → σ₁} {init₂ : ℕ → σ₂} {P : memory τ₁ → memory τ₂ → Prop}
    {f₁ : memory τ₁ → ℕ} {f₂ : memory τ₂ → ℕ} {m₁ : memory τ₁} {m₂ : memory τ₂}
    {n₁} {s₁ : state n₁ σ₁ τ₁} {ac₁ : vector bool n₁} {n₂} {s₂ : state n₂ σ₂ τ₂} {ac₂ : vector bool n₂}
    (i : initial_kernel_assertion init₁ init₂ P f₁ f₂ m₁ m₂ n₁ s₁ ac₁ n₂ s₂ ac₂) := i.right.right.right.right.right.left

    def initial_kernel_assertion.left_all_threads_active {init₁ : ℕ → σ₁} {init₂ : ℕ → σ₂} {P : memory τ₁ → memory τ₂ → Prop}
    {f₁ : memory τ₁ → ℕ} {f₂ : memory τ₂ → ℕ} {m₁ : memory τ₁} {m₂ : memory τ₂}
    {n₁} {s₁ : state n₁ σ₁ τ₁} {ac₁ : vector bool n₁} {n₂} {s₂ : state n₂ σ₂ τ₂} {ac₂ : vector bool n₂}
    (i : initial_kernel_assertion init₁ init₂ P f₁ f₂ m₁ m₂ n₁ s₁ ac₁ n₂ s₂ ac₂) := i.right.right.right.right.right.right.right.left

    def initial_kernel_assertion.precondition {init₁ : ℕ → σ₁} {init₂ : ℕ → σ₂} {P : memory τ₁ → memory τ₂ → Prop}
    {f₁ : memory τ₁ → ℕ} {f₂ : memory τ₂ → ℕ} {m₁ : memory τ₁} {m₂ : memory τ₂}
    {n₁} {s₁ : state n₁ σ₁ τ₁} {ac₁ : vector bool n₁} {n₂} {s₂ : state n₂ σ₂ τ₂} {ac₂ : vector bool n₂}
    (i : initial_kernel_assertion init₁ init₂ P f₁ f₂ m₁ m₂ n₁ s₁ ac₁ n₂ s₂ ac₂) := i.right.right.right.right.right.right.left

    lemma initial_kernel_assertion.initial_state_eq {init₁ : ℕ → σ₁}
    {f₁ : memory τ₁ → ℕ} {f₂ : memory τ₁ → ℕ} {m₁ : memory τ₁} {m₂ : memory τ₁}
    {n₁} {s₁ : state n₁ σ₁ τ₁} {ac₁ : vector bool n₁} {s₂ : state n₁ σ₁ τ₁} {ac₂ : vector bool n₁} :
    initial_kernel_assertion init₁ init₁ eq f₁ f₂ m₁ m₂ n₁ s₁ ac₁ n₁ s₂ ac₂ →
    s₁ = s₂ |
    (and.intro _ (and.intro _ (and.intro _ (and.intro _ (and.intro s_eq (and.intro s'_eq _)))))) := begin
        clear initial_kernel_assertion.initial_state_eq,
        cases s₁,
        cases s₂,
        simp,
        apply vector.eq_element_wise,
        intro tid,
        simp *,
    end

end

/- Reduces proofs on programs to proofs on kernels -/
lemma rel_kernel_to_program {k₁ : kernel σ₁ τ₁} {k₂ : kernel σ₂ τ₂} {init₁ : ℕ → σ₁} {init₂ : ℕ → σ₂} {P Q : memory τ₁ → memory τ₂ → Prop} {f₁ : memory τ₁ → ℕ} {f₂ : memory τ₂ → ℕ}
 (h : {* λ n₁ s₁ ac₁ n₂ s₂ ac₂, ∃ m₁ m₂, initial_kernel_assertion init₁ init₂ P f₁ f₂ m₁ m₂ n₁ s₁ ac₁ n₂ s₂ ac₂ *} k₁ ~> k₂
 {* λ n₁ s₁ ac₁ n₂ s₂ ac₂, (∃ m₁, s₁.syncable m₁) → ∃ m₁ m₂, s₁.syncable m₁ ∧ s₂.syncable m₂ ∧ Q m₁ m₂ *} )
 (hg : ∀ {m₁ m₂}, P m₁ m₂ → 0 < f₁ m₁) :
 rel_hoare_program init₁ init₂ P (program.intro f₁ k₁) (program.intro f₂ k₂) Q :=
begin
    unfold rel_hoare_state at h,
    unfold rel_hoare_program,
    intros m₁ m₁' m₂ hp hep,
    cases hep,
    specialize h (f₁ m₁) (f₂ m₂)
        (init_state init₁ f₁ m₁)
        hep_s'
        (init_state init₂ f₂ m₂)
        (vector.repeat tt (f₁ m₁))
        (vector.repeat tt (f₂ m₂)),
    have hh : (∃ (s₂' : state (f₂ m₂) σ₂ τ₂), exec_state k₂ (vector.repeat tt (f₂ m₂)) (init_state init₂ f₂ m₂) s₂' ∧
    ((∃ m₁, hep_s'.syncable m₁) → ∃ (m₁_1 : memory τ₁) (m₂_1 : memory τ₂), state.syncable hep_s' m₁_1 ∧ state.syncable s₂' m₂_1 ∧ Q m₁_1 m₂_1)) := begin
        apply h,
        {
            apply exists.intro m₁,
            apply exists.intro m₂,
            apply and.intro,
            {
                apply init_state_syncable,
            }, {
                apply and.intro,
                {
                    apply init_state_syncable,
                },
                {
                    apply and.intro,
                    {
                        refl,
                    },
                    {
                        apply and.intro,
                        {
                            refl,
                        },
                        {
                            apply and.intro,
                            {
                                simp,
                                intro i,
                                rw vector.range_nth,
                            },
                            {
                                apply and.intro,
                                {
                                    simp,
                                    intro i,
                                    rw vector.range_nth,
                                }, {
                                    apply and.intro,
                                    {
                                        exact hp,
                                    }, {
                                        apply and.intro,
                                        {
                                            apply all_threads_active_repeat,
                                        }, {
                                            apply all_threads_active_repeat,
                                        }
                                    }
                                }
                            }
                        }
                    }
                }
            }
        }, {
            exact hep_he,
        }
    end,
    cases hh,
    cases hh_h,
    specialize hh_h_right ⟨_, hep_hsync⟩,
    cases hh_h_right with m₁'',
    cases hh_h_right_h with m₂',
    apply exists.intro m₂',
    apply and.intro,
    {
        apply exec_prog.intro _ _ _ _ _ hh_w,
        { exact hh_h_right_h_h.right.left, },
        { exact hh_h_left, },
    }, {
        have hu : m₁' = m₁'' := begin
            have hz : 0 < (f₁ m₁) := hg hp,
            apply state.syncable_unique hep_hsync hh_h_right_h_h.left hz,
        end,
        subst hu,
        exact hh_h_right_h_h.right.right,
    }
end

/-
    Inference rules
 -/

-- TODO: define the alias skip for (compute id)
lemma single_step_left {P Q} {k₁ k : kernel σ₁ τ₁} {k₂ : kernel σ₂ τ₂} (R)
    (h₁ : {* P *} k ~> (kernel.compute id) {* R *})
    (h₂ : {* R *} k₁ ~> k₂ {* Q *}) :
    {* P *} (k ;; k₁) ~> k₂ {* Q *} := begin
    intros n₁ n₂ s₁ s₁'' s₂ ac₁ ac₂ hp hek₁,
    cases hek₁,
    specialize h₁ n₁ n₂ s₁ _ s₂ ac₁ ac₂ hp hek₁_a,
    cases h₁ with s₂' h₁,
    cases h₁,
    have : s₂ = s₂' := begin
        cases h₁_left,
        cases s₂,
        sorry, -- trivial
    end,
    apply h₂,
    rw this,
    exact h₁_right,
    exact hek₁_a_1,
end

lemma single_step_right {P Q} {k₁ : kernel σ₁ τ₁} {k₂ k : kernel σ₂ τ₂} (R)
    (h₁ : {* P *} (kernel.compute id) ~> k  {* R *})
    (h₂ : {* R *} k₁ ~> k₂ {* Q *}) :
    {* P *} k₁ ~> k ;; k₂ {* Q *} := sorry

variables {P Q R P' Q' I : Π n₁:ℕ, state n₁ σ₁ τ₁ → vector bool n₁ → Π n₂:ℕ, state n₂ σ₂ τ₂ → vector bool n₂ → Prop} {k₁ k₁' : kernel σ₁ τ₁} {k₂ k₂' : kernel σ₂ τ₂}

-- intuition of the proof (to be repurposed by further proofs):
-- we get the intermediate state of after k₁ by cases
-- from h₁ we get state after k₂
-- from h₂ we get state after k₂'
lemma seq (Q)
    (h₁ : {* P *} k₁ ~> k₂ {* Q *})
    (h₂ : {* Q *} k₁' ~> k₂' {* R *}) :
    {* P *} (k₁ ;; k₁') ~> (k₂ ;; k₂') {* R *} := begin
        intros _ _ _ _ _ _ _ hp hek₁k₁',
        cases hek₁k₁',
        specialize h₁ n₁ n₂ s₁ hek₁k₁'_t s₂ ac₁ ac₂ hp hek₁k₁'_a,
        cases h₁ with t₂,
        cases h₁_h with hek₂ hq,
        specialize h₂ n₁ n₂ hek₁k₁'_t _ t₂ ac₁ ac₂ hq hek₁k₁'_a_1,
        cases h₂ with s₂',
        apply exists.intro s₂',
        apply and.intro,
        apply exec_state.seq _ _ _ _ _ _ hek₂ (h₂_h.left),
        exact h₂_h.right,
end

-- sometimes called sub
lemma consequence (h : {* P *} k₁ ~> k₂ {* Q *})
(hp : ∀ n₁ s₁ ac₁ n₂ s₂ ac₂, P' n₁ s₁ ac₁ n₂ s₂ ac₂ → P n₁ s₁ ac₁ n₂ s₂ ac₂)
(hq : ∀ n₁ s₁ ac₁ n₂ s₂ ac₂, Q n₁ s₁ ac₁ n₂ s₂ ac₂ → Q' n₁ s₁ ac₁ n₂ s₂ ac₂) : {* P' *} k₁ ~> k₂ {* Q' *} := begin
    intros _ _ _ _ _ _ _ hp' he₁,
    specialize h n₁ n₂ s₁ s₁' s₂ ac₁ ac₂ _ he₁,
    cases h with s₂ h,
    use s₂,cases h,
    apply and.intro,
    assumption,
    apply hq,
    assumption,
    apply hp,
    assumption,
end

lemma consequence_pre (h : {* P *} k₁ ~> k₂ {* Q *})
(hp : ∀ n₁ s₁ ac₁ n₂ s₂ ac₂, P' n₁ s₁ ac₁ n₂ s₂ ac₂ → P n₁ s₁ ac₁ n₂ s₂ ac₂) :
{* P' *} k₁ ~> k₂ {* Q *} := begin
    apply consequence,
    exact h,
    exact hp,
    intros,
    exact a,
end

lemma consequence_post (h : {* P *} k₁ ~> k₂ {* Q *})
(hp : ∀ n₁ s₁ ac₁ n₂ s₂ ac₂, Q n₁ s₁ ac₁ n₂ s₂ ac₂ → Q' n₁ s₁ ac₁ n₂ s₂ ac₂) :
{* P *} k₁ ~> k₂ {* Q' *} := begin
    apply consequence,
    exact h,
    intros,
    exact a,
    exact hp,
end

def assertion_swap_side (P : @rhl_kernel_assertion σ₁ σ₂ _ _ τ₁ τ₂ _ _) := λ n₁ s₁ ac₁ n₂ s₂ ac₂, P n₂ s₂ ac₂ n₁ s₁ ac₁

lemma swap' (h : {* λ n₁ s₁ ac₁ n₂ s₂ ac₂, P n₁ s₁ ac₁ n₂ s₂ ac₂ ∧ ∃ t, exec_state k₂ ac₂ s₂ t *} k₁ ~> k₂ {* Q *}) (he₁ : ∀ {n₁ s₁ ac₁ n₂ s₂ ac₂}, P n₁ s₁ ac₁ n₂ s₂ ac₂ → ∃ s₁', exec_state k₁ ac₁ s₁ s₁') :
{* assertion_swap_side P *} k₂ ~> k₁ {* assertion_swap_side Q *} := begin
    sorry,
end

-- k₁ must terminate
lemma swap (h : {* P *} k₁ ~> k₂ {* Q *}) (he₁ : ∀ {n₁ s₁ ac₁ n₂ s₂ ac₂}, P n₁ s₁ ac₁ n₂ s₂ ac₂ → ∃ s₁', exec_state k₁ ac₁ s₁ s₁') :
{* assertion_swap_side P *} k₂ ~> k₁ {* assertion_swap_side Q *} := begin
    intros n₂ n₁ s₂ s₂' s₁ ac₂ ac₁ hp he₂,
    simp,
    have : ∃ s₁', exec_state k₁ ac₁ s₁ s₁' := he₁ hp,
    cases this with s₁' he₂,
    use s₁',
    split,
    assumption,
    specialize h n₁ n₂ s₁ _ s₂ ac₁ ac₂ hp he₂,
    cases h,
    have : h_w = s₂' := sorry, -- by uniqueness
    subst this,
    exact h_h.right,
end

theorem trans (p₁ : program σ₁ τ₁) (p₂ : program σ₂ τ₁) (p₃ : program σ₃ τ₁) (init₁ init₂ init₃) (h₁ : rel_hoare_program init₁ init₂ eq p₁ p₂ eq) (h₂ : rel_hoare_program init₂ init₃ eq p₂ p₃ eq) :
rel_hoare_program init₁ init₃ eq p₁ p₃ eq := begin
    unfold rel_hoare_program at *,
    intros _ _ _ heq he,
    specialize h₁ m₁ m₁' m₂ heq he,
    cases h₁ with m h,
    cases h,
    subst heq,
    subst h_right,
    specialize h₂ m₁ m₁' m₁ rfl h_left,
    exact h₂,
end

theorem compute_right (f) : {* λ n₁ s₁ ac₁ n₂ s₂ ac₂, Q n₁ s₁ ac₁ n₂ (s₂.map_active_threads ac₂ $ thread_state.compute f) ac₂ *} (kernel.compute id) ~> (kernel.compute f) {* Q *} := begin
    intros _ _ _ _ _ _ _ hp he,
    use (s₂.map_active_threads ac₂ $ thread_state.compute f),
    split,
    {
        apply exec_state.compute,
    }, {
        cases he,
        sorry, -- trivial
    }
end

theorem store_right (f : σ₂ → (Σ (i : ι₂), τ₂ i)) :
{* λ n₁ s₁ ac₁ n₂ s₂ ac₂, Q n₁ s₁ ac₁ n₂ (s₂.map_active_threads ac₂ $ thread_state.store f) ac₂ *}
(kernel.compute id) ~> (kernel.store f)
{* Q *} := begin
    intros _ _ _ _ _ _ _ hp he,
    use (s₂.map_active_threads ac₂ $ thread_state.store f),
    split, {
        apply exec_state.store,
    }, {
        cases he,
        sorry, -- trivial
    }
end

-- TODO: move to another file
theorem else_skip {n} (k : kernel σ τ₁) (c) (ac : vector bool n) (s s' : state n σ τ₁):
exec_state k (deactivate_threads (bnot ∘ c) ac s) s s' ↔
exec_state (kernel.ite c k (kernel.compute id)) ac s s' := begin
    split, {
        intro h,
        apply exec_state.ite s s',
        exact h,
        apply exec_skip,
    }, {
        intro h,
        cases h,
        have := eq.symm (exec_skip_eq h_a_1),
        subst this,
        exact h_a,
    }
end

/--
Breaks a ite-instruction into the individual branches
The assertions can be used to carry information about the active map from before the branch to after the branch
In the if-branch, the condition holds on all active threads (similar in else-branch). The inverse is not true. Just because the condition *c* holds, does not mean that the thread is active (e.g. if the thread was already inactive). -/
theorem ite_right (c : σ₂ → bool) (th) (el) (AC : ∀ {n₂ : ℕ}, vector bool n₂ → Prop)
(h₁ : ∀ n₁ s₁ ac₁ n₂ s₂ ac₂, P n₁ s₁ ac₁ n₂ s₂ ac₂ → P n₁ s₁ ac₁ n₂ s₂ (deactivate_threads (bnot ∘ c) ac₂ s₂))
(h₂ : ∀ n₁ s₁ ac₁ n₂ s₂ ac₂ (s' : state n₂ σ₂ τ₂), Q n₁ s₁ ac₁ n₂ s₂ (deactivate_threads (bnot ∘ c) ac₂ s') → Q n₁ s₁ ac₁ n₂ s₂ ac₂)
(h₃ : ∀ n₁ s₁ ac₁ n₂ s₂ ac₂ (s' : state n₂ σ₂ τ₂), Q n₁ s₁ ac₁ n₂ s₂ ac₂ → Q n₁ s₁ ac₁ n₂ s₂ (deactivate_threads c ac₂ s'))
(h₄ : ∀ n₁ s₁ ac₁ n₂ s₂ ac₂ (s' : state n₂ σ₂ τ₂), R n₁ s₁ ac₁ n₂ s₂ (deactivate_threads c ac₂ s') → R n₁ s₁ ac₁ n₂ s₂ ac₂) :
{* λ n₁ s₁ ac₁ n₂ s₂ ac₂, P n₁ s₁ ac₁ n₂ s₂ ac₂ ∧ (s₂.active_threads ac₂).all (λts, c ts.tlocal) *} kernel.compute id ~> th {* Q *} →
{* λ n₁ s₁ ac₁ n₂ s₂ ac₂, Q n₁ s₁ ac₁ n₂ s₂ ac₂ ∧ (s₂.active_threads ac₂).all (λts, bnot $ c ts.tlocal) *} kernel.compute id ~> el {* R *} →
{* λ n₁ s₁ ac₁ n₂ s₂ ac₂, P n₁ s₁ ac₁ n₂ s₂ ac₂ ∧ AC ac₂ *} kernel.compute id ~> kernel.ite c th el {* λ n₁ s₁ ac₁ n₂ s₂ ac₂, R n₁ s₁ ac₁ n₂ s₂ ac₂ ∧ AC ac₂ *}
:= begin
    intros hth hel,
    intros _ _ _ _ _ _ _ hp he,
    specialize hth n₁ n₂ s₁ s₁ s₂ ac₁ (deactivate_threads (bnot ∘ c) ac₂ s₂) _ exec_skip,
    swap, {
        split, {
            apply h₁ _ _ _ _ _ _ hp.left,
        }, {
            sorry, -- not trivial
        }
    },
    cases hth with s₂' hth,
    specialize hel n₁ n₂ s₁ s₁ s₂' ac₁ (deactivate_threads c ac₂ s₂) _ (exec_skip),
    swap, {
        split, {
            apply h₃,
            apply h₂ _ _ _ _ _ _ s₂,
            exact hth.right,
        }, {
            sorry, -- not trivial
        }
    },
    cases hel with s₂'' hel,
    have := eq.symm (exec_skip_eq he),
    subst this,
    use s₂'',
    split, {
        apply exec_state.ite,
        exact hth.left,
        exact hel.left,
    },
    simp,
    split, {
        apply h₄,
        exact hel.right,
    }, {
        exact hp.right,
    }
end

/-- *ite_right* w/o an assertion on the active map -/
theorem ite_right' (c : σ₂ → bool) (th) (el)
(h₁ : ∀ n₁ s₁ ac₁ n₂ s₂ ac₂, P n₁ s₁ ac₁ n₂ s₂ ac₂ → P n₁ s₁ ac₁ n₂ s₂ (deactivate_threads (bnot ∘ c) ac₂ s₂))
(h₂ : ∀ n₁ s₁ ac₁ n₂ s₂ ac₂ (s' : state n₂ σ₂ τ₂), Q n₁ s₁ ac₁ n₂ s₂ (deactivate_threads (bnot ∘ c) ac₂ s') → Q n₁ s₁ ac₁ n₂ s₂ ac₂)
(h₃ : ∀ n₁ s₁ ac₁ n₂ s₂ ac₂ (s' : state n₂ σ₂ τ₂), Q n₁ s₁ ac₁ n₂ s₂ ac₂ → Q n₁ s₁ ac₁ n₂ s₂ (deactivate_threads c ac₂ s'))
(h₄ : ∀ n₁ s₁ ac₁ n₂ s₂ ac₂ (s' : state n₂ σ₂ τ₂), R n₁ s₁ ac₁ n₂ s₂ (deactivate_threads c ac₂ s') → R n₁ s₁ ac₁ n₂ s₂ ac₂) :
{* λ n₁ s₁ ac₁ n₂ s₂ ac₂, P n₁ s₁ ac₁ n₂ s₂ ac₂ ∧ (s₂.active_threads ac₂).all (λts, c ts.tlocal) *} kernel.compute id ~> th {* Q *} →
{* λ n₁ s₁ ac₁ n₂ s₂ ac₂, Q n₁ s₁ ac₁ n₂ s₂ ac₂ ∧ (s₂.active_threads ac₂).all (λts, bnot $ c ts.tlocal) *} kernel.compute id ~> el {* R *} →
{* P *} kernel.compute id ~> kernel.ite c th el {* R *}
:= begin
    intros _ _,
    suffices : {* λ n₁ s₁ ac₁ n₂ s₂ ac₂, P n₁ s₁ ac₁ n₂ s₂ ac₂ ∧ (λ_, true) ac₂ *} kernel.compute id ~> kernel.ite c th el {* λ n₁ s₁ ac₁ n₂ s₂ ac₂, R n₁ s₁ ac₁ n₂ s₂ ac₂ ∧ (λ_, true) ac₂ *},
    simp at this,
    exact this,
    apply ite_right,
    repeat { assumption, },
    exact h₂,
end

-- TODO: use ite_right
theorem then_right (c : σ₂ → bool) (th)
(h₁ : ∀ n₁ s₁ ac₁ n₂ s₂ ac₂, P n₁ s₁ ac₁ n₂ s₂ ac₂ → P n₁ s₁ ac₁ n₂ s₂ (deactivate_threads (bnot ∘ c) ac₂ s₂))
(h₂ : ∀ n₁ s₁ ac₁ n₂ s₂ ac₂ (s : state n₂ σ₂ τ₂), Q n₁ s₁ ac₁ n₂ s₂ (deactivate_threads (bnot ∘ c) ac₂ s) → Q n₁ s₁ ac₁ n₂ s₂ ac₂) :
{* λ n₁ s₁ ac₁ n₂ s₂ ac₂, P n₁ s₁ ac₁ n₂ s₂ ac₂ ∧ (s₂.active_threads ac₂).all (λts, c ts.tlocal) *} kernel.compute id ~> th {* Q *} →
{* P *} kernel.compute id ~> kernel.ite c th (kernel.compute id) {* Q *}
:= begin
    intros hth,
    intros _ _ _ _ _ _ _ hp he,
    have := eq.symm (exec_skip_eq he),
    subst this,
    specialize hth n₁ n₂ s₁ s₁ s₂ ac₁ (deactivate_threads (bnot ∘ c) ac₂ s₂) _ he,
    swap, {
        split, {
            apply h₁,
            apply hp,
        }, {
            sorry, -- not trivial
        }
    },
    cases hth with s₂' hth,
    use s₂',
    split, {
        apply exec_state.ite,
        exact hth.left,
        apply exec_skip,
    }, {
        apply h₂,
        apply hth.right,
    }
end

/-- TODO:
    - add post-condition: condition is false on all active threads
    - rename n
    - drop h₃ and deactivate threads in the post condition of hb ()
-/
/- theorem while_right.aux (c : σ₂ → bool) (k) (V : ∀ {n₂} (s₂ : state n₂ σ₂ τ₂) (ac₂ : vector bool n₂), ℕ)
(h₁ : ∀ {n₁ s₁ ac₁ n₂ s₂ ac₂}, P n₁ s₁ ac₁ n₂ s₂ ac₂ → P n₁ s₁ ac₁ n₂ s₂ (deactivate_threads (bnot ∘ c) ac₂ s₂))
(h₂ : ∀ {n₁ s₁ ac₁ n₂ s₂ ac₂} {s : state n₂ σ₂ τ₂}, P n₁ s₁ ac₁ n₂ s₂ (deactivate_threads (bnot ∘ c) ac₂ s) → P n₁ s₁ ac₁ n₂ s₂ ac₂)
(h₃ : ∀ {n₂} (s₂ : state n₂ σ₂ τ₂) (ac₂ : vector bool n₂), V s₂ (deactivate_threads (bnot ∘ c) ac₂ s₂) ≤ V s₂ ac₂)
(hb : ∀ n, {* λ n₁ s₁ ac₁ n₂ s₂ ac₂, P n₁ s₁ ac₁ n₂ s₂ ac₂ ∧ (s₂.active_threads ac₂).all (λts, c ts.tlocal) ∧ V s₂ ac₂ = n *} kernel.compute id ~> k {* λ n₁ s₁ ac₁ n₂ s₂ ac₂, P n₁ s₁ ac₁ n₂ s₂ ac₂ ∧ V s₂ ac₂ < n *}) :
∀ (n : ℕ), {* λ n₁ s₁ ac₁ n₂ s₂ ac₂, P n₁ s₁ ac₁ n₂ s₂ ac₂ ∧ V s₂ (deactivate_threads (bnot ∘ c) ac₂ s₂) = n *} kernel.compute id ~> kernel.loop c k {* P *}
| n n₁ n₂ s₁ s₁' s₂ ac₁ ac₂ ⟨hp, hv⟩ he :=
let ha := (any_thread_active (deactivate_threads (bnot ∘ c) ac₂ s₂)) in
let goal := ∃ (s₂' : state n₂ σ₂ τ₂), exec_state (kernel.loop c k) ac₂ s₂ s₂' ∧ P n₁ s₁' ac₁ n₂ s₂' ac₂ in
have base : ha = ff → goal, from begin
    intro ha,
    {
        use s₂,
        split, {
            apply exec_state.loop_stop,
            sorry
        }, {
            sorry, -- trivial
        }
    }
end,
have it : ha = tt → goal, from (
    assume hha,
    /- precondition holds in the first loop iteration -/
    have hp' : P n₁ s₁ ac₁ n₂ s₂ (deactivate_threads (bnot ∘ c) ac₂ s₂) := begin
        exact h₁ hp,
    end,
    /- the condition is true for all active threads in the first loop iteration -/
    have hc : list.all (state.active_threads (deactivate_threads (bnot ∘ c) ac₂ s₂) s₂) (λ ts , c (ts.tlocal)) = tt := begin
        sorry, -- not trivial
    end,
    /- proof of first iteration -/
    have step : _ := hb (V s₂ (deactivate_threads (bnot ∘ c) ac₂ s₂)) n₁ n₂ s₁ s₁ s₂ ac₁ (deactivate_threads (bnot ∘ c) ac₂ s₂) ⟨hp', ⟨hc, rfl⟩⟩ exec_skip,
    /- s₂' is the state after first iteration -/
    show goal, from match step with ⟨s₂', step⟩ :=
        /- condition holds after first iteration -/
        have hp'' : P n₁ s₁ ac₁ n₂ s₂' (deactivate_threads (bnot ∘ c) ac₂ s₂) := begin
            simp at step,
            exact step.right.left,
        end,
        have wf : V s₂' (deactivate_threads (bnot ∘ c) (deactivate_threads (bnot ∘ c) ac₂ s₂) s₂') < n := begin
            simp at step,
            subst hv,
            specialize h₃ s₂' (deactivate_threads (bnot ∘ c) ac₂ s₂),
            rw le_iff_eq_or_lt at h₃,
            cases h₃,
            {
                rw h₃,
                exact step.right.right,
            }, {
                apply lt_trans h₃ step.right.right,
            }
        end,
        have ih : _ := while_right.aux (V s₂' (deactivate_threads (bnot ∘ c) (deactivate_threads (bnot ∘ c) ac₂ s₂) s₂')) n₁ n₂ s₁ s₁ s₂' ac₁ (deactivate_threads (bnot ∘ c) ac₂ s₂) ⟨hp'', rfl⟩ exec_skip,
        show goal, from match ih with ⟨s₂'', ih⟩ := (begin
            use  s₂'',
            split, {
                apply exec_state.loop_step,
                exact ha,
                exact step.left,
                exact ih.left,
            }, {
                have := exec_skip_eq he,
                clear _match _match,
                subst this,
                apply h₂ ih.right,
            },
        end)
        end -- end match
    end
),
show goal, from begin
    cases a : ha,
    exact base a,
    exact it a,
end -/

theorem while_right (c : σ₂ → bool) (k) (V : ∀ {n₂} (s₂ : state n₂ σ₂ τ₂) (ac₂ : vector bool n₂), ℕ)
(h₁ : ∀ {n₁ s₁ ac₁ n₂ s₂ ac₂}, I n₁ s₁ ac₁ n₂ s₂ ac₂ → I n₁ s₁ ac₁ n₂ s₂ (deactivate_threads (bnot ∘ c) ac₂ s₂))
(h₂ : ∀ {n₁ s₁ ac₁ n₂ s₂ ac₂} {s : state n₂ σ₂ τ₂}, I n₁ s₁ ac₁ n₂ s₂ (deactivate_threads (bnot ∘ c) ac₂ s) → I n₁ s₁ ac₁ n₂ s₂ ac₂)
(hb : ∀ n, {* λ n₁ s₁ ac₁ n₂ s₂ ac₂, I n₁ s₁ ac₁ n₂ s₂ ac₂ ∧ (s₂.active_threads ac₂).all (λts, c ts.tlocal) ∧ V s₂ ac₂ = n *} kernel.compute id ~> k {* λ n₁ s₁ ac₁ n₂ s₂ ac₂, I n₁ s₁ ac₁ n₂ s₂ ac₂ ∧ V s₂ (deactivate_threads (bnot ∘ c) ac₂ s₂) < n *}) :
{* I *} kernel.compute id ~> kernel.loop c k {* I *} := sorry

theorem while_left (c : σ₁ → bool) (k) (V : ∀ {n₂} (s₂ : state n₂ σ₂ τ₂) (ac₂ : vector bool n₂), ℕ)
(h₁ : ∀ {n₁ s₁ ac₁ n₂ s₂ ac₂}, I n₁ s₁ ac₁ n₂ s₂ ac₂ → I n₁ s₁ (deactivate_threads (bnot ∘ c) ac₁ s₁) n₂ s₂ ac₂)
(h₂ : ∀ {n₁ s₁ ac₁ n₂ s₂ ac₂} {s : state n₁ σ₁ τ₁}, I n₁ s₁ (deactivate_threads (bnot ∘ c) ac₁ s) n₂ s₂ ac₂ → I n₁ s₁ ac₁ n₂ s₂ ac₂)
(hb : {* λ n₁ s₁ ac₁ n₂ s₂ ac₂, I n₁ s₁ ac₁ n₂ s₂ ac₂ ∧ (s₁.active_threads ac₁).all (λts, c ts.tlocal) *} k ~> kernel.compute id {* λ n₁ s₁ ac₁ n₂ s₂ ac₂, I n₁ s₁ ac₁ n₂ s₂ ac₂ *}) :
{* I *} kernel.loop c k ~> kernel.compute id {* I *} := begin
    apply swap,
    {
        sorry, -- we need the assumption that the loop terminates here
    },
    sorry,
end

theorem ite_left' (c : σ₁ → bool) (th) (el)
(h₁ : ∀ n₁ s₁ ac₁ n₂ s₂ ac₂, P n₁ s₁ ac₁ n₂ s₂ ac₂ → P n₁ s₁ (deactivate_threads (bnot ∘ c) ac₁ s₁) n₂ s₂ ac₂)
(h₂ : ∀ n₁ s₁ ac₁ n₂ s₂ ac₂ (s' : state n₁ σ₁ τ₁), Q n₁ s₁ (deactivate_threads (bnot ∘ c) ac₁ s') n₂ s₂ ac₂ → Q n₁ s₁ ac₁ n₂ s₂ ac₂)
(h₃ : ∀ n₁ s₁ ac₁ n₂ s₂ ac₂ (s' : state n₁ σ₁ τ₁), Q n₁ s₁ ac₁ n₂ s₂ ac₂ → Q n₁ s₁ (deactivate_threads c ac₁ s') n₂ s₂ ac₂)
(h₄ : ∀ n₁ s₁ ac₁ n₂ s₂ ac₂ (s' : state n₁ σ₁ τ₁), R n₁ s₁ (deactivate_threads c ac₁ s') n₂ s₂ ac₂ → R n₁ s₁ ac₁ n₂ s₂ ac₂) :
{* λ n₁ s₁ ac₁ n₂ s₂ ac₂, P n₁ s₁ ac₁ n₂ s₂ ac₂ ∧ (s₁.active_threads ac₁).all (λts, c ts.tlocal) *} th ~> kernel.compute id {* Q *} →
{* λ n₁ s₁ ac₁ n₂ s₂ ac₂, Q n₁ s₁ ac₁ n₂ s₂ ac₂ ∧ (s₁.active_threads ac₁).all (λts, bnot $ c ts.tlocal) *} el ~> kernel.compute id {* R *} →
{* P *} kernel.ite c th el ~> kernel.compute id {* R *} := begin
    intros hth hel,
    apply swap',
    {
        apply ite_right',
        swap 5, {
            apply swap,
            apply consequence,
            apply hth,
            {
                intros,
                exact ⟨a.left.left, a.right⟩,
            }, {
                intros,
                exact a,
            },
            intros,
            cases a.left.right,
            cases h,

            sorry, -- we need proof that th terminates
        },
        swap 5, {
            apply swap,
            apply hel,
            sorry, -- we need proof that el terminates
        }, {
            intros,
            split,
            apply h₁,
            exact a.left,
            sorry,
        }, {
            intros,
            apply h₂,
            exact a,
        }, {
            intros,
            apply h₃,
            exact a,
        }, {
            sorry,
        }
    }, {
        intros,
        use s₁,
        apply exec_skip,
    }
end

lemma kernel_foldr_skip_right {k : kernel σ₂ τ₂} {ks} :
{* P *} k₁ ~> list.foldr kernel.seq k ks {* Q *} ↔ {* P *} k₁ ~> list.foldr kernel.seq (kernel.compute id) ks ;; k {* Q *} := sorry

lemma rhl_eq :
{* λn₁ (s₁ : state n₁ σ₁ τ₁) ac₁ n₂ s₂ ac₂, n₁ = n₂ ∧ ∀ h : n₁ = n₂, s₁ = (by rw h; exact s₂) ∧ ac₁ = (by rw h; exact ac₂) *}
k₁ ~> k₁
{* λn₁ s₁ ac₁ n₂ s₂ ac₂, n₁ = n₂ ∧ ∀ h : n₁ = n₂, s₁ = (by rw h; exact s₂) ∧ ac₁ = (by rw h; exact ac₂) *} := begin
    intros _ _ _ _ _ _ _ hp  he,
    cases hp,
    subst hp_left,
    specialize hp_right rfl,
    have : s₁ = s₂ := hp_right.left,
    subst this,
    have : ac₁ = ac₂ := hp_right.right,
    subst this,
    use s₁',
    split,
    exact he,
    simp,
    split,
    refl,
    refl,
end

theorem known_branch_left (c : σ₁ → bool) (th) (el)
(h₁ : ∀ n₁ s₁ ac₁ n₂ s₂ ac₂, P n₁ s₁ ac₁ n₂ s₂ ac₂ → ∀ tid : fin n₁, c $ (s₁.threads.nth tid).tlocal)
(h₂ : {* P *} th ~> k₂ {* Q *}) :
{* P *} kernel.ite c th el ~> k₂ {* Q *} := begin
    intros _ _ _ _ _ _ _ hp he,
    cases he,
    specialize h₁ n₁ s₁ ac₁ n₂ s₂ ac₂ hp,
    apply h₂ n₁ n₂ s₁ s₁' s₂ ac₁ ac₂ hp,
    have : (deactivate_threads (bnot ∘ c) ac₁ s₁) = ac₁ := begin
        apply ac_deac_ge',
        intros _ h' _,
        specialize h₁ t,
        simp [deactivate_threads, *] at h',
        exact h',
    end,
    rw this at he_a,
    have : no_thread_active (deactivate_threads c ac₁ s₁) = tt := sorry,
    have : exec_state el (deactivate_threads c ac₁ s₁) he_t he_t := exec_no_threads_active this,
    have : he_t = s₁' := exec_state_unique he_a_1 this,
    subst this,
    exact he_a,
end

end parlang


/-
Copyright (c) 2017 Daniel Selsam. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Daniel Selsam

Identifiers.
-/
import .util .label

namespace certigrad

inductive ID : Type
| str : label → ID
| nat : ℕ → ID

namespace ID

instance : decidable_eq ID := by tactic.mk_dec_eq_instance
instance : inhabited ID := ⟨ID.str label.default⟩

private def add : ID → ID → ID
| (ID.nat n₁) (ID.nat n₂) := ID.nat (n₁ + n₂)
| _           _           := default ID

def to_str : ID → string
| (str l) := to_string l
| (nat n) := "#" ++ to_string n

instance : has_to_string ID := ⟨to_str⟩

def less_than : ID → ID → Prop
| (nat n)  (str s) := true
| (str s)  (nat n) := false
| (nat n₁) (nat n₂) := n₁ < n₂
| (str s₁) (str s₂) := s₁ < s₂

instance : has_lt ID := ⟨less_than⟩

instance decidable_less_than : Π (x y : ID), decidable (x < y)
| (nat n)  (str s) := decidable.true
| (str s)  (nat n) := decidable.false
| (nat n₁) (nat n₂) := show decidable (n₁ < n₂), by apply_instance
| (str s₁) (str s₂) := by apply label.decidable_less_than

end ID

lemma id_str_ne_nat (x : label) (n : ℕ) : (ID.str x ≠ ID.nat n) = true :=
begin apply pextt, intro H, injection H end

lemma id_nat_ne_str (x : label) (n : ℕ) : (ID.nat n ≠ ID.str x) = true :=
begin apply pextt, intro H, injection H end

lemma id_str_ne_str (x₁ x₂ : label) : (ID.str x₁ ≠ ID.str x₂) = (x₁ ≠ x₂) :=
begin
apply propext,
split,
intros H_ne H_eq,
subst H_eq,
exact H_ne rfl,
intros H_ne H_eq,
injection H_eq with H,
exact H_ne H
end

lemma id_nat_ne_nat (n₁ n₂ : ℕ) : (ID.nat n₁ ≠ ID.nat n₂) = (n₁ ≠ n₂) :=
begin
apply propext,
split,
intros H_ne H_eq,
subst H_eq,
exact H_ne rfl,
intros H_ne H_eq,
injection H_eq with H,
exact H_ne H
end

end certigrad


/- In this file we define affine varieties and affine groups over a discrete field `K`.
  We take a shortcut in the definition, by defining affine varieties as the opposite
  category of finitely generated reduced algebras. We define affine groups and basic
  group theory for affine groups: closed subgroups, kernels, normal subgroups, solvable groups, Borel subgroups, centralizers. -/
import ring_theory.basic
       ..category_theory.group_object
       ..category_theory.limits2
       tactic.omitted
       category_theory.limits.opposites
       topology.opens

open category_theory ideal set topological_space

noncomputable theory
universes u v w

-- we set some priorities of instances very low, because they cause problems in this file
local attribute [instance, priority 1] limits.category_theory.limits.has_limit
  limits.category_theory.limits.has_colimit limits.category_theory.limits.has_colimits
  limits.category_theory.limits.has_limits limits.category_theory.limits.has_limits_of_shape
  limits.category_theory.limits.has_colimits_of_shape

def has_coe_ideal {α : Type u} [comm_ring α] : has_coe (ideal α) (set α) := by apply_instance
local attribute [instance] has_coe_ideal

/-- An algebraically closed field is a field where every polynomial with positive degree has a root -/
class algebraically_closed_field (α : Type u) extends discrete_field α :=
(closed : is_algebraically_closed α)

local attribute [instance, priority 0] classical.prop_decidable
/-- A finitely generated reduced algebra -/
class finitely_generated_reduced_algebra (R : Type u) (A : Type v)
  [comm_ring R] [comm_ring A] extends algebra R A :=
(finitely_generated : is_finitely_generated R A)
(reduced : is_reduced A)

variables (K : Type u) [discrete_field K]
          (R : Type v) [comm_ring R] (S : Type w) [comm_ring S]
          [finitely_generated_reduced_algebra K R] [finitely_generated_reduced_algebra K S]
          {σ : Type w} [decidable_eq σ]

open finitely_generated_reduced_algebra category_theory tensor_product
namespace algebraic_geometry

/-- The spectrum `Specm(R)` of a `K`-algebra `R` is the set of homomorphisms from `R` to `K`.
  This corresponds to maximal ideals in `R`. -/
@[reducible] def spectrum : Type* := R →ₐ[K] K

variables {R K}
/-- The quotient of R by a maximal ideal is isomorphic to K -/
def quotient_maximal_ideal (I : maximal_ideal R) :
  { f : I.val.quotient ≃ K // is_ring_hom f.to_fun } :=
classical.choice omitted -- TODO: fix non-canoncial choice

/-- The spectrum of R is equivalent to the set of maximal ideals on R -/
def spectrum_equiv_maximal_ideal : spectrum K R ≃ maximal_ideal R :=
let f : maximal_ideal R → R → K :=
  λ I, (quotient_maximal_ideal I).val.to_fun ∘ ideal.quotient.mk I.val in
by { haveI h : ∀ I : maximal_ideal R, is_ring_hom (f I) := omitted,
     exact ⟨λ ϕ, ⟨ideal.ker ⇑ϕ, omitted⟩, λ I, ⟨f I, omitted⟩, omitted, omitted⟩ }

variables (K) {R}
/-- `Z(S)` is the set of homomorphisms in `Spec(R)` that vanish on `S`. -/
def Z (S : set R) : set (spectrum K R) := { f | ∀ x ∈ S, f.to_fun x = 0 }

/--`I(X)` consists of all points in `R` that are send to `0` by all `ϕ ∈ X`-/
def I (X : set (spectrum K R)) : set R :=
{ x : R | ∀ϕ : X, ϕ.val x = 0 }

/-- `Z(S)` is equal to `Z` of the radical of the span of `S`. -/
lemma Z_radical_span (S : set R) : Z K ((ideal.span S).radical.carrier) = Z K S :=
omitted

variables (K R)

/-- The Zariski topology is the topology where the closed sets are of the form `Z(S)` for some `S ⊆ R` -/
instance Zariski_topology : topological_space (spectrum K R) :=
⟨set.range (λ S : set R, - Z K S), omitted, omitted, omitted⟩

variables {K R}
/-- A radical ideal gives rise to a closed set in the Zariski topology -/
def closeds_of_radical_ideal (I : radical_ideal R) : closeds (spectrum K R) :=
⟨Z K I.val, mem_range_self I.val⟩

/-- A closed set in the Zariski topology gives rise to a radical ideal -/
def radical_ideal_of_closeds (X : closeds (spectrum K R)) : radical_ideal R :=
⟨⟨ I K X.val, omitted, omitted, omitted⟩, omitted⟩

/-- Hilbert's Nullstellensatz: there is a correspondence between radical ideals in R and
 closed sets in the spectrum of R. -/
def Nullstellensatz : radical_ideal R ≃ closeds (spectrum K R) :=
⟨closeds_of_radical_ideal, radical_ideal_of_closeds, omitted, omitted⟩

instance base.finitely_generated_reduced_algebra :
  finitely_generated_reduced_algebra K K :=
{ finitely_generated := is_finitely_generated_base K,
  reduced := is_reduced_integral_domain,
  .._inst_1 }

instance quotient.finitely_generated_reduced_algebra (I : radical_ideal R) :
  finitely_generated_reduced_algebra K I.val.quotient :=
{ finitely_generated := is_finitely_generated_quotient (finitely_generated K R) I.val,
  reduced := is_reduced_quotient I.2,
  ..quotient.algebra I.val }

variables (R S)
instance tensor.finitely_generated_reduced_algebra :
  finitely_generated_reduced_algebra K (R ⊗[K] S) :=
{ finitely_generated := is_finitely_generated_tensor
  (finitely_generated K R) (finitely_generated K S),
  reduced := is_reduced_tensor (reduced K R) (reduced K S),
  ..tensor_product.algebra }

/-- For a closed subset `Z` the quotient `K[X]/I(Z)` is an algebra over `K` -/
example (Z : closeds (spectrum K R)) : algebra K (radical_ideal_of_closeds Z).val.quotient :=
infer_instance

/-- The spectrum of `K[X]/I(Z)` is Z for a closed subset `Z` -/
def spectrum_quotient (Z : closeds (spectrum K R)) :
  spectrum K (radical_ideal_of_closeds Z).val.quotient ≃ₜ Z.val :=
{ to_fun := λ x, ⟨x.comp $ algebra.quotient.mk _, omitted⟩,
  inv_fun := λ y, algebra.quotient.lift y omitted,
  left_inv := omitted,
  right_inv := omitted,
  continuous_to_fun := omitted,
  continuous_inv_fun := omitted }

variables {R S}

/-- The type of finitely generated reduced algebras over a fixed commutative ring. -/
structure FRAlgebra (R : Type u) [comm_ring R] : Type (u+1) :=
  (β : Type u)
  [ring : comm_ring β]
  [algebra : finitely_generated_reduced_algebra R β]

attribute [instance, priority 1100] FRAlgebra.ring FRAlgebra.algebra
instance (R : Type v) [comm_ring R] : has_coe_to_sort (FRAlgebra R) :=
{ S := Type v, coe := FRAlgebra.β }

/-- The category of finitely generated reduced (f.g.r.) algebras over a fixed commutative ring. -/
instance FRAlgebra.category (R : Type u) [comm_ring R] : large_category (FRAlgebra R) :=
{ hom   := λ a b, a.β →ₐ[R] b.β,
  id    := λ a, alg_hom.id R a,
  comp  := λ a b c f g, alg_hom.comp g f }

/-- Quotients in the category of f.g.r. algebras -/
def FRAlgebra.quotient (R : FRAlgebra K) (Z : closeds (spectrum K R)) : FRAlgebra K :=
⟨K, (radical_ideal_of_closeds Z).val.quotient⟩

/-- The quotient map in the category of f.g.r. algebras -/
def FRAlgebra.quotient_map (R : FRAlgebra K) (Z : closeds (spectrum K R)) :
  R ⟶ R.quotient Z :=
algebra.quotient.mk _

/-- The tensor product of two finitely generated reduced algebras over `K` -/
def FRAlgebra_tensor (R S : FRAlgebra K) : FRAlgebra K :=
{ β := R ⊗[K] S,
  ring := _,
  algebra := tensor.finitely_generated_reduced_algebra R S }

variables (K)
section
local attribute [instance, priority 1500] algebra.mv_polynomial algebra.polynomial
/-- Polynomials over `K` as an f.g.r. algebra over `K` -/
def FRAlgebra_polynomial : FRAlgebra K :=
{ β := polynomial K,
  algebra := { finitely_generated := omitted,
               reduced := omitted } }

/-- Multivariate polynomials over `K` as an f.g.r. algebra over `K` -/
def FRAlgebra_mv_polynomial (K : Type (max u v)) [discrete_field K] (σ : Type v)
  [decidable_eq σ] : FRAlgebra K :=
{ β := mv_polynomial σ K,
  algebra := { finitely_generated := omitted,
               reduced := omitted } }
end

/-- `K` forms a finitely generated reduced algebras over `K` -/
def FRAlgebra_id : FRAlgebra K := ⟨K, K⟩

example (R : FRAlgebra K) : (R ⟶ FRAlgebra_id K) = (R.β →ₐ[K] K) := by refl
example (R : FRAlgebra K) : (R ⟶ FRAlgebra_id K) = spectrum K R.β := rfl

/-- The category of finitely generated reduced algebras over `K` has binary coproducts -/
def FRAlgebra.has_binary_coproducts : limits.has_binary_coproducts (FRAlgebra K) :=
begin
  fapply limits.has_binary_coproducts.mk FRAlgebra_tensor,
  exact λ X Y, tensor_inl,
  exact λ X Y, tensor_inr,
  exact λ X Y Z, tensor_lift,
  omit_proofs
end

/-- The category of finitely generated reduced algebras over `K` has an initial object -/
def FRAlgebra.has_initial_object : limits.has_initial_object (FRAlgebra K) :=
begin
  fapply limits.has_initial_object.mk (FRAlgebra_id K),
  intro X, exact algebra.of_id K X,
  omitted
end

/-- In algebraic geometry, the categories of algebra's over `K` and affine varieties are opposite of each other. In this development we take a shortcut, and *define* affine varieties as the opposite of algebra's over K. -/
@[reducible] def affine_variety : Type* := opposite (FRAlgebra K)

example : large_category (affine_variety K) := by apply_instance

/-- The category of affine varieties has binary products -/
@[instance, priority 1200] def affine_variety.has_binary_products :
  limits.has_binary_products (affine_variety K) :=
by { haveI : limits.has_colimits_of_shape.{u} (discrete limits.two) (FRAlgebra K) :=
     FRAlgebra.has_binary_coproducts K, exact limits.has_products_opposite _ }

/-- The category of affine varieties has a terminal object -/
@[instance, priority 1200] def affine_variety.has_terminal_object :
  limits.has_terminal_object (affine_variety K) :=
by { haveI : limits.has_colimits_of_shape.{u} (discrete pempty) (FRAlgebra K) :=
     FRAlgebra.has_initial_object K, exact limits.has_products_opposite _ }

/-- The underlying type of an affine variety G = Rᵒᵖ is Spec(R), equivalently the global points
   of G in the category of affine varieties. -/
def affine_variety.type_functor : affine_variety K ⥤ Type u :=
yoneda.obj (FRAlgebra_id K)

/- to do: affine_variety.type_functor preserves finite products (is just left-exact) -/
variables {K R}

/-- The object part of the functor `affine_variety.type_functor` -/
def affine_variety.type (X : affine_variety K) : Type u :=
(affine_variety.type_functor K).obj X

/-- The type of `X` is the spectrum of `X` viewed as an object in the opposite category -/
lemma affine_variety.type_eq (X : affine_variety K) :
  affine_variety.type X = spectrum K (unop X).β := rfl

/-- We tell Lean that the Zariski topology gives a topology on the type of an affine variety -/
instance (X : affine_variety K) : topological_space X.type :=
algebraic_geometry.Zariski_topology _ _

/-- A subobject of an affine variety given by a closed set on its type -/
def affine_variety.subobject (X : affine_variety K) (Z : closeds X.type) : affine_variety K :=
op ((unop X).quotient Z)

/-- A subobject of an affine variety given by a closed set on its type -/
def affine_variety.incl (X : affine_variety K) (Z : closeds X.type) :
  X.subobject Z ⟶ X :=
(FRAlgebra.quotient_map _ _).op

/-- A subobject of an affine variety given by a closed set on its type -/
def incl_of_subset {X : affine_variety K} {Z₁ Z₂ : closeds X.type} (h : Z₁.1 ⊆ Z₂.1) :
  X.subobject Z₁ ⟶ X.subobject Z₂ :=
has_hom.hom.op (algebra.quotient.lift (algebra.quotient.mk _) omitted)

/-- Inclusion of a set on the type of a subobject into the sets on type type of `X` -/
def set_sub_incl {X : affine_variety K} {Z : closeds X.type} :
  set (X.subobject Z).type → set X.type :=
image $ (affine_variety.type_functor K).map $ X.incl Z

variable (K)
/-- An affine group is a group object in the category of affine varieties -/
abbreviation affine_group : Type* := group_object (affine_variety K)

example : category (affine_group K) := by apply_instance

end algebraic_geometry

open algebraic_geometry
variables variables {K} {G G' G₁ G₂ G₃ H : affine_group K}

/-- A morphism between affine groups induces a map between the types -/
def group_hom.type (f : G ⟶ G') : G.obj.type → G'.obj.type :=
(affine_variety.type_functor K).map f.map

namespace algebraic_geometry

-- Given an algebraic group, we get a group structure on its type
section
set_option class.instance_max_depth 80
/-- The multiplication on the type of an affine group -/
def group_type_mul (f g : G.obj.type) : G.obj.type := (tensor_lift f g).comp G.mul.unop
end

/-- The inversion on the type of an affine group -/
def group_type_inv (f : G.obj.type) : G.obj.type := f.comp G.inv.unop

/-- The unit in the type of an affine group -/
def group_type_one : G.obj.type := G.one.unop

/-- Given an algebraic group, we get a group structure on its type -/
instance group_type (G : affine_group K) : group G.obj.type :=
{ mul := group_type_mul,
  mul_assoc := omitted,
  one := group_type_one,
  one_mul := omitted,
  mul_one := omitted,
  inv := group_type_inv,
  mul_left_inv := omitted }

/-- A morphism between affine groups induces a group homomorphism between the types -/
instance (f : G ⟶ G') : is_group_hom f.type := omitted

/-- A closed subgroup of G is a subset of its type that is closed and a subgroup -/
class is_closed_subgroup (s : set G.obj.type) extends is_subgroup s : Prop :=
(closed : is_closed s)

/-- The type of `G` is a closed subgroup of itself -/
instance is_closed_subgroup_univ (G : affine_group K) :
  is_closed_subgroup (univ : set G.obj.type) :=
omitted

/-- A closed subgroup gives a closed set (by forgetting that it is a subgroup) -/
def to_closeds (s : set G.obj.type) [is_closed_subgroup s] : closeds G.obj.type :=
⟨s, is_closed_subgroup.closed s⟩

/-- The (opposite of the) multiplication on a subgroup -/
def sub_mul_op (s : set G.obj.type) [is_closed_subgroup s] : (unop G.obj).quotient (to_closeds s) ⟶
  FRAlgebra_tensor ((unop G.obj).quotient (to_closeds s)) ((unop G.obj).quotient (to_closeds s)) :=
algebra.quotient.lift
  begin
    refine alg_hom.comp _ G.mul.unop,
    exact tensor_functor (algebra.quotient.mk _) (algebra.quotient.mk _)
  end
 omitted

/-- From a closed subgroup we can construct an affine group -/
def sub (s : set G.obj.type) [is_closed_subgroup s] : affine_group K :=
{ obj := G.obj.subobject (to_closeds s),
  mul := (sub_mul_op s).op,
  mul_assoc := omitted,
  one := (show (unop G.obj).quotient (to_closeds s) ⟶ FRAlgebra_id K,
          from algebra.quotient.lift G.one.unop omitted).op,
  one_mul := omitted,
  mul_one := omitted,
  inv := (show (unop G.obj).quotient (to_closeds s) ⟶ (unop G.obj).quotient (to_closeds s),
          from algebra.quotient.functor G.inv.unop omitted).op,
  mul_left_inv := omitted }

def affine_group.incl (G : affine_group K) (s : set G.obj.type) [is_closed_subgroup s] :
  sub s ⟶ G :=
by exact ⟨affine_variety.incl _ _, omitted⟩

instance set_sub_incl.is_closed_subgroup {H : set G.obj.type} {h : is_closed_subgroup H}
  (K' : set (sub H).obj.type) [hK : is_closed_subgroup K'] : is_closed_subgroup (set_sub_incl K') :=
omitted

/-- The kernel of a morphism between affine groups is given by the preimage of 1.

More precisely, we can view `f : G ⟶ G'` as a map between the type of `G` and the type of `G'`,
and then take the preimage of `1 : type G'`, using the group structure induced on the type of `G'` -/
def kernel (f : G ⟶ G') : set G.obj.type :=
is_group_hom.ker f.type

/-- The kernel of a morphism is a closed subgroup -/
instance (f : G ⟶ G') : is_closed_subgroup (kernel f) := omitted

/-- A subset of the type of `G` is a normal subgroup if it the kernel of a morphism between
  affine groups. Any normal subgroup is automatically closed. -/
def is_normal_subgroup (s : set G.obj.type) : Prop :=
∃(G' : affine_group K) (f : G ⟶ G'), kernel f = s

/-- The structure of being a normal subgroup -/
def normal_subgroup_structure (s : set G.obj.type) : Type* :=
Σ(G' : affine_group K), {f : G ⟶ G' // kernel f = s }

/-- An affine group `G` is solvable if it is abelian or inductively if there is a morphism
  `ψ : G ⟶ H` such that both `ker(ψ)` and `H` are solvable. -/
-- For some reason this inductive type is very slow to compile if we make this into a `Type`,
-- probably, during the definition of auxilliary declarations. For now, let's have it a Prop,
-- we can turn it into a type later
inductive solvable : affine_group K → Prop
| base {{G : affine_group K}} : G.is_abelian → solvable G
| step {{G H : affine_group K}} (ψ : G ⟶ H) :
  solvable H → solvable (sub (kernel ψ)) → solvable G

/-- A Borel subgroup is a maximal closed connected solvable subgroup of `G` -/
def is_Borel_subgroup (s : set G.obj.type) : Prop :=
is_maximal { t : set G.obj.type |
  ∃(h : is_closed_subgroup t), is_connected t ∧ by exactI solvable (sub t) } s

/-- There is a unique maximal closed subgroup of `G` that is a kernel of a morphism `ψ : G ⟶ A`
  for an abelian group `A` -/
theorem closed_derived_subgroup_unique (H : set G.obj.type) [is_closed_subgroup H] :
  ∃!(s : set G.obj.type), is_maximal { t : set G.obj.type |
    ∃(A : affine_group K) (ψ : sub H ⟶ A), A.is_abelian ∧ t = set_sub_incl (kernel ψ) } s :=
omitted

/-- The closed derived subgroup of `H` is the unique maximal subgroup of `H` that is a kernel of a
  morphism `ψ : H ⟶ A` for an abelian group `A` -/
def closed_derived_subgroup (H : set G.obj.type) [is_closed_subgroup H] : set G.obj.type :=
classical.the _ (closed_derived_subgroup_unique H)

/-- The closed derived subgroup is a closed subgroup -/
instance closed_derived_subgroup.is_closed_subgroup (H : set G.obj.type) [is_closed_subgroup H] :
  is_closed_subgroup (closed_derived_subgroup H) :=
omitted

open category_theory.limits category_theory.limits.binary_product
local infix ` × `:60 := binary_product
local infix ` ×.map `:90 := binary_product.map

/-- The conjugation map `H₁ × H₂ ⟶ G` given by `(h₁,h₂) ↦ h₁*h₂*h₁⁻¹`-/
def conjugation (H₁ H₂ : set G.obj.type) [is_closed_subgroup H₁] [is_closed_subgroup H₂] :
  (sub H₁).obj × (sub H₂).obj ⟶ G.obj :=
((G.incl H₁).map ≫ diag) ×.map (G.incl H₂).map ≫
product_assoc.hom ≫ 𝟙 G.obj ×.map (product_comm.hom ≫ G.mul) ≫ G.mul
/- The following more explicit definition is hard on the elaborator;
  Probably because of type-class inference for `×` -/
-- calc
--   H₁ × H₂ ⟶ (G × G) × G : ((G.incl H₁).map ≫ diag) ×.map (G.incl H₂).map
--       ... ⟶ G × (G × G) : product_assoc.hom
--       ... ⟶ G × G       : 𝟙 G.obj ×.map (product_comm.hom ≫ G.mul)
--       ... ⟶ G           : G.mul

/-- `C` centralizes `H` if `C × H ⟶ G` given by `(c,h) ↦ c*h*c⁻¹` is equal to the inclusion
`H ⟶ G`. -/
def centralizes (C H : set G.obj.type) [is_closed_subgroup C] [is_closed_subgroup H] : Prop :=
conjugation C H = π₂ ≫ (G.incl H).map

/-- There is a unique maximal closed subgroup of `G` that centralizes `H` -/
theorem centralizer_unique (H : set G.obj.type) [is_closed_subgroup H] :
  ∃!(C : set G.obj.type), is_maximal { C' : set G.obj.type |
    ∃(h : is_closed_subgroup C'), by exactI centralizes C' H } C :=
omitted

/-- The centralizer of `H` is the unique maximal closed subgroup of `G` that centralizes `H` -/
def centralizer (H : set G.obj.type) [is_closed_subgroup H] : set G.obj.type :=
classical.the _ (centralizer_unique H)

/-- The centralizer is a closed subgroup -/
instance centralizer.is_closed_subgroup (H : set G.obj.type) {h : is_closed_subgroup H} :
  is_closed_subgroup (centralizer H) :=
let ⟨h, _⟩ := (classical.the_spec (centralizer_unique H)).1 in h

/-- The center of `G` is the centralizer of `G` as closed subgroup of `G` -/
def center (G : affine_group K) : set G.obj.type :=
centralizer set.univ

/-- `N` normalizes `H` if the conjugation map `N × H ⟶ G` factors through `H` -/
-- this is a slightly different formulation than in the notes
def normalizes (N H : set G.obj.type) [is_closed_subgroup N] [is_closed_subgroup H] : Prop :=
--factors_through (conjugation N H) (G.incl H).map
∃(f : (sub N).obj × (sub H).obj ⟶ (sub H).obj), conjugation N H = f ≫ (G.incl H).map

/-- If `N` normalizes `H` then `N` acts on `H` by conjucation -/
def conjugation_action {N H : set G.obj.type} [is_closed_subgroup N] [is_closed_subgroup H]
  (h : normalizes N H) : group_action (sub N) (sub H).obj :=
classical.take_arbitrary_such_that (λ f, ⟨f, omitted, omitted⟩) h omitted

/-- An affine group is almost simple if it has no proper normal closed connected subgroup.
  Note: by our definition, every normal subgroup is automatically closed -/
def almost_simple (G : affine_group K) : Prop :=
¬∃(T : set G.obj.type), T ≠ set.univ ∧ is_normal_subgroup T ∧ is_connected T

/-- The type of a almost simple affine group is connected -/
lemma connected_space_of_almost_simple : almost_simple G → connected_space G.obj.type :=
omitted

end algebraic_geometry


/-
Copyright (c) 2017 Daniel Selsam. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Daniel Selsam

Tactics to prove specific models satisfy the preconditions of backprop_correct.
-/
import data.list.set .tfacts .graph .predicates .expected_value .reparam .kl .tactics .program .mvn .tactics

#print "compiling prove_model_ok..."

namespace certigrad
open T tactic list

lemma mem_of_ne_mem_cons {α : Type*} {xs : list α} {x y : α} : x ∈ y :: xs → x ≠ y → x ∈ xs :=
begin
intros H_in H_neq,
dunfold has_mem.mem list.mem at H_in,
cases H_in with H_eq H_in,
exfalso, exact H_neq H_eq, exact H_in
end

@[cgsimp] lemma true_of_not_false : (¬ false) = true :=
begin apply propext, split, intro H, exact trivial, intros Ht Hf, exact Hf end

@[cgsimp] lemma label_of (x y : label) : (ID.str x = ID.str y) = (x = y) :=
begin apply propext, split, intro H, injection H, intro H, rw H end

@[cgsimp] lemma eq_of_self_eq {α : Type*} (x : α) : (x = x) = true := propext (eq_self_iff_true _)

@[cgsimp] lemma and_true_left {P : Prop} : (true ∧ P) = P := propext (true_and _)
@[cgsimp] lemma and_true_right {P : Prop} : (P ∧ true) = P := propext (and_true _)
@[cgsimp] lemma and_false_left {P : Prop} : (false ∧ P) = false := propext (false_and _)
@[cgsimp] lemma and_false_right {P : Prop} : (P ∧ false) = false := propext (and_false _)

@[cgsimp] lemma or_false_left {P : Prop} : (false ∨ P) = P := propext (false_or _)
@[cgsimp] lemma or_false_right {P : Prop} : (P ∨ false) = P := propext (or_false _)
@[cgsimp] lemma or_true_left {P : Prop} : (true ∨ P) = true := propext (true_or _)
@[cgsimp] lemma or_true_right {P : Prop} : (P ∨ true) = true := propext (or_true _)

@[cgsimp] lemma true_of_imp_true {α : Sort*} : (α → true) = true := propext (iff.intro (λ H, trivial) (λ H x, trivial))

@[cgsimp] lemma simp_nodup_nil {α : Type*} : @list.nodup α [] = true := pextt list.nodup_nil

@[cgsimp] lemma simp_nodup_singleton {α : Type*} (a : α) : list.nodup [a] = true := pextt (list.nodup_singleton _)
@[cgsimp] lemma simp_nodup_cons {α : Type*} {a : α} {l : list α} (H : a ∉ l) : list.nodup (a::l) = list.nodup l :=
begin apply propext, split, intro H', cases H' with H1 H2 H3 H4, exact H4, apply list.nodup_cons, exact H end

@[cgsimp] lemma false_imp {P : Prop} : (false → P) = true :=
begin apply propext, split, intro H, exact trivial, intros Ht Hf, exfalso, exact Hf end
@[cgsimp] lemma true_imp {P : Prop} : (true → P) = P :=
begin apply propext, split, intro H, exact H trivial, intros H Ht, exact H end

@[cgsimp] lemma simp_mem_nil {α : Type*} (x : α) : (x ∈ @list.nil α) = false :=
begin apply pextf, apply list.not_mem_nil end

@[cgsimp] lemma simp_mem_cons_neq {α : Type*} (x y : α) (xs : list α) : x ≠ y → (x ∈ y :: xs) = (x ∈ xs) :=
begin intro H_neq, apply propext, split, intro H_in, exact mem_of_ne_mem_cons H_in H_neq, intro H_in, exact or.inr H_in end

@[cgsimp] lemma simp_mem_cons_eq {α : Type*} (x y : α) (xs : list α) : x = y → (x ∈ y :: xs) = true :=
begin intro H_eq, apply pextt, dunfold has_mem.mem list.mem, left, exact H_eq end

@[cgsimp] lemma simp_nmem_nil {α : Type*} (x : α) : (x ∉ @list.nil α) = true :=
begin apply pextt, apply list.not_mem_nil end

@[cgsimp] lemma simp_nmem_cons_eq {α : Type*} (x y : α) (xs : list α) : x ≠ y → (x ∉ y :: xs) = (x ∉ xs) :=
begin intro H_neq, apply propext, split, intros H_nin H_in, exact H_nin (or.inr H_in),
intros H_nin H_in, exact H_nin (mem_of_ne_mem_cons H_in H_neq)
end

@[cgsimp] lemma simp_nmem_cons_neq {α : Type*} (x y : α) (xs : list α) : x = y → (x ∉ y :: xs) = false :=
begin intro H_eq, apply pextf, intro H, exact H (or.inl H_eq) end

@[cgsimp] lemma false_of_cons_eq_nil {α : Type*} {x : α} {xs : list α} : (list.cons x xs = list.nil) = false :=
begin apply pextf, intro H, injection H end

@[cgsimp] lemma simp_at_idx_nil {α : Type*} [inhabited α] (x : α) (idx : ℕ) : list.at_idx list.nil idx x = false :=
begin
apply pextf,
intro H,
dunfold list.at_idx at H,
cases H with H1 H2,
exact (nat.not_lt_zero idx) H1
end

@[cgsimp] lemma simp_at_idx_0 {α : Type*} [inhabited α] {x : α} {xs : list α} : list.at_idx (x::xs) 0 x = true :=
begin apply pextt, apply list.at_idx_0 end

@[cgsimp] lemma simp_at_idx_cons {α : Type*} [inhabited α] {x : α} {xs : list α} {y : α} {idx : ℕ} :
  list.at_idx (x::xs) (idx+1) y = list.at_idx xs idx y :=
begin
apply propext,
split,
apply list.at_idx_of_cons,
apply list.at_idx_cons
end

@[cgsimp] lemma of_in_list_forall_cons {α : Type*} (ys : list α) (P : α → Prop) (y : α) : (∀ x, x ∈ list.cons y ys → P x) = (P y ∧ (∀ x, x ∈ ys → P x)) :=
begin
apply propext,
split,
intro H,
{ split, exact H y list.mem_of_cons_same, intros x H_in, exact H x (or.inr H_in) },
{
intro H, cases H with HPy H, intros x H_in,
cases classical.em (x = y) with H_eq H_neq,
rw H_eq, exact HPy,
exact H x (mem_of_ne_mem_cons H_in H_neq)
}
end

@[cgsimp] lemma of_in_list_forall_nil {α : Type*} (P : α → Prop) (y : α) : (∀ (x : α), x ∈  @list.nil α → P x) = true :=
begin
apply pextt,
intros x H_in_nil,
exfalso,
exact (list.not_mem_nil _) H_in_nil
end

@[cgsimp] lemma of_in_list_cons_neq {α : Type*} {P : Prop} (ys : list α) (x y : α) : x ≠ y → (x ∈ list.cons y ys → P) = (x ∈ ys → P) :=
begin
intro H_neq,
apply propext,
split,
intro H,
intro H_in,
apply H,
exact or.inr H_in,
intro H,
intro H_in,
apply H,
exact mem_of_ne_mem_cons H_in H_neq
end

@[cgsimp] lemma of_in_list_cons_eq {α : Type*} {P : Prop} (ys : list α) (x y : α) : x = y → (x ∈ list.cons y ys → P) = P :=
begin
intro H_eq,
apply propext,
split,
intro H_in,
exact H_in (or.inl H_eq),
intros HP H_in,
exact HP
end

@[cgsimp] lemma simp_sublist_cons {α : Type*} (xs : list α) (x : α) : (xs <+ x :: xs) = true :=
begin
apply pextt,
apply list.sublist_cons
end

@[cgsimp] lemma simp_sqrt_pos {shape : S} {x : T shape}: (0 < sqrt x) = (0 < x) :=
begin apply propext, split, apply pos_of_sqrt_pos, apply sqrt_pos end

@[cgsimp] lemma simp_exp_pos {shape : S} {x : T shape} : (0 < exp x) = true :=
begin apply pextt, apply exp_pos end

@[cgsimp] lemma simp_integrable_const (shape₁ shape₂ : S) (y : T shape₂) : is_integrable (λ (x : T shape₁), y) = true :=
begin apply pextt, apply is_integrable_const end

@[cgsimp] lemma simp_nneg_of_pos {shape : S} {x : T shape} : x ≠ 0 = (0 < x ∨ x < 0) :=
begin apply propext, apply nz_iff end

@[cgsimp] lemma simp_one_pos {shape : S} : (0 < (1 : T shape)) = true := pextt one_pos

@[cgsimp] lemma simp_sigmoid_pos {shape : S} {x : T shape} : (0 < sigmoid x) = true := pextt sigmoid_pos
@[cgsimp] lemma simp_sigmoid_lt1 {shape : S} {x : T shape} : (sigmoid x < 1) = true := pextt sigmoid_lt1

-- TODO(dhs): weird lemma
@[cgsimp] lemma simp_one_plus_pos {shape : S} {x : T shape} : 0 < 1 + x = (0 < x ∨ - 1 < x) :=
begin
apply propext,
split,
intro H,
right, exact iff.mp one_plus_pos_iff H,
intro H,
cases H with H H,
apply one_plus_pos,
exact H,
exact iff.mpr one_plus_pos_iff H
end

@[cgsimp] lemma simp_has_key_insert_same (ref : reference) {x : T ref.2} (m : env) :
  env.has_key ref (env.insert ref x m) = true := pextt (by apply env.has_key_insert_same)

@[cgsimp] lemma simp_has_key_insert_diff (ref₁ ref₂ : reference) {x : T ref₂.2} (m : env) :
  ref₁ ≠ ref₂ → env.has_key ref₁ (env.insert ref₂ x m) = env.has_key ref₁ m :=
begin
intro H_neq,
apply propext,
split,
apply env.has_key_insert_diff,
exact H_neq,
apply env.has_key_insert
end

@[cgsimp] lemma simp_has_key_empty (ref : reference) : env.has_key ref env.mk = false :=
begin apply pextf, apply env.not_has_key_empty end

def is_not_used_downstream (tgt : reference) : list node → Prop
| [] := true
| (⟨ref, parents, op⟩ :: nodes) := tgt ∉ parents ∧ is_not_used_downstream nodes

def is_used_downstream (tgt : reference) : list node → Prop
| [] := false
| (⟨ref, parents, op⟩ :: nodes) := tgt ∈ parents ∨ is_used_downstream nodes

attribute [cgsimp] is_not_used_downstream is_used_downstream

lemma costs_helper : Π (costs : list ID) (tgt : reference) (m : env),
  tgt.1 ∉ costs → compute_grad_slow costs [] m tgt = 0
| []      tgt m H_nin := rfl
| (c::cs) tgt m H_nin :=
begin
dunfold compute_grad_slow,
assert H : (tgt ≠ (c, [])),
{
cases tgt with tgt_1 tgt_2,
dsimp at H_nin,
apply pair_neq_of_neq₁,
exact list.ne_of_not_mem_cons H_nin
},
simph,
dunfold list.sumr,
rw zero_add,
exact costs_helper cs tgt m (list.not_mem_of_not_mem_cons H_nin)
end

lemma compute_grad_slow_det_not_used_helper (costs : list ID) : Π (nodes : list node) (m : env) (tgt : reference),
is_not_used_downstream tgt nodes → tgt.1 ∉ costs →
compute_grad_slow costs nodes m tgt = 0
| [] m tgt H_not_used H_tgt_nin_costs :=
begin
apply costs_helper, all_goals { assumption }
end

| (⟨ref, parents, operator.det op⟩::nodes) m tgt H_not_used H_tgt_nin_costs :=
begin
dunfold compute_grad_slow,
dunfold is_not_used_downstream at H_not_used,
rw compute_grad_slow_det_not_used_helper nodes _ tgt H_not_used^.right H_tgt_nin_costs,
rw zero_add,
rw list.not_in_filter_of_match_riota,
reflexivity,
exact H_not_used^.left
end

| (⟨ref, parents, operator.rand op⟩::nodes) m tgt H_not_used H_tgt_nin_costs :=
begin
dunfold compute_grad_slow,
dunfold is_not_used_downstream at H_not_used,
rw compute_grad_slow_det_not_used_helper,
rw zero_add,
rw list.not_in_filter_of_match_riota,
reflexivity,
exact H_not_used^.left,
exact H_not_used^.right,
exact H_tgt_nin_costs
end

@[cgsimp] lemma compute_grad_slow_det_not_used (costs : list ID) (ref : reference) (parents : list reference) (op : det.op parents^.p2 ref^.2)
  : Π (nodes : list node) (m : env) (tgt : reference),
is_not_used_downstream tgt nodes → tgt.1 ∉ costs →
compute_grad_slow costs (⟨ref, parents, operator.det op⟩ :: nodes) m tgt
=
list.sumr (list.map (λ (idx : ℕ), op^.pb (env.get_ks parents m)
                                        (env.get ref m)
                                        (compute_grad_slow costs nodes m ref)
                                        idx
                                        tgt.2)
                    (list.filter (λ idx, tgt = list.dnth parents idx) (list.riota $ list.length parents))) :=
begin
intros nodes m tgt H_not_used H_tgt_nin_costs,
dunfold_occs compute_grad_slow [1],
rw [compute_grad_slow_det_not_used_helper _ _ _ _ H_not_used H_tgt_nin_costs, zero_add]
end

@[cgsimp] lemma compute_grad_slow_det_used (costs : list ID) (ref : reference) (parents : list reference) (op : det.op parents^.p2 ref^.2)
  : Π (nodes : list node) (m : env) (tgt : reference),
is_used_downstream tgt nodes ∨ tgt.1 ∈ costs →
compute_grad_slow costs (⟨ref, parents, operator.det op⟩ :: nodes) m tgt
=
compute_grad_slow costs nodes m tgt +
list.sumr (list.map (λ (idx : ℕ), op^.pb (env.get_ks parents m)
                                        (env.get ref m)
                                        (compute_grad_slow costs nodes m ref)
                                        idx
                                        tgt.2)
                    (list.filter (λ idx, tgt = list.dnth parents idx) (list.riota $ list.length parents))) :=
begin
intros nodes m tgt H_is_used_or_cost,
reflexivity
end

@[cgsimp] lemma compute_grad_slow_rand_not_used (costs : list ID) (ref : reference) (parents : list reference) (op : rand.op parents^.p2 ref^.2)
  : Π (nodes : list node) (m : env) (tgt : reference),
is_not_used_downstream tgt nodes → tgt.1 ∉ costs →
compute_grad_slow costs (⟨ref, parents, operator.rand op⟩ :: nodes) m tgt
=
list.sumr (list.map (λ (idx : ℕ), sum_downstream_costs nodes costs ref m ⬝ op^.glogpdf (env.get_ks parents m) (env.get ref m) idx tgt.2)
                   (list.filter (λ idx, tgt = list.dnth parents idx) (list.riota $ list.length parents))) :=
begin
intros nodes m tgt H_not_used H_tgt_nin_costs,
dunfold_occs compute_grad_slow [1],
rw [compute_grad_slow_det_not_used_helper _ _ _ _ H_not_used H_tgt_nin_costs, zero_add]
end

@[cgsimp] lemma compute_grad_slow_rand_used (costs : list ID) (ref : reference) (parents : list reference) (op : rand.op parents^.p2 ref^.2)
  : Π (nodes : list node) (m : env) (tgt : reference),
is_used_downstream tgt nodes ∨ tgt.1 ∈ costs →
compute_grad_slow costs (⟨ref, parents, operator.rand op⟩ :: nodes) m tgt
=
compute_grad_slow costs nodes m tgt +
list.sumr (list.map (λ (idx : ℕ), sum_downstream_costs nodes costs ref m ⬝ op^.glogpdf (env.get_ks parents m) (env.get ref m) idx tgt.2)
                   (list.filter (λ idx, tgt = list.dnth parents idx) (list.riota $ list.length parents))) :=
begin
intros nodes m tgt H_used_or_cost,
reflexivity
end

attribute [cgsimp] compute_grad_slow.equations._eqn_1

lemma grads_exist_at_simp_helper : Π (nodes : list node) (m : env) (tgt : reference),
  is_not_used_downstream tgt nodes → grads_exist_at nodes m tgt
| [] m tgt H_not_used := trivial

| (⟨ref, parents, operator.det op⟩::nodes) m tgt H_not_used :=
begin
dunfold grads_exist_at,
dunfold is_not_used_downstream at H_not_used,
dsimp,
split,
apply grads_exist_at_simp_helper nodes _ tgt H_not_used^.right,
intro H_in_parents,
exfalso,
exact H_not_used^.left H_in_parents
end

| (⟨ref, parents, operator.rand op⟩::nodes) m tgt H_not_used :=
begin
dunfold grads_exist_at,
dunfold is_not_used_downstream at H_not_used,
dsimp,
split,
intro H_in_parents,
exfalso,
exact H_not_used^.left H_in_parents,
intro y,
apply grads_exist_at_simp_helper nodes _ tgt H_not_used^.right
end

@[cgsimp] lemma grads_exist_at_det_not_used (ref : reference) (parents : list reference) (op : det.op parents^.p2 ref^.2)
  : Π (nodes : list node) (m : env) (tgt : reference),
is_not_used_downstream tgt nodes →
grads_exist_at (⟨ref, parents, operator.det op⟩ :: nodes) m tgt
=
let m' := env.insert ref (op^.f (env.get_ks parents m)) m in
(tgt ∈ parents → op^.pre (env.get_ks parents m) ∧ grads_exist_at nodes (env.insert ref (op^.f (env.get_ks parents m)) m) ref) :=
begin
intros nodes m tgt H_not_used,
dunfold grads_exist_at,
dsimp,
rw (pextt (grads_exist_at_simp_helper _ _ _ H_not_used)),
simp
end

@[cgsimp] lemma grads_exist_at_det_used (ref : reference) (parents : list reference) (op : det.op parents^.p2 ref^.2)
  : Π (nodes : list node) (m : env) (tgt : reference),
is_used_downstream tgt nodes →
grads_exist_at (⟨ref, parents, operator.det op⟩ :: nodes) m tgt
=
let m' := env.insert ref (op^.f (env.get_ks parents m)) m in
grads_exist_at nodes m' tgt ∧
(tgt ∈ parents → op^.pre (env.get_ks parents m) ∧ grads_exist_at nodes (env.insert ref (op^.f (env.get_ks parents m)) m) ref) :=
begin
intros nodes m tgt H, reflexivity
end

attribute [cgsimp] grads_exist_at.equations._eqn_1 grads_exist_at.equations._eqn_3

attribute [cgsimp] all_pdfs_std can_diff_under_ints_pdfs_std

attribute [cgsimp] T.smul_zero T.one_smul

attribute [cgsimp] if_pos if_neg if_true if_false

attribute [cgsimp] dif_pos dif_neg dif_ctx_simp_congr

attribute [cgsimp] mvn_mvn_empirical_kl_int mvn_bernoulli_neglogpdf_int

attribute [cgsimp] force_ok

attribute [cgsimp] list.sumr list.map list.concat list.head list.tail list.riota list.filter list.length list.dnth
                   list.sublist.refl list.nil_subset list.sublist_cons list.cons_append list.append_nil list.nil_append
                   list.p1 list.p2

attribute [cgsimp] hash_map.find_insert_eq hash_map.find_insert_ne

attribute [cgsimp] zero_add add_zero

attribute [cgsimp] dvec.head dvec.head2 dvec.head3

attribute [cgsimp] integrate_kl integrate_mvn_kl integrate_kl_pre integrate_mvn_kl_pre reparameterize
attribute [cgsimp] reparam reparameterize reparameterize_pre

attribute [cgsimp] all_parents_in_env all_costs_scalars /- grads_exist_at -/ pdfs_exist_at uniq_ids
                   is_gintegrable is_nabla_gintegrable is_gdifferentiable /- can_differentiate_under_integrals -/

attribute [cgsimp] graph.to_dist operator.to_dist sum_costs /- compute_grad_slow -/

attribute [cgsimp] E.E_bind E.E_ret

attribute [cgsimp] ops.neg ops.exp ops.log ops.sqrt ops.add ops.sub ops.mul ops.div ops.sum
                   ops.gemm ops.sigmoid ops.softplus ops.scale ops.mul_add ops.mvn_kl ops.bernoulli_neglogpdf

attribute [cgsimp] det.op.f ops.neg.f ops.exp.f ops.log.f ops.sqrt.f ops.add.f ops.sub.f ops.mul.f ops.div.f ops.sum.f
                   ops.gemm.f ops.sigmoid.f ops.softplus.f ops.scale.f ops.mul_add.f ops.mvn_kl.f ops.bernoulli_neglogpdf.f

attribute [cgsimp] det.op.pre ops.neg.f_pre ops.exp.f_pre ops.log.f_pre ops.sqrt.f_pre ops.add.f_pre ops.sub.f_pre ops.mul.f_pre ops.div.f_pre ops.sum.f_pre
                   ops.gemm.f_pre ops.sigmoid.f_pre ops.softplus.f_pre ops.scale.f_pre ops.mul_add.f_pre ops.mvn_kl.f_pre ops.bernoulli_neglogpdf.f_pre

attribute [cgsimp] det.op.pb ops.neg.f_pb ops.exp.f_pb ops.log.f_pb ops.sqrt.f_pb ops.add.f_pb ops.sub.f_pb ops.mul.f_pb ops.div.f_pb ops.sum.f_pb
                   ops.gemm.f_pb ops.sigmoid.f_pb ops.softplus.f_pb ops.scale.f_pb ops.mul_add.f_pb ops.mvn_kl.f_pb ops.bernoulli_neglogpdf.f_pb

attribute [cgsimp] det.op.is_odiff det.op.pb_correct det.op.is_ocont

attribute [cgsimp] rand.op.pdf rand.pdf.mvn rand.pdf.mvn_std
                   rand.op.pre rand.op.mvn rand.op.mvn_std rand.pre.mvn rand.pre.mvn_std

attribute [cgsimp] env.get_ks env.insert_all env.get_insert_same env.get_insert_diff

attribute [cgsimp] list.insertion_sort list.ordered_insert

attribute [cgsimp] program_to_graph program.program_to_graph_core program.get_id
--                  program.unary_to_cwise1 program.binary_to_cwise2
                  program.process_term program.empty_state program.process_rterm
                  program_to_graph._match_1
                  program.program_to_graph_core._match_1
                  program.program_to_graph_core._match_2
                  program.process_rterm._match_1
                  program.process_term._match_6
                  program.process_term._match_10
                  program.process_term._match_13
--                  program.process_term._match_16
--                  program.process_term._match_17
                  program.exp program.log program.sqrt program.softplus program.sigmoid

@[cgsimp] lemma lift_t_label_to_term (x : label) : (lift_t x : program.term) = (program.term.id x) := rfl

namespace tactic
open tactic

run_cmd mk_simp_attr `pcgsimp

attribute [pcgsimp] to_dist_congr_insert

meta def dcgsimp : tactic unit := do
  s ← join_user_simp_lemmas tt [`cgsimp],
  dsimp_core s

meta def gsimpt_core : Π (tac : tactic unit) (s_pre s_post : simp_lemmas) (e : expr), tactic (expr × expr) := λ tac s_pre s_post e,
do (a, new_tgt, pf) ← ext_simplify_core () {} s_post

(λ u, failed)
--pre
--(λ a s r p e, failed)
(λ a s r p e, do ⟨u, new_e, pr⟩ ← conv.apply_lemmas_core reducible s_pre tac r e,
                 return ((), new_e, pr, tt))

--post
(λ a s r p e, do ⟨u, new_e, pr⟩ ← conv.apply_lemmas_core reducible s tac r e,
                 return ((), new_e, pr, tt))
`eq e,

  return (new_tgt, pf)

meta def gsimpt (tac : tactic unit) : tactic unit := do
  s_pre ← join_user_simp_lemmas tt [`pcgsimp],
  s_post ← join_user_simp_lemmas tt [`cgsimp],
  tgt ← target,
  (new_tgt, pf) ← gsimpt_core tac s_pre s_post tgt,
  replace_target new_tgt pf

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

run_cmd mk_simp_attr `idne

attribute [idne] id_str_ne_nat id_nat_ne_str id_str_ne_str id_nat_ne_nat label.neq_of_to_nat label.to_nat

meta def prove_ids_neq : tactic unit :=
do s ← join_user_simp_lemmas tt [`idne, `natne],
   tgt ← target,
   (new_tgt, pf) ← simplify s tgt,
   replace_target new_tgt pf

meta def prove_refs_neq : tactic unit :=
do applyc `pair_neq_of_neq₁, prove_ids_neq

meta def cgsimpt (tac : tactic unit) : tactic unit := do
  repeat $ first [gsimpt tac, prove_refs_neq, prove_ids_neq, triv]

meta def cgsimpn : ℕ → tactic unit
| 0 := cgsimpt skip
| (n+1) := cgsimpt (cgsimpn n)

meta def cgsimp : tactic unit := cgsimpn 100

meta def forall_idxs (tac_base tac_step : tactic unit) : expr → tactic unit
| idx :=
tac_base <|>
(do cases idx [`_idx],
    solve1 tac_step,
    get_local `_idx >>= forall_idxs)

meta def prove_model_base : tactic unit :=
do exfalso,
   H_at_idx ← get_local `H_at_idx,
to_expr ```(list.at_idx_over %%H_at_idx dec_trivial) >>= exact

meta def prove_model_step : tactic unit :=
do H_at_idx ← get_local `H_at_idx,
   mk_app `and.right [H_at_idx] >>= note `H_tgt_eq,
   H_tgt_eq_type ← get_local `H_tgt_eq >>= infer_type,
   s ← join_user_simp_lemmas true [`cgsimp],
   (H_tgt_eq_new_type, pr) ← simplify s H_tgt_eq_type {},
   get_local `H_tgt_eq >>= λ H_tgt_eq, replace_hyp H_tgt_eq H_tgt_eq_new_type pr,
   get_local `H_tgt_eq >>= subst,
   applyc `certigrad.backprop_correct,
   trace "nodup tgts nodes",
     solve1 cgsimp,
   trace "at_idx...",
     solve1 cgsimp,
   trace "well_formed_at...",
     solve1 (constructor >> all_goals cgsimp),
   trace "grads_exist_at...",
     solve1 (cgsimp),
   trace "pdfs_exist_at...",
     solve1 (cgsimp),
   trace "is_gintegrable...",
     solve1 (cgsimp >> prove_is_mvn_integrable),
   trace "can_diff_under_ints...",
     solve1 (applyc `certigrad.can_diff_under_ints_of_all_pdfs_std >> cgsimp >> prove_is_mvn_uintegrable),
   trace "prove_for_tgt done"

meta def prove_model_ok : tactic unit :=
do -- unfold lets
   whnf_target,
   -- introduce hypotheses
   [tgt, idx, H_at_idx] ← intros | fail "can't intro hyps",
   -- repeated case-analysis on idx
   -- TODO(dhs): async would be great but I run out of memory
   forall_idxs prove_model_base prove_model_step idx

end tactic
end certigrad


--

-- no indentation on top-level `by` is still allowed
theorem byTopLevelNoIndent (n : Nat) (h : n > 1) : n > 1 := by
exact h

#print byTopLevelNoIndent

--
theorem byNestedStrictIndent (n : Nat) (h : n > 0) : n > 1 := by
  have helper : n > 1 := by
  sorry -- expected '{' or strict indentation
  sorry

--
theorem byNestedBad₁ (n : Nat) (h : n > 0) : n > 1 := by
  have helper : n > 1 := by
    sorry
   sorry -- expected command
  sorry

theorem byNestedBad₂ (n : Nat) (h : n > 0) : n > 1 := by
  have helper : n > 1 := by
    sorry
      sorry -- expected command
  sorry


inductive KrivineInstruction
  | Access (n: Nat)
  | Grab (next: KrivineInstruction)
  | Push (next: KrivineInstruction) (continuation: KrivineInstruction)

inductive KrivineClosure
  | pair (i: KrivineInstruction) (e: List KrivineClosure)

namespace Ex1

def KrivineEnv := List KrivineClosure

-- We need to define a `SizeOf` instance for `KrivineEnv`. Otherwise, we cannot use the auto-generated well-founded relation in
-- recursive definitions.
noncomputable instance : SizeOf KrivineEnv := inferInstanceAs (SizeOf (List KrivineClosure))
-- We also need a `simp` theorem
@[simp] theorem KrivineEnv.sizeOf_spec (env : KrivineEnv) : sizeOf env = sizeOf (α := List KrivineClosure) env := rfl

-- It would be great to have a `deriving SizeOf` for definitions such as `KrivineEnv` above.

def KrivineEnv.depth (env : KrivineEnv) : Nat :=
  match env with
  | [] => 0
  | KrivineClosure.pair u e :: closures => Nat.max (1 + depth e) (depth closures)

end Ex1

namespace Ex2
-- Same example, but we use `abbrev` to define `KrivineEnv`. Thus, we inherit the `SizeOf` instance for `List`s.

abbrev KrivineEnv := List KrivineClosure

def KrivineEnv.depth (env : KrivineEnv) : Nat :=
  match env with
  | [] => 0
  | KrivineClosure.pair u e :: closures => Nat.max (1 + depth e) (depth closures)

end Ex2

namespace Ex3
-- Same example, but using `structure` instead of `def`

structure KrivineEnv where
  env : List KrivineClosure

def KrivineEnv.depth (env : KrivineEnv) : Nat :=
  match env with
  | { env := [] } => 0
  | { env := KrivineClosure.pair u e :: closures } => Nat.max (1 + depth { env := e }) (depth { env := closures })

end Ex3


/-
Copyright (c) 2015 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Leonardo de Moura

Quotient types.
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.data.sigma.basic
import Mathlib.Lean3Lib.init.logic
import Mathlib.Lean3Lib.init.propext
import Mathlib.Lean3Lib.init.data.setoid

universes u v u_a u_b u_c

namespace Mathlib

/- We import propext here, otherwise we would need a quot.lift for propositions. -/

-- iff can now be used to do substitutions in a calculation

theorem iff_subst {a : Prop} {b : Prop} {p : Prop → Prop} (h₁ : a ↔ b) (h₂ : p a) : p b :=
  propext h₁ ▸ h₂

namespace quot

axiom sound {α : Sort u} {r : α → α → Prop} {a : α} {b : α} : r a b → Quot.mk r a = Quot.mk r b

protected theorem lift_beta {α : Sort u} {r : α → α → Prop} {β : Sort v} (f : α → β)
    (c : ∀ (a b : α), r a b → f a = f b) (a : α) : Quot.lift f c (Quot.mk r a) = f a :=
  rfl

protected theorem ind_beta {α : Sort u} {r : α → α → Prop} {β : Quot r → Prop}
    (p : ∀ (a : α), β (Quot.mk r a)) (a : α) : Quot.ind p (Quot.mk r a) = p a :=
  rfl

protected def lift_on {α : Sort u} {β : Sort v} {r : α → α → Prop} (q : Quot r) (f : α → β)
    (c : ∀ (a b : α), r a b → f a = f b) : β :=
  Quot.lift f c q

protected theorem induction_on {α : Sort u} {r : α → α → Prop} {β : Quot r → Prop} (q : Quot r)
    (h : ∀ (a : α), β (Quot.mk r a)) : β q :=
  Quot.ind h q

theorem exists_rep {α : Sort u} {r : α → α → Prop} (q : Quot r) : ∃ (a : α), Quot.mk r a = q :=
  quot.induction_on q fun (a : α) => Exists.intro a rfl

protected def indep {α : Sort u} {r : α → α → Prop} {β : Quot r → Sort v}
    (f : (a : α) → β (Quot.mk r a)) (a : α) : psigma β :=
  psigma.mk (Quot.mk r a) (f a)

protected theorem indep_coherent {α : Sort u} {r : α → α → Prop} {β : Quot r → Sort v}
    (f : (a : α) → β (Quot.mk r a)) (h : ∀ (a b : α) (p : r a b), Eq._oldrec (f a) (sound p) = f b)
    (a : α) (b : α) : r a b → quot.indep f a = quot.indep f b :=
  fun (e : r a b) => psigma.eq (sound e) (h a b e)

protected theorem lift_indep_pr1 {α : Sort u} {r : α → α → Prop} {β : Quot r → Sort v}
    (f : (a : α) → β (Quot.mk r a)) (h : ∀ (a b : α) (p : r a b), Eq._oldrec (f a) (sound p) = f b)
    (q : Quot r) : psigma.fst (Quot.lift (quot.indep f) (quot.indep_coherent f h) q) = q :=
  Quot.ind (fun (a : α) => Eq.refl (psigma.fst (quot.indep f a))) q

protected def rec {α : Sort u} {r : α → α → Prop} {β : Quot r → Sort v}
    (f : (a : α) → β (Quot.mk r a)) (h : ∀ (a b : α) (p : r a b), Eq._oldrec (f a) (sound p) = f b)
    (q : Quot r) : β q :=
  eq.rec_on (quot.lift_indep_pr1 f h q)
    (psigma.snd (Quot.lift (quot.indep f) (quot.indep_coherent f h) q))

protected def rec_on {α : Sort u} {r : α → α → Prop} {β : Quot r → Sort v} (q : Quot r)
    (f : (a : α) → β (Quot.mk r a))
    (h : ∀ (a b : α) (p : r a b), Eq._oldrec (f a) (sound p) = f b) : β q :=
  quot.rec f h q

protected def rec_on_subsingleton {α : Sort u} {r : α → α → Prop} {β : Quot r → Sort v}
    [h : ∀ (a : α), subsingleton (β (Quot.mk r a))] (q : Quot r) (f : (a : α) → β (Quot.mk r a)) :
    β q :=
  quot.rec f sorry q

protected def hrec_on {α : Sort u} {r : α → α → Prop} {β : Quot r → Sort v} (q : Quot r)
    (f : (a : α) → β (Quot.mk r a)) (c : ∀ (a b : α), r a b → f a == f b) : β q :=
  quot.rec_on q f sorry

end quot

def quotient {α : Sort u} (s : setoid α) := Quot setoid.r

namespace quotient

protected def mk {α : Sort u} [s : setoid α] (a : α) : quotient s := Quot.mk setoid.r a

def sound {α : Sort u} [s : setoid α] {a : α} {b : α} : a ≈ b → quotient.mk a = quotient.mk b :=
  quot.sound

protected def lift {α : Sort u} {β : Sort v} [s : setoid α] (f : α → β) :
    (∀ (a b : α), a ≈ b → f a = f b) → quotient s → β :=
  Quot.lift f

protected theorem ind {α : Sort u} [s : setoid α] {β : quotient s → Prop} :
    (∀ (a : α), β (quotient.mk a)) → ∀ (q : quotient s), β q :=
  Quot.ind

protected def lift_on {α : Sort u} {β : Sort v} [s : setoid α] (q : quotient s) (f : α → β)
    (c : ∀ (a b : α), a ≈ b → f a = f b) : β :=
  quot.lift_on q f c

protected theorem induction_on {α : Sort u} [s : setoid α] {β : quotient s → Prop} (q : quotient s)
    (h : ∀ (a : α), β (quotient.mk a)) : β q :=
  quot.induction_on q h

theorem exists_rep {α : Sort u} [s : setoid α] (q : quotient s) : ∃ (a : α), quotient.mk a = q :=
  quot.exists_rep q

protected def rec {α : Sort u} [s : setoid α] {β : quotient s → Sort v}
    (f : (a : α) → β (quotient.mk a))
    (h : ∀ (a b : α) (p : a ≈ b), Eq._oldrec (f a) (sound p) = f b) (q : quotient s) : β q :=
  quot.rec f h q

protected def rec_on {α : Sort u} [s : setoid α] {β : quotient s → Sort v} (q : quotient s)
    (f : (a : α) → β (quotient.mk a))
    (h : ∀ (a b : α) (p : a ≈ b), Eq._oldrec (f a) (sound p) = f b) : β q :=
  quot.rec_on q f h

protected def rec_on_subsingleton {α : Sort u} [s : setoid α] {β : quotient s → Sort v}
    [h : ∀ (a : α), subsingleton (β (quotient.mk a))] (q : quotient s)
    (f : (a : α) → β (quotient.mk a)) : β q :=
  quot.rec_on_subsingleton q f

protected def hrec_on {α : Sort u} [s : setoid α] {β : quotient s → Sort v} (q : quotient s)
    (f : (a : α) → β (quotient.mk a)) (c : ∀ (a b : α), a ≈ b → f a == f b) : β q :=
  quot.hrec_on q f c

protected def lift₂ {α : Sort u_a} {β : Sort u_b} {φ : Sort u_c} [s₁ : setoid α] [s₂ : setoid β]
    (f : α → β → φ)
    (c : ∀ (a₁ : α) (a₂ : β) (b₁ : α) (b₂ : β), a₁ ≈ b₁ → a₂ ≈ b₂ → f a₁ a₂ = f b₁ b₂)
    (q₁ : quotient s₁) (q₂ : quotient s₂) : φ :=
  quotient.lift (fun (a₁ : α) => quotient.lift (f a₁) sorry q₂) sorry q₁

protected def lift_on₂ {α : Sort u_a} {β : Sort u_b} {φ : Sort u_c} [s₁ : setoid α] [s₂ : setoid β]
    (q₁ : quotient s₁) (q₂ : quotient s₂) (f : α → β → φ)
    (c : ∀ (a₁ : α) (a₂ : β) (b₁ : α) (b₂ : β), a₁ ≈ b₁ → a₂ ≈ b₂ → f a₁ a₂ = f b₁ b₂) : φ :=
  quotient.lift₂ f c q₁ q₂

protected theorem ind₂ {α : Sort u_a} {β : Sort u_b} [s₁ : setoid α] [s₂ : setoid β]
    {φ : quotient s₁ → quotient s₂ → Prop}
    (h : ∀ (a : α) (b : β), φ (quotient.mk a) (quotient.mk b)) (q₁ : quotient s₁)
    (q₂ : quotient s₂) : φ q₁ q₂ :=
  quotient.ind (fun (a₁ : α) => quotient.ind (fun (a₂ : β) => h a₁ a₂) q₂) q₁

protected theorem induction_on₂ {α : Sort u_a} {β : Sort u_b} [s₁ : setoid α] [s₂ : setoid β]
    {φ : quotient s₁ → quotient s₂ → Prop} (q₁ : quotient s₁) (q₂ : quotient s₂)
    (h : ∀ (a : α) (b : β), φ (quotient.mk a) (quotient.mk b)) : φ q₁ q₂ :=
  quotient.ind (fun (a₁ : α) => quotient.ind (fun (a₂ : β) => h a₁ a₂) q₂) q₁

protected theorem induction_on₃ {α : Sort u_a} {β : Sort u_b} {φ : Sort u_c} [s₁ : setoid α]
    [s₂ : setoid β] [s₃ : setoid φ] {δ : quotient s₁ → quotient s₂ → quotient s₃ → Prop}
    (q₁ : quotient s₁) (q₂ : quotient s₂) (q₃ : quotient s₃)
    (h : ∀ (a : α) (b : β) (c : φ), δ (quotient.mk a) (quotient.mk b) (quotient.mk c)) :
    δ q₁ q₂ q₃ :=
  quotient.ind
    (fun (a₁ : α) => quotient.ind (fun (a₂ : β) => quotient.ind (fun (a₃ : φ) => h a₁ a₂ a₃) q₃) q₂)
    q₁

theorem exact {α : Sort u} [s : setoid α] {a : α} {b : α} : quotient.mk a = quotient.mk b → a ≈ b :=
  fun (h : quotient.mk a = quotient.mk b) => eq_imp_rel h

protected def rec_on_subsingleton₂ {α : Sort u_a} {β : Sort u_b} [s₁ : setoid α] [s₂ : setoid β]
    {φ : quotient s₁ → quotient s₂ → Sort u_c}
    [h : ∀ (a : α) (b : β), subsingleton (φ (quotient.mk a) (quotient.mk b))] (q₁ : quotient s₁)
    (q₂ : quotient s₂) (f : (a : α) → (b : β) → φ (quotient.mk a) (quotient.mk b)) : φ q₁ q₂ :=
  quotient.rec_on_subsingleton q₁
    fun (a : α) => quotient.rec_on_subsingleton q₂ fun (b : β) => f a b

end quotient

inductive eqv_gen {α : Type u} (r : α → α → Prop) : α → α → Prop where
| rel : ∀ (x y : α), r x y → eqv_gen r x y
| refl : ∀ (x : α), eqv_gen r x x
| symm : ∀ (x y : α), eqv_gen r x y → eqv_gen r y x
| trans : ∀ (x y z : α), eqv_gen r x y → eqv_gen r y z → eqv_gen r x z

theorem eqv_gen.is_equivalence {α : Type u} (r : α → α → Prop) : equivalence (eqv_gen r) :=
  mk_equivalence (eqv_gen r) eqv_gen.refl eqv_gen.symm eqv_gen.trans

def eqv_gen.setoid {α : Type u} (r : α → α → Prop) : setoid α :=
  setoid.mk (eqv_gen r) (eqv_gen.is_equivalence r)

theorem quot.exact {α : Type u} (r : α → α → Prop) {a : α} {b : α} (H : Quot.mk r a = Quot.mk r b) :
    eqv_gen r a b :=
  quotient.exact
    (congr_arg (Quot.lift quotient.mk fun (x y : α) (h : r x y) => quot.sound (eqv_gen.rel x y h))
      H)

theorem quot.eqv_gen_sound {α : Type u} {r : α → α → Prop} {a : α} {b : α} (H : eqv_gen r a b) :
    Quot.mk r a = Quot.mk r b :=
  sorry

protected instance quotient.decidable_eq {α : Sort u} {s : setoid α}
    [d : (a b : α) → Decidable (a ≈ b)] : DecidableEq (quotient s) :=
  fun (q₁ q₂ : quotient s) => quotient.rec_on_subsingleton₂ q₁ q₂ fun (a₁ a₂ : α) => sorry

end Mathlib