/-
Copyright (c) 2021-2022 by the authors listed in the file AUTHORS and their
institutional affiliations. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Abdalrhman Mohamed
-/

import Lean

import Smt.Dsl.Sexp
import Smt.Query
import Smt.Reconstruction.Certifying
import Smt.Solver

namespace Smt

open Lean Elab Tactic
open Smt Query Solver

initialize
  registerTraceClass `smt.debug
  registerTraceClass `smt.debug.attr
  registerTraceClass `smt.debug.reconstruct
  registerTraceClass `smt.debug.translate.query
  registerTraceClass `smt.debug.translate.expr

syntax smtHints := ("[" ident,* "]")?
syntax smtTimeout := ("(timeout := " num ")")?

/-- `smt` converts the current goal into an SMT query and checks if it is
satisfiable. By default, `smt` generates the minimum valid SMT query needed to
assert the current goal. However, that is not always enough:
```lean
def modus_ponens (p q : Prop) (hp : p) (hpq : p → q) : q := by
  smt
```
For the theorem above, `smt` generates the query below:
```smt2
(declare-const q Bool)
(assert (not q))
(check-sat)
```
which is missing the hypotheses `hp` and `hpq` required to prove the theorem. To
pass hypotheses to the solver, use `smt [h₁, h₂, ..., hₙ]` syntax:
```lean
def modus_ponens (p q : Prop) (hp : p) (hpq : p → q) : q := by
  smt [hp, hpq]
```
The tactic then generates the query below:
```smt2
(declare-const q Bool)
(assert (not q))
(declare-const p Bool)
(assert p)
(assert (=> p q))
(check-sat)
```
-/
syntax (name := smt) "smt" smtHints smtTimeout : tactic

/-- Like `smt`, but just shows the query without invoking a solver. -/
syntax (name := smtShow) "smt_show" smtHints : tactic

def parseHints : TSyntax `smtHints → TacticM (List Expr)
  | `(smtHints| [ $[$hs],* ]) => hs.toList.mapM (fun h => elabTerm h.raw none)
  | `(smtHints| ) => return []
  | _ => throwUnsupportedSyntax

def parseTimeout : TSyntax `smtTimeout → TacticM (Option Nat)
  | `(smtTimeout| (timeout := $n)) => return some n.getNat
  | `(smtTimeout| ) => return some 5
  | _ => throwUnsupportedSyntax

def prepareSmtQuery (hints : TSyntax `smtHints) : TacticM (List Command) := do
  -- 1. Get the current main goal.
  let goalType ← Tactic.getMainTarget
  let goalId ← Lean.mkFreshMVarId
  Lean.Meta.withLocalDeclD goalId.name (mkNot goalType) fun g => do
  -- 2. Get the hints passed to the tactic.
  let mut hs ← parseHints hints
  hs := hs.eraseDups
  -- 3. Generate the SMT query.
  Query.generateQuery g hs

def elabProof (text : String) : TacticM Unit := do
  let (env, log) ← process text (← getEnv) .empty "<proof>"
  _ ← modifyEnv (fun _ => env)
  for m in log.msgs do
    trace[smt.debug.reconstruct] (← m.toString)
  if log.hasErrors then
    throwError "encountered errors elaborating cvc5 proof"

def evalAnyGoals (tactic : TacticM Unit) : TacticM Unit := do
  let mvarIds ← getGoals
  let mut mvarIdsNew := #[]
  for mvarId in mvarIds do
    unless (← mvarId.isAssigned) do
      setGoals [mvarId]
      try
        tactic
        mvarIdsNew := mvarIdsNew ++ (← getUnsolvedGoals)
      catch _ =>
        mvarIdsNew := mvarIdsNew.push mvarId
  setGoals mvarIdsNew.toList

private def addDeclToUnfoldOrTheorem (thms : Meta.SimpTheorems) (e : Expr) : MetaM Meta.SimpTheorems := do
  if e.isConst then
    let declName := e.constName!
    let info ← getConstInfo declName
    if (← Meta.isProp info.type) then
      thms.addConst declName
    else
      thms.addDeclToUnfold declName
  else
    thms.add (.fvar e.fvarId!) #[] e

open Reconstruction.Certifying in
def rconsProof (hints : List Expr) : TacticM Unit := do
  let mut gs ← (← Tactic.getMainGoal).apply (mkApp (mkConst ``notNotElim) (← Tactic.getMainTarget))
  Tactic.replaceMainGoal gs
  if (← getConstInfo `th0).levelParams == [] then
    gs ← (← Tactic.getMainGoal).apply (mkConst `th0)
    trace[smt.debug.reconstruct] "th0 : {← Meta.inferType (mkConst `th0)}"
  else
    let u ← Meta.mkFreshLevelMVar
    gs ← (← Tactic.getMainGoal).apply (mkConst `th0 [u])
    trace[smt.debug.reconstruct] "th0 : {← Meta.inferType (mkConst `th0 [u])}"
  Tactic.replaceMainGoal gs
  for h in hints do
    evalAnyGoals do
      let gs ← (← Tactic.getMainGoal).apply h
      Tactic.replaceMainGoal gs
  let mut some thms ← (← Meta.getSimpExtension? `smt_simp).mapM (·.getTheorems)
    | throwError "smt tactic failed, 'smt_simp' simpset is not available"
  for h in hints do
    thms ← addDeclToUnfoldOrTheorem thms h
  evalAnyGoals do
    let (result?, _) ← Meta.simpGoal (← Tactic.getMainGoal) {
      simpTheorems := #[thms],
      congrTheorems := (← Meta.getSimpCongrTheorems)
    }
    match result? with
    | none => replaceMainGoal []
    | some (_, mvarId) => replaceMainGoal [mvarId]

@[tactic smt] def evalSmt : Tactic := fun stx => withMainContext do
  let goalType ← Tactic.getMainTarget
  let cmds ← prepareSmtQuery ⟨stx[1]⟩
  let query := setOption "produce-models" "true"
            *> emitCommands cmds.reverse
            *> checkSat
  logInfo m!"goal: {goalType}"
  logInfo m!"\nquery:\n{Command.cmdsAsQuery (.checkSat :: cmds)}"
  -- 4. Run the solver.
  let kind := smt.solver.kind.get (← getOptions)
  let path := smt.solver.path.get? (← getOptions)
  let timeout ← parseTimeout ⟨stx[2]⟩
  let ss ← createFromKind kind path timeout
  let (res, ss) ← (StateT.run query ss : MetaM _)
  -- 5. Print the result.
  logInfo m!"\nresult: {res}"
  if res = .sat then
    -- 5a. Print model.
    let (model, _) ← StateT.run getModel ss
    logInfo m!"\ncounter-model:\n{model}\n"
    throwError "unable to prove goal, either it is false or you need to define more symbols with `smt [foo, bar]`"
  if res = .unknown then
    throwError "unable to prove goal"
  try
    -- 5a. Reconstruct proof.
    let (.expr [.atom "proof", .atom nnp], _) ← StateT.run getProof ss
      | throwError "encountered error parsing cvc5 proof"
    let nnp := skipImports (unquote nnp)
    trace[smt.debug.reconstruct] "proof:\n{nnp}"
    elabProof nnp
    rconsProof (← parseHints ⟨stx[1]⟩)
  catch e =>
    logInfo m!"failed to reconstruct proof: {e.toMessageData}"
where
  unquote s := s.extract ⟨1⟩ (s.endPos - ⟨1⟩)
  skipImports (s : String) := Id.run do
    let mut s := s
    while s.startsWith "import" do
      s := s.dropWhile (· != '\n')
      s := s.drop 1
    return s

@[tactic smtShow] def evalSmtShow : Tactic := fun stx => withMainContext do
  let goalType ← Tactic.getMainTarget
  let cmds := .checkSat :: (← prepareSmtQuery ⟨stx[1]⟩)
  -- 4. Print the query.
  logInfo m!"goal: {goalType}\n\nquery:\n{Command.cmdsAsQuery cmds}"

end Smt


/-
Copyright (c) 2022 Andrew Yang. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Andrew Yang
-/
import morphisms.ring_hom_properties
import ring_theory.ring_hom.finite_type
import dimension_theory.jacobson
import algebraic_geometry.surjective_on_stalks

/-!
# Morphisms of finite type

A morphism of schemes `f : X ⟶ Y` is locally of finite type if for each affine `U ⊆ Y` and
`V ⊆ f ⁻¹' U`, The induced map `Γ(Y, U) ⟶ Γ(X, V)` is of finite type.

A morphism of schemes is of finite type if it is both locally of finite type and quasi-compact.

We show that these properties are local, and are stable under compositions.

-/

noncomputable theory

open category_theory category_theory.limits opposite topological_space

universes v u

namespace algebraic_geometry

variables {X Y : Scheme.{u}} (f : X ⟶ Y)

/--
A morphism of schemes `f : X ⟶ Y` is locally of finite type if for each affine `U ⊆ Y` and
`V ⊆ f ⁻¹' U`, The induced map `Γ(Y, U) ⟶ Γ(X, V)` is of finite type.
-/
@[mk_iff]
class locally_of_finite_type (f : X ⟶ Y) : Prop :=
(finite_type_of_affine_subset :
  ∀ (U : Y.affine_opens) (V : X.affine_opens) (e : V.1 ≤ (opens.map f.1.base).obj U.1),
  (f.app_le e).finite_type)

lemma locally_of_finite_type_eq :
  @locally_of_finite_type = affine_locally @ring_hom.finite_type :=
begin
  ext X Y f,
  rw [locally_of_finite_type_iff, affine_locally_iff_affine_opens_le],
  exact ring_hom.finite_type_respects_iso
end

@[priority 900]
instance locally_of_finite_type_of_is_open_immersion {X Y : Scheme} (f : X ⟶ Y)
  [is_open_immersion f] : locally_of_finite_type f :=
locally_of_finite_type_eq.symm ▸
  ring_hom.finite_type_is_local.affine_locally_of_is_open_immersion f

lemma locally_of_finite_type_stable_under_composition :
  morphism_property.stable_under_composition @locally_of_finite_type :=
locally_of_finite_type_eq.symm ▸
ring_hom.finite_type_is_local.affine_locally_stable_under_composition

instance locally_of_finite_type_comp {X Y Z : Scheme} (f : X ⟶ Y) (g : Y ⟶ Z)
  [hf : locally_of_finite_type f] [hg : locally_of_finite_type g] :
  locally_of_finite_type (f ≫ g) :=
locally_of_finite_type_stable_under_composition f g hf hg

lemma locally_of_finite_type_of_comp {X Y Z : Scheme} (f : X ⟶ Y) (g : Y ⟶ Z)
  [hf : locally_of_finite_type (f ≫ g)] :
  locally_of_finite_type f :=
begin
  unfreezingI { revert hf },
  rw [locally_of_finite_type_eq],
  apply ring_hom.finite_type_is_local.affine_locally_of_comp,
  introv H,
  exactI ring_hom.finite_type.of_comp_finite_type H,
end

lemma locally_of_finite_type.affine_open_cover_iff {X Y : Scheme.{u}} (f : X ⟶ Y)
  (𝒰 : Scheme.open_cover.{u} Y) [∀ i, is_affine (𝒰.obj i)]
  (𝒰' : ∀ i, Scheme.open_cover.{u} ((𝒰.pullback_cover f).obj i))
  [∀ i j, is_affine ((𝒰' i).obj j)] :
  locally_of_finite_type f ↔
    (∀ i j, (Scheme.Γ.map ((𝒰' i).map j ≫ pullback.snd).op).finite_type) :=
locally_of_finite_type_eq.symm ▸ ring_hom.finite_type_is_local.affine_open_cover_iff f 𝒰 𝒰'

lemma locally_of_finite_type.source_open_cover_iff {X Y : Scheme.{u}} (f : X ⟶ Y)
  (𝒰 : Scheme.open_cover.{u} X) :
  locally_of_finite_type f ↔ (∀ i, locally_of_finite_type (𝒰.map i ≫ f)) :=
locally_of_finite_type_eq.symm ▸ ring_hom.finite_type_is_local.source_open_cover_iff f 𝒰

lemma locally_of_finite_type.open_cover_iff {X Y : Scheme.{u}} (f : X ⟶ Y)
  (𝒰 : Scheme.open_cover.{u} Y) :
  locally_of_finite_type f ↔
    (∀ i, locally_of_finite_type (pullback.snd : pullback f (𝒰.map i) ⟶ _)) :=
locally_of_finite_type_eq.symm ▸
  ring_hom.finite_type_is_local.is_local_affine_locally.open_cover_iff f 𝒰

lemma locally_of_finite_type_respects_iso :
  morphism_property.respects_iso @locally_of_finite_type :=
locally_of_finite_type_eq.symm ▸ target_affine_locally_respects_iso
  (source_affine_locally_respects_iso ring_hom.finite_type_respects_iso)

lemma locally_of_finite_type_is_local_at_target :
  property_is_local_at_target @locally_of_finite_type :=
locally_of_finite_type_eq.symm ▸
  (source_affine_locally_is_local ring_hom.finite_type_respects_iso
    ring_hom.finite_type_is_local.localization_preserves
     ring_hom.finite_type_is_local.of_localization_span).target_affine_locally_is_local

lemma locally_of_finite_type_is_local_at_source :
  property_is_local_at_source @locally_of_finite_type :=
locally_of_finite_type_eq.symm ▸
  ring_hom.finite_type_is_local.affine_locally_local_at_source

-- move me
lemma subalgebra.map_top {R S T : Type*} [comm_ring R] [comm_ring S] [comm_ring T]
  [algebra R S] [algebra R T] (f : S →ₐ[R] T) : (⊤ : subalgebra R S).map f = f.range :=
begin
  ext, simp,
end

-- move me
lemma _root_.ring_hom.finite_type_stable_under_base_change :
  ring_hom.stable_under_base_change @ring_hom.finite_type :=
begin
  classical,
  rintros R S T _ _ _ _ i7 ⟨⟨s, hs⟩⟩,
  resetI,
  suffices : algebra.finite_type S (tensor_product R S T),
  { delta ring_hom.finite_type, convert this, apply algebra.algebra_ext, intro _, refl },
  replace hs : algebra.adjoin R (↑s : set T) = ⊤,
  { have : i7 = (algebra_map R T).to_algebra := algebra.algebra_ext _ _ (λ _, rfl), convert hs },
  refine ⟨⟨s.image algebra.tensor_product.include_right, _⟩⟩,
  rw [finset.coe_image, ← @algebra.adjoin_adjoin_of_tower R S (tensor_product R S T),
    algebra.adjoin_image, hs, subalgebra.map_top, eq_top_iff],
  rintro x -,
  induction x using tensor_product.induction_on with x y x y hx hy,
  { exact zero_mem _ },
  { convert_to x • ((1 : S) ⊗ₜ y) ∈ _,
    { rw [tensor_product.smul_tmul', ← algebra.algebra_map_eq_smul_one], refl },
    { exact subalgebra.smul_mem _ (algebra.subset_adjoin ⟨y, rfl⟩) _ } },
  { exact add_mem hx hy }
end

lemma locally_of_finite_type_stable_under_base_change :
  morphism_property.stable_under_base_change @locally_of_finite_type :=
locally_of_finite_type_eq.symm ▸
  ring_hom.finite_type_is_local.affine_locally_stable_under_base_change
    ring_hom.finite_type_stable_under_base_change

instance {X Y Z : Scheme} (f : X ⟶ Z) (g : Y ⟶ Z) [locally_of_finite_type g] :
  locally_of_finite_type (pullback.fst : pullback f g ⟶ _) :=
locally_of_finite_type_stable_under_base_change.fst _ _ ‹_›

instance {X Y Z : Scheme} (f : X ⟶ Z) (g : Y ⟶ Z) [locally_of_finite_type f] :
  locally_of_finite_type (pullback.snd : pullback f g ⟶ _) :=
locally_of_finite_type_stable_under_base_change.snd _ _ ‹_›

-- generalize me
lemma locally_of_finite_type_Spec_iff {R S : CommRing} (f : R ⟶ S) :
  locally_of_finite_type (Scheme.Spec.map f.op) ↔ ring_hom.finite_type f :=
begin
  transitivity (@affine ⊓ @locally_of_finite_type) (Scheme.Spec.map f.op),
  { refine (and_iff_right _).symm, apply_instance },
  { rw [locally_of_finite_type_eq, ← ring_hom.property_is_local.affine_and_eq,
      (is_local_affine_and _ _ _ _).affine_target_iff, affine_and_Spec_iff],
    exacts [ring_hom.finite_type_respects_iso, ring_hom.finite_type_respects_iso,
      ring_hom.finite_type_is_local.localization_preserves,
      ring_hom.finite_type_is_local.of_localization_span,
      ring_hom.finite_type_is_local] }
end

lemma locally_of_finite_type.is_jacobson [locally_of_finite_type f] (hY : is_jacobson Y.carrier) :
  is_jacobson X.carrier :=
begin
  let 𝒰 : X.open_cover := (Y.affine_cover.pullback_cover f).bind (λ _, Scheme.affine_cover _),
  rw is_jacobson_iff_of_supr_eq_top 𝒰.supr_opens_range,
  intro i,
  refine is_jacobson.of_closed_embedding _ (homeomorph.of_embedding (𝒰.map i).1.base
    (is_open_immersion.base_open _).to_embedding).symm.closed_embedding,
  let g : 𝒰.obj i ⟶ _ := (Scheme.affine_cover _).map _ ≫ pullback.snd,
  refine prime_spectrum.is_jacobson_iff_is_jacobson.mp _,
  apply_with
    (@@is_jacobson_of_ring_hom_finite_type _ _ (Scheme.Spec.preimage g).unop) { instances := ff },
  { refine prime_spectrum.is_jacobson_iff_is_jacobson.mpr _,
    exact is_jacobson.of_open_embedding hY (is_open_immersion.base_open $ Y.affine_cover.map _) },
  rw [← locally_of_finite_type_Spec_iff, quiver.hom.op_unop, Scheme.Spec.image_preimage],
  apply_instance
end

end algebraic_geometry


/- "Hello world" -/

#eval "hello" ++ " " ++ "world"
-- "hello world"

#check true
-- Bool

def x := 10

#eval x + 2
-- 12

def double (x : Int) := 2*x

#eval double 3
-- 6
#check double
-- Int → Int
example : double 4 = 8 := rfl


/-
Copyright (c) 2020 Oliver Nash. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison, Oliver Nash

! This file was ported from Lean 3 source module tactic.noncomm_ring
! leanprover-community/mathlib commit abaabc8c03c8bdc430975669014d3e6c19de58e4
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Tactic.Abel

namespace Tactic

namespace Interactive

/- ./././Mathport/Syntax/Translate/Expr.lean:330:4: warning: unsupported (TODO): `[tacs] -/
/-- A tactic for simplifying identities in not-necessarily-commutative rings.

An example:
```lean
example {R : Type*} [ring R] (a b c : R) : a * (b + c + c - b) = 2*a*c :=
by noncomm_ring
```
-/
unsafe def noncomm_ring :=
  sorry
#align tactic.interactive.noncomm_ring tactic.interactive.noncomm_ring

-- Expand everything out.
-- Right associate all products.
-- Expand powers to numerals.
-- Replace multiplication by numerals with `zsmul`.
-- Pull `zsmul n` out the front so `abel` can see them.
-- Pull out negations.
add_tactic_doc
  { Name := "noncomm_ring"
    category := DocCategory.tactic
    declNames := [`tactic.interactive.noncomm_ring]
    tags := ["arithmetic", "simplification", "decision procedure"] }

end Interactive

end Tactic


/-
Copyright (c) 2018 Simon Hudon. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Simon Hudon, Patrick Massot

! This file was ported from Lean 3 source module group_theory.group_action.pi
! leanprover-community/mathlib commit c3291da49cfa65f0d43b094750541c0731edc932
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Algebra.Group.Pi
import Mathbin.GroupTheory.GroupAction.Defs

/-!
# Pi instances for multiplicative actions

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

This file defines instances for mul_action and related structures on Pi types.

## See also

* `group_theory.group_action.option`
* `group_theory.group_action.prod`
* `group_theory.group_action.sigma`
* `group_theory.group_action.sum`
-/

universe u v w

variable {I : Type u}

-- The indexing type
variable {f : I → Type v}

-- The family of types already equipped with instances
variable (x y : ∀ i, f i) (i : I)

namespace Pi

#print Pi.smul' /-
@[to_additive Pi.vadd']
instance smul' {g : I → Type _} [∀ i, SMul (f i) (g i)] : SMul (∀ i, f i) (∀ i : I, g i) :=
  ⟨fun s x => fun i => s i • x i⟩
#align pi.has_smul' Pi.smul'
#align pi.has_vadd' Pi.vadd'
-/

/- warning: pi.smul_apply' -> Pi.smul_apply' is a dubious translation:
lean 3 declaration is
  forall {I : Type.{u1}} {f : I -> Type.{u2}} (i : I) {g : I -> Type.{u3}} [_inst_1 : forall (i : I), SMul.{u2, u3} (f i) (g i)] (s : forall (i : I), f i) (x : forall (i : I), g i), Eq.{succ u3} (g i) (SMul.smul.{max u1 u2, max u1 u3} (forall (i : I), f i) (forall (i : I), g i) (Pi.smul'.{u1, u2, u3} I (fun (i : I) => f i) (fun (i : I) => g i) (fun (i : I) => _inst_1 i)) s x i) (SMul.smul.{u2, u3} (f i) (g i) (_inst_1 i) (s i) (x i))
but is expected to have type
  forall {I : Type.{u2}} {f : I -> Type.{u3}} (i : I) {g : I -> Type.{u1}} [_inst_1 : forall (i : I), SMul.{u3, u1} (f i) (g i)] (s : forall (i : I), f i) (x : forall (i : I), g i), Eq.{succ u1} (g i) (HSMul.hSMul.{max u2 u3, max u2 u1, max u2 u1} (forall (i : I), f i) (forall (i : I), g i) (forall (i : I), g i) (instHSMul.{max u2 u3, max u2 u1} (forall (i : I), f i) (forall (i : I), g i) (Pi.smul'.{u2, u3, u1} I (fun (i : I) => f i) (fun (i : I) => g i) (fun (i : I) => _inst_1 i))) s x i) (HSMul.hSMul.{u3, u1, u1} (f i) (g i) (g i) (instHSMul.{u3, u1} (f i) (g i) (_inst_1 i)) (s i) (x i))
Case conversion may be inaccurate. Consider using '#align pi.smul_apply' Pi.smul_apply'ₓ'. -/
@[simp, to_additive]
theorem smul_apply' {g : I → Type _} [∀ i, SMul (f i) (g i)] (s : ∀ i, f i) (x : ∀ i, g i) :
    (s • x) i = s i • x i :=
  rfl
#align pi.smul_apply' Pi.smul_apply'
#align pi.vadd_apply' Pi.vadd_apply'

#print Pi.isScalarTower /-
@[to_additive]
instance isScalarTower {α β : Type _} [SMul α β] [∀ i, SMul β <| f i] [∀ i, SMul α <| f i]
    [∀ i, IsScalarTower α β (f i)] : IsScalarTower α β (∀ i : I, f i) :=
  ⟨fun x y z => funext fun i => smul_assoc x y (z i)⟩
#align pi.is_scalar_tower Pi.isScalarTower
#align pi.vadd_assoc_class Pi.vaddAssocClass
-/

#print Pi.isScalarTower' /-
@[to_additive]
instance isScalarTower' {g : I → Type _} {α : Type _} [∀ i, SMul α <| f i] [∀ i, SMul (f i) (g i)]
    [∀ i, SMul α <| g i] [∀ i, IsScalarTower α (f i) (g i)] :
    IsScalarTower α (∀ i : I, f i) (∀ i : I, g i) :=
  ⟨fun x y z => funext fun i => smul_assoc x (y i) (z i)⟩
#align pi.is_scalar_tower' Pi.isScalarTower'
#align pi.vadd_assoc_class' Pi.vaddAssocClass'
-/

#print Pi.isScalarTower'' /-
@[to_additive]
instance isScalarTower'' {g : I → Type _} {h : I → Type _} [∀ i, SMul (f i) (g i)]
    [∀ i, SMul (g i) (h i)] [∀ i, SMul (f i) (h i)] [∀ i, IsScalarTower (f i) (g i) (h i)] :
    IsScalarTower (∀ i, f i) (∀ i, g i) (∀ i, h i) :=
  ⟨fun x y z => funext fun i => smul_assoc (x i) (y i) (z i)⟩
#align pi.is_scalar_tower'' Pi.isScalarTower''
#align pi.vadd_assoc_class'' Pi.vaddAssocClass''
-/

#print Pi.smulCommClass /-
@[to_additive]
instance smulCommClass {α β : Type _} [∀ i, SMul α <| f i] [∀ i, SMul β <| f i]
    [∀ i, SMulCommClass α β (f i)] : SMulCommClass α β (∀ i : I, f i) :=
  ⟨fun x y z => funext fun i => smul_comm x y (z i)⟩
#align pi.smul_comm_class Pi.smulCommClass
#align pi.vadd_comm_class Pi.vaddCommClass
-/

#print Pi.smulCommClass' /-
@[to_additive]
instance smulCommClass' {g : I → Type _} {α : Type _} [∀ i, SMul α <| g i] [∀ i, SMul (f i) (g i)]
    [∀ i, SMulCommClass α (f i) (g i)] : SMulCommClass α (∀ i : I, f i) (∀ i : I, g i) :=
  ⟨fun x y z => funext fun i => smul_comm x (y i) (z i)⟩
#align pi.smul_comm_class' Pi.smulCommClass'
#align pi.vadd_comm_class' Pi.vaddCommClass'
-/

#print Pi.smulCommClass'' /-
@[to_additive]
instance smulCommClass'' {g : I → Type _} {h : I → Type _} [∀ i, SMul (g i) (h i)]
    [∀ i, SMul (f i) (h i)] [∀ i, SMulCommClass (f i) (g i) (h i)] :
    SMulCommClass (∀ i, f i) (∀ i, g i) (∀ i, h i) :=
  ⟨fun x y z => funext fun i => smul_comm (x i) (y i) (z i)⟩
#align pi.smul_comm_class'' Pi.smulCommClass''
#align pi.vadd_comm_class'' Pi.vaddCommClass''
-/

@[to_additive]
instance {α : Type _} [∀ i, SMul α <| f i] [∀ i, SMul αᵐᵒᵖ <| f i] [∀ i, IsCentralScalar α (f i)] :
    IsCentralScalar α (∀ i, f i) :=
  ⟨fun r m => funext fun i => op_smul_eq_smul _ _⟩

/- warning: pi.has_faithful_smul_at -> Pi.faithfulSMul_at is a dubious translation:
lean 3 declaration is
  forall {I : Type.{u1}} {f : I -> Type.{u2}} {α : Type.{u3}} [_inst_1 : forall (i : I), SMul.{u3, u2} α (f i)] [_inst_2 : forall (i : I), Nonempty.{succ u2} (f i)] (i : I) [_inst_3 : FaithfulSMul.{u3, u2} α (f i) (_inst_1 i)], FaithfulSMul.{u3, max u1 u2} α (forall (i : I), f i) (Pi.instSMul.{u1, u2, u3} I α (fun (i : I) => f i) (fun (i : I) => _inst_1 i))
but is expected to have type
  forall {I : Type.{u2}} {f : I -> Type.{u3}} {α : Type.{u1}} [_inst_1 : forall (i : I), SMul.{u1, u3} α (f i)] [_inst_2 : forall (i : I), Nonempty.{succ u3} (f i)] (i : I) [_inst_3 : FaithfulSMul.{u1, u3} α (f i) (_inst_1 i)], FaithfulSMul.{u1, max u2 u3} α (forall (i : I), f i) (Pi.instSMul.{u2, u3, u1} I α (fun (i : I) => f i) (fun (i : I) => _inst_1 i))
Case conversion may be inaccurate. Consider using '#align pi.has_faithful_smul_at Pi.faithfulSMul_atₓ'. -/
/-- If `f i` has a faithful scalar action for a given `i`, then so does `Π i, f i`. This is
not an instance as `i` cannot be inferred. -/
@[to_additive Pi.faithfulVAdd_at
      "If `f i` has a faithful additive action for a given `i`, then\nso does `Π i, f i`. This is not an instance as `i` cannot be inferred"]
theorem faithfulSMul_at {α : Type _} [∀ i, SMul α <| f i] [∀ i, Nonempty (f i)] (i : I)
    [FaithfulSMul α (f i)] : FaithfulSMul α (∀ i, f i) :=
  ⟨fun x y h =>
    eq_of_smul_eq_smul fun a : f i => by
      classical
        have :=
          congr_fun (h <| Function.update (fun j => Classical.choice (‹∀ i, Nonempty (f i)› j)) i a)
            i
        simpa using this⟩
#align pi.has_faithful_smul_at Pi.faithfulSMul_at
#align pi.has_faithful_vadd_at Pi.faithfulVAdd_at

#print Pi.faithfulSMul /-
@[to_additive Pi.faithfulVAdd]
instance faithfulSMul {α : Type _} [Nonempty I] [∀ i, SMul α <| f i] [∀ i, Nonempty (f i)]
    [∀ i, FaithfulSMul α (f i)] : FaithfulSMul α (∀ i, f i) :=
  let ⟨i⟩ := ‹Nonempty I›
  faithfulSMul_at i
#align pi.has_faithful_smul Pi.faithfulSMul
#align pi.has_faithful_vadd Pi.faithfulVAdd
-/

#print Pi.mulAction /-
@[to_additive]
instance mulAction (α) {m : Monoid α} [∀ i, MulAction α <| f i] : @MulAction α (∀ i : I, f i) m
    where
  smul := (· • ·)
  mul_smul r s f := funext fun i => mul_smul _ _ _
  one_smul f := funext fun i => one_smul α _
#align pi.mul_action Pi.mulAction
#align pi.add_action Pi.addAction
-/

#print Pi.mulAction' /-
@[to_additive]
instance mulAction' {g : I → Type _} {m : ∀ i, Monoid (f i)} [∀ i, MulAction (f i) (g i)] :
    @MulAction (∀ i, f i) (∀ i : I, g i) (@Pi.monoid I f m)
    where
  smul := (· • ·)
  mul_smul r s f := funext fun i => mul_smul _ _ _
  one_smul f := funext fun i => one_smul _ _
#align pi.mul_action' Pi.mulAction'
#align pi.add_action' Pi.addAction'
-/

#print Pi.smulZeroClass /-
instance smulZeroClass (α) {n : ∀ i, Zero <| f i} [∀ i, SMulZeroClass α <| f i] :
    @SMulZeroClass α (∀ i : I, f i) (@Pi.instZero I f n)
    where smul_zero c := funext fun i => smul_zero _
#align pi.smul_zero_class Pi.smulZeroClass
-/

#print Pi.smulZeroClass' /-
instance smulZeroClass' {g : I → Type _} {n : ∀ i, Zero <| g i} [∀ i, SMulZeroClass (f i) (g i)] :
    @SMulZeroClass (∀ i, f i) (∀ i : I, g i) (@Pi.instZero I g n)
    where smul_zero := by
    intros
    ext x
    apply smul_zero
#align pi.smul_zero_class' Pi.smulZeroClass'
-/

#print Pi.distribSMul /-
instance distribSMul (α) {n : ∀ i, AddZeroClass <| f i} [∀ i, DistribSMul α <| f i] :
    @DistribSMul α (∀ i : I, f i) (@Pi.addZeroClass I f n)
    where smul_add c f g := funext fun i => smul_add _ _ _
#align pi.distrib_smul Pi.distribSMul
-/

#print Pi.distribSMul' /-
instance distribSMul' {g : I → Type _} {n : ∀ i, AddZeroClass <| g i}
    [∀ i, DistribSMul (f i) (g i)] : @DistribSMul (∀ i, f i) (∀ i : I, g i) (@Pi.addZeroClass I g n)
    where smul_add := by
    intros
    ext x
    apply smul_add
#align pi.distrib_smul' Pi.distribSMul'
-/

#print Pi.distribMulAction /-
instance distribMulAction (α) {m : Monoid α} {n : ∀ i, AddMonoid <| f i}
    [∀ i, DistribMulAction α <| f i] : @DistribMulAction α (∀ i : I, f i) m (@Pi.addMonoid I f n) :=
  { Pi.mulAction _, Pi.distribSMul _ with }
#align pi.distrib_mul_action Pi.distribMulAction
-/

#print Pi.distribMulAction' /-
instance distribMulAction' {g : I → Type _} {m : ∀ i, Monoid (f i)} {n : ∀ i, AddMonoid <| g i}
    [∀ i, DistribMulAction (f i) (g i)] :
    @DistribMulAction (∀ i, f i) (∀ i : I, g i) (@Pi.monoid I f m) (@Pi.addMonoid I g n) :=
  { Pi.mulAction', Pi.distribSMul' with }
#align pi.distrib_mul_action' Pi.distribMulAction'
-/

/- warning: pi.single_smul -> Pi.single_smul is a dubious translation:
lean 3 declaration is
  forall {I : Type.{u1}} {f : I -> Type.{u2}} {α : Type.{u3}} [_inst_1 : Monoid.{u3} α] [_inst_2 : forall (i : I), AddMonoid.{u2} (f i)] [_inst_3 : forall (i : I), DistribMulAction.{u3, u2} α (f i) _inst_1 (_inst_2 i)] [_inst_4 : DecidableEq.{succ u1} I] (i : I) (r : α) (x : f i), Eq.{max (succ u1) (succ u2)} (forall (i : I), f i) (Pi.single.{u1, u2} I (fun (i : I) => f i) (fun (a : I) (b : I) => _inst_4 a b) (fun (i : I) => AddZeroClass.toHasZero.{u2} (f i) (AddMonoid.toAddZeroClass.{u2} (f i) (_inst_2 i))) i (SMul.smul.{u3, u2} α (f i) (SMulZeroClass.toHasSmul.{u3, u2} α (f i) (AddZeroClass.toHasZero.{u2} (f i) (AddMonoid.toAddZeroClass.{u2} (f i) (_inst_2 i))) (DistribSMul.toSmulZeroClass.{u3, u2} α (f i) (AddMonoid.toAddZeroClass.{u2} (f i) (_inst_2 i)) (DistribMulAction.toDistribSMul.{u3, u2} α (f i) _inst_1 (_inst_2 i) (_inst_3 i)))) r x)) (SMul.smul.{u3, max u1 u2} α (forall (i : I), f i) (Pi.instSMul.{u1, u2, u3} I α (fun (i : I) => f i) (fun (i : I) => SMulZeroClass.toHasSmul.{u3, u2} α (f i) (AddZeroClass.toHasZero.{u2} (f i) (AddMonoid.toAddZeroClass.{u2} (f i) (_inst_2 i))) (DistribSMul.toSmulZeroClass.{u3, u2} α (f i) (AddMonoid.toAddZeroClass.{u2} (f i) (_inst_2 i)) (DistribMulAction.toDistribSMul.{u3, u2} α (f i) _inst_1 (_inst_2 i) (_inst_3 i))))) r (Pi.single.{u1, u2} I (fun (i : I) => f i) (fun (a : I) (b : I) => _inst_4 a b) (fun (i : I) => AddZeroClass.toHasZero.{u2} (f i) (AddMonoid.toAddZeroClass.{u2} (f i) (_inst_2 i))) i x))
but is expected to have type
  forall {I : Type.{u2}} {f : I -> Type.{u3}} {α : Type.{u1}} [_inst_1 : Monoid.{u1} α] [_inst_2 : forall (i : I), AddMonoid.{u3} (f i)] [_inst_3 : forall (i : I), DistribMulAction.{u1, u3} α (f i) _inst_1 (_inst_2 i)] [_inst_4 : DecidableEq.{succ u2} I] (i : I) (r : α) (x : f i), Eq.{max (succ u2) (succ u3)} (forall (i : I), f i) (Pi.single.{u2, u3} I f (fun (a : I) (b : I) => _inst_4 a b) (fun (i : I) => AddMonoid.toZero.{u3} (f i) (_inst_2 i)) i (HSMul.hSMul.{u1, u3, u3} α (f i) (f i) (instHSMul.{u1, u3} α (f i) (SMulZeroClass.toSMul.{u1, u3} α (f i) (AddMonoid.toZero.{u3} (f i) (_inst_2 i)) (DistribSMul.toSMulZeroClass.{u1, u3} α (f i) (AddMonoid.toAddZeroClass.{u3} (f i) (_inst_2 i)) (DistribMulAction.toDistribSMul.{u1, u3} α (f i) _inst_1 (_inst_2 i) (_inst_3 i))))) r x)) (HSMul.hSMul.{u1, max u3 u2, max u2 u3} α (forall (j : I), f j) (forall (i : I), f i) (instHSMul.{u1, max u2 u3} α (forall (j : I), f j) (Pi.instSMul.{u2, u3, u1} I α (fun (j : I) => f j) (fun (i : I) => SMulZeroClass.toSMul.{u1, u3} α (f i) (AddMonoid.toZero.{u3} (f i) (_inst_2 i)) (DistribSMul.toSMulZeroClass.{u1, u3} α (f i) (AddMonoid.toAddZeroClass.{u3} (f i) (_inst_2 i)) (DistribMulAction.toDistribSMul.{u1, u3} α (f i) _inst_1 (_inst_2 i) (_inst_3 i)))))) r (Pi.single.{u2, u3} I f (fun (a : I) (b : I) => _inst_4 a b) (fun (i : I) => AddMonoid.toZero.{u3} (f i) (_inst_2 i)) i x))
Case conversion may be inaccurate. Consider using '#align pi.single_smul Pi.single_smulₓ'. -/
theorem single_smul {α} [Monoid α] [∀ i, AddMonoid <| f i] [∀ i, DistribMulAction α <| f i]
    [DecidableEq I] (i : I) (r : α) (x : f i) : single i (r • x) = r • single i x :=
  single_op (fun i : I => ((· • ·) r : f i → f i)) (fun j => smul_zero _) _ _
#align pi.single_smul Pi.single_smul

/- warning: pi.single_smul' -> Pi.single_smul' is a dubious translation:
lean 3 declaration is
  forall {I : Type.{u1}} {α : Type.{u2}} {β : Type.{u3}} [_inst_1 : Monoid.{u2} α] [_inst_2 : AddMonoid.{u3} β] [_inst_3 : DistribMulAction.{u2, u3} α β _inst_1 _inst_2] [_inst_4 : DecidableEq.{succ u1} I] (i : I) (r : α) (x : β), Eq.{max (succ u1) (succ u3)} (I -> β) (Pi.single.{u1, u3} I (fun (i : I) => β) (fun (a : I) (b : I) => _inst_4 a b) (fun (i : I) => AddZeroClass.toHasZero.{u3} β (AddMonoid.toAddZeroClass.{u3} β _inst_2)) i (SMul.smul.{u2, u3} α β (SMulZeroClass.toHasSmul.{u2, u3} α β (AddZeroClass.toHasZero.{u3} β (AddMonoid.toAddZeroClass.{u3} β _inst_2)) (DistribSMul.toSmulZeroClass.{u2, u3} α β (AddMonoid.toAddZeroClass.{u3} β _inst_2) (DistribMulAction.toDistribSMul.{u2, u3} α β _inst_1 _inst_2 _inst_3))) r x)) (SMul.smul.{u2, max u1 u3} α (I -> β) (Pi.instSMul.{u1, u3, u2} I α (fun (i : I) => β) (fun (i : I) => SMulZeroClass.toHasSmul.{u2, u3} α β (AddZeroClass.toHasZero.{u3} β (AddMonoid.toAddZeroClass.{u3} β _inst_2)) (DistribSMul.toSmulZeroClass.{u2, u3} α β (AddMonoid.toAddZeroClass.{u3} β _inst_2) (DistribMulAction.toDistribSMul.{u2, u3} α β _inst_1 _inst_2 _inst_3)))) r (Pi.single.{u1, u3} I (fun (i : I) => β) (fun (a : I) (b : I) => _inst_4 a b) (fun (i : I) => AddZeroClass.toHasZero.{u3} β (AddMonoid.toAddZeroClass.{u3} β _inst_2)) i x))
but is expected to have type
  forall {I : Type.{u3}} {α : Type.{u2}} {β : Type.{u1}} [_inst_1 : Monoid.{u2} α] [_inst_2 : AddMonoid.{u1} β] [_inst_3 : DistribMulAction.{u2, u1} α β _inst_1 _inst_2] [_inst_4 : DecidableEq.{succ u3} I] (i : I) (r : α) (x : β), Eq.{max (succ u3) (succ u1)} (I -> β) (Pi.single.{u3, u1} I (fun (i : I) => β) (fun (a : I) (b : I) => _inst_4 a b) (fun (i : I) => AddMonoid.toZero.{u1} ((fun (x._@.Mathlib.GroupTheory.GroupAction.Pi._hyg.1984 : I) => β) i) _inst_2) i (HSMul.hSMul.{u2, u1, u1} α β β (instHSMul.{u2, u1} α β (SMulZeroClass.toSMul.{u2, u1} α β (AddMonoid.toZero.{u1} β _inst_2) (DistribSMul.toSMulZeroClass.{u2, u1} α β (AddMonoid.toAddZeroClass.{u1} β _inst_2) (DistribMulAction.toDistribSMul.{u2, u1} α β _inst_1 _inst_2 _inst_3)))) r x)) (HSMul.hSMul.{u2, max u1 u3, max u3 u1} α (forall (j : I), (fun (x._@.Mathlib.GroupTheory.GroupAction.Pi._hyg.2001 : I) => β) j) (forall (i : I), (fun (x._@.Mathlib.GroupTheory.GroupAction.Pi._hyg.2001 : I) => β) i) (instHSMul.{u2, max u3 u1} α (forall (j : I), (fun (x._@.Mathlib.GroupTheory.GroupAction.Pi._hyg.2001 : I) => β) j) (Pi.instSMul.{u3, u1, u2} I α (fun (j : I) => (fun (x._@.Mathlib.GroupTheory.GroupAction.Pi._hyg.2001 : I) => β) j) (fun (i : I) => SMulZeroClass.toSMul.{u2, u1} α ((fun (x._@.Mathlib.GroupTheory.GroupAction.Pi._hyg.2001 : I) => β) i) (AddMonoid.toZero.{u1} ((fun (x._@.Mathlib.GroupTheory.GroupAction.Pi._hyg.2001 : I) => β) i) _inst_2) (DistribSMul.toSMulZeroClass.{u2, u1} α ((fun (x._@.Mathlib.GroupTheory.GroupAction.Pi._hyg.2001 : I) => β) i) (AddMonoid.toAddZeroClass.{u1} ((fun (x._@.Mathlib.GroupTheory.GroupAction.Pi._hyg.2001 : I) => β) i) _inst_2) (DistribMulAction.toDistribSMul.{u2, u1} α ((fun (x._@.Mathlib.GroupTheory.GroupAction.Pi._hyg.2001 : I) => β) i) _inst_1 _inst_2 _inst_3))))) r (Pi.single.{u3, u1} I (fun (i : I) => β) (fun (a : I) (b : I) => _inst_4 a b) (fun (i : I) => AddMonoid.toZero.{u1} ((fun (x._@.Mathlib.GroupTheory.GroupAction.Pi._hyg.2001 : I) => β) i) _inst_2) i x))
Case conversion may be inaccurate. Consider using '#align pi.single_smul' Pi.single_smul'ₓ'. -/
/-- A version of `pi.single_smul` for non-dependent functions. It is useful in cases Lean fails
to apply `pi.single_smul`. -/
theorem single_smul' {α β} [Monoid α] [AddMonoid β] [DistribMulAction α β] [DecidableEq I] (i : I)
    (r : α) (x : β) : single i (r • x) = r • single i x :=
  single_smul i r x
#align pi.single_smul' Pi.single_smul'

/- warning: pi.single_smul₀ -> Pi.single_smul₀ is a dubious translation:
lean 3 declaration is
  forall {I : Type.{u1}} {f : I -> Type.{u2}} {g : I -> Type.{u3}} [_inst_1 : forall (i : I), MonoidWithZero.{u2} (f i)] [_inst_2 : forall (i : I), AddMonoid.{u3} (g i)] [_inst_3 : forall (i : I), DistribMulAction.{u2, u3} (f i) (g i) (MonoidWithZero.toMonoid.{u2} (f i) (_inst_1 i)) (_inst_2 i)] [_inst_4 : DecidableEq.{succ u1} I] (i : I) (r : f i) (x : g i), Eq.{max (succ u1) (succ u3)} (forall (i : I), g i) (Pi.single.{u1, u3} I (fun (i : I) => g i) (fun (a : I) (b : I) => _inst_4 a b) (fun (i : I) => AddZeroClass.toHasZero.{u3} (g i) (AddMonoid.toAddZeroClass.{u3} (g i) (_inst_2 i))) i (SMul.smul.{u2, u3} (f i) (g i) (SMulZeroClass.toHasSmul.{u2, u3} (f i) (g i) (AddZeroClass.toHasZero.{u3} (g i) (AddMonoid.toAddZeroClass.{u3} (g i) (_inst_2 i))) (DistribSMul.toSmulZeroClass.{u2, u3} (f i) (g i) (AddMonoid.toAddZeroClass.{u3} (g i) (_inst_2 i)) (DistribMulAction.toDistribSMul.{u2, u3} (f i) (g i) (MonoidWithZero.toMonoid.{u2} (f i) (_inst_1 i)) (_inst_2 i) (_inst_3 i)))) r x)) (SMul.smul.{max u1 u2, max u1 u3} (forall (i : I), f i) (forall (i : I), g i) (Pi.smul'.{u1, u2, u3} I (fun (i : I) => f i) (fun (i : I) => g i) (fun (i : I) => SMulZeroClass.toHasSmul.{u2, u3} (f i) (g i) (AddZeroClass.toHasZero.{u3} (g i) (AddMonoid.toAddZeroClass.{u3} (g i) (_inst_2 i))) (DistribSMul.toSmulZeroClass.{u2, u3} (f i) (g i) (AddMonoid.toAddZeroClass.{u3} (g i) (_inst_2 i)) (DistribMulAction.toDistribSMul.{u2, u3} (f i) (g i) (MonoidWithZero.toMonoid.{u2} (f i) (_inst_1 i)) (_inst_2 i) (_inst_3 i))))) (Pi.single.{u1, u2} I (fun (i : I) => f i) (fun (a : I) (b : I) => _inst_4 a b) (fun (i : I) => MulZeroClass.toHasZero.{u2} (f i) (MulZeroOneClass.toMulZeroClass.{u2} (f i) (MonoidWithZero.toMulZeroOneClass.{u2} (f i) (_inst_1 i)))) i r) (Pi.single.{u1, u3} I (fun (i : I) => g i) (fun (a : I) (b : I) => _inst_4 a b) (fun (i : I) => AddZeroClass.toHasZero.{u3} (g i) (AddMonoid.toAddZeroClass.{u3} (g i) (_inst_2 i))) i x))
but is expected to have type
  forall {I : Type.{u2}} {f : I -> Type.{u3}} {g : I -> Type.{u1}} [_inst_1 : forall (i : I), MonoidWithZero.{u3} (f i)] [_inst_2 : forall (i : I), AddMonoid.{u1} (g i)] [_inst_3 : forall (i : I), DistribMulAction.{u3, u1} (f i) (g i) (MonoidWithZero.toMonoid.{u3} (f i) (_inst_1 i)) (_inst_2 i)] [_inst_4 : DecidableEq.{succ u2} I] (i : I) (r : f i) (x : g i), Eq.{max (succ u2) (succ u1)} (forall (i : I), g i) (Pi.single.{u2, u1} I g (fun (a : I) (b : I) => _inst_4 a b) (fun (i : I) => AddMonoid.toZero.{u1} (g i) (_inst_2 i)) i (HSMul.hSMul.{u3, u1, u1} (f i) (g i) (g i) (instHSMul.{u3, u1} (f i) (g i) (SMulZeroClass.toSMul.{u3, u1} (f i) (g i) (AddMonoid.toZero.{u1} (g i) (_inst_2 i)) (DistribSMul.toSMulZeroClass.{u3, u1} (f i) (g i) (AddMonoid.toAddZeroClass.{u1} (g i) (_inst_2 i)) (DistribMulAction.toDistribSMul.{u3, u1} (f i) (g i) (MonoidWithZero.toMonoid.{u3} (f i) (_inst_1 i)) (_inst_2 i) (_inst_3 i))))) r x)) (HSMul.hSMul.{max u3 u2, max u1 u2, max u2 u1} (forall (j : I), f j) (forall (i : I), g i) (forall (i : I), g i) (instHSMul.{max u2 u3, max u2 u1} (forall (j : I), f j) (forall (j : I), g j) (Pi.smul'.{u2, u3, u1} I (fun (j : I) => f j) (fun (j : I) => g j) (fun (i : I) => SMulZeroClass.toSMul.{u3, u1} (f i) (g i) (AddMonoid.toZero.{u1} (g i) (_inst_2 i)) (DistribSMul.toSMulZeroClass.{u3, u1} (f i) (g i) (AddMonoid.toAddZeroClass.{u1} (g i) (_inst_2 i)) (DistribMulAction.toDistribSMul.{u3, u1} (f i) (g i) (MonoidWithZero.toMonoid.{u3} (f i) (_inst_1 i)) (_inst_2 i) (_inst_3 i)))))) (Pi.single.{u2, u3} I f (fun (a : I) (b : I) => _inst_4 a b) (fun (i : I) => MonoidWithZero.toZero.{u3} (f i) (_inst_1 i)) i r) (Pi.single.{u2, u1} I g (fun (a : I) (b : I) => _inst_4 a b) (fun (i : I) => AddMonoid.toZero.{u1} (g i) (_inst_2 i)) i x))
Case conversion may be inaccurate. Consider using '#align pi.single_smul₀ Pi.single_smul₀ₓ'. -/
theorem single_smul₀ {g : I → Type _} [∀ i, MonoidWithZero (f i)] [∀ i, AddMonoid (g i)]
    [∀ i, DistribMulAction (f i) (g i)] [DecidableEq I] (i : I) (r : f i) (x : g i) :
    single i (r • x) = single i r • single i x :=
  single_op₂ (fun i : I => ((· • ·) : f i → g i → g i)) (fun j => smul_zero _) _ _ _
#align pi.single_smul₀ Pi.single_smul₀

#print Pi.mulDistribMulAction /-
instance mulDistribMulAction (α) {m : Monoid α} {n : ∀ i, Monoid <| f i}
    [∀ i, MulDistribMulAction α <| f i] :
    @MulDistribMulAction α (∀ i : I, f i) m (@Pi.monoid I f n) :=
  { Pi.mulAction _ with
    smul_one := fun c => funext fun i => smul_one _
    smul_mul := fun c f g => funext fun i => smul_mul' _ _ _ }
#align pi.mul_distrib_mul_action Pi.mulDistribMulAction
-/

#print Pi.mulDistribMulAction' /-
instance mulDistribMulAction' {g : I → Type _} {m : ∀ i, Monoid (f i)} {n : ∀ i, Monoid <| g i}
    [∀ i, MulDistribMulAction (f i) (g i)] :
    @MulDistribMulAction (∀ i, f i) (∀ i : I, g i) (@Pi.monoid I f m) (@Pi.monoid I g n)
    where
  smul_mul := by
    intros
    ext x
    apply smul_mul'
  smul_one := by
    intros
    ext x
    apply smul_one
#align pi.mul_distrib_mul_action' Pi.mulDistribMulAction'
-/

end Pi

namespace Function

#print Function.hasSMul /-
/-- Non-dependent version of `pi.has_smul`. Lean gets confused by the dependent instance if this
is not present. -/
@[to_additive
      "Non-dependent version of `pi.has_vadd`. Lean gets confused by the dependent instance\nif this is not present."]
instance hasSMul {ι R M : Type _} [SMul R M] : SMul R (ι → M) :=
  Pi.instSMul
#align function.has_smul Function.hasSMul
#align function.has_vadd Function.hasVAdd
-/

#print Function.smulCommClass /-
/-- Non-dependent version of `pi.smul_comm_class`. Lean gets confused by the dependent instance if
this is not present. -/
@[to_additive
      "Non-dependent version of `pi.vadd_comm_class`. Lean gets confused by the dependent\ninstance if this is not present."]
instance smulCommClass {ι α β M : Type _} [SMul α M] [SMul β M] [SMulCommClass α β M] :
    SMulCommClass α β (ι → M) :=
  Pi.smulCommClass
#align function.smul_comm_class Function.smulCommClass
#align function.vadd_comm_class Function.vaddCommClass
-/

/- warning: function.update_smul -> Function.update_smul is a dubious translation:
lean 3 declaration is
  forall {I : Type.{u1}} {f : I -> Type.{u2}} {α : Type.{u3}} [_inst_1 : forall (i : I), SMul.{u3, u2} α (f i)] [_inst_2 : DecidableEq.{succ u1} I] (c : α) (f₁ : forall (i : I), f i) (i : I) (x₁ : f i), Eq.{max (succ u1) (succ u2)} (forall (a : I), f a) (Function.update.{succ u1, succ u2} I (fun (i : I) => f i) (fun (a : I) (b : I) => _inst_2 a b) (SMul.smul.{u3, max u1 u2} α (forall (a : I), f a) (Pi.instSMul.{u1, u2, u3} I α (fun (a : I) => f a) (fun (i : I) => _inst_1 i)) c f₁) i (SMul.smul.{u3, u2} α (f i) (_inst_1 i) c x₁)) (SMul.smul.{u3, max u1 u2} α (forall (a : I), f a) (Pi.instSMul.{u1, u2, u3} I α (fun (a : I) => f a) (fun (i : I) => _inst_1 i)) c (Function.update.{succ u1, succ u2} I (fun (a : I) => f a) (fun (a : I) (b : I) => _inst_2 a b) f₁ i x₁))
but is expected to have type
  forall {I : Type.{u2}} {f : I -> Type.{u3}} {α : Type.{u1}} [_inst_1 : forall (i : I), SMul.{u1, u3} α (f i)] [_inst_2 : DecidableEq.{succ u2} I] (c : α) (f₁ : forall (i : I), f i) (i : I) (x₁ : f i), Eq.{max (succ u2) (succ u3)} (forall (a : I), f a) (Function.update.{succ u2, succ u3} I (fun (i : I) => f i) (fun (a : I) (b : I) => _inst_2 a b) (HSMul.hSMul.{u1, max u2 u3, max u2 u3} α (forall (i : I), f i) (forall (a : I), f a) (instHSMul.{u1, max u2 u3} α (forall (i : I), f i) (Pi.instSMul.{u2, u3, u1} I α (fun (i : I) => f i) (fun (i : I) => _inst_1 i))) c f₁) i (HSMul.hSMul.{u1, u3, u3} α (f i) (f i) (instHSMul.{u1, u3} α (f i) (_inst_1 i)) c x₁)) (HSMul.hSMul.{u1, max u2 u3, max u2 u3} α (forall (a : I), f a) (forall (a : I), f a) (instHSMul.{u1, max u2 u3} α (forall (a : I), f a) (Pi.instSMul.{u2, u3, u1} I α (fun (a : I) => f a) (fun (i : I) => _inst_1 i))) c (Function.update.{succ u2, succ u3} I (fun (a : I) => f a) (fun (a : I) (b : I) => _inst_2 a b) f₁ i x₁))
Case conversion may be inaccurate. Consider using '#align function.update_smul Function.update_smulₓ'. -/
@[to_additive]
theorem update_smul {α : Type _} [∀ i, SMul α (f i)] [DecidableEq I] (c : α) (f₁ : ∀ i, f i) (i : I)
    (x₁ : f i) : update (c • f₁) i (c • x₁) = c • update f₁ i x₁ :=
  funext fun j => (apply_update (fun i => (· • ·) c) f₁ i x₁ j).symm
#align function.update_smul Function.update_smul
#align function.update_vadd Function.update_vadd

end Function

namespace Set

/- warning: set.piecewise_smul -> Set.piecewise_smul is a dubious translation:
lean 3 declaration is
  forall {I : Type.{u1}} {f : I -> Type.{u2}} {α : Type.{u3}} [_inst_1 : forall (i : I), SMul.{u3, u2} α (f i)] (s : Set.{u1} I) [_inst_2 : forall (i : I), Decidable (Membership.Mem.{u1, u1} I (Set.{u1} I) (Set.hasMem.{u1} I) i s)] (c : α) (f₁ : forall (i : I), f i) (g₁ : forall (i : I), f i), Eq.{max (succ u1) (succ u2)} (forall (i : I), f i) (Set.piecewise.{u1, succ u2} I (fun (i : I) => f i) s (SMul.smul.{u3, max u1 u2} α (forall (i : I), f i) (Pi.instSMul.{u1, u2, u3} I α (fun (i : I) => f i) (fun (i : I) => _inst_1 i)) c f₁) (SMul.smul.{u3, max u1 u2} α (forall (i : I), f i) (Pi.instSMul.{u1, u2, u3} I α (fun (i : I) => f i) (fun (i : I) => _inst_1 i)) c g₁) (fun (j : I) => _inst_2 j)) (SMul.smul.{u3, max u1 u2} α (forall (i : I), f i) (Pi.instSMul.{u1, u2, u3} I α (fun (i : I) => f i) (fun (i : I) => _inst_1 i)) c (Set.piecewise.{u1, succ u2} I (fun (i : I) => f i) s f₁ g₁ (fun (j : I) => _inst_2 j)))
but is expected to have type
  forall {I : Type.{u2}} {f : I -> Type.{u3}} {α : Type.{u1}} [_inst_1 : forall (i : I), SMul.{u1, u3} α (f i)] (s : Set.{u2} I) [_inst_2 : forall (i : I), Decidable (Membership.mem.{u2, u2} I (Set.{u2} I) (Set.instMembershipSet.{u2} I) i s)] (c : α) (f₁ : forall (i : I), f i) (g₁ : forall (i : I), f i), Eq.{max (succ u2) (succ u3)} (forall (i : I), f i) (Set.piecewise.{u2, succ u3} I (fun (i : I) => f i) s (HSMul.hSMul.{u1, max u2 u3, max u2 u3} α (forall (i : I), f i) (forall (i : I), f i) (instHSMul.{u1, max u2 u3} α (forall (i : I), f i) (Pi.instSMul.{u2, u3, u1} I α (fun (i : I) => f i) (fun (i : I) => _inst_1 i))) c f₁) (HSMul.hSMul.{u1, max u2 u3, max u2 u3} α (forall (i : I), f i) (forall (i : I), f i) (instHSMul.{u1, max u2 u3} α (forall (i : I), f i) (Pi.instSMul.{u2, u3, u1} I α (fun (i : I) => f i) (fun (i : I) => _inst_1 i))) c g₁) (fun (j : I) => _inst_2 j)) (HSMul.hSMul.{u1, max u2 u3, max u2 u3} α (forall (i : I), f i) (forall (i : I), f i) (instHSMul.{u1, max u2 u3} α (forall (i : I), f i) (Pi.instSMul.{u2, u3, u1} I α (fun (i : I) => f i) (fun (i : I) => _inst_1 i))) c (Set.piecewise.{u2, succ u3} I (fun (i : I) => f i) s f₁ g₁ (fun (j : I) => _inst_2 j)))
Case conversion may be inaccurate. Consider using '#align set.piecewise_smul Set.piecewise_smulₓ'. -/
@[to_additive]
theorem piecewise_smul {α : Type _} [∀ i, SMul α (f i)] (s : Set I) [∀ i, Decidable (i ∈ s)] (c : α)
    (f₁ g₁ : ∀ i, f i) : s.piecewise (c • f₁) (c • g₁) = c • s.piecewise f₁ g₁ :=
  s.piecewise_op _ _ fun _ => (· • ·) c
#align set.piecewise_smul Set.piecewise_smul
#align set.piecewise_vadd Set.piecewise_vadd

end Set

section Extend

/- warning: function.extend_smul -> Function.extend_smul is a dubious translation:
lean 3 declaration is
  forall {R : Type.{u1}} {α : Type.{u2}} {β : Type.{u3}} {γ : Type.{u4}} [_inst_1 : SMul.{u1, u4} R γ] (r : R) (f : α -> β) (g : α -> γ) (e : β -> γ), Eq.{max (succ u3) (succ u4)} (β -> γ) (Function.extend.{succ u2, succ u3, succ u4} α β γ f (SMul.smul.{u1, max u2 u4} R (α -> γ) (Function.hasSMul.{u2, u1, u4} α R γ _inst_1) r g) (SMul.smul.{u1, max u3 u4} R (β -> γ) (Function.hasSMul.{u3, u1, u4} β R γ _inst_1) r e)) (SMul.smul.{u1, max u3 u4} R (β -> γ) (Function.hasSMul.{u3, u1, u4} β R γ _inst_1) r (Function.extend.{succ u2, succ u3, succ u4} α β γ f g e))
but is expected to have type
  forall {R : Type.{u4}} {α : Type.{u3}} {β : Type.{u2}} {γ : Type.{u1}} [_inst_1 : SMul.{u4, u1} R γ] (r : R) (f : α -> β) (g : α -> γ) (e : β -> γ), Eq.{max (succ u2) (succ u1)} (β -> γ) (Function.extend.{succ u3, succ u2, succ u1} α β γ f (HSMul.hSMul.{u4, max u3 u1, max u3 u1} R (α -> γ) (α -> γ) (instHSMul.{u4, max u3 u1} R (α -> γ) (Pi.instSMul.{u3, u1, u4} α R (fun (a._@.Mathlib.GroupTheory.GroupAction.Pi._hyg.2657 : α) => γ) (fun (i : α) => _inst_1))) r g) (HSMul.hSMul.{u4, max u2 u1, max u2 u1} R (β -> γ) (β -> γ) (instHSMul.{u4, max u2 u1} R (β -> γ) (Pi.instSMul.{u2, u1, u4} β R (fun (a._@.Mathlib.GroupTheory.GroupAction.Pi._hyg.2660 : β) => γ) (fun (i : β) => _inst_1))) r e)) (HSMul.hSMul.{u4, max u2 u1, max u2 u1} R (β -> γ) (β -> γ) (instHSMul.{u4, max u2 u1} R (β -> γ) (Pi.instSMul.{u2, u1, u4} β R (fun (a._@.Mathlib.Logic.Function.Basic._hyg.7460 : β) => γ) (fun (i : β) => _inst_1))) r (Function.extend.{succ u3, succ u2, succ u1} α β γ f g e))
Case conversion may be inaccurate. Consider using '#align function.extend_smul Function.extend_smulₓ'. -/
@[to_additive]
theorem Function.extend_smul {R α β γ : Type _} [SMul R γ] (r : R) (f : α → β) (g : α → γ)
    (e : β → γ) : Function.extend f (r • g) (r • e) = r • Function.extend f g e :=
  funext fun _ => by convert(apply_dite ((· • ·) r) _ _ _).symm
#align function.extend_smul Function.extend_smul
#align function.extend_vadd Function.extend_vadd

end Extend


/- Global environments are a component of the dynamic semantics of
  all languages involved in the compiler.  A global environment
  maps symbol names (names of functions and of global variables)
  to the corresponding memory addresses.  It also maps memory addresses
  of functions to the corresponding function descriptions.

  Global environments, along with the initial memory state at the beginning
  of program execution, are built from the program of interest, as follows:
- A distinct memory address is assigned to each function of the program.
  These function addresses use negative numbers to distinguish them from
  addresses of memory blocks.  The associations of function name to function
  address and function address to function description are recorded in
  the global environment.
- For each global variable, a memory block is allocated and associated to
  the name of the variable.

  These operations reflect (at a high level of abstraction) what takes
  place during program linking and program loading in a real operating
  system. -/

import .memory .linking

namespace globalenvs
open memdata memory values ast integers maps linking errors
     memdata.memval word floats memdata.quantity memory.perm_kind
     ast.memory_chunk

/- Auxiliary function for initialization of global variables. -/

def store_zeros : mem → block → ℕ → ℕ → option mem
| m b p 0     := some m
| m b p (n+1) := do m' ← store Mint8unsigned m b p Vzero, store_zeros m' b (p + 1) n

/- * Symbol environments -/

/- Symbol environments are a restricted view of global environments,
  focusing on symbol names and their associated blocks.  They do not
  contain mappings from blocks to function or variable definitions. -/

structure Senv : Type :=
(find_symbol : ident → option block)
(public_symbol : ident → bool)
(invert_symbol : block → option ident)
(block_is_volatile : block → bool)
(nextblock : block)
  /- Properties -/
(find_symbol_injective : ∀ {id1 id2 b}, find_symbol id1 = some b → find_symbol id2 = some b → id1 = id2)
(invert_find_symbol : ∀ {id b}, invert_symbol b = some id → find_symbol id = some b)
(find_invert_symbol : ∀ {id b}, find_symbol id = some b → invert_symbol b = some id)
(public_symbol_exists : ∀ {id}, public_symbol id → ∃ b, find_symbol id = some b)
(find_symbol_below : ∀ {id b}, find_symbol id = some b → b < nextblock)
(block_is_volatile_below : ∀ {b}, block_is_volatile b → b < nextblock)

namespace Senv

def symbol_address (ge : Senv) (id : ident) (ofs : ptrofs) : val :=
  match find_symbol ge id with
| some b := Vptr b ofs
| none := Vundef
  end

theorem shift_symbol_address {ge id ofs delta} :
  symbol_address ge id (ofs + delta) = val.offset_ptr (symbol_address ge id ofs) delta := sorry'

theorem shift_symbol_address_32 {ge id ofs n} : ¬ archi.ptr64 →
  symbol_address ge id (ofs + ptrofs.of_int n) = symbol_address ge id ofs + n := sorry'

theorem shift_symbol_address_64 {ge id ofs n} : archi.ptr64 →
  symbol_address ge id (ofs + ptrofs.of_int64 n) = (symbol_address ge id ofs).addl n := sorry'

def equiv (se1 se2 : Senv) : Prop :=
     (∀ id, find_symbol se2 id = find_symbol se1 id)
  ∧ (∀ id, public_symbol se2 id = public_symbol se1 id)
  ∧ (∀ b, block_is_volatile se2 b = block_is_volatile se1 b)

end Senv

/- * Global environments -/

/- The type of global environments. -/

structure Genv (F V : Type) : Type :=
(public : list ident)              /- which symbol names are public -/
(symb : PTree block)             /- mapping symbol -> block -/
(defs : PTree (globdef F V))     /- mapping block -> definition -/
(next : block)                     /- next symbol pointer -/
(symb_range : ∀ {id b}, PTree.get id symb = some b → b < next)
(defs_range : ∀ {b g}, PTree.get b defs = some g → b < next)
(vars_inj : ∀ {id1 id2 b},
    PTree.get id1 symb = some b → PTree.get id2 symb = some b → id1 = id2)

namespace Genv
section

variable {F : Type}  /- The type of function descriptions -/
variable {V : Type}  /- The type of information attached to variables -/

/- ** Lookup functions -/

/- [find_symbol ge id] returns the block associated with the given name, if any -/

def find_symbol (ge : Genv F V) (id : ident) : option block :=
  PTree.get id ge.symb

/- [symbol_address ge id ofs] returns a pointer into the block associated
  with [id], at byte offset [ofs].  [Vundef] is returned if no block is associated
  to [id]. -/

def symbol_address (ge : Genv F V) (id : ident) (ofs : ptrofs) : val :=
  match find_symbol ge id with
| some b := Vptr b ofs
| none := Vundef
  end

/- [public_symbol ge id] says whether the name [id] is public and defined. -/

def public_symbol (ge : Genv F V) (id : ident) : bool :=
(find_symbol ge id).is_some && (id ∈ ge.public)

/- [find_def ge b] returns the global definition associated with the given address. -/

def find_def (ge : Genv F V) (b : block) : option (globdef F V) :=
PTree.get b ge.defs

/- [find_funct_ptr ge b] returns the function description associated with
    the given address. -/

def find_funct_ptr (ge : Genv F V) (b : block) : option F :=
match find_def ge b with some (Gfun f) := some f | _ := none end

/- [find_funct] is similar to [find_funct_ptr], but the function address
    is given as a value, which must be a pointer with offset 0. -/

def find_funct (ge : Genv F V) : val → option F
| (Vptr b ofs) := if ofs = 0 then find_funct_ptr ge b else none
| _ := none

/- [invert_symbol ge b] returns the name associated with the given block, if any -/

def invert_symbol (ge : Genv F V) (b : block) : option ident :=
PTree.fold
  (λ res id b', if b = b' then some id else res)
  ge.symb none

/- [find_var_info ge b] returns the information attached to the variable
   at address [b]. -/

def find_var_info (ge : Genv F V) (b : block) : option (globvar V) :=
match find_def ge b with some (Gvar v) := some v | _ := none end

/- [block_is_volatile ge b] returns [true] if [b] points to a global variable
  of volatile type, [false] otherwise. -/

def block_is_volatile (ge : Genv F V) (b : block) : bool :=
match find_var_info ge b with
| none := ff
| some gv := gv.volatile
end

/- ** Constructing the global environment -/

def add_global (ge : Genv F V) : ident × globdef F V → Genv F V | (id, g) :=
{ public := ge.public,
  symb := PTree.set id ge.next ge.symb,
  defs := PTree.set ge.next g ge.defs,
  next := ge.next.succ,
  symb_range := λid' b h, show (_:ℕ)<_, begin
    rw pos_num.succ_to_nat,
    apply nat.lt_succ_of_le,
    rw PTree.gsspec at h,
    by_cases id' = id with ii; simp [ii] at h,
    { injection h, rw h },
    { exact le_of_lt (ge.symb_range h) }
  end,
  defs_range := λb g' h, show (_:ℕ)<_, begin
    rw pos_num.succ_to_nat,
    apply nat.lt_succ_of_le,
    rw PTree.gsspec at h,
    by_cases b = ge.next with bb,
    { rw bb },
    { simp [bb] at h, exact le_of_lt (ge.defs_range h) }
  end,
  vars_inj := λid1 id2 b h1 h2, begin
    rw PTree.gsspec at h1 h2,
    by_cases id1 = id with i1; simp [i1] at h1;
    by_cases id2 = id with i2; simp [i2] at h2; try {simp [i1, i2]},
    { rw -h1 at h2, exact absurd (ge.symb_range h2) (lt_irrefl _) },
    { rw -h2 at h1, exact absurd (ge.symb_range h1) (lt_irrefl _) },
    { exact ge.vars_inj h1 h2 },
  end }

def add_globals (ge : Genv F V) (gl : list (ident × globdef F V)) : Genv F V :=
gl.foldl add_global ge

lemma add_globals_app (ge : Genv F V) (gl2 gl1) :
  add_globals ge (gl1 ++ gl2) = add_globals (add_globals ge gl1) gl2 := sorry'

def empty (pub : list ident) : Genv F V :=
{ public := pub,
  symb := ∅,
  defs := ∅,
  next := 1,
  symb_range := λid' b h, by rw PTree.gempty at h; contradiction,
  defs_range := λb g' h, by rw PTree.gempty at h; contradiction,
  vars_inj := λid1 id2 b h, by rw PTree.gempty at h; contradiction }

def globalenv (p : program F V) : Genv F V := add_globals (empty p.public) p.defs

/- Proof principles -/

section globalenv_principles

variable P : Genv F V → Prop
include P

lemma add_globals_preserves {gl ge} :
  (∀ ge id g, P ge → (id, g) ∈ gl → P (add_global ge (id, g))) →
  P ge → P (add_globals ge gl) := sorry'

lemma add_globals_ensures {id g gl ge} :
  (∀ ge id g, P ge → (id, g) ∈ gl → P (add_global ge (id, g))) →
  (∀ ge, P (add_global ge (id, g))) →
  (id, g) ∈ gl → P (add_globals ge gl) := sorry'

lemma add_globals_unique_preserves {id gl ge} :
  (∀ ge id1 g, P ge → (id1, g) ∈ gl → id1 ≠ id → P (add_global ge (id1, g))) →
  id ∉ list.map prod.fst gl → P ge → P (add_globals ge gl) := sorry'

lemma add_globals_unique_ensures {gl1 id g gl2 ge} :
  (∀ ge id1 g1, P ge → (id1, g1) ∈ gl2 → id1 ≠ id → P (add_global ge (id1, g1))) →
  (∀ ge, P (add_global ge (id, g))) →
  id ∉ list.map prod.fst gl2 → P (add_globals ge (gl1 ++ (id, g) :: gl2)) := sorry'

theorem in_norepet_unique {id g} {gl : list (ident × globdef F V)} :
  (id, g) ∈ gl → (gl.map prod.fst).nodup →
  ∃ gl1 gl2, gl = gl1 ++ (id, g) :: gl2 ∧ id ∈ gl2.map prod.fst := sorry'

lemma add_globals_norepet_ensures {id g gl ge} :
  (∀ ge id1 g1, P ge → (id1, g1) ∈ gl → id1 ≠ id → P (add_global ge (id1, g1))) →
  (∀ ge, P (add_global ge (id, g))) →
  (id, g) ∈ gl → (list.map prod.fst gl).nodup → P (add_globals ge gl) := sorry'

end globalenv_principles

/- ** Properties of the operations over global environments -/

theorem public_symbol_exists {ge : Genv F V} {id} :
  public_symbol ge id → ∃ b, find_symbol ge id = some b := sorry'

theorem shift_symbol_address {ge : Genv F V} {id ofs delta} :
  symbol_address ge id (ofs + delta) = (symbol_address ge id ofs).offset_ptr delta := sorry'

theorem shift_symbol_address_32 {ge : Genv F V} {id ofs n} :
  ¬ archi.ptr64 →
  symbol_address ge id (ofs + ptrofs.of_int n) = symbol_address ge id ofs + n := sorry'

theorem shift_symbol_address_64 {ge : Genv F V} {id ofs n} :
  archi.ptr64 →
  symbol_address ge id (ofs + ptrofs.of_int64 n) = (symbol_address ge id ofs).addl n := sorry'

theorem find_funct_inv {ge : Genv F V} {v f} :
  find_funct ge v = some f → ∃ b, v = Vptr b 0 := sorry'

theorem find_funct_find_funct_ptr {ge : Genv F V} {b} :
  find_funct ge (Vptr b 0) = find_funct_ptr ge b := sorry'

theorem find_funct_ptr_iff {ge : Genv F V} {b f} :
  find_funct_ptr ge b = some f ↔ find_def ge b = some (Gfun f) := sorry'

theorem find_var_info_iff {ge : Genv F V} {b v} :
  find_var_info ge b = some v ↔ find_def ge b = some (Gvar v) := sorry'

theorem find_def_symbol {p : program F V} {id g} :
  (prog_defmap p^!id) = some g ↔
  ∃ b, find_symbol (globalenv p) id = some b ∧
       find_def (globalenv p) b = some g := sorry'

theorem find_symbol_exists {p : program F V} {id g} :
  (id, g) ∈ p.defs →
  ∃ b, find_symbol (globalenv p) id = some b := sorry'

theorem find_symbol_inversion {p : program F V} {x b} :
  find_symbol (globalenv p) x = some b →
  x ∈ p.defs_names := sorry'

theorem find_def_inversion {p : program F V} {b g} :
  find_def (globalenv p) b = some g →
  ∃ id, (id, g) ∈ p.defs := sorry'

theorem find_funct_ptr_inversion {p : program F V} {b f} :
  find_funct_ptr (globalenv p) b = some f →
  ∃ id, (id, Gfun f) ∈ p.defs := sorry'

theorem find_funct_inversion {p : program F V} {v f} :
  find_funct (globalenv p) v = some f →
  ∃ id, (id, Gfun f) ∈ p.defs := sorry'

theorem find_funct_ptr_prop (P : F → Prop) {p : program F V} {b f} :
  (∀ id f, (id, Gfun f) ∈ p.defs → P f) →
  find_funct_ptr (globalenv p) b = some f →
  P f := sorry'

theorem find_funct_prop (P : F → Prop) {p : program F V} {v f} :
  (∀ id f, (id, Gfun f) ∈ p.defs → P f) →
  find_funct (globalenv p) v = some f →
  P f := sorry'

theorem global_addresses_distinct {ge : Genv F V} {id1 id2 b1 b2} :
  id1 ≠ id2 →
  find_symbol ge id1 = some b1 →
  find_symbol ge id2 = some b2 →
  b1 ≠ b2 := sorry'

theorem invert_find_symbol {ge : Genv F V} {id b} :
  invert_symbol ge b = some id → find_symbol ge id = some b := sorry'

theorem find_invert_symbol {ge : Genv F V} {id b} :
  find_symbol ge id = some b → invert_symbol ge b = some id := sorry'

def advance_next (gl : list (ident × globdef F V)) (x : pos_num) :=
gl.foldl (λ n g, pos_num.succ n) x

theorem genv_next_add_globals (gl) (ge : Genv F V) :
  (add_globals ge gl).next = advance_next gl ge.next := sorry'

theorem genv_public_add_globals (gl) (ge : Genv F V) :
  (add_globals ge gl).public = ge.public := sorry'

theorem globalenv_public (p : program F V) :
  (globalenv p).public = p.public := sorry'

theorem block_is_volatile_below {ge : Genv F V} {b} :
  block_is_volatile ge b → b < ge.next := sorry'

/- ** Coercing a global environment into a symbol environment -/

def to_senv (ge : Genv F V) : Senv :=
{ find_symbol := ge.find_symbol,
  public_symbol := ge.public_symbol,
  invert_symbol := ge.invert_symbol,
  block_is_volatile := ge.block_is_volatile,
  nextblock := ge.next,
  find_symbol_injective := ge.vars_inj,
  invert_find_symbol := ge.invert_find_symbol,
  find_invert_symbol := ge.find_invert_symbol,
  public_symbol_exists := ge.public_symbol_exists,
  find_symbol_below := ge.symb_range,
  block_is_volatile_below := ge.block_is_volatile_below }

instance : has_coe (Genv F V) Senv := ⟨to_senv⟩

/- * Construction of the initial memory state -/

section init_mem

variable ge : Genv F V

def store_init_data (m : mem) (b : block) (p : ℕ) : init_data → option mem
| (init_data.int8 n) := store Mint8unsigned m b p (Vint n)
| (init_data.int16 n) := store Mint16unsigned m b p (Vint n)
| (init_data.int32 n) := store Mint32 m b p (Vint n)
| (init_data.int64 n) := store Mint64 m b p (Vlong n)
| (init_data.float32 n) := store Mfloat32 m b p (Vsingle n)
| (init_data.float64 n) := store Mfloat64 m b p (Vfloat n)
| (init_data.addrof symb ofs) :=
  do b' ← find_symbol ge symb, store Mptr m b p (Vptr b' ofs)
| (init_data.space n) := some m

def store_init_data_list : mem → block → ℕ → list init_data → option mem
| m b p [] := some m
| m b p (id :: idl') :=
  do m' ← store_init_data ge m b p id,
     store_init_data_list m' b (p + id.size) idl'

def perm_globvar (gv : globvar V) : permission :=
  if gv.volatile then Nonempty
  else if gv.readonly then Readable
  else Writable

def alloc_global (m : mem) : ident × globdef F V → option mem
| (id, Gfun f) :=
  drop_perm (m.alloc 0 1) m.nextblock 0 1 Nonempty
| (id, Gvar v) := do
  let init := v.init,
  let sz := init_data.list_size init,
  let b := m.nextblock,
  let m1 := m.alloc 0 sz,
  m2 ← store_zeros m1 b 0 sz,
  m3 ← store_init_data_list ge m2 b 0 init,
  drop_perm m3 b 0 sz (perm_globvar v)

def alloc_globals : mem → list (ident × globdef F V) → option mem :=
mfoldl (alloc_global ge)

lemma alloc_globals_app {gl1 gl2 m m1} :
  alloc_globals ge m gl1 = some m1 →
  alloc_globals ge m1 gl2 = alloc_globals ge m (gl1 ++ gl2) := sorry'

/- Next-block properties -/

theorem store_zeros_nextblock {m b p n m'} : store_zeros m b p n = some m' →
  m'.nextblock = m.nextblock := sorry'

theorem store_init_data_list_nextblock {idl b m p m'} :
  store_init_data_list ge m b p idl = some m' →
  m'.nextblock = m.nextblock := sorry'

theorem alloc_global_nextblock {g m m'} :
  alloc_global ge m g = some m' →
  m'.nextblock = m.nextblock.succ := sorry'

theorem alloc_globals_nextblock {gl m m'} :
  alloc_globals ge m gl = some m' →
  m'.nextblock = advance_next gl m.nextblock := sorry'

/- Permissions -/

theorem store_zeros_perm {k prm b' q m b p n m'} :
  store_zeros m b p n = some m' →
  (perm m b' q k prm ↔ perm m' b' q k prm) := sorry'

theorem store_init_data_perm {k prm b' q i b m p m'} :
  store_init_data ge m b p i = some m' →
  (perm m b' q k prm ↔ perm m' b' q k prm) := sorry'

theorem store_init_data_list_perm {k prm b' q idl b m p m'} :
  store_init_data_list ge m b p idl = some m' →
  (perm m b' q k prm ↔ perm m' b' q k prm) := sorry'

theorem alloc_global_perm {k prm b' q idg m m'} :
  alloc_global ge m idg = some m' →
  valid_block m b' →
  (perm m b' q k prm ↔ perm m' b' q k prm) := sorry'

theorem alloc_globals_perm {k prm b' q gl m m'} :
  alloc_globals ge m gl = some m' →
  valid_block m b' →
  (perm m b' q k prm ↔ perm m' b' q k prm) := sorry'

/- Data preservation properties -/

theorem store_zeros_unchanged {P : block → ℕ → Prop} {m b p n m'} :
  store_zeros m b p n = some m' →
  (∀ i, p ≤ i → i < p + n → ¬ P b i) →
  unchanged_on P m m' := sorry'

theorem store_init_data_unchanged {P : block → ℕ → Prop} {b i m p m'} :
  store_init_data ge m b p i = some m' →
  (∀ ofs, p ≤ ofs → ofs < p + i.size → ¬ P b ofs) →
  unchanged_on P m m' := sorry'

theorem store_init_data_list_unchanged {P : block → ℕ → Prop} {b il m p m'} :
  store_init_data_list ge m b p il = some m' →
  (∀ ofs, p ≤ ofs → ¬ P b ofs) →
  unchanged_on P m m' := sorry'

/- Properties related to [load_bytes] -/

def readbytes_as_zero (m : mem) (b : block) (ofs len : ℕ) : Prop :=
  ∀ p n,
  ofs ≤ p → p + n ≤ ofs + len →
  load_bytes m b p n = some (list.repeat (Byte 0) n)

lemma store_zeros_load_bytes {m b p n m'} :
  store_zeros m b p n = some m' →
  readbytes_as_zero m' b p n := sorry'

def bytes_of_init_data (i : init_data) : list memval :=
  match i with
| (init_data.int8 n) := inj_bytes (encode_int 1 (unsigned n))
| (init_data.int16 n) := inj_bytes (encode_int 2 (unsigned n))
| (init_data.int32 n) := inj_bytes (encode_int 4 (unsigned n))
| (init_data.int64 n) := inj_bytes (encode_int 8 (unsigned n))
| (init_data.float32 n) := inj_bytes (encode_int 4 (unsigned (float32.to_bits n)))
| (init_data.float64 n) := inj_bytes (encode_int 8 (unsigned (float.to_bits n)))
| (init_data.space n) := list.repeat (Byte 0) n
| (init_data.addrof id ofs) :=
      match find_symbol ge id with
      | some b := inj_value (if archi.ptr64 then Q64 else Q32) (Vptr b ofs)
      | none   := list.repeat Undef (if archi.ptr64 then 8 else 4)
      end
  end

theorem init_data_size_addrof {id ofs} :
  (init_data.addrof id ofs).size = (Mptr).size := sorry'

lemma store_init_data_load_bytes {m b p i m'} :
  store_init_data ge m b p i = some m' →
  readbytes_as_zero m b p i.size →
  load_bytes m' b p i.size = some (bytes_of_init_data ge i) := sorry'

def bytes_of_init_data_list (il : list init_data) : list memval :=
il >>= bytes_of_init_data ge

lemma store_init_data_list_load_bytes {b il m p m'} :
  store_init_data_list ge m b p il = some m' →
  readbytes_as_zero m b p (init_data.list_size il) →
  load_bytes m' b p (init_data.list_size il) =
    some (bytes_of_init_data_list ge il) := sorry'

/- Properties related to [load] -/

def chunk_zero_val : memory_chunk → val
| Mint8unsigned  := Vint 0
| Mint8signed    := Vint 0
| Mint16unsigned := Vint 0
| Mint16signed   := Vint 0
| Mint32         := Vint 0
| Mint64         := Vlong 0
| Mfloat32       := Vsingle 0
| Mfloat64       := Vfloat 0
| Many32         := Vundef
| Many64         := Vundef

def read_as_zero (m : mem) (b : block) (ofs len : ℕ) : Prop :=
∀ (chunk : memory_chunk) p,
  ofs ≤ p → p + chunk.size ≤ ofs + len →
  chunk.align ∣ p →
  load chunk m b p =
  some (chunk_zero_val chunk)

theorem read_as_zero_unchanged {P : block → ℕ → Prop} {m b ofs len m'} :
  read_as_zero m b ofs len →
  unchanged_on P m m' →
  (∀ i, ofs ≤ i → i < ofs + len → P b i) →
  read_as_zero m' b ofs len := sorry'

lemma store_zeros_read_as_zero {m b p n m'} :
  store_zeros m b p n = some m' →
  read_as_zero m' b p n := sorry'

def load_store_init_data (m : mem) (b : block) : ℕ → list init_data → Prop
| p [] := true
| p (init_data.int8 n :: il') :=
  load Mint8unsigned m b p = some (Vint (zero_ext 8 n))
  ∧ load_store_init_data (p + 1) il'
| p (init_data.int16 n :: il') :=
  load Mint16unsigned m b p = some (Vint (zero_ext 16 n))
  ∧ load_store_init_data (p + 2) il'
| p (init_data.int32 n :: il') :=
  load Mint32 m b p = some (Vint n)
  ∧ load_store_init_data (p + 4) il'
| p (init_data.int64 n :: il') :=
  load Mint64 m b p = some (Vlong n)
  ∧ load_store_init_data (p + 8) il'
| p (init_data.float32 n :: il') :=
  load Mfloat32 m b p = some (Vsingle n)
  ∧ load_store_init_data (p + 4) il'
| p (init_data.float64 n :: il') :=
  load Mfloat64 m b p = some (Vfloat n)
  ∧ load_store_init_data (p + 8) il'
| p (init_data.addrof symb ofs :: il') :=
  (∃ b', find_symbol ge symb = some b' ∧ load Mptr m b p = some (Vptr b' ofs))
  ∧ load_store_init_data (p + (Mptr).size) il'
| p (init_data.space n :: il') :=
  read_as_zero m b p n
  ∧ load_store_init_data (p + n) il'

lemma store_init_data_list_charact {b il m p m'} :
  store_init_data_list ge m b p il = some m' →
  read_as_zero m b p (init_data.list_size il) →
  load_store_init_data ge m' b p il := sorry'

theorem alloc_global_unchanged {P : block → ℕ → Prop} {m id g m'} :
  alloc_global ge m (id, g) = some m' →
  unchanged_on P m m' := sorry'

theorem alloc_globals_unchanged {P : block → ℕ → Prop} {gl m m'} :
  alloc_globals ge m gl = some m' →
  unchanged_on P m m' := sorry'

theorem load_store_init_data_invariant {m m' b} :
  (∀ chunk ofs, load chunk m' b ofs = load chunk m b ofs) →
  ∀ il p,
  load_store_init_data ge m b p il → load_store_init_data ge m' b p il := sorry'

def globdef_initialized (m : mem) (b : block) : globdef F V → Prop
| (Gfun f) :=
         perm m b 0 Cur Nonempty
      ∧ (∀ ofs k p, perm m b ofs k p → ofs = 0 ∧ p = Nonempty)
| (Gvar v) :=
         range_perm m b 0 (init_data.list_size v.init) Cur (perm_globvar v)
      ∧ (∀ ofs k p, perm m b ofs k p →
            ofs < init_data.list_size v.init ∧ perm_order (perm_globvar v) p)
      ∧ (¬ v.volatile → load_store_init_data ge m b 0 v.init)
      ∧ (¬ v.volatile → load_bytes m b 0 (init_data.list_size v.init) =
                        some (bytes_of_init_data_list ge v.init))

def globals_initialized (g : Genv F V) (m : mem) :=
∀ b gd, find_def g b = some gd → globdef_initialized ge m b gd

lemma alloc_global_initialized {g : Genv F V} {m : mem} {id gd m'} :
  g.next = m.nextblock →
  alloc_global ge m (id, gd) = some m' →
  globals_initialized ge g m →
     globals_initialized ge (add_global g (id, gd)) m'
  ∧ (add_global g (id, gd)).next = m'.nextblock := sorry'

lemma alloc_globals_initialized {gl} {g : Genv F V} {m m'} :
  alloc_globals g m gl = some m' →
  g.next = m.nextblock →
  globals_initialized ge g m →
  globals_initialized ge (add_globals g gl) m' := sorry'

end init_mem

def init_mem (p : program F V) :=
alloc_globals (globalenv p) ∅ p.defs

lemma init_mem_genv_next {p : program F V} {m} :
  init_mem p = some m →
  (globalenv p).next = m.nextblock := sorry'

theorem find_symbol_not_fresh {p : program F V} {id b m} :
  init_mem p = some m →
  find_symbol (globalenv p) id = some b → valid_block m b := sorry'

theorem find_def_not_fresh {p : program F V} {b g m} :
  init_mem p = some m →
  find_def (globalenv p) b = some g → valid_block m b := sorry'

theorem find_funct_ptr_not_fresh {p : program F V} {b f m} :
  init_mem p = some m →
  find_funct_ptr (globalenv p) b = some f → valid_block m b := sorry'

theorem find_var_info_not_fresh {p : program F V} {b gv m} :
  init_mem p = some m →
  find_var_info (globalenv p) b = some gv → valid_block m b := sorry'

lemma init_mem_characterization_gen {p : program F V} {m} :
  init_mem p = some m →
  globals_initialized (globalenv p) (globalenv p) m := sorry'

theorem init_mem_characterization {p : program F V} {b gv m} :
  find_var_info (globalenv p) b = some gv →
  init_mem p = some m →
  range_perm m b 0 (init_data.list_size gv.init) Cur (perm_globvar gv)
  ∧ (∀ ofs k p, perm m b ofs k p →
        ofs < init_data.list_size gv.init ∧ perm_order (perm_globvar gv) p)
  ∧ (¬ gv.volatile →
      load_store_init_data (globalenv p) m b 0 gv.init)
  ∧ (¬ gv.volatile →
      load_bytes m b 0 (init_data.list_size gv.init) =
      some (bytes_of_init_data_list (globalenv p) gv.init)) := sorry'

theorem init_mem_characterization_2 {p : program F V} {b fd m} :
  find_funct_ptr (globalenv p) b = some fd →
  init_mem p = some m →
  perm m b 0 Cur Nonempty
  ∧ (∀ ofs k p, perm m b ofs k p → ofs = 0 ∧ p = Nonempty) := sorry'

/- ** Compatibility with memory injections -/

section init_mem_inj

variable {ge : Genv F V}
variable {thr : block}
variable (symb_inject : ∀ id b, find_symbol ge id = some b → b < thr)
include symb_inject

lemma store_zeros_neutral {m b p n m'} :
  inject_neutral thr m →
  b < thr →
  store_zeros m b p n = some m' →
  inject_neutral thr m' := sorry'

lemma store_init_data_neutral {m b p id m'} :
  inject_neutral thr m →
  b < thr →
  store_init_data ge m b p id = some m' →
  inject_neutral thr m' := sorry'

lemma store_init_data_list_neutral {b idl m p m'} :
  inject_neutral thr m →
  b < thr →
  store_init_data_list ge m b p idl = some m' →
  inject_neutral thr m' := sorry'

lemma alloc_global_neutral {idg m m'} :
  alloc_global ge m idg = some m' →
  inject_neutral thr m →
  m.nextblock < thr →
  inject_neutral thr m' := sorry'

theorem advance_next_le : ∀ gl x, x ≤ @advance_next F V gl x := sorry'

lemma alloc_globals_neutral {gl m m'} :
  alloc_globals ge m gl = some m' →
  inject_neutral thr m →
  m'.nextblock ≤ thr →
  inject_neutral thr m' := sorry'

end init_mem_inj

theorem initmem_inject {p : program F V} {m} :
  init_mem p = some m →
  inject (flat_inj m.nextblock) m m := sorry'

/- ** Sufficient and necessary conditions for the initial memory to exist. -/

/- Alignment properties -/

section init_mem_inversion

variable (ge : Genv F V)

lemma store_init_data_aligned {m b p i m'} :
  store_init_data ge m b p i = some m' →
  i.align ∣ p := sorry'

lemma store_init_data_list_aligned {b il m p m'} :
  store_init_data_list ge m b p il = some m' →
  init_data.list_aligned p il := sorry'

lemma store_init_data_list_free_idents {b i o il m p m'} :
  store_init_data_list ge m b p il = some m' →
  init_data.addrof i o ∈ il →
  ∃ b', find_symbol ge i = some b' := sorry'

end init_mem_inversion

theorem init_mem_inversion {p : program F V} {m id v} :
  init_mem p = some m →
  (id, Gvar v) ∈ p.defs →
  init_data.list_aligned 0 v.init
  ∧ ∀ i o, init_data.addrof i o ∈ v.init →
    ∃ b, find_symbol (globalenv p) i = some b := sorry'

section init_mem_exists

variable (ge : Genv F V)

lemma store_zeros_exists {m b p n} :
  range_perm m b p (p + n) Cur Writable →
  ∃ m', store_zeros m b p n = some m' := sorry'

lemma store_init_data_exists {m b p} {i : init_data} :
  range_perm m b p (p + i.size) Cur Writable →
  i.align ∣ p →
  (∀ id ofs, i = init_data.addrof id ofs → ∃ b, find_symbol ge id = some b) →
  ∃ m', store_init_data ge m b p i = some m' := sorry'

lemma store_init_data_list_exists {b il m p} :
  range_perm m b p (p + init_data.list_size il) Cur Writable →
  init_data.list_aligned p il →
  (∀ id ofs, init_data.addrof id ofs ∈ il → ∃ b, find_symbol ge id = some b) →
  ∃ m', store_init_data_list ge m b p il = some m' := sorry'

def alloc_global_exists_ty : globdef F V → Prop
| (Gfun f) := true
| (Gvar v) := init_data.list_aligned 0 v.init
     ∧ ∀ i o, init_data.addrof i o ∈ v.init → ∃ b, find_symbol ge i = some b

lemma alloc_global_exists {m id g} :
  alloc_global_exists_ty ge g →
  ∃ m', alloc_global ge m (id, g) = some m' := sorry'

end init_mem_exists

theorem init_mem_exists {p : program F V} :
  (∀ id v, (id, Gvar v) ∈ p.defs →
        init_data.list_aligned 0 v.init
     ∧ ∀ i o, init_data.addrof i o ∈ v.init →
        ∃ b, find_symbol (globalenv p) i = some b) →
  ∃ m, init_mem p = some m := sorry'

end

/- * Commutation with program transformations -/

section match_genvs

parameters {A B V W : Type} (R : globdef A V → globdef B W → Prop)

structure match_genvs (ge1 : Genv A V) (ge2 : Genv B W) : Prop :=
(next : ge2.next = ge1.next)
(symb : ∀ id, PTree.get id ge2.symb = PTree.get id ge1.symb)
(defs : ∀ b, option.rel R (PTree.get b ge1.defs) (PTree.get b ge2.defs))

lemma add_global_match {ge1 ge2 id g1 g2} :
  match_genvs ge1 ge2 →
  R g1 g2 →
  match_genvs (ge1.add_global (id, g1)) (ge2.add_global (id, g2)) := sorry'

lemma add_globals_match {gl1 gl2} :
  list.forall2 (λ ⟨id1, g1⟩ ⟨id2, g2⟩, id1 = id2 ∧ R g1 g2 :
    (ident × globdef A V) → (ident × globdef B W) → Prop) gl1 gl2 →
  ∀ {ge1 ge2}, match_genvs ge1 ge2 →
  match_genvs (ge1.add_globals gl1) (ge2.add_globals gl2) := sorry'

end match_genvs

section match_programs

parameters {C F1 V1 F2 V2 : Type} [linker C] [linker F1] [linker V1]
parameter {match_fundef : C → F1 → F2 → Prop}
parameter {match_varinfo : V1 → V2 → Prop}
parameter {ctx : C}
parameter {p : program F1 V1}
parameter {tp : program F2 V2}
parameter (progmatch : match_program_gen match_fundef match_varinfo ctx p tp)

lemma globalenvs_match : match_genvs (match_globdef match_fundef match_varinfo ctx)
  (globalenv p) (globalenv tp) := sorry'

theorem find_def_match_2 {b} : option.rel (match_globdef match_fundef match_varinfo ctx)
  (find_def (globalenv p) b) (find_def (globalenv tp) b) := sorry'

theorem find_funct_ptr_match {b f} : find_funct_ptr (globalenv p) b = some f →
  ∃ cunit tf, find_funct_ptr (globalenv tp) b = some tf ∧ match_fundef cunit f tf ∧
    linkorder cunit ctx := sorry'

theorem find_funct_match {v f} : find_funct (globalenv p) v = some f →
  ∃ cunit tf, find_funct (globalenv tp) v = some tf ∧ match_fundef cunit f tf ∧
    linkorder cunit ctx := sorry'

theorem find_var_info_match {b v} : find_var_info (globalenv p) b = some v →
  ∃ tv, find_var_info (globalenv tp) b = some tv ∧ match_globvar match_varinfo v tv := sorry'

theorem find_symbol_match {s : ident} :
  find_symbol (globalenv tp) s = find_symbol (globalenv p) s := sorry'

theorem senv_match : Senv.equiv (globalenv p) (globalenv tp) := sorry'

lemma store_init_data_list_match {idl m b ofs m'} :
  store_init_data_list (globalenv p) m b ofs idl = some m' →
  store_init_data_list (globalenv tp) m b ofs idl = some m' := sorry'

lemma alloc_globals_match {gl1 gl2} :
  list.forall2 (match_ident_globdef match_fundef match_varinfo ctx) gl1 gl2 →
  ∀ m m', alloc_globals (globalenv p) m gl1 = some m' →
  alloc_globals (globalenv tp) m gl2 = some m' := sorry'

theorem init_mem_match {m} : init_mem p = some m → init_mem tp = some m := sorry'

end match_programs

/- Special case for partial transformations that do not depend on the compilation unit -/

section transform_partial

parameters {A B V : Type} [linker A] [linker V]
parameters {transf : A → res B} {p : program A V} {tp : program B V}
parameter (progmatch : match_program (λ cu f tf, transf f = OK tf) eq p tp)

theorem find_funct_ptr_transf_partial {b f} : find_funct_ptr (globalenv p) b = some f →
  ∃ tf, find_funct_ptr (globalenv tp) b = some tf ∧ transf f = OK tf := sorry'

theorem find_funct_transf_partial {v f} : find_funct (globalenv p) v = some f →
  ∃ tf, find_funct (globalenv tp) v = some tf ∧ transf f = OK tf := sorry'

theorem find_symbol_transf_partial {s : ident} :
  find_symbol (globalenv tp) s = find_symbol (globalenv p) s := sorry'

theorem senv_transf_partial : Senv.equiv (globalenv p) (globalenv tp) := sorry'

theorem init_mem_transf_partial {m} : init_mem p = some m → init_mem tp = some m := sorry'

end transform_partial

/- Special case for total transformations that do not depend on the compilation unit -/

section transform_total

parameters {A B V : Type} [linker A] [linker V]
parameters {transf : A → B} {p : program A V} {tp : program B V}
parameter (progmatch : match_program (λ cu f tf, tf = transf f) eq p tp)

theorem find_funct_ptr_transf {b f} :
  find_funct_ptr (globalenv p) b = some f →
  find_funct_ptr (globalenv tp) b = some (transf f) := sorry'

theorem find_funct_transf {v f} :
  find_funct (globalenv p) v = some f →
  find_funct (globalenv tp) v = some (transf f) := sorry'

theorem find_symbol_transf {s : ident} :
  find_symbol (globalenv tp) s = find_symbol (globalenv p) s := sorry'

theorem senv_transf : Senv.equiv (globalenv p) (globalenv tp) := sorry'

theorem init_mem_transf {m} : init_mem p = some m → init_mem tp = some m := sorry'

end transform_total

end Genv

end globalenvs


/-
Copyright (c) 2014 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura
-/
prelude
import Init.Core
import Init.Control.Basic
import Init.Coe

namespace Option

def toMonad [Monad m] [Alternative m] : Option α → m α
  | none     => failure
  | some a   => pure a

@[inline] def toBool : Option α → Bool
  | some _ => true
  | none   => false

@[inline] def isSome : Option α → Bool
  | some _ => true
  | none   => false

@[inline] def isNone : Option α → Bool
  | some _ => false
  | none   => true

@[inline] protected def bind : Option α → (α → Option β) → Option β
  | none,   b => none
  | some a, b => b a

@[inline] protected def map (f : α → β) (o : Option α) : Option β :=
  Option.bind o (some ∘ f)

theorem mapId : (Option.map id : Option α → Option α) = id :=
  funext (fun o => match o with | none => rfl | some x => rfl)

instance : Functor Option where
  map := Option.map

@[inline] protected def filter (p : α → Bool) : Option α → Option α
  | some a => if p a then some a else none
  | none   => none

@[inline] protected def all (p : α → Bool) : Option α → Bool
  | some a => p a
  | none   => true

@[inline] protected def any (p : α → Bool) : Option α → Bool
  | some a => p a
  | none   => false

@[macroInline] protected def orElse : Option α → Option α → Option α
  | some a, _ => some a
  | none,   b => b

instance : OrElse (Option α) where
  orElse := Option.orElse

@[inline] protected def lt (r : α → α → Prop) : Option α → Option α → Prop
  | none, some x     => True
  | some x,   some y => r x y
  | _, _             => False

instance (r : α → α → Prop) [s : DecidableRel r] : DecidableRel (Option.lt r)
  | none,   some y => isTrue  trivial
  | some x, some y => s x y
  | some x, none   => isFalse notFalse
  | none,   none   => isFalse notFalse

end Option

deriving instance DecidableEq for Option
deriving instance BEq for Option

instance [LT α] : LT (Option α) where
  lt := Option.lt (· < ·)


import tactic.lint

variables {α : Type*}

/-- A property which determins whether this option is inhabited. -/
def option.is_some' : option α → Prop
| (some _) := true
| none := false

instance option.is_some'.decide : decidable_pred (@option.is_some' α)
| (some _) := decidable.true
| none := decidable.false

/-- Extract the value of an option, given a proof it exists. -/
def option.get' : ∀ {o : option α}, option.is_some' o → α
| (some k) _ := k

lemma option.eq_some_of_is_some' : ∀ {o : option α} (h : option.is_some' o), o = some (option.get' h)
| (some x) _ := rfl

#lint-


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

import Lean.Aesop.Rule
import Lean.Aesop.RuleTac

open Lean.Meta

namespace Lean.Aesop

structure RegularRuleBuilderResult where
  builderName : Name
  tac : RuleTac
  indexingMode : IndexingMode
  deriving Inhabited

inductive NormRuleBuilderResult
  | regular (r : RegularRuleBuilderResult)
  | simpEntries (es : Array SimpEntry)
  deriving Inhabited

inductive RuleIdent
  | const (decl : Name)
  | fvar (userName : Name)
  deriving Inhabited

namespace RuleIdent

instance : ToFormat RuleIdent where
  format
    | const decl => format decl
    | fvar userName => format userName

protected def type : RuleIdent → MetaM Expr
  | const c => return (← getConstInfo c).type
  | fvar userName => return (← getLocalDeclFromUserName userName).type

protected def ruleName : RuleIdent → Name
  | const c => `global ++ c
  | fvar userName => `local ++ userName

protected def ofName (n : Name) : MetaM RuleIdent := do
  try
    let _ ← getLocalDeclFromUserName n
    pure $ fvar n
  catch _ =>
    pure $ const n

end RuleIdent

abbrev RuleBuilder α := RuleIdent → MetaM α

namespace RuleBuilder

def normSimpUnfold : RuleBuilder NormRuleBuilderResult
  | RuleIdent.const decl => do
    let info ← getConstInfo decl
    unless info.hasValue do
      throwError "aesop: expected {decl} to be a definition to unfold"
    return NormRuleBuilderResult.simpEntries #[SimpEntry.toUnfold decl]
  | RuleIdent.fvar _ =>
    throwError "aesop: local hypotheses cannot be added as simp lemmas"

def normSimpLemmas : RuleBuilder NormRuleBuilderResult
  | RuleIdent.const decl => do
    let info ← getConstInfo decl
    unless (← isProp info.type) do
      throwError "aesop: tried to add {decl} as a simp lemma, but it is not a proposition"
    let simpLemmas ← mkSimpLemmasFromConst decl (post := true) (prio := 0)
      -- TODO I don't really know what the `post` and `prio` above mean.
    return NormRuleBuilderResult.simpEntries $ simpLemmas.map SimpEntry.lemma
  | RuleIdent.fvar _ => do
    throwError "aesop: local hypotheses cannot be added as simp lemmas"

def applyIndexingMode (type : Expr) : MetaM IndexingMode := do
  let savedState ← saveState
  let path ←
    try
      let (_, _, conclusion) ← forallMetaTelescope type
      DiscrTree.mkPath conclusion
    finally
      restoreState savedState
  -- We use a meta telescope because `DiscrTree.mkPath` ignores metas (they
  -- turn into `Key.star`) but not fvars.
  return IndexingMode.indexTarget path

def apply : RuleBuilder RegularRuleBuilderResult := λ ruleIdent => do
  let type := (← ruleIdent.type)
  let tac ←
    match ruleIdent with
    | RuleIdent.const decl => RuleTacBuilder.apply decl
    | RuleIdent.fvar userName => RuleTacBuilder.applyFVar userName
  return {
    builderName := `apply
    tac := tac
    indexingMode := (← applyIndexingMode type)
  }

def tactic : RuleBuilder RegularRuleBuilderResult
  | RuleIdent.const decl =>
    return {
      builderName := `tactic
      tac := (← RuleTacBuilder.tactic decl)
      indexingMode := IndexingMode.unindexed
    }
  | RuleIdent.fvar _ =>
    throwError "aesop: tactic builder does not support local hypotheses."

-- TODO In the default builders below, we should distinguish between fatal and
-- nonfatal errors. E.g. if the `tactic` builder finds a declaration that is not
-- of tactic type, this is a nonfatal error and we should continue with the next
-- builder. But if the simp builder finds an equation that cannot be interpreted
-- as a simp lemma for some reason, this is a fatal error. Continuing with the
-- next builder is more confusing than anything because the user probably
-- intended to add a simp lemma.

def unsafeRuleDefault : RuleBuilder RegularRuleBuilderResult
  | i@(RuleIdent.const _) => tactic i <|> apply i <|> err i
  | i@(RuleIdent.fvar _) => apply i <|> err i
  where
    err i := throwError "aesop: Unable to interpret {i} as an unsafe rule."

def safeRuleDefault : RuleBuilder RegularRuleBuilderResult
  | i@(RuleIdent.const _) => tactic i <|> apply i <|> err i
  | i@(RuleIdent.fvar _) => apply i <|> err i
  where
    err i := throwError "aesop: Unable to interpret {i} as a safe rule."

def normRuleDefault : RuleBuilder NormRuleBuilderResult
  | i@(RuleIdent.const _) =>
    (NormRuleBuilderResult.regular <$> tactic i) <|>
    normSimpLemmas i <|>
    (NormRuleBuilderResult.regular <$> apply i) <|>
    throwError "aesop: Unable to interpret {i} as a normalization rule."
  | i@(RuleIdent.fvar _) =>
    throwError "aesop: Please specify a builder for norm rule {i}."

end Lean.Aesop.RuleBuilder


import tactic.interactive

lemma a {α} [nonempty α] : ∃ a : α, a = a :=
by inhabit α; use default; refl

noncomputable def b {α} [nonempty α] : α :=
by inhabit α; apply default

lemma c {α} [nonempty α] : ∀ n : ℕ, ∃ b : α, n = n :=
by inhabit α; intro; use default; refl

noncomputable def d {α} [nonempty α] : ∀ n : ℕ, α :=
by inhabit α; intro; apply default


/-
Copyright (c) 2018 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro, Minchao Wu
-/
import tactic.core
/-!
# `#explode` command

Displays a proof term in a line by line format somewhat akin to a Fitch style
proof or the Metamath proof style.
-/

open expr tactic

namespace tactic
namespace explode

@[derive inhabited]
inductive status : Type | reg | intro | lam | sintro

/--
A type to distinguish introduction or elimination rules represented as
strings from theorems referred to by their names.
-/
meta inductive thm : Type
| expr (e : expr)
| name (n : name)
| string (s : string)

/--
Turn a thm into a string.
-/
meta def thm.to_string : thm → string
| (thm.expr e) := e.to_string
| (thm.name n) := n.to_string
| (thm.string s) := s

meta structure entry : Type :=
(expr : expr)
(line : nat)
(depth : nat)
(status : status)
(thm : thm)
(deps : list nat)

meta def pad_right (l : list string) : list string :=
let n := l.foldl (λ r (s:string), max r s.length) 0 in
l.map $ λ s, nat.iterate (λ s, s.push ' ') (n - s.length) s

@[derive inhabited]
meta structure entries : Type := mk' ::
(s : expr_map entry)
(l : list entry)

meta def entries.find (es : entries) (e : expr) : option entry := es.s.find e
meta def entries.size (es : entries) : ℕ := es.s.size

meta def entries.add : entries → entry → entries
| es@⟨s, l⟩ e := if s.contains e.expr then es else ⟨s.insert e.expr e, e :: l⟩

meta def entries.head (es : entries) : option entry := es.l.head'

meta def format_aux : list string → list string → list string → list entry → tactic format
| (line :: lines) (dep :: deps) (thm :: thms) (en :: es) := do
  fmt ← do {
    let margin := string.join (list.repeat " │" en.depth),
    let margin := match en.status with
      | status.sintro := " ├" ++ margin
      | status.intro := " │" ++ margin ++ " ┌"
      | status.reg := " │" ++ margin ++ ""
      | status.lam := " │" ++ margin ++ ""
      end,
    p ← infer_type en.expr >>= pp,
    let lhs :=  line ++ "│" ++ dep ++ "│ " ++ thm ++ margin ++ " ",
    return $ format.of_string lhs ++ (p.nest lhs.length).group ++ format.line },
  (++ fmt) <$> format_aux lines deps thms es
| _ _ _ _ := return format.nil

meta instance : has_to_tactic_format entries :=
⟨λ es : entries,
  let lines := pad_right $ es.l.map (λ en, to_string en.line),
      deps  := pad_right $ es.l.map (λ en, string.intercalate "," (en.deps.map to_string)),
      thms  := pad_right $ es.l.map (λ en, (entry.thm en).to_string) in
  format_aux lines deps thms es.l⟩

meta def append_dep (filter : expr → tactic unit)
 (es : entries) (e : expr) (deps : list nat) : tactic (list nat) :=
do { ei ← es.find e,
  filter ei.expr,
  return (ei.line :: deps) }
<|> return deps

meta def may_be_proof (e : expr) : tactic bool :=
do expr.sort u ← infer_type e >>= infer_type,
   return $ bnot u.nonzero

end explode
open explode

meta mutual def explode.core, explode.args (filter : expr → tactic unit)
with explode.core : expr → bool → nat → entries → tactic entries
| e@(lam n bi d b) si depth es := do
  m ← mk_fresh_name,
  let l := local_const m n bi d,
  let b' := instantiate_var b l,
  if si then
    let en : entry := ⟨l, es.size, depth, status.sintro, thm.name n, []⟩ in do
    es' ← explode.core b' si depth (es.add en),
    return $ es'.add ⟨e, es'.size, depth, status.lam, thm.string "∀I", [es.size, es'.size - 1]⟩
  else do
    let en : entry := ⟨l, es.size, depth, status.intro, thm.name n, []⟩,
    es' ← explode.core b' si (depth + 1) (es.add en),
    -- in case of a "have" clause, the b' here has an annotation
    deps' ← explode.append_dep filter es' b'.erase_annotations [],
    deps' ← explode.append_dep filter es' l deps',
    return $ es'.add ⟨e, es'.size, depth, status.lam, thm.string "∀I", deps'⟩
| e@(elet n t a b) si depth es := explode.core (reduce_lets e) si depth es
| e@(macro n l) si depth es := explode.core l.head si depth es
| e si depth es := filter e >>
  match get_app_fn_args e with
  | (nm@(const n _), args) :=
    explode.args e args depth es (thm.expr nm) []
  | (fn, []) := do
    let en : entry := ⟨fn, es.size, depth, status.reg, thm.expr fn, []⟩,
    return (es.add en)
  | (fn, args) := do
    es' ← explode.core fn ff depth es,
    -- in case of a "have" clause, the fn here has an annotation
    deps ← explode.append_dep filter es' fn.erase_annotations [],
    explode.args e args depth es' (thm.string "∀E") deps
  end
with explode.args : expr → list expr → nat → entries → thm → list nat → tactic entries
| e (arg :: args) depth es thm deps := do
  es' ← explode.core arg ff depth es <|> return es,
  deps' ← explode.append_dep filter es' arg deps,
  explode.args e args depth es' thm deps'
| e [] depth es thm deps :=
  return (es.add ⟨e, es.size, depth, status.reg, thm, deps.reverse⟩)

meta def explode_expr (e : expr) (hide_non_prop := tt) : tactic entries :=
let filter := if hide_non_prop then λ e, may_be_proof e >>= guardb else λ _, skip in
tactic.explode.core filter e tt 0 (default _)

meta def explode (n : name) : tactic unit :=
do const n _ ← resolve_name n | fail "cannot resolve name",
  d ← get_decl n,
  v ← match d with
  | (declaration.defn _ _ _ v _ _) := return v
  | (declaration.thm _ _ _ v)      := return v.get
  | _                  := fail "not a definition"
  end,
  t ← pp d.type,
  explode_expr v <* trace (to_fmt n ++ " : " ++ t) >>= trace

open interactive lean lean.parser interaction_monad.result

/--
`#explode decl_name` displays a proof term in a line-by-line format somewhat akin to a Fitch-style
proof or the Metamath proof style.
`#explode_widget decl_name` renders a widget that displays an `#explode` proof.

`#explode iff_true_intro` produces

```lean
iff_true_intro : ∀ {a : Prop}, a → (a ↔ true)
0│   │ a         ├ Prop
1│   │ h         ├ a
2│   │ hl        │ ┌ a
3│   │ trivial   │ │ true
4│2,3│ ∀I        │ a → true
5│   │ hr        │ ┌ true
6│5,1│ ∀I        │ true → a
7│4,6│ iff.intro │ a ↔ true
8│1,7│ ∀I        │ a → (a ↔ true)
9│0,8│ ∀I        │ ∀ {a : Prop}, a → (a ↔ true)
```

In more detail:

The output of `#explode` is a Fitch-style proof in a four-column diagram modeled after Metamath
proof displays like [this](http://us.metamath.org/mpeuni/ru.html). The headers of the columns are
"Step", "Hyp", "Ref", "Type" (or "Expression" in the case of Metamath):
* Step: An increasing sequence of numbers to number each step in the proof, used in the Hyp field.
* Hyp: The direct children of the current step. Most theorems are implications like `A -> B -> C`,
  and so on the step proving `C` the Hyp field will refer to the steps that prove `A` and `B`.
* Ref: The name of the theorem being applied. This is well-defined in Metamath, but in Lean there
  are some special steps that may have long names because the structure of proof terms doesn't
  exactly match this mold.
  * If the theorem is `foo (x y : Z) : A x -> B y -> C x y`:
    * the Ref field will contain `foo`,
    * `x` and `y` will be suppressed, because term construction is not interesting, and
    * the Hyp field will reference steps proving `A x` and `B y`. This corresponds to a proof term
      like `@foo x y pA pB` where `pA` and `pB` are subproofs.
  * If the head of the proof term is a local constant or lambda, then in this case the Ref will
    say `∀E` for forall-elimination. This happens when you have for example `h : A -> B` and
    `ha : A` and prove `b` by `h ha`; we reinterpret this as if it said `∀E h ha` where `∀E` is
    (n-ary) modus ponens.
  * If the proof term is a lambda, we will also use `∀I` for forall-introduction, referencing the
    body of the lambda. The indentation level will increase, and a bracket will surround the proof
    of the body of the lambda, starting at a proof step labeled with the name of the lambda variable
    and its type, and ending with the `∀I` step. Metamath doesn't have steps like this, but the
    style is based on Fitch proofs in first-order logic.
* Type: This contains the type of the proof term, the theorem being proven at the current step.
  This proof layout differs from `#print` in using lots of intermediate step displays so that you
  can follow along and don't have to see term construction steps because they are implicitly in the
  intermediate step displays.

Also, it is common for a Lean theorem to begin with a sequence of lambdas introducing local
constants of the theorem. In order to minimize the indentation level, the `∀I` steps at the end of
the proof will be introduced in a group and the indentation will stay fixed. (The indentation
brackets are only needed in order to delimit the scope of assumptions, and these assumptions
have global scope anyway so detailed tracking is not necessary.)
-/
@[user_command]
meta def explode_cmd (_ : parse $ tk "#explode") : parser unit :=
do n ← ident,
  explode n
.

add_tactic_doc
{ name       := "#explode / #explode_widget",
  category   := doc_category.cmd,
  decl_names := [`tactic.explode_cmd, `tactic.explode_widget_cmd],
  inherit_description_from := `tactic.explode_cmd,
  tags       := ["proof display", "widgets"] }

end tactic


/-
Copyright (c) 2022 Asta H. From. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Asta H. From, Jannis Limperg
-/
import Aesop

attribute [aesop safe (cases (patterns := [List.Mem _ []]))] List.Mem
attribute [aesop unsafe 50% (cases (patterns := [List.Mem _ (_ :: _)]))] List.Mem

theorem Mem.split [DecidableEq α] (xs : List α) (v : α) (h : v ∈ xs)
  : ∃ l r, xs = l ++ v :: r := by
  induction xs
  case nil =>
    aesop
  case cons x xs ih =>
    have dec : Decidable (x = v) := inferInstance
    cases dec
    case isFalse no =>
      aesop (options := { terminal := true })
    case isTrue yes =>
      apply Exists.intro []
      apply Exists.intro xs
      rw [yes]
      rfl