/-
Copyright 2020 Google LLC

Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at

      http://www.apache.org/licenses/LICENSE-2.0

Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
 -/
import measure_theory.measurable_space

import measure_theory.measure_space
import measure_theory.outer_measure
import measure_theory.lebesgue_measure
import measure_theory.integration
import measure_theory.borel_space
import data.set.countable
import formal_ml.measurable_space
import formal_ml.probability_space
import formal_ml.real_random_variable
import data.complex.exponential
import formal_ml.ennreal
import formal_ml.nnreal
import formal_ml.sum
import formal_ml.exp_bound
import formal_ml.classical

structure PAC_problem :=
(Ω:Type*)                             -- Underlying outcome type
(p:probability_space Ω)               -- underlying probability space
(β:Type*)                             -- instance type
(Mβ:measurable_space β)               -- Measurable space for the instances
(γ:Type*)                             -- label type
(Mγ:measurable_space γ)               -- Measurable space for the labels
(HMEγ:has_measurable_equality Mγ)     -- Measurable equality for the labels
(Eγ:encodable γ)                      -- Encodable labels is very useful
(Di:Type*)                            -- example index type
(FDi:fintype Di)                      -- number of examples are finite
(EDi:encodable Di)                    -- example index is encodable
                                      -- see trunc_encodable_of_fintype
(Hi:Type*)                            -- hypothesis index type
(FHi:fintype Hi)                      -- number of examples are finite
(EHi:encodable Hi)                    -- hypothesis index is encodable
                                      -- see trunc_encodable_of_fintype
(H:Hi → (Mβ →ₘ Mγ))                   -- hypothesis space
(D:Di → (p →ᵣ (Mβ ×ₘ Mγ)))            -- example distribution
(IID:random_variables_IID D)          -- examples are IID
(has_example:inhabited Di)            -- there exists an example

--example_instance P j is the jth instance (the features of an example)
def example_instance (P:PAC_problem)
  (j:P.Di):random_variable P.p P.Mβ :=
  (mf_fst) ∘r (P.D j)

--the measurable space on the examples.
def PAC_problem.Mβγ (P:PAC_problem):
    measurable_space (P.β × P.γ) := P.Mβ ×ₘ P.Mγ

/-
  rv_label_eq X Y is the event that X and Y are equal, where X and Y are labels.
-/
def rv_label_eq (P:PAC_problem)
  (X Y:random_variable P.p P.Mγ):event  P.p :=
  @random_variable_eq P.Ω P.p P.γ P.Mγ P.HMEγ  X Y

/-
  rv_label_ne X Y is the event that X and Y are not equal, where X and Y are labels.
-/
def rv_label_ne (P:PAC_problem)
  (X Y:random_variable P.p P.Mγ):event  P.p :=
  @random_variable_ne P.Ω P.p P.γ P.Mγ P.HMEγ  X Y

/-
  example_label P j is the label of the jth example.
-/
def example_label (P:PAC_problem)
  (j:P.Di):P.p →ᵣ P.Mγ :=
  mf_snd ∘r (P.D j)

/-
  example_classification P i j is the classification by the ith hypothesis of the jth example.
-/
def example_classification (P:PAC_problem)
  (i:P.Hi) (j:P.Di):P.p →ᵣ P.Mγ :=
  (P.H i) ∘r (example_instance P j)

/-
  example_correct P i j is whether the ith hypothesis is correct on the jth example.
-/
def example_correct (P:PAC_problem)
  (i:P.Hi) (j:P.Di):event P.p :=
  rv_label_eq P (example_classification P i j) (example_label P j)

/-
  example_error P i j is whether the ith hypothesis made a mistake on the jth example.
-/
def example_error (P:PAC_problem)
  (i:P.Hi) (j:P.Di):event P.p :=
  rv_label_ne P (example_classification P i j) (example_label P j)

/-
  num_examples P is the number of examples in the problem.
  This is defined as the cardinality of the index type of the examples.
-/
def num_examples  (P:PAC_problem):nat
   := @fintype.card P.Di P.FDi

/-
  The number of examples is the number of elements of type P.Di.
  P.FDi.elems is the set of all elements in P.Di, and P.FDi.elems.card is the cardinality of
  P.FDi.elems.
-/
lemma num_examples_eq_finset_card (P:PAC_problem):
  num_examples P = P.FDi.elems.card :=
begin
  refl,
end

/-
  The number of examples do not equal zero.
 -/
lemma num_examples_ne_zero (P:PAC_problem):
  num_examples P ≠ 0 :=
begin
  unfold num_examples,
  apply @card_ne_zero_of_inhabited P.Di P.has_example P.FDi,
end

/-
  The number of hypotheses.
 -/
def num_hypotheses (P:PAC_problem):nat
   := @fintype.card P.Hi P.FHi

/-
  The number of errors on the training set, divided by the size of the training set.
  training_error P i = (∑ (j:P.Di), (example_error P i j))/(num_exmaples P)
  TODO: replace with average_indicator.
-/
noncomputable def training_error (P:PAC_problem)
  (i:P.Hi):P.p →ᵣ (borel nnreal) :=
  average_identifier (example_error P i) P.FDi
 -- (count_finset_rv P.FDi.elems (example_error P i)) * (to_nnreal_rv ((num_examples P):nnreal)⁻¹)

/-
  The expected test error.
  The test error is equal to the expected training error. Because we have not defined a generating
  process for examples, we use this as the definition.
-/
noncomputable def test_error (P:PAC_problem)
    (i:P.Hi):ennreal := E[training_error P i]

/-
  fake_hypothesis P ε i is the event that hypothesis i has zero training error, but has
  test error > ε.
-/
noncomputable def fake_hypothesis (P:PAC_problem) (ε:nnreal)
  (i:P.Hi):event P.p :=
  ((training_error P i) =ᵣ 0) ∧ (event_const (test_error P i > ε))

/-
  The event that all hypotheses with training error zero have test error ≤ ε.
-/
noncomputable def approximately_correct_event (P:PAC_problem)
  (ε:nnreal):event P.p :=
  enot (eany_fintype P.FHi (fake_hypothesis P ε))

def probably_approximately_correct (P:PAC_problem)
 (ε:nnreal) (δ:nnreal):Prop :=
  1 - δ ≤ Pr[approximately_correct_event P ε]

lemma enot_example_correct_eq_example_error
  (P:PAC_problem) (i:P.Hi) (j:P.Di):enot (example_correct P i j) = (example_error P i j) :=
begin
  apply event.eq,
  unfold example_error example_correct rv_label_ne rv_label_eq,
  refl,
end

lemma enot_example_error_eq_example_correct
  (P:PAC_problem) (i:P.Hi) (j:P.Di):enot (example_error P i j) = (example_correct P i j) :=
begin
  rw ← enot_example_correct_eq_example_error,
  simp,
end

lemma example_correct_iff_not_example_error
  (P:PAC_problem) (i:P.Hi) (j:P.Di) (ω:P.Ω): ω ∉ (example_error P i j).val ↔
  ω ∈ (example_correct P i j).val :=
begin
  rw ← enot_example_error_eq_example_correct,
  simp,
end

lemma example_error_IID (P:PAC_problem) (i:P.Hi):
  @events_IID P.Ω P.Di P.p  (example_error P i) :=
begin
  /-
    To prove that the errors of a particular hypothesis are IID, we must use an alternate
    formulation of the example_error events. Specifically, instead of constructing a hierarchy
    of random variables, we must make a leap from the established IID random variable
    (the data), construct another IID random variable (the product of
    the classification and the label), and show that the set of all label/classification pairs
    that aren't equal are a measurable set (because has_measurable_eq Mγ).

    The indexed set of events of each IID random variable being in a measurable set is IID,
    so the result holds.

    Note that while this proof looks a little long, most of the proof is just unwrapping
    the traditional and internal definitions of example error, and then using simp to show that
    they are equal on all outcomes.
  -/
  let Y:(P.Mβ ×ₘ P.Mγ)→ₘ (P.Mγ ×ₘ P.Mγ) := prod_measurable_fun ((P.H i) ∘m (mf_fst)) (mf_snd),
  begin
  let S:@measurable_setB _ (P.Mγ ×ₘ P.Mγ) := @measurable_setB_ne P.γ P.Mγ P.HMEγ,
  begin
  have A1:@random_variables_IID P.Ω P.p P.Di (P.γ × P.γ) (P.Mγ ×ₘ P.Mγ)
  (λ j:P.Di, Y ∘r (P.D j) ),
  {
    apply compose_IID,
    apply P.IID,
  },
  have A2:@events_IID  P.Ω P.Di P.p (λ j:P.Di, @rv_event P.Ω P.p _ (P.Mγ ×ₘ P.Mγ) (Y ∘r (P.D j)) S),
  {
    apply rv_event_IID,
    apply A1,
  },
  have A3: (λ j:P.Di, @rv_event P.Ω P.p _ (P.Mγ ×ₘ P.Mγ) (Y ∘r (P.D j)) S) = example_error P i,
  {
    apply funext,
    intro j,
    apply event.eq,
    unfold example_error example_label example_classification rv_label_ne example_instance,
    refl,
  },
  rw ← A3,
  exact A2,
  end
  end
end

lemma example_correct_IID (P:PAC_problem) (i:P.Hi):
  @events_IID P.Ω P.Di P.p  (example_correct P i) :=
begin
  /-
    Similar to example_error_IID. Theoretically, we could prove it from example_error_IID.
    However, it is easier for now to prove it from first principles.
  -/
  let Y:(P.Mβ ×ₘ P.Mγ)→ₘ (P.Mγ ×ₘ P.Mγ) := prod_measurable_fun ((P.H i) ∘m (mf_fst)) (mf_snd),
  begin
  let S:@measurable_setB _ (P.Mγ ×ₘ P.Mγ) := {
    val := {x:P.γ × P.γ|x.fst = x.snd},
    property := P.HMEγ.measurable_set_eq,
  },
  begin
  have A1:@random_variables_IID P.Ω P.p P.Di (P.γ × P.γ) (P.Mγ ×ₘ P.Mγ)
  (λ j:P.Di, Y ∘r (P.D j) ),
  {
    apply compose_IID,
    apply P.IID,
  },
  have A2:@events_IID  P.Ω P.Di P.p (λ j:P.Di, @rv_event P.Ω P.p _ (P.Mγ ×ₘ P.Mγ) (Y ∘r (P.D j)) S),
  {
    apply rv_event_IID,
    apply A1,
  },
  have A3: (λ j:P.Di, @rv_event P.Ω P.p _ (P.Mγ ×ₘ P.Mγ) (Y ∘r (P.D j)) S) = example_correct P i,
  {
    apply funext,
    intro j,
    apply event.eq,
    unfold example_correct example_label example_classification rv_label_eq example_instance,
    refl,
  },
  rw ← A3,
  exact A2,
  end
  end
end

lemma example_error_identical (P:PAC_problem) (i:P.Hi) (j j':P.Di):
  Pr[example_error P i j] = Pr[example_error P i j'] :=
begin
  have A1:@events_IID P.Ω P.Di P.p  (example_error P i),
  {
    apply example_error_IID,
  },
  unfold events_IID at A1,
  cases A1 with A2 A3,
  apply A3,
end

--set_option pp.all true
--set_option pp.coercions true

lemma test_error_training_mistake (P:PAC_problem) (i:P.Hi) (j:P.Di):
  (Pr[example_error P i j]:ennreal) = (test_error P i) :=
begin
  have A1:E[(count_finset_rv P.FDi.elems (example_error P i)) *
  (to_nnreal_rv ((num_examples P):nnreal)⁻¹)]=(test_error P i),
  {
    unfold test_error,
    refl,
  },

  have A2:(test_error P i)=E[(count_finset_rv P.FDi.elems (example_error P i))]
  * ((num_examples P):ennreal)⁻¹,
  {
    rw ← A1,
    rw scalar_expected_value,
    rw ennreal.coe_inv,
    have A2A:(((num_examples P):nnreal)⁻¹:ennreal)=((num_examples P):ennreal)⁻¹,
    {
      simp,
    },
    rw A2A,
    simp,
    apply num_examples_ne_zero,
  },

  have A3:E[(count_finset_rv P.FDi.elems (example_error P i))]=
           P.FDi.elems.sum (λ k, Pr[(example_error P i k)]),
  {
    apply linear_count_finset_rv,
  },
  have A4:∀ k, (λ k, (Pr[(example_error P i k)]:ennreal)) k = (Pr[(example_error P i j)]:ennreal),
  {
    intro k,
    simp,
    apply (example_error_identical P i _ j),
  },
  have A5:E[(count_finset_rv P.FDi.elems (example_error P i))]=
           P.FDi.elems.card * (Pr[(example_error P i j)]:ennreal),
  {
    rw A3,
    apply finset_sum_const,
    apply A4,
  },
  have A6:E[(count_finset_rv P.FDi.elems (example_error P i))]=
           (num_examples P) * (Pr[(example_error P i j)]:ennreal),
  {
    rw A5,
    rw num_examples_eq_finset_card,
  },
  rw A6 at A2,
  rw mul_comm at A2,
  rw ← mul_assoc at A2,
  have A7:((num_examples P):ennreal)⁻¹ * ((num_examples P):ennreal) = 1,
  {
    rw mul_comm,
    apply ennreal.mul_inv_cancel,
    {
      simp,
      apply (@num_examples_ne_zero P),
    },
    {
      simp,
    }
  },
  rw A7 at A2,
  simp at A2,
  symmetry,
  exact A2,
end

lemma test_error_training_mistake2 (P:PAC_problem) (i:P.Hi) (j:P.Di):
  Pr[example_error P i j] = (test_error P i).to_nnreal :=
begin
  symmetry,
  apply ennreal_coe_eq_lift,
  rw test_error_training_mistake,
end

lemma example_correct_prob (P:PAC_problem) (i:P.Hi) (j:P.Di):
  Pr[example_correct P i j] = 1 - (test_error P i).to_nnreal :=
begin
  rw ← enot_example_error_eq_example_correct,
  rw ← Pr_one_minus_eq_not,
  rw test_error_training_mistake2,
end

lemma test_error_ne_top (P:PAC_problem) (i:P.Hi):
  (test_error P i) ≠ ⊤ :=
begin
  rw ← test_error_training_mistake,
  simp,
  apply P.has_example.default,
end

/-
event_IID_pow :
  ∀ {α : Type u_1} [Mα : measurable_space α] {p : probability_measure α} {β : Type u_2} [F : fintype β]
  [I : inhabited β] {γ : Type u_3} [Mγ : measurable_space γ] (A : β → event p) (S : finset β),
    events_IID A → Pr[eall_finset S A] = Pr[A (inhabited.default β)] ^ finset.card S
-/
--sorry
set_option pp.implicit true
lemma training_error_zero_prob (P:PAC_problem) (i:P.Hi):
  Pr[training_error P i =ᵣ 0] =
   (Pr[(example_correct P i P.has_example.default)])^(num_examples P) :=
begin
  unfold training_error,
  rw @Pr_average_identifier_eq_zero P.Di P.Ω P.p (example_error P i) P.FDi P.has_example.default,
  rw ← enot_example_correct_eq_example_error,
  rw Pr_one_minus_not_eq,
  rw num_examples_eq_finset_card,
  unfold fintype.card,
  refl,
  apply example_error_IID,
end

lemma fake_hypothesis_prob (P:PAC_problem)
  (ε:nnreal) (i:P.Hi):Pr[fake_hypothesis P ε i]≤(1-ε)^(num_examples P) :=
begin
  unfold fake_hypothesis,
  have A1:decidable (test_error P i ≤ ↑ε),
  {
    apply linear_order.decidable_le,
  },
  cases A1,
  {
    apply le_trans,
    apply Pr_eand_le_left,
    --Note: this could be <.
    have B1:↑ε ≤ test_error P i,
    {
      apply le_of_not_le A1,
    },
    have B2:ε ≤ (test_error P i).to_nnreal,
    {
      apply ennreal_le_to_nnreal_of_ennreal_le_of_ne_top,
      apply test_error_ne_top,
      exact B1,
    },
    rw training_error_zero_prob,
    rw example_correct_prob,
    apply nnreal_pow_mono,
    apply nnreal_sub_le_sub_of_le,
    --ε ≤ (test_error P i).to_nnreal
    exact B2,
  },
  {
    apply le_trans,
    apply Pr_eand_le_right,
    rw Pr_event_const_false,
    {
      simp,
    },
    {
      rw ← le_iff_not_gt,
      exact A1,
    },
  },
end

lemma fake_hypothesis_prob2 (P:PAC_problem)
  (ε:nnreal) (i:P.Hi):
   Pr[fake_hypothesis P ε i] ≤ nnreal.exp (- ε * (num_examples P)) :=
begin
  apply le_trans,
  apply fake_hypothesis_prob,
  apply nnreal_exp_bound2,
end

lemma eany_fake_hypothesis_prob (P:PAC_problem)
  (ε:nnreal):
   Pr[ eany_fintype P.FHi (fake_hypothesis P ε)] ≤ (num_hypotheses P) * nnreal.exp (- ε * (num_examples P)) :=
begin
  apply eany_fintype_bound2,
  intro,
  apply fake_hypothesis_prob2,
end

lemma pac_bound (P:PAC_problem)
  (ε:nnreal):
  (1:nnreal) - (num_hypotheses P) * nnreal.exp (-(ε:real) * (num_examples P:real)) ≤
  Pr[approximately_correct_event P ε]  :=
begin
  have A1:Pr[approximately_correct_event P ε] = 1 - Pr[eany_fintype P.FHi (fake_hypothesis P ε)],
  {
    symmetry,
    unfold approximately_correct_event,
    apply Pr_one_minus_eq_not (eany_fintype P.FHi (fake_hypothesis P ε)),
  },
  rw A1,
  apply nnreal_sub_le_left,
  have A2:Pr[ eany_fintype P.FHi (fake_hypothesis P ε)]
      ≤ (num_hypotheses P) * nnreal.exp (- ε * (num_examples P)),
  {
    apply eany_fake_hypothesis_prob,
  },
  apply A2,
end

lemma pac_bound2 (P:PAC_problem) (ε:nnreal):
  probably_approximately_correct P ε
  ((num_hypotheses P) * nnreal.exp (-ε * (num_examples P))) :=
begin
  unfold probably_approximately_correct,
  apply pac_bound,
end


/-
Copyright (c) 2018 Patrick Massot. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Patrick Massot, Kevin Buzzard, Scott Morrison, Johan Commelin, Chris Hughes,
  Johannes Hölzl, Yury Kudryashov
-/
import algebra.hom.group
import algebra.group.commute

/-!
# Multiplicative homomorphisms respect semiconjugation and commutation.

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

section commute

variables {F M N : Type*} [has_mul M] [has_mul N] {a x y : M}

@[simp, to_additive]
protected lemma semiconj_by.map [mul_hom_class F M N] (h : semiconj_by a x y) (f : F) :
  semiconj_by (f a) (f x) (f y) :=
by simpa only [semiconj_by, map_mul] using congr_arg f h

@[simp, to_additive]
protected lemma commute.map [mul_hom_class F M N] (h : commute x y) (f : F) :
  commute (f x) (f y) :=
h.map f

end commute


/-
Copyright (c) 2020 Kenny Lau. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kenny Lau
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.algebra.algebra.tower
import Mathlib.algebra.invertible
import Mathlib.linear_algebra.basis
import Mathlib.ring_theory.adjoin
import Mathlib.PostPort

universes u v w u₁ u_1 u_2 u_3 u_4 v₁ w₁

namespace Mathlib

/-!
# Towers of algebras

We set up the basic theory of algebra towers.
An algebra tower A/S/R is expressed by having instances of `algebra A S`,
`algebra R S`, `algebra R A` and `is_scalar_tower R S A`, the later asserting the
compatibility condition `(r • s) • a = r • (s • a)`.

In `field_theory/tower.lean` we use this to prove the tower law for finite extensions,
that if `R` and `S` are both fields, then `[A:R] = [A:S] [S:A]`.

In this file we prepare the main lemma:
if `{bi | i ∈ I}` is an `R`-basis of `S` and `{cj | j ∈ J}` is a `S`-basis
of `A`, then `{bi cj | i ∈ I, j ∈ J}` is an `R`-basis of `A`. This statement does not require the
base rings to be a field, so we also generalize the lemma to rings in this file.
-/

namespace is_scalar_tower

protected instance polynomial (R : Type u) {S : Type v} {A : Type w} [comm_semiring R]
    [comm_semiring S] [semiring A] [algebra R S] [algebra S A] [algebra R A]
    [is_scalar_tower R S A] : is_scalar_tower R S (polynomial A) :=
  of_algebra_map_eq fun (x : R) => congr_arg (⇑polynomial.C) (algebra_map_apply R S A x)

theorem aeval_apply (R : Type u) (S : Type v) (A : Type w) [comm_semiring R] [comm_semiring S]
    [semiring A] [algebra R S] [algebra S A] [algebra R A] [is_scalar_tower R S A] (x : A)
    (p : polynomial R) :
    coe_fn (polynomial.aeval x) p =
        coe_fn (polynomial.aeval x) (polynomial.map (algebra_map R S) p) :=
  sorry

/-- Suppose that `R -> S -> A` is a tower of algebras.
If an element `r : R` is invertible in `S`, then it is invertible in `A`. -/
def invertible.algebra_tower (R : Type u) (S : Type v) (A : Type w) [comm_semiring R]
    [comm_semiring S] [semiring A] [algebra R S] [algebra S A] [algebra R A] [is_scalar_tower R S A]
    (r : R) [invertible (coe_fn (algebra_map R S) r)] : invertible (coe_fn (algebra_map R A) r) :=
  invertible.copy (invertible.map (↑(algebra_map S A)) (coe_fn (algebra_map R S) r))
    (coe_fn (algebra_map R A) r) sorry

/-- A natural number that is invertible when coerced to `R` is also invertible
when coerced to any `R`-algebra. -/
def invertible_algebra_coe_nat (R : Type u) (A : Type w) [comm_semiring R] [semiring A]
    [algebra R A] (n : ℕ) [inv : invertible ↑n] : invertible ↑n :=
  invertible.algebra_tower ℕ R A n

theorem algebra_map_aeval (R : Type u) (A : Type w) (B : Type u₁) [comm_semiring R]
    [comm_semiring A] [comm_semiring B] [algebra R A] [algebra A B] [algebra R B]
    [is_scalar_tower R A B] (x : A) (p : polynomial R) :
    coe_fn (algebra_map A B) (coe_fn (polynomial.aeval x) p) =
        coe_fn (polynomial.aeval (coe_fn (algebra_map A B) x)) p :=
  sorry

theorem aeval_eq_zero_of_aeval_algebra_map_eq_zero (R : Type u) (A : Type w) (B : Type u₁)
    [comm_semiring R] [comm_semiring A] [comm_semiring B] [algebra R A] [algebra A B] [algebra R B]
    [is_scalar_tower R A B] {x : A} {p : polynomial R} (h : function.injective ⇑(algebra_map A B))
    (hp : coe_fn (polynomial.aeval (coe_fn (algebra_map A B) x)) p = 0) :
    coe_fn (polynomial.aeval x) p = 0 :=
  sorry

theorem aeval_eq_zero_of_aeval_algebra_map_eq_zero_field {R : Type u_1} {A : Type u_2}
    {B : Type u_3} [comm_semiring R] [field A] [comm_semiring B] [nontrivial B] [algebra R A]
    [algebra R B] [algebra A B] [is_scalar_tower R A B] {x : A} {p : polynomial R}
    (h : coe_fn (polynomial.aeval (coe_fn (algebra_map A B) x)) p = 0) :
    coe_fn (polynomial.aeval x) p = 0 :=
  aeval_eq_zero_of_aeval_algebra_map_eq_zero R A B (ring_hom.injective (algebra_map A B)) h

end is_scalar_tower

namespace algebra

theorem adjoin_algebra_map' {R : Type u} {S : Type v} {A : Type w} [comm_ring R] [comm_ring S]
    [comm_ring A] [algebra R S] [algebra S A] (s : set S) :
    adjoin R (⇑(algebra_map S (comap R S A)) '' s) = subalgebra.map (adjoin R s) (to_comap R S A) :=
  sorry

theorem adjoin_algebra_map (R : Type u) (S : Type v) (A : Type w) [comm_ring R] [comm_ring S]
    [comm_ring A] [algebra R S] [algebra S A] [algebra R A] [is_scalar_tower R S A] (s : set S) :
    adjoin R (⇑(algebra_map S A) '' s) =
        subalgebra.map (adjoin R s) (is_scalar_tower.to_alg_hom R S A) :=
  sorry

theorem adjoin_res (C : Type u_1) (D : Type u_2) (E : Type u_3) [comm_semiring C] [comm_semiring D]
    [comm_semiring E] [algebra C D] [algebra C E] [algebra D E] [is_scalar_tower C D E]
    (S : set E) :
    subalgebra.res C (adjoin D S) =
        subalgebra.under (subalgebra.map ⊤ (is_scalar_tower.to_alg_hom C D E))
          (adjoin (↥(subalgebra.map ⊤ (is_scalar_tower.to_alg_hom C D E))) S) :=
  sorry

theorem adjoin_res_eq_adjoin_res (C : Type u_1) (D : Type u_2) (E : Type u_3) (F : Type u_4)
    [comm_semiring C] [comm_semiring D] [comm_semiring E] [comm_semiring F] [algebra C D]
    [algebra C E] [algebra C F] [algebra D F] [algebra E F] [is_scalar_tower C D F]
    [is_scalar_tower C E F] {S : set D} {T : set E} (hS : adjoin C S = ⊤) (hT : adjoin C T = ⊤) :
    subalgebra.res C (adjoin E (⇑(algebra_map D F) '' S)) =
        subalgebra.res C (adjoin D (⇑(algebra_map E F) '' T)) :=
  sorry

end algebra

namespace subalgebra

@[simp] theorem aeval_coe (R : Type u) {A : Type w} [comm_semiring R] [comm_semiring A]
    [algebra R A] {S : subalgebra R A} {x : ↥S} {p : polynomial R} :
    coe_fn (polynomial.aeval ↑x) p = ↑(coe_fn (polynomial.aeval x) p) :=
  Eq.symm (is_scalar_tower.algebra_map_aeval R (↥S) A x p)

end subalgebra

theorem algebra.fg_trans' {R : Type u_1} {S : Type u_2} {A : Type u_3} [comm_ring R] [comm_ring S]
    [comm_ring A] [algebra R S] [algebra S A] [algebra R A] [is_scalar_tower R S A]
    (hRS : subalgebra.fg ⊤) (hSA : subalgebra.fg ⊤) : subalgebra.fg ⊤ :=
  sorry

theorem linear_independent_smul {R : Type u} {S : Type v} {A : Type w} [comm_ring R] [ring S]
    [add_comm_group A] [algebra R S] [module S A] [module R A] [is_scalar_tower R S A] {ι : Type v₁}
    {b : ι → S} {ι' : Type w₁} {c : ι' → A} (hb : linear_independent R b)
    (hc : linear_independent S c) :
    linear_independent R fun (p : ι × ι') => b (prod.fst p) • c (prod.snd p) :=
  sorry

theorem is_basis.smul {R : Type u} {S : Type v} {A : Type w} [comm_ring R] [ring S]
    [add_comm_group A] [algebra R S] [module S A] [module R A] [is_scalar_tower R S A] {ι : Type v₁}
    {b : ι → S} {ι' : Type w₁} {c : ι' → A} (hb : is_basis R b) (hc : is_basis S c) :
    is_basis R fun (p : ι × ι') => b (prod.fst p) • c (prod.snd p) :=
  sorry

theorem is_basis.smul_repr {R : Type u} {S : Type v} {A : Type w} [comm_ring R] [ring S]
    [add_comm_group A] [algebra R S] [module S A] [module R A] [is_scalar_tower R S A]
    {ι : Type u_1} {ι' : Type u_2} {b : ι → S} {c : ι' → A} (hb : is_basis R b) (hc : is_basis S c)
    (x : A) (ij : ι × ι') :
    coe_fn (coe_fn (is_basis.repr (is_basis.smul hb hc)) x) ij =
        coe_fn (coe_fn (is_basis.repr hb) (coe_fn (coe_fn (is_basis.repr hc) x) (prod.snd ij)))
          (prod.fst ij) :=
  sorry

theorem is_basis.smul_repr_mk {R : Type u} {S : Type v} {A : Type w} [comm_ring R] [ring S]
    [add_comm_group A] [algebra R S] [module S A] [module R A] [is_scalar_tower R S A]
    {ι : Type u_1} {ι' : Type u_2} {b : ι → S} {c : ι' → A} (hb : is_basis R b) (hc : is_basis S c)
    (x : A) (i : ι) (j : ι') :
    coe_fn (coe_fn (is_basis.repr (is_basis.smul hb hc)) x) (i, j) =
        coe_fn (coe_fn (is_basis.repr hb) (coe_fn (coe_fn (is_basis.repr hc) x) j)) i :=
  sorry

theorem exists_subalgebra_of_fg (A : Type w) (B : Type u₁) (C : Type u_1) [comm_ring A]
    [comm_ring B] [comm_ring C] [algebra A B] [algebra B C] [algebra A C] [is_scalar_tower A B C]
    (hAC : subalgebra.fg ⊤) (hBC : submodule.fg ⊤) :
    ∃ (B₀ : subalgebra A B), subalgebra.fg B₀ ∧ submodule.fg ⊤ :=
  sorry

/-- Artin--Tate lemma: if A ⊆ B ⊆ C is a chain of subrings of commutative rings, and
A is noetherian, and C is algebra-finite over A, and C is module-finite over B,
then B is algebra-finite over A.

References: Atiyah--Macdonald Proposition 7.8; Stacks 00IS; Altman--Kleiman 16.17. -/
theorem fg_of_fg_of_fg (A : Type w) (B : Type u₁) (C : Type u_1) [comm_ring A] [comm_ring B]
    [comm_ring C] [algebra A B] [algebra B C] [algebra A C] [is_scalar_tower A B C]
    [is_noetherian_ring A] (hAC : subalgebra.fg ⊤) (hBC : submodule.fg ⊤)
    (hBCi : function.injective ⇑(algebra_map B C)) : subalgebra.fg ⊤ :=
  sorry

/-- Restrict the domain of an `alg_hom`. -/
def alg_hom.restrict_domain {A : Type w} (B : Type u₁) {C : Type u_1} {D : Type u_2}
    [comm_semiring A] [comm_semiring C] [comm_semiring D] [algebra A C] [algebra A D]
    (f : alg_hom A C D) [comm_semiring B] [algebra A B] [algebra B C] [is_scalar_tower A B C] :
    alg_hom A B D :=
  alg_hom.comp f (is_scalar_tower.to_alg_hom A B C)

/-- Extend the scalars of an `alg_hom`. -/
def alg_hom.extend_scalars {A : Type w} (B : Type u₁) {C : Type u_1} {D : Type u_2}
    [comm_semiring A] [comm_semiring C] [comm_semiring D] [algebra A C] [algebra A D]
    (f : alg_hom A C D) [comm_semiring B] [algebra A B] [algebra B C] [is_scalar_tower A B C] :
    alg_hom B C D :=
  alg_hom.mk (alg_hom.to_fun f) sorry sorry sorry sorry sorry

/-- `alg_hom`s from the top of a tower are equivalent to a pair of `alg_hom`s. -/
def alg_hom_equiv_sigma {A : Type w} {B : Type u₁} {C : Type u_1} {D : Type u_2} [comm_semiring A]
    [comm_semiring C] [comm_semiring D] [algebra A C] [algebra A D] [comm_semiring B] [algebra A B]
    [algebra B C] [is_scalar_tower A B C] :
    alg_hom A C D ≃ sigma fun (f : alg_hom A B D) => alg_hom B C D :=
  equiv.mk
    (fun (f : alg_hom A C D) => sigma.mk (alg_hom.restrict_domain B f) (alg_hom.extend_scalars B f))
    (fun (fg : sigma fun (f : alg_hom A B D) => alg_hom B C D) =>
      is_scalar_tower.restrict_base A (sigma.snd fg))
    sorry sorry

end Mathlib


import QL.FOL.Tait.tait provability QL.FOL.coding consistency

universes u v

namespace fol
open_locale logic_symbol
variables {L : language.{u}} {m n : ℕ}

namespace Tait

namespace subformula
variables {L m n}

def uniform : bounded_subformula L m n →ₗ subformula L ℕ n := map coe

@[simp] lemma uniform_inj (p q : bounded_subformula L m n) :
  p.uniform = q.uniform ↔ p = q :=
⟨λ h, map_inj_of_inj coe fin.coe_injective h, λ e, by simp[e]⟩

@[simp] lemma uniform_relation {k} (r : L.pr k) (v : fin k → bounded_subterm L m n) :
  uniform (relation r v) = relation r (λ i, subterm.uniform (v i)) := by simp[uniform, subterm.uniform]

@[simp] lemma uniform_neg_relation {k} (r : L.pr k) (v : fin k → bounded_subterm L m n) :
  uniform (neg_relation r v) = neg_relation r (λ i, subterm.uniform (v i)) := by simp[uniform, subterm.uniform]

@[simp] lemma uniform_fal (p : bounded_subformula L m (n + 1)) :
  uniform (∀'p) = ∀'uniform p := by simp[uniform]; unfold has_univ_quantifier'.univ; simp; refl

@[simp] lemma uniform_ex (p : bounded_subformula L m (n + 1)) :
  uniform (∃'p) = ∃'uniform p := by simp[uniform]; unfold has_exists_quantifier'.ex; simp; refl

@[simp] lemma uniform_mlift (p : bounded_subformula L m n) : p.mlift.uniform = p.uniform :=
by simp[mlift, uniform]; congr

@[simp] lemma uniform_cast_le {m₁ m₂ : ℕ} (h : m₁ ≤ m₂) (p : bounded_subformula L m₁ n) :
  (cast_le h p).uniform = p.uniform :=
by simp[cast_le, uniform]; congr

@[simp] lemma uniform_to_subterm (p : bounded_subformula L m n) (h) : to_bform p.uniform h = p :=
by induction p using fol.Tait.subformula.ind_on; simp*

@[simp] lemma to_subterm_uniform (p : subformula L ℕ n) (h : p.arity ≤ m) : (p.to_bform h).uniform = p :=
by induction p using fol.Tait.subformula.ind_on; simp*

@[simp] lemma subformula_arity (p : bounded_subformula L m n) : p.uniform.arity ≤ m :=
by induction p using fol.Tait.subformula.ind_on; simp*

section encode
open encodable nat
variables {L n} [∀ k, encodable (L.pr k)] [∀ k, encodable (L.fn k)]

@[simp] def to_nat : Π {n}, subformula L ℕ n → ℕ
| n verum                       := 0
| n falsum                      := 1
| n (@relation L _ _ k r v)     := (bit0 $ bit0 $ mkpair k $ mkpair (encode r) (encode v)) + 2
| n (@neg_relation L _ _ k r v) := (bit0 $ bit1 $ mkpair k $ mkpair (encode r) (encode v)) + 2
| n (and p q)                   := (bit1 $ bit0 $ bit0 $ mkpair p.to_nat q.to_nat) + 2
| n (or p q)                    := (bit1 $ bit0 $ bit1 $ mkpair p.to_nat q.to_nat) + 2
| n (fal p)                     := (bit1 $ bit1 $ bit0 p.to_nat) + 2
| n (ex p)                      := (bit1 $ bit1 $ bit1 p.to_nat) + 2

variables (L n)

@[simp] def of_nat : Π n, ℕ → option (subformula L ℕ n)
| n 0 := some verum
| n 1 := some falsum
| n (e + 2) :=
    let i := e.div2.div2.div2 in
    have div8 : i ≤ e := by simp[i, nat.div2_val];
      exact le_trans (nat.div_le_self (e / 2 / 2) 2) (le_trans (nat.div_le_self (e/2) 2) (nat.div_le_self e 2)),
    have hi : i < e + 2, from lt.step (lt_succ_iff.mpr div8),
    have hi1 : i.unpair.1 < e + 2, from (lt.step $ nat.lt_succ_iff.mpr (le_trans (nat.unpair_left_le _) div8)),
    have hi2 : i.unpair.2 < e + 2, from (lt.step $ nat.lt_succ_iff.mpr (le_trans (nat.unpair_right_le _) div8)),
    match e.bodd with
    | ff :=
      match e.div2.bodd with
      | ff :=
        let x := e.div2.div2,
            k := x.unpair.1,
            r := decode₂ (L.pr k) x.unpair.2.unpair.1,
            v := decode₂ (fin k → subterm L ℕ n) x.unpair.2.unpair.2 in
        r.bind (λ r, v.map (relation r))
      | tt :=
        let x := e.div2.div2,
            k := x.unpair.1,
            r := decode₂ (L.pr k) x.unpair.2.unpair.1,
            v := decode₂ (fin k → subterm L ℕ n) x.unpair.2.unpair.2 in
        r.bind (λ r, v.map (neg_relation r))
      end
    | tt :=
      match e.div2.bodd, e.div2.div2.bodd with
      | ff, ff := (of_nat n i.unpair.1).bind (λ p, (of_nat n i.unpair.2).map (and p))
      | ff, tt := (of_nat n i.unpair.1).bind (λ p, (of_nat n i.unpair.2).map (or p))
      | tt, ff := (of_nat (n + 1) i).map fal
      | tt, tt := (of_nat (n + 1) i).map ex
      end
    end
using_well_founded {rel_tac := λ _ _, `[exact ⟨_, measure_wf (λ x, x.2)⟩]}

@[simp] lemma of_nat_to_nat : ∀ {n} (p : subformula L ℕ n), of_nat L n p.to_nat = some p
| n verum                       := by simp
| n falsum                      := by simp
| n (@relation L _ _ k r v)     :=
    begin
      simp only [to_nat, of_nat, nat.bodd_bit0, nat.div2_bit0, nat.unpair_mkpair],
      rw[show (unpair (bit0 (bit0 (mkpair k (mkpair (encode r) (encode v))))).div2.div2).fst = k, by simp],
      simp only [decode₂_encode, option.some_bind', option.map_some', heq.refl], simp
    end
| n (@neg_relation L _ _ k r v) :=
    begin
      simp only [to_nat, of_nat, nat.bodd_bit0, nat.bodd_bit1, nat.div2_bit0, nat.div2_bit1, nat.unpair_mkpair],
      rw[show (unpair (bit0 (bit1 (mkpair k (mkpair (encode r) (encode v))))).div2.div2).fst = k, by simp],
      simp only [decode₂_encode, option.some_bind', option.map_some', heq.refl], simp
    end
| n (and p q)                   := by simp; refine ⟨of_nat_to_nat p, of_nat_to_nat q⟩
| n (or p q)                    := by simp; refine ⟨of_nat_to_nat p, of_nat_to_nat q⟩
| n (fal p)                     := by simp; refine (of_nat_to_nat p)
| n (ex p)                      := by simp; refine (of_nat_to_nat p)

instance (n) : encodable (subformula L ℕ n) :=
{ encode := to_nat,
  decode := of_nat L n,
  encodek := by simp }

variables {L m n}

def index : bounded_subformula L m n → ℕ := λ p, encodable.encode p.uniform

variables (L m n)

def of_index : ℕ → option (bounded_subformula L m n) := λ i,
  let p := encodable.decode₂ (subformula L ℕ n) i in
  p.bind (λ p, if h : p.arity ≤ m then some (p.to_bform h) else none)

variables {L m n}

@[simp] lemma of_index_index (p : bounded_subformula L m n) : of_index L m n p.index = some p :=
by simp[index, of_index]

@[simp] lemma mlift_index (p : bounded_subformula L m n) : p.mlift.index = p.index :=
by simp[index]

@[simp] lemma cast_le_index {m₁ m₂ : ℕ} (h : m₁ ≤ m₂) (p : bounded_subformula L m₁ n) :
  (cast_le h p).index = p.index :=
by simp[index]

@[simp] lemma of_nat_uniform (p : bounded_subformula L m n) : encodable.decode₂ (subformula L ℕ n) p.index = p.uniform :=
by simp[index]; refl

@[simp] lemma index_eq_some {e} {p : bounded_subformula L m n} : of_index L m n e = some p ↔ p.index = e :=
by { simp[of_index, index, encodable.decode₂_eq_some, dite_eq_iff], split,
  { simp, rintros _ rfl h rfl, simp },
  { rintros rfl, refine ⟨p.uniform, rfl, by simp⟩ } }

lemma of_index_eq_some {m₁ m₂} {p : bounded_subformula L m₁ n} {q : bounded_subformula L m₂ n} :
  p.index = q.index ↔ p.uniform = q.uniform :=
by simp[index]

@[simp] lemma index_inj {p q : bounded_subformula L m n} : p.index = q.index ↔ p = q :=
by simp[index]

end encode

end subformula

end Tait

end fol


/-
File: signature_recover_public_key_compute_slope_soundness.lean

Autogenerated file.
-/
import starkware.cairo.lean.semantics.soundness.hoare
import .signature_recover_public_key_code
import ..signature_recover_public_key_spec
import .signature_recover_public_key_verify_zero_soundness
import .signature_recover_public_key_unreduced_mul_soundness
import .signature_recover_public_key_nondet_bigint3_soundness
open tactic

open starkware.cairo.common.cairo_secp.ec
open starkware.cairo.common.cairo_secp.bigint
open starkware.cairo.common.cairo_secp.field

variables {F : Type} [field F] [decidable_eq F] [prelude_hyps F]
variable  mem : F → F
variable  σ : register_state F

/- starkware.cairo.common.cairo_secp.ec.compute_slope autogenerated soundness theorem -/

theorem auto_sound_compute_slope
    -- arguments
    (range_check_ptr : F) (point0 point1 : EcPoint F)
    -- code is in memory at σ.pc
    (h_mem : mem_at mem code_compute_slope σ.pc)
    -- all dependencies are in memory
    (h_mem_4 : mem_at mem code_nondet_bigint3 (σ.pc  - 220))
    (h_mem_5 : mem_at mem code_unreduced_mul (σ.pc  - 208))
    (h_mem_7 : mem_at mem code_verify_zero (σ.pc  - 172))
    -- input arguments on the stack
    (hin_range_check_ptr : range_check_ptr = mem (σ.fp - 15))
    (hin_point0 : point0 = cast_EcPoint mem (σ.fp - 14))
    (hin_point1 : point1 = cast_EcPoint mem (σ.fp - 8))
    -- conclusion
  : ensures_ret mem σ (λ κ τ,
      τ.ap = σ.ap + 59 ∧
      ∃ μ ≤ κ, rc_ensures mem (rc_bound F) μ (mem (σ.fp - 15)) (mem $ τ.ap - 4)
        (spec_compute_slope mem κ range_check_ptr point0 point1 (mem (τ.ap - 4)) (cast_BigInt3 mem (τ.ap - 3)))) :=
begin
  apply ensures_of_ensuresb, intro νbound,
  have h_mem_rec := h_mem,
  unpack_memory code_compute_slope at h_mem with ⟨hpc0, hpc1, hpc2, hpc3, hpc4, hpc5, hpc6, hpc7, hpc8, hpc9, hpc10, hpc11, hpc12, hpc13, hpc14, hpc15, hpc16, hpc17, hpc18, hpc19, hpc20, hpc21, hpc22, hpc23⟩,
  -- function call
  step_assert_eq hpc0 with arg0,
  step_sub hpc1 (auto_sound_nondet_bigint3 mem _ range_check_ptr _ _),
  { rw hpc2, norm_num2, exact h_mem_4 },
  { try { simp only [add_neg_eq_sub, hin_range_check_ptr, hin_point0, hin_point1] },
    try { dsimp [cast_EcPoint, cast_BigInt3] },
    try { arith_simps }, try { simp only [arg0] },
    try { arith_simps; try { split }; triv <|> refl <|> simp <|> abel; try { norm_num } }, },
  intros κ_call3 ap3 h_call3,
  rcases h_call3 with ⟨h_call3_ap_offset, h_call3⟩,
  rcases h_call3 with ⟨rc_m3, rc_mle3, hl_range_check_ptr₁, h_call3⟩,
  generalize' hr_rev_range_check_ptr₁: mem (ap3 - 4) = range_check_ptr₁,
  have htv_range_check_ptr₁ := hr_rev_range_check_ptr₁.symm, clear hr_rev_range_check_ptr₁,
  generalize' hr_rev_slope: cast_BigInt3 mem (ap3 - 3) = slope,
  simp only [hr_rev_slope] at h_call3,
  have htv_slope := hr_rev_slope.symm, clear hr_rev_slope,
  try { simp only [arg0] at hl_range_check_ptr₁ },
  rw [←htv_range_check_ptr₁, ←hin_range_check_ptr] at hl_range_check_ptr₁,
  try { simp only [arg0] at h_call3 },
  rw [hin_range_check_ptr] at h_call3,
  clear arg0,
  -- let
  generalize' hl_rev_x_diff: ({
    d0 := point0.x.d0 - point1.x.d0,
    d1 := point0.x.d1 - point1.x.d1,
    d2 := point0.x.d2 - point1.x.d2
  } : BigInt3 F) = x_diff,
  have hl_x_diff := hl_rev_x_diff.symm, clear hl_rev_x_diff,
  try { dsimp at hl_x_diff }, try { arith_simps at hl_x_diff },
  -- function call
  step_assert_eq hpc3 with arg0,
  step_assert_eq hpc4 with arg1,
  step_assert_eq hpc5 with arg2,
  step_assert_eq hpc6 with arg3,
  step_assert_eq hpc7 with arg4,
  step_assert_eq hpc8 with arg5,
  step_sub hpc9 (auto_sound_unreduced_mul mem _ x_diff slope _ _ _),
  { rw hpc10, norm_num2, exact h_mem_5 },
  { try { ext } ; {
      try { simp only [add_neg_eq_sub, hin_range_check_ptr, hin_point0, hin_point1, htv_range_check_ptr₁, htv_slope, hl_x_diff] },
      try { dsimp [cast_EcPoint, cast_BigInt3] },
      try { arith_simps }, try { simp only [(eq_sub_of_eq_add arg0), (eq_sub_of_eq_add arg1), (eq_sub_of_eq_add arg2), arg3, arg4, arg5] },
      try { simp only [h_call3_ap_offset] },
      try { arith_simps; try { split }; triv <|> refl <|> simp <|> abel; try { norm_num } },}, },
  { try { ext } ; {
      try { simp only [add_neg_eq_sub, hin_range_check_ptr, hin_point0, hin_point1, htv_range_check_ptr₁, htv_slope, hl_x_diff] },
      try { dsimp [cast_EcPoint, cast_BigInt3] },
      try { arith_simps }, try { simp only [(eq_sub_of_eq_add arg0), (eq_sub_of_eq_add arg1), (eq_sub_of_eq_add arg2), arg3, arg4, arg5] },
      try { simp only [h_call3_ap_offset] },
      try { arith_simps; try { split }; triv <|> refl <|> simp <|> abel; try { norm_num } },}, },
  intros κ_call11 ap11 h_call11,
  rcases h_call11 with ⟨h_call11_ap_offset, h_call11⟩,
  generalize' hr_rev_x_diff_slope: cast_UnreducedBigInt3 mem (ap11 - 3) = x_diff_slope,
  simp only [hr_rev_x_diff_slope] at h_call11,
  have htv_x_diff_slope := hr_rev_x_diff_slope.symm, clear hr_rev_x_diff_slope,
  clear arg0 arg1 arg2 arg3 arg4 arg5,
  -- function call
  step_assert_eq hpc11 with arg0,
  step_assert_eq hpc12 with arg1,
  step_assert_eq hpc13 with arg2,
  step_assert_eq hpc14 with arg3,
  step_assert_eq hpc15 with arg4,
  step_assert_eq hpc16 with arg5,
  step_assert_eq hpc17 with arg6,
  step_sub hpc18 (auto_sound_verify_zero mem _ range_check_ptr₁ {
    d0 := x_diff_slope.d0 - point0.y.d0 + point1.y.d0,
    d1 := x_diff_slope.d1 - point0.y.d1 + point1.y.d1,
    d2 := x_diff_slope.d2 - point0.y.d2 + point1.y.d2
  } _ _ _),
  { rw hpc19, norm_num2, exact h_mem_7 },
  { try { simp only [add_neg_eq_sub, hin_range_check_ptr, hin_point0, hin_point1, htv_range_check_ptr₁, htv_slope, hl_x_diff, htv_x_diff_slope] },
    try { dsimp [cast_EcPoint, cast_BigInt3, cast_UnreducedBigInt3] },
    try { arith_simps }, try { simp only [(eq_sub_of_eq_add arg0), (eq_sub_of_eq_add arg1), (eq_sub_of_eq_add arg2), arg3, arg4, arg5, arg6] },
    try { simp only [h_call3_ap_offset, h_call11_ap_offset] },
    try { arith_simps; try { split }; triv <|> refl <|> simp <|> abel; try { norm_num } }, },
  { try { ext } ; {
      try { simp only [add_neg_eq_sub, hin_range_check_ptr, hin_point0, hin_point1, htv_range_check_ptr₁, htv_slope, hl_x_diff, htv_x_diff_slope] },
      try { dsimp [cast_EcPoint, cast_BigInt3, cast_UnreducedBigInt3] },
      try { arith_simps }, try { simp only [(eq_sub_of_eq_add arg0), (eq_sub_of_eq_add arg1), (eq_sub_of_eq_add arg2), arg3, arg4, arg5, arg6] },
      try { simp only [h_call3_ap_offset, h_call11_ap_offset] },
      try { arith_simps; try { split }; triv <|> refl <|> simp <|> abel; try { norm_num } },}, },
  intros κ_call20 ap20 h_call20,
  rcases h_call20 with ⟨h_call20_ap_offset, h_call20⟩,
  rcases h_call20 with ⟨rc_m20, rc_mle20, hl_range_check_ptr₂, h_call20⟩,
  generalize' hr_rev_range_check_ptr₂: mem (ap20 - 1) = range_check_ptr₂,
  have htv_range_check_ptr₂ := hr_rev_range_check_ptr₂.symm, clear hr_rev_range_check_ptr₂,
  try { simp only [arg0 ,arg1 ,arg2 ,arg3 ,arg4 ,arg5 ,arg6] at hl_range_check_ptr₂ },
  try { rw [h_call11_ap_offset] at hl_range_check_ptr₂ }, try { arith_simps at hl_range_check_ptr₂ },
  rw [←htv_range_check_ptr₂, ←htv_range_check_ptr₁] at hl_range_check_ptr₂,
  try { simp only [arg0 ,arg1 ,arg2 ,arg3 ,arg4 ,arg5 ,arg6] at h_call20 },
  try { rw [h_call11_ap_offset] at h_call20 }, try { arith_simps at h_call20 },
  rw [←htv_range_check_ptr₁, hl_range_check_ptr₁, hin_range_check_ptr] at h_call20,
  clear arg0 arg1 arg2 arg3 arg4 arg5 arg6,
  -- return
  step_assert_eq hpc20 with hret0,
  step_assert_eq hpc21 with hret1,
  step_assert_eq hpc22 with hret2,
  step_ret hpc23,
  -- finish
  step_done, use_only [rfl, rfl],
  split,
  { try { simp only [h_call3_ap_offset ,h_call11_ap_offset ,h_call20_ap_offset] },
    try { arith_simps }, try { refl } },
  -- range check condition
  use_only (rc_m3+rc_m20+0+0), split,
  linarith [rc_mle3, rc_mle20],
  split,
  { arith_simps, try { simp only [hret0 ,hret1 ,hret2] },
    rw [←htv_range_check_ptr₂, hl_range_check_ptr₂, hl_range_check_ptr₁, hin_range_check_ptr],
    try { arith_simps, refl <|> norm_cast }, try { refl } },
  intro rc_h_range_check_ptr, repeat { rw [add_assoc] at rc_h_range_check_ptr },
  have rc_h_range_check_ptr' := range_checked_add_right rc_h_range_check_ptr,
  -- Final Proof
  -- user-provided reduction
  suffices auto_spec: auto_spec_compute_slope mem _ range_check_ptr point0 point1 _ _,
  { apply sound_compute_slope, apply auto_spec },
  -- prove the auto generated assertion
  dsimp [auto_spec_compute_slope],
  try { norm_num1 }, try { arith_simps },
  use_only [κ_call3],
  use_only [range_check_ptr₁],
  use_only [slope],
  have rc_h_range_check_ptr₁ := range_checked_offset' rc_h_range_check_ptr,
  have rc_h_range_check_ptr₁' := range_checked_add_right rc_h_range_check_ptr₁, try { norm_cast at rc_h_range_check_ptr₁' },
  have spec3 := h_call3 rc_h_range_check_ptr',
  rw [←hin_range_check_ptr, ←htv_range_check_ptr₁] at spec3,
  try { dsimp at spec3, arith_simps at spec3 },
  use_only [spec3],
  use_only [x_diff, hl_x_diff],
  use_only [κ_call11],
  use_only [x_diff_slope],
  try { dsimp at h_call11, arith_simps at h_call11 },
  try { use_only [h_call11] },
  use_only [κ_call20],
  use_only [range_check_ptr₂],
  have rc_h_range_check_ptr₂ := range_checked_offset' rc_h_range_check_ptr₁,
  have rc_h_range_check_ptr₂' := range_checked_add_right rc_h_range_check_ptr₂, try { norm_cast at rc_h_range_check_ptr₂' },
  have spec20 := h_call20 rc_h_range_check_ptr₁',
  rw [←hin_range_check_ptr, ←hl_range_check_ptr₁, ←htv_range_check_ptr₂] at spec20,
  try { dsimp at spec20, arith_simps at spec20 },
  use_only [spec20],
  try { split, linarith },
  try { ensures_simps; try { simp only [add_neg_eq_sub, hin_range_check_ptr, hin_point0, hin_point1, htv_range_check_ptr₁, htv_slope, hl_x_diff, htv_x_diff_slope, htv_range_check_ptr₂] }, },
  try { dsimp [cast_EcPoint, cast_BigInt3, cast_UnreducedBigInt3] },
  try { arith_simps }, try { simp only [hret0, hret1, hret2] },
  try { simp only [h_call3_ap_offset, h_call11_ap_offset, h_call20_ap_offset] },
  try { arith_simps; try { split }; triv <|> refl <|> simp <|> abel; try { norm_num } },
end


/-
Copyright (c) 2021 Eric Wieser. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Eric Wieser
-/
import group_theory.subgroup.basic
import algebra.graded_monoid
import algebra.direct_sum.basic
import algebra.big_operators.pi

/-!
# Additively-graded multiplicative structures on `⨁ i, A i`

This module provides a set of heterogeneous typeclasses for defining a multiplicative structure
over `⨁ i, A i` such that `(*) : A i → A j → A (i + j)`; that is to say, `A` forms an
additively-graded ring. The typeclasses are:

* `direct_sum.gnon_unital_non_assoc_semiring A`
* `direct_sum.gsemiring A`
* `direct_sum.gring A`
* `direct_sum.gcomm_semiring A`
* `direct_sum.gcomm_ring A`

Respectively, these imbue the external direct sum `⨁ i, A i` with:

* `direct_sum.non_unital_non_assoc_semiring`, `direct_sum.non_unital_non_assoc_ring`
* `direct_sum.semiring`
* `direct_sum.ring`
* `direct_sum.comm_semiring`
* `direct_sum.comm_ring`

the base ring `A 0` with:

* `direct_sum.grade_zero.non_unital_non_assoc_semiring`,
  `direct_sum.grade_zero.non_unital_non_assoc_ring`
* `direct_sum.grade_zero.semiring`
* `direct_sum.grade_zero.ring`
* `direct_sum.grade_zero.comm_semiring`
* `direct_sum.grade_zero.comm_ring`

and the `i`th grade `A i` with `A 0`-actions (`•`) defined as left-multiplication:

* `direct_sum.grade_zero.has_smul (A 0)`, `direct_sum.grade_zero.smul_with_zero (A 0)`
* `direct_sum.grade_zero.module (A 0)`
* (nothing)
* (nothing)
* (nothing)

Note that in the presence of these instances, `⨁ i, A i` itself inherits an `A 0`-action.

`direct_sum.of_zero_ring_hom : A 0 →+* ⨁ i, A i` provides `direct_sum.of A 0` as a ring
homomorphism.

`direct_sum.to_semiring` extends `direct_sum.to_add_monoid` to produce a `ring_hom`.

## Direct sums of subobjects

Additionally, this module provides helper functions to construct `gsemiring` and `gcomm_semiring`
instances for:

* `A : ι → submonoid S`:
  `direct_sum.gsemiring.of_add_submonoids`, `direct_sum.gcomm_semiring.of_add_submonoids`.
* `A : ι → subgroup S`:
  `direct_sum.gsemiring.of_add_subgroups`, `direct_sum.gcomm_semiring.of_add_subgroups`.
* `A : ι → submodule S`:
  `direct_sum.gsemiring.of_submodules`, `direct_sum.gcomm_semiring.of_submodules`.

If `complete_lattice.independent (set.range A)`, these provide a gradation of `⨆ i, A i`, and the
mapping `⨁ i, A i →+ ⨆ i, A i` can be obtained as
`direct_sum.to_monoid (λ i, add_submonoid.inclusion $ le_supr A i)`.

## tags

graded ring, filtered ring, direct sum, add_submonoid
-/

set_option old_structure_cmd true

variables {ι : Type*} [decidable_eq ι]

namespace direct_sum

open_locale direct_sum

/-! ### Typeclasses -/
section defs

variables (A : ι → Type*)

/-- A graded version of `non_unital_non_assoc_semiring`. -/
class gnon_unital_non_assoc_semiring [has_add ι] [Π i, add_comm_monoid (A i)] extends
  graded_monoid.ghas_mul A :=
(mul_zero : ∀ {i j} (a : A i), mul a (0 : A j) = 0)
(zero_mul : ∀ {i j} (b : A j), mul (0 : A i) b = 0)
(mul_add : ∀ {i j} (a : A i) (b c : A j), mul a (b + c) = mul a b + mul a c)
(add_mul : ∀ {i j} (a b : A i) (c : A j), mul (a + b) c = mul a c + mul b c)

end defs

section defs

variables (A : ι → Type*)

/-- A graded version of `semiring`. -/
class gsemiring [add_monoid ι] [Π i, add_comm_monoid (A i)] extends
  gnon_unital_non_assoc_semiring A, graded_monoid.gmonoid A :=
(nat_cast : ℕ → A 0)
(nat_cast_zero : nat_cast 0 = 0)
(nat_cast_succ : ∀ n : ℕ, nat_cast (n + 1) = nat_cast n + graded_monoid.ghas_one.one)

/-- A graded version of `comm_semiring`. -/
class gcomm_semiring [add_comm_monoid ι] [Π i, add_comm_monoid (A i)] extends
  gsemiring A, graded_monoid.gcomm_monoid A

/-- A graded version of `ring`. -/
class gring [add_monoid ι] [Π i, add_comm_group (A i)] extends gsemiring A :=
(int_cast : ℤ → A 0)
(int_cast_of_nat : ∀ n : ℕ, int_cast n = nat_cast n)
(int_cast_neg_succ_of_nat : ∀ n : ℕ, int_cast (-(n+1 : ℕ)) = -nat_cast (n+1 : ℕ))

/-- A graded version of `comm_ring`. -/
class gcomm_ring [add_comm_monoid ι] [Π i, add_comm_group (A i)] extends
  gring A, gcomm_semiring A

end defs

lemma of_eq_of_graded_monoid_eq {A : ι → Type*} [Π (i : ι), add_comm_monoid (A i)]
  {i j : ι} {a : A i} {b : A j} (h : graded_monoid.mk i a = graded_monoid.mk j b) :
  direct_sum.of A i a = direct_sum.of A j b :=
dfinsupp.single_eq_of_sigma_eq h

variables (A : ι → Type*)

/-! ### Instances for `⨁ i, A i` -/

section one
variables [has_zero ι] [graded_monoid.ghas_one A] [Π i, add_comm_monoid (A i)]

instance : has_one (⨁ i, A i) :=
{ one := direct_sum.of (λ i, A i) 0 graded_monoid.ghas_one.one }

end one

section mul
variables [has_add ι] [Π i, add_comm_monoid (A i)] [gnon_unital_non_assoc_semiring A]

open add_monoid_hom (flip_apply coe_comp comp_hom_apply_apply)

/-- The piecewise multiplication from the `has_mul` instance, as a bundled homomorphism. -/
@[simps]
def gmul_hom {i j} : A i →+ A j →+ A (i + j) :=
{ to_fun := λ a,
  { to_fun := λ b, graded_monoid.ghas_mul.mul a b,
    map_zero' := gnon_unital_non_assoc_semiring.mul_zero _,
    map_add' := gnon_unital_non_assoc_semiring.mul_add _ },
  map_zero' := add_monoid_hom.ext $ λ a, gnon_unital_non_assoc_semiring.zero_mul a,
  map_add' := λ a₁ a₂, add_monoid_hom.ext $ λ b, gnon_unital_non_assoc_semiring.add_mul _ _ _}

/-- The multiplication from the `has_mul` instance, as a bundled homomorphism. -/
def mul_hom : (⨁ i, A i) →+ (⨁ i, A i) →+ ⨁ i, A i :=
direct_sum.to_add_monoid $ λ i,
  add_monoid_hom.flip $ direct_sum.to_add_monoid $ λ j, add_monoid_hom.flip $
    (direct_sum.of A _).comp_hom.comp $ gmul_hom A

instance : non_unital_non_assoc_semiring (⨁ i, A i) :=
{ mul := λ a b, mul_hom A a b,
  zero := 0,
  add := (+),
  zero_mul := λ a, by simp only [add_monoid_hom.map_zero, add_monoid_hom.zero_apply],
  mul_zero := λ a, by simp only [add_monoid_hom.map_zero],
  left_distrib := λ a b c, by simp only [add_monoid_hom.map_add],
  right_distrib := λ a b c, by simp only [add_monoid_hom.map_add, add_monoid_hom.add_apply],
  .. direct_sum.add_comm_monoid _ _}

variables {A}

lemma mul_hom_of_of {i j} (a : A i) (b : A j) :
  mul_hom A (of _ i a) (of _ j b) = of _ (i + j) (graded_monoid.ghas_mul.mul a b) :=
begin
  unfold mul_hom,
  rw [to_add_monoid_of, flip_apply, to_add_monoid_of, flip_apply, coe_comp, function.comp_app,
      comp_hom_apply_apply, coe_comp, function.comp_app, gmul_hom_apply_apply],
end

lemma of_mul_of {i j} (a : A i) (b : A j) :
  of _ i a * of _ j b = of _ (i + j) (graded_monoid.ghas_mul.mul a b) :=
mul_hom_of_of a b

end mul

section semiring
variables [Π i, add_comm_monoid (A i)] [add_monoid ι] [gsemiring A]

open add_monoid_hom (flip_hom coe_comp comp_hom_apply_apply flip_apply flip_hom_apply)

private lemma one_mul (x : ⨁ i, A i) : 1 * x = x :=
suffices mul_hom A 1 = add_monoid_hom.id (⨁ i, A i),
  from add_monoid_hom.congr_fun this x,
begin
  apply add_hom_ext, intros i xi,
  unfold has_one.one,
  rw mul_hom_of_of,
  exact of_eq_of_graded_monoid_eq (one_mul $ graded_monoid.mk i xi),
end

private lemma mul_one (x : ⨁ i, A i) : x * 1 = x :=
suffices (mul_hom A).flip 1 = add_monoid_hom.id (⨁ i, A i),
  from add_monoid_hom.congr_fun this x,
begin
  apply add_hom_ext, intros i xi,
  unfold has_one.one,
  rw [flip_apply, mul_hom_of_of],
  exact of_eq_of_graded_monoid_eq (mul_one $ graded_monoid.mk i xi),
end

private lemma mul_assoc (a b c : ⨁ i, A i) : a * b * c = a * (b * c) :=
suffices (mul_hom A).comp_hom.comp (mul_hom A)            -- `λ a b c, a * b * c` as a bundled hom
       = (add_monoid_hom.comp_hom flip_hom $              -- `λ a b c, a * (b * c)` as a bundled hom
             (mul_hom A).flip.comp_hom.comp (mul_hom A)).flip,
  from add_monoid_hom.congr_fun (add_monoid_hom.congr_fun (add_monoid_hom.congr_fun this a) b) c,
begin
  ext ai ax bi bx ci cx : 6,
  dsimp only [coe_comp, function.comp_app, comp_hom_apply_apply, flip_apply, flip_hom_apply],
  rw [mul_hom_of_of, mul_hom_of_of, mul_hom_of_of, mul_hom_of_of],
  exact of_eq_of_graded_monoid_eq (mul_assoc (graded_monoid.mk ai ax) ⟨bi, bx⟩ ⟨ci, cx⟩),
end

/-- The `semiring` structure derived from `gsemiring A`. -/
instance semiring : semiring (⨁ i, A i) :=
{ one := 1,
  mul := (*),
  zero := 0,
  add := (+),
  one_mul := one_mul A,
  mul_one := mul_one A,
  mul_assoc := mul_assoc A,
  nat_cast := λ n, of _ _ (gsemiring.nat_cast n),
  nat_cast_zero := by rw [gsemiring.nat_cast_zero, map_zero],
  nat_cast_succ := λ n, by { rw [gsemiring.nat_cast_succ, map_add], refl },
  ..direct_sum.non_unital_non_assoc_semiring _, }

lemma of_pow {i} (a : A i) (n : ℕ) :
  of _ i a ^ n = of _ (n • i) (graded_monoid.gmonoid.gnpow _ a) :=
begin
  induction n with n,
  { exact of_eq_of_graded_monoid_eq (pow_zero $ graded_monoid.mk _ a).symm, },
  { rw [pow_succ, n_ih, of_mul_of],
    exact of_eq_of_graded_monoid_eq (pow_succ (graded_monoid.mk _ a) n).symm, },
end

lemma of_list_dprod {α} (l : list α) (fι : α → ι) (fA : Π a, A (fι a)) :
  of A _ (l.dprod fι fA) = (l.map $ λ a, of A (fι a) (fA a)).prod :=
begin
  induction l,
  { simp only [list.map_nil, list.prod_nil, list.dprod_nil],
    refl },
  { simp only [list.map_cons, list.prod_cons, list.dprod_cons, ←l_ih, direct_sum.of_mul_of],
    refl },
end

lemma list_prod_of_fn_of_eq_dprod (n : ℕ) (fι : fin n → ι) (fA : Π a, A (fι a)) :
  (list.of_fn $ λ a, of A (fι a) (fA a)).prod = of A _ ((list.fin_range n).dprod fι fA) :=
by rw [list.of_fn_eq_map, of_list_dprod]

open_locale big_operators

/-- A heavily unfolded version of the definition of multiplication -/
lemma mul_eq_sum_support_ghas_mul
  [Π (i : ι) (x : A i), decidable (x ≠ 0)] (a a' : ⨁ i, A i) :
  a * a' =
    ∑ (ij : ι × ι) in (dfinsupp.support a).product (dfinsupp.support a'),
      direct_sum.of _ _ (graded_monoid.ghas_mul.mul (a ij.fst) (a' ij.snd)) :=
begin
  change direct_sum.mul_hom _ a a' = _,
  dsimp [direct_sum.mul_hom, direct_sum.to_add_monoid, dfinsupp.lift_add_hom_apply],
  simp only [dfinsupp.sum_add_hom_apply, dfinsupp.sum, dfinsupp.finset_sum_apply,
    add_monoid_hom.coe_finset_sum, finset.sum_apply, add_monoid_hom.flip_apply,
    add_monoid_hom.comp_hom_apply_apply, add_monoid_hom.comp_apply,
    direct_sum.gmul_hom_apply_apply],
  rw finset.sum_product,
end

end semiring

section comm_semiring

variables [Π i, add_comm_monoid (A i)] [add_comm_monoid ι] [gcomm_semiring A]

private lemma mul_comm (a b : ⨁ i, A i) : a * b = b * a :=
suffices mul_hom A = (mul_hom A).flip,
  from add_monoid_hom.congr_fun (add_monoid_hom.congr_fun this a) b,
begin
  apply add_hom_ext, intros ai ax, apply add_hom_ext, intros bi bx,
  rw [add_monoid_hom.flip_apply, mul_hom_of_of, mul_hom_of_of],
  exact of_eq_of_graded_monoid_eq (gcomm_semiring.mul_comm ⟨ai, ax⟩ ⟨bi, bx⟩),
end

/-- The `comm_semiring` structure derived from `gcomm_semiring A`. -/
instance comm_semiring : comm_semiring (⨁ i, A i) :=
{ one := 1,
  mul := (*),
  zero := 0,
  add := (+),
  mul_comm := mul_comm A,
  ..direct_sum.semiring _, }

end comm_semiring

section non_unital_non_assoc_ring
variables [Π i, add_comm_group (A i)] [has_add ι] [gnon_unital_non_assoc_semiring A]

/-- The `ring` derived from `gsemiring A`. -/
instance non_assoc_ring : non_unital_non_assoc_ring (⨁ i, A i) :=
{ mul := (*),
  zero := 0,
  add := (+),
  neg := has_neg.neg,
  ..(direct_sum.non_unital_non_assoc_semiring _),
  ..(direct_sum.add_comm_group _), }

end non_unital_non_assoc_ring

section ring
variables [Π i, add_comm_group (A i)] [add_monoid ι] [gring A]

/-- The `ring` derived from `gsemiring A`. -/
instance ring : ring (⨁ i, A i) :=
{ one := 1,
  mul := (*),
  zero := 0,
  add := (+),
  neg := has_neg.neg,
  int_cast := λ z, of _ _ (gring.int_cast z),
  int_cast_of_nat := λ z, congr_arg _ $ gring.int_cast_of_nat _,
  int_cast_neg_succ_of_nat := λ z,
    (congr_arg _ $ gring.int_cast_neg_succ_of_nat _).trans (map_neg _ _),
  ..(direct_sum.semiring _),
  ..(direct_sum.add_comm_group _), }

end ring

section comm_ring
variables [Π i, add_comm_group (A i)] [add_comm_monoid ι] [gcomm_ring A]

/-- The `comm_ring` derived from `gcomm_semiring A`. -/
instance comm_ring : comm_ring (⨁ i, A i) :=
{ one := 1,
  mul := (*),
  zero := 0,
  add := (+),
  neg := has_neg.neg,
  ..(direct_sum.ring _),
  ..(direct_sum.comm_semiring _), }

end comm_ring

/-! ### Instances for `A 0`

The various `g*` instances are enough to promote the `add_comm_monoid (A 0)` structure to various
types of multiplicative structure.
-/

section grade_zero

section one
variables [has_zero ι] [graded_monoid.ghas_one A] [Π i, add_comm_monoid (A i)]

@[simp] lemma of_zero_one : of _ 0 (1 : A 0) = 1 := rfl

end one

section mul
variables [add_zero_class ι] [Π i, add_comm_monoid (A i)] [gnon_unital_non_assoc_semiring A]

@[simp] lemma of_zero_smul {i} (a : A 0) (b : A i) : of _ _ (a • b) = of _ _ a * of _ _ b :=
(of_eq_of_graded_monoid_eq (graded_monoid.mk_zero_smul a b)).trans (of_mul_of _ _).symm

@[simp] lemma of_zero_mul (a b : A 0) : of _ 0 (a * b) = of _ 0 a * of _ 0 b:=
of_zero_smul A a b

instance grade_zero.non_unital_non_assoc_semiring : non_unital_non_assoc_semiring (A 0) :=
function.injective.non_unital_non_assoc_semiring (of A 0) dfinsupp.single_injective
  (of A 0).map_zero (of A 0).map_add (of_zero_mul A) (λ x n, dfinsupp.single_smul n x)

instance grade_zero.smul_with_zero (i : ι) : smul_with_zero (A 0) (A i) :=
begin
  letI := smul_with_zero.comp_hom (⨁ i, A i) (of A 0).to_zero_hom,
  refine dfinsupp.single_injective.smul_with_zero (of A i).to_zero_hom (of_zero_smul A),
end

end mul

section semiring
variables [Π i, add_comm_monoid (A i)] [add_monoid ι] [gsemiring A]

@[simp] lemma of_zero_pow (a : A 0) : ∀ n : ℕ, of _ 0 (a ^ n) = of _ 0 a ^ n
| 0 := by rw [pow_zero, pow_zero, direct_sum.of_zero_one]
| (n + 1) := by rw [pow_succ, pow_succ, of_zero_mul, of_zero_pow]

instance : has_nat_cast (A 0) := ⟨gsemiring.nat_cast⟩

@[simp] lemma of_nat_cast (n : ℕ) : of A 0 n = n :=
rfl

/-- The `semiring` structure derived from `gsemiring A`. -/
instance grade_zero.semiring : semiring (A 0) :=
function.injective.semiring (of A 0) dfinsupp.single_injective
  (of A 0).map_zero (of_zero_one A) (of A 0).map_add (of_zero_mul A)
  (of A 0).map_nsmul (λ x n, of_zero_pow _ _ _) (of_nat_cast A)

/-- `of A 0` is a `ring_hom`, using the `direct_sum.grade_zero.semiring` structure. -/
def of_zero_ring_hom : A 0 →+* (⨁ i, A i) :=
{ map_one' := of_zero_one A, map_mul' := of_zero_mul A, ..(of _ 0) }

/-- Each grade `A i` derives a `A 0`-module structure from `gsemiring A`. Note that this results
in an overall `module (A 0) (⨁ i, A i)` structure via `direct_sum.module`.
-/
instance grade_zero.module {i} : module (A 0) (A i) :=
begin
  letI := module.comp_hom (⨁ i, A i) (of_zero_ring_hom A),
  exact dfinsupp.single_injective.module (A 0) (of A i) (λ a, of_zero_smul A a),
end

end semiring

section comm_semiring

variables [Π i, add_comm_monoid (A i)] [add_comm_monoid ι] [gcomm_semiring A]

/-- The `comm_semiring` structure derived from `gcomm_semiring A`. -/
instance grade_zero.comm_semiring : comm_semiring (A 0) :=
function.injective.comm_semiring (of A 0) dfinsupp.single_injective
  (of A 0).map_zero (of_zero_one A) (of A 0).map_add (of_zero_mul A)
  (λ x n, dfinsupp.single_smul n x) (λ x n, of_zero_pow _ _ _) (of_nat_cast A)

end comm_semiring

section ring
variables [Π i, add_comm_group (A i)] [add_zero_class ι] [gnon_unital_non_assoc_semiring A]

/-- The `non_unital_non_assoc_ring` derived from `gnon_unital_non_assoc_semiring A`. -/
instance grade_zero.non_unital_non_assoc_ring : non_unital_non_assoc_ring (A 0) :=
function.injective.non_unital_non_assoc_ring (of A 0) dfinsupp.single_injective
  (of A 0).map_zero (of A 0).map_add (of_zero_mul A)
  (of A 0).map_neg (of A 0).map_sub
  (λ x n, begin
    letI : Π i, distrib_mul_action ℕ (A i) := λ i, infer_instance,
    exact dfinsupp.single_smul n x
  end)
  (λ x n, begin
    letI : Π i, distrib_mul_action ℤ (A i) := λ i, infer_instance,
    exact dfinsupp.single_smul n x
  end)

end ring

section ring
variables [Π i, add_comm_group (A i)] [add_monoid ι] [gring A]

instance : has_int_cast (A 0) := ⟨gring.int_cast⟩

@[simp] lemma of_int_cast (n : ℤ) : of A 0 n = n :=
rfl

/-- The `ring` derived from `gsemiring A`. -/
instance grade_zero.ring : ring (A 0) :=
function.injective.ring (of A 0) dfinsupp.single_injective
  (of A 0).map_zero (of_zero_one A) (of A 0).map_add (of_zero_mul A)
  (of A 0).map_neg (of A 0).map_sub
  (λ x n, begin
    letI : Π i, distrib_mul_action ℕ (A i) := λ i, infer_instance,
    exact dfinsupp.single_smul n x
  end)
  (λ x n, begin
    letI : Π i, distrib_mul_action ℤ (A i) := λ i, infer_instance,
    exact dfinsupp.single_smul n x
  end) (λ x n, of_zero_pow _ _ _)
  (of_nat_cast A) (of_int_cast A)

end ring

section comm_ring
variables [Π i, add_comm_group (A i)] [add_comm_monoid ι] [gcomm_ring A]

/-- The `comm_ring` derived from `gcomm_semiring A`. -/
instance grade_zero.comm_ring : comm_ring (A 0) :=
function.injective.comm_ring (of A 0) dfinsupp.single_injective
  (of A 0).map_zero (of_zero_one A) (of A 0).map_add (of_zero_mul A)
  (of A 0).map_neg (of A 0).map_sub
  (λ x n, begin
    letI : Π i, distrib_mul_action ℕ (A i) := λ i, infer_instance,
    exact dfinsupp.single_smul n x
  end)
  (λ x n, begin
    letI : Π i, distrib_mul_action ℤ (A i) := λ i, infer_instance,
    exact dfinsupp.single_smul n x
  end) (λ x n, of_zero_pow _ _ _)
  (of_nat_cast A) (of_int_cast A)

end comm_ring

end grade_zero

section to_semiring

variables {R : Type*} [Π i, add_comm_monoid (A i)] [add_monoid ι] [gsemiring A] [semiring R]
variables {A}

/-- If two ring homomorphisms from `⨁ i, A i` are equal on each `of A i y`,
then they are equal.

See note [partially-applied ext lemmas]. -/
@[ext]
lemma ring_hom_ext' ⦃F G : (⨁ i, A i) →+* R⦄
  (h : ∀ i, (↑F : _ →+ R).comp (of A i) = (↑G : _ →+ R).comp (of A i)) : F = G :=
ring_hom.coe_add_monoid_hom_injective $ direct_sum.add_hom_ext' h

/-- Two `ring_hom`s out of a direct sum are equal if they agree on the generators. -/
lemma ring_hom_ext ⦃f g : (⨁ i, A i) →+* R⦄ (h : ∀ i x, f (of A i x) = g (of A i x)) :
  f = g :=
ring_hom_ext' $ λ i, add_monoid_hom.ext $ h i

/-- A family of `add_monoid_hom`s preserving `direct_sum.ghas_one.one` and `direct_sum.ghas_mul.mul`
describes a `ring_hom`s on `⨁ i, A i`. This is a stronger version of `direct_sum.to_monoid`.

Of particular interest is the case when `A i` are bundled subojects, `f` is the family of
coercions such as `add_submonoid.subtype (A i)`, and the `[gsemiring A]` structure originates from
`direct_sum.gsemiring.of_add_submonoids`, in which case the proofs about `ghas_one` and `ghas_mul`
can be discharged by `rfl`. -/
@[simps]
def to_semiring
  (f : Π i, A i →+ R) (hone : f _ (graded_monoid.ghas_one.one) = 1)
  (hmul : ∀ {i j} (ai : A i) (aj : A j), f _ (graded_monoid.ghas_mul.mul ai aj) = f _ ai * f _ aj) :
  (⨁ i, A i) →+* R :=
{ to_fun := to_add_monoid f,
  map_one' := begin
    change (to_add_monoid f) (of _ 0 _) = 1,
    rw to_add_monoid_of,
    exact hone
  end,
  map_mul' := begin
    rw (to_add_monoid f).map_mul_iff,
    ext xi xv yi yv : 4,
    show to_add_monoid f (of A xi xv * of A yi yv) =
         to_add_monoid f (of A xi xv) * to_add_monoid f (of A yi yv),
    rw [of_mul_of, to_add_monoid_of, to_add_monoid_of, to_add_monoid_of],
    exact hmul _ _,
  end,
  .. to_add_monoid f}

@[simp] lemma to_semiring_of (f : Π i, A i →+ R) (hone hmul) (i : ι) (x : A i) :
  to_semiring f hone hmul (of _ i x) = f _ x :=
to_add_monoid_of f i x

@[simp] lemma to_semiring_coe_add_monoid_hom (f : Π i, A i →+ R) (hone hmul):
  (to_semiring f hone hmul : (⨁ i, A i) →+ R) = to_add_monoid f := rfl

/-- Families of `add_monoid_hom`s preserving `direct_sum.ghas_one.one` and `direct_sum.ghas_mul.mul`
are isomorphic to `ring_hom`s on `⨁ i, A i`. This is a stronger version of `dfinsupp.lift_add_hom`.
-/
@[simps]
def lift_ring_hom :
  {f : Π {i}, A i →+ R //
    f (graded_monoid.ghas_one.one) = 1 ∧
    ∀ {i j} (ai : A i) (aj : A j), f (graded_monoid.ghas_mul.mul ai aj) = f ai * f aj} ≃
    ((⨁ i, A i) →+* R) :=
{ to_fun := λ f, to_semiring f.1 f.2.1 f.2.2,
  inv_fun := λ F,
    ⟨λ i, (F : (⨁ i, A i) →+ R).comp (of _ i), begin
      simp only [add_monoid_hom.comp_apply, ring_hom.coe_add_monoid_hom],
      rw ←F.map_one,
      refl
    end, λ i j ai aj, begin
      simp only [add_monoid_hom.comp_apply, ring_hom.coe_add_monoid_hom],
      rw [←F.map_mul, of_mul_of],
    end⟩,
  left_inv := λ f, begin
    ext xi xv,
    exact to_add_monoid_of f.1 xi xv,
  end,
  right_inv := λ F, begin
    apply ring_hom.coe_add_monoid_hom_injective,
    ext xi xv,
    simp only [ring_hom.coe_add_monoid_hom_mk,
      direct_sum.to_add_monoid_of,
      add_monoid_hom.mk_coe,
      add_monoid_hom.comp_apply, to_semiring_coe_add_monoid_hom],
  end}

end to_semiring

end direct_sum

/-! ### Concrete instances -/

section uniform

variables (ι)

/-- A direct sum of copies of a `semiring` inherits the multiplication structure. -/
instance non_unital_non_assoc_semiring.direct_sum_gnon_unital_non_assoc_semiring
  {R : Type*} [add_monoid ι] [non_unital_non_assoc_semiring R] :
  direct_sum.gnon_unital_non_assoc_semiring (λ i : ι, R) :=
{ mul_zero := λ i j, mul_zero,
  zero_mul := λ i j, zero_mul,
  mul_add := λ i j, mul_add,
  add_mul := λ i j, add_mul,
  ..has_mul.ghas_mul ι }

/-- A direct sum of copies of a `semiring` inherits the multiplication structure. -/
instance semiring.direct_sum_gsemiring {R : Type*} [add_monoid ι] [semiring R] :
  direct_sum.gsemiring (λ i : ι, R) :=
{ nat_cast := λ n, n,
  nat_cast_zero := nat.cast_zero,
  nat_cast_succ := nat.cast_succ,
  ..non_unital_non_assoc_semiring.direct_sum_gnon_unital_non_assoc_semiring ι,
  ..monoid.gmonoid ι }

open_locale direct_sum

-- To check `has_mul.ghas_mul_mul` matches
example {R : Type*} [add_monoid ι] [semiring R] (i j : ι) (a b : R) :
  (direct_sum.of _ i a * direct_sum.of _ j b : ⨁ i, R) = direct_sum.of _ (i + j) (by exact a * b) :=
by rw [direct_sum.of_mul_of, has_mul.ghas_mul_mul]

/-- A direct sum of copies of a `comm_semiring` inherits the commutative multiplication structure.
-/
instance comm_semiring.direct_sum_gcomm_semiring {R : Type*} [add_comm_monoid ι] [comm_semiring R] :
  direct_sum.gcomm_semiring (λ i : ι, R) :=
{ ..comm_monoid.gcomm_monoid ι, ..semiring.direct_sum_gsemiring ι }

end uniform


import Runtime.Network.Graph.Path.Basic

namespace Network.Graph.Path

-- The prefix of a path is the path without the leaf.
-- If the path is already `.nil` it remains the same.
def prefix? : Path graph start → Option (Path graph start)
  | nil => none
  | cons _ nil => some nil
  | cons child subpath => subpath.prefix? >>= (cons child ·)

theorem prefix?_cons_eq_cons_prefix?
  {graph start} {child : Class.Child start} {subpath subprefix : Path graph child.class} :
  (subpath.prefix? = some subprefix) → (cons child subpath).prefix? = cons child subprefix := by
  intro h
  cases subpath
  case nil => simp [prefix?] at h
  case cons child' subpath => simp [prefix?, h]; rfl

theorem prefix?_isSome_iff_isCons {path : Path graph start} :
  path.prefix?.isSome ↔ path.isCons := by
  constructor
  case mp =>
    intro h
    induction path
    case nil => simp [prefix?] at h
    case cons child₁ subpath₁ hi =>
      cases subpath₁
      case nil => rfl
      case cons child₂ subpath₂ => simp [isCons]
  case mpr =>
    intro h
    induction path
    case nil =>
      have ⟨_, _, _⟩ := isCons_def.mp h
      contradiction
    case cons child₁ subpath₁ hi =>
      cases subpath₁
      case nil => simp [prefix?, Option.isSome]
      case cons child₂ subpath₂ =>
        specialize hi isCons_of_cons
        have ⟨subpath, hi⟩ := Option.isSome_iff_exists.mp hi
        simp [prefix?, hi, Option.isSome_iff_exists]
        exists .cons child₁ subpath

theorem prefix?_iff_cons_prefix?
  {graph start} {child : Class.Child start} {path₁ path₂ : Path graph child.class} :
  (path₁.prefix? = some path₂) ↔ (cons child path₁).prefix? = some (cons child path₂) := by
  constructor
  all_goals
    intro h
    cases path₁
    case nil => simp [prefix?] at h
  case mp.cons => simp [prefix?, h]; rfl
  case mpr.cons child subpath =>
    have hs := prefix?_isSome_iff_isCons.mpr (@isCons_of_cons _ _ child subpath)
    have ⟨_, hs⟩ := Option.isSome_iff_exists.mp hs
    simp [hs, prefix?] at h ⊢
    injection h with h
    injection h

def snd (path : Path graph start) (_ : path.isCons) : Class.Child start :=
  match path with
  | nil => by contradiction
  | cons child _ => child

@[simp]
theorem cons_snd_eq_child : (cons child path).snd h = child := rfl

-- Note: We can't define this property with an optional return type,
--       as we can't even state the return type for an invalid input path.
def suffix (path : Path graph start) (h) : Path graph (path.snd h) :=
  match path with
  | nil => by contradiction
  | cons _ subpath => subpath

@[simp]
theorem suffix_class {path : Path graph start} {h} : (path.suffix h).class = path.class := by
  rw [suffix]
  split
  case _ h => simp [isCons] at h
  · simp

def split (path : Path graph start) (_ : path.isCons) :
  Σ «prefix» : Path graph start, Class.Child prefix.class :=
  match path with
  | nil => by contradiction
  | cons child nil => ⟨nil, child⟩
  | cons child subpath@(cons _ _) =>
    let ⟨sub, cls⟩ := subpath.split (by simp_all [isCons_of_cons])
    ⟨cons child sub, cls⟩

theorem split_class {path : Path graph start} (h : path.isCons) :
  (path.split h).snd.class = path.class := by
  induction path
  case nil => contradiction
  case cons child subpath hi =>
    cases subpath
    case nil => rfl
    case cons child' subpath => rw [split]; exact hi h

end Network.Graph.Path