/-
Copyright (c) 2021 Andrew Yang. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Andrew Yang
-/
import ring_theory.finite_type
import ring_theory.localization.at_prime
import ring_theory.localization.away
import ring_theory.localization.integer
import ring_theory.localization.submodule
import ring_theory.nilpotent
import ring_theory.ring_hom_properties

/-!
# Local properties of commutative rings

In this file, we provide the proofs of various local properties.

## Naming Conventions

* `localization_P` : `P` holds for `S⁻¹R` if `P` holds for `R`.
* `P_of_localization_maximal` : `P` holds for `R` if `P` holds for `Rₘ` for all maximal `m`.
* `P_of_localization_prime` : `P` holds for `R` if `P` holds for `Rₘ` for all prime `m`.
* `P_of_localization_span` : `P` holds for `R` if given a spanning set `{fᵢ}`, `P` holds for all
  `R_{fᵢ}`.

## Main results

The following properties are covered:

* The triviality of an ideal or an element:
  `ideal_eq_bot_of_localization`, `eq_zero_of_localization`
* `is_reduced` : `localization_is_reduced`, `is_reduced_of_localization_maximal`.
* `finite`: `localization_finite`, `finite_of_localization_span`
* `finite_type`: `localization_finite_type`, `finite_type_of_localization_span`

-/

open_locale pointwise classical big_operators

universe u

variables {R S : Type u} [comm_ring R] [comm_ring S] (M : submonoid R)
variables (N : submonoid S) (R' S' : Type u) [comm_ring R'] [comm_ring S'] (f : R →+* S)
variables [algebra R R'] [algebra S S']

section properties

section comm_ring

variable (P : ∀ (R : Type u) [comm_ring R], Prop)

include P

/-- A property `P` of comm rings is said to be preserved by localization
  if `P` holds for `M⁻¹R` whenever `P` holds for `R`. -/
def localization_preserves : Prop :=
  ∀ {R : Type u} [hR : comm_ring R] (M : by exactI submonoid R) (S : Type u) [hS : comm_ring S]
    [by exactI algebra R S] [by exactI is_localization M S], @P R hR → @P S hS

/-- A property `P` of comm rings satisfies `of_localization_maximal` if
  if `P` holds for `R` whenever `P` holds for `Rₘ` for all maximal ideal `m`. -/
def of_localization_maximal : Prop :=
  ∀ (R : Type u) [comm_ring R],
    by exactI (∀ (J : ideal R) (hJ : J.is_maximal), by exactI P (localization.at_prime J)) → P R

end comm_ring

section ring_hom

variable (P : ∀ {R S : Type u} [comm_ring R] [comm_ring S] (f : by exactI R →+* S), Prop)

include P

/-- A property `P` of ring homs is said to be preserved by localization
 if `P` holds for `M⁻¹R →+* M⁻¹S` whenever `P` holds for `R →+* S`. -/
def ring_hom.localization_preserves :=
  ∀ ⦃R S : Type u⦄ [comm_ring R] [comm_ring S] (f : by exactI R →+* S) (M : by exactI submonoid R)
    (R' S' : Type u) [comm_ring R'] [comm_ring S'] [by exactI algebra R R']
    [by exactI algebra S S'] [by exactI is_localization M R']
    [by exactI is_localization (M.map f) S'],
    by exactI (P f → P (is_localization.map S' f (submonoid.le_comap_map M) : R' →+* S'))

/-- A property `P` of ring homs satisfies `ring_hom.of_localization_finite_span`
if `P` holds for `R →+* S` whenever there exists a finite set `{ r }` that spans `R` such that
`P` holds for `Rᵣ →+* Sᵣ`.

Note that this is equivalent to `ring_hom.of_localization_span` via
`ring_hom.of_localization_span_iff_finite`, but this is easier to prove. -/
def ring_hom.of_localization_finite_span :=
  ∀ ⦃R S : Type u⦄ [comm_ring R] [comm_ring S] (f : by exactI R →+* S)
    (s : finset R) (hs : by exactI ideal.span (s : set R) = ⊤)
    (H : by exactI (∀ (r : s), P (localization.away_map f r))), by exactI P f

/-- A property `P` of ring homs satisfies `ring_hom.of_localization_finite_span`
if `P` holds for `R →+* S` whenever there exists a set `{ r }` that spans `R` such that
`P` holds for `Rᵣ →+* Sᵣ`.

Note that this is equivalent to `ring_hom.of_localization_finite_span` via
`ring_hom.of_localization_span_iff_finite`, but this has less restrictions when applying. -/
def ring_hom.of_localization_span :=
  ∀ ⦃R S : Type u⦄ [comm_ring R] [comm_ring S] (f : by exactI R →+* S)
    (s : set R) (hs : by exactI ideal.span s = ⊤)
    (H : by exactI (∀ (r : s), P (localization.away_map f r))), by exactI P f

/-- A property `P` of ring homs satisfies `ring_hom.holds_for_localization_away`
 if `P` holds for each localization map `R →+* Rᵣ`. -/
def ring_hom.holds_for_localization_away : Prop :=
∀ ⦃R : Type u⦄ (S : Type u) [comm_ring R] [comm_ring S] [by exactI algebra R S] (r : R)
  [by exactI is_localization.away r S], by exactI P (algebra_map R S)

/-- A property `P` of ring homs satisfies `ring_hom.of_localization_finite_span_target`
if `P` holds for `R →+* S` whenever there exists a finite set `{ r }` that spans `S` such that
`P` holds for `R →+* Sᵣ`.

Note that this is equivalent to `ring_hom.of_localization_span_target` via
`ring_hom.of_localization_span_target_iff_finite`, but this is easier to prove. -/
def ring_hom.of_localization_finite_span_target : Prop :=
∀ ⦃R S : Type u⦄ [comm_ring R] [comm_ring S] (f : by exactI R →+* S)
  (s : finset S) (hs : by exactI ideal.span (s : set S) = ⊤)
  (H : by exactI (∀ (r : s), P ((algebra_map S (localization.away (r : S))).comp f))),
  by exactI P f

/-- A property `P` of ring homs satisfies `ring_hom.of_localization_span_target`
if `P` holds for `R →+* S` whenever there exists a set `{ r }` that spans `S` such that
`P` holds for `R →+* Sᵣ`.

Note that this is equivalent to `ring_hom.of_localization_finite_span_target` via
`ring_hom.of_localization_span_target_iff_finite`, but this has less restrictions when applying. -/
def ring_hom.of_localization_span_target : Prop :=
∀ ⦃R S : Type u⦄ [comm_ring R] [comm_ring S] (f : by exactI R →+* S)
  (s : set S) (hs : by exactI ideal.span s = ⊤)
  (H : by exactI (∀ (r : s), P ((algebra_map S (localization.away (r : S))).comp f))),
  by exactI P f

/-- A property `P` of ring homs satisfies `of_localization_prime` if
  if `P` holds for `R` whenever `P` holds for `Rₘ` for all prime ideals `p`. -/
def ring_hom.of_localization_prime : Prop :=
∀ ⦃R S : Type u⦄ [comm_ring R] [comm_ring S] (f : by exactI R →+* S),
  by exactI (∀ (J : ideal S) (hJ : J.is_prime),
    by exactI P (localization.local_ring_hom _ J f rfl)) → P f

/-- A property of ring homs is local if it is preserved by localizations and compositions, and for
each `{ r }` that spans `S`, we have `P (R →+* S) ↔ ∀ r, P (R →+* Sᵣ)`. -/
structure ring_hom.property_is_local : Prop :=
(localization_preserves : ring_hom.localization_preserves @P)
(of_localization_span_target : ring_hom.of_localization_span_target @P)
(stable_under_composition : ring_hom.stable_under_composition @P)
(holds_for_localization_away : ring_hom.holds_for_localization_away @P)

lemma ring_hom.of_localization_span_iff_finite :
  ring_hom.of_localization_span @P ↔ ring_hom.of_localization_finite_span @P :=
begin
  delta ring_hom.of_localization_span ring_hom.of_localization_finite_span,
  apply forall₅_congr, -- TODO: Using `refine` here breaks `resetI`.
  introsI,
  split,
  { intros h s, exact h s },
  { intros h s hs hs',
    obtain ⟨s', h₁, h₂⟩ := (ideal.span_eq_top_iff_finite s).mp hs,
    exact h s' h₂ (λ x, hs' ⟨_, h₁ x.prop⟩) }
end

lemma ring_hom.of_localization_span_target_iff_finite :
  ring_hom.of_localization_span_target @P ↔ ring_hom.of_localization_finite_span_target @P :=
begin
  delta ring_hom.of_localization_span_target ring_hom.of_localization_finite_span_target,
  apply forall₅_congr, -- TODO: Using `refine` here breaks `resetI`.
  introsI,
  split,
  { intros h s, exact h s },
  { intros h s hs hs',
    obtain ⟨s', h₁, h₂⟩ := (ideal.span_eq_top_iff_finite s).mp hs,
    exact h s' h₂ (λ x, hs' ⟨_, h₁ x.prop⟩) }
end

variables {P f R' S'}

lemma _root_.ring_hom.property_is_local.respects_iso (hP : ring_hom.property_is_local @P) :
  ring_hom.respects_iso @P :=
begin
  apply hP.stable_under_composition.respects_iso,
  introv,
  resetI,
  letI := e.to_ring_hom.to_algebra,
  apply_with hP.holds_for_localization_away { instances := ff },
  apply is_localization.away_of_is_unit_of_bijective _ is_unit_one,
  exact e.bijective
end

-- Almost all arguments are implicit since this is not intended to use mid-proof.
lemma ring_hom.localization_preserves.away
  (H : ring_hom.localization_preserves @P) (r : R) [is_localization.away r R']
  [is_localization.away (f r) S'] (hf : P f) :
    P (by exactI is_localization.away.map R' S' f r) :=
begin
  resetI,
  haveI : is_localization ((submonoid.powers r).map f) S',
  { rw submonoid.map_powers, assumption },
  exact H f (submonoid.powers r) R' S' hf,
end

lemma ring_hom.property_is_local.of_localization_span (hP : ring_hom.property_is_local @P) :
  ring_hom.of_localization_span @P :=
begin
  introv R hs hs',
  resetI,
  apply_fun (ideal.map f) at hs,
  rw [ideal.map_span, ideal.map_top] at hs,
  apply hP.of_localization_span_target _ _ hs,
  rintro ⟨_, r, hr, rfl⟩,
  have := hs' ⟨r, hr⟩,
  convert hP.stable_under_composition _ _ (hP.holds_for_localization_away (localization.away r) r)
    (hs' ⟨r, hr⟩) using 1,
  exact (is_localization.map_comp _).symm
end

end ring_hom

end properties

section ideal

open_locale non_zero_divisors

/-- Let `I J : ideal R`. If the localization of `I` at each maximal ideal `P` is included in
the localization of `J` at `P`, then `I ≤ J`. -/
lemma ideal.le_of_localization_maximal {I J : ideal R}
  (h : ∀ (P : ideal R) (hP : P.is_maximal),
    ideal.map (algebra_map R (by exactI localization.at_prime P)) I ≤
      ideal.map (algebra_map R (by exactI localization.at_prime P)) J) :
  I ≤ J :=
begin
  intros x hx,
  suffices : J.colon (ideal.span {x}) = ⊤,
  { simpa using submodule.mem_colon.mp
      (show (1 : R) ∈ J.colon (ideal.span {x}), from this.symm ▸ submodule.mem_top)
      x (ideal.mem_span_singleton_self x) },
  refine not.imp_symm (J.colon (ideal.span {x})).exists_le_maximal _,
  push_neg,
  introsI P hP le,
  obtain ⟨⟨⟨a, ha⟩, ⟨s, hs⟩⟩, eq⟩ := (is_localization.mem_map_algebra_map_iff P.prime_compl _).mp
    (h P hP (ideal.mem_map_of_mem _ hx)),
  rw [← _root_.map_mul, ← sub_eq_zero, ← map_sub] at eq,
  obtain ⟨⟨m, hm⟩, eq⟩ := (is_localization.map_eq_zero_iff P.prime_compl _ _).mp eq,
  refine hs ((hP.is_prime.mem_or_mem (le (ideal.mem_colon_singleton.mpr _))).resolve_right hm),
  simp only [subtype.coe_mk, mul_sub, sub_eq_zero, mul_comm x s, mul_left_comm] at eq,
  simpa only [mul_assoc, eq] using J.mul_mem_left m ha
end

/-- Let `I J : ideal R`. If the localization of `I` at each maximal ideal `P` is equal to
the localization of `J` at `P`, then `I = J`. -/
theorem ideal.eq_of_localization_maximal {I J : ideal R}
  (h : ∀ (P : ideal R) (hP : P.is_maximal),
    ideal.map (algebra_map R (by exactI localization.at_prime P)) I =
      ideal.map (algebra_map R (by exactI localization.at_prime P)) J) :
  I = J :=
le_antisymm
  (ideal.le_of_localization_maximal (λ P hP, (h P hP).le))
  (ideal.le_of_localization_maximal (λ P hP, (h P hP).ge))

/-- An ideal is trivial if its localization at every maximal ideal is trivial. -/
lemma ideal_eq_bot_of_localization' (I : ideal R)
   (h : ∀ (J : ideal R) (hJ : J.is_maximal),
      ideal.map (algebra_map R (by exactI (localization.at_prime J))) I = ⊥) : I = ⊥ :=
ideal.eq_of_localization_maximal (λ P hP, (by simpa using h P hP))

-- TODO: This proof should work for all modules, once we have enough material on submodules of
-- localized modules.
/-- An ideal is trivial if its localization at every maximal ideal is trivial. -/
lemma ideal_eq_bot_of_localization (I : ideal R)
   (h : ∀ (J : ideal R) (hJ : J.is_maximal),
      by exactI is_localization.coe_submodule (localization.at_prime J) I = ⊥) : I = ⊥ :=
ideal_eq_bot_of_localization' _ (λ P hP, (ideal.map_eq_bot_iff_le_ker _).mpr (λ x hx,
  by { rw [ring_hom.mem_ker, ← submodule.mem_bot R, ← h P hP, is_localization.mem_coe_submodule],
       exact ⟨x, hx, rfl⟩ }))

lemma eq_zero_of_localization (r : R)
   (h : ∀ (J : ideal R) (hJ : J.is_maximal),
      by exactI algebra_map R (localization.at_prime J) r = 0) : r = 0 :=
begin
  rw ← ideal.span_singleton_eq_bot,
  apply ideal_eq_bot_of_localization,
  intros J hJ,
  delta is_localization.coe_submodule,
  erw [submodule.map_span, submodule.span_eq_bot],
  rintro _ ⟨_, h', rfl⟩,
  cases set.mem_singleton_iff.mpr h',
  exact h J hJ,
end

end ideal

section reduced

lemma localization_is_reduced : localization_preserves (λ R hR, by exactI is_reduced R) :=
begin
  introv R _ _,
  resetI,
  constructor,
  rintro x ⟨(_|n), e⟩,
  { simpa using congr_arg (*x) e },
  obtain ⟨⟨y, m⟩, hx⟩ := is_localization.surj M x,
  dsimp only at hx,
  let hx' := congr_arg (^ n.succ) hx,
  simp only [mul_pow, e, zero_mul, ← ring_hom.map_pow] at hx',
  rw [← (algebra_map R S).map_zero] at hx',
  obtain ⟨m', hm'⟩ := (is_localization.eq_iff_exists M S).mp hx',
  apply_fun (*m'^n) at hm',
  simp only [mul_assoc, zero_mul, mul_zero] at hm',
  rw [← mul_left_comm, ← pow_succ, ← mul_pow] at hm',
  replace hm' := is_nilpotent.eq_zero ⟨_, hm'.symm⟩,
  rw [← (is_localization.map_units S m).mul_left_inj, hx, zero_mul,
    is_localization.map_eq_zero_iff M],
  exact ⟨m', by rw [← hm', mul_comm]⟩
end

instance [is_reduced R] : is_reduced (localization M) := localization_is_reduced M _ infer_instance

lemma is_reduced_of_localization_maximal :
  of_localization_maximal (λ R hR, by exactI is_reduced R) :=
begin
  introv R h,
  constructor,
  intros x hx,
  apply eq_zero_of_localization,
  intros J hJ,
  specialize h J hJ,
  resetI,
  exact (hx.map $ algebra_map R $ localization.at_prime J).eq_zero,
end

end reduced

section surjective

lemma localization_preserves_surjective :
  ring_hom.localization_preserves (λ R S _ _ f, function.surjective f) :=
begin
  introv R H x,
  resetI,
  obtain ⟨x, ⟨_, s, hs, rfl⟩, rfl⟩ := is_localization.mk'_surjective (M.map f) x,
  obtain ⟨y, rfl⟩ := H x,
  use is_localization.mk' R' y ⟨s, hs⟩,
  rw is_localization.map_mk',
  refl,
end

lemma surjective_of_localization_span :
  ring_hom.of_localization_span (λ R S _ _ f, function.surjective f) :=
begin
  introv R e H,
  rw [← set.range_iff_surjective, set.eq_univ_iff_forall],
  resetI,
  letI := f.to_algebra,
  intro x,
  apply submodule.mem_of_span_eq_top_of_smul_pow_mem (algebra.of_id R S).to_linear_map.range s e,
  intro r,
  obtain ⟨a, e'⟩ := H r (algebra_map _ _ x),
  obtain ⟨b, ⟨_, n, rfl⟩, rfl⟩ := is_localization.mk'_surjective (submonoid.powers (r : R)) a,
  erw is_localization.map_mk' at e',
  rw [eq_comm, is_localization.eq_mk'_iff_mul_eq, subtype.coe_mk, subtype.coe_mk, ← map_mul] at e',
  obtain ⟨⟨_, n', rfl⟩, e''⟩ := (is_localization.eq_iff_exists (submonoid.powers (f r)) _).mp e',
  rw [subtype.coe_mk, mul_comm x, ←mul_assoc, ← map_pow, ← map_mul, ← map_mul, ← pow_add] at e'',
  exact ⟨n' + n, _, e''.symm⟩
end

end surjective

section finite

/-- If `S` is a finite `R`-algebra, then `S' = M⁻¹S` is a finite `R' = M⁻¹R`-algebra. -/
lemma localization_finite : ring_hom.localization_preserves @ring_hom.finite :=
begin
  introv R hf,
  -- Setting up the `algebra` and `is_scalar_tower` instances needed
  resetI,
  letI := f.to_algebra,
  letI := ((algebra_map S S').comp f).to_algebra,
  let f' : R' →+* S' := is_localization.map S' f (submonoid.le_comap_map M),
  letI := f'.to_algebra,
  haveI : is_scalar_tower R R' S' :=
    is_scalar_tower.of_algebra_map_eq' (is_localization.map_comp _).symm,
  let fₐ : S →ₐ[R] S' := alg_hom.mk' (algebra_map S S') (λ c x, ring_hom.map_mul _ _ _),

  -- We claim that if `S` is generated by `T` as an `R`-module,
  -- then `S'` is generated by `T` as an `R'`-module.
  unfreezingI { obtain ⟨T, hT⟩ := hf },
  use T.image (algebra_map S S'),
  rw eq_top_iff,
  rintro x -,

  -- By the hypotheses, for each `x : S'`, we have `x = y / (f r)` for some `y : S` and `r : M`.
  -- Since `S` is generated by `T`, the image of `y` should fall in the span of the image of `T`.
  obtain ⟨y, ⟨_, ⟨r, hr, rfl⟩⟩, rfl⟩ := is_localization.mk'_surjective (M.map f) x,
  rw [is_localization.mk'_eq_mul_mk'_one, mul_comm, finset.coe_image],
  have hy : y ∈ submodule.span R ↑T, by { rw hT, trivial },
  replace hy : algebra_map S S' y ∈ submodule.map fₐ.to_linear_map (submodule.span R T) :=
    submodule.mem_map_of_mem hy,
  rw submodule.map_span fₐ.to_linear_map T at hy,
  have H : submodule.span R ((algebra_map S S') '' T) ≤
    (submodule.span R' ((algebra_map S S') '' T)).restrict_scalars R,
  { rw submodule.span_le, exact submodule.subset_span },

  -- Now, since `y ∈ span T`, and `(f r)⁻¹ ∈ R'`, `x / (f r)` is in `span T` as well.
  convert (submodule.span R' ((algebra_map S S') '' T)).smul_mem
    (is_localization.mk' R' (1 : R) ⟨r, hr⟩) (H hy) using 1,
  rw algebra.smul_def,
  erw is_localization.map_mk',
  rw map_one,
  refl,
end

lemma localization_away_map_finite (r : R) [is_localization.away r R']
  [is_localization.away (f r) S'] (hf : f.finite) :
    (is_localization.away.map R' S' f r).finite :=
localization_finite.away r hf

/--
Let `S` be an `R`-algebra, `M` an submonoid of `R`, and `S' = M⁻¹S`.
If the image of some `x : S` falls in the span of some finite `s ⊆ S'` over `R`,
then there exists some `m : M` such that `m • x` falls in the
span of `finset_integer_multiple _ s` over `R`.
-/
lemma is_localization.smul_mem_finset_integer_multiple_span [algebra R S]
  [algebra R S'] [is_scalar_tower R S S']
  [is_localization (M.map (algebra_map R S)) S'] (x : S)
  (s : finset S') (hx : algebra_map S S' x ∈ submodule.span R (s : set S')) :
    ∃ m : M, m • x ∈ submodule.span R
      (is_localization.finset_integer_multiple (M.map (algebra_map R S)) s : set S) :=
begin
  let g : S →ₐ[R] S' := alg_hom.mk' (algebra_map S S')
    (λ c x, by simp [algebra.algebra_map_eq_smul_one]),

  -- We first obtain the `y' ∈ M` such that `s' = y' • s` is falls in the image of `S` in `S'`.
  let y := is_localization.common_denom_of_finset (M.map (algebra_map R S)) s,
  have hx₁ : (y : S) • ↑s = g '' _ := (is_localization.finset_integer_multiple_image _ s).symm,
  obtain ⟨y', hy', e : algebra_map R S y' = y⟩ := y.prop,
  have : algebra_map R S y' • (s : set S') = y' • s :=
    by simp_rw [algebra.algebra_map_eq_smul_one, smul_assoc, one_smul],
  rw [← e, this] at hx₁,
  replace hx₁ := congr_arg (submodule.span R) hx₁,
  rw submodule.span_smul at hx₁,
  replace hx : _ ∈ y' • submodule.span R (s : set S') := set.smul_mem_smul_set hx,
  rw hx₁ at hx,
  erw [← g.map_smul, ← submodule.map_span (g : S →ₗ[R] S')] at hx,
  -- Since `x` falls in the span of `s` in `S'`, `y' • x : S` falls in the span of `s'` in `S'`.
  -- That is, there exists some `x' : S` in the span of `s'` in `S` and `x' = y' • x` in `S'`.
  -- Thus `a • (y' • x) = a • x' ∈ span s'` in `S` for some `a ∈ M`.
  obtain ⟨x', hx', hx'' : algebra_map _ _ _ = _⟩ := hx,
  obtain ⟨⟨_, a, ha₁, rfl⟩, ha₂⟩ := (is_localization.eq_iff_exists
    (M.map (algebra_map R S)) S').mp hx'',
  use (⟨a, ha₁⟩ : M) * (⟨y', hy'⟩ : M),
  convert (submodule.span R (is_localization.finset_integer_multiple
    (submonoid.map (algebra_map R S) M) s : set S)).smul_mem a hx' using 1,
  convert ha₂.symm,
  { rw [subtype.coe_mk, submonoid.smul_def, submonoid.coe_mul, ← smul_smul],
    exact algebra.smul_def _ _ },
  { exact algebra.smul_def _ _ }
end

/-- If `S` is an `R' = M⁻¹R` algebra, and `x ∈ span R' s`,
then `t • x ∈ span R s` for some `t : M`.-/
lemma multiple_mem_span_of_mem_localization_span [algebra R' S] [algebra R S]
  [is_scalar_tower R R' S] [is_localization M R']
  (s : set S) (x : S) (hx : x ∈ submodule.span R' s) :
    ∃ t : M, t • x ∈ submodule.span R s :=
begin
  classical,
  obtain ⟨s', hss', hs'⟩ := submodule.mem_span_finite_of_mem_span hx,
  rsuffices ⟨t, ht⟩ : ∃ t : M, t • x ∈ submodule.span R (s' : set S),
  { exact ⟨t, submodule.span_mono hss' ht⟩ },
  clear hx hss' s,
  revert x,
  apply s'.induction_on,
  { intros x hx, use 1, simpa using hx },
  rintros a s ha hs x hx,
  simp only [finset.coe_insert, finset.image_insert, finset.coe_image, subtype.coe_mk,
    submodule.mem_span_insert] at hx ⊢,
  rcases hx with ⟨y, z, hz, rfl⟩,
  rcases is_localization.surj M y with ⟨⟨y', s'⟩, e⟩,
  replace e : _ * a = _ * a := (congr_arg (λ x, algebra_map R' S x * a) e : _),
  simp_rw [ring_hom.map_mul, ← is_scalar_tower.algebra_map_apply, mul_comm (algebra_map R' S y),
    mul_assoc, ← algebra.smul_def] at e,
  rcases hs _ hz with ⟨t, ht⟩,
  refine ⟨t*s', t*y', _, (submodule.span R (s : set S)).smul_mem s' ht, _⟩,
  rw [smul_add, ← smul_smul, mul_comm, ← smul_smul, ← smul_smul, ← e],
  refl,
end

/-- If `S` is an `R' = M⁻¹R` algebra, and `x ∈ adjoin R' s`,
then `t • x ∈ adjoin R s` for some `t : M`.-/
lemma multiple_mem_adjoin_of_mem_localization_adjoin [algebra R' S] [algebra R S]
  [is_scalar_tower R R' S] [is_localization M R']
  (s : set S) (x : S) (hx : x ∈ algebra.adjoin R' s) :
    ∃ t : M, t • x ∈ algebra.adjoin R s :=
begin
  change ∃ (t : M), t • x ∈ (algebra.adjoin R s).to_submodule,
  change x ∈ (algebra.adjoin R' s).to_submodule at hx,
  simp_rw [algebra.adjoin_eq_span] at hx ⊢,
  exact multiple_mem_span_of_mem_localization_span M R' _ _ hx
end

lemma finite_of_localization_span : ring_hom.of_localization_span @ring_hom.finite :=
begin
  rw ring_hom.of_localization_span_iff_finite,
  introv R hs H,
  -- We first setup the instances
  resetI,
  letI := f.to_algebra,
  letI := λ (r : s), (localization.away_map f r).to_algebra,
  haveI : ∀ r : s, is_localization ((submonoid.powers (r : R)).map (algebra_map R S))
    (localization.away (f r)),
  { intro r, rw submonoid.map_powers, exact localization.is_localization },
  haveI : ∀ r : s, is_scalar_tower R (localization.away (r : R)) (localization.away (f r)) :=
    λ r, is_scalar_tower.of_algebra_map_eq' (is_localization.map_comp _).symm,

  -- By the hypothesis, we may find a finite generating set for each `Sᵣ`. This set can then be
  -- lifted into `R` by multiplying a sufficiently large power of `r`. I claim that the union of
  -- these generates `S`.
  constructor,
  replace H := λ r, (H r).1,
  choose s₁ s₂ using H,
  let sf := λ (x : s), is_localization.finset_integer_multiple (submonoid.powers (f x)) (s₁ x),
  use s.attach.bUnion sf,
  rw [submodule.span_attach_bUnion, eq_top_iff],

  -- It suffices to show that `r ^ n • x ∈ span T` for each `r : s`, since `{ r ^ n }` spans `R`.
  -- This then follows from the fact that each `x : R` is a linear combination of the generating set
  -- of `Sᵣ`. By multiplying a sufficiently large power of `r`, we can cancel out the `r`s in the
  -- denominators of both the generating set and the coefficients.
  rintro x -,
  apply submodule.mem_of_span_eq_top_of_smul_pow_mem _ (s : set R) hs _ _,
  intro r,
  obtain ⟨⟨_, n₁, rfl⟩, hn₁⟩ := multiple_mem_span_of_mem_localization_span
    (submonoid.powers (r : R)) (localization.away (r : R)) (s₁ r : set (localization.away (f r)))
      (algebra_map S _ x) (by { rw s₂ r, trivial }),
  rw [submonoid.smul_def, algebra.smul_def, is_scalar_tower.algebra_map_apply R S,
    subtype.coe_mk, ← map_mul] at hn₁,
  obtain ⟨⟨_, n₂, rfl⟩, hn₂⟩ := is_localization.smul_mem_finset_integer_multiple_span
    (submonoid.powers (r : R)) (localization.away (f r)) _ (s₁ r) hn₁,
  rw [submonoid.smul_def, ← algebra.smul_def, smul_smul, subtype.coe_mk, ← pow_add] at hn₂,
  simp_rw submonoid.map_powers at hn₂,
  use n₂ + n₁,
  exact le_supr (λ (x : s), submodule.span R (sf x : set S)) r hn₂,
end

end finite

section finite_type

lemma localization_finite_type : ring_hom.localization_preserves @ring_hom.finite_type :=
begin
  introv R hf,
  -- mirrors the proof of `localization_map_finite`
  resetI,
  letI := f.to_algebra,
  letI := ((algebra_map S S').comp f).to_algebra,
  let f' : R' →+* S' := is_localization.map S' f (submonoid.le_comap_map M),
  letI := f'.to_algebra,
  haveI : is_scalar_tower R R' S' :=
    is_scalar_tower.of_algebra_map_eq' (is_localization.map_comp _).symm,
  let fₐ : S →ₐ[R] S' := alg_hom.mk' (algebra_map S S') (λ c x, ring_hom.map_mul _ _ _),

  obtain ⟨T, hT⟩ := id hf,
  use T.image (algebra_map S S'),
  rw eq_top_iff,
  rintro x -,
  obtain ⟨y, ⟨_, ⟨r, hr, rfl⟩⟩, rfl⟩ := is_localization.mk'_surjective (M.map f) x,
  rw [is_localization.mk'_eq_mul_mk'_one, mul_comm, finset.coe_image],
  have hy : y ∈ algebra.adjoin R (T : set S), by { rw hT, trivial },
  replace hy : algebra_map S S' y ∈ (algebra.adjoin R (T : set S)).map fₐ :=
    subalgebra.mem_map.mpr ⟨_, hy, rfl⟩,
  rw fₐ.map_adjoin T at hy,
  have H : algebra.adjoin R ((algebra_map S S') '' T) ≤
    (algebra.adjoin R' ((algebra_map S S') '' T)).restrict_scalars R,
  { rw algebra.adjoin_le_iff, exact algebra.subset_adjoin },
  convert (algebra.adjoin R' ((algebra_map S S') '' T)).smul_mem (H hy)
    (is_localization.mk' R' (1 : R) ⟨r, hr⟩) using 1,
  rw algebra.smul_def,
  erw is_localization.map_mk',
  rw map_one,
  refl,
end

lemma localization_away_map_finite_type (r : R) [is_localization.away r R']
  [is_localization.away (f r) S'] (hf : f.finite_type) :
    (is_localization.away.map R' S' f r).finite_type :=
localization_finite_type.away r hf

variable {S'}

/--
Let `S` be an `R`-algebra, `M` a submonoid of `S`, `S' = M⁻¹S`.
Suppose the image of some `x : S` falls in the adjoin of some finite `s ⊆ S'` over `R`,
and `A` is an `R`-subalgebra of `S` containing both `M` and the numerators of `s`.
Then, there exists some `m : M` such that `m • x` falls in `A`.
-/
lemma is_localization.exists_smul_mem_of_mem_adjoin [algebra R S]
  [algebra R S'] [is_scalar_tower R S S'] (M : submonoid S)
  [is_localization M S'] (x : S) (s : finset S') (A : subalgebra R S)
  (hA₁ : (is_localization.finset_integer_multiple M s : set S) ⊆ A)
  (hA₂ : M ≤ A.to_submonoid)
  (hx : algebra_map S S' x ∈ algebra.adjoin R (s : set S')) :
    ∃ m : M, m • x ∈ A :=
begin
  let g : S →ₐ[R] S' := is_scalar_tower.to_alg_hom R S S',
  let y := is_localization.common_denom_of_finset M s,
  have hx₁ : (y : S) • ↑s = g '' _ := (is_localization.finset_integer_multiple_image _ s).symm,
  obtain ⟨n, hn⟩ := algebra.pow_smul_mem_of_smul_subset_of_mem_adjoin (y : S) (s : set S')
    (A.map g) (by { rw hx₁, exact set.image_subset _ hA₁ }) hx (set.mem_image_of_mem _ (hA₂ y.2)),
  obtain ⟨x', hx', hx''⟩ := hn n (le_of_eq rfl),
  rw [algebra.smul_def, ← _root_.map_mul] at hx'',
  obtain ⟨a, ha₂⟩ := (is_localization.eq_iff_exists M S').mp hx'',
  use a * y ^ n,
  convert A.mul_mem hx' (hA₂ a.prop),
  rw [submonoid.smul_def, smul_eq_mul, submonoid.coe_mul, submonoid.coe_pow, mul_assoc, ←ha₂,
    mul_comm],
end

/--
Let `S` be an `R`-algebra, `M` an submonoid of `R`, and `S' = M⁻¹S`.
If the image of some `x : S` falls in the adjoin of some finite `s ⊆ S'` over `R`,
then there exists some `m : M` such that `m • x` falls in the
adjoin of `finset_integer_multiple _ s` over `R`.
-/
lemma is_localization.lift_mem_adjoin_finset_integer_multiple [algebra R S]
  [algebra R S'] [is_scalar_tower R S S']
  [is_localization (M.map (algebra_map R S)) S'] (x : S)
  (s : finset S') (hx : algebra_map S S' x ∈ algebra.adjoin R (s : set S')) :
    ∃ m : M, m • x ∈ algebra.adjoin R
      (is_localization.finset_integer_multiple (M.map (algebra_map R S)) s : set S) :=
begin
  obtain ⟨⟨_, a, ha, rfl⟩, e⟩ := is_localization.exists_smul_mem_of_mem_adjoin
    (M.map (algebra_map R S)) x s (algebra.adjoin R _) algebra.subset_adjoin _ hx,
  { exact ⟨⟨a, ha⟩, by simpa [submonoid.smul_def] using e⟩ },
{ rintros _ ⟨a, ha, rfl⟩, exact subalgebra.algebra_map_mem _ a }
end

lemma finite_type_of_localization_span : ring_hom.of_localization_span @ring_hom.finite_type :=
begin
  rw ring_hom.of_localization_span_iff_finite,
  introv R hs H,
  -- mirrors the proof of `finite_of_localization_span`
  resetI,
  letI := f.to_algebra,
  letI := λ (r : s), (localization.away_map f r).to_algebra,
  haveI : ∀ r : s, is_localization ((submonoid.powers (r : R)).map (algebra_map R S))
    (localization.away (f r)),
  { intro r, rw submonoid.map_powers, exact localization.is_localization },
  haveI : ∀ r : s, is_scalar_tower R (localization.away (r : R)) (localization.away (f r)) :=
    λ r, is_scalar_tower.of_algebra_map_eq' (is_localization.map_comp _).symm,

  constructor,
  replace H := λ r, (H r).1,
  choose s₁ s₂ using H,
  let sf := λ (x : s), is_localization.finset_integer_multiple (submonoid.powers (f x)) (s₁ x),
  use s.attach.bUnion sf,
  convert (algebra.adjoin_attach_bUnion sf).trans _,
  rw eq_top_iff,
  rintro x -,
  apply (⨆ (x : s), algebra.adjoin R (sf x : set S)).to_submodule
    .mem_of_span_eq_top_of_smul_pow_mem _ hs _ _,
  intro r,
  obtain ⟨⟨_, n₁, rfl⟩, hn₁⟩ := multiple_mem_adjoin_of_mem_localization_adjoin
    (submonoid.powers (r : R)) (localization.away (r : R)) (s₁ r : set (localization.away (f r)))
      (algebra_map S (localization.away (f r)) x) (by { rw s₂ r, trivial }),
  rw [submonoid.smul_def, algebra.smul_def, is_scalar_tower.algebra_map_apply R S,
    subtype.coe_mk, ← map_mul] at hn₁,
  obtain ⟨⟨_, n₂, rfl⟩, hn₂⟩ := is_localization.lift_mem_adjoin_finset_integer_multiple
    (submonoid.powers (r : R)) _ (s₁ r) hn₁,
  rw [submonoid.smul_def, ← algebra.smul_def, smul_smul, subtype.coe_mk, ← pow_add] at hn₂,
  simp_rw submonoid.map_powers at hn₂,
  use n₂ + n₁,
  exact le_supr (λ (x : s), algebra.adjoin R (sf x : set S)) r hn₂
end

end finite_type


import Duper.Simp
import Duper.Util.ProofReconstruction
import Lean.Meta.Basic

namespace Duper
open RuleM
open SimpResult
open Lean
open Meta

initialize registerTraceClass `Rule.falseElim

/-- Determines whether a literal has can be unified with the form `False = True` or `True = False`. If it can
    be, then the substitution necessary to achieve that match is applied (if the match is unsuccessful, then
    the MCtx remains unchanged) -/
def isFalseLiteral (lit : Lit) : MetaM Bool := do
  if ← Meta.fastUnify #[(lit.lhs, mkConst ``False), (lit.rhs, mkConst ``True)] then return true
  else if ← Meta.fastUnify #[(lit.lhs, mkConst ``True), (lit.rhs, mkConst ``False)] then return true
  else return false

theorem false_ne_true (h : False = True) : False := by rw [h]; exact ⟨⟩
theorem true_ne_false (h : True = False) : False := by rw [← h]; exact ⟨⟩

def mkFalseElimProof (i : Nat) (premises : List Expr) (parents : List ProofParent) (transferExprs : Array Expr)
  (c : Clause) : MetaM Expr :=
  Meta.forallTelescope c.toForallExpr fun xs body => do
    let cLits := c.lits.map (fun l => l.map (fun e => e.instantiateRev xs))
    let (parentsLits, appliedPremises, transferExprs) ← instantiatePremises parents premises xs transferExprs
    let parentLits := parentsLits[0]!
    let appliedPremise := appliedPremises[0]!

    let mut caseProofs := Array.mkEmpty parentLits.size
    for j in [:parentLits.size] do
      let lit := parentLits[j]!
      if i == j then
        if lit.lhs == mkConst ``True then -- lit unified with `True = False`
          let pr ← Meta.withLocalDeclD `h lit.toExpr fun h => do
            let proofCase := mkApp (mkConst ``true_ne_false) h
            let proofCase := mkApp2 (mkConst ``False.elim [levelZero]) body proofCase
            Meta.mkLambdaFVars #[h] proofCase
          caseProofs := caseProofs.push pr
        else -- lit unified with `False = True`
          let pr ← Meta.withLocalDeclD `h lit.toExpr fun h => do
            let proofCase := mkApp (mkConst ``false_ne_true) h
            let proofCase := mkApp2 (mkConst ``False.elim [levelZero]) body proofCase
            Meta.mkLambdaFVars #[h] proofCase
          caseProofs := caseProofs.push pr
      else
        -- need proof of `L_j → L_1 ∨ ... ∨ L_n`
        let pr ← Meta.withLocalDeclD `h lit.toExpr fun h => do
          let idx := if j ≥ i then j - 1 else j
          Meta.mkLambdaFVars #[h] $ ← orIntro (cLits.map Lit.toExpr) idx h
        caseProofs := caseProofs.push pr

    let r ← orCases (parentLits.map Lit.toExpr) caseProofs
    Meta.mkLambdaFVars xs $ mkApp r appliedPremise

def falseElimAtLit (given : Clause) (c : MClause) (i : Nat) : RuleM (Array ClauseStream) :=
  withoutModifyingMCtx $ do
    let lit := c.lits[i]!
    let eligibility ← eligibilityPreUnificationCheck c i
    if eligibility == Eligibility.notEligible then return #[]
    let loaded ← getLoadedClauses
    let ug ← DUnif.UnifierGenerator.fromMetaMProcedure (isFalseLiteral lit)
    let yC := do
      setLoadedClauses loaded
      if (not $ ← eligibilityPostUnificationCheck c i eligibility (strict := true)) then return none
      let c := c.eraseLit i
      trace[Rule.falseElim] "Successfully yielded {c.lits} by removing literal {i}"
      yieldClause c "falseElim" $ some (mkFalseElimProof i)
    return #[ClauseStream.mk ug given yC "falseElim"]

/-- If there is a substitution σ and literal l in c such that σ(l) equates `True` and `False`, then
    falseElim yields the clause obtained by removing l from c and applying sigma to the rest of c -/
def falseElim (given : Clause) (c : MClause) (cNum : Nat) : RuleM (Array ClauseStream) := do
  trace[Rule.falseElim] "Running FalseElim on {c.lits}"
  let mut streams := #[]
  for i in [:c.lits.size] do
    if c.lits[i]!.sign then
      let str ← falseElimAtLit given c i
      streams := streams.append str
  return streams

end Duper


/-
Definitions and tactics for reasoning about the one-step effects of each assembly instruction.
-/
import starkware.cairo.lean.semantics.util
import starkware.cairo.lean.semantics.soundness.assembly
import starkware.cairo.lean.semantics.air_encoding.instruction

section main

@[class] def char_ge_2_63 (F : Type*) [field F] : Prop := ring_char F ≥ 2^63

variables {F : Type*} [field F]

/-
Reasoning about contents of memory.
-/

def mem_at (mem : F → F) : list F → F → Prop
| [] _        := true
| (v :: l) pc := mem pc = v ∧ mem_at l (pc + 1)

/-
The halting instruction is a relative jump to the same spot. In general, we don't prove that a
program will halt, but, rather, that *if* it halts it has the desired behavior. This is o.k.
because the STARK can certify that the computation has, in fact, halted.

To take a step forward, however, we need to verify that the current instruction is not a halting
instruction. The following lemmas help with do that efficiently.
-/

def jmp_rel_instr : instr := 'jmp_rel[ 'op1[imm] ]

section instr

variables (op0 : op0_spec) (op1 : op1_spec) (res : res_spec) (dst : dst_spec) (ap_update : bool)

lemma assert_eq_ne_jmp_rel :
  (assert_eq_instr op0 res dst ap_update).to_instruction ≠ jmp_rel_instr.to_instruction :=
begin
  intro h,
  have := congr_arg instruction.opcode_assert_eq h,
  contradiction
end

lemma call_ne_jmp_rel (call_abs : bool) :
  (call_instr call_abs res).to_instruction ≠ jmp_rel_instr.to_instruction :=
begin
  intro h,
  have := congr_arg instruction.opcode_call h,
  contradiction
end

lemma ret_ne_jmp_rel : ret_instr.to_instruction ≠ jmp_rel_instr.to_instruction :=
begin
  intro h,
  have := congr_arg instruction.opcode_ret h,
  contradiction
end

lemma advance_ap_ne_jmp_rel :
  (advance_ap_instr op0 res).to_instruction ≠ jmp_rel_instr.to_instruction :=
begin
  intro h,
  have := congr_arg instruction.ap_add h,
  contradiction
end

lemma jnz_ne_jmp_rel :
  (jnz_instr op0 op1 dst ap_update).to_instruction ≠ jmp_rel_instr.to_instruction :=
begin
  intro h,
  have := congr_arg instruction.pc_jnz h,
  contradiction
end

/-- Can be used unless the jump has an immediate argument, in which case instead we have to
    check that the immediate argument is not 0. -/
lemma jump_ne_jmp_rel (jump_abs : bool) (h : res.to_op1.op1_imm = ff) :
  (jump_instr jump_abs op0 res ap_update).to_instruction ≠ jmp_rel_instr.to_instruction :=
begin
  intro h',
  have := congr_arg instruction.op1_imm h',
  dsimp [jump_instr] at this,
  rw h at this,
  contradiction
end

end instr

/-
The definition of a halting execution trace and supporting lemmas.
-/

section halting

variable [decidable_eq F]
variable mem : F → F
variables s t : register_state F

def is_halting_state := mem s.pc = jmp_rel_instr.to_nat ∧ mem (s.pc + 1) = 0

lemma not_is_halting_state_iff {mem : F → F} {s : register_state F} :
  ¬ is_halting_state mem s ↔ mem s.pc ≠ jmp_rel_instr.to_nat ∨ mem (s.pc + 1) ≠ 0 :=
decidable.not_and_distrib

def is_halting_trace {n : ℕ} (exec : fin (n + 1) → register_state F) : Prop :=
  (∀ i : fin n, next_state mem (exec i.cast_succ) (exec i.succ)) ∧
  is_halting_state mem (exec (fin.last n))

theorem eq_succ_of_not_halting_state_0 {mem : F → F} {n : ℕ}
    {exec : fin (n + 1) → register_state F}
    (h : is_halting_trace mem exec)
    (h' : ¬ is_halting_state mem (exec 0)) :
  ∃ m : ℕ, n = m.succ :=
begin
  apply nat.exists_eq_succ_of_ne_zero,
  rintro rfl,
  exact h' h.2
end

theorem is_halting_trace_step {mem : F → F} {n : ℕ} {exec : fin (n.succ + 1) → register_state F}
    (h : is_halting_trace mem exec)
    (h' : ¬ is_halting_state mem (exec 0)) :
  is_halting_trace mem (λ i, exec i.succ) :=
begin
  split,
  { intro i, convert h.1 i.succ, rw [fin.cast_succ_fin_succ] },
  exact h.2
end

theorem is_halting_trace_remainder {m n : ℕ} {exec : fin (m + n + 1) → register_state F}
    (h : is_halting_trace mem exec) :
  is_halting_trace mem (λ j : fin (n + 1), exec (fin.cast_offset' m j)) :=
begin
  rcases h with ⟨h1, h2, h3⟩,
  rw is_halting_trace,
  refine ⟨_, h2, h3⟩,
  intro i,
  convert h1 (fin.cast_offset m i),
  rw [fin.cast_offset', fin.succ_cast_offset]
end

end halting

/-
The `ensures` predicate, and a bounded version.
-/

section ensures

variable [decidable_eq F]

/--
Given `mem` and start state `s`, any halting trace `exec` with `exec 0 = s` eventually reaches a
state `t` in `i` steps such that for some `k ≤ i`, `P k (exec i)`. We use the bound on `k` to
ensure a final claim about the range of values that have been range checked.
-/
def ensures (mem : F → F) (s : register_state F) (P : ℕ → register_state F → Prop) : Prop :=
  ∀ n : ℕ, ∀ exec : fin (n+1) → register_state F,
    is_halting_trace mem exec → exec 0 = s → ∃ i : fin (n + 1), ∃ k ≤ i, P k (exec i)

/-- for use with code blocks that end with a return -/
@[reducible] def ensures_ret (mem : F → F) (s : register_state F)
    (P : ℕ → register_state F → Prop) :
  Prop :=
ensures mem s (λ k t, t.pc = mem (s.fp - 1) ∧ t.fp = mem (s.fp - 2) ∧ P k t)

def ensuresb (bound : ℕ) (mem : F → F) (s : register_state F) (P : ℕ → register_state F → Prop) :
  Prop :=
∀ n : ℕ, n < bound → ∀ exec : fin (n+1) → register_state F,
  is_halting_trace mem exec → exec 0 = s → ∃ i : fin (n + 1), ∃ k ≤ i, P k (exec i)

theorem ensures_of_ensuresb {mem : F → F} {s : register_state F}
    {P : ℕ → register_state F → Prop}
    (h : ∀ bound, ensuresb bound mem s P) :
  ensures mem s P :=
λ n, h (n + 1) _ (nat.lt_succ_self n)

@[reducible] def ensuresb_ret (bound : ℕ) (mem : F → F) (s : register_state F)
    (P : ℕ → register_state F → Prop) :
  Prop :=
ensuresb bound mem s (λ k t, t.pc = mem (s.fp - 1) ∧ t.fp = mem (s.fp - 2) ∧ P k t)

theorem ensures_ret_of_ensuresb_ret {mem : F → F} {s : register_state F}
    {P : ℕ → register_state F → Prop}
    (h : ∀ bound, ensuresb_ret bound mem s P) :
  ensures_ret mem s P :=
λ n, h (n + 1) _ (nat.lt_succ_self n)

/-- Takes a step and augments `k` by 1. -/
theorem ensuresb_step {bound : ℕ}
    {mem : F → F} {s t : register_state F} {P : ℕ → register_state F → Prop}
    {Q : Prop}
    (h0 : ¬ is_halting_state mem s)
    (h1 : ∀ t', next_state mem s t' → t' = t ∧ Q)
    (h : Q → ensuresb bound mem t (λ k t', P (k + 1) t')) :
  ensuresb (bound + 1) mem s P :=
begin
  rintros n₀ n₀le exec h2 rfl,
  rcases eq_succ_of_not_halting_state_0 h2 h0 with ⟨n, rfl⟩,
  rcases h (h1 _ (h2.1 0)).2 n (nat.le_of_succ_le_succ n₀le) (λ i, exec i.succ)
      (is_halting_trace_step h2 h0) (h1 _ (h2.1 0)).1 with ⟨i, k, hik, h4⟩,
  use [i.succ, k.succ], split,
  { exact fin.succ_le_succ_iff.mpr hik },
  convert h4, simp
end

/- used to add a + 1 if necessary -/
theorem ensuresb_succ {bound : ℕ}
    {mem : F → F} {s : register_state F} {P : ℕ → register_state F → Prop}
    (h : ensuresb (bound + 1) mem s P) :
  ensuresb bound mem s P :=
λ n nlt, h _ (nlt.trans $nat.lt_succ_self _)

theorem ensuresb_test {bound : ℕ}
    {mem : F → F} {s : register_state F} {P : ℕ → register_state F → Prop}
    (h : ensuresb (bound + 1) mem s P) : ensuresb (bound + 1) mem s P := h

theorem ensuresb_trans {bound : ℕ}
    {mem : F → F} {s : register_state F} {P Q : ℕ → register_state F → Prop}
    (h0 : ensures mem s P)
    (h1 : ∀ k t, P k t → ensuresb bound mem t (λ k', Q (k + k'))) :
  ensuresb bound mem s Q :=
begin
  rintros n nlt exec h2 h3,
  rcases h0 _ _ h2 h3 with ⟨i, k, hik1, hik2⟩,
  rcases fin.exists_eq_add i with ⟨m, j, hm, rfl⟩,
  have : exec (fin.cast_offset' m 0) = exec i,
  { congr, ext, exact hm  },
  rcases h1 _ _ hik2 _ (lt_of_le_of_lt (nat.le_add_left _ _) nlt) _
    (is_halting_trace_remainder mem h2) this with ⟨i', k', hi'k', h4⟩,
  dsimp at h4,
  have : ↑k + j + 1 ≤ m + j + 1,
  { apply nat.succ_le_succ, apply nat.add_le_add_right, nth_rewrite_rhs 0 hm, exact hik1 },
  use [fin.cast_offset' m i', fin.cast_le this (fin.cast_offset' k k')],
  split,
  { rw fin.le_iff_coe_le_coe,
    simp [fin.cast_offset', fin.cast_offset],
    nth_rewrite_rhs 0 hm,
    rw fin.le_iff_coe_le_coe at hik1 hi'k',
    apply add_le_add hik1 hi'k' },
  exact h4
end

theorem ensuresb_rec_trans {bound : ℕ}
    {mem : F → F} {s : register_state F} {P Q : ℕ → register_state F → Prop}
    (h0 : ensuresb bound mem s P)
    (h1 : ∀ k t, P k t → ensuresb bound mem t (λ k', Q (k + k'))) :
  ensuresb bound mem s Q :=
begin
  rintros n nlt exec h2 h3,
  rcases h0 _ nlt _ h2 h3 with ⟨i, k, hik1, hik2⟩,
  rcases fin.exists_eq_add i with ⟨m, j, hm, rfl⟩,
  have : exec (fin.cast_offset' m 0) = exec i,
  { congr, ext, exact hm  },
  rcases h1 _ _ hik2 _ (lt_of_le_of_lt (nat.le_add_left _ _) nlt) _
    (is_halting_trace_remainder mem h2) this with ⟨i', k', hi'k', h4⟩,
  dsimp at h4,
  have : ↑k + j + 1 ≤ m + j + 1,
  { apply nat.succ_le_succ, apply nat.add_le_add_right, nth_rewrite_rhs 0 hm, exact hik1 },
  use [fin.cast_offset' m i', fin.cast_le this (fin.cast_offset' k k')],
  split,
  { rw fin.le_iff_coe_le_coe,
    simp [fin.cast_offset', fin.cast_offset],
    nth_rewrite_rhs 0 hm,
    rw fin.le_iff_coe_le_coe at hik1 hi'k',
    apply add_le_add hik1 hi'k' },
  exact h4
end

theorem ensuresb_id {bound : ℕ} {mem : F → F} {s : register_state F}
    {P : ℕ → register_state F → Prop} (h : P 0 s) :
  ensuresb (bound + 1) mem s P :=
begin
  intros n nlt exec hexec hexec0,
  use [0, 0, le_refl _],
  rwa hexec0
end

theorem ensuresb_rec {mem : F → F}
    (P : register_state F → F → ℕ → register_state F → Prop)
    (Haux : F → register_state F → Prop)
    (s : register_state F) (arg : F) (hHaux : Haux arg s)
    (hind : ∀ bound, (∀ (arg : F) (s: register_state F),
      Haux arg s → ensuresb bound mem s (P s arg)) →
        (∀ {arg : F}, ∀ {s: register_state F},
          Haux arg s → ensuresb (bound + 1) mem s (P s arg))) :
  ensures mem s (P s arg) :=
begin
  have : ∀ bound, (∀ {arg : F}, ∀ {s: register_state F},
      Haux arg s → ensuresb bound mem s (P s arg)),
  { intro bound,
    induction bound with bound ih,
    { intros _ _ _ n nlt, exact absurd nlt (nat.not_lt_zero _)},
    apply hind, exact @ih },
  apply ensures_of_ensuresb (λ bound, this bound hHaux)
end

-- for handling blocks
theorem ensuresb_ret_trans {bound : ℕ}
    {mem : F → F} {s : register_state F} {P Q : ℕ → register_state F → Prop}
    (h0 : ensuresb_ret bound mem s P)
    (h1 : ∀ k t, P k t → Q k t) :
  ensuresb_ret bound mem s Q :=
begin
  rintros n nlt exec h2 h3,
  rcases h0 _ nlt _ h2 h3 with ⟨i, k, hik1, hik2, hik3, hik4⟩,
  use [i, k, hik1, hik2, hik3, h1 _ _ hik4]
end

end ensures

/-
Characterize next state transitions.
-/

section next_state

variable [decidable_eq F]

lemma instruction.next_state_iff_of_eq [char_ge : char_ge_2_63 F] {i : instruction}
    {mem : F → F} {s t : register_state F} (h : mem s.pc = i.to_nat) :
  next_state mem s t ↔ i.next_state mem s t :=
begin
  rw [next_state], split,
  { rintros ⟨i', i'eq, i'next_state⟩,
    have : i = i' := inst_unique char_ge _ _ (h.symm.trans i'eq),
    rwa this },
  intro h', use [i, h, h']
end

variable {mem : F → F}
variable {s : register_state F}
variable {P : ℕ → register_state F → Prop}

theorem assert_eq_ensuresb' [char_ge : char_ge_2_63 F] {bound : ℕ}
    {op0 : op0_spec} {res : res_spec} {dst : dst_spec} {ap_update : bool}
    (h  : mem s.pc = (assert_eq_instr op0 res dst ap_update).to_nat)
    (h' : compute_dst mem s dst = compute_res mem s op0 res →
      ensuresb bound mem ⟨bump_pc s res.to_op1.op1_imm, bump_ap s ap_update, s.fp⟩
        (λ k t, P (k + 1) t)) :
  ensuresb (bound + 1) mem s P :=
begin
  intros n nlt exec,
  have h1 : ¬ is_halting_state mem s,
  { rw not_is_halting_state_iff, left, rw h,
    intro h0,
    exact assert_eq_ne_jmp_rel _ _ _ _ (inst_unique char_ge _ _ h0) },
  have h2 : ∀ t, next_state mem s t →
      t = ⟨bump_pc s res.to_op1.op1_imm, bump_ap s ap_update, s.fp⟩ ∧
        compute_dst mem s dst = compute_res mem s op0 res,
  { intros t ht,
    rw [instruction.next_state_iff_of_eq h, ←instr.next_state, next_state_assert_eq] at ht,
    simp [ht],
    ext; simp [ht] },
  apply ensuresb_step h1 h2 h' _ nlt
end

theorem jump_ensuresb [char_ge : char_ge_2_63 F] {bound}
    {op0 : op0_spec} {res : res_spec} {ap_update : bool} {jump_abs : bool}
    (h : mem s.pc = (jump_instr jump_abs op0 res ap_update).to_nat)
    (h_aux : res.to_op1.op1_imm = ff)
    (h' : ensuresb bound mem ⟨jump_pc s jump_abs (compute_res mem s op0 res),
      bump_ap s ap_update, s.fp⟩ (λ k t, P (k + 1) t)) :
  ensuresb (bound + 1) mem s P :=
begin
  intros n nlt exec,
  have h1 : ¬ is_halting_state mem s,
  { rw not_is_halting_state_iff, left, rw h,
    intro h0,
    exact jump_ne_jmp_rel _ _ _ _ h_aux (inst_unique char_ge _ _ h0) },
  have h2 : ∀ t, next_state mem s t →
      t = ⟨jump_pc s jump_abs (compute_res mem s op0 res), bump_ap s ap_update, s.fp⟩ ∧ true,
  { intros t ht,
    rw [instruction.next_state_iff_of_eq h, ←instr.next_state, next_state_jump] at ht,
    split, ext; simp [ht], trivial },
  apply ensuresb_step h1 h2 (λ _, h') _ nlt
end

def checked_int_nz (x : ℤ) (h0 : abs x ≠ 0) (h1 : abs x < 2^63) := x

lemma checked_int_nz_eq (x : ℤ) (h0 : abs x ≠ 0) (h1 : abs x < 2^63) :
  checked_int_nz x h0 h1 = x := rfl

meta def abs_lt_tac : tactic unit :=
`[ { rw abs_of_nonneg, norm_num, norm_num } <|> { rw abs_of_nonpos, norm_num, norm_num } ]

notation `'[#nz` x `]` := checked_int_nz x (by norm_num) (by abs_lt_tac)

theorem jump_ensuresb' [char_ge : char_ge_2_63 F] {bound : ℕ}
    {op0 : op0_spec} {res : res_spec} {ap_update : bool} {jump_abs : bool}
    (h : mem s.pc = (jump_instr jump_abs op0 res ap_update).to_nat)
    {x : ℤ} {h0 : abs x ≠ 0} {h1 : abs x < 2^63}
    (h_aux : mem (s.pc + 1) = checked_int_nz x h0 h1)
    (h' : ensuresb bound mem ⟨jump_pc s jump_abs (compute_res mem s op0 res),
      bump_ap s ap_update, s.fp⟩ (λ k t, P (k + 1) t)) :
  ensuresb (bound + 1) mem s P :=
begin
  intros n nlt exec,
  have h1 : ¬ is_halting_state mem s,
  { rw [not_is_halting_state_iff, h_aux], right,
    apply int.cast_ne_zero_of_abs_lt_char h0,
    apply lt_of_lt_of_le h1,
    change ((2^ 63 : ℕ) : ℤ) ≤ _,
    rw int.coe_nat_le_coe_nat_iff,
    apply char_ge },
  have h2 : ∀ t, next_state mem s t →
      t = ⟨jump_pc s jump_abs (compute_res mem s op0 res), bump_ap s ap_update, s.fp⟩ ∧ true,
  { intros t ht,
    rw [instruction.next_state_iff_of_eq h, ←instr.next_state, next_state_jump] at ht,
    split, ext; simp [ht], trivial },
  apply ensuresb_step h1 h2 (λ _, h') _ nlt
end

theorem jnz_ensuresb [char_ge : char_ge_2_63 F] {bound : ℕ}
    {op0 : op0_spec} {op1 : op1_spec} {dst : dst_spec} {ap_update : bool}
    (h  : mem s.pc = (jnz_instr op0 op1 dst ap_update).to_nat)
    (h₀ : compute_dst mem s dst = 0 →
      ensuresb bound mem ⟨bump_pc s op1.op1_imm, bump_ap s ap_update, s.fp⟩ (λ k t, P (k + 1) t))
    (h₁ : compute_dst mem s dst ≠ 0 →
      ensuresb bound mem ⟨s.pc + compute_op1 mem s op0 op1, bump_ap s ap_update, s.fp⟩
        (λ k t, P (k + 1) t)) :
  ensuresb (bound + 1) mem s P :=
begin
  intros n nlt exec,
  have h1 : ¬ is_halting_state mem s,
  { rw not_is_halting_state_iff, left, rw h,
    intro h0,
    exact jnz_ne_jmp_rel _ _ _ _ (inst_unique char_ge _ _ h0) },
  have h2 : ∀ t, next_state mem s t →
      t = ⟨ite (compute_dst mem s dst = 0) (bump_pc s op1.op1_imm)
            (s.pc + compute_op1 mem s op0 op1),  bump_ap s ap_update, s.fp⟩ ∧
        true,
  { intros t ht,
    rw [instruction.next_state_iff_of_eq h, ←instr.next_state, next_state_jnz] at ht,
    simp [ht],
    ext; simp [ht] },
  apply ensuresb_step h1 h2 _ _ nlt,
  by_cases h3 : compute_dst mem s dst = 0,
  { intro _,
    rw if_pos h3,
    exact h₀ h3 },
  intro _,
  rw if_neg h3,
  exact h₁ h3
end

theorem call_ensuresb [char_ge : char_ge_2_63 F] {bound : ℕ} {res : res_spec} {call_abs : bool}
    (h  : mem s.pc = (call_instr call_abs res).to_nat)
    (h' : mem s.ap = s.fp →
            mem (s.ap + 1) = bump_pc s res.to_op1.op1_imm →
            ensuresb bound mem ⟨jump_pc s call_abs (compute_res mem s (op0_spec.ap_plus 1) res),
              s.ap + 2, s.ap + 2⟩ (λ k t, P (k + 1) t)) :
  ensuresb (bound + 1) mem s P :=
begin
  intros n nlt exec,
  have h1 : ¬ is_halting_state mem s,
  { rw not_is_halting_state_iff, left, rw h,
    intro h0,
    exact call_ne_jmp_rel _ _ (inst_unique char_ge _ _ h0) },
  have h2 : ∀ t, next_state mem s t →
      t = ⟨jump_pc s call_abs (compute_res mem s (op0_spec.ap_plus 1) res), s.ap + 2, s.ap + 2⟩ ∧
        mem (s.ap + 1) = bump_pc s res.to_op1.op1_imm ∧ mem s.ap = s.fp,
  { intros t ht,
    rw [instruction.next_state_iff_of_eq h, ←instr.next_state, next_state_call] at ht,
    simp [ht],
    ext; simp [ht] },
  apply ensuresb_step h1 h2 _ _ nlt,
  intro h3,
  apply h' h3.2 h3.1
end

theorem ret_ensuresb [char_ge : char_ge_2_63 F] {bound : ℕ}
    (h  : mem s.pc = ret_instr.to_nat)
    (h' : ensuresb bound mem ⟨mem (s.fp + -1), s.ap, mem (s.fp - 2)⟩ (λ k t, P (k + 1) t)) :
  ensuresb (bound + 1) mem s P :=
begin
  intros n nlt exec,
  have h1 : ¬ is_halting_state mem s,
  { rw not_is_halting_state_iff, left, rw h,
    intro h0,
    exact ret_ne_jmp_rel (inst_unique char_ge _ _ h0) },
  have h2 : ∀ t, next_state mem s t →
      t = ⟨mem (s.fp + -1), s.ap, mem (s.fp - 2)⟩ ∧ true,
  { intros t ht,
    rw [instruction.next_state_iff_of_eq h, ←instr.next_state, next_state_ret] at ht,
    simp [ht],
    ext; simp [ht] },
  apply ensuresb_step h1 h2 (λ _, h') _ nlt
end

theorem call_ensuresb_trans [char_ge : char_ge_2_63 F] {bound : ℕ}
    {P Q : ℕ → register_state F → Prop}
    {res : res_spec} {call_abs : bool} {x : F}
    (h₀ : mem s.pc = x)
    (h₁ : x = (call_instr call_abs res).to_nat)
    (h₂ : ensures_ret mem ⟨jump_pc s call_abs (compute_res mem s (op0_spec.ap_plus 1) res),
            s.ap + 2, s.ap + 2⟩ P)
    (h₃ : ∀ k ap, P k ⟨bump_pc s res.to_op1.op1_imm, ap, s.fp⟩ →
            ensuresb bound mem ⟨bump_pc s res.to_op1.op1_imm, ap, s.fp⟩ (λ k', Q (k + k' + 1))) :
  ensuresb (bound + 1) mem s Q :=
begin
  apply call_ensuresb (h₀.trans h₁),
  intros h1 h2,
  apply ensuresb_trans h₂, dsimp,
  rintros k ⟨tpc, tap, tfp⟩, dsimp,
  rw [add_sub_assoc, add_sub_assoc, sub_self, add_zero], norm_num1,
  rw [h1, h2],
  rintros ⟨rfl, rfl, hP⟩,
  apply h₃ _ _ hP
end

theorem call_rec_ensuresb_trans [char_ge : char_ge_2_63 F] {bound : ℕ}
    {P Q : ℕ → register_state F → Prop}
    {res : res_spec} {call_abs : bool} {x : F}
    (h₀ : mem s.pc = x)
    (h₁ : x = (call_instr call_abs res).to_nat)
    (h₂ : ensuresb_ret bound mem ⟨jump_pc s call_abs (compute_res mem s (op0_spec.ap_plus 1) res),
            s.ap + 2, s.ap + 2⟩ P)
    (h₃ : ∀ k ap, P k ⟨bump_pc s res.to_op1.op1_imm, ap, s.fp⟩ →
            ensuresb bound mem ⟨bump_pc s res.to_op1.op1_imm, ap, s.fp⟩ (λ k', Q (k + k' + 1))) :
  ensuresb (bound + 1) mem s Q :=
begin
  apply call_ensuresb (h₀.trans h₁),
  intros h1 h2,
  apply ensuresb_rec_trans h₂, dsimp,
  rintros k ⟨tpc, tap, tfp⟩, dsimp,
  rw [add_sub_assoc, add_sub_assoc, sub_self, add_zero], norm_num1,
  rw [h1, h2],
  rintros ⟨rfl, rfl, hP⟩,
  apply h₃ _ _ hP
end

theorem advance_ap_ensuresb [char_ge : char_ge_2_63 F] {bound : ℕ}
    {op0 : op0_spec} {res : res_spec}
    (h  : mem s.pc = (advance_ap_instr op0 res).to_nat)
    (h' : ensuresb bound mem ⟨bump_pc s res.to_op1.op1_imm, s.ap + compute_res mem s op0 res, s.fp⟩
      (λ k t, P (k + 1) t)) :
  ensuresb (bound + 1) mem s P :=
begin
  intros n nlt exec,
  have h1 : ¬ is_halting_state mem s,
  { rw not_is_halting_state_iff, left, rw h,
    intro h0,
    exact advance_ap_ne_jmp_rel _ _ (inst_unique char_ge _ _ h0) },
  have h2 : ∀ t, next_state mem s t →
      t = ⟨bump_pc s res.to_op1.op1_imm, s.ap + compute_res mem s op0 res, s.fp⟩ ∧ true,
  { intros t ht,
    rw [instruction.next_state_iff_of_eq h, ←instr.next_state, next_state_advance_ap] at ht,
    simp [ht],
    ext; simp [ht] },
  apply ensuresb_step h1 h2 (λ _, h') _ nlt
end

end next_state

/-
Theorems to handle the range-checked hypotheses.
-/

def is_range_checked (rc_bound : ℕ) (a : F) : Prop := ∃ n : ℕ, n < rc_bound ∧ a = ↑n

def range_checked (mem : F → F) (rc_start : F) (k rc_bound : ℕ) : Prop :=
  ∀ i < k, is_range_checked rc_bound (mem (rc_start + i))

theorem range_checked_mono {mem : F → F} {rc_start : F} {k rc_bound : ℕ}
    (k' : ℕ) (k'le : k' ≤ k)
    (h : range_checked mem rc_start k rc_bound) :
  range_checked mem rc_start k' rc_bound :=
λ i iltk', h i (lt_of_lt_of_le iltk' k'le)

theorem range_checked_add_left {mem : F → F} {rc_start : F} {k' k rc_bound : ℕ}
    (h : range_checked mem rc_start (k' + k) rc_bound) :
  range_checked mem rc_start k rc_bound :=
range_checked_mono _ (nat.le_add_left _ _) h

theorem range_checked_add_right {mem : F → F} {rc_start : F} {k' k rc_bound : ℕ}
    (h : range_checked mem rc_start (k + k') rc_bound) :
  range_checked mem rc_start k rc_bound :=
range_checked_mono _ (nat.le_add_right _ _) h

theorem range_checked_offset {mem : F → F} {rc_start : F} {k' k rc_bound : ℕ}
    (h : range_checked mem rc_start (k + k') rc_bound) :
  range_checked mem (rc_start + k') k rc_bound :=
begin
  intros i iltk,
  rcases h _ (add_lt_add_right iltk k') with ⟨i', hi'⟩,
  use i', rwa [add_assoc, ←nat.cast_add, add_comm k']
end

theorem range_checked_offset' {mem : F → F} {rc_start : F} {k' k rc_bound : ℕ}
    (h : range_checked mem rc_start (k + k') rc_bound) :
  range_checked mem (rc_start + k) k' rc_bound :=
by { rw add_comm at h, exact range_checked_offset h }

def rc_ensures (mem : F → F) (rc_bound k : ℕ) (a0 a1 : F) (P : Prop) :=
a1 = a0 + k ∧ (range_checked mem a0 k rc_bound → P)

theorem rc_ensures_comp {mem : F → F} {rc_bound k0 k1 : ℕ} {a0 a1 a2 : F} {P Q : Prop}
    (h0 : rc_ensures mem rc_bound k0 a0 a1 P)
    (h1 : rc_ensures mem rc_bound k1 a1 a2 Q) :
  rc_ensures mem rc_bound (k0 + k1) a0 a2 (P ∧ Q) :=
begin
  rcases h0 with ⟨hk0, rc0⟩,
  rcases h1 with ⟨hk1, rc1⟩,
  split,
  { rw [hk1, hk0, add_assoc, nat.cast_add] },
  intro h, split,
  { exact rc0 (range_checked_add_right h) },
  apply rc1, rw hk0, exact range_checked_offset' h
end

theorem rc_ensures_trans {mem : F → F} {rc_bound k : ℕ} {a0 a1 : F} {P Q : Prop}
    (h1 : rc_ensures mem rc_bound k a0 a1 P)
    (h2 : P → Q) :
   rc_ensures mem rc_bound k a0 a1 Q :=
begin
  rcases h1 with ⟨hk, h⟩,
  exact ⟨hk, λ h', h2 (h h')⟩
end

end main

/-
Tactics.
-/

lemma add_neg_eq_sub {G : Type*} [add_group G] (a b : G) : a + -b = a - b := by rw sub_eq_add_neg
lemma sub_add_eq_add_neg_add {G : Type*} [add_group G] (a b c : G) :
  a - b + c = a + (-b + c) := by rw [sub_eq_add_neg, add_assoc]

namespace tactic
setup_tactic_parser

variables (F : Type*) [field F]

def loc_target : loc := loc.ns [none]

meta def mk_simp_arg_list : list pexpr → list simp_arg_type
| []        := []
| (p :: ps) := simp_arg_type.expr p :: mk_simp_arg_list ps

namespace interactive

meta def arith_simps (loc : parse location) : tactic unit :=
let cfg : simp_config_ext := {},
    simp_args := mk_simp_arg_list [
    ``(int.cast_zero), ``(int.cast_one), ``(int.cast_bit0), ``(int.cast_bit1), ``(int.cast_neg),
    ``(nat.cast_zero), ``(nat.cast_one), ``(nat.cast_bit0), ``(nat.cast_bit1),
    ``(add_assoc), ``(add_sub_assoc), ``(add_zero), ``(add_right_neg), ``(add_left_neg),
        ``(add_neg_eq_sub), ``(sub_add_eq_add_neg_add), ``(mul_assoc)] in
do try $ simp_core cfg.to_simp_config cfg.discharger tt simp_args [] loc >> skip,
   try $ (tactic.norm_num1 norm_num.derive.step loc >>
   (try $ simp_core cfg.to_simp_config cfg.discharger tt simp_args [] loc >> skip))

meta def ensures_simps (loc : parse location) : tactic unit :=
let cfg : simp_config_ext := {},
    simp_args := mk_simp_arg_list [``(res_spec.to_op1), ``(compute_res), ``(compute_op1),
      ``(compute_op0), ``(op1_spec.op1_imm), ``(compute_dst), ``(bump_pc), ``(bump_ap),
      ``(jump_pc), ``(clip_checked), ``(checked_int_nz_eq),
    ``(int.cast_zero), ``(int.cast_one), ``(int.cast_bit0), ``(int.cast_bit1), ``(int.cast_neg),
    ``(nat.cast_zero), ``(nat.cast_one), ``(nat.cast_bit0), ``(nat.cast_bit1),
    ``(add_assoc), ``(add_sub_assoc), ``(add_zero), ``(add_right_neg), ``(add_left_neg),
        ``(add_neg_eq_sub), ``(sub_add_eq_add_neg_add), ``(mul_assoc)] in
do try $ simp_core cfg.to_simp_config cfg.discharger tt simp_args [] loc >> skip,
   try (tactic.norm_num1 norm_num.derive.step loc >>
   (try $ simp_core cfg.to_simp_config cfg.discharger tt simp_args [] loc >> skip))

meta def unpack_memory (code : parse ident) (h : parse $ tk "at" *> ident)
  (pat : parse $ tk "with" *>rcases_patt_parse) : tactic unit :=
let cfg : simp_config_ext := {},
    simp_args := mk_simp_arg_list [``(mem_at), ``(add_assoc), ``(and_true)] in
do unfold [code] (loc.ns [h]),
   try $ simp_core cfg.to_simp_config cfg.discharger tt simp_args [] (loc.ns [h]) >> skip,
   try $ tactic.norm_num1 norm_num.derive.step (loc.ns [h]),
   eh ← resolve_name h,
   rcases (rcases_args.rcases none eh pat)

meta def ensuresb_make_succ : tactic unit :=
  (applyc ``ensuresb_test) <|> (applyc ``ensuresb_succ)

meta def step_assert_eq (h : parse ident) (h' : parse ident?)
    (hw : parse $ tk "with" *> ident) :=
do ensuresb_make_succ,
   applyc ``assert_eq_ensuresb',
   eh ← get_local h,
   tactic.apply eh,
   tactic.clear eh,
   ensures_simps loc_target,
   match h' with
   | (some n) := do eh ← get_local n,
                    try $ tactic.rewrite_target eh >> tactic.clear eh --,
                    -- ensures_simps loc_target
   | none     := skip
   end,
   intro hw

meta def step_jump (h : parse ident) :=
do ensuresb_make_succ,
   applyc ``jump_ensuresb,
   eh ← get_local h,
   tactic.apply eh,
   tactic.clear eh,
   /- first subgoal: not an immediate argument-/
   tactic.reflexivity,
   /- main goal -/
   ensures_simps loc_target

meta def step_jump_imm (h : parse ident) (h' : parse ident) :=
do ensuresb_make_succ,
   applyc ``jump_ensuresb',
   eh ← get_local h,
   tactic.apply eh,
   arith_simps loc_target,
   eh' ← get_local h',
   tactic.apply eh',
   /- main goal -/
   ensures_simps loc_target,
   eh' ← get_local h',
   try $ tactic.rewrite_target eh',
   tactic.clear eh,
   tactic.clear eh',
   ensures_simps loc_target

meta def step_jnz (h : parse ident) (h' : parse ident?)
  (hw : parse $ tk "with" *> ident) (hw' : parse ident):=
do ensuresb_make_succ,
   applyc ``jnz_ensuresb,
   eh ← get_local h,
   tactic.apply eh,
   tactic.clear eh,
   swap,
   tactic.clear eh,
   focus $ do { ensures_simps loc_target },
   match h' with
   | (some n) := do eh ← get_local n,
                    try $ tactic.rewrite_target eh >> tactic.clear eh,
                    ensures_simps loc_target
   | none     := skip
   end,
   ehw' ← tactic.intro hw',
   try $ tactic.rewrite_target eh,
   swap,
   focus $ do { ensures_simps loc_target },
   intro hw,
   match h' with
   | (some n) := do eh ← get_local n,
                    try $ tactic.rewrite_target eh >> tactic.clear eh,
                    ensures_simps loc_target
   | none     := skip
   end

meta def step_call (h : parse ident) :=
do ensuresb_make_succ,
   applyc ``call_ensuresb,
   eh ← get_local h,
   tactic.apply eh,
   tactic.clear eh,
   ensures_simps loc_target

meta def step_ret (h : parse ident) :=
do ensuresb_make_succ,
   applyc ``ret_ensuresb,
   eh ← get_local h,
   tactic.apply eh,
   tactic.clear eh,
   ensures_simps loc_target

meta def step_advance_ap (h : parse ident) (h' : parse ident?) :=
do ensuresb_make_succ,
   applyc ``advance_ap_ensuresb,
   eh ← get_local h,
   tactic.apply eh,
   tactic.clear eh,
   ensures_simps loc_target,
   match h' with
   | (some n) := do eh ← get_local n,
                    try $ tactic.rewrite_target eh >> tactic.clear eh,
                    ensures_simps loc_target
   | none     := skip
   end

meta def step_sub (h1 : parse ident) (h2 : parse parser.pexpr) :
  tactic unit :=
focus1 $ do
  eh ← get_local h1,
  ensuresb_make_succ,
  apply ``(call_ensuresb_trans _ %%eh %%h2 _),
  refl,
  all_goals' (tactic.clear eh >> ensures_simps loc_target)

meta def step_rec_sub (h1 : parse ident) (h2 : parse parser.pexpr) :
  tactic unit :=
focus1 $ do
  eh ← get_local h1,
  ensuresb_make_succ,
  apply ``(call_rec_ensuresb_trans _ %%eh %%h2 _),
  refl,
  all_goals' (tactic.clear eh >> ensures_simps loc_target)

meta def step_done : tactic unit :=
`[ ensuresb_make_succ, apply ensuresb_id ]

/-- A weaker version of the interactive `use` tactic, which doesn't call `triv` -/
meta def use_only (l : parse pexpr_list_or_texpr) : tactic unit :=
focus1 $ tactic.use l

/-- norm_num1 plus an extra simp rule -/
meta def norm_num2 : tactic unit :=
`[ norm_num1, try { simp only [add_neg_eq_sub] } ]

section
open interactive interactive.types expr

private meta def mkdef_arg_p_aux : pexpr → parser (name × pexpr)
| (app (app (macro _ [const `eq _ ]) (local_const x _ _ _)) h) := pure (x, h)
| _ := fail "parse error"

private meta def mkdef_arg_p : parser (name × pexpr) :=
with_desc "expr = id" $ parser.pexpr 0 >>= mkdef_arg_p_aux

/--
`mkdef h : x = t` introduces a new variable `x` into the context with
assumption `h : x = t`. It is essentially a simplified version of
`generalize'` with the equation syntax reversed.
-/
meta def mkdef (h : parse ident) (_ : parse $ tk ":") (p : parse mkdef_arg_p) :
  tactic unit :=
propagate_tags $
do let (x, p) := p,
   e ← i_to_expr p,
   tgt ← target,
   tgt' ← to_expr ``(Π x, x = %%e → %%tgt),
   t ← assert h tgt',
   swap,
   exact ``(%%t %%e rfl),
   intro x,
   intro h
end

end interactive

end tactic

/-
Some useful things for the autogenerated proofs.
-/

section

theorem assert_eq_reduction {F : Type} {a b c d : F} (h : c = d) (h' : a = c ∧ d = b) :
  a = b := (h'.1.trans h).trans h'.2

variables {F : Type*} [field F]

lemma cond_aux1 {a b t : F} (h1 : t = a - b) (h2 : t = 0) : a = b :=
by { rw h2 at h1, exact eq_of_sub_eq_zero h1.symm }

lemma cond_aux2 {a b t : F} (h1 : t = a - b) (h2 : t ≠ 0) : a ≠ b :=
by { intro h3, apply h2, rwa [h3, sub_self] at h1 }

lemma eq_sub_of_eq_add {a b c : F} (h: b = a + c) : a = b - c :=
eq_sub_of_add_eq h.symm

-- a trick for inferring the value of the ap at proof time
lemma of_register_state [decidable_eq F] {bound : ℕ}
    {mem : F → F} {s : register_state F} {P : ℕ → register_state F → Prop} :
  (∀ x, x = s → ensuresb bound mem s P) →
    ensuresb bound mem s P :=
λ h, h s rfl

/-- division with a default value -/
def ddiv [decidable_eq F] (a b c : F) : F := if b ≠ 0 then a / b else c

theorem ddiv_eq [decidable_eq F] {a b c : F} (h : b ≠ 0) : ddiv a b c = a / b :=
if_pos h

theorem eq_ddiv_of_eq_mul [decidable_eq F] {a b c : F} (h : a = c * b) : c = ddiv a b c :=
begin
  by_cases h' : b ≠ 0,
  { rw [ddiv, if_pos h', eq_div_iff h', h] },
  rw [ddiv, if_neg h']
end

theorem exists_eq_ddiv_of_eq_mul [decidable_eq F] {a b c : F} (h : a = c * b) :
  ∃ d, c = ddiv a b d :=
⟨c, eq_ddiv_of_eq_mul h⟩

-- for handling division by a constant
lemma div_eq_mul_inv' {F : Type*} [field F]  {x y z : F}
  (h : y * z = 1) : x / y = x * z :=
begin
  have : y ≠ 0,
  { intro yzero, simp [yzero] at h, contradiction },
  symmetry, apply eq_div_of_mul_eq this,
  rw [mul_assoc, mul_comm z, h, mul_one],
end

end


-- https://github.com/dwrensha/lean4-maze/blob/main/Maze.lean

import Lean

-- Turn off pp.analyze. When pp.analyze is set to true (the default), some of our
-- larger mazes take a long time to display.
set_option pp.analyze false

-- Coordinates in a two dimensional grid. ⟨0,0⟩ is the upper left.
structure Coords where
  x : Nat -- column number
  y : Nat -- row number
deriving BEq

instance : ToString Coords where
  toString := (λ ⟨x,y⟩ => String.join ["Coords.mk ", toString x, ", ", toString y])

structure GameState where
  size     : Coords      -- coordinates of bottom-right cell
  position : Coords      -- row and column of the player
  walls    : List Coords -- maze cells that are not traversible

-- We define custom syntax for GameState.

declare_syntax_cat game_cell
declare_syntax_cat game_cell_sequence
declare_syntax_cat game_row
declare_syntax_cat horizontal_border
declare_syntax_cat game_top_row
declare_syntax_cat game_bottom_row

syntax "─" : horizontal_border

syntax "\n┌" horizontal_border* "┐\n" : game_top_row

syntax "└" horizontal_border* "┘\n" : game_bottom_row

syntax "░" : game_cell -- empty
syntax "▓" : game_cell -- wall
syntax "@" : game_cell -- player

syntax "│" game_cell* "│\n" : game_row

syntax:max game_top_row game_row* game_bottom_row : term

inductive CellContents where
  | empty  : CellContents
  | wall   : CellContents
  | player : CellContents

def update_state_with_row_aux : Nat → Nat → List CellContents → GameState → GameState
| currentRowNum, currentColNum, [], oldState => oldState
| currentRowNum, currentColNum, cell::contents, oldState =>
    let oldState' := update_state_with_row_aux currentRowNum (currentColNum+1) contents oldState
    match cell with
    | CellContents.empty => oldState'
    | CellContents.wall => {oldState' .. with
                            walls := ⟨currentColNum,currentRowNum⟩::oldState'.walls}
    | CellContents.player => {oldState' .. with
                              position := ⟨currentColNum,currentRowNum⟩}

def update_state_with_row : Nat → List CellContents → GameState → GameState
| currentRowNum, rowContents, oldState => update_state_with_row_aux currentRowNum 0 rowContents oldState

-- size, current row, remaining cells -> gamestate
def game_state_from_cells_aux : Coords → Nat → List (List CellContents) → GameState
| size, _, [] => ⟨size, ⟨0,0⟩, []⟩
| size, currentRow, row::rows =>
        let prevState := game_state_from_cells_aux size (currentRow + 1) rows
        update_state_with_row currentRow row prevState

-- size, remaining cells -> gamestate
def game_state_from_cells : Coords → List (List CellContents) → GameState
| size, cells => game_state_from_cells_aux size 0 cells

def termOfCell : Lean.Macro
| `(game_cell| ░) => `(CellContents.empty)
| `(game_cell| ▓) => `(CellContents.wall)
| `(game_cell| @) => `(CellContents.player)
| _ => Lean.Macro.throwError "unknown game cell"

def termOfGameRow : Nat → Lean.Macro
| expectedRowSize, `(game_row| │$cells:game_cell*│) =>
      do if cells.size != expectedRowSize
         then Lean.Macro.throwError "row has wrong size"
         let cells' ← Array.mapM termOfCell cells
         `([$cells',*])
| _, _ => Lean.Macro.throwError "unknown game row"

macro_rules
| `(┌ $tb:horizontal_border* ┐
    $rows:game_row*
    └ $bb:horizontal_border* ┘) =>
      do let rsize := Lean.Syntax.mkNumLit (toString rows.size)
         let csize := Lean.Syntax.mkNumLit (toString tb.size)
         if tb.size != bb.size then Lean.Macro.throwError "top/bottom border mismatch"
         let rows' ← Array.mapM (termOfGameRow tb.size) rows
         `(game_state_from_cells ⟨$csize,$rsize⟩ [$rows',*])

---------------------------
-- Now we define a delaborator that will cause GameState to be rendered as a maze.

def extractXY : Lean.Expr → Lean.MetaM Coords
| e => do
  let e':Lean.Expr ← (Lean.Meta.whnf e)
  let sizeArgs := Lean.Expr.getAppArgs e'
  let f := Lean.Expr.getAppFn e'
  let x ← Lean.Meta.whnf sizeArgs[0]
  let y ← Lean.Meta.whnf sizeArgs[1]
  let numCols := (Lean.Expr.natLit? x).get!
  let numRows := (Lean.Expr.natLit? y).get!
  Coords.mk numCols numRows

partial def extractWallList : Lean.Expr → Lean.MetaM (List Coords)
| exp => do
  let exp':Lean.Expr ← (Lean.Meta.whnf exp)
  let f := Lean.Expr.getAppFn exp'
  if f.constName!.toString == "List.cons"
  then let consArgs := Lean.Expr.getAppArgs exp'
       let rest ← extractWallList consArgs[2]
       let ⟨wallCol, wallRow⟩ ← extractXY consArgs[1]
       (Coords.mk wallCol wallRow) :: rest
  else [] -- "List.nil"

partial def extractGameState : Lean.Expr → Lean.MetaM GameState
| exp => do
    let exp': Lean.Expr ← (Lean.Meta.whnf exp)
    let gameStateArgs := Lean.Expr.getAppArgs exp'
    let size ← extractXY gameStateArgs[0]
    let playerCoords ← extractXY gameStateArgs[1]
    let walls ← extractWallList gameStateArgs[2]
    pure ⟨size, playerCoords, walls⟩

def update2dArray {α : Type} : Array (Array α) → Coords → α → Array (Array α)
| a, ⟨x,y⟩, v =>
   Array.set! a y $ Array.set! (Array.get! a y) x v

def update2dArrayMulti {α : Type} : Array (Array α) → List Coords → α → Array (Array α)
| a, [], v => a
| a, c::cs, v =>
     let a' := update2dArrayMulti a cs v
     update2dArray a' c v

def delabGameRow : (Array Lean.Syntax) → Lean.PrettyPrinter.Delaborator.Delab
| a => `(game_row| │ $a:game_cell* │)

def delabGameState : Lean.Expr → Lean.PrettyPrinter.Delaborator.Delab
| e =>
  do guard $ e.getAppNumArgs == 3
     let ⟨⟨numCols, numRows⟩, playerCoords, walls⟩ ←
       try extractGameState e
       catch err => failure -- can happen if game state has variables in it

     let topBar := Array.mkArray numCols $ ← `(horizontal_border| ─)
     let emptyCell ← `(game_cell| ░)
     let emptyRow := Array.mkArray numCols emptyCell
     let emptyRowStx ← `(game_row| │$emptyRow:game_cell*│)
     let allRows := Array.mkArray numRows emptyRowStx

     let a0 := Array.mkArray numRows $ Array.mkArray numCols emptyCell
     let a1 := update2dArray a0 playerCoords $ ← `(game_cell| @)
     let a2 := update2dArrayMulti a1 walls $ ← `(game_cell| ▓)
     let aa ← Array.mapM delabGameRow a2

     `(┌$topBar:horizontal_border*┐ $aa:game_row*
       └$topBar:horizontal_border*┘)

-- The attribute [delab] registers this function as a delaborator for the GameState.mk constructor.
@[delab app.GameState.mk] def delabGameStateMk : Lean.PrettyPrinter.Delaborator.Delab := do
  let e ← Lean.PrettyPrinter.Delaborator.SubExpr.getExpr
  delabGameState e

-- We register the same elaborator for applications of the game_state_from_cells function.
@[delab app.game_state_from_cells] def delabGameState' : Lean.PrettyPrinter.Delaborator.Delab :=
  do let e ← Lean.PrettyPrinter.Delaborator.SubExpr.getExpr
     let e' ← (Lean.Meta.whnf e)
     delabGameState e'

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

inductive Move where
  | east  : Move
  | west  : Move
  | north : Move
  | south : Move

@[simp]
def make_move : GameState → Move → GameState
| ⟨s, ⟨x,y⟩, w⟩, Move.east =>
             if w.notElem ⟨x+1, y⟩ ∧ x + 1 ≤ s.x
             then ⟨s, ⟨x+1, y⟩, w⟩
             else ⟨s, ⟨x,y⟩, w⟩
| ⟨s, ⟨x,y⟩, w⟩, Move.west =>
             if w.notElem ⟨x-1, y⟩
             then ⟨s, ⟨x-1, y⟩, w⟩
             else ⟨s, ⟨x,y⟩, w⟩
| ⟨s, ⟨x,y⟩, w⟩, Move.north =>
             if w.notElem ⟨x, y-1⟩
             then ⟨s, ⟨x, y-1⟩, w⟩
             else ⟨s, ⟨x,y⟩, w⟩
| ⟨s, ⟨x,y⟩, w⟩, Move.south =>
             if w.notElem ⟨x, y + 1⟩ ∧ y + 1 ≤ s.y
             then ⟨s, ⟨x, y+1⟩, w⟩
             else ⟨s, ⟨x,y⟩, w⟩

def is_win : GameState → Prop
| ⟨⟨sx, sy⟩, ⟨x,y⟩, w⟩ => x = 0 ∨ y = 0 ∨ x + 1 = sx ∨ y + 1 = sy

def can_escape (state : GameState) : Prop :=
  ∃ (gs : List Move), is_win (List.foldl make_move state gs)

theorem can_still_escape
  (g : GameState) (m : Move) (hg : can_escape (make_move g m)) : can_escape g :=
 have ⟨pms, hpms⟩ := hg
 Exists.intro (m::pms) hpms

theorem step_west
  {s: Coords}
  {x y : Nat}
  {w: List Coords}
  (hclear' : w.notElem ⟨x,y⟩)
  (W : can_escape ⟨s,⟨x,y⟩,w⟩) :
  can_escape ⟨s,⟨x+1,y⟩,w⟩ :=
   by have hmm : GameState.mk s ⟨x,y⟩ w = make_move ⟨s,⟨x+1, y⟩,w⟩ Move.west :=
               by have h' : x + 1 - 1 = x := rfl
                  simp [h', hclear']
      rw [hmm] at W
      exact can_still_escape ⟨s,⟨x+1,y⟩,w⟩ Move.west W

theorem step_east
  {s: Coords}
  {x y : Nat}
  {w: List Coords}
  (hclear' : w.notElem ⟨x+1,y⟩)
  (hinbounds : x + 1 ≤ s.x)
  (E : can_escape ⟨s,⟨x+1,y⟩,w⟩) :
  can_escape ⟨s,⟨x, y⟩,w⟩ :=
    by have hmm : GameState.mk s ⟨x+1,y⟩ w = make_move ⟨s, ⟨x,y⟩,w⟩ Move.east :=
         by simp [hclear', hinbounds]
       rw [hmm] at E
       exact can_still_escape ⟨s, ⟨x,y⟩, w⟩ Move.east E

theorem step_north
  {s: Coords}
  {x y : Nat}
  {w: List Coords}
  (hclear' : w.notElem ⟨x,y⟩)
  (N : can_escape ⟨s,⟨x,y⟩,w⟩) :
  can_escape ⟨s,⟨x, y+1⟩,w⟩ :=
    by have hmm : GameState.mk s ⟨x,y⟩ w = make_move ⟨s,⟨x, y+1⟩,w⟩ Move.north :=
         by have h' : y + 1 - 1 = y := rfl
            simp [h', hclear']
       rw [hmm] at N
       exact can_still_escape ⟨s,⟨x,y+1⟩,w⟩ Move.north N

theorem step_south
  {s: Coords}
  {x y : Nat}
  {w: List Coords}
  (hclear' : w.notElem ⟨x,y+1⟩)
  (hinbounds : y + 1 ≤ s.y)
  (S : can_escape ⟨s,⟨x,y+1⟩,w⟩) :
  can_escape ⟨s,⟨x, y⟩,w⟩ :=
    by have hmm : GameState.mk s ⟨x,y+1⟩ w = make_move ⟨s,⟨x, y⟩,w⟩ Move.south :=
            by simp [hclear', hinbounds]
       rw [hmm] at S
       exact can_still_escape ⟨s,⟨x,y⟩,w⟩ Move.south S

def escape_west {sx sy : Nat} {y : Nat} {w : List Coords} : can_escape ⟨⟨sx, sy⟩,⟨0, y⟩,w⟩ :=
    ⟨[], Or.inl rfl⟩

def escape_east {sy x y : Nat} {w : List Coords} : can_escape ⟨⟨x+1, sy⟩,⟨x, y⟩,w⟩ :=
  ⟨[], Or.inr $ Or.inr $ Or.inl rfl⟩

def escape_north {sx sy : Nat} {x : Nat} {w : List Coords} : can_escape ⟨⟨sx, sy⟩,⟨x, 0⟩,w⟩ :=
  ⟨[], Or.inr $ Or.inl rfl⟩

def escape_south {sx x y : Nat} {w: List Coords} : can_escape ⟨⟨sx, y+1⟩,⟨x, y⟩,w⟩ :=
  ⟨[], Or.inr $ Or.inr $ Or.inr rfl⟩

-- Define an "or" tactic combinator, like <|> in Lean 3.
elab t1:tactic " ⟨|⟩ " t2:tactic : tactic =>
   try Lean.Elab.Tactic.evalTactic t1
   catch err => Lean.Elab.Tactic.evalTactic t2

elab "fail" m:term  : tactic => throwError m

-- the `simp`s are to discharge the `hclear` and `hinbounds` side-goals
macro "west" : tactic => `((apply step_west; simp)    ⟨|⟩ fail "cannot step west")
macro "east" : tactic => `((apply step_east; simp; simp)    ⟨|⟩ fail "cannot step east")
macro "xxx" : tactic => `((apply step_east; simp; simp)    ⟨|⟩ fail "cannot step xxx")
macro "north" : tactic => `((apply step_north; simp)  ⟨|⟩ fail "cannot step north")
macro "south" : tactic => `((apply step_south; simp; simp)  ⟨|⟩ fail "cannot step south")

macro "out" : tactic => `(apply escape_north ⟨|⟩ apply escape_south ⟨|⟩
                           apply escape_east ⟨|⟩ apply escape_west ⟨|⟩
                           fail "not currently at maze boundary")

-- Can escape the trivial maze in any direction.
example : can_escape ┌─┐
                     │@│
                     └─┘ := by out

-- some other mazes with immediate escapes
example : can_escape ┌──┐
                     │░░│
                     │@░│
                     │░░│
                     └──┘ := by out
example : can_escape ┌──┐
                     │░░│
                     │░@│
                     │░░│
                     └──┘ := by out
example : can_escape ┌───┐
                     │░@░│
                     │░░░│
                     │░░░│
                     └───┘ := by out
example : can_escape ┌───┐
                     │░░░│
                     │░░░│
                     │░@░│
                     └───┘ := by out

-- Now for some more interesting mazes.

abbrev maze1 := ┌──────┐
                │▓▓▓▓▓▓│
                │▓░░@░▓│
                │▓░░░░▓│
                │▓░░░░▓│
                │▓▓▓▓░▓│
                └──────┘

def ex1 : can_escape maze1 := by
  west
  west
  east
  south
  south
  east
  east
  south
  out

def maze2 := ┌────────┐
             │▓▓▓▓▓▓▓▓│
             │▓░▓@▓░▓▓│
             │▓░▓░░░▓▓│
             │▓░░▓░▓▓▓│
             │▓▓░▓░▓░░│
             │▓░░░░▓░▓│
             │▓░▓▓▓▓░▓│
             │▓░░░░░░▓│
             │▓▓▓▓▓▓▓▓│
             └────────┘

example : can_escape maze2 :=
 by south
    east
    south
    south
    south
    west
    west
    west
    south
    south
    east
    east
    east
    east
    east
    north
    north
    north
    east
    out

def maze3 := ┌────────────────────────────┐
             │▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓│
             │▓░░░░░░░░░░░░░░░░░░░░▓░░░@░▓│
             │▓░▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓░▓░▓▓▓▓▓│
             │▓░▓░░░▓░░░░▓░░░░░░░░░▓░▓░░░▓│
             │▓░▓░▓░▓░▓▓▓▓░▓▓▓▓▓▓▓▓▓░▓░▓░▓│
             │▓░▓░▓░▓░▓░░░░▓░░░░░░░░░░░▓░▓│
             │▓░▓░▓░▓░▓░▓▓▓▓▓▓▓▓▓▓▓▓░▓▓▓░▓│
             │▓░▓░▓░▓░░░▓░░░░░░░░░░▓░░░▓░▓│
             │▓░▓░▓░▓▓▓░▓░▓▓▓▓▓▓▓▓▓▓░▓░▓░▓│
             │▓░▓░▓░░░░░▓░░░░░░░░░░░░▓░▓░▓│
             │▓░▓░▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓░▓│
             │░░▓░░░░░░░░░░░░░░░░░░░░░░░░▓│
             │▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓│
             └────────────────────────────┘

example : can_escape maze3 :=
 by west
    west
    west
    south
    admit -- can you finish the proof?


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

Standard identity and composition functors
-/
import tactic.ext tactic.cache category.basic

universe variables u v w

section functor

variables {F : Type u → Type v}
variables {α β γ : Type u}
variables [functor F] [is_lawful_functor F]

lemma functor.map_id : (<$>) id = (id : F α → F α) :=
by apply funext; apply id_map

lemma functor.map_comp_map (f : α → β) (g : β → γ) :
  ((<$>) g ∘ (<$>) f : F α → F γ) = (<$>) (g ∘ f) :=
by apply funext; intro; rw comp_map

theorem functor.ext {F} : ∀ {F1 : functor F} {F2 : functor F}
  [@is_lawful_functor F F1] [@is_lawful_functor F F2]
  (H : ∀ α β (f : α → β) (x : F α),
    @functor.map _ F1 _ _ f x = @functor.map _ F2 _ _ f x),
  F1 = F2
| ⟨m, mc⟩ ⟨m', mc'⟩ H1 H2 H :=
begin
  cases show @m = @m', by funext α β f x; apply H,
  congr, funext α β,
  have E1 := @map_const_eq _ ⟨@m, @mc⟩ H1,
  have E2 := @map_const_eq _ ⟨@m, @mc'⟩ H2,
  exact E1.trans E2.symm
end

end functor

def id.mk {α : Sort u} : α → id α := id

namespace functor

/-- `functor.comp` is a wrapper around `function.comp` for types.
    It prevents Lean's type class resolution mechanism from trying
    a `functor (comp F id)` when `functor F` would do. -/
def comp (F : Type u → Type w) (G : Type v → Type u) (α : Type v) : Type w :=
F $ G α

@[pattern] def comp.mk {F : Type u → Type w} {G : Type v → Type u} {α : Type v}
  (x : F (G α)) : comp F G α := x

def comp.run {F : Type u → Type w} {G : Type v → Type u} {α : Type v}
  (x : comp F G α) : F (G α) := x

namespace comp

variables {F : Type u → Type w} {G : Type v → Type u}

protected lemma ext
  {α} {x y : comp F G α} : x.run = y.run → x = y := id

variables [functor F] [functor G]

protected def map {α β : Type v} (h : α → β) : comp F G α → comp F G β
| (comp.mk x) := comp.mk ((<$>) h <$> x)

instance : functor (comp F G) := { map := @comp.map F G _ _ }

@[functor_norm] lemma map_mk {α β} (h : α → β) (x : F (G α)) :
  h <$> comp.mk x = comp.mk ((<$>) h <$> x) := rfl

variables [is_lawful_functor F] [is_lawful_functor G]
variables {α β γ : Type v}

protected lemma id_map : ∀ (x : comp F G α), comp.map id x = x
| (comp.mk x) := by simp [comp.map, functor.map_id]

protected lemma comp_map (g' : α → β) (h : β → γ) : ∀ (x : comp F G α),
           comp.map (h ∘ g') x = comp.map h (comp.map g' x)
| (comp.mk x) := by simp [comp.map, functor.map_comp_map g' h] with functor_norm

@[simp] protected lemma run_map (h : α → β) (x : comp F G α) :
  (h <$> x).run = (<$>) h <$> x.run := rfl

instance : is_lawful_functor (comp F G) :=
{ id_map := @comp.id_map F G _ _ _ _,
  comp_map := @comp.comp_map F G _ _ _ _ }

theorem functor_comp_id {F} [AF : functor F] [is_lawful_functor F] :
  @comp.functor F id _ _ = AF :=
@functor.ext F _ AF (@comp.is_lawful_functor F id _ _ _ _) _ (λ α β f x, rfl)

theorem functor_id_comp {F} [AF : functor F] [is_lawful_functor F] :
  @comp.functor id F _ _ = AF :=
@functor.ext F _ AF (@comp.is_lawful_functor id F _ _ _ _) _ (λ α β f x, rfl)

end comp

end functor

namespace ulift

instance : functor ulift :=
{ map := λ α β f, up ∘ f ∘ down }

end ulift

namespace sum

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

protected def mapr (f : α → β) : γ ⊕ α → γ ⊕ β
| (inl x) := inl x
| (inr x) := inr (f x)

instance : functor (sum.{u v} γ) :=
{ map := @sum.mapr γ }

instance : is_lawful_functor (sum γ) :=
{ id_map := by intros; casesm _ ⊕ _; refl,
  comp_map := by intros; casesm _ ⊕ _; refl }

end sum


def myid (a : α) := a -- works

#check myid 10
#check myid true

theorem ex1 (a : α) : myid a = a := rfl

def cnst (b : β) : α → β := fun _ => b -- works

theorem ex2 (b : β) (a : α) : cnst b a = b := rfl

def Vec (α : Type) (n : Nat) := { a : Array α // a.size = n }

def mkVec : Vec α 0 := ⟨ #[], rfl ⟩

def Vec.map (xs : Vec α n) (f : α → β) : Vec β n :=
  ⟨ xs.val.map f, sorry ⟩

/- unbound implicit locals must be greek or lower case letters followed by numerical digits -/
def Vec.map2 (xs : Vec α size /- error: unknown identifier size -/) (f : α → β) : Vec β n :=
  ⟨ xs.val.map f, sorry ⟩

set_option autoBoundImplicitLocal false in
def Vec.map3 (xs : Vec α n) (f : α → β) : Vec β n := -- Errors, unknown identifiers 'α', 'n', 'β'
  ⟨ xs.val.map f, sorry ⟩

def double [Add α] (a : α) := a + a

variable (xs : Vec α n) -- works

def f := xs

#check @f

#check f mkVec

#check f (α := Nat) mkVec

def g (a : α) := xs.val.push a

theorem ex3 : g ⟨#[0], rfl⟩ 1 = #[0, 1] :=
  rfl

inductive Tree (α β : Type) :=
  | leaf1 : α → Tree α β
  | leaf2 : β → Tree α β
  | node : Tree α β → Tree α β → Tree α β

inductive TreeElem1 : α → Tree α β → Prop
  | leaf1     : (a : α) → TreeElem1 a (Tree.leaf1 (β := β) a)
  | nodeLeft  : (a : α) → (left : Tree α β) → (right : Tree α β) → TreeElem1 a left  → TreeElem1 a (Tree.node left right)
  | nodeRight : (a : α) → (left : Tree α β) → (right : Tree α β) → TreeElem1 a right → TreeElem1 a (Tree.node left right)

inductive TreeElem2 : β → Tree α β → Prop
  | leaf2     : (b : β) → TreeElem2 b (Tree.leaf2 (α := α) b)
  | nodeLeft  : (b : β) → (left : Tree α β) → (right : Tree α β) → TreeElem2 b left  → TreeElem2 b (Tree.node left right)
  | nodeRight : (b : β) → (left : Tree α β) → (right : Tree α β) → TreeElem2 b right → TreeElem2 b (Tree.node left right)

namespace Ex1

def findSomeRevM? [Monad m] (as : Array α) (f : α → m (Option β)) : m (Option β) :=
  pure none

def findSomeRev? (as : Array α) (f : α → Option β) : Option β :=
  Id.run <| findSomeRevM? as f

end Ex1

def apply {α : Type u₁} {β : α → Type u₂} (f : (a : α) → β a) (a : α) : β a :=
  f a

def pair (a : α₁) := (a, a)


/-
Copyright © 2020 Nicolò Cavalleri. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Nicolò Cavalleri.
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.geometry.manifold.times_cont_mdiff_map
import Mathlib.PostPort

universes u_1 u_2 u_3 u_5 u_6 u_8 u_9 l u_10 u_4 u_7

namespace Mathlib

/-!
# Diffeomorphisms
This file implements diffeomorphisms.

## Definitions

* `times_diffeomorph I I' M M' n`:  `n`-times continuously differentiable diffeomorphism between
                                    `M` and `M'` with respect to I and I'
* `diffeomorph  I I' M M'` : smooth diffeomorphism between `M` and `M'` with respect to I and I'

## Notations

* `M ≃ₘ^n⟮I, I'⟯ M'` := `times_diffeomorph I J M N n`
* `M ≃ₘ⟮I, I'⟯ M'`   := `times_diffeomorph I J M N ⊤`

## Implementation notes

This notion of diffeomorphism is needed although there is already a notion of structomorphism
because structomorphisms do not allow the model spaces `H` and `H'` of the two manifolds to be
different, i.e. for a structomorphism one has to impose `H = H'` which is often not the case in
practice.

-/

/--
`n`-times continuously differentiable diffeomorphism between `M` and `M'` with respect to I and I'
-/
structure times_diffeomorph {𝕜 : Type u_1} [nondiscrete_normed_field 𝕜] {E : Type u_2} [normed_group E] [normed_space 𝕜 E] {E' : Type u_3} [normed_group E'] [normed_space 𝕜 E'] {H : Type u_5} [topological_space H] {H' : Type u_6} [topological_space H'] (I : model_with_corners 𝕜 E H) (I' : model_with_corners 𝕜 E' H') (M : Type u_8) [topological_space M] [charted_space H M] [smooth_manifold_with_corners I M] (M' : Type u_9) [topological_space M'] [charted_space H' M'] [smooth_manifold_with_corners I' M'] (n : with_top ℕ)
extends M ≃ M'
where
  times_cont_mdiff_to_fun : times_cont_mdiff I I' n (equiv.to_fun _to_equiv)
  times_cont_mdiff_inv_fun : times_cont_mdiff I' I n (equiv.inv_fun _to_equiv)

/-- A `diffeomorph` is just a smooth `times_diffeomorph`. -/
def diffeomorph {𝕜 : Type u_1} [nondiscrete_normed_field 𝕜] {E : Type u_2} [normed_group E] [normed_space 𝕜 E] {E' : Type u_3} [normed_group E'] [normed_space 𝕜 E'] {H : Type u_5} [topological_space H] {H' : Type u_6} [topological_space H'] (I : model_with_corners 𝕜 E H) (I' : model_with_corners 𝕜 E' H') (M : Type u_8) [topological_space M] [charted_space H M] [smooth_manifold_with_corners I M] (M' : Type u_9) [topological_space M'] [charted_space H' M'] [smooth_manifold_with_corners I' M'] :=
  times_diffeomorph I I' M M' ⊤

namespace times_diffeomorph

protected instance has_coe_to_fun {𝕜 : Type u_1} [nondiscrete_normed_field 𝕜] {E : Type u_2} [normed_group E] [normed_space 𝕜 E] {E' : Type u_3} [normed_group E'] [normed_space 𝕜 E'] {H : Type u_5} [topological_space H] {H' : Type u_6} [topological_space H'] (I : model_with_corners 𝕜 E H) (I' : model_with_corners 𝕜 E' H') (M : Type u_8) [topological_space M] [charted_space H M] [smooth_manifold_with_corners I M] (M' : Type u_9) [topological_space M'] [charted_space H' M'] [smooth_manifold_with_corners I' M'] (n : with_top ℕ) : has_coe_to_fun (times_diffeomorph I I' M M' n) :=
  has_coe_to_fun.mk (fun (_x : times_diffeomorph I I' M M' n) => M → M')
    fun (e : times_diffeomorph I I' M M' n) => ⇑(times_diffeomorph.to_equiv e)

protected instance times_cont_mdiff_map.has_coe {𝕜 : Type u_1} [nondiscrete_normed_field 𝕜] {E : Type u_2} [normed_group E] [normed_space 𝕜 E] {E' : Type u_3} [normed_group E'] [normed_space 𝕜 E'] {H : Type u_5} [topological_space H] {H' : Type u_6} [topological_space H'] (I : model_with_corners 𝕜 E H) (I' : model_with_corners 𝕜 E' H') (M : Type u_8) [topological_space M] [charted_space H M] [smooth_manifold_with_corners I M] (M' : Type u_9) [topological_space M'] [charted_space H' M'] [smooth_manifold_with_corners I' M'] (n : with_top ℕ) : has_coe (times_diffeomorph I I' M M' n) (times_cont_mdiff_map I I' M M' n) :=
  has_coe.mk
    fun (Φ : times_diffeomorph I I' M M' n) => times_cont_mdiff_map.mk (⇑Φ) (times_diffeomorph.times_cont_mdiff_to_fun Φ)

protected theorem continuous {𝕜 : Type u_1} [nondiscrete_normed_field 𝕜] {E : Type u_2} [normed_group E] [normed_space 𝕜 E] {E' : Type u_3} [normed_group E'] [normed_space 𝕜 E'] {H : Type u_5} [topological_space H] {H' : Type u_6} [topological_space H'] (I : model_with_corners 𝕜 E H) (I' : model_with_corners 𝕜 E' H') (M : Type u_8) [topological_space M] [charted_space H M] [smooth_manifold_with_corners I M] (M' : Type u_9) [topological_space M'] [charted_space H' M'] [smooth_manifold_with_corners I' M'] (n : with_top ℕ) (h : times_diffeomorph I I' M M' n) : continuous ⇑h :=
  times_cont_mdiff.continuous (times_diffeomorph.times_cont_mdiff_to_fun h)

protected theorem times_cont_mdiff {𝕜 : Type u_1} [nondiscrete_normed_field 𝕜] {E : Type u_2} [normed_group E] [normed_space 𝕜 E] {E' : Type u_3} [normed_group E'] [normed_space 𝕜 E'] {H : Type u_5} [topological_space H] {H' : Type u_6} [topological_space H'] (I : model_with_corners 𝕜 E H) (I' : model_with_corners 𝕜 E' H') (M : Type u_8) [topological_space M] [charted_space H M] [smooth_manifold_with_corners I M] (M' : Type u_9) [topological_space M'] [charted_space H' M'] [smooth_manifold_with_corners I' M'] (n : with_top ℕ) (h : times_diffeomorph I I' M M' n) : times_cont_mdiff I I' n ⇑h :=
  times_diffeomorph.times_cont_mdiff_to_fun h

protected theorem smooth {𝕜 : Type u_1} [nondiscrete_normed_field 𝕜] {E : Type u_2} [normed_group E] [normed_space 𝕜 E] {E' : Type u_3} [normed_group E'] [normed_space 𝕜 E'] {H : Type u_5} [topological_space H] {H' : Type u_6} [topological_space H'] (I : model_with_corners 𝕜 E H) (I' : model_with_corners 𝕜 E' H') (M : Type u_8) [topological_space M] [charted_space H M] [smooth_manifold_with_corners I M] (M' : Type u_9) [topological_space M'] [charted_space H' M'] [smooth_manifold_with_corners I' M'] (h : times_diffeomorph I I' M M' ⊤) : smooth I I' ⇑h :=
  times_diffeomorph.times_cont_mdiff_to_fun h

theorem coe_eq_to_equiv {𝕜 : Type u_1} [nondiscrete_normed_field 𝕜] {E : Type u_2} [normed_group E] [normed_space 𝕜 E] {E' : Type u_3} [normed_group E'] [normed_space 𝕜 E'] {H : Type u_5} [topological_space H] {H' : Type u_6} [topological_space H'] (I : model_with_corners 𝕜 E H) (I' : model_with_corners 𝕜 E' H') (M : Type u_8) [topological_space M] [charted_space H M] [smooth_manifold_with_corners I M] (M' : Type u_9) [topological_space M'] [charted_space H' M'] [smooth_manifold_with_corners I' M'] (n : with_top ℕ) (h : times_diffeomorph I I' M M' n) (x : M) : coe_fn h x = coe_fn (times_diffeomorph.to_equiv h) x :=
  rfl

/-- Identity map as a diffeomorphism. -/
protected def refl {𝕜 : Type u_1} [nondiscrete_normed_field 𝕜] {E : Type u_2} [normed_group E] [normed_space 𝕜 E] {H : Type u_5} [topological_space H] (I : model_with_corners 𝕜 E H) (M : Type u_8) [topological_space M] [charted_space H M] [smooth_manifold_with_corners I M] (n : with_top ℕ) : times_diffeomorph I I M M n :=
  mk (equiv.mk (equiv.to_fun (equiv.refl M)) (equiv.inv_fun (equiv.refl M)) sorry sorry) times_cont_mdiff_id
    times_cont_mdiff_id

/-- Composition of two diffeomorphisms. -/
protected def trans {𝕜 : Type u_1} [nondiscrete_normed_field 𝕜] {E : Type u_2} [normed_group E] [normed_space 𝕜 E] {E' : Type u_3} [normed_group E'] [normed_space 𝕜 E'] {F : Type u_4} [normed_group F] [normed_space 𝕜 F] {H : Type u_5} [topological_space H] {H' : Type u_6} [topological_space H'] {G : Type u_7} [topological_space G] (I : model_with_corners 𝕜 E H) (I' : model_with_corners 𝕜 E' H') (J : model_with_corners 𝕜 F G) (M : Type u_8) [topological_space M] [charted_space H M] [smooth_manifold_with_corners I M] (M' : Type u_9) [topological_space M'] [charted_space H' M'] [smooth_manifold_with_corners I' M'] (N : Type u_10) [topological_space N] [charted_space G N] [smooth_manifold_with_corners J N] (n : with_top ℕ) (h₁ : times_diffeomorph I I' M M' n) (h₂ : times_diffeomorph I' J M' N n) : times_diffeomorph I J M N n :=
  mk
    (equiv.mk (equiv.to_fun (equiv.trans (times_diffeomorph.to_equiv h₁) (times_diffeomorph.to_equiv h₂)))
      (equiv.inv_fun (equiv.trans (times_diffeomorph.to_equiv h₁) (times_diffeomorph.to_equiv h₂))) sorry sorry)
    sorry sorry

/-- Inverse of a diffeomorphism. -/
protected def symm {𝕜 : Type u_1} [nondiscrete_normed_field 𝕜] {E : Type u_2} [normed_group E] [normed_space 𝕜 E] {F : Type u_4} [normed_group F] [normed_space 𝕜 F] {H : Type u_5} [topological_space H] {G : Type u_7} [topological_space G] (I : model_with_corners 𝕜 E H) (J : model_with_corners 𝕜 F G) (M : Type u_8) [topological_space M] [charted_space H M] [smooth_manifold_with_corners I M] (N : Type u_10) [topological_space N] [charted_space G N] [smooth_manifold_with_corners J N] (n : with_top ℕ) (h : times_diffeomorph I J M N n) : times_diffeomorph J I N M n :=
  mk
    (equiv.mk (equiv.to_fun (equiv.symm (times_diffeomorph.to_equiv h)))
      (equiv.inv_fun (equiv.symm (times_diffeomorph.to_equiv h))) sorry sorry)
    (times_diffeomorph.times_cont_mdiff_inv_fun h) (times_diffeomorph.times_cont_mdiff_to_fun h)