/-
Copyright (c) 2015 Haitao Zhang. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author : Haitao Zhang
-/
import theories.number_theory.primes data algebra.group algebra.group_power algebra.group_bigops
import .cyclic .finsubg .hom .perm .action

open nat fin list function subtype

namespace group_theory

section pgroup

open finset fintype

variables {G S : Type} [ambientG : group G] [deceqG : decidable_eq G] [finS : fintype S] [deceqS : decidable_eq S]
include ambientG

definition psubg (H : finset G) (p m : nat) : Prop := prime p ∧ card H = p^m

include deceqG finS deceqS
variables {H : finset G} [subgH : is_finsubg H]
include subgH

variables {hom : G → perm S} [Hom : is_hom_class hom]
include Hom
open finset.partition

lemma card_mod_eq_of_action_by_psubg {p : nat} :
  ∀ {m : nat}, psubg H p m → (card S) % p = (card (fixed_points hom H)) % p
| 0        := by rewrite [↑psubg, pow_zero]; intro Psubg;
  rewrite [finsubg_eq_singleton_one_of_card_one (and.right Psubg), fixed_points_of_one]
| (succ m) := take Ppsubg, begin
  rewrite [@orbit_class_equation' G S ambientG _ finS deceqS hom Hom H subgH],
  apply add_mod_eq_of_dvd, apply dvd_Sum_of_dvd,
  intro s Psin,
  rewrite mem_sep_iff at Psin,
  cases Psin with Psinorbs Pcardne,
  esimp [orbits, equiv_classes, orbit_partition] at Psinorbs,
  rewrite mem_image_iff at Psinorbs,
  cases Psinorbs with a Pa,
  cases Pa with Pain Porb,
  substvars,
  cases Ppsubg with Pprime PcardH,
  have Pdvd : card (orbit hom H a) ∣ p ^ (succ m),
    begin
      rewrite -PcardH,
      apply dvd_of_eq_mul (finset.card (stab hom H a)),
      apply orbit_stabilizer_theorem
    end,
  apply or.elim (eq_one_or_dvd_of_dvd_prime_pow Pprime Pdvd),
    intro Pcardeq, contradiction,
    intro Ppdvd, exact Ppdvd
  end

end pgroup

section psubg_cosets
open finset fintype
variables {G : Type} [ambientG : group G] [finG : fintype G] [deceqG : decidable_eq G]
include ambientG deceqG finG

variables {H : finset G} [finsubgH : is_finsubg H]
include finsubgH

lemma card_psubg_cosets_mod_eq {p : nat} {m : nat} :
  psubg H p m → (card (lcoset_type univ H)) % p = card (lcoset_type (normalizer H) H) % p :=
assume Psubg, by rewrite [-card_aol_fixed_points_eq_card_cosets]; exact card_mod_eq_of_action_by_psubg Psubg

end psubg_cosets

section cauchy

lemma prodl_rotl_eq_one_of_prodl_eq_one {A B : Type} [gB : group B] {f : A → B} :
  ∀ {l : list A}, Prodl l f = 1 → Prodl (list.rotl l) f = 1
| nil := assume Peq, rfl
| (a::l) := begin
  rewrite [rotl_cons, Prodl_cons f, Prodl_append _ _ f, Prodl_singleton],
  exact mul_eq_one_of_mul_eq_one
  end

section rotl_peo

variables {A : Type} [ambA : group A]
include ambA

variable [finA : fintype A]
include finA

variable (A)

definition all_prodl_eq_one (n : nat) : list (list A) :=
map (λ l, cons (Prodl l id)⁻¹ l) (all_lists_of_len n)

variable {A}

lemma prodl_eq_one_of_mem_all_prodl_eq_one {n : nat} {l : list A} : l ∈ all_prodl_eq_one A n → Prodl l id = 1 :=
assume Plin, obtain l' Pl' Pl, from exists_of_mem_map Plin,
by substvars; rewrite [Prodl_cons id _ l', mul.left_inv]

lemma length_of_mem_all_prodl_eq_one {n : nat} {l : list A} : l ∈ all_prodl_eq_one A n → length l = succ n :=
assume Plin, obtain l' Pl' Pl, from exists_of_mem_map Plin,
begin substvars, rewrite [length_cons, length_mem_all_lists Pl'] end

lemma nodup_all_prodl_eq_one {n : nat} : nodup (all_prodl_eq_one A n) :=
nodup_map (take l₁ l₂ Peq, tail_eq_of_cons_eq Peq) nodup_all_lists

lemma all_prodl_eq_one_complete {n : nat} : ∀ {l : list A}, length l = succ n → Prodl l id = 1 → l ∈ all_prodl_eq_one A n
| nil    := assume Pleq, by contradiction
| (a::l) := assume Pleq Pprod,
  begin
    rewrite length_cons at Pleq,
    rewrite (Prodl_cons id a l) at Pprod,
    rewrite [eq_inv_of_mul_eq_one Pprod],
    apply mem_map, apply mem_all_lists, apply succ.inj Pleq
  end

open fintype
lemma length_all_prodl_eq_one {n : nat} : length (@all_prodl_eq_one A _ _ n) = (card A)^n :=
eq.trans !length_map length_all_lists

open fin

definition prodseq {n : nat} (s : seq A n) : A := Prodl (upto n) s

definition peo [reducible] {n : nat} (s : seq A n) := prodseq s = 1

definition constseq {n : nat} (s : seq A (succ n)) := ∀ i, s i = s !zero

lemma prodseq_eq {n :nat} {s : seq A n} : prodseq s = Prodl (fun_to_list s) id :=
Prodl_map

lemma prodseq_eq_pow_of_constseq {n : nat} (s : seq A (succ n)) :
  constseq s → prodseq s = (s !zero) ^ succ n :=
assume Pc, have Pcl : ∀ i, i ∈ upto (succ n) → s i = s !zero,
  from take i, assume Pin, Pc i,
by rewrite [↑prodseq, Prodl_eq_pow_of_const _ Pcl, fin.length_upto]

lemma seq_eq_of_constseq_of_eq {n : nat} {s₁ s₂ : seq A (succ n)} :
  constseq s₁ → constseq s₂ → s₁ !zero = s₂ !zero → s₁ = s₂ :=
assume Pc₁ Pc₂ Peq, funext take i, by rewrite [Pc₁ i,  Pc₂ i, Peq]

lemma peo_const_one : ∀ {n : nat}, peo (λ i : fin n, (1 : A))
| 0 := rfl
| (succ n) := let s := λ i : fin (succ n), (1 : A) in
  have Pconst : constseq s, from take i, rfl,
  calc prodseq s = (s !zero) ^ succ n : prodseq_eq_pow_of_constseq s Pconst
             ... = (1 : A) ^ succ n : rfl
             ... = 1 : one_pow

variable [deceqA : decidable_eq A]
include deceqA

variable (A)

definition peo_seq [reducible] (n : nat) := {s : seq A (succ n) | peo s}

definition peo_seq_one (n : nat) : peo_seq A n :=
tag (λ i : fin (succ n), (1 : A)) peo_const_one

definition all_prodseq_eq_one (n : nat) : list (seq A (succ n)) :=
dmap (λ l, length l = card (fin (succ n))) list_to_fun (all_prodl_eq_one A n)

definition all_peo_seqs (n : nat) : list (peo_seq A n) :=
dmap peo tag (all_prodseq_eq_one A n)

variable {A}

lemma prodseq_eq_one_of_mem_all_prodseq_eq_one {n : nat} {s : seq A (succ n)} :
  s ∈ all_prodseq_eq_one A n → prodseq s = 1 :=
assume Psin, obtain l Pex, from exists_of_mem_dmap Psin,
obtain leq Pin Peq, from Pex,
by rewrite [prodseq_eq, Peq, list_to_fun_to_list, prodl_eq_one_of_mem_all_prodl_eq_one Pin]

lemma all_prodseq_eq_one_complete {n : nat} {s : seq A (succ n)} :
  prodseq s = 1 → s ∈ all_prodseq_eq_one A n :=
assume Peq,
have Plin : map s (elems (fin (succ n))) ∈ all_prodl_eq_one A n,
  from begin
  apply all_prodl_eq_one_complete,
    rewrite [length_map], exact length_upto (succ n),
    rewrite prodseq_eq at Peq, exact Peq
  end,
have Psin : list_to_fun (map s (elems (fin (succ n)))) (length_map_of_fintype s) ∈ all_prodseq_eq_one A n,
  from mem_dmap _ Plin,
by rewrite [fun_eq_list_to_fun_map s (length_map_of_fintype s)]; apply Psin

lemma nodup_all_prodseq_eq_one {n : nat} : nodup (all_prodseq_eq_one A n) :=
dmap_nodup_of_dinj dinj_list_to_fun nodup_all_prodl_eq_one

lemma rotl1_peo_of_peo {n : nat} {s : seq A n} : peo s → peo (rotl_fun 1 s) :=
begin rewrite [↑peo, *prodseq_eq, seq_rotl_eq_list_rotl], apply prodl_rotl_eq_one_of_prodl_eq_one end

section
local attribute perm.f [coercion]

lemma rotl_perm_peo_of_peo {n : nat} : ∀ {m} {s : seq A n}, peo s → peo (rotl_perm A n m s)
| 0        := begin rewrite [↑rotl_perm, rotl_seq_zero], intros, assumption end
| (succ m) := take s,
  have Pmul : rotl_perm A n (m + 1) s = rotl_fun 1 (rotl_perm A n m s), from
    calc s ∘ (rotl (m + 1)) = s ∘ ((rotl m) ∘ (rotl 1)) : rotl_compose
                        ... = s ∘ (rotl m) ∘ (rotl 1) : comp.assoc,
  begin
  rewrite [-add_one, Pmul], intro P,
  exact rotl1_peo_of_peo (rotl_perm_peo_of_peo P)
  end

end

lemma nodup_all_peo_seqs {n : nat} : nodup (all_peo_seqs A n) :=
dmap_nodup_of_dinj (dinj_tag peo) nodup_all_prodseq_eq_one

lemma all_peo_seqs_complete {n : nat} : ∀ s : peo_seq A n, s ∈ all_peo_seqs A n :=
take ps, subtype.destruct ps (take s, assume Ps,
  have Pin : s ∈ all_prodseq_eq_one A n, from all_prodseq_eq_one_complete Ps,
  mem_dmap Ps Pin)

lemma length_all_peo_seqs {n : nat} : length (all_peo_seqs A n) = (card A)^n :=
eq.trans (eq.trans
  (show length (all_peo_seqs A n) = length (all_prodseq_eq_one A n), from
    have Pmap : map elt_of (all_peo_seqs A n) = all_prodseq_eq_one A n,
      from map_dmap_of_inv_of_pos (λ s P, rfl)
        (λ s, prodseq_eq_one_of_mem_all_prodseq_eq_one),
    by rewrite [-Pmap, length_map])
  (show length (all_prodseq_eq_one A n) = length (all_prodl_eq_one A n), from
    have Pmap : map fun_to_list (all_prodseq_eq_one A n) = all_prodl_eq_one A n,
      from map_dmap_of_inv_of_pos list_to_fun_to_list
        (λ l Pin, by rewrite [length_of_mem_all_prodl_eq_one Pin, card_fin]),
    by rewrite [-Pmap, length_map]))
  length_all_prodl_eq_one

definition peo_seq_is_fintype [instance] {n : nat} : fintype (peo_seq A n) :=
fintype.mk (all_peo_seqs A n) nodup_all_peo_seqs all_peo_seqs_complete

lemma card_peo_seq {n : nat} : card (peo_seq A n) = (card A)^n :=
length_all_peo_seqs

section

variable (A)

local attribute perm.f [coercion]

definition rotl_peo_seq (n : nat) (m : nat) (s : peo_seq A n) : peo_seq A n :=
tag (rotl_perm A (succ n) m (elt_of s)) (rotl_perm_peo_of_peo (has_property s))

variable {A}

end

lemma rotl_peo_seq_zero {n : nat} : rotl_peo_seq A n 0 = id :=
funext take s, subtype.eq begin rewrite [↑rotl_peo_seq, ↑rotl_perm, rotl_seq_zero] end

lemma rotl_peo_seq_id {n : nat} : rotl_peo_seq A n (succ n) = id :=
funext take s, subtype.eq begin rewrite [↑rotl_peo_seq, -rotl_perm_pow_eq, rotl_perm_pow_eq_one] end

lemma rotl_peo_seq_compose {n i j : nat} :
  (rotl_peo_seq A n i) ∘ (rotl_peo_seq A n j) = rotl_peo_seq A n (j + i) :=
funext take s, subtype.eq begin rewrite [↑rotl_peo_seq, ↑rotl_perm, ↑rotl_fun, comp.assoc, rotl_compose] end

lemma rotl_peo_seq_mod {n i : nat} : rotl_peo_seq A n i = rotl_peo_seq A n (i % succ n) :=
funext take s, subtype.eq begin rewrite [↑rotl_peo_seq, rotl_perm_mod] end

lemma rotl_peo_seq_inj {n m : nat} : injective (rotl_peo_seq A n m) :=
take ps₁ ps₂, subtype.destruct ps₁ (λ s₁ P₁, subtype.destruct ps₂ (λ s₂ P₂,
  assume Peq, tag_eq (rotl_fun_inj (dinj_tag peo _ _ Peq))))

variable (A)

definition rotl_perm_ps [reducible] (n : nat) (m : fin (succ n)) : perm (peo_seq A n) :=
perm.mk (rotl_peo_seq A n m) rotl_peo_seq_inj

variable {A}

variable {n : nat}

lemma rotl_perm_ps_eq {m : fin (succ n)} {s : peo_seq A n} : elt_of (perm.f (rotl_perm_ps A n m) s) = perm.f (rotl_perm A (succ n) m) (elt_of s) := rfl

lemma rotl_perm_ps_eq_of_rotl_perm_eq {i j : fin (succ n)} :
  (rotl_perm A (succ n) i) = (rotl_perm A (succ n) j) → (rotl_perm_ps A n i) = (rotl_perm_ps A n j) :=
assume Peq, eq_of_feq (funext take s, subtype.eq (by rewrite [*rotl_perm_ps_eq, Peq]))

lemma rotl_perm_ps_hom (i j : fin (succ n)) :
  rotl_perm_ps A n (i+j) = (rotl_perm_ps A n i) * (rotl_perm_ps A n j) :=
eq_of_feq (begin rewrite [↑rotl_perm_ps, {val (i+j)}val_madd, add.comm, -rotl_peo_seq_mod, -rotl_peo_seq_compose] end)

section
local attribute group_of_add_group [instance]

definition rotl_perm_ps_is_hom [instance] : is_hom_class (rotl_perm_ps A n) :=
is_hom_class.mk rotl_perm_ps_hom

open finset

lemma const_of_is_fixed_point {s : peo_seq A n} :
  is_fixed_point (rotl_perm_ps A n) univ s → constseq (elt_of s) :=
assume Pfp, take i, begin
  rewrite [-(Pfp i !mem_univ) at {1}, rotl_perm_ps_eq, ↑rotl_perm, ↑rotl_fun, {i}mk_mod_eq at {2}, rotl_to_zero]
end

lemma const_of_rotl_fixed_point {s : peo_seq A n} :
  s ∈ fixed_points (rotl_perm_ps A n) univ → constseq (elt_of s) :=
assume Psin, take i, begin
  apply const_of_is_fixed_point, exact is_fixed_point_of_mem_fixed_points Psin
end

lemma pow_eq_one_of_mem_fixed_points {s : peo_seq A n} :
  s ∈ fixed_points (rotl_perm_ps A n) univ → (elt_of s !zero)^(succ n) = 1 :=
assume Psin, eq.trans
  (eq.symm (prodseq_eq_pow_of_constseq (elt_of s) (const_of_rotl_fixed_point Psin)))
  (has_property s)

lemma peo_seq_one_is_fixed_point : is_fixed_point (rotl_perm_ps A n) univ (peo_seq_one A n) :=
take h, assume Pin, by esimp [rotl_perm_ps]

lemma peo_seq_one_mem_fixed_points : peo_seq_one A n ∈ fixed_points (rotl_perm_ps A n) univ :=
mem_fixed_points_of_exists_of_is_fixed_point (exists.intro !zero !mem_univ) peo_seq_one_is_fixed_point

lemma generator_of_prime_of_dvd_order {p : nat}
  : prime p → p ∣ card A → ∃ g : A, g ≠ 1 ∧ g^p = 1 :=
assume Pprime Pdvd,
let pp := nat.pred p, spp := nat.succ pp in
have Peq : spp = p, from succ_pred_prime Pprime,
have Ppsubg : psubg (@univ (fin spp) _) spp 1,
  from and.intro (eq.symm Peq ▸ Pprime) (by rewrite [Peq, card_fin, pow_one]),
have (pow_nat (card A) pp) % spp = (card (fixed_points (rotl_perm_ps A pp) univ)) % spp,
  by rewrite -card_peo_seq; apply card_mod_eq_of_action_by_psubg Ppsubg,
have Pcardmod : (pow_nat (card A) pp) % p = (card (fixed_points (rotl_perm_ps A pp) univ)) % p,
  from Peq ▸ this,
have Pfpcardmod : (card (fixed_points (rotl_perm_ps A pp) univ)) % p = 0,
  from eq.trans (eq.symm Pcardmod) (mod_eq_zero_of_dvd (dvd_pow_of_dvd_of_pos Pdvd (pred_prime_pos Pprime))),
have Pfpcardpos : card (fixed_points (rotl_perm_ps A pp) univ) > 0,
  from card_pos_of_mem peo_seq_one_mem_fixed_points,
have Pfpcardgt1 : card (fixed_points (rotl_perm_ps A pp) univ) > 1,
  from gt_one_of_pos_of_prime_dvd Pprime Pfpcardpos Pfpcardmod,
obtain s₁ s₂ Pin₁ Pin₂ Psnes, from exists_two_of_card_gt_one Pfpcardgt1,
decidable.by_cases
  (λ Pe₁ : elt_of s₁ !zero = 1,
    have Pne₂ : elt_of s₂ !zero ≠ 1,
    from assume Pe₂,
      absurd
        (subtype.eq (seq_eq_of_constseq_of_eq
          (const_of_rotl_fixed_point Pin₁)
          (const_of_rotl_fixed_point Pin₂)
          (eq.trans Pe₁ (eq.symm Pe₂))))
        Psnes,
    exists.intro (elt_of s₂ !zero)
      (and.intro Pne₂ (Peq ▸ pow_eq_one_of_mem_fixed_points Pin₂)))
  (λ Pne, exists.intro (elt_of s₁ !zero)
    (and.intro Pne (Peq ▸ pow_eq_one_of_mem_fixed_points Pin₁)))
end

theorem cauchy_theorem {p : nat} : prime p → p ∣ card A → ∃ g : A, order g = p :=
assume Pprime Pdvd,
obtain g Pne Pgpow, from generator_of_prime_of_dvd_order Pprime Pdvd,
have Porder : order g ∣ p, from order_dvd_of_pow_eq_one Pgpow,
or.elim (eq_one_or_eq_self_of_prime_of_dvd Pprime Porder)
  (λ Pe, absurd (eq_one_of_order_eq_one Pe) Pne)
  (λ Porderp, exists.intro g Porderp)

end rotl_peo

end cauchy

section sylow

open finset fintype

variables {G : Type} [ambientG : group G] [finG : fintype G] [deceqG : decidable_eq G]
include ambientG deceqG finG

theorem first_sylow_theorem {p : nat} (Pp : prime p) :
  ∀ n, p^n ∣ card G → ∃ (H : finset G) (finsubgH : is_finsubg H), card H = p^n
| 0        := assume Pdvd, exists.intro ('{1})
  (exists.intro one_is_finsubg
    (by rewrite [pow_zero]))
| (succ n) := assume Pdvd,
  obtain H PfinsubgH PcardH, from first_sylow_theorem n (pow_dvd_of_pow_succ_dvd Pdvd),
  have Ppsubg : psubg H p n, from and.intro Pp PcardH,
  have Ppowsucc : p^(succ n) ∣ (card (lcoset_type univ H) * p^n),
    by rewrite [-PcardH, -(lagrange_theorem' !subset_univ)]; exact Pdvd,
  have Ppdvd : p ∣ card (lcoset_type (normalizer H) H), from
    dvd_of_mod_eq_zero
      (by rewrite [-(card_psubg_cosets_mod_eq Ppsubg), -dvd_iff_mod_eq_zero];
      exact dvd_of_pow_succ_dvd_mul_pow (pos_of_prime Pp) Ppowsucc),
  obtain J PJ, from cauchy_theorem Pp Ppdvd,
  exists.intro (fin_coset_Union (cyc J))
    (exists.intro _
      (by rewrite [pow_succ, -PcardH, -PJ]; apply card_Union_lcosets))

end sylow

end group_theory


/-
Copyright (c) 2020 Frédéric Dupuis. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Frédéric Dupuis
-/

import analysis.calculus.local_extr
import topology.algebra.affine

/-!
# Minima and maxima of convex functions

We show that if a function `f : E → β` is convex, then a local minimum is also
a global minimum, and likewise for concave functions.
-/

variables {E β: Type*} [add_comm_group E] [topological_space E]
  [module ℝ E] [topological_add_group E] [has_continuous_smul ℝ E]
  [linear_ordered_add_comm_group β] [module ℝ β] [ordered_module ℝ β]
  {s : set E}

open set filter
open_locale classical

/--
Helper lemma for the more general case: `is_min_on.of_is_local_min_on_of_convex_on`.
-/
lemma is_min_on.of_is_local_min_on_of_convex_on_Icc {f : ℝ → β} {a b : ℝ}
  (a_lt_b : a < b) (h_local_min : is_local_min_on f (Icc a b) a) (h_conv : convex_on (Icc a b) f) :
  ∀ x ∈ Icc a b, f a ≤ f x :=
begin
  by_contradiction H_cont,
  push_neg at H_cont,
  rcases H_cont with ⟨x, ⟨h_ax, h_xb⟩, fx_lt_fa⟩,
  obtain ⟨z, hz, ge_on_nhd⟩ : ∃ z > a, ∀ y ∈ (Icc a z), f y ≥ f a,
  { rcases eventually_iff_exists_mem.mp h_local_min with ⟨U, U_in_nhds_within, fy_ge_fa⟩,
    rw [nhds_within_Icc_eq_nhds_within_Ici a_lt_b, mem_nhds_within_Ici_iff_exists_Icc_subset]
        at U_in_nhds_within,
    rcases U_in_nhds_within with ⟨ε, ε_in_Ioi, Ioc_in_U⟩,
    exact ⟨ε, mem_Ioi.mp ε_in_Ioi, λ y y_in_Ioc, fy_ge_fa y $ Ioc_in_U y_in_Ioc⟩ },
  have a_lt_x : a < x := lt_of_le_of_ne h_ax (λ H, by subst H; exact lt_irrefl (f a) fx_lt_fa),
  have lt_on_nhd : ∀ y ∈ Ioc a x, f y < f a,
  { intros y y_in_Ioc,
    rcases (convex.mem_Ioc a_lt_x).mp y_in_Ioc with ⟨ya, yx, ya_pos, yx_pos, yax, y_combo⟩,
    calc
      f y = f (ya * a + yx * x)       : by rw [y_combo]
      ... ≤ ya • f a + yx • f x
                : h_conv.2 (left_mem_Icc.mpr (le_of_lt a_lt_b)) ⟨h_ax, h_xb⟩ (ya_pos)
                    (le_of_lt yx_pos) yax
      ... < ya • f a + yx • f a       : add_lt_add_left (smul_lt_smul_of_pos fx_lt_fa yx_pos) _
      ... = f a                       : by rw [←add_smul, yax, one_smul] },
  by_cases h_xz : x ≤ z,
  { exact not_lt_of_ge (ge_on_nhd x (show x ∈ Icc a z, by exact ⟨h_ax, h_xz⟩)) fx_lt_fa, },
  { have h₁ : z ∈ Ioc a x := ⟨hz, le_of_not_ge h_xz⟩,
    have h₂ : z ∈ Icc a z := ⟨le_of_lt hz, le_refl z⟩,
    exact not_lt_of_ge (ge_on_nhd z h₂) (lt_on_nhd z h₁) }
end

/--
A local minimum of a convex function is a global minimum, restricted to a set `s`.
-/
lemma is_min_on.of_is_local_min_on_of_convex_on {f : E → β} {a : E}
  (a_in_s : a ∈ s) (h_localmin: is_local_min_on f s a) (h_conv : convex_on s f) :
  ∀ x ∈ s, f a ≤ f x :=
begin
  by_contradiction H_cont,
  push_neg at H_cont,
  rcases H_cont with ⟨x, ⟨x_in_s, fx_lt_fa⟩⟩,
  let g : ℝ →ᵃ[ℝ] E := affine_map.line_map a x,
  have hg0 : g 0 = a := affine_map.line_map_apply_zero a x,
  have hg1 : g 1 = x := affine_map.line_map_apply_one a x,
  have fg_local_min_on : is_local_min_on (f ∘ g) (g ⁻¹' s) 0,
  { rw ←hg0 at h_localmin,
    refine is_local_min_on.comp_continuous_on h_localmin subset.rfl
      (continuous.continuous_on (affine_map.line_map_continuous)) _,
    simp [mem_preimage, hg0, a_in_s] },
  have fg_min_on : ∀ x ∈ (Icc 0 1 : set ℝ), (f ∘ g) 0 ≤ (f ∘ g) x,
  { have Icc_in_s' : Icc 0 1 ⊆ (g ⁻¹' s),
    { have h0 : (0 : ℝ) ∈ (g ⁻¹' s) := by simp [mem_preimage, a_in_s],
      have h1 : (1 : ℝ) ∈ (g ⁻¹' s) := by simp [mem_preimage, hg1, x_in_s],
      rw ←segment_eq_Icc (show (0 : ℝ) ≤ 1, by linarith),
      exact (convex.affine_preimage g h_conv.1).segment_subset
        (by simp [mem_preimage, hg0, a_in_s]) (by simp [mem_preimage, hg1, x_in_s]) },
    have fg_local_min_on' : is_local_min_on (f ∘ g) (Icc 0 1) 0 :=
      is_local_min_on.on_subset fg_local_min_on Icc_in_s',
    refine is_min_on.of_is_local_min_on_of_convex_on_Icc (by linarith) fg_local_min_on' _,
    exact (convex_on.comp_affine_map g h_conv).subset Icc_in_s' (convex_Icc 0 1) },
  have gx_lt_ga : (f ∘ g) 1 < (f ∘ g) 0 := by simp [hg1, fx_lt_fa, hg0],
  exact not_lt_of_ge (fg_min_on 1 (mem_Icc.mpr ⟨zero_le_one, le_refl 1⟩)) gx_lt_ga,
end

/-- A local maximum of a concave function is a global maximum, restricted to a set `s`. -/
lemma is_max_on.of_is_local_max_on_of_concave_on {f : E → β} {a : E}
  (a_in_s : a ∈ s) (h_localmax: is_local_max_on f s a) (h_conc : concave_on s f) :
  ∀ x ∈ s, f x ≤ f a :=
@is_min_on.of_is_local_min_on_of_convex_on
  _ (order_dual β) _ _ _ _ _ _ _ _ s f a a_in_s h_localmax h_conc

/-- A local minimum of a convex function is a global minimum. -/
lemma is_min_on.of_is_local_min_of_convex_univ {f : E → β} {a : E}
  (h_local_min : is_local_min f a) (h_conv : convex_on univ f) : ∀ x, f a ≤ f x :=
λ x, (is_min_on.of_is_local_min_on_of_convex_on (mem_univ a)
        (is_local_min.on h_local_min univ) h_conv) x (mem_univ x)

/-- A local maximum of a concave function is a global maximum. -/
lemma is_max_on.of_is_local_max_of_convex_univ {f : E → β} {a : E}
  (h_local_max : is_local_max f a) (h_conc : concave_on univ f) : ∀ x, f x ≤ f a :=
@is_min_on.of_is_local_min_of_convex_univ _ (order_dual β) _ _ _ _ _ _ _ _ f a h_local_max h_conc


/-
Copyright (c) 2020 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Mario Carneiro
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.computability.halting
import Mathlib.computability.turing_machine
import Mathlib.data.num.lemmas
import Mathlib.PostPort

universes l u_1

namespace Mathlib

/-!
# Modelling partial recursive functions using Turing machines

This file defines a simplified basis for partial recursive functions, and a `turing.TM2` model
Turing machine for evaluating these functions. This amounts to a constructive proof that every
`partrec` function can be evaluated by a Turing machine.

## Main definitions

* `to_partrec.code`: a simplified basis for partial recursive functions, valued in
  `list ℕ →. list ℕ`.
  * `to_partrec.code.eval`: semantics for a `to_partrec.code` program
* `partrec_to_TM2.tr`: A TM2 turing machine which can evaluate `code` programs
-/

namespace turing

/-!
## A simplified basis for partrec

This section constructs the type `code`, which is a data type of programs with `list ℕ` input and
output, with enough expressivity to write any partial recursive function. The primitives are:

* `zero'` appends a `0` to the input. That is, `zero' v = 0 :: v`.
* `succ` returns the successor of the head of the input, defaulting to zero if there is no head:
  * `succ [] = [1]`
  * `succ (n :: v) = [n + 1]`
* `tail` returns the tail of the input
  * `tail [] = []`
  * `tail (n :: v) = v`
* `cons f fs` calls `f` and `fs` on the input and conses the results:
  * `cons f fs v = (f v).head :: fs v`
* `comp f g` calls `f` on the output of `g`:
  * `comp f g v = f (g v)`
* `case f g` cases on the head of the input, calling `f` or `g` depending on whether it is zero or
  a successor (similar to `nat.cases_on`).
  * `case f g [] = f []`
  * `case f g (0 :: v) = f v`
  * `case f g (n+1 :: v) = g (n :: v)`
* `fix f` calls `f` repeatedly, using the head of the result of `f` to decide whether to call `f`
  again or finish:
  * `fix f v = []` if `f v = []`
  * `fix f v = w` if `f v = 0 :: w`
  * `fix f v = fix f w` if `f v = n+1 :: w` (the exact value of `n` is discarded)

This basis is convenient because it is closer to the Turing machine model - the key operations are
splitting and merging of lists of unknown length, while the messy `n`-ary composition operation
from the traditional basis for partial recursive functions is absent - but it retains a
compositional semantics. The first step in transitioning to Turing machines is to make a sequential
evaluator for this basis, which we take up in the next section.
-/

namespace to_partrec

/-- The type of codes for primitive recursive functions. Unlike `nat.partrec.code`, this uses a set
of operations on `list ℕ`. See `code.eval` for a description of the behavior of the primitives. -/
inductive code
where
| zero' : code
| succ : code
| tail : code
| cons : code → code → code
| comp : code → code → code
| case : code → code → code
| fix : code → code

/-- The semantics of the `code` primitives, as partial functions `list ℕ →. list ℕ`. By convention
we functions that return a single result return a singleton `[n]`, or in some cases `n :: v` where
`v` will be ignored by a subsequent function.

* `zero'` appends a `0` to the input. That is, `zero' v = 0 :: v`.
* `succ` returns the successor of the head of the input, defaulting to zero if there is no head:
  * `succ [] = [1]`
  * `succ (n :: v) = [n + 1]`
* `tail` returns the tail of the input
  * `tail [] = []`
  * `tail (n :: v) = v`
* `cons f fs` calls `f` and `fs` on the input and conses the results:
  * `cons f fs v = (f v).head :: fs v`
* `comp f g` calls `f` on the output of `g`:
  * `comp f g v = f (g v)`
* `case f g` cases on the head of the input, calling `f` or `g` depending on whether it is zero or
  a successor (similar to `nat.cases_on`).
  * `case f g [] = f []`
  * `case f g (0 :: v) = f v`
  * `case f g (n+1 :: v) = g (n :: v)`
* `fix f` calls `f` repeatedly, using the head of the result of `f` to decide whether to call `f`
  again or finish:
  * `fix f v = []` if `f v = []`
  * `fix f v = w` if `f v = 0 :: w`
  * `fix f v = fix f w` if `f v = n+1 :: w` (the exact value of `n` is discarded)
-/
@[simp] def code.eval : code → List ℕ →. List ℕ :=
  sorry

namespace code

/-- `nil` is the constant nil function: `nil v = []`. -/
def nil : code :=
  comp tail succ

@[simp] theorem nil_eval (v : List ℕ) : eval nil v = pure [] := sorry

/-- `id` is the identity function: `id v = v`. -/
def id : code :=
  comp tail zero'

@[simp] theorem id_eval (v : List ℕ) : eval id v = pure v := sorry

/-- `head` gets the head of the input list: `head [] = [0]`, `head (n :: v) = [n]`. -/
def head : code :=
  cons id nil

@[simp] theorem head_eval (v : List ℕ) : eval head v = pure [list.head v] := sorry

/-- `zero` is the constant zero function: `zero v = [0]`. -/
def zero : code :=
  cons zero' nil

@[simp] theorem zero_eval (v : List ℕ) : eval zero v = pure [0] := sorry

/-- `pred` returns the predecessor of the head of the input:
`pred [] = [0]`, `pred (0 :: v) = [0]`, `pred (n+1 :: v) = [n]`. -/
def pred : code :=
  case zero head

@[simp] theorem pred_eval (v : List ℕ) : eval pred v = pure [Nat.pred (list.head v)] := sorry

/-- `rfind f` performs the function of the `rfind` primitive of partial recursive functions.
`rfind f v` returns the smallest `n` such that `(f (n :: v)).head = 0`.

It is implemented as:

    rfind f v = pred (fix (λ (n::v), f (n::v) :: n+1 :: v) (0 :: v))

The idea is that the initial state is `0 :: v`, and the `fix` keeps `n :: v` as its internal state;
it calls `f (n :: v)` as the exit test and `n+1 :: v` as the next state. At the end we get
`n+1 :: v` where `n` is the desired output, and `pred (n+1 :: v) = [n]` returns the result.
 -/
def rfind (f : code) : code :=
  comp pred (comp (fix (cons f (cons succ tail))) zero')

/-- `prec f g` implements the `prec` (primitive recursion) operation of partial recursive
functions. `prec f g` evaluates as:

* `prec f g [] = [f []]`
* `prec f g (0 :: v) = [f v]`
* `prec f g (n+1 :: v) = [g (n :: prec f g (n :: v) :: v)]`

It is implemented as:

    G (a :: b :: IH :: v) = (b :: a+1 :: b-1 :: g (a :: IH :: v) :: v)
    F (0 :: f_v :: v) = (f_v :: v)
    F (n+1 :: f_v :: v) = (fix G (0 :: n :: f_v :: v)).tail.tail
    prec f g (a :: v) = [(F (a :: f v :: v)).head]

Because `fix` always evaluates its body at least once, we must special case the `0` case to avoid
calling `g` more times than necessary (which could be bad if `g` diverges). If the input is
`0 :: v`, then `F (0 :: f v :: v) = (f v :: v)` so we return `[f v]`. If the input is `n+1 :: v`,
we evaluate the function from the bottom up, with initial state `0 :: n :: f v :: v`. The first
number counts up, providing arguments for the applications to `g`, while the second number counts
down, providing the exit condition (this is the initial `b` in the return value of `G`, which is
stripped by `fix`). After the `fix` is complete, the final state is `n :: 0 :: res :: v` where
`res` is the desired result, and the rest reduces this to `[res]`. -/
def prec (f : code) (g : code) : code :=
  let G : code :=
    cons tail (cons succ (cons (comp pred tail) (cons (comp g (cons id (comp tail tail))) (comp tail (comp tail tail)))));
  let F : code := case id (comp (comp (comp tail tail) (fix G)) zero');
  cons (comp F (cons head (cons (comp f tail) tail))) nil

theorem exists_code.comp {m : ℕ} {n : ℕ} {f : vector ℕ n →. ℕ} {g : fin n → vector ℕ m →. ℕ} (hf : ∃ (c : code), ∀ (v : vector ℕ n), eval c (subtype.val v) = pure <$> f v) (hg : ∀ (i : fin n), ∃ (c : code), ∀ (v : vector ℕ m), eval c (subtype.val v) = pure <$> g i v) : ∃ (c : code), ∀ (v : vector ℕ m), eval c (subtype.val v) = pure <$> ((vector.m_of_fn fun (i : fin n) => g i v) >>= f) := sorry

theorem exists_code {n : ℕ} {f : vector ℕ n →. ℕ} (hf : nat.partrec' f) : ∃ (c : code), ∀ (v : vector ℕ n), eval c (subtype.val v) = pure <$> f v := sorry

end code

/-!
## From compositional semantics to sequential semantics

Our initial sequential model is designed to be as similar as possible to the compositional
semantics in terms of its primitives, but it is a sequential semantics, meaning that rather than
defining an `eval c : list ℕ →. list ℕ` function for each program, defined by recursion on
programs, we have a type `cfg` with a step function `step : cfg → option cfg` that provides a
deterministic evaluation order. In order to do this, we introduce the notion of a *continuation*,
which can be viewed as a `code` with a hole in it where evaluation is currently taking place.
Continuations can be assigned a `list ℕ →. list ℕ` semantics as well, with the interpretation
being that given a `list ℕ` result returned from the code in the hole, the remainder of the
program will evaluate to a `list ℕ` final value.

The continuations are:

* `halt`: the empty continuation: the hole is the whole program, whatever is returned is the
  final result. In our notation this is just `_`.
* `cons₁ fs v k`: evaluating the first part of a `cons`, that is `k (_ :: fs v)`, where `k` is the
  outer continuation.
* `cons₂ ns k`: evaluating the second part of a `cons`: `k (ns.head :: _)`. (Technically we don't
  need to hold on to all of `ns` here since we are already committed to taking the head, but this
  is more regular.)
* `comp f k`: evaluating the first part of a composition: `k (f _)`.
* `fix f k`: waiting for the result of `f` in a `fix f` expression:
  `k (if _.head = 0 then _.tail else fix f (_.tail))`

The type `cfg` of evaluation states is:

* `ret k v`: we have received a result, and are now evaluating the continuation `k` with result
  `v`; that is, `k v` where `k` is ready to evaluate.
* `halt v`: we are done and the result is `v`.

The main theorem of this section is that for each code `c`, the state `step_normal c halt v` steps
to `v'` in finitely many steps if and only if `code.eval c v = some v'`.
-/

/-- The type of continuations, built up during evaluation of a `code` expression. -/
inductive cont
where
| halt : cont
| cons₁ : code → List ℕ → cont → cont
| cons₂ : List ℕ → cont → cont
| comp : code → cont → cont
| fix : code → cont → cont

/-- The semantics of a continuation. -/
def cont.eval : cont → List ℕ →. List ℕ :=
  sorry

/-- The semantics of a continuation. -/
inductive cfg
where
| halt : List ℕ → cfg
| ret : cont → List ℕ → cfg

/-- Evaluating `c : code` in a continuation `k : cont` and input `v : list ℕ`. This goes by
recursion on `c`, building an augmented continuation and a value to pass to it.

* `zero' v = 0 :: v` evaluates immediately, so we return it to the parent continuation
* `succ v = [v.head.succ]` evaluates immediately, so we return it to the parent continuation
* `tail v = v.tail` evaluates immediately, so we return it to the parent continuation
* `cons f fs v = (f v).head :: fs v` requires two sub-evaluations, so we evaluate
  `f v` in the continuation `k (_.head :: fs v)` (called `cont.cons₁ fs v k`)
* `comp f g v = f (g v)` requires two sub-evaluations, so we evaluate
  `g v` in the continuation `k (f _)` (called `cont.comp f k`)
* `case f g v = v.head.cases_on (f v.tail) (λ n, g (n :: v.tail))` has the information needed to
  evaluate the case statement, so we do that and transition to either `f v` or `g (n :: v.tail)`.
* `fix f v = let v' := f v in if v'.head = 0 then k v'.tail else fix f v'.tail`
  needs to first evaluate `f v`, so we do that and leave the rest for the continuation (called
  `cont.fix f k`)
-/
def step_normal : code → cont → List ℕ → cfg :=
  sorry

/-- Evaluating a continuation `k : cont` on input `v : list ℕ`. This is the second part of
evaluation, when we receive results from continuations built by `step_normal`.

* `cont.halt v = v`, so we are done and transition to the `cfg.halt v` state
* `cont.cons₁ fs as k v = k (v.head :: fs as)`, so we evaluate `fs as` now with the continuation
  `k (v.head :: _)` (called `cons₂ v k`).
* `cont.cons₂ ns k v = k (ns.head :: v)`, where we now have everything we need to evaluate
  `ns.head :: v`, so we return it to `k`.
* `cont.comp f k v = k (f v)`, so we call `f v` with `k` as the continuation.
* `cont.fix f k v = k (if v.head = 0 then k v.tail else fix f v.tail)`, where `v` is a value,
  so we evaluate the if statement and either call `k` with `v.tail`, or call `fix f v` with `k` as
  the continuation (which immediately calls `f` with `cont.fix f k` as the continuation).
-/
def step_ret : cont → List ℕ → cfg :=
  sorry

/-- If we are not done (in `cfg.halt` state), then we must be still stuck on a continuation, so
this main loop calls `step_ret` with the new continuation. The overall `step` function transitions
from one `cfg` to another, only halting at the `cfg.halt` state. -/
def step : cfg → Option cfg :=
  sorry

/-- In order to extract a compositional semantics from the sequential execution behavior of
configurations, we observe that continuations have a monoid structure, with `cont.halt` as the unit
and `cont.then` as the multiplication. `cont.then k₁ k₂` runs `k₁` until it halts, and then takes
the result of `k₁` and passes it to `k₂`.

We will not prove it is associative (although it is), but we are instead interested in the
associativity law `k₂ (eval c k₁) = eval c (k₁.then k₂)`. This holds at both the sequential and
compositional levels, and allows us to express running a machine without the ambient continuation
and relate it to the original machine's evaluation steps. In the literature this is usually
where one uses Turing machines embedded inside other Turing machines, but this approach allows us
to avoid changing the ambient type `cfg` in the middle of the recursion.
-/
def cont.then : cont → cont → cont :=
  sorry

theorem cont.then_eval {k : cont} {k' : cont} {v : List ℕ} : cont.eval (cont.then k k') v = cont.eval k v >>= cont.eval k' := sorry

/-- The `then k` function is a "configuration homomorphism". Its operation on states is to append
`k` to the continuation of a `cfg.ret` state, and to run `k` on `v` if we are in the `cfg.halt v`
state. -/
def cfg.then : cfg → cont → cfg :=
  sorry

/-- The `step_normal` function respects the `then k'` homomorphism. Note that this is an exact
equality, not a simulation; the original and embedded machines move in lock-step until the
embedded machine reaches the halt state. -/
theorem step_normal_then (c : code) (k : cont) (k' : cont) (v : List ℕ) : step_normal c (cont.then k k') v = cfg.then (step_normal c k v) k' := sorry

/-- The `step_ret` function respects the `then k'` homomorphism. Note that this is an exact
equality, not a simulation; the original and embedded machines move in lock-step until the
embedded machine reaches the halt state. -/
theorem step_ret_then {k : cont} {k' : cont} {v : List ℕ} : step_ret (cont.then k k') v = cfg.then (step_ret k v) k' := sorry

/-- This is a temporary definition, because we will prove in `code_is_ok` that it always holds.
It asserts that `c` is semantically correct; that is, for any `k` and `v`,
`eval (step_normal c k v) = eval (cfg.ret k (code.eval c v))`, as an equality of partial values
(so one diverges iff the other does).

In particular, we can let `k = cont.halt`, and then this asserts that `step_normal c cont.halt v`
evaluates to `cfg.halt (code.eval c v)`. -/
def code.ok (c : code) :=
  ∀ (k : cont) (v : List ℕ),
    eval step (step_normal c k v) =
      do
        let v ← code.eval c v
        eval step (cfg.ret k v)

theorem code.ok.zero {c : code} (h : code.ok c) {v : List ℕ} : eval step (step_normal c cont.halt v) = cfg.halt <$> code.eval c v := sorry

theorem step_normal.is_ret (c : code) (k : cont) (v : List ℕ) : ∃ (k' : cont), ∃ (v' : List ℕ), step_normal c k v = cfg.ret k' v' := sorry

theorem cont_eval_fix {f : code} {k : cont} {v : List ℕ} (fok : code.ok f) : eval step (step_normal f (cont.fix f k) v) =
  do
    let v ← code.eval (code.fix f) v
    eval step (cfg.ret k v) := sorry

theorem code_is_ok (c : code) : code.ok c := sorry

theorem step_normal_eval (c : code) (v : List ℕ) : eval step (step_normal c cont.halt v) = cfg.halt <$> code.eval c v :=
  code.ok.zero (code_is_ok c)

theorem step_ret_eval {k : cont} {v : List ℕ} : eval step (step_ret k v) = cfg.halt <$> cont.eval k v := sorry

end to_partrec

/-!
## Simulating sequentialized partial recursive functions in TM2

At this point we have a sequential model of partial recursive functions: the `cfg` type and
`step : cfg → option cfg` function from the previous section. The key feature of this model is that
it does a finite amount of computation (in fact, an amount which is statically bounded by the size
of the program) between each step, and no individual step can diverge (unlike the compositional
semantics, where every sub-part of the computation is potentially divergent). So we can utilize the
same techniques as in the other TM simulations in `computability.turing_machine` to prove that
each step corresponds to a finite number of steps in a lower level model. (We don't prove it here,
but in anticipation of the complexity class P, the simulation is actually polynomial-time as well.)

The target model is `turing.TM2`, which has a fixed finite set of stacks, a bit of local storage,
with programs selected from a potentially infinite (but finitely accessible) set of program
positions, or labels `Λ`, each of which executes a finite sequence of basic stack commands.

For this program we will need four stacks, each on an alphabet `Γ'` like so:

    inductive Γ'  | Cons | cons | bit0 | bit1

We represent a number as a bit sequence, lists of numbers by putting `cons` after each element, and
lists of lists of natural numbers by putting `Cons` after each list. For example:

    0 ~> []
    1 ~> [bit1]
    6 ~> [bit0, bit1, bit1]
    [1, 2] ~> [bit1, cons, bit0, bit1, cons]
    [[], [1, 2]] ~> [Cons, bit1, cons, bit0, bit1, cons, Cons]

The four stacks are `main`, `rev`, `aux`, `stack`. In normal mode, `main` contains the input to the
current program (a `list ℕ`) and `stack` contains data (a `list (list ℕ)`) associated to the
current continuation, and in `ret` mode `main` contains the value that is being passed to the
continuation and `stack` contains the data for the continuation. The `rev` and `aux` stacks are
usually empty; `rev` is used to store reversed data when e.g. moving a value from one stack to
another, while `aux` is used as a temporary for a `main`/`stack` swap that happens during `cons₁`
evaluation.

The only local store we need is `option Γ'`, which stores the result of the last pop
operation. (Most of our working data are natural numbers, which are too large to fit in the local
store.)

The continuations from the previous section are data-carrying, containing all the values that have
been computed and are awaiting other arguments. In order to have only a finite number of
continuations appear in the program so that they can be used in machine states, we separate the
data part (anything with type `list ℕ`) from the `cont` type, producing a `cont'` type that lacks
this information. The data is kept on the `stack` stack.

Because we want to have subroutines for e.g. moving an entire stack to another place, we use an
infinite inductive type `Λ'` so that we can execute a program and then return to do something else
without having to define too many different kinds of intermediate states. (We must nevertheless
prove that only finitely many labels are accessible.) The labels are:

* `move p k₁ k₂ q`: move elements from stack `k₁` to `k₂` while `p` holds of the value being moved.
  The last element, that fails `p`, is placed in neither stack but left in the local store.
  At the end of the operation, `k₂` will have the elements of `k₁` in reverse order. Then do `q`.
* `clear p k q`: delete elements from stack `k` until `p` is true. Like `move`, the last element is
  left in the local storage. Then do `q`.
* `copy q`: Move all elements from `rev` to both `main` and `stack` (in reverse order),
  then do `q`. That is, it takes `(a, b, c, d)` to `(b.reverse ++ a, [], c, b.reverse ++ d)`.
* `push k f q`: push `f s`, where `s` is the local store, to stack `k`, then do `q`. This is a
  duplicate of the `push` instruction that is part of the TM2 model, but by having a subroutine
  just for this purpose we can build up programs to execute inside a `goto` statement, where we
  have the flexibility to be general recursive.
* `read (f : option Γ' → Λ')`: go to state `f s` where `s` is the local store. Again this is only
  here for convenience.
* `succ q`: perform a successor operation. Assuming `[n]` is encoded on `main` before,
  `[n+1]` will be on main after. This implements successor for binary natural numbers.
* `pred q₁ q₂`: perform a predecessor operation or `case` statement. If `[]` is encoded on
  `main` before, then we transition to `q₁` with `[]` on main; if `(0 :: v)` is on `main` before
  then `v` will be on `main` after and we transition to `q₁`; and if `(n+1 :: v)` is on `main`
  before then `n :: v` will be on `main` after and we transition to `q₂`.
* `ret k`: call continuation `k`. Each continuation has its own interpretation of the data in
  `stack` and sets up the data for the next continuation.
  * `ret (cons₁ fs k)`: `v :: k_data` on `stack` and `ns` on `main`, and the next step expects
    `v` on `main` and `ns :: k_data` on `stack`. So we have to do a little dance here with six
    reverse-moves using the `aux` stack to perform a three-point swap, each of which involves two
    reversals.
  * `ret (cons₂ k)`: `ns :: k_data` is on `stack` and `v` is on `main`, and we have to put
    `ns.head :: v` on `main` and `k_data` on `stack`. This is done using the `head` subroutine.
  * `ret (fix f k)`: This stores no data, so we just check if `main` starts with `0` and
    if so, remove it and call `k`, otherwise `clear` the first value and call `f`.
  * `ret halt`: the stack is empty, and `main` has the output. Do nothing and halt.

In addition to these basic states, we define some additional subroutines that are used in the
above:
* `push'`, `peek'`, `pop'` are special versions of the builtins that use the local store to supply
  inputs and outputs.
* `unrev`: special case `move ff rev main` to move everything from `rev` back to `main`. Used as a
  cleanup operation in several functions.
* `move_excl p k₁ k₂ q`: same as `move` but pushes the last value read back onto the source stack.
* `move₂ p k₁ k₂ q`: double `move`, so that the result comes out in the right order at the target
  stack. Implemented as `move_excl p k rev; move ff rev k₂`. Assumes that neither `k₁` nor `k₂` is
  `rev` and `rev` is initially empty.
* `head k q`: get the first natural number from stack `k` and reverse-move it to `rev`, then clear
  the rest of the list at `k` and then `unrev` to reverse-move the head value to `main`. This is
  used with `k = main` to implement regular `head`, i.e. if `v` is on `main` before then `[v.head]`
  will be on `main` after; and also with `k = stack` for the `cons` operation, which has `v` on
  `main` and `ns :: k_data` on `stack`, and results in `k_data` on `stack` and `ns.head :: v` on
  `main`.
* `tr_normal` is the main entry point, defining states that perform a given `code` computation.
  It mostly just dispatches to functions written above.

The main theorem of this section is `tr_eval`, which asserts that for each that for each code `c`,
the state `init c v` steps to `halt v'` in finitely many steps if and only if
`code.eval c v = some v'`.
-/

namespace partrec_to_TM2

/-- The alphabet for the stacks in the program. `bit0` and `bit1` are used to represent `ℕ` values
as lists of binary digits, `cons` is used to separate `list ℕ` values, and `Cons` is used to
separate `list (list ℕ)` values. See the section documentation. -/
inductive Γ'
where
| Cons : Γ'
| cons : Γ'
| bit0 : Γ'
| bit1 : Γ'

/-- The four stacks used by the program. `main` is used to store the input value in `tr_normal`
mode and the output value in `Λ'.ret` mode, while `stack` is used to keep all the data for the
continuations. `rev` is used to store reversed lists when transferring values between stacks, and
`aux` is only used once in `cons₁`. See the section documentation. -/
inductive K'
where
| main : K'
| rev : K'
| aux : K'
| stack : K'

/-- Continuations as in `to_partrec.cont` but with the data removed. This is done because we want
the set of all continuations in the program to be finite (so that it can ultimately be encoded into
the finite state machine of a Turing machine), but a continuation can handle a potentially infinite
number of data values during execution. -/
inductive cont'
where
| halt : cont'
| cons₁ : to_partrec.code → cont' → cont'
| cons₂ : cont' → cont'
| comp : to_partrec.code → cont' → cont'
| fix : to_partrec.code → cont' → cont'

/-- The set of program positions. We make extensive use of inductive types here to let us describe
"subroutines"; for example `clear p k q` is a program that clears stack `k`, then does `q` where
`q` is another label. In order to prevent this from resulting in an infinite number of distinct
accessible states, we are careful to be non-recursive (although loops are okay). See the section
documentation for a description of all the programs. -/
inductive Λ'
where
| move : (Γ' → Bool) → K' → K' → Λ' → Λ'
| clear : (Γ' → Bool) → K' → Λ' → Λ'
| copy : Λ' → Λ'
| push : K' → (Option Γ' → Option Γ') → Λ' → Λ'
| read : (Option Γ' → Λ') → Λ'
| succ : Λ' → Λ'
| pred : Λ' → Λ' → Λ'
| ret : cont' → Λ'

protected instance Λ'.inhabited : Inhabited Λ' :=
  { default := Λ'.ret cont'.halt }

/-- The type of TM2 statements used by this machine. -/
/-- The type of TM2 configurations used by this machine. -/
def stmt' :=
  TM2.stmt (fun (_x : K') => Γ') Λ' (Option Γ')

def cfg' :=
  TM2.cfg (fun (_x : K') => Γ') Λ' (Option Γ')

/-- A predicate that detects the end of a natural number, either `Γ'.cons` or `Γ'.Cons` (or
implicitly the end of the list), for use in predicate-taking functions like `move` and `clear`. -/
def nat_end : Γ' → Bool :=
  sorry

/-- Pop a value from the stack and place the result in local store. -/
/-- Peek a value from the stack and place the result in local store. -/
@[simp] def pop' (k : K') : stmt' → stmt' :=
  TM2.stmt.pop k fun (x v : Option Γ') => v

/-- Push the value in the local store to the given stack. -/
@[simp] def peek' (k : K') : stmt' → stmt' :=
  TM2.stmt.peek k fun (x v : Option Γ') => v

@[simp] def push' (k : K') : stmt' → stmt' :=
  TM2.stmt.push k fun (x : Option Γ') => option.iget x

/-- Move everything from the `rev` stack to the `main` stack (reversed). -/
def unrev (q : Λ') : Λ' :=
  Λ'.move (fun (_x : Γ') => false) K'.rev K'.main

/-- Move elements from `k₁` to `k₂` while `p` holds, with the last element being left on `k₁`. -/
def move_excl (p : Γ' → Bool) (k₁ : K') (k₂ : K') (q : Λ') : Λ' :=
  Λ'.move p k₁ k₂ (Λ'.push k₁ id q)

/-- Move elements from `k₁` to `k₂` without reversion, by performing a double move via the `rev`
stack. -/
def move₂ (p : Γ' → Bool) (k₁ : K') (k₂ : K') (q : Λ') : Λ' :=
  move_excl p k₁ K'.rev (Λ'.move (fun (_x : Γ') => false) K'.rev k₂ q)

/-- Assuming `tr_list v` is on the front of stack `k`, remove it, and push `v.head` onto `main`.
See the section documentation. -/
def head (k : K') (q : Λ') : Λ' :=
  Λ'.move nat_end k K'.rev
    (Λ'.push K'.rev (fun (_x : Option Γ') => some Γ'.cons)
      (Λ'.read
        fun (s : Option Γ') => ite (s = some Γ'.Cons) id (Λ'.clear (fun (x : Γ') => to_bool (x = Γ'.Cons)) k) (unrev q)))

/-- The program that evaluates code `c` with continuation `k`. This expects an initial state where
`tr_list v` is on `main`, `tr_cont_stack k` is on `stack`, and `aux` and `rev` are empty.
See the section documentation for details. -/
@[simp] def tr_normal : to_partrec.code → cont' → Λ' :=
  sorry

/-- The main program. See the section documentation for details. -/
@[simp] def tr : Λ' → stmt' :=
  sorry

/-- Translating a `cont` continuation to a `cont'` continuation simply entails dropping all the
data. This data is instead encoded in `tr_cont_stack` in the configuration. -/
def tr_cont : to_partrec.cont → cont' :=
  sorry

/-- We use `pos_num` to define the translation of binary natural numbers. A natural number is
represented as a little-endian list of `bit0` and `bit1` elements:

    1 = [bit1]
    2 = [bit0, bit1]
    3 = [bit1, bit1]
    4 = [bit0, bit0, bit1]

In particular, this representation guarantees no trailing `bit0`'s at the end of the list. -/
def tr_pos_num : pos_num → List Γ' :=
  sorry

/-- We use `num` to define the translation of binary natural numbers. Positive numbers are
translated using `tr_pos_num`, and `tr_num 0 = []`. So there are never any trailing `bit0`'s in
a translated `num`.

    0 = []
    1 = [bit1]
    2 = [bit0, bit1]
    3 = [bit1, bit1]
    4 = [bit0, bit0, bit1]
-/
def tr_num : num → List Γ' :=
  sorry

/-- Because we use binary encoding, we define `tr_nat` in terms of `tr_num`, using `num`, which are
binary natural numbers. (We could also use `nat.binary_rec_on`, but `num` and `pos_num` make for
easy inductions.) -/
def tr_nat (n : ℕ) : List Γ' :=
  tr_num ↑n

@[simp] theorem tr_nat_zero : tr_nat 0 = [] :=
  rfl

/-- Lists are translated with a `cons` after each encoded number.
For example:

    [] = []
    [0] = [cons]
    [1] = [bit1, cons]
    [6, 0] = [bit0, bit1, bit1, cons, cons]
-/
@[simp] def tr_list : List ℕ → List Γ' :=
  sorry

/-- Lists of lists are translated with a `Cons` after each encoded list.
For example:

    [] = []
    [[]] = [Cons]
    [[], []] = [Cons, Cons]
    [[0]] = [cons, Cons]
    [[1, 2], [0]] = [bit1, cons, bit0, bit1, cons, Cons, cons, Cons]
-/
@[simp] def tr_llist : List (List ℕ) → List Γ' :=
  sorry

/-- The data part of a continuation is a list of lists, which is encoded on the `stack` stack
using `tr_llist`. -/
@[simp] def cont_stack : to_partrec.cont → List (List ℕ) :=
  sorry

/-- The data part of a continuation is a list of lists, which is encoded on the `stack` stack
using `tr_llist`. -/
def tr_cont_stack (k : to_partrec.cont) : List Γ' :=
  tr_llist (cont_stack k)

/-- This is the nondependent eliminator for `K'`, but we use it specifically here in order to
represent the stack data as four lists rather than as a function `K' → list Γ'`, because this makes
rewrites easier. The theorems `K'.elim_update_main` et. al. show how such a function is updated
after an `update` to one of the components. -/
@[simp] def K'.elim (a : List Γ') (b : List Γ') (c : List Γ') (d : List Γ') : K' → List Γ' :=
  sorry

@[simp] theorem K'.elim_update_main {a : List Γ'} {b : List Γ'} {c : List Γ'} {d : List Γ'} {a' : List Γ'} : function.update (K'.elim a b c d) K'.main a' = K'.elim a' b c d := sorry

@[simp] theorem K'.elim_update_rev {a : List Γ'} {b : List Γ'} {c : List Γ'} {d : List Γ'} {b' : List Γ'} : function.update (K'.elim a b c d) K'.rev b' = K'.elim a b' c d := sorry

@[simp] theorem K'.elim_update_aux {a : List Γ'} {b : List Γ'} {c : List Γ'} {d : List Γ'} {c' : List Γ'} : function.update (K'.elim a b c d) K'.aux c' = K'.elim a b c' d := sorry

@[simp] theorem K'.elim_update_stack {a : List Γ'} {b : List Γ'} {c : List Γ'} {d : List Γ'} {d' : List Γ'} : function.update (K'.elim a b c d) K'.stack d' = K'.elim a b c d' := sorry

/-- The halting state corresponding to a `list ℕ` output value. -/
def halt (v : List ℕ) : cfg' :=
  TM2.cfg.mk none none (K'.elim (tr_list v) [] [] [])

/-- The `cfg` states map to `cfg'` states almost one to one, except that in normal operation the
local store contains an arbitrary garbage value. To make the final theorem cleaner we explicitly
clear it in the halt state so that there is exactly one configuration corresponding to output `v`.
-/
def tr_cfg : to_partrec.cfg → cfg' → Prop :=
  sorry

/-- This could be a general list definition, but it is also somewhat specialized to this
application. `split_at_pred p L` will search `L` for the first element satisfying `p`.
If it is found, say `L = l₁ ++ a :: l₂` where `a` satisfies `p` but `l₁` does not, then it returns
`(l₁, some a, l₂)`. Otherwise, if there is no such element, it returns `(L, none, [])`. -/
def split_at_pred {α : Type u_1} (p : α → Bool) : List α → List α × Option α × List α :=
  sorry

theorem split_at_pred_eq {α : Type u_1} (p : α → Bool) (L : List α) (l₁ : List α) (o : Option α) (l₂ : List α) : (∀ (x : α), x ∈ l₁ → p x = false) →
  (option.elim o (L = l₁ ∧ l₂ = []) fun (a : α) => p a = tt ∧ L = l₁ ++ a :: l₂) → split_at_pred p L = (l₁, o, l₂) := sorry

theorem split_at_pred_ff {α : Type u_1} (L : List α) : split_at_pred (fun (_x : α) => false) L = (L, none, []) :=
  split_at_pred_eq (fun (_x : α) => false) L L none [] (fun (_x : α) (_x : _x ∈ L) => rfl) { left := rfl, right := rfl }

theorem move_ok {p : Γ' → Bool} {k₁ : K'} {k₂ : K'} {q : Λ'} {s : Option Γ'} {L₁ : List Γ'} {o : Option Γ'} {L₂ : List Γ'} {S : K' → List Γ'} (h₁ : k₁ ≠ k₂) (e : split_at_pred p (S k₁) = (L₁, o, L₂)) : reaches₁ (TM2.step tr) (TM2.cfg.mk (some (Λ'.move p k₁ k₂ q)) s S)
  (TM2.cfg.mk (some q) o (function.update (function.update S k₁ L₂) k₂ (list.reverse_core L₁ (S k₂)))) := sorry

theorem unrev_ok {q : Λ'} {s : Option Γ'} {S : K' → List Γ'} : reaches₁ (TM2.step tr) (TM2.cfg.mk (some (unrev q)) s S)
  (TM2.cfg.mk (some q) none
    (function.update (function.update S K'.rev []) K'.main (list.reverse_core (S K'.rev) (S K'.main)))) :=
  move_ok (of_as_true trivial) (split_at_pred_ff (S K'.rev))

theorem move₂_ok {p : Γ' → Bool} {k₁ : K'} {k₂ : K'} {q : Λ'} {s : Option Γ'} {L₁ : List Γ'} {o : Option Γ'} {L₂ : List Γ'} {S : K' → List Γ'} (h₁ : k₁ ≠ K'.rev ∧ k₂ ≠ K'.rev ∧ k₁ ≠ k₂) (h₂ : S K'.rev = []) (e : split_at_pred p (S k₁) = (L₁, o, L₂)) : reaches₁ (TM2.step tr) (TM2.cfg.mk (some (move₂ p k₁ k₂ q)) s S)
  (TM2.cfg.mk (some q) none (function.update (function.update S k₁ (option.elim o id List.cons L₂)) k₂ (L₁ ++ S k₂))) := sorry

theorem clear_ok {p : Γ' → Bool} {k : K'} {q : Λ'} {s : Option Γ'} {L₁ : List Γ'} {o : Option Γ'} {L₂ : List Γ'} {S : K' → List Γ'} (e : split_at_pred p (S k) = (L₁, o, L₂)) : reaches₁ (TM2.step tr) (TM2.cfg.mk (some (Λ'.clear p k q)) s S) (TM2.cfg.mk (some q) o (function.update S k L₂)) := sorry

theorem copy_ok (q : Λ') (s : Option Γ') (a : List Γ') (b : List Γ') (c : List Γ') (d : List Γ') : reaches₁ (TM2.step tr) (TM2.cfg.mk (some (Λ'.copy q)) s (K'.elim a b c d))
  (TM2.cfg.mk (some q) none (K'.elim (list.reverse_core b a) [] c (list.reverse_core b d))) := sorry

theorem tr_pos_num_nat_end (n : pos_num) (x : Γ') (H : x ∈ tr_pos_num n) : nat_end x = false := sorry

theorem tr_num_nat_end (n : num) (x : Γ') (H : x ∈ tr_num n) : nat_end x = false := sorry

theorem tr_nat_nat_end (n : ℕ) (x : Γ') (H : x ∈ tr_nat n) : nat_end x = false :=
  tr_num_nat_end ↑n

theorem tr_list_ne_Cons (l : List ℕ) (x : Γ') (H : x ∈ tr_list l) : x ≠ Γ'.Cons := sorry

theorem head_main_ok {q : Λ'} {s : Option Γ'} {L : List ℕ} {c : List Γ'} {d : List Γ'} : reaches₁ (TM2.step tr) (TM2.cfg.mk (some (head K'.main q)) s (K'.elim (tr_list L) [] c d))
  (TM2.cfg.mk (some q) none (K'.elim (tr_list [list.head L]) [] c d)) := sorry

theorem head_stack_ok {q : Λ'} {s : Option Γ'} {L₁ : List ℕ} {L₂ : List ℕ} {L₃ : List Γ'} : reaches₁ (TM2.step tr)
  (TM2.cfg.mk (some (head K'.stack q)) s (K'.elim (tr_list L₁) [] [] (tr_list L₂ ++ Γ'.Cons :: L₃)))
  (TM2.cfg.mk (some q) none (K'.elim (tr_list (list.head L₂ :: L₁)) [] [] L₃)) := sorry

theorem succ_ok {q : Λ'} {s : Option Γ'} {n : ℕ} {c : List Γ'} {d : List Γ'} : reaches₁ (TM2.step tr) (TM2.cfg.mk (some (Λ'.succ q)) s (K'.elim (tr_list [n]) [] c d))
  (TM2.cfg.mk (some q) none (K'.elim (tr_list [Nat.succ n]) [] c d)) := sorry

theorem pred_ok (q₁ : Λ') (q₂ : Λ') (s : Option Γ') (v : List ℕ) (c : List Γ') (d : List Γ') : ∃ (s' : Option Γ'),
  reaches₁ (TM2.step tr) (TM2.cfg.mk (some (Λ'.pred q₁ q₂)) s (K'.elim (tr_list v) [] c d))
    (nat.elim (TM2.cfg.mk (some q₁) s' (K'.elim (tr_list (list.tail v)) [] c d))
      (fun (n : ℕ) (_x : TM2.cfg (fun (_x : K') => Γ') Λ' (Option Γ')) =>
        TM2.cfg.mk (some q₂) s' (K'.elim (tr_list (n :: list.tail v)) [] c d))
      (list.head v)) := sorry

theorem tr_normal_respects (c : to_partrec.code) (k : to_partrec.cont) (v : List ℕ) (s : Option Γ') : ∃ (b₂ : cfg'),
  tr_cfg (to_partrec.step_normal c k v) b₂ ∧
    reaches₁ (TM2.step tr) (TM2.cfg.mk (some (tr_normal c (tr_cont k))) s (K'.elim (tr_list v) [] [] (tr_cont_stack k)))
      b₂ := sorry

theorem tr_ret_respects (k : to_partrec.cont) (v : List ℕ) (s : Option Γ') : ∃ (b₂ : cfg'),
  tr_cfg (to_partrec.step_ret k v) b₂ ∧
    reaches₁ (TM2.step tr) (TM2.cfg.mk (some (Λ'.ret (tr_cont k))) s (K'.elim (tr_list v) [] [] (tr_cont_stack k))) b₂ := sorry

theorem tr_respects : respects to_partrec.step (TM2.step tr) tr_cfg := sorry

/-- The initial state, evaluating function `c` on input `v`. -/
def init (c : to_partrec.code) (v : List ℕ) : cfg' :=
  TM2.cfg.mk (some (tr_normal c cont'.halt)) none (K'.elim (tr_list v) [] [] [])

theorem tr_init (c : to_partrec.code) (v : List ℕ) : ∃ (b : cfg'), tr_cfg (to_partrec.step_normal c to_partrec.cont.halt v) b ∧ reaches₁ (TM2.step tr) (init c v) b :=
  tr_normal_respects c to_partrec.cont.halt v none

theorem tr_eval (c : to_partrec.code) (v : List ℕ) : eval (TM2.step tr) (init c v) = halt <$> to_partrec.code.eval c v := sorry