(** * Skelet #10 *)
(** Following https://www.sligocki.com/2023/03/14/skelet-10.html *)
Set Default Goal Selector "!".
Definition tm : TM := fun '(q, s) =>
match q, s with
| A, 0 => Some (1, R, B)  | A, 1 => Some (0, R, A)
| B, 0 => Some (0, L, C)  | B, 1 => Some (1, R, A)
| C, 0 => Some (1, R, E)  | C, 1 => Some (1, L, D)
| D, 0 => Some (1, L, C)  | D, 1 => Some (0, L, D)
| E, 0 => None            | E, 1 => Some (0, R, B)
end.
Notation "c --> c'" := (c -[ tm ]-> c')   (at level 40).
Notation "c -->* c'" := (c -[ tm ]->* c') (at level 40).
Notation "c -->+ c'" := (c -[ tm ]->+ c') (at level 40).
Inductive dorf : Set :=
| zend : dorf
| zO : dorf -> dorf
| zIO : dorf -> dorf.
(* Note: We don't actually need to define [val] for the proof to go through. It's just useful to sanity-check the definition. *)
Fixpoint val' (n : dorf) (prev cur : nat) : nat :=
match n with
| zend => 0
| zO n' => val' n' cur (cur + prev)
| zIO n' => cur + val' n' (cur + prev) (cur + prev + cur)
end.
Definition val (n : dorf) : nat := val' n 1 1.
Example val_11 : val (zO (zO (zIO (zIO zend)))) = 11.
(** * Right Side Counter *)
Fixpoint Z (n : dorf) : side :=
match n with
| zend => const 0
| zO n' => 0 >> Z n'
| zIO n' => 1 >> 0 >> Z n'
end.
(** * Left Side Counter *)
Fixpoint T (n : dorf) : side :=
match n with
| zend => const 0
| zO n' => T n' <* <[0; 0]
| zIO n' => T n' <* <[1; 0; 1; 0]
end.
Definition L (n : dorf) : side :=
match n with
| zend => const 0
| zO n' => T n'
| zIO n' => T n' <* <[1; 0]
end.
(** * Complete Behavior *)
Definition D (n : dorf) : (Q * tape) :=
L n <{{D}} Z (incr n).
Proof with execute.
unfold D.
destruct n...
- destruct n.
+ execute.
+ (* zO (zO n) *)
start_progress.
follow incr_right...
+ (* zO (zIO n) *)
start_progress.
follow incr_left...
- follow incr_left. start_progress.
follow incr_right. finish.
Qed.

Theorem nonhalt : ~ halts tm c0.