/-
Copyright (c) 2021 Eric Wieser. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Eric Wieser

From: https://github.com/leanprover-community/mathlib/blob/master/src/algebra/direct_sum/graded_ring.lean
-/
import group_theory.subgroup.basic
import algebra.direct_sum.basic
import algebra.big_operators.pi

import cicm2022.graded_monoid

/-!
# 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*}

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 [decidable_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 [decidable_eq ι] [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  [decidable_eq ι] : (⨁ 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  [decidable_eq ι] : 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 [decidable_eq ι] {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 [decidable_eq ι] {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 [decidable_eq ι] [Π 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 [decidable_eq ι] [Π 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 [decidable_eq ι] [Π 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 [decidable_eq ι] [Π 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 [decidable_eq ι] [Π 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 [decidable_eq ι] [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 [decidable_eq ι] [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 [decidable_eq ι] (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 [decidable_eq ι] (n : ℕ) : of A 0 n = n :=
rfl

/-- The `semiring` structure derived from `gsemiring A`. -/
instance grade_zero.semiring [decidable_eq ι] : 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 [decidable_eq ι] : 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 [decidable_eq ι] {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 [decidable_eq ι] [Π 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 [decidable_eq ι] [Π 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 [decidable_eq ι] (n : ℤ) : of A 0 n = n :=
rfl

/-- The `ring` derived from `gsemiring A`. -/
instance grade_zero.ring [decidable_eq ι] : 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 [decidable_eq ι] [Π 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*} [decidable_eq ι] [Π 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*} [decidable_eq ι] [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 tactic.linarith

/- Tactique écrite par Mario, qui aojute au contexte que les carrés sont positifs
et que les produits de nb positifs sont positifs avant d'essayer linarith
AFER : ajouter les inverses de positifs
-/

namespace tactic

meta def find_squares : expr → tactic unit
| e@`(%%a ^ 2) := do
  find_squares a,
  try (do
    p ← mk_app ``pow_two_nonneg [a],
    t ← infer_type p,
    assertv `h t p) >> skip
| e := () <$ e.traverse (λ e, e <$ find_squares e)

meta def nra : tactic unit :=
do ls ← local_context,
  ls' ← ls.mfoldr (λ h l, do
    t ← infer_type h,
    find_squares t,
    match t with
    | `(0 ≤ %%a) := return (h :: l)
    | _ := return l
    end) [],
  target >>= find_squares,
  ls'.mmap' (λ a, ls'.mmap' $ λ b, do
    p ← mk_app ``mul_nonneg [a, b],
    t ← infer_type p,
    assertv `h t p),
  tactic.interactive.linarith none none none

example {α:Type} [linear_ordered_comm_ring α] (a b : α) : 0 ≤ a ^ 2 + b ^ 2 := by nra
end tactic


import Mathlib.Data.Nat.Basic
import Mathlib.Init.Algebra.Order
import Mathlib.Init.Data.Nat.Basic
import Mathlib.Init.Data.Nat.Lemmas
import Mathlib.Init.Data.Int.Basic
import Mathlib.Tactic.LibrarySearch
import Mathlib.Data.Equiv.Basic
import Mathlib.Init.Data.Int.Order
import Timelib.Date.Year
import Timelib.Date.Month
import Timelib.Date.ScalarDate
import Timelib.Date.OrdinalDate
import Timelib.Date.Ymd
import Timelib.Date.Convert
import Timelib.Util

/--
Proof that `Ymd` and `Ordinal` are Equivalent using their respective conversion functions
`Ymd.toOrdinalDate` and `OrdinalDate.toYmd`
-/

theorem Ymd.is_january_month {ymd : Ymd} (h_is_month_day : (ymd.toOrdinalDate).isJanuaryDay) : ymd.month = Month.january := by
  simp only [Ymd.toOrdinalDate]
  by_cases hLeap : ymd.year.isLeapYear <;>
    (simp_arith [hLeap, OrdinalDate.isJanuaryDay] at h_is_month_day
     simp only [Ymd.toOrdinalDate] at h_is_month_day
     simp only [hLeap]
     split at h_is_month_day <;> (simp (config := { arith := true }) at *; try assumption)
     case _ hM =>
       simp_arith [hM] at h_is_month_day
       exact False.elim ((show ¬0 >= 1 by decide) (h_is_month_day ▸ ymd.dayGe)))

theorem Ymd.is_february_month {ymd : Ymd} (h_is_month_day : ymd.toOrdinalDate.isFebruaryDay) : ymd.month = Month.february := by
  simp only [Ymd.toOrdinalDate]
  by_cases hLeap : ymd.year.isLeapYear <;>
    (simp_arith [hLeap, OrdinalDate.isFebruaryDay] at h_is_month_day
     simp only [Ymd.toOrdinalDate] at h_is_month_day
     simp only [hLeap]
     split at h_is_month_day <;> (simp (config := { arith := true }) [Month.numDays, hLeap] at *; try assumption)
     case _ hM =>
       have hDayLe := ymd.dayLe
       simp [hM, Month.numDays, hLeap] at hDayLe
       exact False.elim (not_le_and_ge_of_lt hDayLe (by decide) h_is_month_day.left)
     case _ hM =>
       simp_arith [hM, hLeap] at h_is_month_day
       exact False.elim ((show ¬0 >= 1 by decide) (h_is_month_day ▸ ymd.dayGe)))

theorem Ymd.is_march_month {ymd : Ymd} (h_is_month_day : ymd.toOrdinalDate.isMarchDay) : ymd.month = Month.march := by
  simp only [Ymd.toOrdinalDate]
  by_cases hLeap : ymd.year.isLeapYear <;>
    (simp [hLeap, OrdinalDate.isMarchDay] at h_is_month_day
     simp only [Ymd.toOrdinalDate] at h_is_month_day
     simp only [hLeap]
     have hDayLe := ymd.dayLe
     split at h_is_month_day <;> (simp (config := { arith := true }) at *; try assumption)
     case _ hM =>
       simp [hM, Month.numDays, hLeap] at hDayLe
       exact False.elim (not_le_and_ge_of_lt hDayLe (by decide) h_is_month_day.left)
     case _ hM =>
       simp [hM, Month.numDays, hLeap] at hDayLe
       exact False.elim (not_le_and_ge_of_lt hDayLe (by decide) h_is_month_day.left)
     case _ hM =>
       simp_arith [hLeap] at h_is_month_day
       exact False.elim ((show ¬0 >= 1 by decide) (h_is_month_day ▸ ymd.dayGe)))

theorem Ymd.is_april_month {ymd : Ymd} (h_is_month_day : ymd.toOrdinalDate.isAprilDay) : ymd.month = Month.april := by
  simp only [Ymd.toOrdinalDate]
  by_cases hLeap : ymd.year.isLeapYear <;>
  (simp [OrdinalDate.isAprilDay, hLeap] at h_is_month_day
   simp only [Ymd.toOrdinalDate] at h_is_month_day
   simp only [hLeap]
   have h_DayLe := ymd.dayLe
   split at h_is_month_day <;> (simp (config := { arith := true }) [Month.numDays, hLeap] at *; try assumption)
   case _ hM =>
     simp [hM, Month.numDays, hLeap] at h_DayLe
     exact False.elim (not_le_and_ge_of_lt h_DayLe (by decide) h_is_month_day.left)
   case _ hM =>
     simp [hM, Month.numDays, hLeap] at h_DayLe
     exact False.elim (not_le_and_ge_of_lt h_DayLe (by decide) h_is_month_day.left)
   case _ hM =>
     simp [hM, Month.numDays, hLeap] at h_DayLe
     exact False.elim (not_le_and_ge_of_lt h_DayLe (by decide) h_is_month_day.left)
   case _ hM => exact False.elim ((show ¬0 >= 1 by decide) (h_is_month_day ▸ ymd.dayGe)))

theorem Ymd.is_may_month {ymd : Ymd} (h_is_month_day : ymd.toOrdinalDate.isMayDay) : ymd.month = Month.may := by
  simp only [Ymd.toOrdinalDate]
  by_cases hLeap : ymd.year.isLeapYear <;>
  (simp [OrdinalDate.isMayDay, hLeap] at h_is_month_day
   simp only [Ymd.toOrdinalDate] at h_is_month_day
   simp only [hLeap]
   have h_DayLe := ymd.dayLe
   split at h_is_month_day <;> (simp (config := { arith := true }) [Month.numDays, hLeap] at *; try assumption)
   case _ hM =>
     simp [hM, Month.numDays, hLeap] at h_DayLe
     exact False.elim (not_le_and_ge_of_lt h_DayLe (by decide) h_is_month_day.left)
   case _ hM =>
     simp [hM, Month.numDays, hLeap] at h_DayLe
     exact False.elim (not_le_and_ge_of_lt h_DayLe (by decide) h_is_month_day.left)
   case _ hM =>
     simp [hM, Month.numDays, hLeap] at h_DayLe
     exact False.elim (not_le_and_ge_of_lt h_DayLe (by decide) h_is_month_day.left)
   case _ hM =>
     simp [hM, Month.numDays, hLeap] at h_DayLe
     exact False.elim (not_le_and_ge_of_lt h_DayLe (by decide) h_is_month_day.left)
   case _ hM => exact False.elim ((show ¬0 >= 1 by decide) (h_is_month_day ▸ ymd.dayGe)))

theorem Ymd.is_june_month {ymd : Ymd} (h_is_month_day : ymd.toOrdinalDate.isJuneDay) : ymd.month = Month.june := by
  simp only [Ymd.toOrdinalDate]
  by_cases hLeap : ymd.year.isLeapYear <;>
  (simp [OrdinalDate.isJuneDay, hLeap] at h_is_month_day
   simp only [Ymd.toOrdinalDate] at h_is_month_day
   simp only [hLeap]
   have h_DayLe := ymd.dayLe
   split at h_is_month_day <;> (simp (config := { arith := true }) [Month.numDays, hLeap] at *; try assumption)
   case _ hM =>
     simp [hM, Month.numDays, hLeap] at h_DayLe
     exact False.elim (not_le_and_ge_of_lt h_DayLe (by decide) h_is_month_day.left)
   case _ hM =>
     simp [hM, Month.numDays, hLeap] at h_DayLe
     exact False.elim (not_le_and_ge_of_lt h_DayLe (by decide) h_is_month_day.left)
   case _ hM =>
     simp [hM, Month.numDays, hLeap] at h_DayLe
     exact False.elim (not_le_and_ge_of_lt h_DayLe (by decide) h_is_month_day.left)
   case _ hM =>
     simp [hM, Month.numDays, hLeap] at h_DayLe
     exact False.elim (not_le_and_ge_of_lt h_DayLe (by decide) h_is_month_day.left)
   case _ hM =>
     simp [hM, Month.numDays, hLeap] at h_DayLe
     exact False.elim (not_le_and_ge_of_lt h_DayLe (by decide) h_is_month_day.left)
   case _ hM => exact False.elim ((show ¬0 >= 1 by decide) (h_is_month_day ▸ ymd.dayGe)))

theorem Ymd.is_july_month {ymd : Ymd} (h_is_month_day : ymd.toOrdinalDate.isJulyDay) : ymd.month = Month.july := by
  simp only [Ymd.toOrdinalDate]
  by_cases hLeap : ymd.year.isLeapYear <;>
  (simp [OrdinalDate.isJulyDay, hLeap] at h_is_month_day
   simp only [Ymd.toOrdinalDate] at h_is_month_day
   simp only [hLeap]
   have h_DayLe := ymd.dayLe
   split at h_is_month_day <;> (simp (config := { arith := true }) [Month.numDays, hLeap] at *; try assumption)
   case _ hM =>
     simp [hM, Month.numDays, hLeap] at h_DayLe
     exact False.elim (not_le_and_ge_of_lt h_DayLe (by decide) h_is_month_day.left)
   case _ hM =>
     simp [hM, Month.numDays, hLeap] at h_DayLe
     exact False.elim (not_le_and_ge_of_lt h_DayLe (by decide) h_is_month_day.left)
   case _ hM =>
     simp [hM, Month.numDays, hLeap] at h_DayLe
     exact False.elim (not_le_and_ge_of_lt h_DayLe (by decide) h_is_month_day.left)
   case _ hM =>
     simp [hM, Month.numDays, hLeap] at h_DayLe
     exact False.elim (not_le_and_ge_of_lt h_DayLe (by decide) h_is_month_day.left)
   case _ hM =>
     simp [hM, Month.numDays, hLeap] at h_DayLe
     exact False.elim (not_le_and_ge_of_lt h_DayLe (by decide) h_is_month_day.left)
   case _ hM =>
     simp [hM, Month.numDays, hLeap] at h_DayLe
     exact False.elim (not_le_and_ge_of_lt h_DayLe (by decide) h_is_month_day.left)
   case _ hM => exact False.elim ((show ¬0 >= 1 by decide) (h_is_month_day ▸ ymd.dayGe)))

theorem Ymd.is_august_month {ymd : Ymd} (h_is_month_day : ymd.toOrdinalDate.isAugustDay) : ymd.month = Month.august := by
  simp only [Ymd.toOrdinalDate]
  by_cases hLeap : ymd.year.isLeapYear <;>
  (simp [OrdinalDate.isAugustDay, hLeap] at h_is_month_day
   simp only [Ymd.toOrdinalDate] at h_is_month_day
   simp only [hLeap]
   have h_DayLe := ymd.dayLe
   split at h_is_month_day <;> (simp (config := { arith := true }) [Month.numDays, hLeap] at *; try assumption)
   case _ hM =>
     simp [hM, Month.numDays, hLeap] at h_DayLe
     exact False.elim (not_le_and_ge_of_lt h_DayLe (by decide) h_is_month_day.left)
   case _ hM =>
     simp [hM, Month.numDays, hLeap] at h_DayLe
     exact False.elim (not_le_and_ge_of_lt h_DayLe (by decide) h_is_month_day.left)
   case _ hM =>
     simp [hM, Month.numDays, hLeap] at h_DayLe
     exact False.elim (not_le_and_ge_of_lt h_DayLe (by decide) h_is_month_day.left)
   case _ hM =>
     simp [hM, Month.numDays, hLeap] at h_DayLe
     exact False.elim (not_le_and_ge_of_lt h_DayLe (by decide) h_is_month_day.left)
   case _ hM =>
     simp [hM, Month.numDays, hLeap] at h_DayLe
     exact False.elim (not_le_and_ge_of_lt h_DayLe (by decide) h_is_month_day.left)
   case _ hM =>
     simp [hM, Month.numDays, hLeap] at h_DayLe
     exact False.elim (not_le_and_ge_of_lt h_DayLe (by decide) h_is_month_day.left)
   case _ hM =>
     simp [hM, Month.numDays, hLeap] at h_DayLe
     exact False.elim (not_le_and_ge_of_lt h_DayLe (by decide) h_is_month_day.left)
   case _ hM => exact False.elim ((show ¬0 >= 1 by decide) (h_is_month_day ▸ ymd.dayGe)))

theorem Ymd.is_september_month {ymd : Ymd} (h_is_month_day : ymd.toOrdinalDate.isSeptemberDay) : ymd.month = Month.september := by
  simp only [Ymd.toOrdinalDate]
  by_cases hLeap : ymd.year.isLeapYear <;>
  (simp [OrdinalDate.isSeptemberDay, hLeap] at h_is_month_day
   simp only [Ymd.toOrdinalDate] at h_is_month_day
   simp only [hLeap]
   have h_DayLe := ymd.dayLe
   split at h_is_month_day <;> (simp (config := { arith := true }) [Month.numDays, hLeap] at *; try assumption)
   case _ hM =>
     simp [hM, Month.numDays, hLeap] at h_DayLe
     exact False.elim (not_le_and_ge_of_lt h_DayLe (by decide) h_is_month_day.left)
   case _ hM =>
     simp [hM, Month.numDays, hLeap] at h_DayLe
     exact False.elim (not_le_and_ge_of_lt h_DayLe (by decide) h_is_month_day.left)
   case _ hM =>
     simp [hM, Month.numDays, hLeap] at h_DayLe
     exact False.elim (not_le_and_ge_of_lt h_DayLe (by decide) h_is_month_day.left)
   case _ hM =>
     simp [hM, Month.numDays, hLeap] at h_DayLe
     exact False.elim (not_le_and_ge_of_lt h_DayLe (by decide) h_is_month_day.left)
   case _ hM =>
     simp [hM, Month.numDays, hLeap] at h_DayLe
     exact False.elim (not_le_and_ge_of_lt h_DayLe (by decide) h_is_month_day.left)
   case _ hM =>
     simp [hM, Month.numDays, hLeap] at h_DayLe
     exact False.elim (not_le_and_ge_of_lt h_DayLe (by decide) h_is_month_day.left)
   case _ hM =>
     simp [hM, Month.numDays, hLeap] at h_DayLe
     exact False.elim (not_le_and_ge_of_lt h_DayLe (by decide) h_is_month_day.left)
   case _ hM =>
     simp [hM, Month.numDays, hLeap] at h_DayLe
     exact False.elim (not_le_and_ge_of_lt h_DayLe (by decide) h_is_month_day.left)
   case _ hM => exact False.elim ((show ¬0 >= 1 by decide) (h_is_month_day ▸ ymd.dayGe)))

theorem Ymd.is_october_month {ymd : Ymd} (h_is_month_day : ymd.toOrdinalDate.isOctoberDay) : ymd.month = Month.october := by
  simp only [Ymd.toOrdinalDate]
  by_cases hLeap : ymd.year.isLeapYear <;>
  (simp [OrdinalDate.isOctoberDay, hLeap] at h_is_month_day
   simp only [Ymd.toOrdinalDate] at h_is_month_day
   simp only [hLeap]
   have h_DayLe := ymd.dayLe
   split at h_is_month_day <;> (simp (config := { arith := true }) [Month.numDays, hLeap] at *; try assumption)
   case _ hM =>
     simp [hM, Month.numDays, hLeap] at h_DayLe
     exact False.elim (not_le_and_ge_of_lt h_DayLe (by decide) h_is_month_day.left)
   case _ hM =>
     simp [hM, Month.numDays, hLeap] at h_DayLe
     exact False.elim (not_le_and_ge_of_lt h_DayLe (by decide) h_is_month_day.left)
   case _ hM =>
     simp [hM, Month.numDays, hLeap] at h_DayLe
     exact False.elim (not_le_and_ge_of_lt h_DayLe (by decide) h_is_month_day.left)
   case _ hM =>
     simp [hM, Month.numDays, hLeap] at h_DayLe
     exact False.elim (not_le_and_ge_of_lt h_DayLe (by decide) h_is_month_day.left)
   case _ hM =>
     simp [hM, Month.numDays, hLeap] at h_DayLe
     exact False.elim (not_le_and_ge_of_lt h_DayLe (by decide) h_is_month_day.left)
   case _ hM =>
     simp [hM, Month.numDays, hLeap] at h_DayLe
     exact False.elim (not_le_and_ge_of_lt h_DayLe (by decide) h_is_month_day.left)
   case _ hM =>
     simp [hM, Month.numDays, hLeap] at h_DayLe
     exact False.elim (not_le_and_ge_of_lt h_DayLe (by decide) h_is_month_day.left)
   case _ hM =>
     simp [hM, Month.numDays, hLeap] at h_DayLe
     exact False.elim (not_le_and_ge_of_lt h_DayLe (by decide) h_is_month_day.left)
   case _ hM =>
     simp [hM, Month.numDays, hLeap] at h_DayLe
     exact False.elim (not_le_and_ge_of_lt h_DayLe (by decide) h_is_month_day.left)
   case _ hM => exact False.elim ((show ¬0 >= 1 by decide) (h_is_month_day ▸ ymd.dayGe)))

theorem Ymd.is_november_month {ymd : Ymd} (h_is_month_day : ymd.toOrdinalDate.isNovemberDay) : ymd.month = Month.november := by
  simp only [Ymd.toOrdinalDate]
  by_cases hLeap : ymd.year.isLeapYear <;>
  (simp [OrdinalDate.isNovemberDay, hLeap] at h_is_month_day
   simp only [Ymd.toOrdinalDate] at h_is_month_day
   simp only [hLeap]
   have h_DayLe := ymd.dayLe
   split at h_is_month_day <;> (simp (config := { arith := true }) [Month.numDays, hLeap] at *; try assumption)
   case _ hM =>
     simp [hM, Month.numDays, hLeap] at h_DayLe
     exact False.elim (not_le_and_ge_of_lt h_DayLe (by decide) h_is_month_day.left)
   case _ hM =>
     simp [hM, Month.numDays, hLeap] at h_DayLe
     exact False.elim (not_le_and_ge_of_lt h_DayLe (by decide) h_is_month_day.left)
   case _ hM =>
     simp [hM, Month.numDays, hLeap] at h_DayLe
     exact False.elim (not_le_and_ge_of_lt h_DayLe (by decide) h_is_month_day.left)
   case _ hM =>
     simp [hM, Month.numDays, hLeap] at h_DayLe
     exact False.elim (not_le_and_ge_of_lt h_DayLe (by decide) h_is_month_day.left)
   case _ hM =>
     simp [hM, Month.numDays, hLeap] at h_DayLe
     exact False.elim (not_le_and_ge_of_lt h_DayLe (by decide) h_is_month_day.left)
   case _ hM =>
     simp [hM, Month.numDays, hLeap] at h_DayLe
     exact False.elim (not_le_and_ge_of_lt h_DayLe (by decide) h_is_month_day.left)
   case _ hM =>
     simp [hM, Month.numDays, hLeap] at h_DayLe
     exact False.elim (not_le_and_ge_of_lt h_DayLe (by decide) h_is_month_day.left)
   case _ hM =>
     simp [hM, Month.numDays, hLeap] at h_DayLe
     exact False.elim (not_le_and_ge_of_lt h_DayLe (by decide) h_is_month_day.left)
   case _ hM =>
     simp [hM, Month.numDays, hLeap] at h_DayLe
     exact False.elim (not_le_and_ge_of_lt h_DayLe (by decide) h_is_month_day.left)
   case _ hM =>
     simp [hM, Month.numDays, hLeap] at h_DayLe
     exact False.elim (not_le_and_ge_of_lt h_DayLe (by decide) h_is_month_day.left)
   case _ hM => exact False.elim ((show ¬0 >= 1 by decide) (h_is_month_day ▸ ymd.dayGe)))

theorem Ymd.is_december_month {ymd : Ymd} (h_is_month_day : ymd.toOrdinalDate.isDecemberDay) : ymd.month = Month.december := by
  simp only [Ymd.toOrdinalDate]
  by_cases hLeap : ymd.year.isLeapYear <;>
  (simp [OrdinalDate.isDecemberDay, hLeap] at h_is_month_day
   simp only [Ymd.toOrdinalDate] at h_is_month_day
   simp only [hLeap]
   have h_DayLe := ymd.dayLe
   split at h_is_month_day <;> (simp (config := { arith := true }) [Month.numDays, hLeap] at *; try assumption)
   case _ hM =>
     simp [hM, Month.numDays, hLeap] at h_DayLe
     exact False.elim (not_le_and_ge_of_lt h_DayLe (by decide) h_is_month_day)
   case _ hM =>
     simp [hM, Month.numDays, hLeap] at h_DayLe
     exact False.elim (not_le_and_ge_of_lt h_DayLe (by decide) h_is_month_day)
   case _ hM =>
     simp [hM, Month.numDays, hLeap] at h_DayLe
     exact False.elim (not_le_and_ge_of_lt h_DayLe (by decide) h_is_month_day)
   case _ hM =>
     simp [hM, Month.numDays, hLeap] at h_DayLe
     exact False.elim (not_le_and_ge_of_lt h_DayLe (by decide) h_is_month_day)
   case _ hM =>
     simp [hM, Month.numDays, hLeap] at h_DayLe
     exact False.elim (not_le_and_ge_of_lt h_DayLe (by decide) h_is_month_day)
   case _ hM =>
     simp [hM, Month.numDays, hLeap] at h_DayLe
     exact False.elim (not_le_and_ge_of_lt h_DayLe (by decide) h_is_month_day)
   case _ hM =>
     simp [hM, Month.numDays, hLeap] at h_DayLe
     exact False.elim (not_le_and_ge_of_lt h_DayLe (by decide) h_is_month_day)
   case _ hM =>
     simp [hM, Month.numDays, hLeap] at h_DayLe
     exact False.elim (not_le_and_ge_of_lt h_DayLe (by decide) h_is_month_day)
   case _ hM =>
     simp [hM, Month.numDays, hLeap] at h_DayLe
     exact False.elim (not_le_and_ge_of_lt h_DayLe (by decide) h_is_month_day)
   case _ hM =>
     simp [hM, Month.numDays, hLeap] at h_DayLe
     exact False.elim (not_le_and_ge_of_lt h_DayLe (by decide) h_is_month_day)
   case _ hM =>
     simp [hM, Month.numDays, hLeap] at h_DayLe
     exact False.elim (not_le_and_ge_of_lt h_DayLe (by decide) h_is_month_day))

theorem OrdinalDate.toYmd_right_inv (ordinal : OrdinalDate) : ordinal.toYmd.toOrdinalDate = ordinal := by
  by_cases hLeap : ordinal.year.isLeapYear <;>
  (simp [OrdinalDate.toYmd, hLeap]
   split
   case _ hJan => simp [Ymd.toOrdinalDate, hJan]
   case _ hJan =>
      split
      case _ hFeb =>
        simp [hFeb, Ymd.toOrdinalDate]
        apply OrdinalDate.eq_of_val_eq
        case h_year => simp
        case h_day => exact Nat.sub_add_cancel (Nat.le_of_lt (Nat.gt_of_not_le hJan))
      case _ hFeb =>
        split
        case _ hMar =>
          simp [hMar, Ymd.toOrdinalDate, hLeap]
          apply OrdinalDate.eq_of_val_eq
          case h_year => simp
          case h_day => exact Nat.sub_add_cancel (Nat.le_of_lt (Nat.gt_of_not_le hFeb))
        case _ hMar =>
          split
          case _ hApr =>
            simp [hApr, Ymd.toOrdinalDate, hLeap]
            apply OrdinalDate.eq_of_val_eq
            case h_year => simp
            case h_day => exact Nat.sub_add_cancel (Nat.le_of_lt (Nat.gt_of_not_le hMar))
          case _ hApr =>
            split
            case _ hMay =>
              simp [hMay, Ymd.toOrdinalDate, hLeap]
              apply OrdinalDate.eq_of_val_eq
              case h_year => simp
              case h_day => exact Nat.sub_add_cancel (Nat.le_of_lt (Nat.gt_of_not_le hApr))
            case _ hMay =>
                split
                case _ hJun =>
                  simp [hJun, Ymd.toOrdinalDate, hLeap]
                  apply OrdinalDate.eq_of_val_eq
                  case h_year => simp
                  case h_day => exact Nat.sub_add_cancel (Nat.le_of_lt (Nat.gt_of_not_le hMay))
                case _ hJun =>
                  split
                  case _ hJul =>
                    simp [hJul, Ymd.toOrdinalDate, hLeap]
                    apply OrdinalDate.eq_of_val_eq
                    case h_year => simp
                    case h_day => exact Nat.sub_add_cancel (Nat.le_of_lt (Nat.gt_of_not_le hJun))
                  case _ hJul =>
                    split
                    case _ hAug =>
                      simp [hAug, Ymd.toOrdinalDate, hLeap]
                      apply OrdinalDate.eq_of_val_eq
                      case h_year => simp
                      case h_day => exact Nat.sub_add_cancel (Nat.le_of_lt (Nat.gt_of_not_le hJul))
                    case _ hAug =>
                      split
                      case _ hSep =>
                        simp [hSep, Ymd.toOrdinalDate, hLeap]
                        apply OrdinalDate.eq_of_val_eq
                        case h_year => simp
                        case h_day => exact Nat.sub_add_cancel (Nat.le_of_lt (Nat.gt_of_not_le hAug))
                      case _ hSep =>
                        split
                        case _ hOct =>
                          simp [hOct, Ymd.toOrdinalDate, hLeap]
                          apply OrdinalDate.eq_of_val_eq
                          case h_year => simp
                          case h_day => exact Nat.sub_add_cancel (Nat.le_of_lt (Nat.gt_of_not_le hSep))
                        case _ hOct =>
                          split
                          case _ hNov =>
                            simp [hNov, Ymd.toOrdinalDate, hLeap]
                            apply OrdinalDate.eq_of_val_eq
                            case h_year => simp
                            case h_day => exact Nat.sub_add_cancel (Nat.le_of_lt (Nat.gt_of_not_le hOct))
                          case _ hNov =>
                            simp [hNov, Ymd.toOrdinalDate, hLeap]
                            apply OrdinalDate.eq_of_val_eq
                            case h_year => simp
                            case h_day => exact Nat.sub_add_cancel (Nat.le_of_lt (Nat.gt_of_not_le hNov)))

theorem Ymd.toOrdinalDate_left_inv (ymd : Ymd) : ymd.toOrdinalDate.toYmd = ymd := by
  simp [OrdinalDate.toYmd]
  by_cases hLeap : ymd.year.isLeapYear <;>
  (simp [hLeap, Ymd.toOrdinalDate_year_same]
   split
   case _ hJan =>
     have h_is_month_day : ymd.toOrdinalDate.isJanuaryDay := by simp [OrdinalDate.isJanuaryDay]; exact hJan
     apply Ymd.eq_of_val_eq <;> simp [Ymd.toOrdinalDate, (Ymd.is_january_month h_is_month_day), hLeap, Nat.add_sub_cancel]
   case _ hJan =>
     split
     case _ hFeb =>
         have h_is_month_day : ymd.toOrdinalDate.isFebruaryDay := by
           simp [OrdinalDate.isFebruaryDay, Year.lastDayFebruary, hLeap]
           exact And.intro (Nat.gt_of_not_le hJan) hFeb
         apply Ymd.eq_of_val_eq <;> simp [Ymd.toOrdinalDate, (Ymd.is_february_month h_is_month_day), hLeap, Nat.add_sub_cancel]
     case _ hFeb =>
       split
       case _ hMar =>
         have h_is_month_day : ymd.toOrdinalDate.isMarchDay := by
           simp [OrdinalDate.isMarchDay, Year.lastDayMarch, hLeap]
           exact And.intro (Nat.gt_of_not_le hFeb) hMar
         apply Ymd.eq_of_val_eq <;> simp [Ymd.toOrdinalDate, (Ymd.is_march_month h_is_month_day), hLeap, Nat.add_sub_cancel]
       case _ hMar =>
         split
         case _ hApr =>
           have h_is_month_day : ymd.toOrdinalDate.isAprilDay := by
             simp [OrdinalDate.isAprilDay, Year.lastDayApril, hLeap]
             exact And.intro (Nat.gt_of_not_le hMar) hApr
           apply Ymd.eq_of_val_eq <;> simp [Ymd.toOrdinalDate, (Ymd.is_april_month h_is_month_day), hLeap, Nat.add_sub_cancel]
         case _ hApr =>
           split
           case _ hMay =>
             have h_is_month_day : ymd.toOrdinalDate.isMayDay := by
               simp [OrdinalDate.isMayDay, Year.lastDayMay, hLeap]
               exact And.intro (Nat.gt_of_not_le hApr) hMay
             apply Ymd.eq_of_val_eq <;> simp [Ymd.toOrdinalDate, (Ymd.is_may_month h_is_month_day), hLeap, Nat.add_sub_cancel]
           case _ hMay =>
               split
               case _ hJun =>
                 have h_is_month_day : ymd.toOrdinalDate.isJuneDay := by
                   simp [OrdinalDate.isJuneDay, Year.lastDayJune, hLeap]
                   exact And.intro (Nat.gt_of_not_le hMay) hJun
                 apply Ymd.eq_of_val_eq <;> simp [Ymd.toOrdinalDate, (Ymd.is_june_month h_is_month_day), hLeap, Nat.add_sub_cancel]
               case _ hJun =>
                 split
                 case _ hJul =>
                   have h_is_month_day : ymd.toOrdinalDate.isJulyDay := by
                     simp [OrdinalDate.isJulyDay, Year.lastDayJuly, hLeap]
                     exact And.intro (Nat.gt_of_not_le hJun) hJul
                   apply Ymd.eq_of_val_eq <;> simp [Ymd.toOrdinalDate, (Ymd.is_july_month h_is_month_day), hLeap, Nat.add_sub_cancel]
                 case _ hJul =>
                   split
                   case _ hAug =>
                     have h_is_month_day : ymd.toOrdinalDate.isAugustDay := by
                       simp [OrdinalDate.isAugustDay, Year.lastDayAugust, hLeap]
                       exact And.intro (Nat.gt_of_not_le hJul) hAug
                     apply Ymd.eq_of_val_eq <;> simp [Ymd.toOrdinalDate, (Ymd.is_august_month h_is_month_day), hLeap, Nat.add_sub_cancel]
                   case _ hAug =>
                     split
                     case _ hSep =>
                       have h_is_month_day : ymd.toOrdinalDate.isSeptemberDay := by
                         simp [OrdinalDate.isSeptemberDay, Year.lastDaySeptember, hLeap]
                         exact And.intro (Nat.gt_of_not_le hAug) hSep
                       apply Ymd.eq_of_val_eq <;> simp [Ymd.toOrdinalDate, (Ymd.is_september_month h_is_month_day), hLeap, Nat.add_sub_cancel]
                     case _ hSep =>
                       split
                       case _ hOct =>
                         have h_is_month_day : ymd.toOrdinalDate.isOctoberDay := by
                           simp [OrdinalDate.isOctoberDay, Year.lastDayOctober, hLeap]
                           exact And.intro (Nat.gt_of_not_le hSep) hOct
                         apply Ymd.eq_of_val_eq <;> simp [Ymd.toOrdinalDate, (Ymd.is_october_month h_is_month_day), hLeap, Nat.add_sub_cancel]
                       case _ hOct =>
                         split
                         case _ hNov =>
                           have h_is_month_day : ymd.toOrdinalDate.isNovemberDay := by
                             simp [OrdinalDate.isNovemberDay, Year.lastDayNovember, hLeap]
                             exact And.intro (Nat.gt_of_not_le hOct) hNov
                           apply Ymd.eq_of_val_eq <;> simp [Ymd.toOrdinalDate, (Ymd.is_november_month h_is_month_day), hLeap, Nat.add_sub_cancel]
                         case _ hNov =>
                           have h_is_month_day : ymd.toOrdinalDate.isDecemberDay := by
                             simp [OrdinalDate.isDecemberDay, hLeap]
                             exact Nat.gt_of_not_le hNov
                           apply Ymd.eq_of_val_eq <;> simp [Ymd.toOrdinalDate, (Ymd.is_december_month h_is_month_day), hLeap, Nat.add_sub_cancel])


/-
Copyright (c) 2019 Chris Hughes. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Chris Hughes
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.list.basic
import Mathlib.PostPort

universes u

namespace Mathlib

namespace list

theorem rotate_mod {α : Type u} (l : List α) (n : ℕ) : rotate l (n % length l) = rotate l n := sorry

@[simp] theorem rotate_nil {α : Type u} (n : ℕ) : rotate [] n = [] :=
  nat.cases_on n (Eq.refl (rotate [] 0)) fun (n : ℕ) => Eq.refl (rotate [] (Nat.succ n))

@[simp] theorem rotate_zero {α : Type u} (l : List α) : rotate l 0 = l := sorry

@[simp] theorem rotate'_nil {α : Type u} (n : ℕ) : rotate' [] n = [] :=
  nat.cases_on n (Eq.refl (rotate' [] 0)) fun (n : ℕ) => Eq.refl (rotate' [] (Nat.succ n))

@[simp] theorem rotate'_zero {α : Type u} (l : List α) : rotate' l 0 = l :=
  list.cases_on l (Eq.refl (rotate' [] 0))
    fun (l_hd : α) (l_tl : List α) => Eq.refl (rotate' (l_hd :: l_tl) 0)

theorem rotate'_cons_succ {α : Type u} (l : List α) (a : α) (n : ℕ) :
    rotate' (a :: l) (Nat.succ n) = rotate' (l ++ [a]) n :=
  sorry

@[simp] theorem length_rotate' {α : Type u} (l : List α) (n : ℕ) :
    length (rotate' l n) = length l :=
  sorry

theorem rotate'_eq_take_append_drop {α : Type u} {l : List α} {n : ℕ} :
    n ≤ length l → rotate' l n = drop n l ++ take n l :=
  sorry

theorem rotate'_rotate' {α : Type u} (l : List α) (n : ℕ) (m : ℕ) :
    rotate' (rotate' l n) m = rotate' l (n + m) :=
  sorry

@[simp] theorem rotate'_length {α : Type u} (l : List α) : rotate' l (length l) = l := sorry

@[simp] theorem rotate'_length_mul {α : Type u} (l : List α) (n : ℕ) :
    rotate' l (length l * n) = l :=
  sorry

theorem rotate'_mod {α : Type u} (l : List α) (n : ℕ) : rotate' l (n % length l) = rotate' l n :=
  sorry

theorem rotate_eq_rotate' {α : Type u} (l : List α) (n : ℕ) : rotate l n = rotate' l n := sorry

theorem rotate_cons_succ {α : Type u} (l : List α) (a : α) (n : ℕ) :
    rotate (a :: l) (Nat.succ n) = rotate (l ++ [a]) n :=
  sorry

@[simp] theorem mem_rotate {α : Type u} {l : List α} {a : α} {n : ℕ} : a ∈ rotate l n ↔ a ∈ l :=
  sorry

@[simp] theorem length_rotate {α : Type u} (l : List α) (n : ℕ) : length (rotate l n) = length l :=
  eq.mpr (id (Eq._oldrec (Eq.refl (length (rotate l n) = length l)) (rotate_eq_rotate' l n)))
    (eq.mpr (id (Eq._oldrec (Eq.refl (length (rotate' l n) = length l)) (length_rotate' l n)))
      (Eq.refl (length l)))

theorem rotate_eq_take_append_drop {α : Type u} {l : List α} {n : ℕ} :
    n ≤ length l → rotate l n = drop n l ++ take n l :=
  eq.mpr
    (id
      (Eq._oldrec (Eq.refl (n ≤ length l → rotate l n = drop n l ++ take n l))
        (rotate_eq_rotate' l n)))
    rotate'_eq_take_append_drop

theorem rotate_rotate {α : Type u} (l : List α) (n : ℕ) (m : ℕ) :
    rotate (rotate l n) m = rotate l (n + m) :=
  sorry

@[simp] theorem rotate_length {α : Type u} (l : List α) : rotate l (length l) = l :=
  eq.mpr (id (Eq._oldrec (Eq.refl (rotate l (length l) = l)) (rotate_eq_rotate' l (length l))))
    (eq.mpr (id (Eq._oldrec (Eq.refl (rotate' l (length l) = l)) (rotate'_length l))) (Eq.refl l))

@[simp] theorem rotate_length_mul {α : Type u} (l : List α) (n : ℕ) : rotate l (length l * n) = l :=
  eq.mpr
    (id (Eq._oldrec (Eq.refl (rotate l (length l * n) = l)) (rotate_eq_rotate' l (length l * n))))
    (eq.mpr (id (Eq._oldrec (Eq.refl (rotate' l (length l * n) = l)) (rotate'_length_mul l n)))
      (Eq.refl l))

theorem prod_rotate_eq_one_of_prod_eq_one {α : Type u} [group α] {l : List α} (hl : prod l = 1)
    (n : ℕ) : prod (rotate l n) = 1 :=
  sorry

end Mathlib


/-
Copyright (c) 2021 Junyan Xu. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Junyan Xu
-/

import topology.sheaves.sheaf_condition.pairwise_intersections

/-!
# functors between categories of sheaves

Show that the pushforward of a sheaf is a sheaf, and define
the pushforward functor from the category of C-valued sheaves
on X to that of sheaves on Y, given a continuous map between
topological spaces X and Y.

TODO: pullback for presheaves and sheaves
-/

noncomputable theory

universes w v u

open category_theory
open category_theory.limits
open topological_space

variables {C : Type u} [category.{v} C]
variables {X Y : Top.{w}} (f : X ⟶ Y)
variables ⦃ι : Type w⦄ {U : ι → opens Y}

namespace Top
namespace presheaf.sheaf_condition_pairwise_intersections

lemma map_diagram :
  pairwise.diagram U ⋙ opens.map f = pairwise.diagram ((opens.map f).obj ∘ U) :=
begin
  apply functor.hext,
  abstract obj_eq {intro i, cases i; refl},
  intros i j g, apply subsingleton.helim,
  iterate 2 {rw map_diagram.obj_eq},
end

lemma map_cocone : (opens.map f).map_cocone (pairwise.cocone U)
                     == pairwise.cocone ((opens.map f).obj ∘ U) :=
begin
  unfold functor.map_cocone cocones.functoriality, dsimp, congr,
  iterate 2 {rw map_diagram, rw opens.map_supr},
  apply subsingleton.helim, rw [map_diagram, opens.map_supr],
  apply proof_irrel_heq,
end

theorem pushforward_sheaf_of_sheaf {F : presheaf C X}
  (h : F.is_sheaf_pairwise_intersections) :
  (f _* F).is_sheaf_pairwise_intersections :=
λ ι U, begin
  convert h ((opens.map f).obj ∘ U) using 2,
  rw ← map_diagram, refl,
  change F.map_cone ((opens.map f).map_cocone _).op == _,
  congr, iterate 2 {rw map_diagram}, apply map_cocone,
end

end presheaf.sheaf_condition_pairwise_intersections

namespace sheaf

open presheaf

/--
The pushforward of a sheaf (by a continuous map) is a sheaf.
-/
theorem pushforward_sheaf_of_sheaf
  {F : X.presheaf C} (h : F.is_sheaf) : (f _* F).is_sheaf :=
by rw is_sheaf_iff_is_sheaf_pairwise_intersections at h ⊢;
   exact sheaf_condition_pairwise_intersections.pushforward_sheaf_of_sheaf f h

/--
The pushforward functor.
-/
def pushforward (f : X ⟶ Y) : X.sheaf C ⥤ Y.sheaf C :=
{ obj := λ ℱ, ⟨f _* ℱ.1, pushforward_sheaf_of_sheaf f ℱ.2⟩,
  map := λ _ _ g, ⟨pushforward_map f g.1⟩ }

end sheaf

end Top


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

Stochastic computation graphs.
-/
import .det .rand .util .id .sprog .env .reference

namespace certigrad

inductive operator (ishapes : list S) (oshape : S) : Type
| det : det.op ishapes oshape → operator
| rand : rand.op ishapes oshape → operator

namespace operator

def to_dist (m : env) : Π {parents : list reference} {oshape : S}, operator parents^.p2 oshape → sprog [oshape]
| parents _ (det op)   := sprog.ret ⟦op^.f (env.get_ks parents m)⟧
| parents _ (rand op) := sprog.prim op (env.get_ks parents m)

end operator

structure node : Type := (ref : reference) (parents : list (ID × S)) (op : operator parents^.p2 ref.2)
structure graph : Type := (nodes : list node) (costs : list ID) (targets inputs : list reference)

def uniq_ids : Π (nodes : list node) (inputs : env), Prop
| [] inputs := true
| (⟨ref, op, parents⟩ :: nodes) inputs :=
¬ env.has_key ref inputs ∧ ∀ (x : T ref.2), uniq_ids nodes (env.insert ref x inputs)

namespace graph

open sprog

def to_dist {fshapes : list S} (k : env → dvec T fshapes) : env → list node → sprog fshapes
| m []            := ret (k m)
| m (⟨ref, parents, op⟩::nodes) := bind (operator.to_dist m op)
                                        (λ (x : dvec T [ref.2]), to_dist (env.insert ref x^.head m) nodes)

open list

lemma envs_match_helper {fshapes : list S} (k₁ k₂ : env → dvec T fshapes) : Π (inputs : env) (nodes : list node),
    ∀ (n : node) (x : T n^.ref.2),
      uniq_ids (n :: nodes) inputs →
      (∀ (m : env), (∀ (ref : reference), env.has_key ref inputs → env.get ref m = env.get ref inputs) → k₁ m = k₂ m) →
      ∀  (m : env),
         (∀ (r : reference), env.has_key r (env.insert n^.ref x inputs) → env.get r m = env.get r (env.insert n^.ref x inputs)) → k₁ m = k₂ m :=
assume inputs nodes n x H_uids H_k_eq,
assume (m : env) H_next_envs_agree,
  have H_envs_agree : ∀ (ref' : reference), env.has_key ref' inputs → env.get ref' m = env.get ref' inputs, from
    assume (ref' : reference) (H_inputs_contains_ref' : env.has_key ref' inputs),
    show env.get ref' m = env.get ref' inputs, from
    have H_next_contains_name : env.has_key ref' (env.insert n^.ref x inputs), from env.has_key_insert H_inputs_contains_ref',
    have H_next_agree : env.get ref' m = env.get ref' (env.insert n^.ref x inputs), from H_next_envs_agree _ H_next_contains_name,
    have H_ref'_neq_ref : ref' ≠ n^.ref,
      begin
      cases n with ref parents op, dsimp [uniq_ids] at H_uids,
      dsimp, intro H_eq, subst H_eq, exact H_uids^.left H_inputs_contains_ref'
      end,
    begin rw env.get_insert_diff _ _ H_ref'_neq_ref at H_next_agree, exact H_next_agree end,
  H_k_eq _ H_envs_agree

lemma to_dist_k_congr {fshapes : list S} (k₁ k₂ : env → dvec T fshapes) (inputs : env) (nodes : list node) :
  k₁ = k₂ →  graph.to_dist k₁ inputs nodes = graph.to_dist k₂ inputs nodes := by { intro H, rw H }

lemma to_dist_congr {fshapes : list S} (k₁ k₂ : env → dvec T fshapes) : Π (inputs : env) (nodes : list node),
      uniq_ids nodes inputs →
      (∀ (m : env), (∀ (ref : reference), env.has_key ref inputs → env.get ref m = env.get ref inputs) → k₁ m = k₂ m) →
      to_dist k₁ inputs nodes = to_dist k₂ inputs nodes

-- Case 1
| inputs [] H_uids H_k_eq :=
show to_dist k₁ inputs [] = to_dist k₂ inputs [], from
show sprog.ret (k₁ inputs) = sprog.ret (k₂ inputs), from
have H_inputs_eq : ∀ (ref : reference), env.has_key ref inputs → env.get ref inputs = env.get ref inputs, from
  assume (ref : reference) (H_inputs_contain : env.has_key ref inputs), rfl,
by rw (H_k_eq _ H_inputs_eq)

-- Case 2
| inputs (⟨ref, parents, op⟩::nodes) H_uids H_k_eq :=
show to_dist k₁ inputs (⟨ref, parents, op⟩ :: nodes) = to_dist k₂ inputs (⟨ref, parents, op⟩ :: nodes), from
show bind (operator.to_dist inputs op) (λ (x : dvec T [ref.2]), to_dist k₁ (env.insert ref x^.head inputs) nodes)
     =
     bind (operator.to_dist inputs op) (λ (x : dvec T [ref.2]), to_dist k₂ (env.insert ref x^.head inputs) nodes), from
suffices ∀ (x : dvec T [ref.2]), to_dist k₁ (env.insert ref x^.head inputs) nodes = to_dist k₂ (env.insert ref x^.head inputs) nodes, from
  congr_arg _ (funext this),
assume (x : dvec T [ref.2]),
show to_dist k₁ (env.insert ref x^.head inputs) nodes = to_dist k₂ (env.insert ref x^.head inputs) nodes, from
to_dist_congr _ _ (H_uids^.right _) (envs_match_helper k₁ k₂ _ _ _ _ H_uids H_k_eq)

lemma graph_to_dist_inputs_congr {fshapes : list S} (k : env → dvec T fshapes) (inputs₁ inputs₂ : env) (nodes : list node) :
  inputs₁ = inputs₂ → graph.to_dist k inputs₁ nodes = graph.to_dist k inputs₂ nodes := assume H, by rw H

end graph

noncomputable def is_gintegrable {shapes : list S} (k : env → dvec T shapes) {shape : S} : Π (m : env) (nodes : list node) (f : dvec T shapes → T shape), Prop
| _ [] f := true

| m (⟨ref, parents, operator.det op⟩ :: nodes) f := is_gintegrable (env.insert ref (op^.f (env.get_ks parents m)) m) nodes f

| m (⟨ref, parents, operator.rand op⟩ :: nodes) f :=
  let m' := (λ (y : T ref.2), env.insert ref y m) in
  T.is_integrable (λ x, op^.pdf (env.get_ks parents m) x ⬝ E (graph.to_dist k (m' x) nodes) f) ∧
  ∀ x, is_gintegrable (m' x) nodes f

open list

noncomputable def is_gdifferentiable (k : env → dvec T [[]]) : Π (tgt : reference) (m : env) (nodes : list node) (f : dvec T [[]] → ℝ), Prop
| tgt _ [] f := true

| tgt m (⟨ref, parents, operator.det op⟩ :: nodes) f :=
let θ := env.get tgt m,
    x := op^.f (env.get_ks parents m),
    g := (λ (v : dvec T parents^.p2) (θ : T tgt.2), E (graph.to_dist k (env.insert ref (det.op.f op v) (env.insert tgt θ m)) nodes) dvec.head) in

T.is_cdifferentiable (λ (θ₀ : T (tgt.snd)), g (env.get_ks parents (env.insert tgt θ m)) θ₀) θ
∧ T.is_cdifferentiable (λ (θ₀ : T (tgt.snd)), sumr (map (λ (idx : ℕ), g (dvec.update_at θ₀ (env.get_ks parents (env.insert tgt θ m)) idx) θ)
                                                       (filter (λ (idx : ℕ), tgt = dnth parents idx) (riota (length parents))))) θ
∧ is_gdifferentiable tgt (env.insert ref x m) nodes f
∧ ∀ {idx : ℕ}, idx ∈ riota (length parents) → tgt = dnth parents idx → is_gdifferentiable ref (env.insert ref x m) nodes f

| tgt m (⟨ref, parents, operator.rand op⟩ :: nodes) f :=
let g : dvec T [ref.2] → T tgt.2 → ℝ :=
           (λ (x : dvec T [ref.2]) (θ₀ : T tgt.2), E (graph.to_dist k (env.insert ref x^.head (env.insert tgt θ₀ m)) nodes) dvec.head),
   θ : T tgt.2 := env.get tgt m,
   m' := (λ (y : T ref.2), env.insert ref y m) in

T.is_cdifferentiable (λ (θ₀ : T (tgt.snd)), E (sprog.prim op (env.get_ks parents (env.insert tgt θ m))) (λ (y : dvec T [ref.snd]), g y θ₀)) θ
∧ T.is_cdifferentiable (λ (θ₀ : T (tgt.snd)), sumr (map (λ (idx : ℕ), E (sprog.prim op (dvec.update_at θ₀ (env.get_ks parents (env.insert tgt θ m)) idx))
                                                                       (λ (y : dvec T [ref.snd]), g y θ))
                                                       (filter (λ (idx : ℕ), tgt = dnth parents idx) (riota (length parents))))) θ
∧ ∀ (y : T ref.2), is_gdifferentiable tgt (env.insert ref y m) nodes f

lemma is_gintegrable_k_congr {fshapes : list S} {fshape : S} (k₁ k₂ : env → dvec T fshapes) : Π (inputs : env) (nodes : list node) (f : dvec T fshapes → T fshape),
  uniq_ids nodes inputs →
  (∀ (m : env), (∀ (ref : reference), env.has_key ref inputs → env.get ref m = env.get ref inputs) → k₁ m = k₂ m) →
  is_gintegrable k₁ inputs nodes f → is_gintegrable k₂ inputs nodes f

| inputs [] f H_uids H_k_eq H_gint₁ := trivial

| inputs (⟨ref, parents, operator.det op⟩ :: nodes) f H_uids H_k_eq H_gint₁ :=
begin
dsimp [is_gintegrable] at H_gint₁,
dsimp [is_gintegrable],
apply is_gintegrable_k_congr _ _ _ (H_uids^.right _) (graph.envs_match_helper k₁ k₂ _ _ _ _ H_uids H_k_eq) H_gint₁
end

| inputs (⟨ref, parents, operator.rand op⟩ :: nodes) f H_uids H_k_eq H_gint₁ :=
begin
dsimp [is_gintegrable] at H_gint₁,
dsimp [is_gintegrable],
split,
{
assertv H_dist_congr : ∀ x, graph.to_dist k₁ (env.insert ref x inputs) nodes = graph.to_dist k₂ (env.insert ref x inputs) nodes :=
assume x,
graph.to_dist_congr k₁ k₂ _ _ (H_uids^.right _) (graph.envs_match_helper k₁ k₂ _ _ _ _ H_uids H_k_eq),
simp only [H_dist_congr] at H_gint₁,
exact H_gint₁^.left
},

{
intro x,
apply is_gintegrable_k_congr _ _ _ (H_uids^.right _) (graph.envs_match_helper k₁ k₂ _ _ _ _ H_uids H_k_eq) (H_gint₁^.right x)
}

end

-- TODO(dhs): this seems like it could be provable given is_gintegrable and compute_grad_slow_correct
noncomputable def is_nabla_gintegrable (k : env → dvec T [[]]) : Π (tgt : reference) (m : env) (nodes : list node) (f : dvec T [[]] → ℝ), Prop
| tgt m [] f := true

| tgt m (⟨ref, parents, operator.det op⟩ :: nodes) f :=
  is_nabla_gintegrable tgt (env.insert ref (op^.f (env.get_ks parents m)) m) nodes f
  ∧ ∀ {idx : ℕ}, idx ∈ riota (length parents) → tgt = dnth parents idx → is_nabla_gintegrable ref (env.insert ref (op^.f (env.get_ks parents m)) m) nodes f

| tgt m (⟨ref, parents, operator.rand op⟩ :: nodes) f :=
  T.is_integrable (λ (x : T ref.2), op^.pdf (env.get_ks parents m) x ⬝ ∇ (λ (θ₀ : T tgt.2), E (graph.to_dist k (env.insert ref x (env.insert tgt θ₀ m)) nodes) f) (env.get tgt m))

∧ T.is_integrable
    (λ (x : T (ref.snd)),
       rand.op.pdf op (env.get_ks parents m) x ⬝ sumr
         (map
            (λ (idx : ℕ),
               E
                 (graph.to_dist k
                    (env.insert ref x m)
                    nodes)
                 dvec.head ⬝ ∇
                 (λ (θ₀ : T (tgt.snd)),
                    T.log (rand.op.pdf op (dvec.update_at θ₀ (env.get_ks parents m) idx) x))
                 (env.get tgt m))
            (filter (λ (idx : ℕ), tgt = dnth parents idx) (riota (length parents)))))

  ∧ ∀ (y : T ref.2), is_nabla_gintegrable tgt (env.insert ref y m) nodes f

--  is_gintegrable (λ m, ⟦compute_grad_slow costs nodes m tgt⟧) inputs nodes dvec.head →

end certigrad


open function

#print surjective

universes u v w
variables {α : Type u} {β : Type v} {γ : Type w}

lemma surjective_comp {g : β → γ} {f : α → β}
  (hg : surjective g) (hf : surjective f) : surjective (g ∘ f) :=
λ z,
let ⟨y, iy⟩ := hg z,
    ⟨x, ix⟩ := hf y in
  ⟨x, show g(f(x)) = z, by simp *⟩

#print surjective_comp


import ..lovelib

/-! # LoVe Demo 7: Metaprogramming

Users can extend Lean with custom tactics and tools. This kind of
programming—programming the prover—is called metaprogramming.

Lean's metaprogramming framework uses mostly the same notions and syntax as
Lean's input language itself. Abstract syntax trees __reflect__ internal data
structures, e.g., for expressions (terms). The prover's C++ internals are
exposed through Lean interfaces, which we can use for

* accessing the current context and goal;
* unifying expressions;
* querying and modifying the environment;
* setting attributes.

Most of Lean's predefined tactics are implemented in Lean (and not in C++).

Example applications:

* proof goal transformations;
* heuristic proof search;
* decision procedures;
* definition generators;
* advisor tools;
* exporters;
* ad hoc automation.

Advantages of Lean's metaprogramming framework:

* Users do not need to learn another programming language to write
  metaprograms; they can work with the same constructs and notation used to
  define ordinary objects in the prover's library.

* Everything in that library is available for metaprogramming purposes.

* Metaprograms can be written and debugged in the same interactive environment,
  encouraging a style where formal libraries and supporting automation are
  developed at the same time. -/

set_option pp.beta true
set_option pp.generalized_field_notation false

namespace LoVe

/-!

## Well-founded and non-well-founded recursion

The recursive functions we've written are structurally recursive.
But sometimes this feels like too strong of a restriction.
-/

def list.map {α β : Type} (f : α → β) : list α → list β
| [] := []
| (h::t) := f h :: list.map t

lemma list.map_length {α β : Type} (f : α → β): ∀ l :
  list α, list.length (list.map f l) = list.length l
| [] := rfl
| (h::t) := by simp [list.map, list.map_length]

def list.multimap₁ {α : Type} (f : α → α) : list α → list α
| [] := []
| (h::t) := f h :: list.multimap₁ (list.map f t)

def list.multimap₂ {α : Type} (f : α → α) : list α → list α
| [] := []
| (h::t) :=
  have hl : list.sizeof (list.map f t) < 1 + list.sizeof t := sorry,
  f h :: list.multimap₂ (list.map f t)

#eval list.multimap₂ (λ x, x + 1) [0, 0, 0, 0]

def list.multimap₃ {α : Type} (f : α → α) : list α → list α
| [] := []
| (h::t) :=
  have hl : list.length (list.map f t) < list.length t + 1 :=
    by simp [list.map_length, nat.lt_succ_self],
  f h :: list.multimap₃ (list.map f t)
using_well_founded {rel_tac := λ _ _, `[exact ⟨_, measure_wf list.length⟩]}

/-!
Proving well-foundedness can be arbitrarily hard.
-/

def f : ℕ → ℕ
| n := if n = 1 then 1
       else if n%2 = 0 then f (n/2)
       else f (3*n + 1)

/-!
All functions in "standard" Lean must terminate, otherwise we could prove false.

But maybe all we want to do is *compute* with the function, and not worry about
proving anything about it.

The keyword *meta* lets us do exactly this.
Like *noncomputable*, *meta* is sticky: anything that references a meta declaration
must be meta itself.
All it does is disable the well-foundedness checker.
-/

meta def g : ℕ → ℕ
| n := if n = 1 then 1
       else if n%2 = 0 then g (n/2)
       else g (3*n + 1)

#eval (list.iota 100).map g

meta def oops : false := oops

/-!

Note that this use of the word "meta" is somewhat misleading.
Nothing is "about Lean" yet, we've just defined a language extension.
Morally speaking, meta definitions are ones that we intend for "computation
purposes only."

## What are tactics, really?

Recall that when we write a tactic proof, it's generating a proof term under the hood.

Between each tactic we can inspect a *proof state*, which has a context and goal.

A tactic behaves like a function from proof state to proof state.
-/

lemma test_lemma : ∀ x, x = 3 → x + 10 = 13 :=
begin
  intros x hx,
  cases hx,
  refl
end

#print test_lemma

/-
But tactics can fail. So they're not total functions.
And tactics can also fail to terminate.
-/

-- example (x y z : ℕ) : x + y + z = z + y + x :=
-- by simp [add_comm x y, add_comm y x]

/-!

So it feels like we have something like

    meta def simp : simp_args → tactic_state → option tactic_state

Which is actually not so far from the truth!

We've mentioned the difference between `#reduce` and `#eval`.
`#eval` is for data only. It doesn't care about proof terms, instead interpreting
expressions in the Lean virtual machine.

It replaces certain data types and operations with more efficient implementations,
e.g. arithmetic on `nat`.

It also replaces certain *constants* with actual data.

-/

#print tactic_state
#print tactic_state.get_options

/-

So a tactic in Lean is like a function `tactic_state → tactic_state`.
It can use these uninterpreted constants like `get_options`.
In a `begin...end` block, Lean generates the initial tactic state.
Then it sequentially calls the tactics in the block, producing a new tactic state.
When a tactic leaves a state that has no goals, the proof is done.

There are some hiccups here.
* "State"? Sounds imperative!
* Stringing together `option`-valued functions sounds annoying.
* How do we write these? Can we read and write to the state at the same time?

These questions aren't unique to Lean -- these are common functional programming issues.
They have a solution: *monads*.

## Monads

Extra reference: https://leanprover.github.io/programming_in_lean/#07_Monads.html

Monads are an abstraction of "programming with side effects."
The side effects we'll be interested in are state and failure.

In general, a __monad__ is a type constructor `m` that depends on some type
parameter `α` (i.e., `m α`) equipped with two distinguished operations:

    `pure {α : Type} : α → m α`
    `bind {α β : Type} : m α → (α → m β) → m β`

Consider the following programming task:

    Implement a function `sum_2_5_7 ns` that sums up the second, fifth, and
    seventh items of a list `ns` of natural numbers. Use `option ℕ` for the
    result so that if the list has fewer than seven elements, you can return
    `option.none`.

A straightforward solution follows: -/

def sum_2_5_7 (ns : list ℕ) : option ℕ :=
match list.nth ns 1 with
| option.none    := option.none
| option.some n2 :=
  match list.nth ns 4 with
  | option.none    := option.none
  | option.some n5 :=
    match list.nth ns 6 with
    | option.none    := option.none
    | option.some n7 := option.some (n2 + n5 + n7)
    end
  end
end

/-!
`option` is a monad with failure. `some v` is the success case,
`none` is the failure case.

If `v : ℕ`, then `pure v = some v`. `bind` is `connect`:
-/

def connect {α : Type} {β : Type} :
  option α → (α → option β) → option β
| option.none     f := option.none
| (option.some a) f := f a

def sum_2_5_7₂ (ns : list ℕ) : option ℕ :=
connect (list.nth ns 1)
  (λn2, connect (list.nth ns 4)
     (λn5, connect (list.nth ns 6)
        (λn7, option.some (n2 + n5 + n7))))

def sum_2_5_7₆ (ns : list ℕ) : option ℕ :=
do
  n2 ← list.nth ns 1,
  n5 ← list.nth ns 4,
  n7 ← list.nth ns 6,
  pure (n2 + n5 + n7)

/-!

Programming with state is also monadic.

`action σ α` is the type of functions that take in a state of type `σ`
and produce a value of type `α`, along with a possibly updated state.
-/

def action (σ α : Type) : Type :=
σ → α × σ

def action.read {σ : Type} : action σ σ :=
λ s, (s, s)

def action.write {σ : Type} (s : σ) : action σ unit :=
λ _, ((), s)

def action.pure {σ α : Type} (a : α) : action σ α :=
λ s, (a, s)

def action.bind {σ : Type} {α β : Type} (ma : action σ α)
    (f : α → action σ β) :
  action σ β :=
λ s, match ma s with
| (a, s') := f a s'
end

@[instance] def action.monad {σ : Type} :
  monad (action σ) :=
{ pure       := @action.pure σ,
  bind       := @action.bind σ }

def nat_action : action ℕ string :=
do
  first_val ← action.read,
  action.write (first_val * 2),
  new_val ← action.read,
  pure (to_string first_val ++ " ---> " ++ to_string new_val)

#eval nat_action 3

/-!

## The tactic monad

tactic α := tactic_state → result tactic_state α

A tactic can read and/or modify the tactic state, and either succeeds
(producing a value of type α) or fails with an exception message.

-/

#print tactic
#print result

#check tactic.local_context

open tactic

meta def my_first_tactic : tactic unit :=
do
  l ← local_context,
  trace l

meta def show_true : tactic unit :=
do applyc `trivial

example (a b c : ℕ) (h : a + b + c = 0) : true :=
begin
  my_first_tactic,
  show_true
end

run_cmd my_first_tactic

meta def apply_and : tactic unit :=
do
  trace "applying and.intro",
  applyc `and.intro

example : true ∧ true :=
begin
  apply_and,
  show_true, show_true
end

meta def apply_and_or_intro : tactic unit :=
do applyc `and.intro <|>
do intro `nv, skip

example : false → true ∧ true :=
begin
  apply_and_or_intro,
  apply_and_or_intro,
  show_true, show_true
end

meta def my_repeat : tactic unit → tactic unit :=
λ t, (do t, my_repeat t) <|> skip

example : false → true ∧ true :=
begin
  my_repeat apply_and_or_intro,
  my_repeat show_true
end

/-!

## Built-in data types

To be properly "meta," our tactics should be able to express
and manipulate Lean programs (= terms).
We see these in Lean as traditional data types. But, like `tactic_state`
and others, the runtime representation of these is different.

-/

#check declaration
#check tactic.get_decl

#check name
#print name

#check `nat
#check `nat.succ

#print prefix name

#check expr
#print expr

#check expr.to_raw_fmt

open tactic

run_cmd do
  d ← get_decl `nat.succ,
  trace d.type.to_raw_fmt

/-!

A closed expression (e.g. the type or body of a declaration in the environment)
should have no occurrences of `local_const` or `mvar`.
`elet` and `macro` can always be expanded.

Bound variables (`var`) are indexed by natural numbers, not names!
The names and types are stored in the binders (`lam` or `pi`).
`var 0` refers to "the variable bound by the closest binder."
`var 1` refers to "the variable bound by the second-closest binder."
And so on.

But often we aren't dealing with closed expressions.
If we get the type of the goal in the middle of a proof, it will probably refer
to things in the local context.
These are represented as local constants, `local_const`.
They have a unique name, pretty-printing name, binder info, and type.

-/

meta def expr.local_unique_name : expr → name
| (expr.local_const nm ppnm bi tp) := nm
| _ := default _

example (a a a : ℕ) : true := by do
  lc ← local_context,
  trace lc,
  trace (lc.map expr.local_unique_name),
  triv

/-!

Things that are already defined in our environment can be accessed as `const`s.
A `const` has a name and list of universe parameters.

Often we won't build these by hand, but use `tactic.mk_const`.
-/

#check expr.const `nat []
run_cmd do
  e ← mk_const `nat,
  trace e.to_raw_fmt

/-!
Building expressions by hand is rather cumbersome. There are ways around this.
`tactic.mk_app` will fill in implicit arguments for you.
-/

#check tactic.mk_app

run_cmd do
  z ← mk_const `nat.zero,
  a ← mk_app `nat.add [z, z],
  trace a,
  if a = z then trace "eq" else trace "neq"

/-!
We can also write *quoted* expressions, like quoted names.
-/

#check `(0 + 0)

/-!
We can insert expressions into quoted expressions using antiquotes:
-/

meta def trace_add_expr (e : expr) : tactic unit :=
trace `(0 + %%e)

run_cmd trace_add_expr `(44)

run_cmd trace_add_expr `(nat)

/-!
Sometimes expr quoting fails. In these cases, we might have to use `pexpr`s.
A pre-expression corresponds to unelaborated, input-level syntax:
implicit arguments have not been filled in yet.

`tactic.to_expr` performs *elaboration*: it turns a `pexpr` into an `expr`.
-/

meta def trace_add_expr' (e : expr) : tactic unit :=
trace `(%%e + %%e)

meta def trace_add_expr' (e : expr) : tactic unit := do
  e ← to_expr ``(%%e + %%e),
  trace e

run_cmd trace_add_expr' `(44)

run_cmd trace_add_expr' `(nat)

/-!
We can walk through expressions, normally and monadically:
-/

#check @expr.fold

#eval expr.fold `(1 + 0) "" (λ e _ s, s ++ ", " ++ to_string e)

#check @expr.mfold

run_cmd expr.mfold `(1 + 0) () (λ e _ _, tactic.trace e)

/-!
One of the most important operations on `expr` is type inference.
-/

run_cmd do
  t ← infer_type `(λ x : ℕ, x + 1),
  trace t

/-!

*Declarations* are stored in the *environment*.
A declaration is an axiom, constant, theorem, or definition.

-/

#check tactic.get_env
#check environment.fold
#check environment.mfold

run_cmd do
  e ← get_env,
  environment.mfold e () (λ d _, tactic.trace (declaration.to_name d))

/-!
## Working with goals and hypotheses

We already saw the tactic `local_context` for getting hypotheses.
`target` returns the type of the goal.
`get_local` retrieves a single hypothesis by name.
-/

example (a b c : ℕ) (h : a + b = c) : a + c + 0 = a + c + 1 - 1 :=
by do
  lc ← local_context,
  trace lc,
  lc_types ← list.mmap infer_type lc,
  trace lc_types,
  tgt ← target,
  trace tgt,
  admit

/-!
`tactic.assert` adds a new hypothesis, creating a new goal for its proof.

There are lots of variants.
-/

example (a b c : ℕ) : true :=
by do
  ac ← get_local `a,
  bc ← get_local `b,
  tactic.assert `new_hyp `(%%ac + %%bc = 0),
  trace_state,
  admit,
  admit

#check tactic.assert
#check tactic.assertv
#check @tactic.note
#check @tactic.note_anon

/-!

To modify the goal, we have our familiar `apply` tactic,
in a few variants:

-/

#check tactic.apply
#check tactic.applyc
#check tactic.exact

/-!
There are lots of ways to call the simplifier...
-/

#check tactic.simplify
#check tactic.simp_target
#check tactic.simp_hyp

/-!
If you want the familiar begin..end block syntax, there's
yet another form of quotation: e.g.

    `[simp [lemma1, lemma2] at h]

is of type `tactic unit`.
-/

example (a b c : ℕ) (h : a + b = c) : a + c + 0 = a + c + 1 - 1 :=
by do
  lc ← local_context,
  trace lc,
  lc_types ← list.mmap infer_type lc,
  trace lc_types,
  tgt ← target,
  trace tgt,
  `[simp]

/-! ## Example: A Conjuction-Destructing Tactic

We define a `destruct_and` tactic that automates the elimination of `∧` in
premises, automating proofs such as these: -/

lemma abcd_a (a b c d : Prop) (h : a ∧ (b ∧ c) ∧ d) :
  a :=
and.elim_left h

lemma abcd_b (a b c d : Prop) (h : a ∧ (b ∧ c) ∧ d) :
  b :=
and.elim_left (and.elim_left (and.elim_right h))

lemma abcd_bc (a b c d : Prop) (h : a ∧ (b ∧ c) ∧ d) :
  b ∧ c :=
and.elim_left (and.elim_right h)

/-! Our tactic relies on a helper metafunction, which takes as argument the
hypothesis `h` to use as an expression rather than as a name: -/

meta def destruct_and_helper : expr → tactic unit
| h :=
  do
    t ← tactic.infer_type h,
    match t with
    | `(%%a ∧ %%b) :=
      tactic.exact h
      <|>
      do {
        ha ← tactic.to_expr ``(and.elim_left %%h),
        destruct_and_helper ha }
      <|>
      do {
        hb ← tactic.to_expr ``(and.elim_right %%h),
        destruct_and_helper hb }
    | _            := tactic.exact h
    end

meta def tactic.destruct_and (nam : name) : tactic unit :=
do
  h ← tactic.get_local nam,
  destruct_and_helper h

/-! Let us check that our tactic works: -/

lemma abc_a (a b c : Prop) (h : a ∧ b ∧ c) :
  a :=
by tactic.destruct_and `h

lemma abc_b (a b c : Prop) (h : a ∧ b ∧ c) :
  b :=
by tactic.destruct_and `h

lemma abc_bc (a b c : Prop) (h : a ∧ b ∧ c) :
  b ∧ c :=
by tactic.destruct_and `h

lemma abc_ac (a b c : Prop) (h : a ∧ b ∧ c) :
  a ∧ c :=
by destruct_and `h   -- fails

/-!
## Interactive parsing

Writing
    destruct_and `h
with the quoted name `h` is ugly. We don't want to do this in our tactic proofs.
And indeed, most of the time, we don't have to:
there's no quoting in `apply h`, `simp [h]`, etc.

There's some trickery going on here at the parser level.
`begin...end` and `by` blocks are parsed in "interactive tactic mode."
When we wrote `by destruct_and` above, Lean first looked for a declaration
called `tactic.interactive.destruct_and`. When it failed to find such a tactic,
it fell back on resolving `destruct_and` in the normal way.
-/

#check @tactic.apply
#check @tactic.interactive.apply

/-!
Instead of taking arguments of type `expr`, `name`, etc., interactive mode tactics
take parser commands.

`setup_tactic_parser` is equivalent to
```
open _root_.lean
open _root_.lean.parser
open _root_.interactive _root_.interactive.types
local postfix `?`:9001 := optional
local postfix *:9001 := many .
```
-/

section interactive_mode

setup_tactic_parser

meta def _root_.tactic.interactive.destruct_and (h : parse ident) : tactic unit :=
tactic.destruct_and h

/-!
`parse ident` is definitionally equal to `name`, but in interactive mode,
we can write it unquoted.
We put this in the `_root_` namespace to escape the `LoVe` namespace.
-/

lemma abc_bc' (a b c : Prop) (h : a ∧ b ∧ c) :
  b ∧ c :=
by destruct_and h

#check parse parser.pexpr
#check parse pexpr_list
#check parse ident*
#check parse ident?

end interactive_mode

meta def tactic.destruct_and_anon : tactic unit :=
do
  lc ← local_context,
  lc.mfirst (λ h, destruct_and_helper h)

section interactive_mode

setup_tactic_parser

meta def _root_.tactic.interactive.destruct_and' (h : parse ident?) : tactic unit :=
match h with
| some h' := tactic.destruct_and h'
| none    := tactic.destruct_and_anon
end

lemma abc_bc'' (a b c : Prop) (h : a ∧ b ∧ c) :
  b ∧ c :=
by destruct_and'

/-!
Interactive-mode tactics are *always* `tactic unit`.
-/

end interactive_mode

/-!

## Goal management

We know that tactics ultimately need to build a proof term.
How does this actually happen?

At the beginning of a begin...end block where the goal is to prove `T`,
Lean creates a *metavariable* `?m1 : T`.
Tactics that update the goal, like `applyc`,
(partially) assign values to the goal metavariable.
These values can contain new metavariables.

-/

example : true ∧ false :=
by do
  gs ← get_goals,
  trace gs,
  trace (gs.map expr.to_raw_fmt),
  gs' ← gs.mmap infer_type,
  trace gs',
  let orig_goal := gs.head,
  trace "------",

  applyc `and.intro,

  gs ← get_goals,
  trace gs,
  trace (gs.map expr.to_raw_fmt),
  gs' ← gs.mmap infer_type,
  trace gs',
  trace "------",

  orig_goal ← instantiate_mvars orig_goal,
  trace orig_goal.to_raw_fmt

/-!
`get_goals` returns a list of metavariables (of type `epxr`),
representing the remaining proof obligations.
*Unifying* these metavariables with other terms will create partial assignments.

(This is a very low-level technique, we don't usually do this in practice!)
-/

example : true :=
by do
  [g] ← get_goals,
  trace g,
  unify g `(trivial),
  gs ← get_goals,
  trace gs,
  set_goals [],
  gs ← get_goals,
  trace gs

/-!
Note that this can also get us in "trouble": we can tell the system we've
finished a proof when we really haven't.
-/

meta def _root_.tactic.interactive.oops : tactic unit :=
do
  mv ← mk_meta_var `(true),
  set_goals [mv]

example : false :=
begin
  oops,
  trivial,
end

/-!

Metavariable assignments are stored in the tactic state.
So the ultimate goal of a begin...end block is:
"write a function tactic_state → tactic_state that assigns the initial goal
metavariable to a term that does not contain any metavariables."

-/

/-!

## Proof by reflection

YOu may have noticed that we can't prove anything about the tactics we write.
But there's a middle ground: sometimes with a bit of meta "wrapper code,"
we can turn proofs about syntax-like operations into actual proof terms.

The general strategy looks like this:
* represent the syntax of some class of formulas in (non-meta) Lean
* define an interpretation function from these formulas to Prop
* define some operation on this syntax, and prove it correct with respect to the interpretation
* write a small bit of meta code that turns a goal into a statement about your reflected syntax

The idea is that the goal left after applying your correctness theorem can be proved by computation.

This is commonly used for evaluation or normalization functions.
`ring`, for example, can be implemented by defining the syntax of ring expressions
and verifying a normalization algorithm:
if
`ring_syntax : Type`,
`interp {α : Type} [ring α] : ring_syntax → α`,
`normalize : ring_syntax → ring_syntax`, then
`∀ r1 r2 : ring_syntax, interp r1 = interp r2 ↔ normalize r1 = normalize r2`.

The meta code looks at a goal `c + a*b = b*a + c`,
constructs `ring_syntax` objects `r1` and `r2` representing both sides,
and changes the goal to showing that `normalize r1 = normalize r2`.
This can be proved by `refl`.

-/

inductive bexpr
| atom : bool → bexpr
| and : bexpr → bexpr → bexpr
| or : bexpr → bexpr → bexpr
| imp : bexpr → bexpr → bexpr
| not : bexpr → bexpr

open bexpr

def interp : bexpr → Prop
| (atom tt) := true
| (atom ff) := false
| (and a b) := interp a ∧ interp b
| (or a b) := interp a ∨ interp b
| (imp a b) := interp a → interp b
| (not b) := ¬ interp b

def normalize : bexpr → bool
| (atom b) := b
| (and a b) := normalize a && normalize b
| (or a b) := normalize a || normalize b
| (imp a b) := (bnot (normalize a)) || normalize b
| (not b) := bnot (normalize b)

theorem normalize_correct (b : bexpr) : normalize b = tt ↔ interp b :=
begin
  induction' b; try {simp [normalize, interp] at *},
  case and : { finish },
  case or : { finish },
  case not : { simpa using not_iff_not.mpr ih },
  case atom: { cases b; simp [normalize, interp] },
  case imp :
  { have h_not : normalize b = ff ↔ ¬ interp b := by simpa using not_iff_not.mpr ih_b,
    finish },
end

meta def bexpr_of_expr : expr → option expr
| `(true) := some `(bexpr.atom tt)
| `(false) := some `(bexpr.atom ff)
| `(%%a ∧ %%b) := do a ← bexpr_of_expr a, b ← bexpr_of_expr b, some `(bexpr.and %%(a) %%(b))
| `(%%a ∨ %%b) := do a ← bexpr_of_expr a, b ← bexpr_of_expr b, some `(bexpr.or %%(a) %%(b))
| `(%%a → %%b) := do a ← bexpr_of_expr a, b ← bexpr_of_expr b, some `(bexpr.imp %%(a) %%(b))
| `(¬ %%a) := do a ← bexpr_of_expr a, some `(bexpr.not %%(a))
| _ := none

meta def _root_.tactic.interactive.change_goal : tactic unit :=
do
  t ← target,
  match bexpr_of_expr t with
  | some t' := do apply `(iff.mp (normalize_correct %%(t'))), skip
  | none := fail "goal is not a bexpr pattern"
  end

example : (true → true) ∨ false :=
begin
  change_goal,
  refl
end

/-!
You could imagine doing the same with, say, a SAT solver.

Modify `bexpr` to cover all propositional formulas: `atom : ℕ → bexpr`.
Add an argument to `interp`: `dict : ℕ → Prop` assigning atoms to propositions.
`normalize` becomes `is_tautology : bexpr → bool`.
`normalize_correct` becomes
  `is_tautology_correct (b : bexpr) : is_tautology b = tt ↔ ∀ dict, interp dict b`
`bexpr_of_expr` will also have to return a dictionary.

-/

end LoVe


import tree
import complexity_class.basic

@[user_attribute]
meta def complexity_class_attr : user_attribute :=
{ name := `complexity,
  descr := "lemmas usable to prove a function is primitive recursive" }

@[user_attribute]
meta def primrec_attr : user_attribute :=
{ name := `primrec,
  descr := "lemmas usable to prove a function is primitive recursive" }

@[user_attribute]
meta def polytime_attr  : user_attribute :=
{ name := `polytime,
  descr := "lemmas usable to prove a function is primitive recursive" }

namespace tactic

meta def is_tencodable (e : expr) : tactic bool :=
(do
   e' ← infer_type e,
   cache ← mk_instance_cache e',
   (cache', s) ← instance_cache.get cache ``tencodable,
   return tt) <|> (return ff)

-- meta def get_num_params (s : expr) : tactic ℕ :=
-- -- TODO: This should be based on the type of `s`, not the fact that `s` is a lambda function
-- do  guard s.is_lambda <|> fail "Not a lambda function",
--     mv ← mk_meta_var s.binding_domain,
--     e ←  instantiate_mvars (s.instantiate_lambdas [mv]),
--     f ← mfilter is_tencodable e.get_app_args,
--     return f.length

/-- Compute the maximum number of arguments subject to the conditions that
  only encodable and non-dependent arguments can be counted -/
meta def get_num_params_aux : expr → list expr → tactic ℕ
| tp (x :: xs) :=
do tp' ← whnf tp reducible,
  (do guard tp'.is_arrow,
    to_expr ``(tencodable %%tp'.binding_domain) >>= mk_instance,
    (+1) <$> get_num_params_aux tp'.binding_body xs
  ) <|> (guard tp'.is_pi >> get_num_params_aux (tp'.instantiate_pis [x]) xs)
| tp [] := pure 0

meta def get_num_params (s : expr) : tactic ℕ :=
do guard s.is_lambda <|> fail "Not a lambda function",
   mv ← mk_meta_var s.binding_domain,
   e ←  instantiate_mvars (s.instantiate_lambdas [mv]),
   let args := e.get_app_args,
   let fn := e.get_app_fn,
   -- Special casing `tree.node` because it is always called with argument `unit` TODO: a better way?
   if fn.const_name = ``tree.node then return 2
   else do
    tp ← infer_type fn,
    get_num_params_aux tp args

#check expr.is_constant

inductive tactic_classes
| prim | poly | computable

-- returns (function, complexity class, true if predicate false if function)
meta def get_goal_uncurry_base_fun : tactic (expr × expr × bool) :=
(do
  `(@complexity_class.mem _ _ _ _ _ (@function.has_uncurry_base _ _) %%f %%C) ← target,
  return (f, C, ff)) <|>
(do
  `(@complexity_class.mem_pred _ _ _ (@function.has_uncurry_base _ _) %%f %%C) ← target,
  return (f, C, tt))

meta def rw_lemmas : list name × list (expr ff) :=
([``complexity_class.mem, ``complexity_class.mem_pred], [``(complexity_class.mem1_iff_mem), ``(complexity_class.mem1_iff_mem_pred)])

meta def tactic_classes.attr_name : tactic_classes → name
| tactic_classes.prim := primrec_attr.name
| tactic_classes.poly := polytime_attr.name
| _ := default

meta def fail_lemmas : list name :=
[``complexity_class.const, ``complexity_class.mem.pair]

def comp_lemmas : bool → list name
| tt := [``complexity_class.const, ``complexity_class.mem_pred.comp, ``complexity_class.mem_pred.comp₂, ``complexity_class.mem_pred.comp₃]
| ff := [``complexity_class.const, ``complexity_class.mem.comp, ``complexity_class.mem.comp₂, ``complexity_class.mem.comp₃, ``complexity_class.mem.comp₄, ``complexity_class.mem.comp₅, ``complexity_class.mem.comp₆]

/-- Uncurries the target so that `polytime (λ (x : α) (y : β), ...)` becomes `polytime (λ (xy : α × β), ...)` -/
meta def uncurry_target (md : transparency) : tactic unit :=
do fail_if_success get_goal_uncurry_base_fun,
   dsimp_target simp_lemmas.mk (rw_lemmas.1 ++ [``function.has_uncurry.uncurry, ``id]) { md := md },
   first (rw_lemmas.2.map $ λ e, to_expr e >>= rewrite_target)

meta def try_comp (md : transparency) : tactic ℕ :=
do fail_lemmas.mfoldl (λ (_ : unit) x, fail_if_success (do
    x' ← resolve_name x,
    e ← to_expr x' tt ff,
    apply e { md := md })
   ) (),
   old_goal ← target,
   (target_fun, C, is_pred) ← get_goal_uncurry_base_fun,
   let comp_lemmas : list name := comp_lemmas is_pred,
   n ← get_num_params target_fun,
   guard (0 < n ∧ n < comp_lemmas.length),
   s' ← to_expr $ expr.const (comp_lemmas.inth n) [],
   apply s' {md := md},
   try `[ any_goals { apply_instance, } ], -- why is this necessary??
   (fail_if_success (uncurry_target md >> target >>= λ t, unify t old_goal md)) <|>
    focus1 (apply_rules [] [complexity_class_attr.name] 50 { md := md } >> done),
  return n

meta def auto_computable (md : transparency := reducible) : list (tactic string) :=
[
  apply_rules [] [complexity_class_attr.name] 50 { md := md }
                        >> pure ("apply_rules with " ++ (to_string complexity_class_attr.name)),
  uncurry_target md >> pure ("uncurry_target md"),
  try_comp md >>= λ n, pure ("apply comp" ++ (to_string n))
]

/- Given a goal of the form `a P b`, if `new_tgt` is a pexpr, say `a'`, changes
  the goal to `a' P b` and adds the goal `a = a'` -/
meta def rw_arg_ext (new_tgt : pexpr) : tactic unit :=
do tgt ← target,
   guard tgt.is_app,
   let arg₁ := tgt.app_fn,
   guard arg₁.is_app,
   let arg := arg₁.app_arg,
   n ← mk_fresh_name,
   to_expr ``(%%arg = %%new_tgt) >>= assert n,
   focus1 (symmetry >> tactic.funext),
   swap,
   resolve_name n >>= to_expr >>= rewrite_target

namespace interactive

setup_tactic_parser

meta def complexity
  (bang : parse $ optional (tk "!")) (trace : parse $ optional (tk "?")) (rw_tgt : parse $ (tk "using" *> texpr)?) (cfg : tidy.cfg := {}) :
  tactic unit :=
let md              := if bang.is_some then semireducible else reducible,
    core := tactic.tidy { tactics := auto_computable md, ..cfg },
    trace_fn        := if trace.is_some then show_term else id in
/- Make sure assumptions and goals are in the right form before we start -/
do try `[simp only [complexity_class.prop_iff_mem, complexity_class.mem1_iff_mem] at *],
  rw_tgt.elim skip (λ rw_tgt', rw_arg_ext rw_tgt'),
  trace_fn core

meta def clean_target : tactic unit :=
(expr.clean <$> target) >>= unsafe_change

end interactive

end tactic

attribute [complexity]
  complexity_class.const
  complexity_class.mem.pair
  complexity_class.mem.fst
  complexity_class.mem.snd
  complexity_class.mem_pred.ite

@[complexity]
lemma complexity_class.id' {α} [tencodable α] (C : complexity_class) :
  C.mem (λ x : α, x) := ⟨_, C.id, λ _, rfl⟩

example (C : complexity_class) : C.mem (λ (x : ℕ × ℕ), (x, x.2)) :=
by { complexity, }