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

! This file was ported from Lean 3 source module category_theory.sites.cover_preserving
! leanprover-community/mathlib commit e2e38c005fc6f715502490da6cb0ec84df9ed228
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.CategoryTheory.Sites.Limits
import Mathbin.CategoryTheory.Functor.Flat
import Mathbin.CategoryTheory.Limits.Preserves.Filtered

/-!
# Cover-preserving functors between sites.

We define cover-preserving functors between sites as functors that push covering sieves to
covering sieves. A cover-preserving and compatible-preserving functor `G : C ⥤ D` then pulls
sheaves on `D` back to sheaves on `C` via `G.op ⋙ -`.

## Main definitions

* `category_theory.cover_preserving`: a functor between sites is cover-preserving if it
pushes covering sieves to covering sieves
* `category_theory.compatible_preserving`: a functor between sites is compatible-preserving
if it pushes compatible families of elements to compatible families.
* `category_theory.pullback_sheaf`: the pullback of a sheaf along a cover-preserving and
compatible-preserving functor.
* `category_theory.sites.pullback`: the induced functor `Sheaf K A ⥤ Sheaf J A` for a
cover-preserving and compatible-preserving functor `G : (C, J) ⥤ (D, K)`.

## Main results

- `category_theory.sites.whiskering_left_is_sheaf_of_cover_preserving`: If `G : C ⥤ D` is
cover-preserving and compatible-preserving, then `G ⋙ -` (`uᵖ`) as a functor
`(Dᵒᵖ ⥤ A) ⥤ (Cᵒᵖ ⥤ A)` of presheaves maps sheaves to sheaves.

## References

* [Elephant]: *Sketches of an Elephant*, P. T. Johnstone: C2.3.
* https://stacks.math.columbia.edu/tag/00WW

-/

universe w v₁ v₂ v₃ u₁ u₂ u₃

noncomputable section

open CategoryTheory

open Opposite

open CategoryTheory.Presieve.FamilyOfElements

open CategoryTheory.Presieve

open CategoryTheory.Limits

namespace CategoryTheory

variable {C : Type u₁} [Category.{v₁} C] {D : Type u₂} [Category.{v₂} D]

variable {A : Type u₃} [Category.{v₃} A]

variable (J : GrothendieckTopology C) (K : GrothendieckTopology D)

variable {L : GrothendieckTopology A}

/-- A functor `G : (C, J) ⥤ (D, K)` between sites is *cover-preserving*
if for all covering sieves `R` in `C`, `R.pushforward_functor G` is a covering sieve in `D`.
-/
@[nolint has_nonempty_instance]
structure CoverPreserving (G : C ⥤ D) : Prop where
  cover_preserve : ∀ {U : C} {S : Sieve U} (hS : S ∈ J U), S.functorPushforward G ∈ K (G.obj U)
#align category_theory.cover_preserving CategoryTheory.CoverPreserving

/-- The identity functor on a site is cover-preserving. -/
theorem idCoverPreserving : CoverPreserving J J (𝟭 _) :=
  ⟨fun U S hS => by simpa using hS⟩
#align category_theory.id_cover_preserving CategoryTheory.idCoverPreserving

variable (J) (K)

/-- The composition of two cover-preserving functors is cover-preserving. -/
theorem CoverPreserving.comp {F} (hF : CoverPreserving J K F) {G} (hG : CoverPreserving K L G) :
    CoverPreserving J L (F ⋙ G) :=
  ⟨fun U S hS => by
    rw [sieve.functor_pushforward_comp]
    exact hG.cover_preserve (hF.cover_preserve hS)⟩
#align category_theory.cover_preserving.comp CategoryTheory.CoverPreserving.comp

/-- A functor `G : (C, J) ⥤ (D, K)` between sites is called compatible preserving if for each
compatible family of elements at `C` and valued in `G.op ⋙ ℱ`, and each commuting diagram
`f₁ ≫ G.map g₁ = f₂ ≫ G.map g₂`, `x g₁` and `x g₂` coincide when restricted via `fᵢ`.
This is actually stronger than merely preserving compatible families because of the definition of
`functor_pushforward` used.
-/
@[nolint has_nonempty_instance]
structure CompatiblePreserving (K : GrothendieckTopology D) (G : C ⥤ D) : Prop where
  Compatible :
    ∀ (ℱ : SheafOfTypes.{w} K) {Z} {T : Presieve Z} {x : FamilyOfElements (G.op ⋙ ℱ.val) T}
      (h : x.Compatible) {Y₁ Y₂} {X} (f₁ : X ⟶ G.obj Y₁) (f₂ : X ⟶ G.obj Y₂) {g₁ : Y₁ ⟶ Z}
      {g₂ : Y₂ ⟶ Z} (hg₁ : T g₁) (hg₂ : T g₂) (eq : f₁ ≫ G.map g₁ = f₂ ≫ G.map g₂),
      ℱ.val.map f₁.op (x g₁ hg₁) = ℱ.val.map f₂.op (x g₂ hg₂)
#align category_theory.compatible_preserving CategoryTheory.CompatiblePreserving

variable {J K} {G : C ⥤ D} (hG : CompatiblePreserving.{w} K G) (ℱ : SheafOfTypes.{w} K) {Z : C}

variable {T : Presieve Z} {x : FamilyOfElements (G.op ⋙ ℱ.val) T} (h : x.Compatible)

include h hG

/-- `compatible_preserving` functors indeed preserve compatible families. -/
theorem Presieve.FamilyOfElements.Compatible.functorPushforward :
    (x.functorPushforward G).Compatible :=
  by
  rintro Z₁ Z₂ W g₁ g₂ f₁' f₂' H₁ H₂ eq
  unfold family_of_elements.functor_pushforward
  rcases get_functor_pushforward_structure H₁ with ⟨X₁, f₁, h₁, hf₁, rfl⟩
  rcases get_functor_pushforward_structure H₂ with ⟨X₂, f₂, h₂, hf₂, rfl⟩
  suffices : ℱ.val.map (g₁ ≫ h₁).op (x f₁ hf₁) = ℱ.val.map (g₂ ≫ h₂).op (x f₂ hf₂)
  simpa using this
  apply hG.compatible ℱ h _ _ hf₁ hf₂
  simpa using Eq
#align category_theory.presieve.family_of_elements.compatible.functor_pushforward CategoryTheory.Presieve.FamilyOfElements.Compatible.functorPushforward

@[simp]
theorem CompatiblePreserving.apply_map {Y : C} {f : Y ⟶ Z} (hf : T f) :
    x.functorPushforward G (G.map f) (image_mem_functorPushforward G T hf) = x f hf :=
  by
  unfold family_of_elements.functor_pushforward
  rcases e₁ : get_functor_pushforward_structure (image_mem_functor_pushforward G T hf) with
    ⟨X, g, f', hg, eq⟩
  simpa using hG.compatible ℱ h f' (𝟙 _) hg hf (by simp [Eq])
#align category_theory.compatible_preserving.apply_map CategoryTheory.CompatiblePreserving.apply_map

omit h hG

open Limits.WalkingCospan

theorem compatiblePreservingOfFlat {C : Type u₁} [Category.{v₁} C] {D : Type u₁} [Category.{v₁} D]
    (K : GrothendieckTopology D) (G : C ⥤ D) [RepresentablyFlat G] : CompatiblePreserving K G :=
  by
  constructor
  intro ℱ Z T x hx Y₁ Y₂ X f₁ f₂ g₁ g₂ hg₁ hg₂ e
  -- First, `f₁` and `f₂` form a cone over `cospan g₁ g₂ ⋙ u`.
  let c : cone (cospan g₁ g₂ ⋙ G) :=
    (cones.postcompose (diagram_iso_cospan (cospan g₁ g₂ ⋙ G)).inv).obj (pullback_cone.mk f₁ f₂ e)
  /-
    This can then be viewed as a cospan of structured arrows, and we may obtain an arbitrary cone
    over it since `structured_arrow W u` is cofiltered.
    Then, it suffices to prove that it is compatible when restricted onto `u(c'.X.right)`.
    -/
  let c' := is_cofiltered.cone (structured_arrow_cone.to_diagram c ⋙ structured_arrow.pre _ _ _)
  have eq₁ : f₁ = (c'.X.hom ≫ G.map (c'.π.app left).right) ≫ eq_to_hom (by simp) :=
    by
    erw [← (c'.π.app left).w]
    dsimp
    simp
  have eq₂ : f₂ = (c'.X.hom ≫ G.map (c'.π.app right).right) ≫ eq_to_hom (by simp) :=
    by
    erw [← (c'.π.app right).w]
    dsimp
    simp
  conv_lhs => rw [eq₁]
  conv_rhs => rw [eq₂]
  simp only [op_comp, functor.map_comp, types_comp_apply, eq_to_hom_op, eq_to_hom_map]
  congr 1
  /-
    Since everything now falls in the image of `u`,
    the result follows from the compatibility of `x` in the image of `u`.
    -/
  injection c'.π.naturality walking_cospan.hom.inl with _ e₁
  injection c'.π.naturality walking_cospan.hom.inr with _ e₂
  exact hx (c'.π.app left).right (c'.π.app right).right hg₁ hg₂ (e₁.symm.trans e₂)
#align category_theory.compatible_preserving_of_flat CategoryTheory.compatiblePreservingOfFlat

theorem compatiblePreservingOfDownwardsClosed (F : C ⥤ D) [Full F] [Faithful F]
    (hF : ∀ {c : C} {d : D} (f : d ⟶ F.obj c), Σc', F.obj c' ≅ d) : CompatiblePreserving K F :=
  by
  constructor
  introv hx he
  obtain ⟨X', e⟩ := hF f₁
  apply (ℱ.1.mapIso e.op).toEquiv.Injective
  simp only [iso.op_hom, iso.to_equiv_fun, ℱ.1.mapIso_hom, ← functor_to_types.map_comp_apply]
  simpa using
    hx (F.preimage <| e.hom ≫ f₁) (F.preimage <| e.hom ≫ f₂) hg₁ hg₂
      (F.map_injective <| by simpa using he)
#align category_theory.compatible_preserving_of_downwards_closed CategoryTheory.compatiblePreservingOfDownwardsClosed

/-- If `G` is cover-preserving and compatible-preserving,
then `G.op ⋙ _` pulls sheaves back to sheaves.

This result is basically <https://stacks.math.columbia.edu/tag/00WW>.
-/
theorem pullback_isSheaf_of_coverPreserving {G : C ⥤ D} (hG₁ : CompatiblePreserving.{v₃} K G)
    (hG₂ : CoverPreserving J K G) (ℱ : Sheaf K A) : Presheaf.IsSheaf J (G.op ⋙ ℱ.val) :=
  by
  intro X U S hS x hx
  change family_of_elements (G.op ⋙ ℱ.val ⋙ coyoneda.obj (op X)) _ at x
  let H := ℱ.2 X _ (hG₂.cover_preserve hS)
  let hx' := hx.functor_pushforward hG₁ (sheaf_over ℱ X)
  constructor; swap
  · apply H.amalgamate (x.functor_pushforward G)
    exact hx'
  constructor
  · intro V f hf
    convert H.is_amalgamation hx' (G.map f) (image_mem_functor_pushforward G S hf)
    rw [hG₁.apply_map (sheaf_over ℱ X) hx]
  · intro y hy
    refine'
      H.is_separated_for _ y _ _ (H.is_amalgamation (hx.functor_pushforward hG₁ (sheaf_over ℱ X)))
    rintro V f ⟨Z, f', g', h, rfl⟩
    erw [family_of_elements.comp_of_compatible (S.functor_pushforward G) hx'
        (image_mem_functor_pushforward G S h) g']
    dsimp
    simp [hG₁.apply_map (sheaf_over ℱ X) hx h, ← hy f' h]
#align category_theory.pullback_is_sheaf_of_cover_preserving CategoryTheory.pullback_isSheaf_of_coverPreserving

/-- The pullback of a sheaf along a cover-preserving and compatible-preserving functor. -/
def pullbackSheaf {G : C ⥤ D} (hG₁ : CompatiblePreserving K G) (hG₂ : CoverPreserving J K G)
    (ℱ : Sheaf K A) : Sheaf J A :=
  ⟨G.op ⋙ ℱ.val, pullback_isSheaf_of_coverPreserving hG₁ hG₂ ℱ⟩
#align category_theory.pullback_sheaf CategoryTheory.pullbackSheaf

variable (A)

/-- The induced functor from `Sheaf K A ⥤ Sheaf J A` given by `G.op ⋙ _`
if `G` is cover-preserving and compatible-preserving.
-/
@[simps]
def Sites.pullback {G : C ⥤ D} (hG₁ : CompatiblePreserving K G) (hG₂ : CoverPreserving J K G) :
    Sheaf K A ⥤ Sheaf J A where
  obj ℱ := pullbackSheaf hG₁ hG₂ ℱ
  map _ _ f := ⟨((whiskeringLeft _ _ _).obj G.op).map f.val⟩
  map_id' ℱ := by
    ext1
    apply ((whiskering_left _ _ _).obj G.op).map_id
  map_comp' _ _ _ f g := by
    ext1
    apply ((whiskering_left _ _ _).obj G.op).map_comp
#align category_theory.sites.pullback CategoryTheory.Sites.pullback

end CategoryTheory


import Architectural.ArchWithContracts
import Architectural.ArchitectureDecomp
import tactic

variables {Φ Var : Type} [fintype Var] [decidable_eq Var] [AssertionLang Φ Var]

@[reducible]
def list_conj : list Φ → Φ
| [] := ⊤
| (h::t) := AssertionLang.conj Var (h) (list_conj t)

theorem list_conj_iff (l : list Φ) (σ : Trace Var) : (σ ∈ (@AssertionLang.sem Φ Var _ _ _ (@list_conj Φ Var _ _ _ l))) ↔ (∀ φ ∈ l, σ ∈ (@AssertionLang.sem Φ Var _ _ _ φ)) :=
begin
  split,
  intro H1,
  intros φ H2,
  induction l with hd tl IH,
  exfalso, assumption,
  cases H2,rw H2,
  unfold list_conj at H1,
  rw AssertionLang.conj_def at H1,
  cases H1 with H11 H22, exact H11,
  apply IH,
  unfold list_conj at H1,
  rw AssertionLang.conj_def at H1,
  exact H1.2, assumption,

  intros H,
  induction l with hd tl IH,
  unfold list_conj, rw AssertionLang.T_def, simp,
  obtain H1 := H hd,
  unfold list_conj,
  rw AssertionLang.conj_def,
  split,
  apply H1,
  simp,
  apply IH,
  intros φ H',
  have : φ ∈ hd::tl, from list.mem_cons_of_mem hd H',
  cases this,
  rw this, apply H, exact list.mem_cons_self hd tl,
  apply H φ, exact list.mem_cons_of_mem hd H',
end

@[reducible]
def get_nfs {S : Component Var} (A : ArchitectureWithContracts Φ S) : list Φ :=
  (A.subs.map (λ C, (A.contracts.find_val C).iget)).map (λ C, C.nf)

def RPO_fst {S : Component Var} (A : ArchitectureWithContracts Φ S): Prop :=
  ∀ σ , σ ∈ (@AssertionLang.sem Φ Var _ _ _  (@AssertionLang.Impl Φ Var _ _ _ (@list_conj Φ Var _ _ _ (get_nfs A)) (A.parent.nf)))

def RPO_snd {S : Component Var}  (A : ArchitectureWithContracts Φ S) : Prop :=
  ∀ S' ∈ A.subs,
  ∀ σ, σ ∈ (@AssertionLang.sem Φ Var _ _ _
  (@AssertionLang.Impl Φ Var _ _ _
  (AssertionLang.conj Var A.parent.A (@list_conj Φ Var _ _ _ (list.map (λ C : Component Var,  (A.contracts.find_val C).iget.nf) (A.subs.erase S')))) (A.contracts.find_val S').iget.A)
  )

def RPO {S : Component Var}  (A : ArchitectureWithContracts Φ S) : Prop := RPO_fst A ∧ RPO_snd A

variables S : Component Var

variables IMPLEMENTATIONS : Π (U : Component Var),  Impl Var

variable CURRENT_ENVIRONMENT : Env Var

def isCorrectImplementation (C : Component Var) (I : Impl Var) (Ctr : Contract Φ Var) : Claim (Trace Var) :=
{
  X := I,
  P := λ σ, σ ∈ (@AssertionLang.sem Φ Var _ _ _ Ctr.A) → σ ∈
                (@AssertionLang.sem Φ Var _ _ _ Ctr.G)
}

def isGoodEnv (E : Env Var) (C : Contract Φ Var) : Claim (Trace Var) :=
{
  X := E,
  P := λ s, s ∈ (@AssertionLang.sem Φ Var _ _ _ C.A)
}

namespace Contract

def to_arch_components
{S : Component Var}
 (A : ArchitectureWithContracts Φ S)
(IMPLEMENTATIONS : Implementations A.to_Architecture) :
Π (a : Component Var), (λ (C : Component Var), C ∈ A.to_Architecture.subs) a → Claim (Trace Var) :=
λ a h, isCorrectImplementation a  (IMPLEMENTATIONS a h) (A.contracts.find_val a).iget

def strategy
 {S : Component Var}
 (A : ArchitectureWithContracts Φ S)
 (Is : Implementations A.to_Architecture)
 (CURRENT_ENVIRONMENT : Env Var) : Strategy (Trace Var) :=
{ parent := Claim.correctDecomposition A Is CURRENT_ENVIRONMENT,
  decomp := λ _,
  (@list.pmap (Component Var) (Claim (Trace Var)) (λ C, C ∈ A.subs)
  (λ a h, isCorrectImplementation a (Is a h) (A.contracts.find_val a).iget) A.subs (by {simp,}))++[isGoodEnv CURRENT_ENVIRONMENT A.parent]

}

def mk_strategy {S : Component Var}
 (A : ArchitectureWithContracts Φ S) : Strategy (Trace Var) := Contract.strategy A (λ e h, set.univ) (set.univ)

def strat_is_deductive
{S : Component Var}
(A : ArchitectureWithContracts Φ S) : Prop := ∀ Is : Implementations A.to_Architecture, ∀ E : Env Var,
deductive (Trace Var) (Contract.strategy A Is E)

end Contract

lemma subclaims_meaning_env
 {S : Component Var}
 (A : ArchitectureWithContracts Φ S)
 (IMPLEMENTATIONS : Implementations A.to_Architecture)
 (CURRENT_ENVIRONMENT : Env Var)
 :
  (∀ clm ∈ (Contract.strategy A IMPLEMENTATIONS CURRENT_ENVIRONMENT).subclaims, ⟦clm⟧) →
 ⟦isGoodEnv CURRENT_ENVIRONMENT A.parent⟧ :=
begin
 intros H₁,
 replace H₁ := H₁ (isGoodEnv CURRENT_ENVIRONMENT A.parent),
 rw Contract.strategy at H₁, rw Strategy.subclaims at H₁,
  simp at H₁,
  exact H₁,
end

lemma subclaims_meaning_impl
 {S : Component Var}
 (A : ArchitectureWithContracts Φ S)
 (IMPLEMENTATIONS : Implementations A.to_Architecture)
 (CURRENT_ENVIRONMENT : Env Var):
  (∀ clm ∈ (Contract.strategy A IMPLEMENTATIONS CURRENT_ENVIRONMENT).subclaims, ⟦clm⟧) →
 ∀ C ∈ A.subs, ⟦isCorrectImplementation C (IMPLEMENTATIONS C H) (A.contracts.find_val C).iget⟧ :=
begin
 intros H₁,
 rw Contract.strategy at H₁, rw Strategy.subclaims at H₁,
 simp at H₁,
 intros C mem,
 replace H₁ := H₁ (isCorrectImplementation C (IMPLEMENTATIONS C mem) (Map.find_val C A.contracts).iget),
 apply H₁,
 clear H₁,
 left, use C,
 split, refl, assumption,
end

lemma subclaims_meaning
  {S : Component Var}
 (A : ArchitectureWithContracts Φ S)
 (IMPLEMENTATIONS : Implementations A.to_Architecture)
 (CURRENT_ENVIRONMENT : Env Var) :
  (∀ clm ∈ (Contract.strategy A IMPLEMENTATIONS CURRENT_ENVIRONMENT).subclaims, ⟦clm⟧) →
  ⟦isGoodEnv CURRENT_ENVIRONMENT A.parent⟧ ∧
 ∀ C ∈ A.subs, ⟦isCorrectImplementation C (IMPLEMENTATIONS C H) (A.contracts.find_val C).iget⟧ :=
begin
  intros H₁,
  split, apply subclaims_meaning_env, assumption,
  apply subclaims_meaning_impl, assumption,
end

-- theorem validity : deductive (Trace PORTS) (Contract.strategy IMPLEMENTATIONS CURRENT_ENVIRONMENT) :=
-- begin
--   intro H,
--   replace H := subclaims_meaning _ _ H,
--   cases H with Henv Himpl,
--   rw Contract.strategy,
--   simp,
--   rw Claim.correctDecomposition,
--   rw meaning,
--   simp,
--   intros σ,
--   split, {
--     rw Claim.correctDecompositionImpl,
--     intros H₁ H₂,
--     rw CI at H₂,
--     simp at H₂,
--     sorry
--   }
-- end

-- def LACU_ARCH_WITH_CONTRACTS : ArchitectureWithContracts lt_eq_assertions LACU :=

theorem via_rpo
{S : Component Var}
{A : ArchitectureWithContracts Φ S}
(E :  Env Var)
(Is :Implementations A.to_Architecture)
: RPO A → deductive (Trace Var) (Contract.strategy A Is E) :=
begin
  rintros ⟨H₁, H₂⟩,
  intros H,
  replace H := subclaims_meaning _ _  _ H,
  cases H with H₃ H₄,
  intros σ mem,
  rw Contract.strategy, rw Claim.correctDecomposition,
  simp, split, {
  clear H₂ H₃,
  rw Claim.correctDecompositionImpl, simp,
  intros H₂ H₃ H₅,
  rw CompositeImplementation at H₃,
  simp at H₃,
  rw RPO_fst at H₁,
  replace H₁ := H₁ σ,
  rw AssertionLang.impl_def at H₁,
  have : σ ∈ AssertionLang.sem (list_conj (get_nfs A)) := by
  {
    rw list_conj_iff,
    rw get_nfs,
    simp,
    intros S' Hmem,
    have : Map.find_val S' A.contracts ≠ none, from A.all_components S' Hmem,
    have opt : ∃ C : Contract Φ Var, Map.find_val S' A.contracts = some C, by
      {exact option.ne_none_iff_exists'.mp this,},
    cases opt with C H₆,
    have further : (Map.find_val S' A.contracts).iget = C, by {exact (congr_arg option.iget H₆).trans rfl,},
    simp [further] at *,
    replace H₄ := H₄ S' Hmem,
    rw isCorrectImplementation at H₄,
    rw meaning at H₄, simp at H₄,
    replace H₃ := H₃ S' S',
    unfold set.Inter at H₃,
    unfold infi at H₃,
    unfold Inf at H₃,
    simp at H₃,
    replace H₄ := H₄ σ (H₃ Hmem),
    have further : (Map.find_val S' A.contracts).iget = C, by {exact (congr_arg option.iget H₆).trans rfl,},
    simp [further] at *, clear further,
    rw AssertionLang.disj_def,
    have EM : σ ∈ @AssertionLang.sem Φ Var _ _ _ (AssertionLang.compl Var C.A) ∨ σ ∉ AssertionLang.sem (AssertionLang.compl Var C.A), from or_not,
    cases EM,
    left, assumption,
    right, apply H₄,
    rw AssertionLang.compl_def at EM,
    simp at EM, exact EM,
  },
  replace H₁ := H₁ this,
  rw AssertionLang.disj_def at H₁,
  cases H₁,
  rw AssertionLang.compl_def at H₁,
  simp at H₁,
  contradiction,
  exact H₁,},
  { clear H₁,
    rw Claim.correctDecompositionEnv,
    intros  _ S' EnvSat H₅ H₈ H₆,
    rw CompositeEnvironment at H₆,
    simp at H₆, cases H₆ with H₆ H₇,
    rw RPO_snd at H₂,
    replace H₂ := H₂ S' EnvSat σ,
    rw AssertionLang.impl_def at H₂,
    apply H₂, clear H₂, simp,
    rw AssertionLang.conj_def, split,
    rw Env.satisfiesContract at H₅,
    apply H₅, apply H₆,
    rw list_conj_iff,
    dsimp at *,
    intros φ hφ, simp at *,
    cases hφ with w h,
    cases h with h1 h2,
    have opt : ∃ C : Contract Φ Var, Map.find_val w A.contracts = some C, by
      {exact option.ne_none_iff_exists'.mp (A.all_components w (list.mem_of_mem_erase h1)),},
    cases opt with C H₆,
    have further : (Map.find_val w A.contracts).iget = C, by {exact (congr_arg option.iget H₆).trans rfl,},
    simp [further] at *,
    rw ← h2, rw AssertionLang.disj_def, tidy,
    replace H₄ := H₄ w (list.mem_of_mem_erase h1),
    rw meaning at H₄, rw isCorrectImplementation at H₄, replace H₄ := H₄ σ,simp at H₄,
    replace H₇ := (H₇ w w (h1)),
    rw H₆_1 at *,
    replace H₄ := H₄ H₇,
    rw AssertionLang.compl_def,
    simp at *,
    rwa ← imp_iff_not_or,
  }
end


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

The actual graph produced by the naive variational auto-encoder code in aevb/prog.lean.

Note: we include this file as an optimization, to avoid repeatedly simplifying the
program into the graph.
-/
import ..program ..prove_model_ok .util .prog

namespace certigrad
namespace aevb

section nodes

open det rand.op label tactic certigrad.tactic

#print "Defining graph_naive..."

def graph_naive : Π (a : arch) (x_data : T [a^.n_in, a^.n_x]), graph
| a x_data :=
graph.mk [⟨(ID.nat 0, [a^.ne, a^.bs]), [(ID.str W_encode₁, [a^.ne, a^.n_in]), (ID.str x, [a^.n_in, a^.bs])], operator.det $ ops.gemm _ _ _⟩,
          ⟨(ID.nat 1, [a^.ne, a^.bs]), [(ID.nat 0, [a^.ne, a^.bs])], operator.det $ ops.softplus _⟩,
          ⟨(ID.nat 2, [a^.ne, a^.bs]), [(ID.str W_encode₂, [a^.ne, a^.ne]), (ID.nat 1, [a^.ne, a^.bs])], operator.det $ ops.gemm _ _ _⟩,
          ⟨(ID.str h_encode, [a^.ne, a^.bs]), [(ID.nat 2, [a^.ne, a^.bs])], operator.det $ ops.softplus _⟩,
          ⟨(ID.str μ, [a^.nz, a^.bs]), [(ID.str W_encode_μ, [a^.nz, a^.ne]), (ID.str h_encode, [a^.ne, a^.bs])], operator.det $ ops.gemm _ _ _⟩,
          ⟨(ID.nat 5, [a^.nz, a^.bs]), [(ID.str W_encode_logσ₂, [a^.nz, a^.ne]), (ID.str h_encode, [a^.ne, a^.bs])], operator.det $ ops.gemm _ _ _⟩,
          ⟨(ID.nat 6, [a^.nz, a^.bs]), [(ID.nat 5, [a^.nz, a^.bs])], operator.det $ ops.exp _⟩,
          ⟨(ID.str σ, [a^.nz, a^.bs]), [(ID.nat 6, [a^.nz, a^.bs])], operator.det $ ops.sqrt _⟩,
          ⟨(ID.str z, [a^.nz, a^.bs]), [(ID.str μ, [a^.nz, a^.bs]), (ID.str σ, [a^.nz, a^.bs])], operator.rand $ mvn _⟩,
          ⟨(ID.str encoding_loss, []), [(ID.str μ, [a^.nz, a^.bs]), (ID.str σ, [a^.nz, a^.bs]), (ID.str z, [a^.nz, a^.bs])], operator.det $ op.mvn_empirical_kl _⟩,
          ⟨(ID.nat 10, [a^.nd, a^.bs]), [(ID.str W_decode₁, [a^.nd, a^.nz]), (ID.str z, [a^.nz, a^.bs])], operator.det $ ops.gemm _ _ _⟩,
          ⟨(ID.nat 11, [a^.nd, a^.bs]), [(ID.nat 10, [a^.nd, a^.bs])], operator.det $ ops.softplus _⟩,
          ⟨(ID.nat 12, [a^.nd, a^.bs]), [(ID.str W_decode₂, [a^.nd, a^.nd]), (ID.nat 11, [a^.nd, a^.bs])], operator.det $ ops.gemm _ _ _⟩,
          ⟨(ID.str h_decode, [a^.nd, a^.bs]), [(ID.nat 12, [a^.nd, a^.bs])], operator.det $ ops.softplus _⟩,
          ⟨(ID.nat 14, [a^.n_in, a^.bs]), [(ID.str W_decode_p, [a^.n_in, a^.nd]), (ID.str h_decode, [a^.nd, a^.bs])], operator.det $ ops.gemm _ _ _⟩,
          ⟨(ID.str p, [a^.n_in, a^.bs]), [(ID.nat 14, [a^.n_in, a^.bs])], operator.det $ ops.sigmoid _⟩,
          ⟨(ID.str decoding_loss, []), [(ID.str p, [a^.n_in, a^.bs]), (ID.str x, [a^.n_in, a^.bs])], operator.det $ ops.bernoulli_neglogpdf _⟩]
         [ID.str encoding_loss, ID.str decoding_loss]
         [(ID.str W_encode₁, [a^.ne, a^.n_in]), (ID.str W_encode₂, [a^.ne, a^.ne]), (ID.str W_encode_μ, [a^.nz, a^.ne]), (ID.str W_encode_logσ₂, [a^.nz, a^.ne]),
          (ID.str W_decode₁, [a^.nd, a^.nz]), (ID.str W_decode₂, [a^.nd, a^.nd]), (ID.str W_decode_p, [a^.n_in, a^.nd])]
         [(ID.str x, [a^.n_in, a^.bs]),
          (ID.str W_encode₁, [a^.ne, a^.n_in]), (ID.str W_encode₂, [a^.ne, a^.ne]), (ID.str W_encode_μ, [a^.nz, a^.ne]), (ID.str W_encode_logσ₂, [a^.nz, a^.ne]),
          (ID.str W_decode₁, [a^.nd, a^.nz]), (ID.str W_decode₂, [a^.nd, a^.nd]), (ID.str W_decode_p, [a^.n_in, a^.nd])]

attribute [cgsimp] graph_naive

open tactic certigrad.tactic

#print "proving naive_aevb_as_graph..."
@[cgsimp] lemma naive_aevb_as_graph (a : arch) (x_data : T [a^.n_in, a^.n_x]) : naive_aevb a x_data = graph_naive a x_data :=
by { dunfold naive_aevb, cgsimp, dcgsimp, cgsimp, reflexivity }

end nodes

end aevb
end certigrad


import super.lpo
open tactic expr super

example (x : ℕ) : true := by do
x ← get_local `x,
let gt := mk_lpo [``eq,
  x.local_uniq_name, ``has_add.add, ``has_zero.zero],
let d (x y : pexpr) := (do
  x ← to_expr x,
  y ← to_expr y,
  trace (x,y,gt x y)),
d ```(x + x) ```(x),
d ```(x + 0) ```(x),
d ```(x) ```(x + 0),
d ```(x = x + 0) ```(x + 0 = x),
m ← mk_meta_var `(ℕ),
d ```(%%m + 0 = %%m) ```(%%m = %%m + 0),
d ```(%%m + 0) ```(%%m),
unify m `(0),
triv


import Std

def List.enum' (L : List α) : List (Fin L.length × α) :=
  let rec go (rest : List α) (i : Nat)
              (h : i + rest.length = L.length) :=
    match rest, h with
    | [], _ => []
    | (x :: xs), h =>
      (⟨i, (h.symm ▸ Nat.lt_add_of_pos_right (Nat.zero_lt_succ _))⟩, x)
      :: go xs (i+1) (by
        simp [←h, Nat.add_succ, Nat.succ_add])
  go L 0 (by simp)

def Fin.last (n : Nat) (_ : 0 < n) : Fin n :=
  match n with
  | 0 => by contradiction
  | n+1 => ⟨n, Nat.le_refl _⟩

def Fin.pred? : Fin n → Option (Fin n)
| ⟨0, _⟩ => none
| ⟨i+1,h⟩ => some ⟨i, Nat.le_of_succ_le h⟩

def Fin.succ? : {n : Nat} → Fin n → Option (Fin n)
| 0, i => i.elim0
| n+1, ⟨i,_⟩ =>
  if h : i < n
  then some ⟨i+1, Nat.succ_le_succ h⟩
  else none

def Function.iterate (f : α → α) : Nat → (α → α)
| 0 => id
| n+1 => iterate f n ∘ f

def Array.init (n : Nat) (f : Fin n → α) : Array α := Id.run do
  let mut A := Array.mkEmpty n
  for h:i in [0:n] do
    A := A.push (f ⟨i,h.2⟩)
  return A

def Array.initM [Monad m] (n : Nat) (f : Fin n → m α) : m (Array α) := do
  let mut A := Array.mkEmpty n
  for h:i in [0:n] do
    A := A.push (← f ⟨i,h.2⟩)
  return A

theorem Array.init_zero : Array.init 0 f = #[] := by
  simp [init, Id.run, forIn', Std.Range.forIn']
  unfold Std.Range.forIn'.loop
  simp

theorem Array.init_succ {f : Fin n.succ → α}
  : Array.init n.succ f = (
      Array.init n (fun i => f ⟨i,Nat.lt_trans i.isLt (by exact Nat.le_refl _)⟩)
    ).push (f ⟨n, by exact Nat.le_refl _⟩)
  := by
  simp [init, Id.run, forIn', Std.Range.forIn']
  suffices ∀ i (hi : i ≤ n) o (_ : o.size = n-i),
    Std.Range.forIn'.loop (m := Id) 0 n.succ 1
      (fun i h r => ForInStep.yield (push r (f ⟨i, h.2⟩)))
      i.succ (n-i)
      (Nat.zero_le _)
      o
    = push (Std.Range.forIn'.loop (m := Id) 0 n 1
      (fun i h r => ForInStep.yield (push r (f ⟨i, Nat.le_step h.2⟩)))
      i (n-i)
      (Nat.zero_le _)
      o) (f ⟨n, Nat.lt_succ_self n⟩)
    by
    have := this n (Nat.le_refl _) #[] (by simp)
    simp at this
    exact this
  intro i hi o ho
  induction i generalizing o with
  | zero =>
    unfold Std.Range.forIn'.loop
    unfold Std.Range.forIn'.loop
    simp
  | succ i ih =>
    conv => lhs; unfold Std.Range.forIn'.loop
    conv => rhs; unfold Std.Range.forIn'.loop
    simp
    have hn := Nat.sub_lt_of_pos_le _ _ (Nat.succ_pos _) hi
    have hn' : n - Nat.succ i < Nat.succ n := Nat.le_step hn
    simp [hn, hn']
    have : n - Nat.succ i + 1 = n - i := by
      simp [Nat.sub_succ]
      rw [Nat.add_one, Nat.succ_pred_eq_of_pos (Nat.zero_lt_sub_of_lt hi)]
    suffices ∀ j, j = n - Nat.succ i + 1 →
      Std.Range.forIn'.loop (m := Id)  _ _ _ _ _ j (Nat.zero_le _) _
      = push (Std.Range.forIn'.loop (m := Id) _ _ _ _ _ j (Nat.zero_le _) _) _
      from this _ rfl
    intro j hj
    rw [this] at hj
    cases hj
    apply ih
    exact Nat.le_of_lt hi
    simp [ho, this]

@[simp]
theorem Array.size_init : (Array.init n f).size = n := by
  induction n
  . simp [size, init_zero]
  . next ih =>
    simp [init_succ]; exact ih

@[simp]
theorem Array.get_init {i : Nat} {h} : (Array.init n f)[i]'h = f ⟨i, @size_init n _ f ▸ h⟩ := by
  induction n generalizing i with
  | zero => simp at h; exact False.elim <| Nat.not_lt_zero _ h
  | succ n ih =>
    simp [init_succ, get_push]
    split
    next h =>
      have := @ih (fun i => f ⟨i,Nat.lt_trans i.isLt (by exact Nat.le_refl _)⟩) i (by simp; assumption)
      simp at this ⊢
      rw [this]
    next h' =>
      simp at h'
      have : i = n := Nat.le_antisymm
        (Nat.le_of_succ_le_succ (by rw [size_init] at h; exact h))
        h'
      cases this
      congr

def List.distinct [DecidableEq α] (L : List α) : List α :=
  L.foldl (·.insert ·) []

def List.isDistinct [BEq α] : List α → Bool
| [] => true
| x::xs => !xs.contains x && xs.isDistinct

def List.fins (n : Nat) : List (Fin n) :=
  finsAux n (Nat.le_refl _) []
where
  finsAux : (i : Nat) → i ≤ n → List (Fin n) → List (Fin n)
  | 0, _, acc => acc
  | i+1, h, acc => finsAux i (Nat.le_of_lt h) (⟨i,h⟩ :: acc)

/- Better parallelism primitive, that is actually like Scala's Future -/
def TaskIO (α) := IO (Task (Except IO.Error α))

namespace TaskIO

instance : Monad TaskIO where
  pure a := pure (f := IO) <| Task.pure (Except.ok a)
  bind a f := bind (m := IO) a (fun task =>
    IO.bindTask task (fun res => do
      let res ← ofExcept res
      f res))

instance : MonadLift IO TaskIO where
  monadLift io := io.map (fun a => Task.pure (Except.ok a))

def wait (task : TaskIO α) : IO α := do
  let task ← task
  let x ← IO.wait task
  ofExcept x

instance : MonadExceptOf IO.Error TaskIO where
  throw e := show IO _ from throw e
  tryCatch a f := bind (m := IO) a (IO.bindTask · fun
    | .ok a => show TaskIO _ from pure a
    | .error e => f e)

def par [ForIn IO σ α] (xs : σ) (f : α → TaskIO β)
    : TaskIO (List β) := show IO _ from do
  let mut tasks := #[]
  for x in xs do
    tasks := tasks.push (← (f x))
  let task ← IO.mapTasks (fun bs => do
    return ←bs.mapM (fun b => ofExcept b)
  ) tasks.toList
  return task

def parUnit [ForIn IO σ α] (xs : σ) (f : α → TaskIO Unit)
    : TaskIO Unit := do
  let _allUnits ← par xs f
  return ()

def parTasks [ForIn IO σ α] (xs : σ) (f : α → IO β)
    : TaskIO (List β) := do
  par xs (fun a => liftM (n := IO) <| IO.asTask (do f a))

def parTasksUnit [ForIn IO σ α] (xs : σ) (f : α → IO Unit)
    : TaskIO Unit := do
  parUnit xs (fun a => liftM (n := IO) <| IO.asTask (do f a))

end TaskIO

def Option.forIn [Monad m] (o : Option α) (b : β) (f : α → β → m (ForInStep β)) : m β := do
  match o with
  | none => return b
  | some a =>
  match ← f a b with
  | .done b => return b
  | .yield b => return b

instance : ForIn m (Option α) α where
  forIn := Option.forIn

def IO.timeMs (prog : IO α) : IO (Nat × α) := do
  let start ← IO.monoMsNow
  let res ← prog
  let end_ ← IO.monoMsNow

  return (end_ - start, res)

instance : GetElem String Nat Char (fun s i => i < s.length) where
  getElem | xs, i, _ => xs.get (String.Pos.mk i)

def randFin (n) (_h : n > 0) : IO (Fin n) := do
  let i ← IO.rand 0 n.pred
  if h : i < n then
    return ⟨i,h⟩
  else
    panic! s!"failed to get random number {i} < {n}"

/- Generate a random permutation of the list.
Implementation is quadratic in length of L. -/
def IO.randPerm (L : List α) : IO (List α) :=
  randPermTR L [] 0
where randPermTR (L acc n) := do
  match L with
  | [] => return acc
  | x::xs =>
    let idx ← IO.rand 0 n
    let acc' := acc.insertNth idx x
    randPermTR xs acc' (n+1)

@[simp]
theorem List.sizeOf_filter [SizeOf α] (f) (L : List α)
  : sizeOf (List.filter f L) ≤ sizeOf L
  := by
  induction L <;> simp [filter]
  split
  . simp
    apply Nat.add_le_add_left
    assumption
  . simp
    apply Nat.le_trans ?_ (Nat.le_add_left _ _)
    assumption

theorem List.sizeOf_filter_lt_of_ne [SizeOf α] (f) (L : List α)
    (h : List.filter f L ≠ L)
  : sizeOf (List.filter f L) < sizeOf L
  := by
  induction L <;> simp [filter] at *
  next hd tl ih =>
  split
  next hHd =>
    simp [hHd] at h
    simp [_sizeOf_1]
    apply Nat.add_lt_add_left
    apply ih
    assumption
  next hHd =>
    clear h hHd
    apply Nat.lt_of_le_of_lt (sizeOf_filter _ _)
    rw [Nat.add_comm, Nat.add_comm 1, Nat.add_one, Nat.add_succ]
    apply Nat.succ_le_succ
    apply Nat.le_add_right

@[simp] theorem List.find?_map (p : β → Bool) (f : α → β) (L : List α)
  : List.find? p (List.map f L) = Option.map f (List.find? (p ∘ f) L)
  := by induction L <;> simp; split <;> simp [*]

@[simp]
def Std.AssocList.ofList : List (α × β) → Std.AssocList α β
| [] => .nil
| (a,b)::tail => .cons a b (ofList tail)

@[simp] theorem Std.AssocList.toList_ofList (L : List (α × β))
  : toList (ofList L) = L
  := by induction L <;> simp [*]

@[simp]
theorem Std.HashMap.find?_ofList {B : BEq α} {H : Hashable α} (a : List (α × β)) (k : α)
  : (@Std.HashMap.ofList _ B H _ a |>.find? k) = (Std.AssocList.ofList a |>.find? k)
  := sorry

@[inline]
def Option.expectSome (err : Unit → ε) : Option α → Except ε α
| none => .error (err ())
| some a => .ok a

structure NonemptyList (α) where
  hd : α
  tl : List α

@[inline]
def List.expectNonempty (err : Unit → ε) : List α → Except ε (NonemptyList α)
| [] => .error (err ())
| hd::tl => .ok ⟨hd,tl⟩

def PrinterM := StateM String
def PrinterM.putStr : String → PrinterM Unit :=
  fun string state => ((), state.append string)
def PrinterM.run : PrinterM Unit → String := (StateT.run · "" |>.2)

instance : Monad PrinterM := show Monad (StateM String) from inferInstance

def IO.FS.withTempFile (f : System.FilePath → IO α) : IO α := do
  let mut file := ".tmp"
  while ← System.FilePath.pathExists file do
    file := file ++ toString (← IO.rand 0 999999)

  IO.FS.writeFile file ""
  let res ← f file
  if ← System.FilePath.pathExists file then
    IO.FS.removeFile file

  return res


import .sous_foncteur
import category_theory.elements
import .A2
open category_theory
open A2
open int
-- universes  v u
lemma int_commute_with_morph  {A B :Type }[comm_ring A][comm_ring B](f : A →  B)[is_ring_hom  f](n : ℕ) : ∀ x : A, f( n*x ) = n *(f x) := λ x,
    nat.rec_on n (show  f(0*x) = 0* (f x), {rw [zero_mul,zero_mul], exact is_ring_hom.map_zero f, })
        (assume n, assume rec_hyp : f(n * x) = n *(f x),
            show f( (n+1)*x) = (n+1)*(f(x)),{
                rw [right_distrib,right_distrib,one_mul,one_mul,← rec_hyp,is_ring_hom.map_add f],
            })
structure A2_disc(R : Type )[comm_ring R] :=
(ζ : A2 R)
(inv_disc : R)
(certif_disc : (ζ.a * ζ.a - ↑4 * ζ.b ) * inv_disc = 1)
namespace A2_disc
section
variables {R : Type } [comm_ring R]
--- idée faire des lemmes simplificateurs !
lemma disc :  ∀ {ζ1 ζ2 : A2_disc R}, ζ1.ζ = ζ2.ζ → ((ζ1.ζ.a = ζ2.ζ.a) ∧ (ζ1.ζ.b = ζ2.ζ.b)) :=
begin
    intros ζ1 ζ2,
    intro h,
    split,
    apply congr_arg, assumption,
    apply congr_arg, assumption,
end
lemma disc_ :  ∀ {ζ1 ζ2 : A2_disc R}, ζ1.ζ = ζ2.ζ  →  (ζ1.ζ.a * ζ1.ζ.a - ↑4 * ζ1.ζ.b ) = (ζ2.ζ.a * ζ2.ζ.a - ↑4 * ζ2.ζ.b ) :=
begin
    intros ζ1 ζ2,
    intro h,
    have H : ((ζ1.ζ.a = ζ2.ζ.a) ∧ (ζ1.ζ.b = ζ2.ζ.b)),
        apply disc,
        assumption,
    rw H.1,
    rw H.2,
end
    lemma inverse_unique (a b c d: R) : a * c = 1 → d * b = 1 → a = d → c = b := λ h1 h2 h3, begin  --- remettre dans l'ordre
        have : c = (a * b) * c,
            rw h3,
            rw h2,
            rw one_mul c,
        rw this,
        rw [mul_assoc, mul_comm b c,← mul_assoc,h1, one_mul],
        end
    @[ext] lemma ext :  ∀ {ζ1 ζ2 : A2_disc R}, (ζ1.ζ  = ζ2.ζ)  → ζ1 = ζ2 := λ ζ1 ζ2,
        begin
            intro h,
            cases ζ1,
            cases ζ2,
            congr ; try { assumption },
            apply inverse_unique,
            exact ζ1_certif_disc,
            exact ζ2_certif_disc,
            exact  disc_ h,
        end
open is_ring_hom
def map_A2_disc {A B :Type }[comm_ring A][comm_ring B](f : A →  B)[is_ring_hom  f] : A2_disc A → A2_disc B := λ η,  begin
    have  h : ((f η.ζ.a) * (f η.ζ.a)  - (  ↑4 * (f η.ζ.b ))) * (f η.inv_disc) = 1,
            have j :    f( ↑4* η.ζ.b) = ↑4 * (f η.ζ.b ),
                exact int_commute_with_morph f (4) (η.ζ.b),
            rw [← j,← map_mul f,← map_sub f,← map_mul f,η.certif_disc],
            exact map_one f,
    exact { ζ := {a := f η.ζ.a, b := f η.ζ.b},
          inv_disc :=  f η.inv_disc,
          certif_disc :=  h,},
    end
lemma map_comp_a {A B :Type }[comm_ring A][comm_ring B](f : A →  B)[is_ring_hom  f] (ζ : A2_disc (A) ) : (map_A2_disc f ζ).ζ.a = f ζ.ζ.a := rfl
lemma map_comp_b {A B :Type }[comm_ring A][comm_ring B](f : A →  B)[is_ring_hom  f] (ζ : A2_disc (A) ) : (map_A2_disc f ζ).ζ.b = f ζ.ζ.b := rfl
lemma map_comp_inv_disc {A B :Type }[comm_ring A][comm_ring B](f : A →  B)[is_ring_hom  f] (ζ : A2_disc (A) ) : (map_A2_disc f ζ).inv_disc = f ζ.inv_disc := rfl
def 𝔸2_disc: CommRing ⥤ Type  :=
{ obj := λ R, A2_disc R,
  map := λ R R' f, map_A2_disc f,
}

-- def A :=   (functor.elements) (𝔸2_disc)
end
end A2_disc


import Lib.Data.Array
import Lib.Data.Nat
import Lib.Data.DecSubtype
import Lib.Data.OrdMap
import Lib.Logic.Classical

namespace Nat

theorem lt_mul_iff_div_lt {x y k : Nat} (h : 1 ≤ k) :
  x < y*k ↔ x / k < y := by
rw [← Classical.not_iff_not, ← le_iff_not_lt, mul_le_iff_le_div, le_iff_not_lt]
 <;> auto

end Nat

inductive InfArrayBuf (α : Type u) : Nat → Type u where
  | default : α → n > 0 → InfArrayBuf α n
  | node : Buffer n α → InfArrayBuf α (n*2) → InfArrayBuf α n

namespace InfArrayBuf

theorem is_pos (ar : InfArrayBuf α n) : n > 0 := by
induction ar with
| default x h => exact h
| node buf ar ih =>
  simp [Nat.lt_mul_iff_div_lt] at ih
  auto

def mk (x : α) (h : n > 0) : InfArrayBuf α n :=
default x h

def get : InfArrayBuf α n → Nat → α
| default x _, _ => x
| ar@(node buf ar'), i =>
  if h : i < n then
    buf.get ⟨i, h⟩
  else
    get ar' (i - n)
def set : InfArrayBuf α n → Nat → α → InfArrayBuf α n
| default x h, i, y =>
  let buf := Buffer.mkFilled x
  have h'' : n*2 > 0 := by
    simp [Nat.lt_mul_iff_div_lt]; auto
  if h' : i < n then
    node (buf.set ⟨i, h'⟩ y) (default x h'')
  else
    have h₂ : 0 < i := Nat.lt_of_lt_of_le h (Nat.le_of_not_gt h')
    have h₃ : i - n < i := Nat.sub_lt h₂ h
    node buf (set (default x h'') (i - n) y)
| ar@(node buf ar'), i, x =>
  if h' : i < n then
    node (buf.set ⟨i, h'⟩ x) ar'
  else
    have h'' : n*2 > 0 := ar'.is_pos
    have h   : n > 0 := ar.is_pos
    have h₂ : 0 < i := Nat.lt_of_lt_of_le h (Nat.le_of_not_gt h')
    have h₃ : i - n < i := Nat.sub_lt h₂ h
    node buf (set ar' (i - n) x)
termination_by _ i _ => i

def size : InfArrayBuf α n → Nat
| default _ _ => 0
| node _ ar => n + ar.size

def toList : InfArrayBuf α n → Nat → List α
| default x h, n => List.replicate n x
| node buf ar, m =>
  if m ≤ n then buf.cells.toList.take m
  else buf.cells.foldr (. :: .) (toList ar (m - n))

def dropHead : InfArrayBuf α n → InfArrayBuf α (n*2)
| default x h => default x <| by simp [Nat.lt_mul_iff_div_lt]; auto
| node buf ar => ar

end InfArrayBuf

structure InfArray (α : Type u) where
mkImpl ::
  bufSize : Nat
  buffers : InfArrayBuf α bufSize

namespace InfArray

def mkFilled (x : α) : InfArray α where
  bufSize := 10
  buffers := InfArrayBuf.node (Buffer.mkFilled x)
    (InfArrayBuf.default x <| by auto)

def size (ar : InfArray α) : Nat :=
ar.buffers.size

def get (ar : InfArray α) (i : Nat) : α :=
ar.buffers.get i

def set (ar : InfArray α) (i : Nat) (x : α) : InfArray α where
  buffers := ar.buffers.set i x

def toList (ar : InfArray α) (n : Nat) : List α :=
ar.buffers.toList n

def dropHead (ar : InfArray α) : InfArray α where
  buffers := ar.buffers.dropHead

end InfArray

def Heap := OrdMap

namespace Heap
open Std.AssocList
variable [LT α]

def takeMin (h : Heap α β) : Option (α × β × Heap α β) :=
match h' : h.vals with
| nil => none
| cons k v xs =>
  let xs' :=
    { vals := xs
      sorted := by
        have h'' := h.sorted
        simp [h', keys] at h''
        cases h''; assumption }
  -- let z := h.insert
  some (k, v, xs')

def nonEmpty (h : Heap α β) : Bool :=
match h.vals with
| nil => false
| cons k v xs => true

def empty : Heap α β where
  vals := nil
  sorted := by constructor

end Heap

def NEHeap (α) [LT α] (β) :=
DecSubtype (Heap.nonEmpty (α := α) (β := β))

namespace NEHeap
open Std.AssocList
variable [LT α]

def takeMin (h : NEHeap α β) : α × β × Heap α β :=
match h' : h with
| ⟨ ⟨cons k v xs, hxs ⟩, rfl ⟩ =>
  let xs' :=
    { vals := xs
      sorted := by
        have h'' := h.val.sorted
        simp [h', keys] at h''
        cases h''; assumption }
  (k, v, xs')

def head (h : NEHeap α β) : α :=
match h' : h with
| ⟨ ⟨cons k v xs, hxs ⟩, rfl ⟩ => k

end NEHeap

namespace OrdMap

variable [LE k] [DecidableTotalOrder k]
variable (f : k → α → α → α)

def insertWith (x : k) (v : α) :
  OrdMap k α → OrdMap k α :=
unionWith f (singleton x v)

end OrdMap

namespace Heap
open Std.AssocList
variable [LE α] [DecidableTotalOrder α]
variable (f : α → β → β → β)

def insertWith' (h : Heap α β) (k : α) (v : β) : NEHeap α β where
  val := h.insertWith f k v
  property := by
    cases h' : h.vals <;>
    simp [OrdMap.insertWith, OrdMap.unionWith, OrdMap.unionWith, OrdMap.mergeWith] <;>
    simp [OrdMap.singleton, h', zipWith, mapFilter, nonEmpty]
    next k v k' v' tail =>
      cases compare k k' <;> simp

end Heap

structure SieveEntry where
mkImpl ::
  key : Nat
  prime : Nat
  coef : Nat
  cached_key : key = prime * coef
  le_coef : prime ≤ coef

instance : ToString SieveEntry where
  toString x := toString (x.prime, x.coef)

namespace SieveEntry

def mk (n : Nat) : SieveEntry where
  key := n * n
  prime := n
  coef := n
  le_coef := Nat.le_refl _
  cached_key := rfl

def step' (s : SieveEntry) : SieveEntry where
  key := s.key + s.prime + s.prime
  prime := s.prime
  coef := s.coef + 2
  le_coef := by trans _; apply s.le_coef; auto
  cached_key := by simp [Nat.mul_succ, s.cached_key]

def step (s : SieveEntry) : Nat × SieveEntry :=
let s' := s.step'
(s'.key, s')

end SieveEntry

def List.nonEmpty : List α → Bool
| [] => false
| _ :: _ => true

def NEList (α) := DecSubtype (List.nonEmpty (α := α))

namespace NEList

def append : NEList α → NEList α → NEList α
| ⟨x :: xs, rfl⟩, ⟨ys, _⟩ => ⟨x :: (xs ++ ys), rfl⟩

instance : Append (NEList α) := ⟨ append ⟩

instance [Repr α] : Repr (NEList α) where
  reprPrec x n := reprPrec x.1 n

instance [ToString α] : ToString (NEList α) where
  toString x := toString x.1

end NEList

structure SieveState where
  cursor : NEHeap Nat (NEList SieveEntry)
  -- offset : Nat
  -- flags : InfArray Bool
  next : Nat
  primes : Array Nat

namespace SieveState

def pushPrime (n : Nat) (h : Heap Nat (NEList SieveEntry)) :
  NEHeap Nat (NEList SieveEntry) :=
let e := SieveEntry.mk n
h.insertWith' (λ _ => (. ++ .)) e.key ⟨ [e], rfl ⟩

-- def toList (s : SieveState) (n : Nat) : List (Nat × Bool) :=
-- s.flags.toList n |>.enumFrom s.offset |>.map <| Prod.map (. *2 +1) id

def init : SieveState where
  cursor := pushPrime 3 Heap.empty
  -- offset := 0
  -- flags := InfArray.mkFilled true
  next := 2 -- we consider only next * 2 + 1
  primes := #[2,3]

def next' (s : SieveState) : Nat := s.next*2 + 1

-- def index (s : SieveState) (c : Nat) : Nat :=
-- (((c - 1) / 2) - s.offset)

def insert (h : Heap Nat (NEList SieveEntry)) (e : SieveEntry) :
  NEHeap Nat (NEList SieveEntry) :=
h.insertWith' (λ _ => (. ++ .)) e.key ⟨[e],rfl⟩

def steps (h : Heap Nat (NEList SieveEntry)) :
  NEList SieveEntry →
  NEHeap Nat (NEList SieveEntry)
| ⟨e::es, rfl⟩ =>
  let (c', e') := e.step
  let h' := insert h e'
  es.foldl (λ h e => insert h.1 e.step') h'
   -- match es with
  -- | [] => h'
  -- | ys@(e' :: es) =>
    -- have : ys.length < xs.length := sorry
    -- steps h'.val ⟨e':: es, rfl ⟩
-- termination_by _ es => es.val.length

def step' (s : SieveState) : SieveState :=
let (c, es, cursor') := s.cursor.takeMin
-- let (c', e') := e.step
-- let i := s.index c
let cursor' := steps cursor' es
-- let flags' := s.flags.set i false
{ cursor := cursor'
  -- offset := s.offset
  -- flags := flags'
  next := s.next
  primes := s.primes
}

-- def condition (s : SieveState) : Bool × Nat × Nat :=
-- ( s.next' < s.cursor.head ∧ s.flags.get (s.index s.next),
--  s.index s.next,
--  s.next
-- )

-- def toList (s : SieveState) : List (Nat × Bool) :=

def step (s : SieveState) : SieveState :=
-- if s.offset + s.flags.bufSize ≤ s.next then
  -- { s with
    -- offset := s.offset + s.flags.bufSize
    -- flags := s.flags.dropHead }
if s.next' < s.cursor.head then
  let p := s.next'
  -- let i := s.next - s.offset
  -- let i := s'.next
  let cursor' := pushPrime p s.cursor.1
  let primes' := s.primes.push p
  { s with
           next := s.next + 1
           cursor := cursor'
           primes := primes' }
else if s.next' = s.cursor.head then
  { s.step' with next := s.next + 1 }
else
  s.step'

def test : IO Unit := do
  let mut s := init
  for i in [0:79] do
    s := step s
  print_vars![s.next', s.primes,
              s.cursor.val.vals.toList]

-- #eval test

end SieveState


/-
Copyright (c) 2018 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison, Bhavik Mehta
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.category_theory.limits.limits
import Mathlib.category_theory.discrete_category
import Mathlib.PostPort

universes v u u_1 u₂

namespace Mathlib

namespace category_theory.limits

-- We don't need an analogue of `pair` (for binary products), `parallel_pair` (for equalizers),

-- or `(co)span`, since we already have `discrete.functor`.

/-- A fan over `f : β → C` consists of a collection of maps from an object `P` to every `f b`. -/
/-- A cofan over `f : β → C` consists of a collection of maps from every `f b` to an object `P`. -/
def fan {β : Type v} {C : Type u} [category C] (f : β → C) := cone (discrete.functor f)

def cofan {β : Type v} {C : Type u} [category C] (f : β → C) := cocone (discrete.functor f)

/-- A fan over `f : β → C` consists of a collection of maps from an object `P` to every `f b`. -/
@[simp] theorem fan.mk_X {β : Type v} {C : Type u} [category C] {f : β → C} (P : C)
    (p : (b : β) → P ⟶ f b) : cone.X (fan.mk P p) = P :=
  Eq.refl (cone.X (fan.mk P p))

/-- A cofan over `f : β → C` consists of a collection of maps from every `f b` to an object `P`. -/
@[simp] theorem cofan.mk_X {β : Type v} {C : Type u} [category C] {f : β → C} (P : C)
    (p : (b : β) → f b ⟶ P) : cocone.X (cofan.mk P p) = P :=
  Eq.refl (cocone.X (cofan.mk P p))

/-- An abbreviation for `has_limit (discrete.functor f)`. -/
def has_product {β : Type v} {C : Type u} [category C] (f : β → C) := has_limit (discrete.functor f)

/-- An abbreviation for `has_colimit (discrete.functor f)`. -/
def has_coproduct {β : Type v} {C : Type u} [category C] (f : β → C) :=
  has_colimit (discrete.functor f)

/-- An abbreviation for `has_limits_of_shape (discrete f)`. -/
/-- An abbreviation for `has_colimits_of_shape (discrete f)`. -/
def has_products_of_shape (β : Type v) (C : Type u_1) [category C] :=
  has_limits_of_shape (discrete β)

def has_coproducts_of_shape (β : Type v) (C : Type u_1) [category C] :=
  has_colimits_of_shape (discrete β)

/-- `pi_obj f` computes the product of a family of elements `f`. (It is defined as an abbreviation
   for `limit (discrete.functor f)`, so for most facts about `pi_obj f`, you will just use general facts
   about limits.) -/
/-- `sigma_obj f` computes the coproduct of a family of elements `f`. (It is defined as an abbreviation
def pi_obj {β : Type v} {C : Type u} [category C] (f : β → C) [has_product f] : C :=
  limit (discrete.functor f)

   for `colimit (discrete.functor f)`, so for most facts about `sigma_obj f`, you will just use general facts
   about colimits.) -/
def sigma_obj {β : Type v} {C : Type u} [category C] (f : β → C) [has_coproduct f] : C :=
  colimit (discrete.functor f)

prefix:20 "∏ " => Mathlib.category_theory.limits.pi_obj

prefix:20 "∐ " => Mathlib.category_theory.limits.sigma_obj

/-- The `b`-th projection from the pi object over `f` has the form `∏ f ⟶ f b`. -/
def pi.π {β : Type v} {C : Type u} [category C] (f : β → C) [has_product f] (b : β) : ∏ f ⟶ f b :=
  limit.π (discrete.functor f) b

/-- The `b`-th inclusion into the sigma object over `f` has the form `f b ⟶ ∐ f`. -/
def sigma.ι {β : Type v} {C : Type u} [category C] (f : β → C) [has_coproduct f] (b : β) :
    f b ⟶ ∐ f :=
  colimit.ι (discrete.functor f) b

/-- The fan constructed of the projections from the product is limiting. -/
def product_is_product {β : Type v} {C : Type u} [category C] (f : β → C) [has_product f] :
    is_limit (fan.mk (∏ f) (pi.π f)) :=
  is_limit.of_iso_limit (limit.is_limit (discrete.functor f))
    (cones.ext (iso.refl (cone.X (limit.cone (discrete.functor fun (b : β) => f b)))) sorry)

/-- A collection of morphisms `P ⟶ f b` induces a morphism `P ⟶ ∏ f`. -/
def pi.lift {β : Type v} {C : Type u} [category C] {f : β → C} [has_product f] {P : C}
    (p : (b : β) → P ⟶ f b) : P ⟶ ∏ f :=
  limit.lift (discrete.functor fun (b : β) => f b) (fan.mk P p)

/-- A collection of morphisms `f b ⟶ P` induces a morphism `∐ f ⟶ P`. -/
def sigma.desc {β : Type v} {C : Type u} [category C] {f : β → C} [has_coproduct f] {P : C}
    (p : (b : β) → f b ⟶ P) : ∐ f ⟶ P :=
  colimit.desc (discrete.functor fun (b : β) => f b) (cofan.mk P p)

/--
Construct a morphism between categorical products (indexed by the same type)
from a family of morphisms between the factors.
-/
def pi.map {β : Type v} {C : Type u} [category C] {f : β → C} {g : β → C} [has_product f]
    [has_product g] (p : (b : β) → f b ⟶ g b) : ∏ f ⟶ ∏ g :=
  lim_map (discrete.nat_trans p)

/--
Construct an isomorphism between categorical products (indexed by the same type)
from a family of isomorphisms between the factors.
-/
def pi.map_iso {β : Type v} {C : Type u} [category C] {f : β → C} {g : β → C}
    [has_products_of_shape β C] (p : (b : β) → f b ≅ g b) : ∏ f ≅ ∏ g :=
  functor.map_iso lim (discrete.nat_iso p)

/--
Construct a morphism between categorical coproducts (indexed by the same type)
from a family of morphisms between the factors.
-/
def sigma.map {β : Type v} {C : Type u} [category C] {f : β → C} {g : β → C} [has_coproduct f]
    [has_coproduct g] (p : (b : β) → f b ⟶ g b) : ∐ f ⟶ ∐ g :=
  colim_map (discrete.nat_trans p)

/--
Construct an isomorphism between categorical coproducts (indexed by the same type)
from a family of isomorphisms between the factors.
-/
def sigma.map_iso {β : Type v} {C : Type u} [category C] {f : β → C} {g : β → C}
    [has_coproducts_of_shape β C] (p : (b : β) → f b ≅ g b) : ∐ f ≅ ∐ g :=
  functor.map_iso colim (discrete.nat_iso p)

-- TODO: show this is an iso iff G preserves the product of f.

/-- The comparison morphism for the product of `f`. -/
def pi_comparison {β : Type v} {C : Type u} [category C] {D : Type u₂} [category D] (G : C ⥤ D)
    (f : β → C) [has_product f] [has_product fun (b : β) => functor.obj G (f b)] :
    functor.obj G (∏ f) ⟶ ∏ fun (b : β) => functor.obj G (f b) :=
  pi.lift fun (b : β) => functor.map G (pi.π f b)

@[simp] theorem pi_comparison_comp_π_assoc {β : Type v} {C : Type u} [category C] {D : Type u₂}
    [category D] (G : C ⥤ D) (f : β → C) [has_product f]
    [has_product fun (b : β) => functor.obj G (f b)] (b : β) {X' : D}
    (f' : functor.obj G (f b) ⟶ X') :
    pi_comparison G f ≫ pi.π (fun (b : β) => functor.obj G (f b)) b ≫ f' =
        functor.map G (pi.π f b) ≫ f' :=
  sorry

@[simp] theorem map_lift_pi_comparison_assoc {β : Type v} {C : Type u} [category C] {D : Type u₂}
    [category D] (G : C ⥤ D) (f : β → C) [has_product f]
    [has_product fun (b : β) => functor.obj G (f b)] (P : C) (g : (j : β) → P ⟶ f j) {X' : D}
    (f' : (∏ fun (b : β) => functor.obj G (f b)) ⟶ X') :
    functor.map G (pi.lift g) ≫ pi_comparison G f ≫ f' =
        (pi.lift fun (j : β) => functor.map G (g j)) ≫ f' :=
  sorry

-- TODO: show this is an iso iff G preserves the coproduct of f.

/-- The comparison morphism for the coproduct of `f`. -/
def sigma_comparison {β : Type v} {C : Type u} [category C] {D : Type u₂} [category D] (G : C ⥤ D)
    (f : β → C) [has_coproduct f] [has_coproduct fun (b : β) => functor.obj G (f b)] :
    (∐ fun (b : β) => functor.obj G (f b)) ⟶ functor.obj G (∐ f) :=
  sigma.desc fun (b : β) => functor.map G (sigma.ι f b)

@[simp] theorem ι_comp_sigma_comparison_assoc {β : Type v} {C : Type u} [category C] {D : Type u₂}
    [category D] (G : C ⥤ D) (f : β → C) [has_coproduct f]
    [has_coproduct fun (b : β) => functor.obj G (f b)] (b : β) {X' : D}
    (f' : functor.obj G (∐ f) ⟶ X') :
    sigma.ι (fun (b : β) => functor.obj G (f b)) b ≫ sigma_comparison G f ≫ f' =
        functor.map G (sigma.ι f b) ≫ f' :=
  sorry

@[simp] theorem sigma_comparison_map_desc {β : Type v} {C : Type u} [category C] {D : Type u₂}
    [category D] (G : C ⥤ D) (f : β → C) [has_coproduct f]
    [has_coproduct fun (b : β) => functor.obj G (f b)] (P : C) (g : (j : β) → f j ⟶ P) :
    sigma_comparison G f ≫ functor.map G (sigma.desc g) =
        sigma.desc fun (j : β) => functor.map G (g j) :=
  sorry

/-- An abbreviation for `Π J, has_limits_of_shape (discrete J) C` -/
/-- An abbreviation for `Π J, has_colimits_of_shape (discrete J) C` -/
def has_products (C : Type u) [category C] := ∀ (J : Type v), has_limits_of_shape (discrete J) C

def has_coproducts (C : Type u) [category C] := ∀ (J : Type v), has_colimits_of_shape (discrete J) C

end Mathlib


/-
Copyright (c) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison, Shing Tak Lam, Mario Carneiro
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.int.modeq
import Mathlib.tactic.interval_cases
import Mathlib.tactic.linarith.default
import Mathlib.PostPort

universes u_1

namespace Mathlib

/-!
# Digits of a natural number

This provides a basic API for extracting the digits of a natural number in a given base,
and reconstructing numbers from their digits.

We also prove some divisibility tests based on digits, in particular completing
Theorem #85 from https://www.cs.ru.nl/~freek/100/.

A basic `norm_digits` tactic is also provided for proving goals of the form
`nat.digits a b = l` where `a` and `b` are numerals.
-/

namespace nat

/-- (Impl.) An auxiliary definition for `digits`, to help get the desired definitional unfolding. -/
def digits_aux_0 : ℕ → List ℕ := sorry

/-- (Impl.) An auxiliary definition for `digits`, to help get the desired definitional unfolding. -/
def digits_aux_1 (n : ℕ) : List ℕ := list.repeat 1 n

/-- (Impl.) An auxiliary definition for `digits`, to help get the desired definitional unfolding. -/
def digits_aux (b : ℕ) (h : bit0 1 ≤ b) : ℕ → List ℕ := sorry

@[simp] theorem digits_aux_zero (b : ℕ) (h : bit0 1 ≤ b) : digits_aux b h 0 = [] := rfl

theorem digits_aux_def (b : ℕ) (h : bit0 1 ≤ b) (n : ℕ) (w : 0 < n) :
    digits_aux b h n = n % b :: digits_aux b h (n / b) :=
  sorry

/--
`digits b n` gives the digits, in little-endian order,
of a natural number `n` in a specified base `b`.

In any base, we have `of_digits b L = L.foldr (λ x y, x + b * y) 0`.
* For any `2 ≤ b`, we have `l < b` for any `l ∈ digits b n`,
  and the last digit is not zero.
  This uniquely specifies the behaviour of `digits b`.
* For `b = 1`, we define `digits 1 n = list.repeat 1 n`.
* For `b = 0`, we define `digits 0 n = [n]`, except `digits 0 0 = []`.

Note this differs from the existing `nat.to_digits` in core, which is used for printing numerals.
In particular, `nat.to_digits b 0 = [0]`, while `digits b 0 = []`.
-/
def digits : ℕ → ℕ → List ℕ := sorry

@[simp] theorem digits_zero (b : ℕ) : digits b 0 = [] :=
  nat.cases_on b (Eq.refl (digits 0 0))
    fun (b : ℕ) =>
      nat.cases_on b (Eq.refl (digits 1 0))
        fun (b : ℕ) => Eq.refl (digits (Nat.succ (Nat.succ b)) 0)

@[simp] theorem digits_zero_zero : digits 0 0 = [] := rfl

@[simp] theorem digits_zero_succ (n : ℕ) : digits 0 (Nat.succ n) = [n + 1] := rfl

theorem digits_zero_succ' {n : ℕ} (w : 0 < n) : digits 0 n = [n] :=
  nat.cases_on n (fun (w : 0 < 0) => idRhs (digits 0 0 = [0]) (absurd w (of_as_true trivial)))
    (fun (n : ℕ) (w : 0 < Nat.succ n) => idRhs (digits 0 (n + 1) = digits 0 (n + 1)) rfl) w

@[simp] theorem digits_one (n : ℕ) : digits 1 n = list.repeat 1 n := rfl

@[simp] theorem digits_one_succ (n : ℕ) : digits 1 (n + 1) = 1 :: digits 1 n := rfl

@[simp] theorem digits_add_two_add_one (b : ℕ) (n : ℕ) :
    digits (b + bit0 1) (n + 1) =
        (n + 1) % (b + bit0 1) :: digits (b + bit0 1) ((n + 1) / (b + bit0 1)) :=
  rfl

theorem digits_def' {b : ℕ} (h : bit0 1 ≤ b) {n : ℕ} (w : 0 < n) :
    digits b n = n % b :: digits b (n / b) :=
  sorry

@[simp] theorem digits_of_lt (b : ℕ) (x : ℕ) (w₁ : 0 < x) (w₂ : x < b) : digits b x = [x] := sorry

theorem digits_add (b : ℕ) (h : bit0 1 ≤ b) (x : ℕ) (y : ℕ) (w : x < b) (w' : 0 < x ∨ 0 < y) :
    digits b (x + b * y) = x :: digits b y :=
  sorry

/--
`of_digits b L` takes a list `L` of natural numbers, and interprets them
as a number in semiring, as the little-endian digits in base `b`.
-/
-- If we had a function converting a list into a polynomial,

-- and appropriate lemmas about that function,

-- we could rewrite this in terms of that.

def of_digits {α : Type u_1} [semiring α] (b : α) : List ℕ → α := sorry

theorem of_digits_eq_foldr {α : Type u_1} [semiring α] (b : α) (L : List ℕ) :
    of_digits b L = list.foldr (fun (x : ℕ) (y : α) => ↑x + b * y) 0 L :=
  sorry

@[simp] theorem of_digits_singleton {b : ℕ} {n : ℕ} : of_digits b [n] = n := sorry

@[simp] theorem of_digits_one_cons {α : Type u_1} [semiring α] (h : ℕ) (L : List ℕ) :
    of_digits 1 (h :: L) = ↑h + of_digits 1 L :=
  sorry

theorem of_digits_append {b : ℕ} {l1 : List ℕ} {l2 : List ℕ} :
    of_digits b (l1 ++ l2) = of_digits b l1 + b ^ list.length l1 * of_digits b l2 :=
  sorry

theorem coe_of_digits (α : Type u_1) [semiring α] (b : ℕ) (L : List ℕ) :
    ↑(of_digits b L) = of_digits (↑b) L :=
  sorry

theorem coe_int_of_digits (b : ℕ) (L : List ℕ) : ↑(of_digits b L) = of_digits (↑b) L := sorry

theorem digits_zero_of_eq_zero {b : ℕ} (h : 1 ≤ b) {L : List ℕ} (w : of_digits b L = 0) (l : ℕ)
    (H : l ∈ L) : l = 0 :=
  sorry

theorem digits_of_digits (b : ℕ) (h : bit0 1 ≤ b) (L : List ℕ) (w₁ : ∀ (l : ℕ), l ∈ L → l < b)
    (w₂ : ∀ (h : L ≠ []), list.last L h ≠ 0) : digits b (of_digits b L) = L :=
  sorry

theorem of_digits_digits (b : ℕ) (n : ℕ) : of_digits b (digits b n) = n := sorry

theorem of_digits_one (L : List ℕ) : of_digits 1 L = list.sum L := sorry

/-!
### Properties

This section contains various lemmas of properties relating to `digits` and `of_digits`.
-/

theorem digits_eq_nil_iff_eq_zero {b : ℕ} {n : ℕ} : digits b n = [] ↔ n = 0 := sorry

theorem digits_ne_nil_iff_ne_zero {b : ℕ} {n : ℕ} : digits b n ≠ [] ↔ n ≠ 0 :=
  not_congr digits_eq_nil_iff_eq_zero

theorem digits_last {b : ℕ} {m : ℕ} (h : bit0 1 ≤ b) (hm : 0 < m) (p : digits b m ≠ [])
    (q : digits b (m / b) ≠ []) : list.last (digits b m) p = list.last (digits b (m / b)) q :=
  sorry

theorem last_digit_ne_zero (b : ℕ) {m : ℕ} (hm : m ≠ 0) :
    list.last (digits b m) (iff.mpr digits_ne_nil_iff_ne_zero hm) ≠ 0 :=
  sorry

/-- The digits in the base b+2 expansion of n are all less than b+2 -/
theorem digits_lt_base' {b : ℕ} {m : ℕ} {d : ℕ} : d ∈ digits (b + bit0 1) m → d < b + bit0 1 :=
  sorry

/-- The digits in the base b expansion of n are all less than b, if b ≥ 2 -/
theorem digits_lt_base {b : ℕ} {m : ℕ} {d : ℕ} (hb : bit0 1 ≤ b) (hd : d ∈ digits b m) : d < b :=
  sorry

/-- an n-digit number in base b + 2 is less than (b + 2)^n -/
theorem of_digits_lt_base_pow_length' {b : ℕ} {l : List ℕ}
    (hl : ∀ (x : ℕ), x ∈ l → x < b + bit0 1) :
    of_digits (b + bit0 1) l < (b + bit0 1) ^ list.length l :=
  sorry

/-- an n-digit number in base b is less than b^n if b ≥ 2 -/
theorem of_digits_lt_base_pow_length {b : ℕ} {l : List ℕ} (hb : bit0 1 ≤ b)
    (hl : ∀ (x : ℕ), x ∈ l → x < b) : of_digits b l < b ^ list.length l :=
  sorry

/-- Any number m is less than (b+2)^(number of digits in the base b + 2 representation of m) -/
theorem lt_base_pow_length_digits' {b : ℕ} {m : ℕ} :
    m < (b + bit0 1) ^ list.length (digits (b + bit0 1) m) :=
  sorry

/-- Any number m is less than b^(number of digits in the base b representation of m) -/
theorem lt_base_pow_length_digits {b : ℕ} {m : ℕ} (hb : bit0 1 ≤ b) :
    m < b ^ list.length (digits b m) :=
  sorry

theorem of_digits_digits_append_digits {b : ℕ} {m : ℕ} {n : ℕ} :
    of_digits b (digits b n ++ digits b m) = n + b ^ list.length (digits b n) * m :=
  sorry

theorem digits_len_le_digits_len_succ (b : ℕ) (n : ℕ) :
    list.length (digits b n) ≤ list.length (digits b (n + 1)) :=
  sorry

theorem le_digits_len_le (b : ℕ) (n : ℕ) (m : ℕ) (h : n ≤ m) :
    list.length (digits b n) ≤ list.length (digits b m) :=
  monotone_of_monotone_nat (digits_len_le_digits_len_succ b) h

theorem pow_length_le_mul_of_digits {b : ℕ} {l : List ℕ} (hl : l ≠ []) (hl2 : list.last l hl ≠ 0) :
    (b + bit0 1) ^ list.length l ≤ (b + bit0 1) * of_digits (b + bit0 1) l :=
  sorry

/--
Any non-zero natural number `m` is greater than
(b+2)^((number of digits in the base (b+2) representation of m) - 1)
-/
theorem base_pow_length_digits_le' (b : ℕ) (m : ℕ) (hm : m ≠ 0) :
    (b + bit0 1) ^ list.length (digits (b + bit0 1) m) ≤ (b + bit0 1) * m :=
  sorry

/--
Any non-zero natural number `m` is greater than
b^((number of digits in the base b representation of m) - 1)
-/
theorem base_pow_length_digits_le (b : ℕ) (m : ℕ) (hb : bit0 1 ≤ b) :
    m ≠ 0 → b ^ list.length (digits b m) ≤ b * m :=
  sorry

/-! ### Modular Arithmetic -/

-- This is really a theorem about polynomials.

theorem dvd_of_digits_sub_of_digits {α : Type u_1} [comm_ring α] {a : α} {b : α} {k : α}
    (h : k ∣ a - b) (L : List ℕ) : k ∣ of_digits a L - of_digits b L :=
  sorry

theorem of_digits_modeq' (b : ℕ) (b' : ℕ) (k : ℕ) (h : modeq k b b') (L : List ℕ) :
    modeq k (of_digits b L) (of_digits b' L) :=
  sorry

theorem of_digits_modeq (b : ℕ) (k : ℕ) (L : List ℕ) :
    modeq k (of_digits b L) (of_digits (b % k) L) :=
  of_digits_modeq' b (b % k) k (modeq.symm (modeq.mod_modeq b k)) L

theorem of_digits_mod (b : ℕ) (k : ℕ) (L : List ℕ) : of_digits b L % k = of_digits (b % k) L % k :=
  of_digits_modeq b k L

theorem of_digits_zmodeq' (b : ℤ) (b' : ℤ) (k : ℕ) (h : int.modeq (↑k) b b') (L : List ℕ) :
    int.modeq (↑k) (of_digits b L) (of_digits b' L) :=
  sorry

theorem of_digits_zmodeq (b : ℤ) (k : ℕ) (L : List ℕ) :
    int.modeq (↑k) (of_digits b L) (of_digits (b % ↑k) L) :=
  of_digits_zmodeq' b (b % ↑k) k (int.modeq.symm (int.modeq.mod_modeq b ↑k)) L

theorem of_digits_zmod (b : ℤ) (k : ℕ) (L : List ℕ) :
    of_digits b L % ↑k = of_digits (b % ↑k) L % ↑k :=
  of_digits_zmodeq b k L

theorem modeq_digits_sum (b : ℕ) (b' : ℕ) (h : b' % b = 1) (n : ℕ) :
    modeq b n (list.sum (digits b' n)) :=
  sorry

theorem modeq_three_digits_sum (n : ℕ) :
    modeq (bit1 1) n (list.sum (digits (bit0 (bit1 (bit0 1))) n)) :=
  sorry

theorem modeq_nine_digits_sum (n : ℕ) :
    modeq (bit1 (bit0 (bit0 1))) n (list.sum (digits (bit0 (bit1 (bit0 1))) n)) :=
  sorry

theorem zmodeq_of_digits_digits (b : ℕ) (b' : ℕ) (c : ℤ) (h : int.modeq (↑b) (↑b') c) (n : ℕ) :
    int.modeq (↑b) (↑n) (of_digits c (digits b' n)) :=
  sorry

theorem of_digits_neg_one (L : List ℕ) :
    of_digits (-1) L = list.alternating_sum (list.map (fun (n : ℕ) => ↑n) L) :=
  sorry

theorem modeq_eleven_digits_sum (n : ℕ) :
    int.modeq (bit1 (bit1 (bit0 1))) (↑n)
        (list.alternating_sum (list.map (fun (n : ℕ) => ↑n) (digits (bit0 (bit1 (bit0 1))) n))) :=
  sorry

/-! ## Divisibility  -/

theorem dvd_iff_dvd_digits_sum (b : ℕ) (b' : ℕ) (h : b' % b = 1) (n : ℕ) :
    b ∣ n ↔ b ∣ list.sum (digits b' n) :=
  sorry

theorem three_dvd_iff (n : ℕ) : bit1 1 ∣ n ↔ bit1 1 ∣ list.sum (digits (bit0 (bit1 (bit0 1))) n) :=
  sorry

theorem nine_dvd_iff (n : ℕ) :
    bit1 (bit0 (bit0 1)) ∣ n ↔ bit1 (bit0 (bit0 1)) ∣ list.sum (digits (bit0 (bit1 (bit0 1))) n) :=
  sorry

theorem dvd_iff_dvd_of_digits (b : ℕ) (b' : ℕ) (c : ℤ) (h : ↑b ∣ ↑b' - c) (n : ℕ) :
    b ∣ n ↔ ↑b ∣ of_digits c (digits b' n) :=
  sorry

theorem eleven_dvd_iff (n : ℕ) :
    bit1 (bit1 (bit0 1)) ∣ n ↔
        bit1 (bit1 (bit0 1)) ∣
          list.alternating_sum (list.map (fun (n : ℕ) => ↑n) (digits (bit0 (bit1 (bit0 1))) n)) :=
  sorry

/-! ### `norm_digits` tactic -/

namespace norm_digits

theorem digits_succ (b : ℕ) (n : ℕ) (m : ℕ) (r : ℕ) (l : List ℕ) (e : r + b * m = n) (hr : r < b)
    (h : digits b m = l ∧ bit0 1 ≤ b ∧ 0 < m) : digits b n = r :: l ∧ bit0 1 ≤ b ∧ 0 < n :=
  sorry

theorem digits_one (b : ℕ) (n : ℕ) (n0 : 0 < n) (nb : n < b) :
    digits b n = [n] ∧ bit0 1 ≤ b ∧ 0 < n :=
  sorry

end Mathlib


/-
Copyright (c) 2022 Yury Kudryashov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yury Kudryashov

! This file was ported from Lean 3 source module topology.metric_space.isometric_smul
! leanprover-community/mathlib commit 832a8ba8f10f11fea99367c469ff802e69a5b8ec
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Topology.MetricSpace.Isometry

/-!
# Group actions by isometries

In this file we define two typeclasses:

- `IsometricSMul M X` says that `M` multiplicatively acts on a (pseudo extended) metric space
  `X` by isometries;
- `IsometricVAdd` is an additive version of `IsometricSMul`.

We also prove basic facts about isometric actions and define bundled isometries
`IsometryEquiv.constSMul`, `IsometryEquiv.mulLeft`, `IsometryEquiv.mulRight`,
`IsometryEquiv.divLeft`, `IsometryEquiv.divRight`, and `IsometryEquiv.inv`, as well as their
additive versions.

If `G` is a group, then `IsometricSMul G G` means that `G` has a left-invariant metric while
`IsometricSMul Gᵐᵒᵖ G` means that `G` has a right-invariant metric. For a commutative group,
these two notions are equivalent. A group with a right-invariant metric can be also represented as a
`NormedGroup`.
-/

open Set

open ENNReal Pointwise

universe u v w

variable (M : Type u) (G : Type v) (X : Type w)

/-- An additive action is isometric if each map `x ↦ c +ᵥ x` is an isometry. -/
class IsometricVAdd [PseudoEMetricSpace X] [VAdd M X] : Prop where
  protected isometry_vadd : ∀ c : M, Isometry ((c +ᵥ ·) : X → X)
#align has_isometric_vadd IsometricVAdd

/-- A multiplicative action is isometric if each map `x ↦ c • x` is an isometry. -/
@[to_additive]
class IsometricSMul [PseudoEMetricSpace X] [SMul M X] : Prop where
  protected isometry_smul : ∀ c : M, Isometry ((c • ·) : X → X)
#align has_isometric_smul IsometricSMul

-- Porting note: Lean 4 doesn' support `[]` in classes, so make a lemma instead of `export`ing
@[to_additive]
theorem isometry_smul {M : Type u} (X : Type w) [PseudoEMetricSpace X] [SMul M X]
    [IsometricSMul M X] (c : M) : Isometry (c • · : X → X) :=
  IsometricSMul.isometry_smul c

@[to_additive]
instance (priority := 100) IsometricSMul.to_continuousConstSMul [PseudoEMetricSpace X] [SMul M X]
    [IsometricSMul M X] : ContinuousConstSMul M X :=
  ⟨fun c => (isometry_smul X c).continuous⟩
#align has_isometric_smul.to_has_continuous_const_smul IsometricSMul.to_continuousConstSMul
#align has_isometric_vadd.to_has_continuous_const_vadd IsometricVAdd.to_continuousConstVAdd

@[to_additive]
instance (priority := 100) IsometricSMul.opposite_of_comm [PseudoEMetricSpace X] [SMul M X]
    [SMul Mᵐᵒᵖ X] [IsCentralScalar M X] [IsometricSMul M X] : IsometricSMul Mᵐᵒᵖ X :=
  ⟨fun c x y => by simpa only [← op_smul_eq_smul] using isometry_smul X c.unop x y⟩
#align has_isometric_smul.opposite_of_comm IsometricSMul.opposite_of_comm
#align has_isometric_vadd.opposite_of_comm IsometricVAdd.opposite_of_comm

variable {M G X}

section EMetric

variable [PseudoEMetricSpace X] [Group G] [MulAction G X] [IsometricSMul G X]

@[to_additive (attr := simp)]
theorem edist_smul_left [SMul M X] [IsometricSMul M X] (c : M) (x y : X) :
    edist (c • x) (c • y) = edist x y :=
  isometry_smul X c x y
#align edist_smul_left edist_smul_left
#align edist_vadd_left edist_vadd_left

@[to_additive]
theorem isometry_mul_left [Mul M] [PseudoEMetricSpace M] [IsometricSMul M M] (a : M) :
    Isometry ((· * ·) a) :=
  isometry_smul M a
#align isometry_mul_left isometry_mul_left
#align isometry_add_left isometry_add_left

@[to_additive (attr := simp)]
theorem edist_mul_left [Mul M] [PseudoEMetricSpace M] [IsometricSMul M M] (a b c : M) :
    edist (a * b) (a * c) = edist b c :=
  isometry_mul_left a b c
#align edist_mul_left edist_mul_left
#align edist_add_left edist_add_left

@[to_additive]
theorem isometry_mul_right [Mul M] [PseudoEMetricSpace M] [IsometricSMul Mᵐᵒᵖ M] (a : M) :
    Isometry fun x => x * a :=
  isometry_smul M (MulOpposite.op a)
#align isometry_mul_right isometry_mul_right
#align isometry_add_right isometry_add_right

@[to_additive (attr := simp)]
theorem edist_mul_right [Mul M] [PseudoEMetricSpace M] [IsometricSMul Mᵐᵒᵖ M] (a b c : M) :
    edist (a * c) (b * c) = edist a b :=
  isometry_mul_right c a b
#align edist_mul_right edist_mul_right
#align edist_add_right edist_add_right

@[to_additive (attr := simp)]
theorem edist_div_right [DivInvMonoid M] [PseudoEMetricSpace M] [IsometricSMul Mᵐᵒᵖ M]
    (a b c : M) : edist (a / c) (b / c) = edist a b := by
  simp only [div_eq_mul_inv, edist_mul_right]
#align edist_div_right edist_div_right
#align edist_sub_right edist_sub_right

@[to_additive (attr := simp)]
theorem edist_inv_inv [PseudoEMetricSpace G] [IsometricSMul G G] [IsometricSMul Gᵐᵒᵖ G]
    (a b : G) : edist a⁻¹ b⁻¹ = edist a b := by
  rw [← edist_mul_left a, ← edist_mul_right _ _ b, mul_right_inv, one_mul, inv_mul_cancel_right,
    edist_comm]
#align edist_inv_inv edist_inv_inv
#align edist_neg_neg edist_neg_neg

@[to_additive]
theorem isometry_inv [PseudoEMetricSpace G] [IsometricSMul G G] [IsometricSMul Gᵐᵒᵖ G] :
    Isometry (Inv.inv : G → G) :=
  edist_inv_inv
#align isometry_inv isometry_inv
#align isometry_neg isometry_neg

@[to_additive]
theorem edist_inv [PseudoEMetricSpace G] [IsometricSMul G G] [IsometricSMul Gᵐᵒᵖ G]
    (x y : G) : edist x⁻¹ y = edist x y⁻¹ := by rw [← edist_inv_inv, inv_inv]
#align edist_inv edist_inv
#align edist_neg edist_neg

@[to_additive (attr := simp)]
theorem edist_div_left [PseudoEMetricSpace G] [IsometricSMul G G] [IsometricSMul Gᵐᵒᵖ G]
    (a b c : G) : edist (a / b) (a / c) = edist b c := by
  rw [div_eq_mul_inv, div_eq_mul_inv, edist_mul_left, edist_inv_inv]
#align edist_div_left edist_div_left
#align edist_sub_left edist_sub_left

namespace IsometryEquiv

/-- If a group `G` acts on `X` by isometries, then `IsometryEquiv.constSMul` is the isometry of
`X` given by multiplication of a constant element of the group. -/
@[to_additive (attr := simps! toEquiv apply) "If an additive group `G` acts on `X` by isometries,
then `IsometryEquiv.constVAdd` is the isometry of `X` given by addition of a constant element of the
group."]
def constSMul (c : G) : X ≃ᵢ X where
  toEquiv := MulAction.toPerm c
  isometry_toFun := isometry_smul X c
#align isometry_equiv.const_smul IsometryEquiv.constSMul
#align isometry_equiv.const_vadd IsometryEquiv.constVAdd
#align isometry_equiv.const_smul_to_equiv IsometryEquiv.constSMul_toEquiv
#align isometry_equiv.const_smul_apply IsometryEquiv.constSMul_apply
#align isometry_equiv.const_vadd_to_equiv IsometryEquiv.constVAdd_toEquiv
#align isometry_equiv.const_vadd_apply IsometryEquiv.constVAdd_apply

@[to_additive (attr := simp)]
theorem constSMul_symm (c : G) : (constSMul c : X ≃ᵢ X).symm = constSMul c⁻¹ :=
  ext fun _ => rfl
#align isometry_equiv.const_smul_symm IsometryEquiv.constSMul_symm
#align isometry_equiv.const_vadd_symm IsometryEquiv.constVAdd_symm

variable [PseudoEMetricSpace G]

/-- Multiplication `y ↦ x * y` as an `IsometryEquiv`. -/
@[to_additive (attr := simps! apply toEquiv) "Addition `y ↦ x + y` as an `IsometryEquiv`."]
def mulLeft [IsometricSMul G G] (c : G) : G ≃ᵢ G where
  toEquiv := Equiv.mulLeft c
  isometry_toFun := edist_mul_left c
#align isometry_equiv.mul_left IsometryEquiv.mulLeft
#align isometry_equiv.add_left IsometryEquiv.addLeft
#align isometry_equiv.mul_left_apply IsometryEquiv.mulLeft_apply
#align isometry_equiv.mul_left_to_equiv IsometryEquiv.mulLeft_toEquiv
#align isometry_equiv.add_left_apply IsometryEquiv.addLeft_apply
#align isometry_equiv.add_left_to_equiv IsometryEquiv.addLeft_toEquiv

@[to_additive (attr := simp)]
theorem mulLeft_symm [IsometricSMul G G] (x : G) :
    (mulLeft x).symm = IsometryEquiv.mulLeft x⁻¹ :=
  constSMul_symm x
#align isometry_equiv.mul_left_symm IsometryEquiv.mulLeft_symm
#align isometry_equiv.add_left_symm IsometryEquiv.addLeft_symm

/-- Multiplication `y ↦ y * x` as an `IsometryEquiv`. -/
@[to_additive (attr := simps! apply toEquiv) "Addition `y ↦ y + x` as an `IsometryEquiv`."]
def mulRight [IsometricSMul Gᵐᵒᵖ G] (c : G) : G ≃ᵢ G where
  toEquiv := Equiv.mulRight c
  isometry_toFun a b := edist_mul_right a b c
#align isometry_equiv.mul_right IsometryEquiv.mulRight
#align isometry_equiv.add_right IsometryEquiv.addRight
#align isometry_equiv.mul_right_apply IsometryEquiv.mulRight_apply
#align isometry_equiv.mul_right_to_equiv IsometryEquiv.mulRight_toEquiv
#align isometry_equiv.add_right_apply IsometryEquiv.addRight_apply
#align isometry_equiv.add_right_to_equiv IsometryEquiv.addRight_toEquiv

@[to_additive (attr := simp)]

/-- Division `y ↦ y / x` as an `IsometryEquiv`. -/
@[to_additive (attr := simps! apply toEquiv) "Subtraction `y ↦ y - x` as an `IsometryEquiv`."]
def divRight [IsometricSMul Gᵐᵒᵖ G] (c : G) : G ≃ᵢ G where
  toEquiv := Equiv.divRight c
  isometry_toFun a b := edist_div_right a b c
#align isometry_equiv.div_right IsometryEquiv.divRight
#align isometry_equiv.sub_right IsometryEquiv.subRight
#align isometry_equiv.div_right_apply IsometryEquiv.divRight_apply
#align isometry_equiv.div_right_to_equiv IsometryEquiv.divRight_toEquiv
#align isometry_equiv.sub_right_apply IsometryEquiv.subRight_apply
#align isometry_equiv.sub_right_to_equiv IsometryEquiv.subRight_toEquiv

@[to_additive (attr := simp)]
theorem divRight_symm [IsometricSMul Gᵐᵒᵖ G] (c : G) : (divRight c).symm = mulRight c :=
  ext fun _ => rfl
#align isometry_equiv.div_right_symm IsometryEquiv.divRight_symm
#align isometry_equiv.sub_right_symm IsometryEquiv.subRight_symm

variable [IsometricSMul G G] [IsometricSMul Gᵐᵒᵖ G]

/-- Division `y ↦ x / y` as an `IsometryEquiv`. -/
@[to_additive (attr := simps! apply symm_apply toEquiv)
  "Subtraction `y ↦ x - y` as an `IsometryEquiv`."]
def divLeft (c : G) : G ≃ᵢ G where
  toEquiv := Equiv.divLeft c
  isometry_toFun := edist_div_left c
#align isometry_equiv.div_left IsometryEquiv.divLeft
#align isometry_equiv.sub_left IsometryEquiv.subLeft
#align isometry_equiv.div_left_apply IsometryEquiv.divLeft_apply
#align isometry_equiv.div_left_symm_apply IsometryEquiv.divLeft_symm_apply
#align isometry_equiv.div_left_to_equiv IsometryEquiv.divLeft_toEquiv
#align isometry_equiv.sub_left_apply IsometryEquiv.subLeft_apply
#align isometry_equiv.sub_left_symm_apply IsometryEquiv.subLeft_symm_apply
#align isometry_equiv.sub_left_to_equiv IsometryEquiv.subLeft_toEquiv

variable (G)

/-- Inversion `x ↦ x⁻¹` as an `IsometryEquiv`. -/
@[to_additive (attr := simps! apply toEquiv) "Negation `x ↦ -x` as an `IsometryEquiv`."]
def inv : G ≃ᵢ G where
  toEquiv := Equiv.inv G
  isometry_toFun := edist_inv_inv
#align isometry_equiv.inv IsometryEquiv.inv
#align isometry_equiv.neg IsometryEquiv.neg
#align isometry_equiv.inv_apply IsometryEquiv.inv_apply
#align isometry_equiv.inv_to_equiv IsometryEquiv.inv_toEquiv
#align isometry_equiv.neg_apply IsometryEquiv.neg_apply
#align isometry_equiv.neg_to_equiv IsometryEquiv.neg_toEquiv

@[to_additive (attr := simp)] theorem inv_symm : (inv G).symm = inv G := rfl
#align isometry_equiv.inv_symm IsometryEquiv.inv_symm
#align isometry_equiv.neg_symm IsometryEquiv.neg_symm

end IsometryEquiv

namespace EMetric

@[to_additive (attr := simp)]
theorem smul_ball (c : G) (x : X) (r : ℝ≥0∞) : c • ball x r = ball (c • x) r :=
  (IsometryEquiv.constSMul c).image_emetric_ball _ _
#align emetric.smul_ball EMetric.smul_ball
#align emetric.vadd_ball EMetric.vadd_ball

@[to_additive (attr := simp)]
theorem preimage_smul_ball (c : G) (x : X) (r : ℝ≥0∞) : (· • ·) c ⁻¹' ball x r = ball (c⁻¹ • x) r :=
  by rw [preimage_smul, smul_ball]
#align emetric.preimage_smul_ball EMetric.preimage_smul_ball
#align emetric.preimage_vadd_ball EMetric.preimage_vadd_ball

@[to_additive (attr := simp)]
theorem smul_closedBall (c : G) (x : X) (r : ℝ≥0∞) : c • closedBall x r = closedBall (c • x) r :=
  (IsometryEquiv.constSMul c).image_emetric_closedBall _ _
#align emetric.smul_closed_ball EMetric.smul_closedBall
#align emetric.vadd_closed_ball EMetric.vadd_closedBall

@[to_additive (attr := simp)]
theorem preimage_smul_closedBall (c : G) (x : X) (r : ℝ≥0∞) :
    (· • ·) c ⁻¹' closedBall x r = closedBall (c⁻¹ • x) r := by
  rw [preimage_smul, smul_closedBall]
#align emetric.preimage_smul_closed_ball EMetric.preimage_smul_closedBall
#align emetric.preimage_vadd_closed_ball EMetric.preimage_vadd_closedBall

variable [PseudoEMetricSpace G]

@[to_additive (attr := simp)]
theorem preimage_mul_left_ball [IsometricSMul G G] (a b : G) (r : ℝ≥0∞) :
    (· * ·) a ⁻¹' ball b r = ball (a⁻¹ * b) r :=
  preimage_smul_ball a b r
#align emetric.preimage_mul_left_ball EMetric.preimage_mul_left_ball
#align emetric.preimage_add_left_ball EMetric.preimage_add_left_ball

@[to_additive (attr := simp)]
theorem preimage_mul_right_ball [IsometricSMul Gᵐᵒᵖ G] (a b : G) (r : ℝ≥0∞) :
    (fun x => x * a) ⁻¹' ball b r = ball (b / a) r := by
  rw [div_eq_mul_inv]
  exact preimage_smul_ball (MulOpposite.op a) b r
#align emetric.preimage_mul_right_ball EMetric.preimage_mul_right_ball
#align emetric.preimage_add_right_ball EMetric.preimage_add_right_ball

@[to_additive (attr := simp)]
theorem preimage_mul_left_closedBall [IsometricSMul G G] (a b : G) (r : ℝ≥0∞) :
    (· * ·) a ⁻¹' closedBall b r = closedBall (a⁻¹ * b) r :=
  preimage_smul_closedBall a b r
#align emetric.preimage_mul_left_closed_ball EMetric.preimage_mul_left_closedBall
#align emetric.preimage_add_left_closed_ball EMetric.preimage_add_left_closedBall

@[to_additive (attr := simp)]
theorem preimage_mul_right_closedBall [IsometricSMul Gᵐᵒᵖ G] (a b : G) (r : ℝ≥0∞) :
    (fun x => x * a) ⁻¹' closedBall b r = closedBall (b / a) r := by
  rw [div_eq_mul_inv]
  exact preimage_smul_closedBall (MulOpposite.op a) b r
#align emetric.preimage_mul_right_closed_ball EMetric.preimage_mul_right_closedBall
#align emetric.preimage_add_right_closed_ball EMetric.preimage_add_right_closedBall

end EMetric

end EMetric

@[to_additive (attr := simp)]
theorem dist_smul [PseudoMetricSpace X] [SMul M X] [IsometricSMul M X] (c : M) (x y : X) :
    dist (c • x) (c • y) = dist x y :=
  (isometry_smul X c).dist_eq x y
#align dist_smul dist_smul
#align dist_vadd dist_vadd

@[to_additive (attr := simp)]
theorem nndist_smul [PseudoMetricSpace X] [SMul M X] [IsometricSMul M X] (c : M) (x y : X) :
    nndist (c • x) (c • y) = nndist x y :=
  (isometry_smul X c).nndist_eq x y
#align nndist_smul nndist_smul
#align nndist_vadd nndist_vadd

@[to_additive (attr := simp)]
theorem dist_mul_left [PseudoMetricSpace M] [Mul M] [IsometricSMul M M] (a b c : M) :
    dist (a * b) (a * c) = dist b c :=
  dist_smul a b c
#align dist_mul_left dist_mul_left
#align dist_add_left dist_add_left

@[to_additive (attr := simp)]
theorem nndist_mul_left [PseudoMetricSpace M] [Mul M] [IsometricSMul M M] (a b c : M) :
    nndist (a * b) (a * c) = nndist b c :=
  nndist_smul a b c
#align nndist_mul_left nndist_mul_left
#align nndist_add_left nndist_add_left

@[to_additive (attr := simp)]
theorem dist_mul_right [Mul M] [PseudoMetricSpace M] [IsometricSMul Mᵐᵒᵖ M] (a b c : M) :
    dist (a * c) (b * c) = dist a b :=
  dist_smul (MulOpposite.op c) a b
#align dist_mul_right dist_mul_right
#align dist_add_right dist_add_right

@[to_additive (attr := simp)]
theorem nndist_mul_right [PseudoMetricSpace M] [Mul M] [IsometricSMul Mᵐᵒᵖ M] (a b c : M) :
    nndist (a * c) (b * c) = nndist a b :=
  nndist_smul (MulOpposite.op c) a b
#align nndist_mul_right nndist_mul_right
#align nndist_add_right nndist_add_right

@[to_additive (attr := simp)]
theorem dist_div_right [DivInvMonoid M] [PseudoMetricSpace M] [IsometricSMul Mᵐᵒᵖ M]
    (a b c : M) : dist (a / c) (b / c) = dist a b := by simp only [div_eq_mul_inv, dist_mul_right]
#align dist_div_right dist_div_right
#align dist_sub_right dist_sub_right

@[to_additive (attr := simp)]
theorem nndist_div_right [DivInvMonoid M] [PseudoMetricSpace M] [IsometricSMul Mᵐᵒᵖ M]
    (a b c : M) : nndist (a / c) (b / c) = nndist a b := by
  simp only [div_eq_mul_inv, nndist_mul_right]
#align nndist_div_right nndist_div_right
#align nndist_sub_right nndist_sub_right

@[to_additive (attr := simp)]
theorem dist_inv_inv [Group G] [PseudoMetricSpace G] [IsometricSMul G G]
    [IsometricSMul Gᵐᵒᵖ G] (a b : G) : dist a⁻¹ b⁻¹ = dist a b :=
  (IsometryEquiv.inv G).dist_eq a b
#align dist_inv_inv dist_inv_inv
#align dist_neg_neg dist_neg_neg

@[to_additive (attr := simp)]
theorem nndist_inv_inv [Group G] [PseudoMetricSpace G] [IsometricSMul G G]
    [IsometricSMul Gᵐᵒᵖ G] (a b : G) : nndist a⁻¹ b⁻¹ = nndist a b :=
  (IsometryEquiv.inv G).nndist_eq a b
#align nndist_inv_inv nndist_inv_inv
#align nndist_neg_neg nndist_neg_neg

@[to_additive (attr := simp)]
theorem dist_div_left [Group G] [PseudoMetricSpace G] [IsometricSMul G G]
    [IsometricSMul Gᵐᵒᵖ G] (a b c : G) : dist (a / b) (a / c) = dist b c := by
  simp [div_eq_mul_inv]
#align dist_div_left dist_div_left
#align dist_sub_left dist_sub_left

@[to_additive (attr := simp)]
theorem nndist_div_left [Group G] [PseudoMetricSpace G] [IsometricSMul G G]
    [IsometricSMul Gᵐᵒᵖ G] (a b c : G) : nndist (a / b) (a / c) = nndist b c := by
  simp [div_eq_mul_inv]
#align nndist_div_left nndist_div_left
#align nndist_sub_left nndist_sub_left

namespace Metric

variable [PseudoMetricSpace X] [Group G] [MulAction G X] [IsometricSMul G X]

@[to_additive (attr := simp)]
theorem smul_ball (c : G) (x : X) (r : ℝ) : c • ball x r = ball (c • x) r :=
  (IsometryEquiv.constSMul c).image_ball _ _
#align metric.smul_ball Metric.smul_ball
#align metric.vadd_ball Metric.vadd_ball

@[to_additive (attr := simp)]
theorem preimage_smul_ball (c : G) (x : X) (r : ℝ) : (· • ·) c ⁻¹' ball x r = ball (c⁻¹ • x) r := by
  rw [preimage_smul, smul_ball]
#align metric.preimage_smul_ball Metric.preimage_smul_ball
#align metric.preimage_vadd_ball Metric.preimage_vadd_ball

@[to_additive (attr := simp)]
theorem smul_closedBall (c : G) (x : X) (r : ℝ) : c • closedBall x r = closedBall (c • x) r :=
  (IsometryEquiv.constSMul c).image_closedBall _ _
#align metric.smul_closed_ball Metric.smul_closedBall
#align metric.vadd_closed_ball Metric.vadd_closedBall

@[to_additive (attr := simp)]
theorem preimage_smul_closedBall (c : G) (x : X) (r : ℝ) :
    (· • ·) c ⁻¹' closedBall x r = closedBall (c⁻¹ • x) r := by rw [preimage_smul, smul_closedBall]
#align metric.preimage_smul_closed_ball Metric.preimage_smul_closedBall
#align metric.preimage_vadd_closed_ball Metric.preimage_vadd_closedBall

@[to_additive (attr := simp)]
theorem smul_sphere (c : G) (x : X) (r : ℝ) : c • sphere x r = sphere (c • x) r :=
  (IsometryEquiv.constSMul c).image_sphere _ _
#align metric.smul_sphere Metric.smul_sphere
#align metric.vadd_sphere Metric.vadd_sphere

@[to_additive (attr := simp)]
theorem preimage_smul_sphere (c : G) (x : X) (r : ℝ) :
    (· • ·) c ⁻¹' sphere x r = sphere (c⁻¹ • x) r := by rw [preimage_smul, smul_sphere]
#align metric.preimage_smul_sphere Metric.preimage_smul_sphere
#align metric.preimage_vadd_sphere Metric.preimage_vadd_sphere

variable [PseudoMetricSpace G]

@[to_additive (attr := simp)]
theorem preimage_mul_left_ball [IsometricSMul G G] (a b : G) (r : ℝ) :
    (· * ·) a ⁻¹' ball b r = ball (a⁻¹ * b) r :=
  preimage_smul_ball a b r
#align metric.preimage_mul_left_ball Metric.preimage_mul_left_ball
#align metric.preimage_add_left_ball Metric.preimage_add_left_ball

@[to_additive (attr := simp)]
theorem preimage_mul_right_ball [IsometricSMul Gᵐᵒᵖ G] (a b : G) (r : ℝ) :
    (fun x => x * a) ⁻¹' ball b r = ball (b / a) r := by
  rw [div_eq_mul_inv]
  exact preimage_smul_ball (MulOpposite.op a) b r
#align metric.preimage_mul_right_ball Metric.preimage_mul_right_ball
#align metric.preimage_add_right_ball Metric.preimage_add_right_ball

@[to_additive (attr := simp)]
theorem preimage_mul_left_closedBall [IsometricSMul G G] (a b : G) (r : ℝ) :
    (· * ·) a ⁻¹' closedBall b r = closedBall (a⁻¹ * b) r :=
  preimage_smul_closedBall a b r
#align metric.preimage_mul_left_closed_ball Metric.preimage_mul_left_closedBall
#align metric.preimage_add_left_closed_ball Metric.preimage_add_left_closedBall

@[to_additive (attr := simp)]
theorem preimage_mul_right_closedBall [IsometricSMul Gᵐᵒᵖ G] (a b : G) (r : ℝ) :
    (fun x => x * a) ⁻¹' closedBall b r = closedBall (b / a) r := by
  rw [div_eq_mul_inv]
  exact preimage_smul_closedBall (MulOpposite.op a) b r
#align metric.preimage_mul_right_closed_ball Metric.preimage_mul_right_closedBall
#align metric.preimage_add_right_closed_ball Metric.preimage_add_right_closedBall

end Metric

section Instances

variable {Y : Type _} [PseudoEMetricSpace X] [PseudoEMetricSpace Y] [SMul M X]
  [IsometricSMul M X]

@[to_additive]
instance [SMul M Y] [IsometricSMul M Y] : IsometricSMul M (X × Y) :=
  ⟨fun c => (isometry_smul X c).prod_map (isometry_smul Y c)⟩

@[to_additive]
instance Prod.isometricSMul' {N} [Mul M] [PseudoEMetricSpace M] [IsometricSMul M M] [Mul N]
    [PseudoEMetricSpace N] [IsometricSMul N N] : IsometricSMul (M × N) (M × N) :=
  ⟨fun c => (isometry_smul M c.1).prod_map (isometry_smul N c.2)⟩
#align prod.has_isometric_smul' Prod.isometricSMul'
#align prod.has_isometric_vadd' Prod.isometricVAdd'

@[to_additive]
instance Prod.isometricSMul'' {N} [Mul M] [PseudoEMetricSpace M] [IsometricSMul Mᵐᵒᵖ M]
    [Mul N] [PseudoEMetricSpace N] [IsometricSMul Nᵐᵒᵖ N] :
    IsometricSMul (M × N)ᵐᵒᵖ (M × N) :=
  ⟨fun c => (isometry_mul_right c.unop.1).prod_map (isometry_mul_right c.unop.2)⟩
#align prod.has_isometric_smul'' Prod.isometricSMul''
#align prod.has_isometric_vadd'' Prod.isometricVAdd''

@[to_additive]
instance Units.isometricSMul [Monoid M] : IsometricSMul Mˣ X :=
  ⟨fun c => isometry_smul X (c : M)⟩
#align units.has_isometric_smul Units.isometricSMul
#align add_units.has_isometric_vadd AddUnits.isometricVAdd

@[to_additive]
instance : IsometricSMul M Xᵐᵒᵖ :=
  ⟨fun c x y => by simpa only using edist_smul_left c x.unop y.unop⟩

@[to_additive]
instance ULift.isometricSMul : IsometricSMul (ULift M) X :=
  ⟨fun c => by simpa only using isometry_smul X c.down⟩
#align ulift.has_isometric_smul ULift.isometricSMul
#align ulift.has_isometric_vadd ULift.isometricVAdd

@[to_additive]
instance ULift.isometricSMul' : IsometricSMul M (ULift X) :=
  ⟨fun c x y => by simpa only using edist_smul_left c x.1 y.1⟩
#align ulift.has_isometric_smul' ULift.isometricSMul'
#align ulift.has_isometric_vadd' ULift.isometricVAdd'

@[to_additive]
instance {ι} {X : ι → Type _} [Fintype ι] [∀ i, SMul M (X i)] [∀ i, PseudoEMetricSpace (X i)]
    [∀ i, IsometricSMul M (X i)] : IsometricSMul M (∀ i, X i) :=
  ⟨fun c => isometry_dcomp (fun _ => (c • ·)) fun i => isometry_smul (X i) c⟩

@[to_additive]
instance Pi.isometricSMul' {ι} {M X : ι → Type _} [Fintype ι] [∀ i, SMul (M i) (X i)]
    [∀ i, PseudoEMetricSpace (X i)] [∀ i, IsometricSMul (M i) (X i)] :
    IsometricSMul (∀ i, M i) (∀ i, X i) :=
  ⟨fun c => isometry_dcomp (fun i => (c i • ·)) fun _ => isometry_smul _ _⟩
#align pi.has_isometric_smul' Pi.isometricSMul'
#align pi.has_isometric_vadd' Pi.isometricVAdd'

@[to_additive]
instance Pi.isometricSMul'' {ι} {M : ι → Type _} [Fintype ι] [∀ i, Mul (M i)]
    [∀ i, PseudoEMetricSpace (M i)] [∀ i, IsometricSMul (M i)ᵐᵒᵖ (M i)] :
    IsometricSMul (∀ i, M i)ᵐᵒᵖ (∀ i, M i) :=
  ⟨fun c => isometry_dcomp (fun i (x : M i) => x * c.unop i) fun _ => isometry_mul_right _⟩
#align pi.has_isometric_smul'' Pi.isometricSMul''
#align pi.has_isometric_vadd'' Pi.isometricVAdd''

instance Additive.isometricVAdd : IsometricVAdd (Additive M) X :=
  ⟨fun c => isometry_smul X (toMul c)⟩
#align additive.has_isometric_vadd Additive.isometricVAdd

instance Additive.isometricVAdd' [Mul M] [PseudoEMetricSpace M] [IsometricSMul M M] :
    IsometricVAdd (Additive M) (Additive M) :=
  ⟨fun c x y => edist_smul_left (toMul c) (toMul x) (toMul y)⟩
#align additive.has_isometric_vadd' Additive.isometricVAdd'

instance Additive.isometricVAdd'' [Mul M] [PseudoEMetricSpace M] [IsometricSMul Mᵐᵒᵖ M] :
    IsometricVAdd (Additive M)ᵃᵒᵖ (Additive M) :=
  ⟨fun c x y => edist_smul_left (MulOpposite.op (toMul c.unop)) (toMul x) (toMul y)⟩
#align additive.has_isometric_vadd'' Additive.isometricVAdd''

instance Multiplicative.isometricSMul {M X} [VAdd M X] [PseudoEMetricSpace X]
    [IsometricVAdd M X] : IsometricSMul (Multiplicative M) X :=
  ⟨fun c => isometry_vadd X (toAdd c)⟩
#align multiplicative.has_isometric_smul Multiplicative.isometricSMul

instance Multiplicative.isometricSMul' [Add M] [PseudoEMetricSpace M] [IsometricVAdd M M] :
    IsometricSMul (Multiplicative M) (Multiplicative M) :=
  ⟨fun c x y => edist_vadd_left (toAdd c) (toAdd x) (toAdd y)⟩
#align multiplicative.has_isometric_smul' Multiplicative.isometricSMul'

instance Multiplicative.isometricVAdd'' [Add M] [PseudoEMetricSpace M]
    [IsometricVAdd Mᵃᵒᵖ M] : IsometricSMul (Multiplicative M)ᵐᵒᵖ (Multiplicative M) :=
  ⟨fun c x y => edist_vadd_left (AddOpposite.op (toAdd c.unop)) (toAdd x) (toAdd y)⟩
#align multiplicative.has_isometric_vadd'' Multiplicative.isometricVAdd''

end Instances