/-
Copyright (c) 2018 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Mario Carneiro

Define a sequence of simple machine languages, starting with Turing
machines and working up to more complex lanaguages based on
Wang B-machines.
-/
import data.fintype data.pfun logic.relation

open relation

namespace turing

/-- A direction for the turing machine `move` command, either
  left or right. -/
@[derive decidable_eq]
inductive dir | left | right

def tape (Γ) := Γ × list Γ × list Γ

def tape.mk {Γ} [inhabited Γ] (l : list Γ) : tape Γ :=
(l.head, [], l.tail)

def tape.mk' {Γ} [inhabited Γ] (L R : list Γ) : tape Γ :=
(R.head, L, R.tail)

def tape.move {Γ} [inhabited Γ] : dir → tape Γ → tape Γ
| dir.left (a, L, R) := (L.head, L.tail, a :: R)
| dir.right (a, L, R) := (R.head, a :: L, R.tail)

def tape.nth {Γ} [inhabited Γ] : tape Γ → ℤ → Γ
| (a, L, R) 0 := a
| (a, L, R) (n+1:ℕ) := R.inth n
| (a, L, R) -[1+ n] := L.inth n

@[simp] theorem tape.nth_zero {Γ} [inhabited Γ] :
  ∀ (T : tape Γ), T.nth 0 = T.1
| (a, L, R) := rfl

@[simp] theorem tape.move_left_nth {Γ} [inhabited Γ] :
  ∀ (T : tape Γ) (i : ℤ), (T.move dir.left).nth i = T.nth (i-1)
| (a, L, R) -[1+ n]      := by cases L; refl
| (a, L, R) 0           := by cases L; refl
| (a, L, R) 1           := rfl
| (a, L, R) ((n+1:ℕ)+1) := by rw add_sub_cancel; refl

@[simp] theorem tape.move_right_nth {Γ} [inhabited Γ] :
  ∀ (T : tape Γ) (i : ℤ), (T.move dir.right).nth i = T.nth (i+1)
| (a, L, R) (n+1:ℕ)    := by cases R; refl
| (a, L, R) 0         := by cases R; refl
| (a, L, R) -1        := rfl
| (a, L, R) -[1+ n+1] := show _ = tape.nth _ (-[1+ n] - 1 + 1),
  by rw sub_add_cancel; refl

def tape.write {Γ} (b : Γ) : tape Γ → tape Γ
| (a, LR) := (b, LR)

@[simp] theorem tape.write_self {Γ} : ∀ (T : tape Γ), T.write T.1 = T
| (a, LR) := rfl

@[simp] theorem tape.write_nth {Γ} [inhabited Γ] (b : Γ) :
  ∀ (T : tape Γ) {i : ℤ}, (T.write b).nth i = if i = 0 then b else T.nth i
| (a, L, R) 0       := rfl
| (a, L, R) (n+1:ℕ) := rfl
| (a, L, R) -[1+ n] := rfl

def tape.map {Γ Γ'} (f : Γ → Γ') : tape Γ → tape Γ'
| (a, L, R) := (f a, L.map f, R.map f)

@[simp] theorem tape.map_fst {Γ Γ'} (f : Γ → Γ') : ∀ (T : tape Γ), (T.map f).1 = f T.1
| (a, L, R) := rfl

@[simp] theorem tape.map_write {Γ Γ'} (f : Γ → Γ') (b : Γ) :
  ∀ (T : tape Γ), (T.write b).map f = (T.map f).write (f b)
| (a, L, R) := rfl

@[class] def pointed_map {Γ Γ'} [inhabited Γ] [inhabited Γ'] (f : Γ → Γ') :=
f (default _) = default _

theorem tape.map_move {Γ Γ'} [inhabited Γ] [inhabited Γ']
  (f : Γ → Γ') [pointed_map f] :
  ∀ (T : tape Γ) d, (T.move d).map f = (T.map f).move d
| (a, [],   R) dir.left  := by simpa!
| (a, b::L, R) dir.left  := by simp!
| (a, L, [])   dir.right := by simpa!
| (a, L, b::R) dir.right := by simp!

theorem tape.map_mk {Γ Γ'} [inhabited Γ] [inhabited Γ']
  (f : Γ → Γ') [f0 : pointed_map f] :
  ∀ (l : list Γ), (tape.mk l).map f = tape.mk (l.map f)
| []     := by simpa! [tape.mk]
| (a::l) := rfl

def eval {σ} (f : σ → option σ) : σ → roption σ :=
pfun.fix (λ s, roption.some $
  match f s with none := sum.inl s | some s' := sum.inr s' end)

def reaches {σ} (f : σ → option σ) : σ → σ → Prop :=
refl_trans_gen (λ a b, b ∈ f a)

def reaches₁ {σ} (f : σ → option σ) : σ → σ → Prop :=
trans_gen (λ a b, b ∈ f a)

theorem reaches₁_eq {σ} {f : σ → option σ} {a b c}
  (h : f a = f b) : reaches₁ f a c ↔ reaches₁ f b c :=
trans_gen.head'_iff.trans (trans_gen.head'_iff.trans $ by rw h).symm

theorem reaches_total {σ} {f : σ → option σ}
  {a b c} : reaches f a b → reaches f a c →
  reaches f b c ∨ reaches f c b :=
refl_trans_gen.total_of_right_unique $ λ _ _ _, option.mem_unique

theorem reaches₁_fwd {σ} {f : σ → option σ}
  {a b c} (h₁ : reaches₁ f a c) (h₂ : b ∈ f a) : reaches f b c :=
begin
  rcases trans_gen.head'_iff.1 h₁ with ⟨b', hab, hbc⟩,
  cases option.mem_unique hab h₂, exact hbc
end

def reaches₀ {σ} (f : σ → option σ) (a b : σ) : Prop :=
∀ c, reaches₁ f b c → reaches₁ f a c

theorem reaches₀.trans {σ} {f : σ → option σ} {a b c : σ}
  (h₁ : reaches₀ f a b) (h₂ : reaches₀ f b c) : reaches₀ f a c
| d h₃ := h₁ _ (h₂ _ h₃)

@[refl] theorem reaches₀.refl {σ} {f : σ → option σ} (a : σ) : reaches₀ f a a
| b h := h

theorem reaches₀.single {σ} {f : σ → option σ} {a b : σ}
  (h : b ∈ f a) : reaches₀ f a b
| c h₂ := h₂.head h

theorem reaches₀.head {σ} {f : σ → option σ} {a b c : σ}
  (h : b ∈ f a) (h₂ : reaches₀ f b c) : reaches₀ f a c :=
(reaches₀.single h).trans h₂

theorem reaches₀.tail {σ} {f : σ → option σ} {a b c : σ}
  (h₁ : reaches₀ f a b) (h : c ∈ f b) : reaches₀ f a c :=
h₁.trans (reaches₀.single h)

theorem reaches₀_eq {σ} {f : σ → option σ} {a b}
  (e : f a = f b) : reaches₀ f a b
| d h := (reaches₁_eq e).2 h

theorem reaches₁.to₀ {σ} {f : σ → option σ} {a b : σ}
  (h : reaches₁ f a b) : reaches₀ f a b
| c h₂ := h.trans h₂

theorem reaches.to₀ {σ} {f : σ → option σ} {a b : σ}
  (h : reaches f a b) : reaches₀ f a b
| c h₂ := h₂.trans_right h

theorem reaches₀.tail' {σ} {f : σ → option σ} {a b c : σ}
  (h : reaches₀ f a b) (h₂ : c ∈ f b) : reaches₁ f a c :=
h _ (trans_gen.single h₂)

theorem mem_eval {σ} {f : σ → option σ} {a b} :
  b ∈ eval f a ↔ reaches f a b ∧ f b = none :=
⟨λ h, begin
  refine pfun.fix_induction h (λ a h IH, _),
  cases e : f a with a',
  { rw roption.mem_unique h (pfun.mem_fix_iff.2 $ or.inl $
      roption.mem_some_iff.2 $ by rw e; refl),
    exact ⟨refl_trans_gen.refl, e⟩ },
  { rcases pfun.mem_fix_iff.1 h with h | ⟨_, h, h'⟩;
      rw e at h; cases roption.mem_some_iff.1 h,
    cases IH a' h' (by rwa e) with h₁ h₂,
    exact ⟨refl_trans_gen.head e h₁, h₂⟩ }
end, λ ⟨h₁, h₂⟩, begin
  refine refl_trans_gen.head_induction_on h₁ _ (λ a a' h _ IH, _),
  { refine pfun.mem_fix_iff.2 (or.inl _),
    rw h₂, apply roption.mem_some },
  { refine pfun.mem_fix_iff.2 (or.inr ⟨_, _, IH⟩),
    rw show f a = _, from h,
    apply roption.mem_some }
end⟩

theorem eval_maximal₁ {σ} {f : σ → option σ} {a b}
  (h : b ∈ eval f a) (c) : ¬ reaches₁ f b c | bc :=
let ⟨ab, b0⟩ := mem_eval.1 h, ⟨b', h', _⟩ := trans_gen.head'_iff.1 bc in
by cases b0.symm.trans h'

theorem eval_maximal {σ} {f : σ → option σ} {a b}
  (h : b ∈ eval f a) {c} : reaches f b c ↔ c = b :=
let ⟨ab, b0⟩ := mem_eval.1 h in
refl_trans_gen_iff_eq $ λ b' h', by cases b0.symm.trans h'

theorem reaches_eval {σ} {f : σ → option σ} {a b}
  (ab : reaches f a b) : eval f a = eval f b :=
roption.ext $ λ c,
 ⟨λ h, let ⟨ac, c0⟩ := mem_eval.1 h in
    mem_eval.2 ⟨(or_iff_left_of_imp $ by exact
      λ cb, (eval_maximal h).1 cb ▸ refl_trans_gen.refl).1
      (reaches_total ab ac), c0⟩,
  λ h, let ⟨bc, c0⟩ := mem_eval.1 h in mem_eval.2 ⟨ab.trans bc, c0⟩,⟩

def respects {σ₁ σ₂}
  (f₁ : σ₁ → option σ₁) (f₂ : σ₂ → option σ₂) (tr : σ₁ → σ₂ → Prop) :=
∀ ⦃a₁ a₂⦄, tr a₁ a₂ → (match f₁ a₁ with
  | some b₁ := ∃ b₂, tr b₁ b₂ ∧ reaches₁ f₂ a₂ b₂
  | none := f₂ a₂ = none
  end : Prop)

theorem tr_reaches₁ {σ₁ σ₂ f₁ f₂} {tr : σ₁ → σ₂ → Prop}
  (H : respects f₁ f₂ tr) {a₁ a₂} (aa : tr a₁ a₂) {b₁} (ab : reaches₁ f₁ a₁ b₁) :
  ∃ b₂, tr b₁ b₂ ∧ reaches₁ f₂ a₂ b₂ :=
begin
  induction ab with c₁ ac c₁ d₁ ac cd IH,
  { have := H aa,
    rwa (show f₁ a₁ = _, from ac) at this },
  { rcases IH with ⟨c₂, cc, ac₂⟩,
    have := H cc,
    rw (show f₁ c₁ = _, from cd) at this,
    rcases this with ⟨d₂, dd, cd₂⟩,
    exact ⟨_, dd, ac₂.trans cd₂⟩ }
end

theorem tr_reaches {σ₁ σ₂ f₁ f₂} {tr : σ₁ → σ₂ → Prop}
  (H : respects f₁ f₂ tr) {a₁ a₂} (aa : tr a₁ a₂) {b₁} (ab : reaches f₁ a₁ b₁) :
  ∃ b₂, tr b₁ b₂ ∧ reaches f₂ a₂ b₂ :=
begin
  rcases refl_trans_gen_iff_eq_or_trans_gen.1 ab with rfl | ab,
  { exact ⟨_, aa, refl_trans_gen.refl⟩ },
  { exact let ⟨b₂, bb, h⟩ := tr_reaches₁ H aa ab in
    ⟨b₂, bb, h.to_refl⟩ }
end

theorem tr_reaches_rev {σ₁ σ₂ f₁ f₂} {tr : σ₁ → σ₂ → Prop}
  (H : respects f₁ f₂ tr) {a₁ a₂} (aa : tr a₁ a₂) {b₂} (ab : reaches f₂ a₂ b₂) :
  ∃ c₁ c₂, reaches f₂ b₂ c₂ ∧ tr c₁ c₂ ∧ reaches f₁ a₁ c₁ :=
begin
  induction ab with c₂ d₂ ac cd IH,
  { exact ⟨_, _, refl_trans_gen.refl, aa, refl_trans_gen.refl⟩ },
  { rcases IH with ⟨e₁, e₂, ce, ee, ae⟩,
    rcases refl_trans_gen.cases_head ce with rfl | ⟨d', cd', de⟩,
    { have := H ee, revert this,
      cases eg : f₁ e₁ with g₁; simp [respects],
      { intro c0, cases cd.symm.trans c0 },
      { intros g₂ gg cg,
        rcases trans_gen.head'_iff.1 cg with ⟨d', cd', dg⟩,
        cases option.mem_unique cd cd',
        exact ⟨_, _, dg, gg, ae.tail eg⟩ } },
    { cases option.mem_unique cd cd',
      exact ⟨_, _, de, ee, ae⟩ } }
end

theorem tr_eval {σ₁ σ₂ f₁ f₂} {tr : σ₁ → σ₂ → Prop}
  (H : respects f₁ f₂ tr) {a₁ b₁ a₂} (aa : tr a₁ a₂)
  (ab : b₁ ∈ eval f₁ a₁) : ∃ b₂, tr b₁ b₂ ∧ b₂ ∈ eval f₂ a₂ :=
begin
  cases mem_eval.1 ab with ab b0,
  rcases tr_reaches H aa ab with ⟨b₂, bb, ab⟩,
  refine ⟨_, bb, mem_eval.2 ⟨ab, _⟩⟩,
  have := H bb, rwa b0 at this
end

theorem tr_eval_rev {σ₁ σ₂ f₁ f₂} {tr : σ₁ → σ₂ → Prop}
  (H : respects f₁ f₂ tr) {a₁ b₂ a₂} (aa : tr a₁ a₂)
  (ab : b₂ ∈ eval f₂ a₂) : ∃ b₁, tr b₁ b₂ ∧ b₁ ∈ eval f₁ a₁ :=
begin
  cases mem_eval.1 ab with ab b0,
  rcases tr_reaches_rev H aa ab with ⟨c₁, c₂, bc, cc, ac⟩,
  cases (refl_trans_gen_iff_eq
    (by exact option.eq_none_iff_forall_not_mem.1 b0)).1 bc,
  refine ⟨_, cc, mem_eval.2 ⟨ac, _⟩⟩,
  have := H cc, cases f₁ c₁ with d₁, {refl},
  rcases this with ⟨d₂, dd, bd⟩,
  rcases trans_gen.head'_iff.1 bd with ⟨e, h, _⟩,
  cases b0.symm.trans h
end

theorem tr_eval_dom {σ₁ σ₂ f₁ f₂} {tr : σ₁ → σ₂ → Prop}
  (H : respects f₁ f₂ tr) {a₁ a₂} (aa : tr a₁ a₂) :
  (eval f₂ a₂).dom ↔ (eval f₁ a₁).dom :=
⟨λ h, let ⟨b₂, tr, h, _⟩ := tr_eval_rev H aa ⟨h, rfl⟩ in h,
 λ h, let ⟨b₂, tr, h, _⟩ := tr_eval H aa ⟨h, rfl⟩ in h⟩

def frespects {σ₁ σ₂} (f₂ : σ₂ → option σ₂) (tr : σ₁ → σ₂) (a₂ : σ₂) : option σ₁ → Prop
| (some b₁) := reaches₁ f₂ a₂ (tr b₁)
| none := f₂ a₂ = none

theorem frespects_eq {σ₁ σ₂} {f₂ : σ₂ → option σ₂} {tr : σ₁ → σ₂} {a₂ b₂}
  (h : f₂ a₂ = f₂ b₂) : ∀ {b₁}, frespects f₂ tr a₂ b₁ ↔ frespects f₂ tr b₂ b₁
| (some b₁) := reaches₁_eq h
| none := by simp [frespects, h]

theorem fun_respects {σ₁ σ₂ f₁ f₂} {tr : σ₁ → σ₂} :
  respects f₁ f₂ (λ a b, tr a = b) ↔ ∀ ⦃a₁⦄, frespects f₂ tr (tr a₁) (f₁ a₁) :=
forall_congr $ λ a₁, by cases f₁ a₁; simp [frespects, respects]

theorem tr_eval' {σ₁ σ₂}
  (f₁ : σ₁ → option σ₁) (f₂ : σ₂ → option σ₂) (tr : σ₁ → σ₂)
  (H : respects f₁ f₂ (λ a b, tr a = b))
  (a₁) : eval f₂ (tr a₁) = tr <$> eval f₁ a₁ :=
roption.ext $ λ b₂, by simp; exact
 ⟨λ h, let ⟨b₁, bb, hb⟩ :=
    tr_eval_rev H rfl h in ⟨b₁, hb, bb⟩,
  λ ⟨b₁, ab, bb⟩, begin
    rcases tr_eval H rfl ab with ⟨_, rfl, h⟩,
    rwa bb at h
  end⟩

def dwrite {K} [decidable_eq K] {C : K → Type*}
  (S : ∀ k, C k) (k') (l : C k') (k) : C k :=
if h : k = k' then eq.rec_on h.symm l else S k

@[simp] theorem dwrite_eq {K} [decidable_eq K] {C : K → Type*}
  (S : ∀ k, C k) (k) (l : C k) : dwrite S k l k = l :=
by simp [dwrite]

@[simp] theorem dwrite_ne {K} [decidable_eq K] {C : K → Type*}
  (S : ∀ k, C k) (k') (l : C k') (k) (h : ¬ k = k') : dwrite S k' l k = S k :=
by simp [dwrite, h]

@[simp] theorem dwrite_self
  {K} [decidable_eq K] {C : K → Type*}
  (S : ∀ k, C k) (k) : dwrite S k (S k) = S :=
funext $ λ k', by unfold dwrite; split_ifs; [subst h, refl]

namespace TM0

section
parameters (Γ : Type*) [inhabited Γ] -- type of tape symbols
parameters (Λ : Type*) [inhabited Λ] -- type of "labels" or TM states

/-- A Turing machine "statement" is just a command to either move
  left or right, or write a symbol on the tape. -/
inductive stmt
| move {} : dir → stmt
| write {} : Γ → stmt

/-- A Post-Turing machine with symbol type `Γ` and label type `Λ`
  is a function which, given the current state `q : Λ` and
  the tape head `a : Γ`, either halts (returns `none`) or returns
  a new state `q' : Λ` and a `stmt` describing what to do,
  either a move left or right, or a write command.

  Both `Λ` and `Γ` are required to be inhabited; the default value
  for `Γ` is the "blank" tape value, and the default value of `Λ` is
  the initial state. -/
def machine := Λ → Γ → option (Λ × stmt)

/-- The configuration state of a Turing machine during operation
  consists of a label (machine state), and a tape, represented in
  the form `(a, L, R)` meaning the tape looks like `L.rev ++ [a] ++ R`
  with the machine currently reading the `a`. The lists are
  automatically extended with blanks as the machine moves around. -/
structure cfg :=
(q : Λ)
(tape : tape Γ)

parameters {Γ Λ}
/-- Execution semantics of the Turing machine. -/
def step (M : machine) : cfg → option cfg
| ⟨q, T⟩ := (M q T.1).map (λ ⟨q', a⟩, ⟨q',
  match a with
  | stmt.move d := T.move d
  | stmt.write a := T.write a
  end⟩)

/-- The statement `reaches M s₁ s₂` means that `s₂` is obtained
  starting from `s₁` after a finite number of steps from `s₂`. -/
def reaches (M : machine) : cfg → cfg → Prop :=
refl_trans_gen (λ a b, b ∈ step M a)

/-- The initial configuration. -/
def init (l : list Γ) : cfg :=
⟨default Λ, tape.mk l⟩

/-- Evaluate a Turing machine on initial input to a final state,
  if it terminates. -/
def eval (M : machine) (l : list Γ) : roption (list Γ) :=
(eval (step M) (init l)).map (λ c, c.tape.2.2)

/-- The raw definition of a Turing machine does not require that
  `Γ` and `Λ` are finite, and in practice we will be interested
  in the infinite `Λ` case. We recover instead a notion of
  "effectively finite" Turing machines, which only make use of a
  finite subset of their states. We say that a set `S ⊆ Λ`
  supports a Turing machine `M` if `S` is closed under the
  transition function and contains the initial state. -/
def supports (M : machine) (S : set Λ) :=
default Λ ∈ S ∧ ∀ {q a q' s}, (q', s) ∈ M q a → q ∈ S → q' ∈ S

theorem step_supports (M : machine) {S}
  (ss : supports M S) : ∀ {c c' : cfg},
  c' ∈ step M c → c.q ∈ S → c'.q ∈ S
| ⟨q, T⟩ c' h₁ h₂ := begin
  rcases option.map_eq_some'.1 h₁ with ⟨⟨q', a⟩, h, rfl⟩,
  exact ss.2 h h₂,
end

theorem univ_supports (M : machine) : supports M set.univ :=
⟨trivial, λ q a q' s h₁ h₂, trivial⟩

end

section
variables {Γ : Type*} [inhabited Γ]
variables {Γ' : Type*} [inhabited Γ']
variables {Λ : Type*} [inhabited Λ]
variables {Λ' : Type*} [inhabited Λ']

def stmt.map (f : Γ → Γ') : stmt Γ → stmt Γ'
| (stmt.move d)  := stmt.move d
| (stmt.write a) := stmt.write (f a)

def cfg.map (f : Γ → Γ') (g : Λ → Λ') : cfg Γ Λ → cfg Γ' Λ'
| ⟨q, T⟩ := ⟨g q, T.map f⟩

variables (M : machine Γ Λ)
  (f₁ : Γ → Γ') (f₂ : Γ' → Γ) (g₁ : Λ → Λ') (g₂ : Λ' → Λ)

def machine.map : machine Γ' Λ'
| q l := (M (g₂ q) (f₂ l)).map (prod.map g₁ (stmt.map f₁))

theorem machine.map_step {S} (ss : supports M S)
  [pointed_map f₁] (f₂₁ : function.right_inverse f₁ f₂)
  (g₂₁ : ∀ q ∈ S, g₂ (g₁ q) = q) :
  ∀ c : cfg Γ Λ, c.q ∈ S →
    (step M c).map (cfg.map f₁ g₁) =
    step (M.map f₁ f₂ g₁ g₂) (cfg.map f₁ g₁ c)
| ⟨q, T⟩ h := begin
  simp! [g₂₁ q h, f₂₁ _],
  rcases M q T.1 with _|⟨q', d|a⟩, {refl},
  { simp! [tape.map_move f₁] },
  { simp! }
end

theorem map_init [pointed_map f₁] [g0 : pointed_map g₁] (l : list Γ) :
  (init l).map f₁ g₁ = init (l.map f₁) :=
by simp [init, cfg.map]; exact ⟨g0, tape.map_mk _ _⟩

theorem machine.map_respects {S} (ss : supports M S)
  [pointed_map f₁] [pointed_map g₁]
  (f₂₁ : function.right_inverse f₁ f₂)
  (g₂₁ : ∀ q ∈ S, g₂ (g₁ q) = q) :
  respects (step M) (step (M.map f₁ f₂ g₁ g₂))
    (λ a b, a.q ∈ S ∧ cfg.map f₁ g₁ a = b)
| c _ ⟨cs, rfl⟩ := begin
  cases e : step M c with c'; simp!,
  { rw [← M.map_step f₁ f₂ g₁ g₂ ss f₂₁ g₂₁ _ cs, e], refl },
  { refine ⟨_, ⟨step_supports M ss e cs, rfl⟩, trans_gen.single _⟩,
    rw [← M.map_step f₁ f₂ g₁ g₂ ss f₂₁ g₂₁ _ cs, e], exact rfl }
end

end

end TM0

namespace TM1

section
parameters (Γ : Type*) [inhabited Γ] -- Type of tape symbols
parameters (Λ : Type*) -- Type of function labels
parameters (σ : Type*) -- Type of variable settings

/-- The TM1 model is a simplification and extension of TM0
  (Post-Turing model) in the direction of Wang B-machines. The machine's
  internal state is extended with a (finite) store `σ` of variables
  that may be accessed and updated at any time.
  A machine is given by a `Λ` indexed set of procedures or functions.
  Each function has a body which is a `stmt`, which can either be a
  `move` or `write` command, a `branch` (if statement based on the
  current tape value), a `load` (set the variable value),
  a `goto` (call another function), or `halt`. Note that here
  most statements do not have labels; `goto` commands can only
  go to a new function. All commands have access to the variable value
  and current tape value. -/
inductive stmt
| move : dir → stmt → stmt
| write : (Γ → σ → Γ) → stmt → stmt
| load : (Γ → σ → σ) → stmt → stmt
| branch : (Γ → σ → bool) → stmt → stmt → stmt
| goto {} : (Γ → σ → Λ) → stmt
| halt {} : stmt
open stmt

/-- The configuration of a TM1 machine is given by the currently
  evaluating statement, the variable store value, and the tape. -/
structure cfg :=
(l : option Λ)
(var : σ)
(tape : tape Γ)

parameters {Γ Λ σ}
/-- The semantics of TM1 evaluation. -/
def step_aux : stmt → σ → tape Γ → cfg
| (move d q)       v T := step_aux q v (T.move d)
| (write a q)      v T := step_aux q v (T.write (a T.1 v))
| (load s q)       v T := step_aux q (s T.1 v) T
| (branch p q₁ q₂) v T :=
  cond (p T.1 v) (step_aux q₁ v T) (step_aux q₂ v T)
| (goto l)         v T := ⟨some (l T.1 v), v, T⟩
| halt             v T := ⟨none, v, T⟩

def step (M : Λ → stmt) : cfg → option cfg
| ⟨none,   v, T⟩ := none
| ⟨some l, v, T⟩ := some (step_aux (M l) v T)

variables [inhabited Λ] [inhabited σ]
def init (l : list Γ) : cfg :=
⟨some (default _), default _, tape.mk l⟩

def eval (M : Λ → stmt) (l : list Γ) : roption (list Γ) :=
(eval (step M) (init l)).map (λ c, c.tape.2.2)

variables [fintype Γ]
def supports_stmt (S : finset Λ) : stmt → Prop
| (move d q)       := supports_stmt q
| (write a q)      := supports_stmt q
| (load s q)       := supports_stmt q
| (branch p q₁ q₂) := supports_stmt q₁ ∧ supports_stmt q₂
| (goto l)         := ∀ a v, l a v ∈ S
| halt             := true

/-- A set `S` of labels supports machine `M` if all the `goto`
  statements in the functions in `S` refer only to other functions
  in `S`. -/
def supports (M : Λ → stmt) (S : finset Λ) :=
default Λ ∈ S ∧ ∀ q ∈ S, supports_stmt S (M q)

local attribute [instance] classical.dec
noncomputable def stmts₁ : stmt → finset stmt
| Q@(move d q)       := insert Q (stmts₁ q)
| Q@(write a q)      := insert Q (stmts₁ q)
| Q@(load s q)       := insert Q (stmts₁ q)
| Q@(branch p q₁ q₂) := insert Q (stmts₁ q₁ ∪ stmts₁ q₂)
| Q                  := {Q}

theorem stmts₁_self {q} : q ∈ stmts₁ q :=
by cases q; simp [stmts₁]

theorem stmts₁_trans {q₁ q₂} :
  q₁ ∈ stmts₁ q₂ → stmts₁ q₁ ⊆ stmts₁ q₂ :=
begin
  intros h₁₂ q₀ h₀₁,
  induction q₂ with _ q IH _ q IH _ q IH;
    simp [stmts₁, finset.subset_iff] at h₁₂ ⊢,
  iterate 3 {
    rcases h₁₂ with rfl | h₁₂,
    { simp [stmts₁] at h₀₁, rcases h₀₁ with rfl | h; simp * },
    { exact or.inr (IH h₁₂) } },
  case TM1.stmt.branch : p q₁ q₂ IH₁ IH₂ {
    rcases h₁₂ with rfl | h₁₂ | h₁₂,
    { simp [stmts₁] at h₀₁, rcases h₀₁ with rfl | h; simp * },
    { simp [IH₁ h₁₂] }, { simp [IH₂ h₁₂] } },
  case TM1.stmt.goto : l {
    subst h₁₂, simpa [stmts₁] using h₀₁ },
  case TM1.stmt.halt {
    subst h₁₂, simpa [stmts₁] using h₀₁ }
end

theorem stmts₁_supports_stmt_mono {S q₁ q₂}
  (h : q₁ ∈ stmts₁ q₂) (hs : supports_stmt S q₂) : supports_stmt S q₁ :=
begin
  induction q₂ with _ q IH _ q IH _ q IH;
    simp [stmts₁, supports_stmt] at h hs,
  iterate 3 { rcases h with rfl | h; [exact hs, exact IH h hs] },
  case TM1.stmt.branch : p q₁ q₂ IH₁ IH₂ {
    rcases h with rfl | h | h, exacts [hs, IH₁ h hs.1, IH₂ h hs.2] },
  case TM1.stmt.goto : l { subst h, exact hs },
  case TM1.stmt.halt { subst h, trivial }
end

noncomputable def stmts
  (M : Λ → stmt) (S : finset Λ) : finset (option stmt) :=
(S.bind (λ q, stmts₁ (M q))).insert_none

theorem stmts_trans {M : Λ → stmt} {S q₁ q₂}
  (h₁ : q₁ ∈ stmts₁ q₂) : some q₂ ∈ stmts M S → some q₁ ∈ stmts M S :=
by simp [stmts]; exact λ l ls h₂, ⟨_, ls, stmts₁_trans h₂ h₁⟩

theorem stmts_supports_stmt {M : Λ → stmt} {S q}
  (ss : supports M S) : some q ∈ stmts M S → supports_stmt S q :=
by simp [stmts]; exact
λ l ls h, stmts₁_supports_stmt_mono h (ss.2 _ ls)

local attribute [-simp] finset.mem_insert_none
theorem step_supports (M : Λ → stmt) {S}
  (ss : supports M S) : ∀ {c c' : cfg},
  c' ∈ step M c → c.l ∈ S.insert_none → c'.l ∈ S.insert_none
| ⟨some l₁, v, T⟩ c' h₁ h₂ := begin
  replace h₂ := ss.2 _ (finset.some_mem_insert_none.1 h₂),
  simp [step] at h₁, subst c',
  revert h₂, induction M l₁ with _ q IH _ q IH _ q IH generalizing v T;
    intro hs,
  iterate 3 { exact IH _ _ hs },
  case TM1.stmt.branch : p q₁' q₂' IH₁ IH₂ {
    simp [step_aux], cases p T.1 v,
    { exact IH₂ _ _ hs.2 },
    { exact IH₁ _ _ hs.1 } },
  case TM1.stmt.goto { exact finset.some_mem_insert_none.2 (hs _ _) },
  case TM1.stmt.halt { apply multiset.mem_cons_self }
end

end

end TM1

namespace TM1to0

section
parameters {Γ : Type*} [inhabited Γ]
parameters {Λ : Type*} [inhabited Λ]
parameters {σ : Type*} [inhabited σ]

local notation `stmt₁` := TM1.stmt Γ Λ σ
local notation `cfg₁` := TM1.cfg Γ Λ σ
local notation `stmt₀` := TM0.stmt Γ

parameters (M : Λ → stmt₁)
include M

def Λ' := option stmt₁ × σ
instance : inhabited Λ' := ⟨(some (M (default _)), default _)⟩

open TM0.stmt

def tr_aux (s : Γ) : stmt₁ → σ → Λ' × stmt₀
| (TM1.stmt.move d q)       v := ((some q, v), move d)
| (TM1.stmt.write a q)      v := ((some q, v), write (a s v))
| (TM1.stmt.load a q)       v := tr_aux q (a s v)
| (TM1.stmt.branch p q₁ q₂) v := cond (p s v) (tr_aux q₁ v) (tr_aux q₂ v)
| (TM1.stmt.goto l)         v := ((some (M (l s v)), v), write s)
| TM1.stmt.halt             v := ((none, v), write s)

local notation `cfg₀` := TM0.cfg Γ Λ'

def tr : TM0.machine Γ Λ'
| (none,   v) s := none
| (some q, v) s := some (tr_aux s q v)

def tr_cfg : cfg₁ → cfg₀
| ⟨l, v, T⟩ := ⟨(l.map M, v), T⟩

theorem tr_respects : respects (TM1.step M) (TM0.step tr)
  (λ c₁ c₂, tr_cfg c₁ = c₂) :=
fun_respects.2 $ λ ⟨l₁, v, T⟩, begin
  cases l₁ with l₁, {exact rfl},
  simp!,
  induction M l₁ with _ q IH _ q IH _ q IH generalizing v T,
  case TM1.stmt.move  : d q IH { exact trans_gen.head rfl (IH _ _) },
  case TM1.stmt.write : a q IH { exact trans_gen.head rfl (IH _ _) },
  case TM1.stmt.load : a q IH { exact (reaches₁_eq (by refl)).2 (IH _ _) },
  case TM1.stmt.branch : p q₁ q₂ IH₁ IH₂ {
    simp [TM1.step_aux], cases e : p T.1 v,
    { exact (reaches₁_eq (by simp! [e])).2 (IH₂ _ _) },
    { exact (reaches₁_eq (by simp! [e])).2 (IH₁ _ _) } },
  case TM1.stmt.goto : l { apply trans_gen.single, simp! },
  case TM1.stmt.halt     { apply trans_gen.single, simp! }
end

variables [fintype Γ] [fintype σ]
noncomputable def tr_stmts (S : finset Λ) : finset Λ' :=
(TM1.stmts M S).product finset.univ

local attribute [instance] classical.dec
local attribute [simp] TM1.stmts₁_self
theorem tr_supports {S : finset Λ} (ss : TM1.supports M S) :
  TM0.supports tr (↑(tr_stmts S)) :=
⟨by simp [tr_stmts]; exact finset.some_mem_insert_none.2
  (finset.mem_bind.2 ⟨_, ss.1, TM1.stmts₁_self⟩),
 λ q a q' s h₁ h₂, begin
  rcases q with ⟨_|q, v⟩, {cases h₁},
  cases q' with q' v', simp [tr_stmts] at h₂ ⊢,
  cases q', {simp [TM1.stmts]},
  simp [tr] at h₁,
  have := TM1.stmts_supports_stmt ss h₂,
  revert this, induction q generalizing v; intro hs,
  case TM1.stmt.move : d q {
    cases h₁, refine TM1.stmts_trans _ h₂, simp [TM1.stmts₁] },
  case TM1.stmt.write : b q {
    cases h₁, refine TM1.stmts_trans _ h₂, simp [TM1.stmts₁] },
  case TM1.stmt.load : b q IH {
    refine IH (TM1.stmts_trans _ h₂) _ h₁ hs, simp [TM1.stmts₁] },
  case TM1.stmt.branch : p q₁ q₂ IH₁ IH₂ {
    simp! at h₁, cases p a v,
    { refine IH₂ (TM1.stmts_trans _ h₂) _ h₁ hs.2, simp [TM1.stmts₁] },
    { refine IH₁ (TM1.stmts_trans _ h₂) _ h₁ hs.1, simp [TM1.stmts₁] } },
  case TM1.stmt.goto : l {
    cases h₁, exact finset.some_mem_insert_none.2
      (finset.mem_bind.2 ⟨_, hs _ _, TM1.stmts₁_self⟩) },
  case TM1.stmt.halt { cases h₁ }
end⟩

theorem tr_eval (l : list Γ) : TM0.eval tr l = TM1.eval M l :=
(congr_arg _ (tr_eval' _ _ _ tr_respects ⟨some _, _, _⟩)).trans begin
  simp [tr_cfg],
  rw [roption.map_map, TM1.eval],
  congr', exact funext (λ ⟨_, _, _⟩, rfl)
end

end
end TM1to0

/- Reduce an n-symbol Turing machine to a 2-symbol Turing machine -/
namespace TM1to1
open TM1

section
parameters {Γ : Type*} [inhabited Γ]

theorem exists_enc_dec [fintype Γ] :
  ∃ n (enc : Γ → vector bool n) (dec : vector bool n → Γ),
    enc (default _) = vector.repeat ff n ∧ ∀ a, dec (enc a) = a :=
begin
  rcases fintype.exists_equiv_fin Γ with ⟨n, ⟨F⟩⟩,
  let G : fin n ↪ fin n → bool := ⟨λ a b, a = b,
    λ a b h, by simpa using congr_fun h b⟩,
  let H := (F.to_embedding.trans G).trans
    (equiv.vector_equiv_fin _ _).symm.to_embedding,
  let enc := H.set_value (default _) (vector.repeat ff n),
  exact ⟨_, enc, function.inv_fun enc,
    H.set_value_eq _ _, function.left_inverse_inv_fun enc.2⟩
end

parameters {Λ : Type*} [inhabited Λ]
parameters {σ : Type*} [inhabited σ]

local notation `stmt₁` := stmt Γ Λ σ
local notation `cfg₁` := cfg Γ Λ σ

inductive Λ' : Type (max u_1 u_2 u_3)
| normal : Λ → Λ'
| write : Γ → stmt₁ → Λ'
instance : inhabited Λ' := ⟨Λ'.normal (default _)⟩

local notation `stmt'` := stmt bool Λ' σ
local notation `cfg'` := cfg bool Λ' σ

def read_aux : ∀ n, (vector bool n → stmt') → stmt'
| 0     f := f vector.nil
| (i+1) f := stmt.branch (λ a s, a)
    (stmt.move dir.right $ read_aux i (λ v, f (tt :: v)))
    (stmt.move dir.right $ read_aux i (λ v, f (ff :: v)))

parameters {n : ℕ} (enc : Γ → vector bool n) (dec : vector bool n → Γ)

def move (d : dir) (q : stmt') : stmt' := (stmt.move d)^[n] q

def read (f : Γ → stmt') : stmt' :=
read_aux n (λ v, move dir.left $ f (dec v))

def write : list bool → stmt' → stmt'
| []       q := q
| (a :: l) q := stmt.write (λ _ _, a) $ stmt.move dir.right $ write l q

def tr_normal : stmt₁ → stmt'
| (stmt.move dir.left q)  := move dir.right $ (move dir.left)^[2] $ tr_normal q
| (stmt.move dir.right q) := move dir.right $ tr_normal q
| (stmt.write f q)        := read $ λ a, stmt.goto $ λ _ s, Λ'.write (f a s) q
| (stmt.load f q)         := read $ λ a, stmt.load (λ _ s, f a s) $ tr_normal q
| (stmt.branch p q₁ q₂)   := read $ λ a,
  stmt.branch (λ _ s, p a s) (tr_normal q₁) (tr_normal q₂)
| (stmt.goto l)           := read $ λ a,
  stmt.goto (λ _ s, Λ'.normal (l a s))
| stmt.halt               := move dir.right $ move dir.left $ stmt.halt

def tr_tape' (L R : list Γ) : tape bool :=
tape.mk'
  (L.bind (λ x, (enc x).to_list.reverse))
  (R.bind (λ x, (enc x).to_list) ++ [default _])

def tr_tape : tape Γ → tape bool
| (a, L, R) := tr_tape' L (a :: R)

theorem tr_tape_drop_right : ∀ R : list Γ,
  list.drop n (R.bind (λ x, (enc x).to_list)) =
  R.tail.bind (λ x, (enc x).to_list)
| []     := list.drop_nil _
| (a::R) := by simp; exact list.drop_left' (enc a).2

parameters (enc0 : enc (default _) = vector.repeat ff n)

section
include enc0
theorem tr_tape_take_right : ∀ R : list Γ,
  list.take' n (R.bind (λ x, (enc x).to_list)) =
  (enc R.head).to_list
| []     := by simp; exact (congr_arg vector.to_list enc0).symm
| (a::R) := by simp; exact list.take'_left' (enc a).2
end

parameters (M : Λ → stmt₁)

def tr : Λ' → stmt'
| (Λ'.normal l)  := tr_normal (M l)
| (Λ'.write a q) := write (enc a).to_list $ move dir.left $ tr_normal q

def tr_cfg : cfg₁ → cfg'
| ⟨l, v, T⟩ := ⟨l.map Λ'.normal, v, tr_tape T⟩

include enc0

theorem tr_tape'_move_left (L R) :
  (tape.move dir.left)^[n] (tr_tape' L R) =
  (tr_tape' L.tail (L.head :: R)) :=
begin
  cases L with a L,
  { simp [enc0, vector.repeat, tr_tape'],
    suffices : ∀ i R', default _ ∈ R' →
      (tape.move dir.left^[i]) (tape.mk' [] R') =
      tape.mk' [] (list.repeat ff i ++ R'),
    from this n _ (by simp),
    intros i R' hR, induction i with i IH, {refl},
    rw [nat.iterate_succ', IH],
    simp [tape.mk', tape.move],
    exact list.cons_head_tail
      (list.ne_nil_of_mem $ list.mem_append_right _ hR) },
  { simp [tr_tape'],
    suffices : ∀ L' R' l₁ l₂
      (hR : default _ ∈ R')
      (e : vector.to_list (enc a) = list.reverse_core l₁ l₂),
      (tape.move dir.left^[l₁.length]) (tape.mk' (l₁ ++ L') (l₂ ++ R')) =
      tape.mk' L' (vector.to_list (enc a) ++ R'),
    { simpa using this _ _ _ _ _ (list.reverse_reverse _).symm,
      simp },
    intros, induction l₁ with b l₁ IH generalizing l₂,
    { cases e, refl },
    simp [nat.iterate_succ, -add_comm],
    convert IH _ e,
    simp [tape.move, tape.mk'],
    exact list.cons_head_tail
      (list.ne_nil_of_mem $ list.mem_append_right _ hR) }
end

theorem tr_tape'_move_right (L R) :
  (tape.move dir.right)^[n] (tr_tape' L R) =
  (tr_tape' (R.head :: L) R.tail) :=
begin
  cases R with a R,
  { simp [enc0, vector.repeat, tr_tape'],
    suffices : ∀ i L',
      (tape.move dir.right^[i]) (ff, L', []) =
      (ff, list.repeat ff i ++ L', []),
    from this n _,
    intros, induction i;
      simp [nat.iterate_succ', tape.move, *]; refl },
  { simp [tr_tape'],
    suffices : ∀ L' R' l₁ l₂ : list bool,
      (tape.move dir.right^[l₂.length]) (tape.mk' (l₁ ++ L') (l₂ ++ R')) =
      tape.mk' (list.reverse_core l₂ l₁ ++ L') R',
    { simpa using this _ _ [] (enc a).to_list },
    intros, induction l₂ with b l₂ IH generalizing l₁, {refl},
    simp [-add_comm, nat.iterate_succ],
    exact IH (b::l₁) }
end

theorem step_aux_move (d q v T) :
  step_aux (move d q) v T =
  step_aux q v ((tape.move d)^[n] T) :=
begin
  simp [move],
  suffices : ∀ i,
    step_aux (stmt.move d^[i] q) v T =
    step_aux q v (tape.move d^[i] T), from this n,
  intro, induction i with i IH generalizing T, {refl},
  rw [nat.iterate_succ', step_aux, IH, ← nat.iterate_succ]
end

parameters (encdec : ∀ a, dec (enc a) = a)
include encdec

theorem step_aux_read (f v L R) :
  step_aux (read f) v (tr_tape' L R) =
  step_aux (f R.head) v (tr_tape' L (R.head :: R.tail)) :=
begin
  suffices : ∀ f,
    step_aux (read_aux n f) v (tr_tape' enc L R) =
    step_aux (f (enc R.head)) v
      (tr_tape' enc (R.head :: L) R.tail),
  { rw [read, this, step_aux_move enc enc0, encdec,
      tr_tape'_move_left enc enc0], refl },
  cases R with a R,
  { suffices : ∀ i f L',
      step_aux (read_aux i f) v (ff, L', []) =
      step_aux (f (vector.repeat ff i)) v
        (ff, list.repeat ff i ++ L', []),
    { intro f, convert this n f _,
      simp [tr_tape', tape.mk', enc0, vector.repeat] },
    clear f L, intros, induction i with i IH generalizing L', {refl},
    simp [read_aux, step_aux, tape.mk', tape.move],
    rw [IH], congr',
    simpa using congr_arg (++ L') (list.repeat_add ff i 1).symm },
  { simp [tr_tape'],
    suffices : ∀ i f L' R' l₁ l₂ h,
      step_aux (read_aux i f) v
        (tape.mk' (l₁ ++ L') (l₂ ++ R')) =
      step_aux (f ⟨l₂, h⟩) v
        (tape.mk' (l₂.reverse_core l₁ ++ L') R'),
    { intro f, convert this n f _ _ _ _ (enc a).2; simp },
    clear f L a R, intros, subst i,
    induction l₂ with a l₂ IH generalizing l₁, {refl},
    dsimp [read_aux, step_aux],
    change (tape.mk' (l₁ ++ L') (a :: (l₂ ++ R'))).1 with a,
    transitivity step_aux
      (read_aux l₂.length (λ v, f (a :: v))) v
      (tape.mk' (a :: l₁ ++ L') (l₂ ++ R')),
    { cases a; refl },
    rw IH, refl }
end

theorem step_aux_write (q v a b L R) :
  step_aux (write (enc a).to_list q) v (tr_tape' L (b :: R)) =
  step_aux q v (tr_tape' (a :: L) R) :=
begin
  simp [tr_tape'],
  suffices : ∀ {L' R'} (l₁ l₂ l₂' : list bool)
    (e : l₂'.length = l₂.length),
    step_aux (write l₂ q) v (tape.mk' (l₁ ++ L') (l₂' ++ R')) =
    step_aux q v (tape.mk' (list.reverse_core l₂ l₁ ++ L') R'),
  from this [] _ _ ((enc b).2.trans (enc a).2.symm),
  clear a b L R, intros,
  induction l₂ with a l₂ IH generalizing l₁ l₂',
  { cases list.length_eq_zero.1 e, refl },
  cases l₂' with b l₂'; injection e with e,
  simp [write, step_aux],
  convert IH _ _ e, refl
end

theorem tr_respects : respects (step M) (step tr)
  (λ c₁ c₂, tr_cfg c₁ = c₂) :=
fun_respects.2 $ λ ⟨l₁, v, (a, L, R)⟩, begin
  cases l₁ with l₁, {exact rfl},
  suffices : ∀ q R, reaches (step (tr enc dec M))
    (step_aux (tr_normal dec q) v (tr_tape' enc L R))
    (tr_cfg enc (step_aux q v (tape.mk' L R))),
  { refine trans_gen.head' rfl (this _ (a::R)) },
  clear R l₁, intros,
  induction q with _ q IH _ q IH _ q IH generalizing v L R,
  case TM1.stmt.move : d q IH {
    cases d; simp [tr_normal, step_aux_move enc enc0, step_aux,
      tr_tape'_move_left enc enc0, tr_tape'_move_right enc enc0];
      apply IH },
  case TM1.stmt.write : a q IH {
    simp [tr_normal, step_aux_read enc dec enc0 encdec, step_aux],
    refine refl_trans_gen.head rfl _,
    simp [tr, tr_normal, step_aux,
      step_aux_write enc dec enc0 encdec,
      step_aux_move enc enc0, tr_tape'_move_left enc enc0],
    apply IH },
  case TM1.stmt.load : a q IH {
    simp [tr_normal, step_aux_read enc dec enc0 encdec],
    apply IH },
  case TM1.stmt.branch : p q₁ q₂ IH₁ IH₂ {
    simp [tr_normal, step_aux_read enc dec enc0 encdec, step_aux],
    change (tape.mk' L R).1 with R.head,
    cases p R.head v; [apply IH₂, apply IH₁] },
  case TM1.stmt.goto : l {
    simp [tr_normal, step_aux_read enc dec enc0 encdec, step_aux],
    apply refl_trans_gen.refl },
  case TM1.stmt.halt {
    simp [tr_normal, step_aux, tr_cfg, step_aux_move enc enc0,
      tr_tape'_move_left enc enc0, tr_tape'_move_right enc enc0],
    apply refl_trans_gen.refl }
end

omit enc0 encdec
local attribute [instance] classical.dec
parameters [fintype Γ]
noncomputable def writes : stmt₁ → finset Λ'
| (stmt.move d q)       := writes q
| (stmt.write f q)      := finset.univ.image (λ a, Λ'.write a q) ∪ writes q
| (stmt.load f q)       := writes q
| (stmt.branch p q₁ q₂) := writes q₁ ∪ writes q₂
| (stmt.goto l)         := ∅
| stmt.halt             := ∅

noncomputable def tr_supp (S : finset Λ) : finset Λ' :=
S.bind (λ l, insert (Λ'.normal l) (writes (M l)))

theorem supports_stmt_move {S d q} :
  supports_stmt S (move d q) = supports_stmt S q :=
suffices ∀ {i}, supports_stmt S (stmt.move d^[i] q) = _, from this,
by intro; induction i generalizing q; simp [*, supports_stmt]

theorem supports_stmt_write {S l q} :
  supports_stmt S (write l q) = supports_stmt S q :=
by induction l with a l IH; simp [write, supports_stmt, *]

local attribute [simp] supports_stmt_move supports_stmt_write

theorem supports_stmt_read {S} : ∀ {f : Γ → stmt'},
  (∀ a, supports_stmt S (f a)) → supports_stmt S (read f) :=
suffices ∀ i (f : vector bool i → stmt'),
  (∀ v, supports_stmt S (f v)) → supports_stmt S (read_aux i f),
from λ f hf, this n _ (by simp [hf]),
λ i f hf, begin
  induction i with i IH, {exact hf _},
  split; simp [supports_stmt]; apply IH; simp [hf],
end

theorem tr_supports {S} (ss : supports M S) :
  supports tr (tr_supp S) :=
⟨by simp [tr_supp]; exact ⟨_, ss.1, or.inl rfl⟩, λ q h, begin
  simp [tr_supp] at h,
  suffices : ∀ q, supports_stmt S q →
    (∀ q' ∈ writes q, q' ∈ tr_supp M S) →
    supports_stmt (tr_supp M S) (tr_normal dec q) ∧
    ∀ q' ∈ writes q, supports_stmt (tr_supp M S) (tr enc dec M q'),
  { rcases h with ⟨l, hl, h⟩,
    have := this _ (ss.2 _ hl) (λ q' hq,
      by simp [tr_supp]; exact ⟨_, hl, or.inr hq⟩),
    rcases h with rfl | h,
    exacts [this.1, this.2 _ h] },
  intros q hs hw, induction q,
  case TM1.stmt.move : d q IH {
    dsimp [writes] at hw ⊢,
    replace IH := IH hs hw, refine ⟨_, IH.2⟩,
    cases d; simp [tr_normal, IH] },
  case TM1.stmt.write : f q IH {
    simp [writes] at hw ⊢,
    replace IH := IH hs (λ q hq, hw q (or.inl hq)),
    refine ⟨supports_stmt_read _ $ λ a _ s,
      hw _ (or.inr ⟨_, rfl⟩), λ q' hq, _⟩,
    rcases hq with hq | ⟨a, q₂, rfl⟩,
    { exact IH.2 _ hq }, { simp [tr, IH.1] } },
  case TM1.stmt.load : a q IH {
    dsimp [writes] at hw ⊢,
    replace IH := IH hs hw,
    refine ⟨supports_stmt_read _ (λ a, _), IH.2⟩,
    simp [tr_normal, supports_stmt, IH.1] },
  case TM1.stmt.branch : p q₁ q₂ IH₁ IH₂ {
    simp [writes] at hw ⊢,
    replace IH₁ := IH₁ hs.1 (λ q hq, hw q (or.inl hq)),
    replace IH₂ := IH₂ hs.2 (λ q hq, hw q (or.inr hq)),
    exact ⟨supports_stmt_read _ (λ a, ⟨IH₁.1, IH₂.1⟩),
      λ q, or.rec (IH₁.2 _) (IH₂.2 _)⟩ },
  case TM1.stmt.goto : l {
    simp [writes],
    refine supports_stmt_read _ (λ a _ s, _),
    simp [tr_supp], exact ⟨_, hs _ _, or.inl rfl⟩ },
  case TM1.stmt.halt {
    simp [supports_stmt, writes, tr_normal] }
end⟩

end

end TM1to1

namespace TM0to1

section
parameters {Γ : Type*} [inhabited Γ]
parameters {Λ : Type*} [inhabited Λ]

inductive Λ'
| normal : Λ → Λ'
| act : TM0.stmt Γ → Λ → Λ'
instance : inhabited Λ' := ⟨Λ'.normal (default _)⟩

local notation `cfg₀` := TM0.cfg Γ Λ
local notation `stmt₁` := TM1.stmt Γ Λ' unit
local notation `cfg₁` := TM1.cfg Γ Λ' unit

parameters (M : TM0.machine Γ Λ)

open TM1.stmt

def tr : Λ' → stmt₁
| (Λ'.normal q) :=
  branch (λ a _, (M q a).is_none) halt $
  goto (λ a _, match M q a with
  | none := default _
  | some (q', s) := Λ'.act s q'
  end)
| (Λ'.act (TM0.stmt.move d) q) :=
  move d $ goto (λ _ _, Λ'.normal q)
| (Λ'.act (TM0.stmt.write a) q) :=
  write (λ _ _, a) $ goto (λ _ _, Λ'.normal q)

def tr_cfg : cfg₀ → cfg₁
| ⟨q, T⟩ := ⟨cond (M q T.1).is_some
  (some (Λ'.normal q)) none, (), T⟩

theorem tr_respects : respects (TM0.step M) (TM1.step tr)
  (λ a b, tr_cfg a = b) :=
fun_respects.2 $ λ ⟨q, T⟩, begin
  simp [TM0.step],
  cases e : M q T.1,
  { simp [frespects, TM1.step, tr_cfg, e] },
  cases val with q' s,
  simp [frespects, TM0.step, tr_cfg, e],
  have : TM1.step (tr M) ⟨some (Λ'.act s q'), (), T⟩ =
    some ⟨some (Λ'.normal q'), (), TM0.step._match_1 T s⟩,
  { cases s with d a; refl },
  refine trans_gen.head _ (trans_gen.head' this _);
  simp [TM1.step, TM1.step_aux, tr, e, TM0.step],
  cases e' : M q' (TM0.step._match_1 T s).1,
  { apply refl_trans_gen.single,
    simp [TM1.step, e', tr, TM1.step_aux] },
  { refl }
end

end

end TM0to1

namespace TM2

section
parameters {K : Type*} [decidable_eq K] -- Index type of stacks
parameters (Γ : K → Type*) -- Type of stack elements
parameters (Λ : Type*) -- Type of function labels
parameters (σ : Type*) -- Type of variable settings

/-- The TM2 model removes the tape entirely from the TM1 model,
  replacing it with an arbitrary (finite) collection of stacks.
  The operation `push` puts an element on one of the stacks,
  and `pop` removes an element from a stack (and modifying the
  internal state based on the result). `peek` modifies the
  internal state but does not remove an element. -/
inductive stmt
| push {} : ∀ k, (σ → Γ k) → stmt → stmt
| peek {} : ∀ k, (σ → option (Γ k) → σ) → stmt → stmt
| pop {} : ∀ k, (σ → option (Γ k) → σ) → stmt → stmt
| load : (σ → σ) → stmt → stmt
| branch : (σ → bool) → stmt → stmt → stmt
| goto {} : (σ → Λ) → stmt
| halt {} : stmt
open stmt

structure cfg :=
(l : option Λ)
(var : σ)
(stk : ∀ k, list (Γ k))

parameters {Γ Λ σ K}
def step_aux : stmt → σ → (∀ k, list (Γ k)) → cfg
| (push k f q)     v S := step_aux q v (dwrite S k (f v :: S k))
| (peek k f q)     v S := step_aux q (f v (S k).head') S
| (pop k f q)      v S := step_aux q (f v (S k).head') (dwrite S k (S k).tail)
| (load a q)       v S := step_aux q (a v) S
| (branch f q₁ q₂) v S :=
  cond (f v) (step_aux q₁ v S) (step_aux q₂ v S)
| (goto f)         v S := ⟨some (f v), v, S⟩
| halt             v S := ⟨none, v, S⟩

def step (M : Λ → stmt) : cfg → option cfg
| ⟨none,   v, S⟩ := none
| ⟨some l, v, S⟩ := some (step_aux (M l) v S)

def reaches (M : Λ → stmt) : cfg → cfg → Prop :=
refl_trans_gen (λ a b, b ∈ step M a)

variables [inhabited Λ] [inhabited σ]
def init (k) (L : list (Γ k)) : cfg :=
⟨some (default _), default _, dwrite (λ _, []) k L⟩

def eval (M : Λ → stmt) (k) (L : list (Γ k)) : roption (list (Γ k)) :=
(eval (step M) (init k L)).map $ λ c, c.stk k

variables [fintype K] [∀ k, fintype (Γ k)] [fintype σ]
def supports_stmt (S : finset Λ) : stmt → Prop
| (push k f q)     := supports_stmt q
| (peek k f q)     := supports_stmt q
| (pop k f q)      := supports_stmt q
| (load a q)       := supports_stmt q
| (branch f q₁ q₂) := supports_stmt q₁ ∧ supports_stmt q₂
| (goto l)         := ∀ v, l v ∈ S
| halt             := true

def supports (M : Λ → stmt) (S : finset Λ) :=
default Λ ∈ S ∧ ∀ q ∈ S, supports_stmt S (M q)

local attribute [instance] classical.dec
noncomputable def stmts₁ : stmt → finset stmt
| Q@(push k f q)     := insert Q (stmts₁ q)
| Q@(peek k f q)     := insert Q (stmts₁ q)
| Q@(pop k f q)      := insert Q (stmts₁ q)
| Q@(load a q)       := insert Q (stmts₁ q)
| Q@(branch f q₁ q₂) := insert Q (stmts₁ q₁ ∪ stmts₁ q₂)
| Q@(goto l)         := {Q}
| Q@halt             := {Q}

theorem stmts₁_self {q} : q ∈ stmts₁ q :=
by cases q; simp [stmts₁]

theorem stmts₁_trans {q₁ q₂} :
  q₁ ∈ stmts₁ q₂ → stmts₁ q₁ ⊆ stmts₁ q₂ :=
begin
  intros h₁₂ q₀ h₀₁,
  induction q₂ with _ _ q IH _ _ q IH _ _ q IH _ q IH;
    simp [stmts₁, finset.subset_iff] at h₁₂ ⊢,
  iterate 4 {
    rcases h₁₂ with rfl | h₁₂,
    { simp [stmts₁] at h₀₁, rcases h₀₁ with rfl | h; simp * },
    { exact or.inr (IH h₁₂) } },
  case TM2.stmt.branch : f q₁ q₂ IH₁ IH₂ {
    rcases h₁₂ with rfl | h₁₂ | h₁₂,
    { simp [stmts₁] at h₀₁, rcases h₀₁ with rfl | h; simp * },
    { simp [IH₁ h₁₂] }, { simp [IH₂ h₁₂] } },
  case TM2.stmt.goto : l {
    subst h₁₂, simpa [stmts₁] using h₀₁ },
  case TM2.stmt.halt {
    subst h₁₂, simpa [stmts₁] using h₀₁ }
end

theorem stmts₁_supports_stmt_mono {S q₁ q₂}
  (h : q₁ ∈ stmts₁ q₂) (hs : supports_stmt S q₂) : supports_stmt S q₁ :=
begin
  induction q₂ with _ _ q IH _ _ q IH _ _ q IH _ q IH;
    simp [stmts₁, supports_stmt] at h hs,
  iterate 4 { rcases h with rfl | h; [exact hs, exact IH h hs] },
  case TM2.stmt.branch : f q₁ q₂ IH₁ IH₂ {
    rcases h with rfl | h | h, exacts [hs, IH₁ h hs.1, IH₂ h hs.2] },
  case TM2.stmt.goto : l { subst h, exact hs },
  case TM2.stmt.halt { subst h, trivial }
end

noncomputable def stmts
  (M : Λ → stmt) (S : finset Λ) : finset (option stmt) :=
(S.bind (λ q, stmts₁ (M q))).insert_none

theorem stmts_trans {M : Λ → stmt} {S q₁ q₂}
  (h₁ : q₁ ∈ stmts₁ q₂) : some q₂ ∈ stmts M S → some q₁ ∈ stmts M S :=
by simp [stmts]; exact λ l ls h₂, ⟨_, ls, stmts₁_trans h₂ h₁⟩

theorem stmts_supports_stmt {M : Λ → stmt} {S q}
  (ss : supports M S) : some q ∈ stmts M S → supports_stmt S q :=
by simp [stmts]; exact
λ l ls h, stmts₁_supports_stmt_mono h (ss.2 _ ls)

local attribute [-simp] finset.mem_insert_none
theorem step_supports (M : Λ → stmt) {S}
  (ss : supports M S) : ∀ {c c' : cfg},
  c' ∈ step M c → c.l ∈ S.insert_none → c'.l ∈ S.insert_none
| ⟨some l₁, v, T⟩ c' h₁ h₂ := begin
  replace h₂ := ss.2 _ (finset.some_mem_insert_none.1 h₂),
  simp [step] at h₁, subst c',
  revert h₂, induction M l₁ with _ _ q IH _ _ q IH _ _ q IH _ q IH generalizing v T;
    intro hs,
  iterate 4 { exact IH _ _ hs },
  case TM2.stmt.branch : p q₁' q₂' IH₁ IH₂ {
    simp [step_aux], cases p v,
    { exact IH₂ _ _ hs.2 },
    { exact IH₁ _ _ hs.1 } },
  case TM2.stmt.goto { exact finset.some_mem_insert_none.2 (hs _) },
  case TM2.stmt.halt { apply multiset.mem_cons_self }
end

end

end TM2

namespace TM2to1

section
parameters {K : Type*} [decidable_eq K]
parameters {Γ : K → Type*}
parameters {Λ : Type*} [inhabited Λ]
parameters {σ : Type*} [inhabited σ]

local notation `stmt₂` := TM2.stmt Γ Λ σ
local notation `cfg₂` := TM2.cfg Γ Λ σ

inductive stackel (k : K)
| val : Γ k → stackel
| bottom : stackel
| top : stackel

instance stackel.inhabited (k) : inhabited (stackel k) :=
⟨stackel.top _⟩

def stackel.is_bottom {k} : stackel k → bool
| (stackel.bottom _) := tt
| _ := ff

def stackel.is_top {k} : stackel k → bool
| (stackel.top _) := tt
| _ := ff

def stackel.get {k} : stackel k → option (Γ k)
| (stackel.val a) := some a
| _ := none

section
open stackel

def stackel_equiv {k} : stackel k ≃ option (option (Γ k)) :=
begin
  refine ⟨λ s, _, λ s, _, _, _⟩,
  { cases s, exacts [some (some s), none, some none] },
  { rcases s with _|_|s, exacts [bottom _, top _, val s] },
  { intro s, cases s; refl },
  { intro s, rcases s with _|_|s; refl },
end

end

def Γ' := ∀ k, stackel k

instance Γ'.inhabited : inhabited Γ' := ⟨λ _, default _⟩

instance stackel.fintype {k} [fintype (Γ k)] : fintype (stackel k) :=
fintype.of_equiv _ stackel_equiv.symm

instance Γ'.fintype [fintype K] [∀ k, fintype (Γ k)] : fintype Γ' :=
pi.fintype

inductive st_act (k : K)
| push {} : (σ → Γ k) → st_act
| pop {} : bool → (σ → option (Γ k) → σ) → st_act

section
open st_act

def st_run {k : K} : st_act k → stmt₂ → stmt₂
| (push f)   := TM2.stmt.push k f
| (pop ff f) := TM2.stmt.peek k f
| (pop tt f) := TM2.stmt.pop k f

def st_var {k : K} (v : σ) (l : list (Γ k)) : st_act k → σ
| (push f)  := v
| (pop b f) := f v l.head'

def st_write {k : K} (v : σ) (l : list (Γ k)) : st_act k → list (Γ k)
| (push f) := f v :: l
| (pop ff f) := l
| (pop tt f) := l.tail

@[elab_as_eliminator] theorem {l} stmt_st_rec
  {C : stmt₂ → Sort l}
  (H₁ : Π k (s : st_act k) q (IH : C q), C (st_run s q))
  (H₂ : Π a q (IH : C q), C (TM2.stmt.load a q))
  (H₃ : Π p q₁ q₂ (IH₁ : C q₁) (IH₂ : C q₂), C (TM2.stmt.branch p q₁ q₂))
  (H₄ : Π l, C (TM2.stmt.goto l))
  (H₅ : C TM2.stmt.halt) : ∀ n, C n
| (TM2.stmt.push k f q)     := H₁ _ (push f) _ (stmt_st_rec q)
| (TM2.stmt.peek k f q)     := H₁ _ (pop ff f) _ (stmt_st_rec q)
| (TM2.stmt.pop k f q)      := H₁ _ (pop tt f) _ (stmt_st_rec q)
| (TM2.stmt.load a q)       := H₂ _ _ (stmt_st_rec q)
| (TM2.stmt.branch a q₁ q₂) := H₃ _ _ _ (stmt_st_rec q₁) (stmt_st_rec q₂)
| (TM2.stmt.goto l)         := H₄ _
| TM2.stmt.halt             := H₅

theorem supports_run [fintype K] [∀ k, fintype (Γ k)] [fintype σ]
  (S : finset Λ) {k} (s : st_act k) (q) :
  TM2.supports_stmt S (st_run s q) ↔ TM2.supports_stmt S q :=
by rcases s with _|_|_; refl

end

inductive Λ' : Type (max u_1 u_2 u_3 u_4)
| normal {} : Λ → Λ'
| go (k) : st_act k → stmt₂ → Λ'
| ret {} : K → stmt₂ → Λ'
open Λ'
instance : inhabited Λ' := ⟨normal (default _)⟩

local notation `stmt₁` := TM1.stmt Γ' Λ' σ
local notation `cfg₁` := TM1.cfg Γ' Λ' σ

open TM1.stmt

def tr_st_act {k} (q : stmt₁) : st_act k → stmt₁
| (st_act.push f) :=
  write (λ a s, dwrite a k $ stackel.val $ f s) $
  move dir.right $
  write (λ a s, dwrite a k $ stackel.top k) q
| (st_act.pop b f) :=
  move dir.left $
  load (λ a s, f s (a k).get) $
  cond b
  ( branch (λ a s, (a k).is_bottom)
    ( move dir.right q )
    ( move dir.right $
      write (λ a s, dwrite a k $ default _) $
      move dir.left $
      write (λ a s, dwrite a k $ stackel.top k) q ) )
  ( move dir.right q )

def tr_init (k) (L : list (Γ k)) : list Γ' :=
stackel.bottom :: match L.reverse with
| [] := [stackel.top]
| (a::L') := dwrite stackel.top k (stackel.val a) ::
  (L'.map stackel.val ++ [stackel.top k]).map (dwrite (default _) k)
end

theorem step_run {k : K} (q v S) : ∀ s : st_act k,
  TM2.step_aux (st_run s q) v S =
  TM2.step_aux q (st_var v (S k) s) (dwrite S k (st_write v (S k) s))
| (st_act.push f) := rfl
| (st_act.pop ff f) := by simp!
| (st_act.pop tt f) := rfl

def tr_normal : stmt₂ → stmt₁
| (TM2.stmt.push k f q)     := goto (λ _ _, go k (st_act.push f) q)
| (TM2.stmt.peek k f q)     := goto (λ _ _, go k (st_act.pop ff f) q)
| (TM2.stmt.pop k f q)      := goto (λ _ _, go k (st_act.pop tt f) q)
| (TM2.stmt.load a q)       := load (λ _, a) (tr_normal q)
| (TM2.stmt.branch f q₁ q₂) := branch (λ a, f) (tr_normal q₁) (tr_normal q₂)
| (TM2.stmt.goto l)         := goto (λ a s, normal (l s))
| TM2.stmt.halt             := halt

theorem tr_normal_run {k} (s q) :
  tr_normal (st_run s q) = goto (λ _ _, go k s q) :=
by rcases s with _|_|_; refl

parameters (M : Λ → stmt₂)
include M

def tr : Λ' → stmt₁
| (normal q) := tr_normal (M q)
| (go k s q) :=
  branch (λ a s, (a k).is_top) (tr_st_act (goto (λ _ _, ret k q)) s)
    (move dir.right $ goto (λ _ _, go k s q))
| (ret k q) :=
  branch (λ a s, (a k).is_bottom) (tr_normal q)
    (move dir.left $ goto (λ _ _, ret k q))

def tr_stk {k} (S : list (Γ k)) (L : list (stackel k)) : Prop :=
∃ n, L = (S.map stackel.val).reverse_core (stackel.top k :: list.repeat (default _) n)

local attribute [pp_using_anonymous_constructor] turing.TM1.cfg
inductive tr_cfg : cfg₂ → cfg₁ → Prop
| mk {q v} {S : ∀ k, list (Γ k)} {L : list Γ'} :
  (∀ k, tr_stk (S k) (L.map (λ a, a k))) →
  tr_cfg ⟨q, v, S⟩ ⟨q.map normal, v, (stackel.bottom, [], L)⟩

theorem tr_respects_aux₁ {k} (o q v) : ∀ S₁ {s S₂} {T : list Γ'},
  T.map (λ (a : Γ'), a k) = (list.map stackel.val S₁).reverse_core (s :: S₂) →
  ∃ a T₁ T₂,
    T = list.reverse_core T₁ (a :: T₂) ∧
    a k = s ∧
    T₁.map (λ (a : Γ'), a k) = S₁.map stackel.val ∧
    T₂.map (λ (a : Γ'), a k) = S₂ ∧
    reaches₀ (TM1.step tr)
      ⟨some (go k o q), v, (stackel.bottom, [], T)⟩
      ⟨some (go k o q), v, (a, T₁ ++ [stackel.bottom], T₂)⟩
| [] s S₂ (a :: T) hT := by injection hT with es e₂; exact
  ⟨a, [], _, rfl, es, rfl, e₂, reaches₀.single rfl⟩
| (s' :: S₁) s S₂ T hT :=
  let ⟨a, T₁, b'::T₂, e, es', e₁, e₂, H⟩ := tr_respects_aux₁ S₁ hT in
  by injection e₂ with es e₂; exact
  ⟨b', a::T₁, T₂, e, es, by simpa [es'], e₂, H.tail (by simp! [es'])⟩

local attribute [simp] TM1.step TM1.step_aux tr tr_st_act st_var st_write
  tape.move tape.write list.reverse_core stackel.get stackel.is_bottom

theorem tr_respects_aux₂
  {k q v} {S : Π k, list (Γ k)} {T₁ T₂ : list Γ'} {a : Γ'}
  (hT : ∀ k, tr_stk (S k) ((T₁.reverse_core (a :: T₂)).map (λ (a : Γ'), a k)))
  (e₁ : T₁.map (λ (a : Γ'), a k) = list.map stackel.val (S k))
  (ea : a k = stackel.top k) (o) :
  let v' := st_var v (S k) o,
      Sk' := st_write v (S k) o,
      S' : ∀ k, list (Γ k) := dwrite S k Sk' in
  ∃ b (T₁' T₂' : list Γ'),
    (∀ (k' : K), tr_stk (S' k') ((T₁'.reverse_core (b :: T₂')).map (λ (a : Γ'), a k'))) ∧
    T₁'.map (λ a, a k) = Sk'.map stackel.val ∧
    b k = stackel.top k ∧
    TM1.step_aux (tr_st_act q o) v (a, T₁ ++ [stackel.bottom], T₂) =
    TM1.step_aux q v' (b, T₁' ++ [stackel.bottom], T₂') :=
begin
  dsimp, cases o with f b f,
  { -- push
    refine ⟨_, dwrite a k (stackel.val (f v)) :: T₁,
      _, _, by simp [e₁]; refl, by simp, rfl⟩,
    intro k', cases hT k' with n e,
    by_cases h : k' = k,
    { subst k', existsi n.pred,
      simp [list.reverse_core_eq, e₁, list.append_left_inj] at e ⊢,
      simp [e] },
    { cases T₂ with t T₂,
      { existsi n+1,
        simpa [h, list.reverse_core_eq, e₁, list.repeat_add] using
          congr_arg (++ [default Γ' k']) e },
      { existsi n,
        simpa [h, list.reverse_core_eq] using e } } },
  have dw := dwrite_self S k,
  cases T₁ with t T₁; cases eS : S k with s Sk;
    rw eS at e₁ dw; injection e₁ with tk e₁'; cases b,
  { -- peek nil
    simp [eS, dw],
    exact ⟨_, [], _, hT, rfl, ea, rfl⟩ },
  { -- pop nil
    simp [eS, dw],
    exact ⟨_, [], _, hT, rfl, ea, rfl⟩ },
  { -- peek cons
    dsimp at tk,
    simp [eS, tk, dw],
    exact ⟨_, t::T₁, _, hT, e₁, ea, rfl⟩ },
  { -- pop cons
    dsimp at tk,
    simp [eS, tk],
    refine ⟨_, _, _, _, e₁', by simp, rfl⟩,
    intro k', cases hT k' with n e,
    by_cases h : k' = k,
    { subst k', existsi n+1,
      simp [list.reverse_core_eq, eS, e₁', list.append_left_inj] at e ⊢,
      simp [e] },
    { existsi n, simpa [h, list.map_reverse_core] using e } },
end

theorem tr_respects_aux₃ {k q v}
  {S : Π k, list (Γ k)} {T : list Γ'}
  (hT : ∀ k, tr_stk (S k) (T.map (λ (a : Γ'), a k))) :
  ∀ (T₁ : list Γ') {T₂ : list Γ'} {a : Γ'} {S₁}
    (e : T = T₁.reverse_core (a :: T₂))
    (ha : (a k).is_bottom = ff)
    (e₁ : T₁.map (λ (a : Γ'), a k) = list.map stackel.val S₁),
    reaches₀ (TM1.step tr)
      ⟨some (ret k q), v, (a, T₁ ++ [stackel.bottom], T₂)⟩
      ⟨some (ret k q), v, (stackel.bottom, [], T)⟩
| [] T₂ a S₁ e ha e₁ := reaches₀.single (by simp [ha, e])
| (b :: T₁) T₂ a (s :: S₁) e ha e₁ := begin
    injection e₁ with es e₁, dsimp at es,
    refine reaches₀.head _ (tr_respects_aux₃ T₁ e (by simp [es]) e₁),
    simp [ha]
  end

theorem tr_respects_aux {q v T k} {S : Π k, list (Γ k)}
  (hT : ∀ (k : K), tr_stk (S k) (list.map (λ (a : Γ'), a k) T))
  (o : st_act k)
  (IH : ∀ {v : σ} {S : Π (k : K), list (Γ k)} {T : list Γ'},
    (∀ (k : K), tr_stk (S k) (list.map (λ (a : Γ'), a k) T)) →
    (∃ b, tr_cfg (TM2.step_aux q v S) b ∧
      reaches (TM1.step tr) (TM1.step_aux (tr_normal q) v (stackel.bottom, [], T)) b)) :
  ∃ b, tr_cfg (TM2.step_aux (st_run o q) v S) b ∧
    reaches (TM1.step tr) (TM1.step_aux (tr_normal (st_run o q))
      v (stackel.bottom, [], T)) b :=
begin
  rcases hT k with ⟨n, hTk⟩,
  simp [tr_normal_run],
  rcases tr_respects_aux₁ M o q v _ hTk with ⟨a, T₁, T₂, rfl, ea, e₁, e₂, hgo⟩,
  rcases tr_respects_aux₂ M hT e₁ ea _ with ⟨b, T₁', T₂', hT', e₁', eb, hrun⟩,
  have hret := tr_respects_aux₃ M hT' _ rfl (by simp [eb]) e₁',
  have := hgo.tail' rfl,
  simp [ea, tr] at this, rw [hrun, TM1.step_aux] at this,
  rcases IH hT' with ⟨c, gc, rc⟩,
  simp [step_run],
  refine ⟨c, gc, (this.to₀.trans hret _ (trans_gen.head' rfl rc)).to_refl⟩
end

local attribute [simp] respects TM2.step TM2.step_aux tr_normal

theorem tr_respects : respects (TM2.step M) (TM1.step tr) tr_cfg :=
λ c₁ c₂ h, begin
  cases h with l v S L hT, clear h,
  cases l; simp!,
  suffices : ∃ b, _ ∧ reaches (TM1.step (tr M)) _ _,
  from let ⟨b, c, r⟩ := this in ⟨b, c, trans_gen.head' rfl r⟩,
  rw [tr],
  revert v S L hT, refine stmt_st_rec _ _ _ _ _ (M l); intros,
  { exact tr_respects_aux M hT s @IH },
  { simp [IH hT] },
  { simp, cases p v; [exact IH₂ hT, exact IH₁ hT] },
  { exact ⟨_, ⟨hT⟩, refl_trans_gen.refl⟩ },
  { exact ⟨_, ⟨hT⟩, refl_trans_gen.refl⟩ }
end

theorem tr_cfg_init (k) (L : list (Γ k)) :
  tr_cfg (TM2.init k L) (TM1.init (tr_init k L)) :=
⟨λ k', begin
  simp [tr_init, (∘)],
  cases e : L.reverse with a L'; simp [tr_init],
  { cases list.reverse_eq_nil.1 e, simp, exact ⟨0, rfl⟩ },
  by_cases k' = k,
  { subst k', existsi 0,
    simp [list.reverse_core_eq, (∘)],
    rw [← list.map_reverse, e], refl },
  { simp [h, (∘)],
    existsi L'.length + 1,
    rw list.repeat_add, refl }
end⟩

theorem tr_eval_dom (k) (L : list (Γ k)) :
  (TM1.eval tr (tr_init k L)).dom ↔ (TM2.eval M k L).dom :=
tr_eval_dom tr_respects (tr_cfg_init _ _)

theorem tr_eval (k) (L : list (Γ k)) {L₁ L₂}
  (H₁ : L₁ ∈ TM1.eval tr (tr_init k L))
  (H₂ : L₂ ∈ TM2.eval M k L) :
  ∃ S : ∀ k, list (Γ k),
    (∀ k', tr_stk (S k') (L₁.map (λ a, a k'))) ∧ S k = L₂ :=
begin
  rcases (roption.mem_map_iff _).1 H₁ with ⟨c₁, h₁, rfl⟩,
  rcases (roption.mem_map_iff _).1 H₂ with ⟨c₂, h₂, rfl⟩,
  rcases tr_eval (tr_respects M) (tr_cfg_init M k L) h₂
    with ⟨_, ⟨q, v, S, L₁', hT⟩, h₃⟩,
  cases roption.mem_unique h₁ h₃,
  exact ⟨S, hT, rfl⟩
end

variables [fintype K] [∀ k, fintype (Γ k)] [fintype σ]
local attribute [instance] classical.dec
local attribute [simp] TM2.stmts₁_self

noncomputable def tr_stmts₁ : stmt₂ → finset Λ'
| Q@(TM2.stmt.push k f q)     := {go k (st_act.push f) q, ret k q} ∪ tr_stmts₁ q
| Q@(TM2.stmt.peek k f q)     := {go k (st_act.pop ff f) q, ret k q} ∪ tr_stmts₁ q
| Q@(TM2.stmt.pop k f q)      := {go k (st_act.pop tt f) q, ret k q} ∪ tr_stmts₁ q
| Q@(TM2.stmt.load a q)       := tr_stmts₁ q
| Q@(TM2.stmt.branch f q₁ q₂) := tr_stmts₁ q₁ ∪ tr_stmts₁ q₂
| _                           := ∅

theorem tr_stmts₁_run {k s q} : tr_stmts₁ (st_run s q) = {go k s q, ret k q} ∪ tr_stmts₁ q :=
by rcases s with _|_|_; dsimp [tr_stmts₁, st_run]; congr

noncomputable def tr_supp (S : finset Λ) : finset Λ' :=
S.bind (λ l, insert (normal l) (tr_stmts₁ (M l)))

local attribute [simp] tr_stmts₁ tr_stmts₁_run supports_run
  tr_normal_run TM1.supports_stmt TM2.supports_stmt

theorem tr_supports {S} (ss : TM2.supports M S) :
  TM1.supports tr (tr_supp S) :=
⟨finset.mem_bind.2 ⟨_, ss.1, finset.mem_insert.2 $ or.inl rfl⟩,
λ l' h, begin
  suffices : ∀ q (ss' : TM2.supports_stmt S q)
    (sub : ∀ x ∈ tr_stmts₁ M q, x ∈ tr_supp M S),
    TM1.supports_stmt (tr_supp M S) (tr_normal q) ∧
    (∀ l' ∈ tr_stmts₁ M q, TM1.supports_stmt (tr_supp M S) (tr M l')),
  { simp [tr_supp] at h,
    rcases h with ⟨l, lS, h⟩,
    have := this _ (ss.2 l lS) (λ x hx,
      finset.mem_bind.2 ⟨_, lS, finset.mem_insert_of_mem hx⟩),
    rcases h with rfl | h; [exact this.1, exact this.2 _ h] },
  refine stmt_st_rec _ _ _ _ _; clear h l'; intros,
  { -- stack op
    simp at sub ss',
    have hgo := sub _ (or.inr $ or.inr rfl),
    have hret := sub _ (or.inl rfl),
    cases IH ss' (λ x hx, sub x $ or.inr $ or.inl hx) with IH₁ IH₂,
    refine ⟨by simp [hgo], λ l h, _⟩,
    rw [tr_stmts₁_run] at h, simp at h,
    rcases h with rfl | h | rfl,
    { simp [hret], exact IH₁ },
    { exact IH₂ _ h },
    { simp [hgo],
      rcases s with _|_|_; simp! [hret] } },
  { -- load
    dsimp at sub ⊢, exact IH ss' sub },
  { -- branch
    simp at sub,
    cases IH₁ ss'.1 (λ x hx, sub x $ or.inl hx) with IH₁₁ IH₁₂,
    cases IH₂ ss'.2 (λ x hx, sub x $ or.inr hx) with IH₂₁ IH₂₂,
    refine ⟨⟨IH₁₁, IH₂₁⟩, λ l h, _⟩,
    rw [tr_stmts₁] at h, simp at h,
    rcases h with h | h; [exact IH₁₂ _ h, exact IH₂₂ _ h] },
  { -- goto
    rw tr_stmts₁, simp [tr_normal],
    exact λ v, finset.mem_bind.2 ⟨_, ss' v, by simp⟩ },
  { simp } -- halt
end⟩

end

end TM2to1

end turing


namespace Ex1

inductive T: Type :=
  | mk: String → Option T → T

def runT: T → Nat
  | .mk _ none => 0
  | .mk _ (some t) => runT t

class Run (α: Type) where
  run: α → Nat
instance: Run T := ⟨runT⟩

def x := T.mk "PrettyLong" (some <| .mk "PrettyLong" none)

theorem equivalent: Run.run x = Run.run x := by
  -- simp (config := { dsimp := false, decide := false, etaStruct := .none }) [Run.run]
  apply Eq.refl (runT x)

example : Run.run x = Run.run x := by
  simp [Run.run]

end Ex1

namespace Ex2

inductive Wrapper where
  | wrap: Wrapper

def Wrapper.extend: Wrapper → (Unit × Unit)
  | .wrap => ((), ())

mutual
inductive Op where
  | mk: String → Block → Op

inductive Assign where
  | mk : String → Op → Assign

inductive Block where
  | mk: Assign → Block
  | empty: Block
end

mutual
def runOp: Op → Wrapper
  | .mk _ r => let r' := runBlock r; .wrap

def runAssign: Assign → Wrapper
  | .mk _ op => runOp op

def runBlock: Block → Wrapper
  | .mk a => runAssign a
  | .empty => .wrap
end

private def b: Assign := .mk "r" (.mk "APrettyLongString" .empty)

theorem bug: (runAssign b).extend.snd = (runAssign b).extend.snd := by
  --unfold b -- extremely slow
  sorry

end Ex2

namespace Ex3

inductive ProgramType := | Op | Assign | Block

section
set_option hygiene false
notation "Op"     => Program ProgramType.Op
notation "Assign" => Program ProgramType.Assign
notation "Block"  => Program ProgramType.Block
end

inductive Program: (type: ProgramType) → Type :=
  | mkOp: String → Block → Op
  | mkAssign: String → Op → Assign
  | mkBlock: Assign → Block
  | emptyBlock: Block

def runBase: Program type → Nat
  | .mkOp _ v => let _ := runBase v; 0
  | .mkAssign _ t => runBase t
  | .mkBlock u => runBase u
  | .emptyBlock => 0

class Run (α: Type) where
  run: α → Nat
instance: Run Assign := ⟨runBase⟩

def x: Assign := .mkAssign "PrettyLong" <| .mkOp "PrettyLong" .emptyBlock
-- Now runs fine
theorem equivalent: Run.run x = Run.run x := by simp [Run.run]

end Ex3


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

/-!
# Morphisms of finite type

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

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

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

-/

noncomputable theory

open category_theory category_theory.limits opposite topological_space

universes v u

namespace algebraic_geometry

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

end algebraic_geometry


/- "Hello world" -/

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

#check true
-- Bool

def x := 10

#eval x + 2
-- 12

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

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


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

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

/-!
# Pi instances for multiplicative actions

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

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

## See also

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

universe u v w

variable {I : Type u}

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

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

namespace Pi

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

end Pi

namespace Function

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

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

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

end Function

namespace Set

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

end Set

section Extend

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

end Extend


import tactic.interactive

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

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

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

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