Module TM (Ctx : Ctx).
Export Ctx.
#[export] Hint Resolve all_qs_spec all_syms_spec : core.
(** A Turing machine is a function mapping each [(state, symbol)] pair to one of  - [None], in which case the machine halts; - [Some (s, d, q)], in which case the machine writes [s] on the tape, moves in the direction specified by [d], and transitions to state [q].  *)
Definition TM : Type := Q * Sym -> option (Sym * dir * Q).
Notation side := (Stream Sym).
(** The state of the tape is represented abstractly as a tuple [(l, s, r)], where [v] is the symbol under the head, while [l] and [r] are infinite streams of symbols on the left and right side of the head, respectively. *)
Notation tape := (side * Sym * side)%type.
(** We define a notation for tapes, evocative of a turing machine's head hovering over a particular symbol. **)
Notation "l {{ s }} r" := (l, s, r)
(at level 30, s at next level, only parsing).
Local Example tape_ex (a b c d e : Sym) : tape :=
const s0 << a << b {{c}} d >> e >> const s0.
(** Helper functions for moving the tape head: *)
Definition move_left (t : tape) : tape :=
match t with
| l {{s}} r => tl l {{hd l}} s >> r
end.
Definition move_right (t : tape) : tape :=
match t with
| l {{s}} r => l << s {{hd r}} tl r
end.
(** Notation for the configuration of a machine. Note that the position of the head within the tape is implicit, since the tape is centered at the head. *)
Notation "q ;; t" := (q, t) (at level 35, only parsing).
(** For the directed head formulation, we use the following: *)
Notation "l <{{ q }} r" := (q;; tl l {{hd l}} r)  (at level 30, q at next level).
Notation "l {{ q }}> r" := (q;; l {{hd r}} tl r)  (at level 30, q at next level).
(** The small-step semantics of Turing machines: *)
Reserved Notation "c -[ tm ]-> c'" (at level 40).
Inductive step (tm : TM) : Q * tape -> Q * tape -> Prop :=
| step_left q q' s s' l r :
tm (q, s) = Some (s', L, q') ->
q;; l {{s}} r -[ tm ]-> q';; (move_left (l {{s'}} r))
| step_right q q' s s' l r :
tm (q, s) = Some (s', R, q') ->
q;; l {{s}} r -[ tm ]-> q';; (move_right (l {{s'}} r))
where "c -[ tm ]-> c'" := (step tm c c').
Arguments step_left {tm q q' s s' l r}.
Arguments step_right {tm q q' s s' l r}.
#[export] Hint Constructors step : core.
(** If we have an assumption of the form [tm (q, s) = Some (s', d, q')], perform case analysis on [d]. *)
Ltac destruct_dir tm q s :=
lazymatch goal with
| H: tm (q, s) = Some (?s', ?d, ?q') |- _ =>
lazymatch d with
| L => fail
| R => fail
| _ => destruct d
end
end.
Local Hint Extern 1 =>
match goal with
| |- context [?q;; _ {{?s}} _ -[ ?tm ]-> _] => destruct_dir tm q s
end : core.
(** Executing a specified number of steps: *)
Reserved Notation "c -[ tm ]->> n / c'" (at level 40, n at next level).
Inductive multistep (tm : TM) : nat -> Q * tape -> Q * tape -> Prop :=
| multistep_0 c : c -[ tm ]->> 0 / c
| multistep_S n c c' c'' :
c  -[ tm ]->  c' ->
c' -[ tm ]->> n / c'' ->
c  -[ tm ]->> S n / c''
where "c -[ tm ]->> n / c'" := (multistep tm n c c').
#[export] Hint Constructors multistep : core.
Local Hint Extern 1 =>
lazymatch goal with
| H: _ -[ _ ]->> S _ / _ |- _ => inverts H
| H: _ -[ _ ]->> O / _ |- _ => inverts H
end : core.
(** Executing an unspecified number of steps (the "eventually reaches" relation): *)
Reserved Notation "c -[ tm ]->* c'" (at level 40).
Inductive evstep (tm : TM) : Q * tape -> Q * tape -> Prop :=
| evstep_refl c : c -[ tm ]->* c
| evstep_step c c' c'' :
c  -[ tm ]->  c'  ->
c' -[ tm ]->* c'' ->
c  -[ tm ]->* c''
where "c -[ tm ]->* c'" := (evstep tm c c').
#[export] Hint Constructors evstep : core.
(** Executing an unspecified, but non-zero number of steps: *)
Reserved Notation "c -[ tm ]->+ c'" (at level 40).
Inductive progress (tm : TM) : Q * tape -> Q * tape -> Prop :=
| progress_base c c' :
c -[ tm ]->  c' ->
c -[ tm ]->+ c'
| progress_step c c' c'' :
c  -[ tm ]->  c'  ->
c' -[ tm ]->+ c'' ->
c  -[ tm ]->+ c''
where "c -[ tm ]->+ c'" := (progress tm c c').
Arguments progress_base {tm c c'}.
Arguments progress_step {tm c c' c''}.
#[export] Hint Constructors progress : core.
(** The Turing machine has halted if [tm (q, s)] returns [None]. *)
Definition halted (tm : TM) (c : Q * tape) : Prop :=
match c with
| (q, l {{s}} r) => tm (q, s) = None
end.
(** The initial configuration of the machine *)
Definition tape0 : tape := const s0 {{s0}} const s0.
Definition c0 : Q * tape := q0;; tape0.
(** A Turing machine halts if it eventually reaches a halting configuration. *)
Definition halts_in (tm : TM) (c : Q * tape) (n : nat) :=
exists ch, c -[ tm ]->> n / ch /\ halted tm ch.
Definition halts (tm : TM) (c0 : Q * tape) :=
exists n, halts_in tm c0 n.
#[export] Hint Unfold halts halts_in : core.
#[export] Hint Rewrite move_left_tape0 move_right_tape0 : tape.
Ltac step_deterministic :=
lazymatch goal with
| H1: ?c -[ ?tm ]-> ?c',
H2: ?c -[ ?tm ]-> ?c''
|- _ =>
pose proof (step_deterministic tm c c' c'' H1 H2); subst c''; clear H2
end.
Local Hint Extern 1 => step_deterministic : core.
Ltac multistep_deterministic :=
lazymatch goal with
| H1: ?c -[ ?tm ]->> ?n / ?c',
H2: ?c -[ ?tm ]->> ?n / ?c''
|- _ =>
pose proof (multistep_deterministic tm n c c' c'' H1 H2); subst c''; clear H2
end.
Local Hint Extern 1 => multistep_deterministic : core.
Ltac deterministic := repeat (step_deterministic || multistep_deterministic).
#[export] Hint Resolve halts_in_S : core.
#[export] Hint Resolve halts_step : core.
#[export] Hint Resolve halts_multistep : core.
#[export] Hint Resolve multistep_progress : core.
Proof with eauto.
introv Hstep.
apply progress_nonhalt with (P := fun c => exists i, c = C i)...
- introv [i Hi]. subst c.
destruct (Hstep i) as [i' Hi']...
Qed.

Corollary progress_nonhalt_cond : forall tm (A : Type) (i0 : A)
(C : A -> Q * tape) (P : A -> Prop),
(forall i, P i -> exists i', C i -[ tm ]->+ C i' /\ P i') ->
P i0 ->
~ halts tm (C i0).