(** * Skelet #17 *)
Set Default Goal Selector "!".
Definition tm : TM := fun '(q, s) =>
match q, s with
| A, 0 => Some (1, R, B)  | A, 1 => None
| B, 0 => Some (0, L, C)  | B, 1 => Some (1, R, E)
| C, 0 => Some (0, L, D)  | C, 1 => Some (1, L, C)
| D, 0 => Some (1, R, A)  | D, 1 => Some (1, L, B)
| E, 0 => Some (0, R, B)  | E, 1 => Some (0, R, A)
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).
Notation "l <| r" := (l <{{C}} r) (at level 30).
Notation "l |> r" := (l {{B}}> r) (at level 30).
Local Hint Rewrite shift10 : tape_post.
(** ** List-of-exponents representation *)
(* the list starts with the element closest to the tape head *)
(* Note: [lowerL'] and [lowerR'] assume a (10)^n term will get prepended, and thus emit the separator for it. This could be written without an auxiliary definition, but this form is much easier to state lemmas about. *)
Fixpoint lowerL' (xs : list nat) : side :=
match xs with
| [] => const 0
| x::xs => lowerL' xs <* <[1; 0]^^x << 1
end.
Definition lowerL (xs : list nat) : side :=
match xs with
| [] => const 0
| x::xs => lowerL' xs <* <[1; 0]^^x
end.
Fixpoint lowerR' (xs : list nat) : side :=
match xs with
| [] => const 0
| x::xs => 1 >> [1; 0]^^x *> lowerR' xs
end.
Definition lowerR (xs : list nat) : side :=
match xs with
| [] => const 0
| x::xs => [1; 0]^^x *> lowerR' xs
end.
Definition lower (xs : list nat) : Q * tape :=
lowerL xs <| lowerR' [].
Definition lower' (xs : list nat) : Q * tape :=
lowerL xs |> lowerR' [].
(** ** Higher-level behavior *)
Notation Nonzero := (fun n => n <> O).
Ltac evstep1 := (econstructor; [ econstructor; reflexivity | cbn ]).
#[export] Hint Resolve -> Odd_succ : core.
#[export] Hint Resolve Forall_rev : core.

Lemma increment_S_even : forall x xs y z zs,
Forall Nonzero xs ->
Forall Even xs ->
Even (S x) ->
Odd y ->
lower (S x :: xs ++ y :: z :: zs) -->*
lower (x :: xs ++ y :: S z :: zs).