(** * 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.
#[local] Hint Extern 1 (Even _) => rewrite <- even_spec; reflexivity : core.
(* from here we talk about the operations defined in Chris Xu's paper *)
Inductive Increment: (nat*(list nat))->(nat*(list nat))->Prop :=
| Increment_even x xs y z zs:
Even x ->
Forall Nonzero xs ->
Forall Even xs ->
Odd y ->
Increment
(S x, xs ++ y :: z :: zs)
(x, xs ++ y :: S z :: zs)
| Increment_odd x y xs:
Odd x ->
Increment
(S x, y :: xs)
(x, S y :: xs)
.
Inductive Halve: (nat*(list nat))->(nat*(list nat))->Prop :=
| Halve_intro x xs:
Halve
(O, x :: xs)
(S x, xs)
.
Inductive Zero: (nat*(list nat))->(nat*(list nat))->Prop :=
| Zero_intro x xs y:
Forall Nonzero xs ->
Forall Even xs ->
Even x ->
Even y ->
Zero
(S x, xs ++ [y])
(x, xs ++ [S y; O; O])
.
Inductive Overflow: (nat*(list nat))->(nat*(list nat))->Prop :=
| Overflow_intro x xs y:
Forall Nonzero xs ->
Forall Even xs ->
Even x ->
Odd y ->
Overflow
(S x, xs ++ [y])
(S x, xs ++ [S y; O])
.
Inductive TryHalve: (nat*(list nat))->(nat*(list nat))->Prop :=
| TryHalve_1 x xs:
TryHalve
(O, x :: xs)
(S x, xs)
| TryHalve_0 x xs:
TryHalve
(S x, xs)
(S x, xs)
.
(* translation between savask's operations and Chris Xu's operations *)
Inductive toConfig: (nat*(list nat))->(Q*tape)->Prop :=
| toConfig_intro x xs:
toConfig (S x,xs) (lower (x::xs))
.

Lemma Overflow_toConfig s1 s2 s3 s4 c1 c4:
Overflow s1 s2 ->
Zero s2 s3 ->
TryHalve s3 s4 ->
toConfig s1 c1 ->
toConfig s4 c4 ->
c1 -->* c4.