(** * 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.
Inductive Box(P:Prop):Prop :=
| Box_intro: P -> Box P
.
Inductive weakly_embanked: (nat*(list nat))->(nat*(list nat))->nat->nat->nat->nat->Prop :=
| weakly_embanked_intro n1' n2' s1' s2' s3' s4' s5' s6'
(* use ' to avoid auto-renaming of number suffix in the name *)
(Z12':Zero s1' s2')
(I23':Increments n1' s2' s3')
(H34':Halve s3' s4')
(I45':Increments (S n2') s4' s5')
(H56':Halve s5' s6')
(Hwf1':WF1 s1')
(Hs1s:to_s s1' = false)
(Hs1n:to_n s1' = O)
(Hs1l:to_l s1' >= 3)
(Hs1a0_odd:Odd (fst s1'))
(Hs1a0_lt:fst s1' < 2 ^ to_l s1' - 1)
(Hs1a1_lt:ai O s1' < 3 * (2 ^ (to_l s1' - 1)))
(Hwf6':WF1 s6')
(Hs6s:to_s s6' = false)
(Hs6l:to_l s6' = to_l s1')
(* use Box to avoid subst to use this equations *)
(n34_expr:Box ((to_n s4') = (to_n s3')/2))
(n56_expr:Box ((to_n s6') = (to_n s5')/2))
(n3_expr:(to_n s3') + (fst s1') = 2^(to_l s1'))
(n4_expr:(to_n s4') + (fst s1')/2 + 1 = 2^(to_l s1' - 1))
(n5_expr:(to_n s5') = (ai O s1') + 2^(to_l s1' - 1))
(n6_expr:(to_n s6') = (ai O s1')/2 + 2^(to_l s1' - 2))
(a60_expr:ai 1 s1' + 2 ^ (to_l s1' - 2) + divpow2r (to_n s5') 0 + 1 =
fst s6' + divpow2r (to_n s4') 0 + divpow2r (to_n s3') 1)
(a6_expr:forall i : nat,
ai (S (S i)) s1' + (if S (S i) =? to_l s1' - 1 then 1 else 0) + divpow2r (2^(to_l s1') - 1) (S (S i)) +
divpow2r (to_n s5') (S i) = ai i s6' + divpow2r (to_n s4') (S i) + divpow2r (to_n s3') (S (S i))):
weakly_embanked s1' s6' (to_n s3') (to_n s4') (to_n s5') (to_n s6').
Inductive embanked: (nat*(list nat))->(nat*(list nat))->nat->nat->nat->nat->Prop :=
| embanked_intro n1' s1' s6' s7' s8' s_1' h_1' s_2' h_2'
(Hwemb:weakly_embanked s1' s6' s_1' h_1' s_2' h_2')
(I67:Increments n1' s6' s7')
(Z78:Zero s7' s8')
(H_a60_ge_n6:fst s6' >= h_2')
(a70_expr : ai 1 s1' + 2 ^ (to_l s1' - 2) + divpow2r s_2' 0 - (to_n s7') + 1 =
fst s7' + h_2' + divpow2r h_1' 0 + divpow2r s_1' 1)
(a7_expr : forall i : nat,
ai (S (S i)) s1' + (if S (S i) =? (to_l s1') - 1 then 1 else 0) +
divpow2r (2 ^ (to_l s1') - 1) (S (S i)) + divpow2r s_2' (S i) + divpow2r h_2' i =
ai i s7' + divpow2r h_1' (S i) + divpow2r s_1' (S (S i)))
(Hwf7:WF1 s7')
(Hs7s:to_s s7' = false)
(Hs7n:to_n s7' = O)
(Hl_eq:to_l s1' = to_l s7'):
embanked s1' s7' s_1' h_1' s_2' h_2'.
Definition ai' i s :=
match i with
| O => fst s
| S i0 => ai i0 s
end.
Inductive Add2: nat->(nat*(list nat))->(nat*(list nat))->Prop :=
| Add2_intro i0 s1 s2
(Hadd2:forall i, ai' i s1 + (if Nat.eqb i i0 then 2 else 0) = ai' i s2):
Add2 i0 s1 s2
.

(* Lemma 3.5 *)
Lemma emb_wemb_s_h {e ne nne i s_1 h_1 s_2 h_2 s_1' h_1' s_2' h_2'}:
embanked e ne s_1 h_1 s_2 h_2 ->
weakly_embanked ne nne s_1' h_1' s_2' h_2' ->
Add2 i e ne ->
match i with
| O => (s_1,h_1,s_2,h_2) = (s_1'+2,h_1'+1,s_2',h_2')
| S O => (s_1,h_1,s_2+2,h_2+1) = (s_1',h_1',s_2',h_2')
| _ => (s_1,h_1,s_2,h_2) = (s_1',h_1',s_2',h_2')
end.