(** * 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))
.
(* decode of Grey Code *)
Fixpoint grey_to_binary(xs:list bool):(list bool) :=
match xs with
| nil => nil
| xh::xt => (xorb xh (hd false (grey_to_binary xt)))::(grey_to_binary xt)
end.
Definition list_to_binary(xs:list nat):(list bool) :=
grey_to_binary (map odd xs).
Fixpoint binary_to_nat(xs:list bool):nat :=
match xs with
| nil => O
| xh::xt =>
(if xh then (S O) else O)+(binary_to_nat xt)*2
end.
(* n (binary) *)
Definition to_n_binary(s:nat*(list nat)) :=
list_to_binary (snd s).
(* n *)
Definition to_n(s:nat*(list nat)) :=
binary_to_nat (to_n_binary s).
(* s *)
Definition to_s(s:nat*(list nat)) :=
let (x,xs):=s in
xorb (even x) (hd false (list_to_binary xs)).
(* l *)
Definition to_l(s:nat*(list nat)) :=
length (to_n_binary s).
Ltac simpl_xor_neg :=
repeat (
rewrite <-Bool.negb_xorb_l ||
rewrite <-Bool.negb_xorb_r ||
rewrite Bool.negb_involutive ||
rewrite Bool.xorb_true_l ||
rewrite Bool.negb_true_iff ||
rewrite Bool.negb_false_iff);
try reflexivity.
Ltac simpl_oe_S :=
repeat (rewrite odd_succ || rewrite even_succ).
Ltac OE_oe :=
repeat (match goal with
| H: Even _ |- _ => rewrite <-even_spec in H
| H: Odd _ |- _ => rewrite <-odd_spec in H
end).
(* some trivial lemmas *)
Ltac simpl_list_to_binary_0s:=
unfold list_to_binary;
rewrite map_app;
rewrite map_odd_Even; [idtac | auto 1; fail];
rewrite grey_to_binary_0s;
cbn;
try rewrite hd_repeat.
(* s after Inc/Halve/Zero/Overflow *)
(* trivial properties of the config before Increment *)
(* n after Inc/Halve/Zero/Overflow *)
(* l after Inc/Halve/Zero/Overflow *)
(* <n/2^i> *)
Definition divpow2r(n i:nat) :=
(n+(2^i))/(2^(i+1)).
Definition ai(i:nat)(s:nat*(list nat)) :=
nth i (snd s) O.
Inductive Increments: nat->(nat*(list nat))->(nat*(list nat))->Prop :=
| Increments_O s: Increments O s s
| Increments_S n s1 s2 s3:
Increment s1 s2 ->
Increments n s2 s3 ->
Increments (S n) s1 s3
.
Inductive WF1: (nat*(list nat))->Prop :=
| WF1_intro x xs y:
Forall Nonzero xs ->
WF1 (x,xs ++ [y]).
Inductive WF2: (nat*(list nat))->Prop :=
| WF2_intro x xs y zs:
Forall Nonzero xs ->
Forall Even xs ->
Odd y ->
Forall Nonzero zs ->
WF2 (x,xs ++ y :: zs ++ [O; O])
.
(* weak pre-cond for Inc/Halve/Zero/Overflow *)
Inductive WF: (nat*(list nat))->Prop :=
| WF_1 s:
WF1 s -> WF s
| WF_2 s:
WF2 s -> WF s
.
Ltac Odd_Even_contra:=
match goal with
| H1:Odd ?x, H2:Even ?x |- _ => destruct (Even_Odd_False _ H2 H1)
end.
Ltac rsplit :=
try match goal with
| |- (?a /\ ?b) => split; rsplit
end.
Close Scope sym_scope.

Lemma Increments_inc_precond2 {s1} n:
WF2 s1 ->
to_s s1 = true ->
to_n s1 + n >= 2^(to_l s1 - 2) ->
to_n s1 + n < 2^(to_l s1) ->
fst s1 >= n ->
exists s2, Increments n s1 s2 /\ WF1 s2.