(**************************************************************)
(* Copyright Dominique Larchey-Wendling * *)
(* *)
(* * Affiliation LORIA -- CNRS *)
(**************************************************************)
(* This file is distributed under the terms of the *)
(* CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT *)
(**************************************************************)
Require Import List Arith Omega Bool.
Require Import utils pos vec.
Require Import subcode sss.
Require Import list_bool tiles_solvable bsm_defs.
Set Implicit Arguments.
Tactic Notation "rew" "length" := autorewrite with length_db.
Local Notation "e #> x" := (vec_pos e x).
Local Notation "e [ v / x ]" := (vec_change e x v).
Local Notation "P // s -[ k ]-> t" := (sss_steps (@bsm_sss _) P k s t).
Local Notation "P // s ->> t" := (sss_compute (@bsm_sss _) P s t).
Section Binary_Stack_Machines.
Variable (n : nat).
Ltac dest x y := destruct (pos_eq_dec x y) as [ | ]; [ subst x | ]; rew vec.
Section empty_stack.
Variable (x : pos n) (i : nat).
(* Code for emptying stack x *)
Definition empty_stack := POP x i (3+i) :: PUSH x Zero :: POP x i i :: nil.
Fact empty_stack_length : length empty_stack = 3.
Proof. auto. Qed.
Fact empty_stack_spec v : (i,empty_stack) // (i,v) ->> (3+i,v[nil/x]).
Proof.
set (l := v#>x).
generalize (eq_refl l).
unfold l at 2.
generalize l v; clear l v.
unfold empty_stack.
induction l as [ | [] l IHl ]; intros v Hv.
bsm sss POP empty with x i (3+i).
bsm sss stop; f_equal.
apply vec_pos_ext; intros p; dest x p.
bsm sss POP 1 with x i (3+i) l.
bsm sss PUSH with x Zero.
bsm sss POP 0 with x i i l; rew vec.
clear Hv.
specialize (IHl (v[l/x])).
spec in IHl.
rew vec.
revert IHl; rew vec.
bsm sss POP 0 with x i (3+i) l.
clear Hv.
specialize (IHl (v[l/x])).
spec in IHl.
rew vec.
revert IHl; rew vec.
Qed.
End empty_stack.
Section move_rev.
Variable (x y : pos n) (Hxy : x <> y) (i : nat).
Let y' := y.
(* Code that transfers stack x to y, reversing x in the interval *)
Definition move_rev_stack :=
(* i *) POP x (4+i) (7+i) ::
(* 1+i *) PUSH y One :: PUSH y' Zero :: POP y' i i ::
(* 4+i *) PUSH y Zero :: PUSH x Zero :: POP x i i ::
(* 7+i *) nil.
Fact length_move_rev_stack : length move_rev_stack = 7.
Proof. auto. Qed.
Fact move_rev_stack_spec l v w :
v#>x = l
-> w = v[nil/x][(rev l++v#>y)/y]
-> (i,move_rev_stack) // (i,v) ->> (7+i,w).
Proof.
revert v w; induction l as [ | [] l IHl ]; intros v w Hv Hw; subst w; unfold move_rev_stack.
* bsm sss POP empty with x (4+i) (7+i).
bsm sss stop.
f_equal.
apply vec_pos_ext; intros z; dest z y; dest z x.
* bsm sss POP 1 with x (4+i) (7+i) l.
bsm sss PUSH with y One.
bsm sss PUSH with y' Zero.
bsm sss POP 0 with y' i i (One::v#>y); unfold y'; rew vec.
apply IHl; rew vec.
apply vec_pos_ext; intros z.
dest z y; simpl; solve list eq.
dest z x.
* bsm sss POP 0 with x (4+i) (7+i) l.
bsm sss PUSH with y Zero.
bsm sss PUSH with x Zero.
bsm sss POP 0 with x i i l; rew vec.
apply IHl; rew vec.
apply vec_pos_ext; intros z.
dest z y; simpl; solve list eq.
dest z x.
Qed.
End move_rev.
Section copy_rev_stack.
Variable (x y z : pos n) (Hxy : x <> y) (Hxz : x <> z) (Hyz : y <> z) (i : nat).
Let y' := y.
(* Code that transfers x to both y and z, reversing x in the interval *)
Definition copy_rev_stack :=
(* i *) POP x (5+i) (9+i) ::
(* 1+i *) PUSH y One :: PUSH z One :: PUSH y' Zero :: POP y' i i ::
(* 5+i *) PUSH y Zero :: PUSH z Zero :: PUSH x Zero :: POP x i i ::
(* 9+i *) nil.
Fact length_copy_rev_stack : length copy_rev_stack = 9.
Proof. auto. Qed.
Fact copy_rev_stack_spec l v w :
v#>x = l
-> w = v[nil/x][(rev l++v#>y)/y][(rev l++v#>z)/z]
-> (i,copy_rev_stack) // (i,v) ->> (9+i,w).
Proof.
revert v w; induction l as [ | [] l IHl ]; intros v w Hv Hw; subst w; unfold copy_rev_stack.
* bsm sss POP empty with x (5+i) (9+i).
bsm sss stop.
f_equal.
apply vec_pos_ext; intros k; dest k z; dest k y; dest k x.
* bsm sss POP 1 with x (5+i) (9+i) l.
bsm sss PUSH with y One.
bsm sss PUSH with z One.
bsm sss PUSH with y' Zero.
bsm sss POP 0 with y' i i (One::v#>y); unfold y'; rew vec.
apply IHl; rew vec.
apply vec_pos_ext; intros k.
dest k z; simpl; solve list eq.
dest k y; dest k x.
* bsm sss POP 0 with x (5+i) (9+i) l.
bsm sss PUSH with y Zero.
bsm sss PUSH with z Zero.
bsm sss PUSH with x Zero.
bsm sss POP 0 with x i i l; rew vec.
apply IHl; rew vec.
apply vec_pos_ext; intros k.
dest k z; simpl; solve list eq.
dest k y; dest k x.
Qed.
End copy_rev_stack.
Hint Rewrite empty_stack_length length_move_rev_stack length_copy_rev_stack : length_db.
Section copy_stack.
Variable (x y z : pos n) (Hxy : x <> y) (Hxz : x <> z) (Hyz : y <> z) (i : nat).
(* Code that copies x into y, stack z must be an empty spare stack *)
Definition copy_stack := move_rev_stack x z i ++ copy_rev_stack z x y (7+i).
Fact copy_stack_length : length copy_stack = 16.
Proof. auto. Qed.
Fact copy_stack_spec l v w :
v#>x = l
-> v#>z = nil
-> w = v[(l++v#>y)/y]
-> (i,copy_stack) // (i,v) ->> (16+i,w).
Proof.
intros H1 H2 H3; subst w.
unfold copy_stack.
apply sss_compute_trans with (st2 := (7+i,v[nil/x][(rev l)/z])).
* apply subcode_sss_compute with (P := (i,move_rev_stack x z i)); auto.
apply move_rev_stack_spec with l; auto.
rew vec; rewrite H2; solve list eq.
* apply subcode_sss_compute with (P := (7+i,copy_rev_stack z x y (7+i))); auto.
apply copy_rev_stack_spec with (rev l); rew vec.
apply vec_pos_ext; intros k.
dest k z; simpl; solve list eq.
dest k y; [ | dest k x ];
rewrite rev_involutive; auto.
Qed.
End copy_stack.
Hint Rewrite copy_stack_length : length_db.
Section compare_stacks.
Variables (x y : pos n) (Hxy : x <> y) (i p q : nat).
Let x' := x.
(* Code that compares two stacks x and y:
- ends at p if the stacks x and y are identical
- ends at q otherwise
The status of x and y is unspecified after the
execution but the stacks other than x and y are
unmodified *)
Definition compare_stacks :=
(* i *) POP x (4+i) (7+i) ::
(* 1+i *) POP y q q ::
(* 2+i *) PUSH x Zero :: POP x i i ::
(* 4+i *) POP y i q ::
(* 5+i *) PUSH y Zero :: POP y q i ::
(* 7+i *) POP y q p ::
(* 8+i *) PUSH x' Zero :: POP x' q q :: nil.
Fact compare_stacks_length : length compare_stacks = 10.
Proof. auto. Qed.
Let cs_spec_rec l : forall m v, v#>x = l
-> v#>y = m
-> exists w, (forall z, z <> x -> z <> y -> v#>z = w#>z)
/\ (l = m -> (i,compare_stacks) // (i,v) ->> (p,w))
/\ (l <> m -> (i,compare_stacks) // (i,v) ->> (q,w)).
Proof.
induction l as [ | [] l IHl ]; intros [ | [] m ] v Hx Hy; unfold compare_stacks.
(* l = nil, m = nil *)
exists v; split; auto.
split; [ intros _ | intros [] ]; auto.
bsm sss POP empty with x (4+i) (7+i).
bsm sss POP empty with y q p.
bsm sss stop.
(* l = nil, m = One::_ *)
exists (v[m/y]); split.
intros; rew vec.
split; [ discriminate | intros _ ].
bsm sss POP empty with x (4+i) (7+i).
bsm sss POP 1 with y q p m.
bsm sss PUSH with x' Zero.
bsm sss POP 0 with x' q q nil.
rew vec; f_equal; auto.
bsm sss stop; f_equal.
unfold x'; rew vec.
apply vec_pos_ext; intros z; dest x z.
(* l = nil, m = Zero::_ *)
exists (v[m/y]); split.
intros; rew vec.
split; [ discriminate | intros _ ].
bsm sss POP empty with x (4+i) (7+i).
bsm sss POP 0 with y q p m.
bsm sss stop.
(* l = One::_, m = nil *)
exists (v[l/x]); split.
intros; rew vec.
split; [ discriminate | intros _ ].
bsm sss POP 1 with x (4+i) (7+i) l.
bsm sss POP empty with y q q; rew vec.
bsm sss stop.
(* l = One::l', m = One::m' *)
destruct (IHl m (v[l/x][m/y])) as (w & H1 & H2 & H3); rew vec.
exists w; split.
intros z G1 G2; specialize (H1 _ G1 G2); rewrite <- H1; rew vec.
split.
intros E1; inversion E1 as [ E ]; clear E1.
specialize (H2 E).
bsm sss POP 1 with x (4+i) (7+i) l.
bsm sss POP 1 with y q q m; rew vec.
bsm sss PUSH with x Zero.
bsm sss POP 0 with x i i l; rew vec.
eq goal H2; do 2 f_equal.
apply vec_pos_ext; intros z; dest z x.
intros E1.
spec in H3.
contradict E1; subst; auto.
bsm sss POP 1 with x (4+i) (7+i) l.
bsm sss POP 1 with y q q m; rew vec.
bsm sss PUSH with x Zero.
bsm sss POP 0 with x i i l; rew vec.
eq goal H3; do 2 f_equal.
apply vec_pos_ext; intros z; dest z x.
(* l = One::l', m = Zero::m' *)
exists (v[l/x][m/y]).
split.
intros; rew vec.
split; [ discriminate | intros _ ].
bsm sss POP 1 with x (4+i) (7+i) l.
bsm sss POP 0 with y q q m; rew vec.
bsm sss stop.
(* l = Zero::l', m = nil *)
exists (v[l/x]).
split.
intros; rew vec.
split; [ discriminate | intros _ ].
bsm sss POP 0 with x (4+i) (7+i) l.
bsm sss POP empty with y i q; rew vec.
bsm sss stop.
(* l = Zero::l', m = nil *)
exists (v[l/x][m/y]).
split.
intros; rew vec.
split; [ discriminate | intros _ ].
bsm sss POP 0 with x (4+i) (7+i) l.
bsm sss POP 1 with y i q m; rew vec.
bsm sss PUSH with y Zero.
bsm sss POP 0 with y q i m; rew vec.
bsm sss stop.
(* l = Zero::l', m = Zero::m' *)
destruct (IHl m (v[l/x][m/y])) as (w & H1 & H2 & H3); rew vec.
exists w; split.
intros z G1 G2; specialize (H1 _ G1 G2); rewrite <- H1; rew vec.
split.
intros E1; inversion E1 as [ E ]; clear E1.
specialize (H2 E).
bsm sss POP 0 with x (4+i) (7+i) l.
bsm sss POP 0 with y i q m; rew vec.
intros E1.
spec in H3.
contradict E1; subst; auto.
bsm sss POP 0 with x (4+i) (7+i) l.
bsm sss POP 0 with y i q m; rew vec.
Qed.
Fact compare_stack_eq_spec v :
v#>x = v#>y
-> exists w, (i,compare_stacks) // (i,v) ->> (p,w)
/\ forall z, z <> x -> z <> y -> v#>z = w#>z.
Proof.
intros E.
destruct (cs_spec_rec v eq_refl eq_refl) as (w & H1 & H2 & H3).
exists w; split; auto.
Qed.
Fact compare_stack_neq_spec v :
v#>x <> v#>y
-> exists w, (i,compare_stacks) // (i,v) ->> (q,w)
/\ forall z, z <> x -> z <> y -> v#>z = w#>z.
Proof.
intros E.
destruct (cs_spec_rec v eq_refl eq_refl) as (w & H1 & H2 & H3).
exists w; split; auto.
Qed.
Theorem compare_stack_spec v : exists j w, (i,compare_stacks) // (i,v) ->> (j,w)
/\ forall z, z <> x -> z <> y -> v#>z = w#>z
/\ (v#>x = v#>y /\ j = p \/ v#>x <> v#>y /\ j = q).
Proof.
destruct (list_bool_dec (v#>x) (v#>y)) as [ H | H ].
+ destruct compare_stack_eq_spec with (1 := H) as (w & H1 & H2); exists p, w; auto.
+ destruct compare_stack_neq_spec with (1 := H) as (w & H1 & H2); exists q, w; auto.
Qed.
End compare_stacks.
Section half_tile.
Variable (x : pos n).
(* Code that pushes the reverse of a half tile on a stack *)
Fixpoint half_tile (l : list bool) :=
match l with
| nil => nil
| b::l => PUSH x b :: half_tile l
end.
Fact half_tile_length l : length (half_tile l) = length l.
Proof. induction l; simpl; f_equal; auto. Qed.
Fact half_tile_spec i l v : (i,half_tile l) // (i,v) ->> (length (half_tile l)+i,v[(rev l++v#>x)/x]).
Proof.
rewrite half_tile_length.
revert i v; induction l as [ | b l IHl ]; intros i v; simpl.
bsm sss stop; f_equal.
apply vec_pos_ext; intros z; dest z x.
bsm sss PUSH with x b.
specialize (IHl (1+i) (v[(b::v#>x)/x])).
apply subcode_sss_compute with (P := (1+i,half_tile l)).
subcode_tac; solve list eq.
eq goal IHl; do 2 f_equal.
omega.
apply vec_pos_ext; intros z; dest z x.
solve list eq.
Qed.
End half_tile.
Hint Rewrite empty_stack_length compare_stacks_length half_tile_length : length_db.
Section tile.
Variable (x y : pos n) (Hxy : x <> y) (high low : list bool).
(* Code that pushes a reversed tile on both stacks high and low *)
Definition tile := half_tile x (rev high) ++ half_tile y (rev low).
Fact tile_length : length tile = length high + length low.
Proof. unfold tile; rew length; auto. Qed.
Fact tile_spec i v st : st = (length tile+i,v[(high++v#>x)/x][(low++v#>y)/y])
-> (i,tile) // (i,v) ->> st.
Proof.
intro; subst.
unfold tile.
apply sss_compute_trans with (st2 := (length (half_tile x (rev high))+i,v[(high++v#>x)/x])).
rewrite <- (rev_involutive high) at 3.
apply subcode_sss_compute with (P := (i,half_tile x (rev high))).
subcode_tac.
apply half_tile_spec.
rewrite <- (rev_involutive low) at 3.
apply subcode_sss_compute with (P := (length (half_tile x (rev high))+i,half_tile y (rev low))).
subcode_tac; solve list eq.
replace (length (half_tile x (rev high) ++ half_tile y (rev low)) + i)
with (length (half_tile y (rev low)) + (length (half_tile x (rev high)) + i)).
replace (v#>y) with (v[(high ++ v#>x)/x]#>y) by rew vec.
apply half_tile_spec.
rew length; omega.
Qed.
End tile.
Hint Rewrite tile_length : length_db.
Section transfer_ones.
Variable (x y : pos n) (Hxy : x <> y) (i p q : nat).
(* Code that does the following:
* if x is 111110++l where 1 occurs k times then
- x becomes l
- y becomes bbbbb++y where b occurs k times
* if x is 11111 where 1 occurs k times then
- x becomes nil
- y becomes bbbbb++y where b occurs k times
*)
Definition transfer_ones b := POP x p q :: PUSH y b :: PUSH y Zero :: POP y i i :: nil.
Fact transfer_ones_length b : length (transfer_ones b) = 4.
Proof. auto. Qed.
Fact transfer_ones_spec_1 b k l v st : v#>x = list_repeat One k ++ Zero :: l
-> st = (p,v[l/x][(list_repeat b k ++ v#>y)/y])
-> (i,transfer_ones b) // (i,v) ->> st.
Proof.
intros H1 E; subst st.
revert v H1.
induction k as [ | k IHk ]; intros v; intros Hx;
simpl list_repeat; simpl app; unfold transfer_ones; simpl in Hx.
bsm sss POP 0 with x p q l.
bsm sss stop; f_equal.
apply vec_pos_ext; intros z; dest z y.
bsm sss POP 1 with x p q (list_repeat One k ++ Zero :: l).
bsm sss PUSH with y b.
bsm sss PUSH with y Zero.
bsm sss POP 0 with y i i (b::v#>y); rew vec.
specialize (IHk (v [(list_repeat One k ++ Zero :: l) / x] [(b :: v #> y) / y])).
spec in IHk.
rew vec.
eq goal IHk; do 2 f_equal.
apply vec_pos_ext; intros z; dest z y.
2: dest z x.
change (b :: list_repeat b k ++ v#>y)
with (list_repeat b (S k) ++ v#>y).
replace (S k) with (k+1) by omega.
rewrite list_repeat_plus; solve list eq.
Qed.
Fact transfer_ones_spec_2 b k v st : v#>x = list_repeat One k
-> st = (q,v[nil/x][(list_repeat b k ++ v#>y)/y])
-> (i,transfer_ones b) // (i,v) ->> st.
Proof.
intros H1 E; subst st.
revert v H1.
induction k as [ | k IHk ]; intros v; intros Hx;
simpl list_repeat; simpl app; unfold transfer_ones; simpl in Hx.
bsm sss POP empty with x p q.
bsm sss stop; f_equal.
apply vec_pos_ext; intros z; dest z y; dest z x.
bsm sss POP 1 with x p q (list_repeat One k).
bsm sss PUSH with y b.
bsm sss PUSH with y Zero.
bsm sss POP 0 with y i i (b::v#>y); rew vec.
specialize (IHk (v [(list_repeat One k) / x] [(b :: v #> y) / y])).
spec in IHk.
rew vec.
eq goal IHk; do 2 f_equal.
apply vec_pos_ext; intros z; dest z y.
2: dest z x.
change (b :: list_repeat b k ++ v#>y)
with (list_repeat b (S k) ++ v#>y).
replace (S k) with (k+1) by omega.
rewrite list_repeat_plus; solve list eq.
Qed.
End transfer_ones.
Hint Rewrite transfer_ones_length : length_db.
Section increment.
Variable (x y : pos n) (Hxy : x <> y).
(* Code that increments the stack x by one ie.
for l such that list_bool_succ x l, x becomes l
y is a spare register which is (globally) unmodified
*)
Definition increment i := PUSH y Zero :: transfer_ones x y (1+i) (5+i) (10+i) One ++
PUSH x One :: transfer_ones y x (6+i) (15+i) (15+i) Zero ++
PUSH x Zero :: transfer_ones y x (11+i) (15+i) (15+i) Zero ++
nil.
Fact increment_length i : length (increment i) = 15.
Proof. unfold increment; rew length; auto. Qed.
Fact increment_spec_1 i v k l : v#>x = list_repeat One k ++ Zero :: l
-> (i,increment i) // (i,v) ->> (15+i,v[(list_repeat Zero k ++ One :: l)/x]).
Proof.
intros Hx.
unfold increment.
bsm sss PUSH with y Zero.
apply subcode_sss_compute_trans with (P := (1+i,transfer_ones x y (1+i) (5+i) (10+i) One))
(st2 := (5+i,v[l/x][(list_repeat One k ++ Zero:: v#>y)/y])); auto.
apply transfer_ones_spec_1 with (k := k) (l := l); rew vec.
f_equal.
apply vec_pos_ext; intros z; dest z y; dest z x.
bsm sss PUSH with x One.
apply subcode_sss_compute_trans with (P := (6+i,transfer_ones y x (6+i) (15+i) (15+i) Zero))
(st2 := (15+i,v[(list_repeat Zero k++One::l)/x])); auto.
apply transfer_ones_spec_1 with (k := k) (l := v#>y); rew vec.
f_equal.
apply vec_pos_ext; intros z; dest z y; dest z x.
bsm sss stop.
Qed.
Fact increment_spec_2 i v k : v#>x = list_repeat One k
-> (i,increment i) // (i,v) ->> (15+i,v[(list_repeat Zero (S k))/x]).
Proof.
intros Hx.
unfold increment.
bsm sss PUSH with y Zero.
apply subcode_sss_compute_trans with (P := (1+i,transfer_ones x y (1+i) (5+i) (10+i) One))
(st2 := (10+i,v[nil/x][(list_repeat One k ++ Zero:: v#>y)/y])); auto.
apply transfer_ones_spec_2 with (k := k); rew vec.
f_equal.
apply vec_pos_ext; intros z; dest z y; dest z x.
bsm sss PUSH with x Zero.
apply subcode_sss_compute_trans with (P := (11+i,transfer_ones y x (11+i) (15+i) (15+i) Zero))
(st2 := (15+i,v[(list_repeat Zero (S k))/x])); auto.
apply transfer_ones_spec_1 with (k := k) (l := v#>y); rew vec.
f_equal.
apply vec_pos_ext; intros z; dest z y; dest z x.
replace (S k) with (k+1) by omega.
rewrite list_repeat_plus; auto.
bsm sss stop.
Qed.
Fact increment_spec i v l m :
list_bool_succ l m
-> v#>x = l
-> (i,increment i) // (i,v) ->> (15+i,v[m/x]).
Proof.
revert l m; intros ? ? [ k l | k ] H.
apply increment_spec_1; auto.
apply increment_spec_2; auto.
Qed.
End increment.
Hint Rewrite increment_length : length_db.
Section full_decoder.
Implicit Type (lt : list ((list bool) * list bool)).
Definition size_cards lt := fold_right (fun c x => length (fst c) + length (snd c) + x) 0 lt.
Variables (c h l : pos n) (Hch : c <> h) (Hcl : c <> l) (Hhl : h <> l).
Variables (p : nat) (* jumps here when decoding worked correctly *)
(q : nat) (* jumps here when decoding produced an error *)
.
Let decoder_error := PUSH c Zero :: POP c q q :: nil.
(* Code that implements a decoder for tile indices
- ll is a list of tiles (th,tl)
- when c starts with a valid tile index in ll
encoded as 00001 (with n 0s to represent b)
then the corresponding tile is stacked into
h and l. The code ends up at s
- otherwise, h and l are left unchanged and the
code ends up at q
*)
Fixpoint decoder s i lt :=
match lt with
| nil => decoder_error
| (th,tl) :: lt => POP c (3+length (tile h l th tl)+i) q ::
tile h l th tl ++
PUSH c Zero ::
POP c s s ::
decoder s (3+length (tile h l th tl)+i) lt
end.
Fixpoint length_decoder lt :=
match lt with
| nil => 2
| (th,tl) :: lt => 3+length th+length tl+length_decoder lt
end.
Fact decoder_length s i lt : length (decoder s i lt) = length_decoder lt.
Proof.
revert s i; induction lt as [ | (th,tl) lt IHlt ]; intros s i; rew length; auto.
simpl; rew length; rewrite IHlt; omega.
Qed.
Fact length_decoder_size lt : length_decoder lt = 2+3*length lt+size_cards lt.
Proof. induction lt as [ | [] ]; simpl; auto; omega. Qed.
Local Fact decoder_spec_rec s i mm ll th tl lr lc v w :
v#>c = list_repeat Zero (length ll) ++ One :: lc
-> mm = ll++(th,tl)::lr
-> w = (s,v[lc/c][(th++v#>h)/h][(tl++v#>l)/l])
-> (i,decoder s i mm) // (i,v) ->> w.
Proof.
revert i mm th tl lr lc v w.
induction ll as [ | (t1,t2) ll IHll ]; simpl; intros i mm th tl lr lc v w H1 H2 H3; subst w.
(* The list ll is empty *)
subst mm; simpl decoder.
bsm sss POP 1 with c (S (S (S (length (tile h l th tl) + i)))) q lc.
apply subcode_sss_compute_trans with (P := (1+i,tile h l th tl))
(st2 := (1+length (tile h l th tl)+i,v[lc/c][(th++v#>h)/h][(tl++v#>l)/l])); auto.
apply tile_spec; auto.
f_equal.
rew length; omega.
apply vec_pos_ext; intros z; dest z l.
bsm sss PUSH with c Zero.
bsm sss POP 0 with c s s lc; rew vec.
bsm sss stop; f_equal.
apply vec_pos_ext; intros z; dest z c.
(* The list ll is not empty *)
subst mm; simpl.
bsm sss POP 0 with c (S (S (S (length (tile h l t1 t2) + i)))) q (list_repeat Zero (length ll) ++ One :: lc).
apply subcode_sss_compute with (P := (3+length (tile h l t1 t2)+i,
decoder s (S (S (S (length (tile h l t1 t2)+i)))) (ll++(th,tl)::lr))); auto.
subcode_tac; solve list eq.
apply IHll with th tl lr lc; auto.
rew vec.
f_equal.
apply vec_pos_ext; intros z; dest z c.
Qed.
Fact decoder_spec_ok s i ll th tl lr lc v st :
v#>c = list_repeat Zero (length ll) ++ One :: lc
-> st = (s,v[lc/c][(th++v#>h)/h][(tl++v#>l)/l])
-> (i,decoder s i (ll++(th,tl)::lr)) // (i,v) ->> st.
Proof.
intros; subst; apply decoder_spec_rec with ll th tl lr lc; auto.
Qed.
(* There is no trailing 1 *)
Fact decoder_spec_nok_1 s i ll v k :
v#>c = list_repeat Zero k
-> exists r, (i,decoder s i ll) // (i,v) ->> (q,v[(list_repeat Zero r)/c]).
Proof.
revert i v k.
induction ll as [ | (t1,t2) ll IHll ]; intros i v k H1.
simpl; unfold decoder_error.
exists k.
bsm sss PUSH with c Zero.
bsm sss POP 0 with c q q (v#>c); rew vec.
bsm sss stop.
f_equal.
apply vec_pos_ext; intros z; dest z c.
unfold decoder; fold decoder.
destruct k as [ | k ].
exists 0.
bsm sss POP empty with c (3 + length (tile h l t1 t2) + i) q.
bsm sss stop.
f_equal; apply vec_pos_ext; intros z; dest z c.
simpl in H1.
destruct (IHll (3 + length (tile h l t1 t2) + i) (v[(list_repeat Zero k)/c]) k)
as (r & Hr); rew vec.
exists r.
bsm sss POP 0 with c (3 + length (tile h l t1 t2) + i) q (list_repeat Zero k).
revert Hr; rew vec; apply subcode_sss_compute; auto.
subcode_tac; solve list eq.
Qed.
(* There might be a trailing 1 but the list of 0s is too long *)
Fact decoder_spec_nok_2 s i ll lc v k :
v#>c = list_repeat Zero k ++ lc
-> length ll <= k
-> exists r, (i,decoder s i ll) // (i,v) ->> (q,v[(list_repeat Zero r ++ lc)/c]).
Proof.
revert i lc v k.
induction ll as [ | (t1,t2) ll IHll ]; intros i lc v k H1 H2.
simpl; unfold decoder_error.
exists k.
bsm sss PUSH with c Zero.
bsm sss POP 0 with c q q (v#>c); rew vec.
bsm sss stop.
f_equal.
apply vec_pos_ext; intros z; dest z c.
unfold decoder; fold decoder.
destruct k as [ | k ].
simpl in H2; omega.
simpl in H1, H2.
destruct (IHll (3 + length (tile h l t1 t2) + i) lc (v[(list_repeat Zero k++lc)/c]) k)
as (r & Hr); rew vec.
omega.
exists r.
bsm sss POP 0 with c (3 + length (tile h l t1 t2) + i) q (list_repeat Zero k++lc).
revert Hr; rew vec; apply subcode_sss_compute; auto.
subcode_tac; solve list eq.
Qed.
(* A full decoder of a list of boolean into a list a valid tile indices,
stacking the tiles in h/l in the list on the run.
The following list of indices 5,3,0,2 is encoded as 000001 0001 1 001
A valid list of booleans is an encoding of n1,...,n_p where each
n_i is stricly less than length mm
If the encoding on the list of indices is incorrect in any way:
- either not a list of indices
- or some index is to big
then the full decoder ends up at q.
The empty list is not a valid list of tile indices
*)
Definition full_decoder i ll :=
POP c (4+i) p ::
PUSH c One ::
PUSH h Zero ::
POP h (5+i) q ::
PUSH c Zero ::
decoder i (5+i) ll.
Definition length_full_decoder ll := 5 + length_decoder ll.
Fact full_decoder_length i ll : length (full_decoder i ll) = length_full_decoder ll.
Proof. unfold full_decoder, length_full_decoder; rew length; rewrite decoder_length; auto. Qed.
Local Fact full_dec_start_spec_0 i lt v :
v#>c = nil
-> (i,full_decoder i lt) // (i,v) ->> (p,v).
Proof.
intros H1.
unfold full_decoder; simpl in H1.
bsm sss POP empty with c (4+i) p.
bsm sss stop; f_equal.
Qed.
Local Fact full_dec_start_spec_1 i lt v :
v#>c <> nil
-> (i,full_decoder i lt) // (i,v) ->> (5+i,v).
Proof.
intros H1.
case_eq (v#>c).
intros; destruct H1; auto.
clear H1.
unfold full_decoder.
intros [] lc Hlc.
bsm sss POP 1 with c (4+i) p lc.
bsm sss PUSH with c One.
bsm sss PUSH with h Zero.
bsm sss POP 0 with h (5+i) q (v#>h); rew vec.
bsm sss stop; f_equal.
apply vec_pos_ext; intros z; dest z h; dest z c.
bsm sss POP 0 with c (4+i) p lc.
bsm sss PUSH with c Zero.
bsm sss stop; f_equal.
apply vec_pos_ext; intros z; dest z c.
Qed.
Local Fact full_dec_spec_rec i ln lc lt v :
v#>c = list_nat_bool ln ++ lc
-> Forall (fun x => x < length lt) ln
-> let (hh,ll) := tile_concat ln lt
in (i,full_decoder i lt) // (i,v) ->> (i,v[lc/c][(hh++v#>h)/h][(ll++v#>l)/l]).
Proof.
intros H1 H2; revert H2 v H1.
induction 1 as [ | k ln Hk Hln IHln ]; intros v H1; simpl.
bsm sss stop; f_equal.
apply vec_pos_ext; intros z; dest z l; dest z h; dest z c.
destruct (nth_split _ (nil,nil) Hk) as (ll & lr & H2 & H3).
revert H2; generalize (nth k lt (nil,nil)); intros (th, tl) H2.
simpl in H1.
specialize (IHln (v[(list_nat_bool ln ++ lc)/c][(th++v#>h)/h][(tl++v#>l)/l])).
spec in IHln; rew vec.
destruct (tile_concat ln lt) as (thh,tll).
apply sss_compute_trans with (st2 := (5+i,v)).
apply full_dec_start_spec_1.
rewrite H1; destruct k; discriminate.
unfold full_decoder.
apply subcode_sss_compute_trans with (P := (5+i,decoder i (5 + i) lt))
(st2 := (i,v[(list_nat_bool ln++lc)/c][(th++v#>h)/h][(tl++v#>l)/l])); auto.
subcode_tac; solve list eq.
subst lt; apply decoder_spec_ok with (list_nat_bool ln++lc); auto.
rewrite H3; revert H1; solve list eq.
eq goal IHln; do 2 f_equal.
apply vec_pos_ext; intros z.
dest z l; solve list eq.
dest z h; solve list eq.
dest z c.
Qed.
(* Correctness lemma for the full decoder when
then input actually encodes a valid list of tiles *)
Theorem full_decoder_ok_spec i ln lt v :
v#>c = list_nat_bool ln
-> v#>h = nil
-> v#>l = nil
-> Forall (fun x => x < length lt) ln
-> let (hh,ll) := tile_concat ln lt
in (i,full_decoder i lt) // (i,v) ->> (p,v[nil/c][hh/h][ll/l]).
Proof.
intros H1 H2 H3 H4.
rewrite app_nil_end in H1.
generalize (@full_dec_spec_rec i ln nil lt v H1 H4).
destruct (tile_concat ln lt) as (hh,ll).
intros E.
apply sss_compute_trans with (1 := E); auto.
rewrite H2, H3; repeat rewrite <- app_nil_end.
apply full_dec_start_spec_0; rew vec.
Qed.
Local Fact full_dec_spec_rec1 i ln lc lt v :
v#>c = list_nat_bool ln ++ lc
-> Exists (fun x => length lt <= x) ln
-> exists w, (i,full_decoder i lt) // (i,v) ->> (q,w)
/\ forall z, z <> c -> z <> h -> z <> l -> v#>z = w#>z.
Proof.
intros H1 H2; revert H2 v H1.
induction ln as [ | x ln IHln ]; intros Hln v H1.
inversion Hln.
generalize (full_dec_start_spec_1 i lt v).
intros H2; spec in H2.
rewrite H1; simpl; destruct x; discriminate.
simpl in H1.
destruct (le_lt_dec (length lt) x) as [ Hx | Hx ].
unfold full_decoder.
solve list eq in H1.
destruct (decoder_spec_nok_2 i (5+i) lt _ _ H1 Hx) as (r & Hr).
exists (v [(list_repeat Zero r++One::list_nat_bool ln++lc)/c]); split.
apply sss_compute_trans with (1 := H2); auto.
unfold full_decoder; revert Hr; apply subcode_sss_compute; auto.
subcode_tac; solve list eq.
intros; rew vec.
apply Exists_cons in Hln.
destruct Hln as [ Hln | Hln ].
omega.
specialize (IHln Hln).
destruct (nth_split _ (nil,nil) Hx) as (ll & lr & H3 & H4).
revert H3; generalize (nth x lt (nil,nil)); intros (th, tl) H3.
specialize (IHln (v[(list_nat_bool ln++lc)/c][(th++v#>h)/h][(tl++v#>l)/l])).
spec in IHln; rew vec.
destruct IHln as (w & Hw & Hw1).
exists w; split.
apply sss_compute_trans with (2 := Hw).
apply sss_compute_trans with (1 := H2); auto.
rewrite <- H4 in H1.
solve list eq in H1.
generalize (@decoder_spec_ok i (5+i) ll th tl lr _ _ _ H1 eq_refl).
unfold full_decoder; apply subcode_sss_compute.
subst; subcode_tac; solve list eq.
intros z G1 G2 G3; generalize (Hw1 _ G1 G2 G3); rew vec.
Qed.
Local Fact full_dec_spec_rec2 i k lt v :
v#>c = list_repeat Zero (S k)
-> exists w, (i,full_decoder i lt) // (i,v) ->> (q,w)
/\ forall z, z <> c -> z <> h -> z <> l -> v#>z = w#>z.
Proof.
intros H.
destruct (@decoder_spec_nok_1 i (5+i) lt _ _ H) as (r & Hr).
exists (v[(list_repeat Zero r)/c]); split.
2: intros; rew vec.
generalize (@full_dec_start_spec_1 i lt v); intros H1.
spec in H1.
rewrite H; discriminate.
apply sss_compute_trans with (1 := H1); auto.
revert Hr.
unfold full_decoder.
apply subcode_sss_compute; auto.
subcode_tac; solve list eq.
Qed.
(* Correctness lemma for the full decoder when
then input encodes an invalid list of tiles *)
Theorem full_decoder_ko_spec i ln lc lt v :
v#>c = list_nat_bool ln ++ lc
-> (Exists (fun x => length lt <= x) ln
\/ Forall (fun x => x < length lt) ln
/\ exists k, lc = list_repeat Zero (S k))
-> exists w, (i,full_decoder i lt) // (i,v) ->> (q,w)
/\ forall z, z <> c -> z <> h -> z <> l -> v#>z = w#>z.
Proof.
intros H1 [ H2 | (H2 & k & H3) ].
apply full_dec_spec_rec1 with ln lc; auto.
generalize (@full_dec_spec_rec i ln lc lt v H1 H2).
destruct (tile_concat ln lt) as (hh,ll); intros H4.
destruct (@full_dec_spec_rec2 i k lt
(v[lc/c][(hh++v#>h)/h][(ll++v#>l)/l])) as (w & Hw1 & Hw2); rew vec.
exists w; split.
apply sss_compute_trans with (1 := H4); auto.
intros x E1 E2 E3; rewrite <- Hw2; auto; rew vec.
Qed.
End full_decoder.
Hint Rewrite full_decoder_length : length_db.
Section simulator.
Variables (s a h l : pos n) (Hsa : s <> a) (Hsh : s <> h) (Hsl : s <> l)
(Hah : a <> h) (Hal : a <> l) (Hhl : h <> l)
(lt : list ((list bool)*list bool)).
Section increment_erase.
Variable (i p : nat).
(* This code does the following
- increments s (as a list of booleans)
- empties h, l and a
- jumps to p
*)
Definition increment_erase :=
(* i *) increment s a i ++
(* 15+i *) empty_stack h (15+i) ++
(* 18+i *) empty_stack l (18+i) ++
(* 21+i *) empty_stack a (21+i) ++
(* 24+i *) PUSH l Zero :: POP l p p :: nil.
Fact increment_erase_length : length increment_erase = 26.
Proof. auto. Qed.
Fact increment_erase_spec v ln mn w :
list_bool_succ ln mn
-> v#>s = ln
-> w = v[mn/s][nil/h][nil/l][nil/a]
-> (i,increment_erase) // (i,v) ->> (p,w).
Proof.
intros H1 H2 ?; subst w.
unfold increment_erase.
apply sss_compute_trans with (st2 := (15+i,v[mn/s])).
apply subcode_sss_compute with (P := (i,increment s a i )); auto.
apply increment_spec with ln; auto.
apply sss_compute_trans with (st2 := (18+i,v[mn/s][nil/h])).
apply subcode_sss_compute with (P := (15+i,empty_stack h (15+i))); auto.
apply empty_stack_spec.
apply sss_compute_trans with (st2 := (21+i,v[mn/s][nil/h][nil/l])).
apply subcode_sss_compute with (P := (18+i,empty_stack l (18+i))); auto.
apply empty_stack_spec.
apply sss_compute_trans with (st2 := (24+i,v[mn/s][nil/h][nil/l][nil/a])).
apply subcode_sss_compute with (P := (21+i,empty_stack a (21+i))); auto.
apply empty_stack_spec.
bsm sss PUSH with l Zero.
bsm sss POP 0 with l p p nil; rew vec.
bsm sss stop.
f_equal.
apply vec_pos_ext; intros x; dest x l.
Qed.
End increment_erase.
Hint Rewrite increment_erase_length : length_db.
Section main_init.
Variable (i : nat).
(* Self explaining code:
- s becomes Zero::nil
- a, h and l are emptied
*)
Definition main_init :=
(* i *) empty_stack s i ++
(* 3+i *) empty_stack a (3+i) ++
(* 6+i *) empty_stack h (6+i) ++
(* 9+i *) empty_stack l (9+i) ++
(* 12+i *) PUSH s Zero :: nil.
Fact main_init_length : length main_init = 13.
Proof. auto. Qed.
Fact main_init_spec v : (i,main_init) // (i,v) ->> (13+i,v[(Zero::nil)/s][nil/a][nil/h][nil/l]).
Proof.
unfold main_init.
apply subcode_sss_compute_trans with (2 := empty_stack_spec s _ _); auto.
apply subcode_sss_compute_trans with (2 := empty_stack_spec a _ _); auto.
apply subcode_sss_compute_trans with (2 := empty_stack_spec h (6+i) _); auto.
apply subcode_sss_compute_trans with (2 := empty_stack_spec l (9+i) _); auto.
bsm sss PUSH with s Zero.
bsm sss stop.
f_equal.
apply vec_pos_ext; intros x.
dest x a; dest x l; dest x h; dest x s.
Qed.
End main_init.
Section main_loop.
Variables (i p : nat).
Let lFD := length_full_decoder lt.
(* This code does the following:
- copies s to a (temporarily using the empty h stack)
- decodes a as a list of tiles into h/l
* if the list is correct and h = l at the ends, we
have a solution to PCP and we jump to p
* if the list is incorrect, increments s,
clean up of h, l and a and start over (loop)
*)
Definition main_loop :=
(* i *) copy_stack s a h i ++
(* 16+i *) full_decoder a h l (lFD+16+i) (lFD+26+i) (16+i) lt ++
(* lFD+16+i *) compare_stacks h l (lFD+16+i) p (lFD+26+i) ++
(* lFD+26+i *) increment_erase (lFD+26+i) i.
Definition length_main_loop := 52 + lFD.
Fact main_loop_length : length main_loop = length_main_loop.
Proof. unfold main_loop, length_main_loop, lFD; rew length; omega. Qed.
Fact main_loop_size : length_main_loop = 59+3*length lt+size_cards lt.
Proof.
unfold length_main_loop, lFD, length_full_decoder.
rewrite length_decoder_size; omega.
Qed.
Fact main_loop_ok_spec v ln :
v#>h = nil
-> v#>l = nil
-> v#>a = nil
-> v#>s = list_nat_bool ln
-> Forall (fun x => x < length lt) ln
-> (let (hh,ll) := tile_concat ln lt in hh = ll)
-> exists w, (i,main_loop) // (i,v) ->> (p,w)
/\ forall x, x <> a -> x <> h -> x <> l -> v#>x = w#> x.
Proof.
intros H0 H1 H2 H3 H4 H5.
case_eq (tile_concat ln lt).
intros hh ll E; rewrite E in H5.
destruct (compare_stack_eq_spec Hhl (lFD+16+i) p (lFD+26+i) (v[nil/a][hh/h][ll/l]))
as (w & Hw1 & Hw2); rew vec.
exists w; split.
unfold main_loop.
apply sss_compute_trans with (st2 := (16+i,v[(list_nat_bool ln)/a])).
apply subcode_sss_compute with (P := (i,copy_stack s a h i)); auto.
apply copy_stack_spec with (list_nat_bool ln); auto.
rewrite H2, <- app_nil_end; auto.
apply sss_compute_trans with (st2 := (lFD+16+i,v[nil/a][hh/h][ll/l])).
apply subcode_sss_compute with (P := (16+i,full_decoder a h l (lFD+16+i) (lFD+26+i) (16+i) lt)); auto.
generalize (@full_decoder_ok_spec _ _ _ Hah Hal Hhl (lFD+16+i) (lFD+26+i) (16+i) ln lt
(v[(list_nat_bool ln)/a])); intros H6.
do 3 (spec in H6; [ rew vec | ]).
spec in H6; auto.
rewrite E in H6.
eq goal H6; do 2 f_equal; rew vec.
apply subcode_sss_compute with (P := (lFD+16+i,compare_stacks h l (lFD+16+i) p (lFD+26+i))); auto.
intros x E1 E2 E3; generalize (Hw2 _ E2 E3); rew vec.
Qed.
Fact main_loop_ko_spec v ln lc :
v#>h = nil
-> v#>l = nil
-> v#>a = nil
-> v#>s = list_nat_bool ln ++ lc
-> ( ( Exists (fun x => length lt <= x) ln
\/ Forall (fun x => x < length lt) ln /\ exists k, lc = list_repeat Zero (S k) )
\/ Forall (fun x => x < length lt) ln /\ lc = nil
/\ let (hh,ll) := tile_concat ln lt in hh <> ll)
-> (i,main_loop) // (i,v) ->> (i,v[(list_bool_next (v#>s))/s]).
Proof.
intros H0 H1 H2 H3 [ H4 | (H4 & ? & H5) ].
destruct (@full_decoder_ko_spec _ _ _ Hah Hal Hhl (lFD+16+i) (lFD+26+i) (16+i))
with (v := v[(list_nat_bool ln ++ lc)/a]) (2 := H4) as (w & Hw1 & Hw2); rew vec.
unfold main_loop.
apply sss_compute_trans with (st2 := (16+i,v[(list_nat_bool ln++lc)/a])).
apply subcode_sss_compute with (P := (i,copy_stack s a h i)); auto.
apply copy_stack_spec with (list_nat_bool ln++lc); auto.
rewrite H2, <- app_nil_end; auto.
apply subcode_sss_compute_trans with (2 := Hw1); auto.
apply subcode_sss_compute with (P := (lFD+26+i,increment_erase (lFD + 26 + i) i)); auto.
apply increment_erase_spec with (1 := list_bool_next_spec (v#>s)); auto.
rewrite <- Hw2; auto; rew vec.
apply vec_pos_ext; intros x.
dest x a; dest x l; dest x h; dest x s.
rewrite <- Hw2; auto; rew vec.
unfold main_loop.
subst lc.
rewrite <- app_nil_end in H3.
case_eq (tile_concat ln lt).
intros hh ll E; rewrite E in H5.
destruct (compare_stack_neq_spec Hhl (lFD+16+i) p (lFD+26+i) (v[nil/a][hh/h][ll/l]))
as (w & Hw1 & Hw2); rew vec.
apply sss_compute_trans with (st2 := (16+i,v[(list_nat_bool ln)/a])).
apply subcode_sss_compute with (P := (i,copy_stack s a h i)); auto.
apply copy_stack_spec with (list_nat_bool ln); auto.
rewrite H2, <- app_nil_end; auto.
apply sss_compute_trans with (st2 := (lFD+16+i,v[nil/a][hh/h][ll/l])).
apply subcode_sss_compute with (P := (16+i,full_decoder a h l (lFD+16+i) (lFD+26+i) (16+i) lt)); auto.
generalize (@full_decoder_ok_spec _ _ _ Hah Hal Hhl (lFD+16+i) (lFD+26+i) (16+i) ln lt
(v[(list_nat_bool ln)/a])); intros H6.
do 3 (spec in H6; [ rew vec | ]).
spec in H6; auto.
rewrite E in H6.
eq goal H6; do 2 f_equal; rew vec.
apply sss_compute_trans with (st2 := (lFD+26+i,w)).
apply subcode_sss_compute with (P := (lFD+16+i,compare_stacks h l (lFD+16+i) p (lFD+26+i))); auto.
apply subcode_sss_compute with (P := (lFD+26+i,increment_erase (lFD + 26 + i) i)); auto.
apply increment_erase_spec with (1 := list_bool_next_spec (v#>s)); auto.
rewrite <- Hw2; auto; rew vec.
apply vec_pos_ext; intros x.
dest x a; dest x l; dest x h; dest x s.
rewrite <- Hw2; auto; rew vec.
Qed.
Implicit Type (v : vec (list bool) n).
Let pre v := v#>h = nil /\ v#>l = nil /\ v#>a = nil.
Let spec v w := forall x, x <> a -> x <> h -> x <> l -> v#>x = w#> x.
Let f v := v[(list_bool_next (v#>s))/s].
Let Hf v : v <> f v.
Proof.
intros E.
apply (list_bool_succ_neq) with (1 := list_bool_next_spec (v#>s)).
rewrite E at 1.
unfold f; rew vec.
Qed.
Let C2 v := exists ln,
v#>s = list_nat_bool ln
/\ Forall (fun x => x < length lt) ln
/\ (let (hh,ll) := tile_concat ln lt in hh = ll).
Let C1 v := exists ln lc,
v#>s = list_nat_bool ln ++ lc
/\ ( ( Exists (fun x => length lt <= x) ln
\/ Forall (fun x => x < length lt) ln /\ exists k, lc = list_repeat Zero (S k) )
\/ Forall (fun x => x < length lt) ln /\ lc = nil
/\ let (hh,ll) := tile_concat ln lt in hh <> ll).
Let HC v : pre v -> { C1 v } + { C2 v }.
Proof.
unfold C1, C2.
intros _.
generalize (v#>s); clear v; intros m.
destruct (list_bool_valid_dec (length lt) m)
as [ (ln & H1) | (ln & H1) ].
case_eq (tile_concat ln lt); intros hh ll H2.
destruct (list_bool_dec hh ll) as [ H3 | H3 ].
* right.
exists ln.
destruct H1 as (H1 & H4).
rewrite H2; auto.
* left.
destruct H1 as (H1 & H4).
exists ln, nil.
rewrite <- app_nil_end.
split; auto.
right.
rewrite H2; auto.
* left.
destruct H1 as (lc & H1 & H2).
exists ln, lc; split; auto.
Qed.
Hypothesis (Hp : out_code p (i,main_loop)).
Let HP1 : forall x, pre x -> C1 x -> (i,main_loop) // (i,x) ->> (i,f x) /\ pre (f x).
Proof.
intros v (H1 & H2 & H3) (ln & lc & H4 & H5).
split.
apply main_loop_ko_spec with ln lc; auto.
red; unfold f; rew vec; auto.
Qed.
Let HP2 : forall x, pre x -> C2 x -> exists y, (i,main_loop) // (i,x) ->> (p,y) /\ spec x y.
Proof.
intros v (H1 & H2 & H3) (ln & H4 & H5 & H6).
apply main_loop_ok_spec with ln; auto.
Qed.
Let main_loop_sound_rec v :
pre v
-> (exists n, C2 (iter f v n))
-> exists n w, (i,main_loop) // (i,v) ->> (p,w) /\ spec (iter f v n) w.
Proof.
apply sss_loop_sound with (C1 := C1); auto.
Qed.
Let main_loop_complete_rec v w q : pre v
-> out_code q (i,main_loop)
-> (i,main_loop) // (i,v) ->> (q,w)
-> p = q /\ exists n, C2 (iter f v n) /\ spec (iter f v n) w.
Proof.
apply sss_loop_complete with (C1 := C1); auto.
apply bsm_sss_fun.
Qed.
Let iter_f_v v k : iter f v k = v[(iter list_bool_next (v#>s) k)/s].
Proof.
revert v.
unfold f; induction k as [ | k IHk ]; intros v; simpl; [ | rewrite IHk ]; rew vec.
Qed.
Let C2_eq v : v#>s = Zero::nil -> (exists n, C2 (iter f v n)) <-> tiles_solvable lt.
Proof.
unfold tiles_solvable.
intros H1; simpl.
split.
intros (k & Hk).
rewrite iter_f_v, H1 in Hk.
destruct Hk as (ln & H2 & H3 & H4).
revert H2; rew vec; intros H2.
exists ln; repeat split; auto.
intros E.
subst ln.
simpl in H2.
apply iter_list_bool_next_nil in H2.
destruct H2; discriminate.
intros (ln & H2 & H3 & H4).
destruct (@list_bool_next_total (list_nat_bool ln)) as (k & Hk).
destruct ln as [ | [ | u ] ln ]; simpl; auto; discriminate.
exists k.
rewrite iter_f_v, H1, <- Hk.
exists ln; rew vec; auto.
Qed.
Theorem main_loop_sound v :
v#>s = Zero::nil -> v#>h = nil -> v#>l = nil -> v#>a = nil
-> tiles_solvable lt
-> exists w, (i,main_loop) // (i,v) ->> (p,w)
/\ forall x, x <> s -> x <> a -> x <> h -> x <> l -> v#>x = w#>x.
Proof.
intros H1 H2 H3 H4.
rewrite <- (C2_eq _ H1); auto.
intros H5.
destruct main_loop_sound_rec with (2 := H5)
as (k & w & Hw1 & Hw2).
red; auto.
exists w; split; auto.
unfold spec in Hw2 |- *.
intros; rewrite <- Hw2; auto.
rewrite iter_f_v; rew vec.
Qed.
Theorem main_loop_complete v w q :
v#>s = Zero::nil -> v#>h = nil -> v#>l = nil -> v#>a = nil
-> out_code q (i,main_loop)
-> (i,main_loop) // (i,v) ->> (q,w)
-> p = q
/\ (forall x, x <> s -> x <> a -> x <> h -> x <> l -> v#>x = w#>x)
/\ tiles_solvable lt.
Proof.
intros H1 H2 H3 H4 H5 H6.
rewrite <- (C2_eq _ H1); auto.
destruct main_loop_complete_rec with (2 := H5) (3 := H6)
as (G1 & k & G2 & G3).
red; auto.
split; auto.
split; [ | exists k ]; auto.
red in G3.
intros; rewrite <- G3; auto.
rewrite iter_f_v; rew vec.
Qed.
End main_loop.
End simulator.
End Binary_Stack_Machines.
(* Copyright Dominique Larchey-Wendling * *)
(* *)
(* * Affiliation LORIA -- CNRS *)
(**************************************************************)
(* This file is distributed under the terms of the *)
(* CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT *)
(**************************************************************)
Require Import List Arith Omega Bool.
Require Import utils pos vec.
Require Import subcode sss.
Require Import list_bool tiles_solvable bsm_defs.
Set Implicit Arguments.
Tactic Notation "rew" "length" := autorewrite with length_db.
Local Notation "e #> x" := (vec_pos e x).
Local Notation "e [ v / x ]" := (vec_change e x v).
Local Notation "P // s -[ k ]-> t" := (sss_steps (@bsm_sss _) P k s t).
Local Notation "P // s ->> t" := (sss_compute (@bsm_sss _) P s t).
Section Binary_Stack_Machines.
Variable (n : nat).
Ltac dest x y := destruct (pos_eq_dec x y) as [ | ]; [ subst x | ]; rew vec.
Section empty_stack.
Variable (x : pos n) (i : nat).
(* Code for emptying stack x *)
Definition empty_stack := POP x i (3+i) :: PUSH x Zero :: POP x i i :: nil.
Fact empty_stack_length : length empty_stack = 3.
Proof. auto. Qed.
Fact empty_stack_spec v : (i,empty_stack) // (i,v) ->> (3+i,v[nil/x]).
Proof.
set (l := v#>x).
generalize (eq_refl l).
unfold l at 2.
generalize l v; clear l v.
unfold empty_stack.
induction l as [ | [] l IHl ]; intros v Hv.
bsm sss POP empty with x i (3+i).
bsm sss stop; f_equal.
apply vec_pos_ext; intros p; dest x p.
bsm sss POP 1 with x i (3+i) l.
bsm sss PUSH with x Zero.
bsm sss POP 0 with x i i l; rew vec.
clear Hv.
specialize (IHl (v[l/x])).
spec in IHl.
rew vec.
revert IHl; rew vec.
bsm sss POP 0 with x i (3+i) l.
clear Hv.
specialize (IHl (v[l/x])).
spec in IHl.
rew vec.
revert IHl; rew vec.
Qed.
End empty_stack.
Section move_rev.
Variable (x y : pos n) (Hxy : x <> y) (i : nat).
Let y' := y.
(* Code that transfers stack x to y, reversing x in the interval *)
Definition move_rev_stack :=
(* i *) POP x (4+i) (7+i) ::
(* 1+i *) PUSH y One :: PUSH y' Zero :: POP y' i i ::
(* 4+i *) PUSH y Zero :: PUSH x Zero :: POP x i i ::
(* 7+i *) nil.
Fact length_move_rev_stack : length move_rev_stack = 7.
Proof. auto. Qed.
Fact move_rev_stack_spec l v w :
v#>x = l
-> w = v[nil/x][(rev l++v#>y)/y]
-> (i,move_rev_stack) // (i,v) ->> (7+i,w).
Proof.
revert v w; induction l as [ | [] l IHl ]; intros v w Hv Hw; subst w; unfold move_rev_stack.
* bsm sss POP empty with x (4+i) (7+i).
bsm sss stop.
f_equal.
apply vec_pos_ext; intros z; dest z y; dest z x.
* bsm sss POP 1 with x (4+i) (7+i) l.
bsm sss PUSH with y One.
bsm sss PUSH with y' Zero.
bsm sss POP 0 with y' i i (One::v#>y); unfold y'; rew vec.
apply IHl; rew vec.
apply vec_pos_ext; intros z.
dest z y; simpl; solve list eq.
dest z x.
* bsm sss POP 0 with x (4+i) (7+i) l.
bsm sss PUSH with y Zero.
bsm sss PUSH with x Zero.
bsm sss POP 0 with x i i l; rew vec.
apply IHl; rew vec.
apply vec_pos_ext; intros z.
dest z y; simpl; solve list eq.
dest z x.
Qed.
End move_rev.
Section copy_rev_stack.
Variable (x y z : pos n) (Hxy : x <> y) (Hxz : x <> z) (Hyz : y <> z) (i : nat).
Let y' := y.
(* Code that transfers x to both y and z, reversing x in the interval *)
Definition copy_rev_stack :=
(* i *) POP x (5+i) (9+i) ::
(* 1+i *) PUSH y One :: PUSH z One :: PUSH y' Zero :: POP y' i i ::
(* 5+i *) PUSH y Zero :: PUSH z Zero :: PUSH x Zero :: POP x i i ::
(* 9+i *) nil.
Fact length_copy_rev_stack : length copy_rev_stack = 9.
Proof. auto. Qed.
Fact copy_rev_stack_spec l v w :
v#>x = l
-> w = v[nil/x][(rev l++v#>y)/y][(rev l++v#>z)/z]
-> (i,copy_rev_stack) // (i,v) ->> (9+i,w).
Proof.
revert v w; induction l as [ | [] l IHl ]; intros v w Hv Hw; subst w; unfold copy_rev_stack.
* bsm sss POP empty with x (5+i) (9+i).
bsm sss stop.
f_equal.
apply vec_pos_ext; intros k; dest k z; dest k y; dest k x.
* bsm sss POP 1 with x (5+i) (9+i) l.
bsm sss PUSH with y One.
bsm sss PUSH with z One.
bsm sss PUSH with y' Zero.
bsm sss POP 0 with y' i i (One::v#>y); unfold y'; rew vec.
apply IHl; rew vec.
apply vec_pos_ext; intros k.
dest k z; simpl; solve list eq.
dest k y; dest k x.
* bsm sss POP 0 with x (5+i) (9+i) l.
bsm sss PUSH with y Zero.
bsm sss PUSH with z Zero.
bsm sss PUSH with x Zero.
bsm sss POP 0 with x i i l; rew vec.
apply IHl; rew vec.
apply vec_pos_ext; intros k.
dest k z; simpl; solve list eq.
dest k y; dest k x.
Qed.
End copy_rev_stack.
Hint Rewrite empty_stack_length length_move_rev_stack length_copy_rev_stack : length_db.
Section copy_stack.
Variable (x y z : pos n) (Hxy : x <> y) (Hxz : x <> z) (Hyz : y <> z) (i : nat).
(* Code that copies x into y, stack z must be an empty spare stack *)
Definition copy_stack := move_rev_stack x z i ++ copy_rev_stack z x y (7+i).
Fact copy_stack_length : length copy_stack = 16.
Proof. auto. Qed.
Fact copy_stack_spec l v w :
v#>x = l
-> v#>z = nil
-> w = v[(l++v#>y)/y]
-> (i,copy_stack) // (i,v) ->> (16+i,w).
Proof.
intros H1 H2 H3; subst w.
unfold copy_stack.
apply sss_compute_trans with (st2 := (7+i,v[nil/x][(rev l)/z])).
* apply subcode_sss_compute with (P := (i,move_rev_stack x z i)); auto.
apply move_rev_stack_spec with l; auto.
rew vec; rewrite H2; solve list eq.
* apply subcode_sss_compute with (P := (7+i,copy_rev_stack z x y (7+i))); auto.
apply copy_rev_stack_spec with (rev l); rew vec.
apply vec_pos_ext; intros k.
dest k z; simpl; solve list eq.
dest k y; [ | dest k x ];
rewrite rev_involutive; auto.
Qed.
End copy_stack.
Hint Rewrite copy_stack_length : length_db.
Section compare_stacks.
Variables (x y : pos n) (Hxy : x <> y) (i p q : nat).
Let x' := x.
(* Code that compares two stacks x and y:
- ends at p if the stacks x and y are identical
- ends at q otherwise
The status of x and y is unspecified after the
execution but the stacks other than x and y are
unmodified *)
Definition compare_stacks :=
(* i *) POP x (4+i) (7+i) ::
(* 1+i *) POP y q q ::
(* 2+i *) PUSH x Zero :: POP x i i ::
(* 4+i *) POP y i q ::
(* 5+i *) PUSH y Zero :: POP y q i ::
(* 7+i *) POP y q p ::
(* 8+i *) PUSH x' Zero :: POP x' q q :: nil.
Fact compare_stacks_length : length compare_stacks = 10.
Proof. auto. Qed.
Let cs_spec_rec l : forall m v, v#>x = l
-> v#>y = m
-> exists w, (forall z, z <> x -> z <> y -> v#>z = w#>z)
/\ (l = m -> (i,compare_stacks) // (i,v) ->> (p,w))
/\ (l <> m -> (i,compare_stacks) // (i,v) ->> (q,w)).
Proof.
induction l as [ | [] l IHl ]; intros [ | [] m ] v Hx Hy; unfold compare_stacks.
(* l = nil, m = nil *)
exists v; split; auto.
split; [ intros _ | intros [] ]; auto.
bsm sss POP empty with x (4+i) (7+i).
bsm sss POP empty with y q p.
bsm sss stop.
(* l = nil, m = One::_ *)
exists (v[m/y]); split.
intros; rew vec.
split; [ discriminate | intros _ ].
bsm sss POP empty with x (4+i) (7+i).
bsm sss POP 1 with y q p m.
bsm sss PUSH with x' Zero.
bsm sss POP 0 with x' q q nil.
rew vec; f_equal; auto.
bsm sss stop; f_equal.
unfold x'; rew vec.
apply vec_pos_ext; intros z; dest x z.
(* l = nil, m = Zero::_ *)
exists (v[m/y]); split.
intros; rew vec.
split; [ discriminate | intros _ ].
bsm sss POP empty with x (4+i) (7+i).
bsm sss POP 0 with y q p m.
bsm sss stop.
(* l = One::_, m = nil *)
exists (v[l/x]); split.
intros; rew vec.
split; [ discriminate | intros _ ].
bsm sss POP 1 with x (4+i) (7+i) l.
bsm sss POP empty with y q q; rew vec.
bsm sss stop.
(* l = One::l', m = One::m' *)
destruct (IHl m (v[l/x][m/y])) as (w & H1 & H2 & H3); rew vec.
exists w; split.
intros z G1 G2; specialize (H1 _ G1 G2); rewrite <- H1; rew vec.
split.
intros E1; inversion E1 as [ E ]; clear E1.
specialize (H2 E).
bsm sss POP 1 with x (4+i) (7+i) l.
bsm sss POP 1 with y q q m; rew vec.
bsm sss PUSH with x Zero.
bsm sss POP 0 with x i i l; rew vec.
eq goal H2; do 2 f_equal.
apply vec_pos_ext; intros z; dest z x.
intros E1.
spec in H3.
contradict E1; subst; auto.
bsm sss POP 1 with x (4+i) (7+i) l.
bsm sss POP 1 with y q q m; rew vec.
bsm sss PUSH with x Zero.
bsm sss POP 0 with x i i l; rew vec.
eq goal H3; do 2 f_equal.
apply vec_pos_ext; intros z; dest z x.
(* l = One::l', m = Zero::m' *)
exists (v[l/x][m/y]).
split.
intros; rew vec.
split; [ discriminate | intros _ ].
bsm sss POP 1 with x (4+i) (7+i) l.
bsm sss POP 0 with y q q m; rew vec.
bsm sss stop.
(* l = Zero::l', m = nil *)
exists (v[l/x]).
split.
intros; rew vec.
split; [ discriminate | intros _ ].
bsm sss POP 0 with x (4+i) (7+i) l.
bsm sss POP empty with y i q; rew vec.
bsm sss stop.
(* l = Zero::l', m = nil *)
exists (v[l/x][m/y]).
split.
intros; rew vec.
split; [ discriminate | intros _ ].
bsm sss POP 0 with x (4+i) (7+i) l.
bsm sss POP 1 with y i q m; rew vec.
bsm sss PUSH with y Zero.
bsm sss POP 0 with y q i m; rew vec.
bsm sss stop.
(* l = Zero::l', m = Zero::m' *)
destruct (IHl m (v[l/x][m/y])) as (w & H1 & H2 & H3); rew vec.
exists w; split.
intros z G1 G2; specialize (H1 _ G1 G2); rewrite <- H1; rew vec.
split.
intros E1; inversion E1 as [ E ]; clear E1.
specialize (H2 E).
bsm sss POP 0 with x (4+i) (7+i) l.
bsm sss POP 0 with y i q m; rew vec.
intros E1.
spec in H3.
contradict E1; subst; auto.
bsm sss POP 0 with x (4+i) (7+i) l.
bsm sss POP 0 with y i q m; rew vec.
Qed.
Fact compare_stack_eq_spec v :
v#>x = v#>y
-> exists w, (i,compare_stacks) // (i,v) ->> (p,w)
/\ forall z, z <> x -> z <> y -> v#>z = w#>z.
Proof.
intros E.
destruct (cs_spec_rec v eq_refl eq_refl) as (w & H1 & H2 & H3).
exists w; split; auto.
Qed.
Fact compare_stack_neq_spec v :
v#>x <> v#>y
-> exists w, (i,compare_stacks) // (i,v) ->> (q,w)
/\ forall z, z <> x -> z <> y -> v#>z = w#>z.
Proof.
intros E.
destruct (cs_spec_rec v eq_refl eq_refl) as (w & H1 & H2 & H3).
exists w; split; auto.
Qed.
Theorem compare_stack_spec v : exists j w, (i,compare_stacks) // (i,v) ->> (j,w)
/\ forall z, z <> x -> z <> y -> v#>z = w#>z
/\ (v#>x = v#>y /\ j = p \/ v#>x <> v#>y /\ j = q).
Proof.
destruct (list_bool_dec (v#>x) (v#>y)) as [ H | H ].
+ destruct compare_stack_eq_spec with (1 := H) as (w & H1 & H2); exists p, w; auto.
+ destruct compare_stack_neq_spec with (1 := H) as (w & H1 & H2); exists q, w; auto.
Qed.
End compare_stacks.
Section half_tile.
Variable (x : pos n).
(* Code that pushes the reverse of a half tile on a stack *)
Fixpoint half_tile (l : list bool) :=
match l with
| nil => nil
| b::l => PUSH x b :: half_tile l
end.
Fact half_tile_length l : length (half_tile l) = length l.
Proof. induction l; simpl; f_equal; auto. Qed.
Fact half_tile_spec i l v : (i,half_tile l) // (i,v) ->> (length (half_tile l)+i,v[(rev l++v#>x)/x]).
Proof.
rewrite half_tile_length.
revert i v; induction l as [ | b l IHl ]; intros i v; simpl.
bsm sss stop; f_equal.
apply vec_pos_ext; intros z; dest z x.
bsm sss PUSH with x b.
specialize (IHl (1+i) (v[(b::v#>x)/x])).
apply subcode_sss_compute with (P := (1+i,half_tile l)).
subcode_tac; solve list eq.
eq goal IHl; do 2 f_equal.
omega.
apply vec_pos_ext; intros z; dest z x.
solve list eq.
Qed.
End half_tile.
Hint Rewrite empty_stack_length compare_stacks_length half_tile_length : length_db.
Section tile.
Variable (x y : pos n) (Hxy : x <> y) (high low : list bool).
(* Code that pushes a reversed tile on both stacks high and low *)
Definition tile := half_tile x (rev high) ++ half_tile y (rev low).
Fact tile_length : length tile = length high + length low.
Proof. unfold tile; rew length; auto. Qed.
Fact tile_spec i v st : st = (length tile+i,v[(high++v#>x)/x][(low++v#>y)/y])
-> (i,tile) // (i,v) ->> st.
Proof.
intro; subst.
unfold tile.
apply sss_compute_trans with (st2 := (length (half_tile x (rev high))+i,v[(high++v#>x)/x])).
rewrite <- (rev_involutive high) at 3.
apply subcode_sss_compute with (P := (i,half_tile x (rev high))).
subcode_tac.
apply half_tile_spec.
rewrite <- (rev_involutive low) at 3.
apply subcode_sss_compute with (P := (length (half_tile x (rev high))+i,half_tile y (rev low))).
subcode_tac; solve list eq.
replace (length (half_tile x (rev high) ++ half_tile y (rev low)) + i)
with (length (half_tile y (rev low)) + (length (half_tile x (rev high)) + i)).
replace (v#>y) with (v[(high ++ v#>x)/x]#>y) by rew vec.
apply half_tile_spec.
rew length; omega.
Qed.
End tile.
Hint Rewrite tile_length : length_db.
Section transfer_ones.
Variable (x y : pos n) (Hxy : x <> y) (i p q : nat).
(* Code that does the following:
* if x is 111110++l where 1 occurs k times then
- x becomes l
- y becomes bbbbb++y where b occurs k times
* if x is 11111 where 1 occurs k times then
- x becomes nil
- y becomes bbbbb++y where b occurs k times
*)
Definition transfer_ones b := POP x p q :: PUSH y b :: PUSH y Zero :: POP y i i :: nil.
Fact transfer_ones_length b : length (transfer_ones b) = 4.
Proof. auto. Qed.
Fact transfer_ones_spec_1 b k l v st : v#>x = list_repeat One k ++ Zero :: l
-> st = (p,v[l/x][(list_repeat b k ++ v#>y)/y])
-> (i,transfer_ones b) // (i,v) ->> st.
Proof.
intros H1 E; subst st.
revert v H1.
induction k as [ | k IHk ]; intros v; intros Hx;
simpl list_repeat; simpl app; unfold transfer_ones; simpl in Hx.
bsm sss POP 0 with x p q l.
bsm sss stop; f_equal.
apply vec_pos_ext; intros z; dest z y.
bsm sss POP 1 with x p q (list_repeat One k ++ Zero :: l).
bsm sss PUSH with y b.
bsm sss PUSH with y Zero.
bsm sss POP 0 with y i i (b::v#>y); rew vec.
specialize (IHk (v [(list_repeat One k ++ Zero :: l) / x] [(b :: v #> y) / y])).
spec in IHk.
rew vec.
eq goal IHk; do 2 f_equal.
apply vec_pos_ext; intros z; dest z y.
2: dest z x.
change (b :: list_repeat b k ++ v#>y)
with (list_repeat b (S k) ++ v#>y).
replace (S k) with (k+1) by omega.
rewrite list_repeat_plus; solve list eq.
Qed.
Fact transfer_ones_spec_2 b k v st : v#>x = list_repeat One k
-> st = (q,v[nil/x][(list_repeat b k ++ v#>y)/y])
-> (i,transfer_ones b) // (i,v) ->> st.
Proof.
intros H1 E; subst st.
revert v H1.
induction k as [ | k IHk ]; intros v; intros Hx;
simpl list_repeat; simpl app; unfold transfer_ones; simpl in Hx.
bsm sss POP empty with x p q.
bsm sss stop; f_equal.
apply vec_pos_ext; intros z; dest z y; dest z x.
bsm sss POP 1 with x p q (list_repeat One k).
bsm sss PUSH with y b.
bsm sss PUSH with y Zero.
bsm sss POP 0 with y i i (b::v#>y); rew vec.
specialize (IHk (v [(list_repeat One k) / x] [(b :: v #> y) / y])).
spec in IHk.
rew vec.
eq goal IHk; do 2 f_equal.
apply vec_pos_ext; intros z; dest z y.
2: dest z x.
change (b :: list_repeat b k ++ v#>y)
with (list_repeat b (S k) ++ v#>y).
replace (S k) with (k+1) by omega.
rewrite list_repeat_plus; solve list eq.
Qed.
End transfer_ones.
Hint Rewrite transfer_ones_length : length_db.
Section increment.
Variable (x y : pos n) (Hxy : x <> y).
(* Code that increments the stack x by one ie.
for l such that list_bool_succ x l, x becomes l
y is a spare register which is (globally) unmodified
*)
Definition increment i := PUSH y Zero :: transfer_ones x y (1+i) (5+i) (10+i) One ++
PUSH x One :: transfer_ones y x (6+i) (15+i) (15+i) Zero ++
PUSH x Zero :: transfer_ones y x (11+i) (15+i) (15+i) Zero ++
nil.
Fact increment_length i : length (increment i) = 15.
Proof. unfold increment; rew length; auto. Qed.
Fact increment_spec_1 i v k l : v#>x = list_repeat One k ++ Zero :: l
-> (i,increment i) // (i,v) ->> (15+i,v[(list_repeat Zero k ++ One :: l)/x]).
Proof.
intros Hx.
unfold increment.
bsm sss PUSH with y Zero.
apply subcode_sss_compute_trans with (P := (1+i,transfer_ones x y (1+i) (5+i) (10+i) One))
(st2 := (5+i,v[l/x][(list_repeat One k ++ Zero:: v#>y)/y])); auto.
apply transfer_ones_spec_1 with (k := k) (l := l); rew vec.
f_equal.
apply vec_pos_ext; intros z; dest z y; dest z x.
bsm sss PUSH with x One.
apply subcode_sss_compute_trans with (P := (6+i,transfer_ones y x (6+i) (15+i) (15+i) Zero))
(st2 := (15+i,v[(list_repeat Zero k++One::l)/x])); auto.
apply transfer_ones_spec_1 with (k := k) (l := v#>y); rew vec.
f_equal.
apply vec_pos_ext; intros z; dest z y; dest z x.
bsm sss stop.
Qed.
Fact increment_spec_2 i v k : v#>x = list_repeat One k
-> (i,increment i) // (i,v) ->> (15+i,v[(list_repeat Zero (S k))/x]).
Proof.
intros Hx.
unfold increment.
bsm sss PUSH with y Zero.
apply subcode_sss_compute_trans with (P := (1+i,transfer_ones x y (1+i) (5+i) (10+i) One))
(st2 := (10+i,v[nil/x][(list_repeat One k ++ Zero:: v#>y)/y])); auto.
apply transfer_ones_spec_2 with (k := k); rew vec.
f_equal.
apply vec_pos_ext; intros z; dest z y; dest z x.
bsm sss PUSH with x Zero.
apply subcode_sss_compute_trans with (P := (11+i,transfer_ones y x (11+i) (15+i) (15+i) Zero))
(st2 := (15+i,v[(list_repeat Zero (S k))/x])); auto.
apply transfer_ones_spec_1 with (k := k) (l := v#>y); rew vec.
f_equal.
apply vec_pos_ext; intros z; dest z y; dest z x.
replace (S k) with (k+1) by omega.
rewrite list_repeat_plus; auto.
bsm sss stop.
Qed.
Fact increment_spec i v l m :
list_bool_succ l m
-> v#>x = l
-> (i,increment i) // (i,v) ->> (15+i,v[m/x]).
Proof.
revert l m; intros ? ? [ k l | k ] H.
apply increment_spec_1; auto.
apply increment_spec_2; auto.
Qed.
End increment.
Hint Rewrite increment_length : length_db.
Section full_decoder.
Implicit Type (lt : list ((list bool) * list bool)).
Definition size_cards lt := fold_right (fun c x => length (fst c) + length (snd c) + x) 0 lt.
Variables (c h l : pos n) (Hch : c <> h) (Hcl : c <> l) (Hhl : h <> l).
Variables (p : nat) (* jumps here when decoding worked correctly *)
(q : nat) (* jumps here when decoding produced an error *)
.
Let decoder_error := PUSH c Zero :: POP c q q :: nil.
(* Code that implements a decoder for tile indices
- ll is a list of tiles (th,tl)
- when c starts with a valid tile index in ll
encoded as 00001 (with n 0s to represent b)
then the corresponding tile is stacked into
h and l. The code ends up at s
- otherwise, h and l are left unchanged and the
code ends up at q
*)
Fixpoint decoder s i lt :=
match lt with
| nil => decoder_error
| (th,tl) :: lt => POP c (3+length (tile h l th tl)+i) q ::
tile h l th tl ++
PUSH c Zero ::
POP c s s ::
decoder s (3+length (tile h l th tl)+i) lt
end.
Fixpoint length_decoder lt :=
match lt with
| nil => 2
| (th,tl) :: lt => 3+length th+length tl+length_decoder lt
end.
Fact decoder_length s i lt : length (decoder s i lt) = length_decoder lt.
Proof.
revert s i; induction lt as [ | (th,tl) lt IHlt ]; intros s i; rew length; auto.
simpl; rew length; rewrite IHlt; omega.
Qed.
Fact length_decoder_size lt : length_decoder lt = 2+3*length lt+size_cards lt.
Proof. induction lt as [ | [] ]; simpl; auto; omega. Qed.
Local Fact decoder_spec_rec s i mm ll th tl lr lc v w :
v#>c = list_repeat Zero (length ll) ++ One :: lc
-> mm = ll++(th,tl)::lr
-> w = (s,v[lc/c][(th++v#>h)/h][(tl++v#>l)/l])
-> (i,decoder s i mm) // (i,v) ->> w.
Proof.
revert i mm th tl lr lc v w.
induction ll as [ | (t1,t2) ll IHll ]; simpl; intros i mm th tl lr lc v w H1 H2 H3; subst w.
(* The list ll is empty *)
subst mm; simpl decoder.
bsm sss POP 1 with c (S (S (S (length (tile h l th tl) + i)))) q lc.
apply subcode_sss_compute_trans with (P := (1+i,tile h l th tl))
(st2 := (1+length (tile h l th tl)+i,v[lc/c][(th++v#>h)/h][(tl++v#>l)/l])); auto.
apply tile_spec; auto.
f_equal.
rew length; omega.
apply vec_pos_ext; intros z; dest z l.
bsm sss PUSH with c Zero.
bsm sss POP 0 with c s s lc; rew vec.
bsm sss stop; f_equal.
apply vec_pos_ext; intros z; dest z c.
(* The list ll is not empty *)
subst mm; simpl.
bsm sss POP 0 with c (S (S (S (length (tile h l t1 t2) + i)))) q (list_repeat Zero (length ll) ++ One :: lc).
apply subcode_sss_compute with (P := (3+length (tile h l t1 t2)+i,
decoder s (S (S (S (length (tile h l t1 t2)+i)))) (ll++(th,tl)::lr))); auto.
subcode_tac; solve list eq.
apply IHll with th tl lr lc; auto.
rew vec.
f_equal.
apply vec_pos_ext; intros z; dest z c.
Qed.
Fact decoder_spec_ok s i ll th tl lr lc v st :
v#>c = list_repeat Zero (length ll) ++ One :: lc
-> st = (s,v[lc/c][(th++v#>h)/h][(tl++v#>l)/l])
-> (i,decoder s i (ll++(th,tl)::lr)) // (i,v) ->> st.
Proof.
intros; subst; apply decoder_spec_rec with ll th tl lr lc; auto.
Qed.
(* There is no trailing 1 *)
Fact decoder_spec_nok_1 s i ll v k :
v#>c = list_repeat Zero k
-> exists r, (i,decoder s i ll) // (i,v) ->> (q,v[(list_repeat Zero r)/c]).
Proof.
revert i v k.
induction ll as [ | (t1,t2) ll IHll ]; intros i v k H1.
simpl; unfold decoder_error.
exists k.
bsm sss PUSH with c Zero.
bsm sss POP 0 with c q q (v#>c); rew vec.
bsm sss stop.
f_equal.
apply vec_pos_ext; intros z; dest z c.
unfold decoder; fold decoder.
destruct k as [ | k ].
exists 0.
bsm sss POP empty with c (3 + length (tile h l t1 t2) + i) q.
bsm sss stop.
f_equal; apply vec_pos_ext; intros z; dest z c.
simpl in H1.
destruct (IHll (3 + length (tile h l t1 t2) + i) (v[(list_repeat Zero k)/c]) k)
as (r & Hr); rew vec.
exists r.
bsm sss POP 0 with c (3 + length (tile h l t1 t2) + i) q (list_repeat Zero k).
revert Hr; rew vec; apply subcode_sss_compute; auto.
subcode_tac; solve list eq.
Qed.
(* There might be a trailing 1 but the list of 0s is too long *)
Fact decoder_spec_nok_2 s i ll lc v k :
v#>c = list_repeat Zero k ++ lc
-> length ll <= k
-> exists r, (i,decoder s i ll) // (i,v) ->> (q,v[(list_repeat Zero r ++ lc)/c]).
Proof.
revert i lc v k.
induction ll as [ | (t1,t2) ll IHll ]; intros i lc v k H1 H2.
simpl; unfold decoder_error.
exists k.
bsm sss PUSH with c Zero.
bsm sss POP 0 with c q q (v#>c); rew vec.
bsm sss stop.
f_equal.
apply vec_pos_ext; intros z; dest z c.
unfold decoder; fold decoder.
destruct k as [ | k ].
simpl in H2; omega.
simpl in H1, H2.
destruct (IHll (3 + length (tile h l t1 t2) + i) lc (v[(list_repeat Zero k++lc)/c]) k)
as (r & Hr); rew vec.
omega.
exists r.
bsm sss POP 0 with c (3 + length (tile h l t1 t2) + i) q (list_repeat Zero k++lc).
revert Hr; rew vec; apply subcode_sss_compute; auto.
subcode_tac; solve list eq.
Qed.
(* A full decoder of a list of boolean into a list a valid tile indices,
stacking the tiles in h/l in the list on the run.
The following list of indices 5,3,0,2 is encoded as 000001 0001 1 001
A valid list of booleans is an encoding of n1,...,n_p where each
n_i is stricly less than length mm
If the encoding on the list of indices is incorrect in any way:
- either not a list of indices
- or some index is to big
then the full decoder ends up at q.
The empty list is not a valid list of tile indices
*)
Definition full_decoder i ll :=
POP c (4+i) p ::
PUSH c One ::
PUSH h Zero ::
POP h (5+i) q ::
PUSH c Zero ::
decoder i (5+i) ll.
Definition length_full_decoder ll := 5 + length_decoder ll.
Fact full_decoder_length i ll : length (full_decoder i ll) = length_full_decoder ll.
Proof. unfold full_decoder, length_full_decoder; rew length; rewrite decoder_length; auto. Qed.
Local Fact full_dec_start_spec_0 i lt v :
v#>c = nil
-> (i,full_decoder i lt) // (i,v) ->> (p,v).
Proof.
intros H1.
unfold full_decoder; simpl in H1.
bsm sss POP empty with c (4+i) p.
bsm sss stop; f_equal.
Qed.
Local Fact full_dec_start_spec_1 i lt v :
v#>c <> nil
-> (i,full_decoder i lt) // (i,v) ->> (5+i,v).
Proof.
intros H1.
case_eq (v#>c).
intros; destruct H1; auto.
clear H1.
unfold full_decoder.
intros [] lc Hlc.
bsm sss POP 1 with c (4+i) p lc.
bsm sss PUSH with c One.
bsm sss PUSH with h Zero.
bsm sss POP 0 with h (5+i) q (v#>h); rew vec.
bsm sss stop; f_equal.
apply vec_pos_ext; intros z; dest z h; dest z c.
bsm sss POP 0 with c (4+i) p lc.
bsm sss PUSH with c Zero.
bsm sss stop; f_equal.
apply vec_pos_ext; intros z; dest z c.
Qed.
Local Fact full_dec_spec_rec i ln lc lt v :
v#>c = list_nat_bool ln ++ lc
-> Forall (fun x => x < length lt) ln
-> let (hh,ll) := tile_concat ln lt
in (i,full_decoder i lt) // (i,v) ->> (i,v[lc/c][(hh++v#>h)/h][(ll++v#>l)/l]).
Proof.
intros H1 H2; revert H2 v H1.
induction 1 as [ | k ln Hk Hln IHln ]; intros v H1; simpl.
bsm sss stop; f_equal.
apply vec_pos_ext; intros z; dest z l; dest z h; dest z c.
destruct (nth_split _ (nil,nil) Hk) as (ll & lr & H2 & H3).
revert H2; generalize (nth k lt (nil,nil)); intros (th, tl) H2.
simpl in H1.
specialize (IHln (v[(list_nat_bool ln ++ lc)/c][(th++v#>h)/h][(tl++v#>l)/l])).
spec in IHln; rew vec.
destruct (tile_concat ln lt) as (thh,tll).
apply sss_compute_trans with (st2 := (5+i,v)).
apply full_dec_start_spec_1.
rewrite H1; destruct k; discriminate.
unfold full_decoder.
apply subcode_sss_compute_trans with (P := (5+i,decoder i (5 + i) lt))
(st2 := (i,v[(list_nat_bool ln++lc)/c][(th++v#>h)/h][(tl++v#>l)/l])); auto.
subcode_tac; solve list eq.
subst lt; apply decoder_spec_ok with (list_nat_bool ln++lc); auto.
rewrite H3; revert H1; solve list eq.
eq goal IHln; do 2 f_equal.
apply vec_pos_ext; intros z.
dest z l; solve list eq.
dest z h; solve list eq.
dest z c.
Qed.
(* Correctness lemma for the full decoder when
then input actually encodes a valid list of tiles *)
Theorem full_decoder_ok_spec i ln lt v :
v#>c = list_nat_bool ln
-> v#>h = nil
-> v#>l = nil
-> Forall (fun x => x < length lt) ln
-> let (hh,ll) := tile_concat ln lt
in (i,full_decoder i lt) // (i,v) ->> (p,v[nil/c][hh/h][ll/l]).
Proof.
intros H1 H2 H3 H4.
rewrite app_nil_end in H1.
generalize (@full_dec_spec_rec i ln nil lt v H1 H4).
destruct (tile_concat ln lt) as (hh,ll).
intros E.
apply sss_compute_trans with (1 := E); auto.
rewrite H2, H3; repeat rewrite <- app_nil_end.
apply full_dec_start_spec_0; rew vec.
Qed.
Local Fact full_dec_spec_rec1 i ln lc lt v :
v#>c = list_nat_bool ln ++ lc
-> Exists (fun x => length lt <= x) ln
-> exists w, (i,full_decoder i lt) // (i,v) ->> (q,w)
/\ forall z, z <> c -> z <> h -> z <> l -> v#>z = w#>z.
Proof.
intros H1 H2; revert H2 v H1.
induction ln as [ | x ln IHln ]; intros Hln v H1.
inversion Hln.
generalize (full_dec_start_spec_1 i lt v).
intros H2; spec in H2.
rewrite H1; simpl; destruct x; discriminate.
simpl in H1.
destruct (le_lt_dec (length lt) x) as [ Hx | Hx ].
unfold full_decoder.
solve list eq in H1.
destruct (decoder_spec_nok_2 i (5+i) lt _ _ H1 Hx) as (r & Hr).
exists (v [(list_repeat Zero r++One::list_nat_bool ln++lc)/c]); split.
apply sss_compute_trans with (1 := H2); auto.
unfold full_decoder; revert Hr; apply subcode_sss_compute; auto.
subcode_tac; solve list eq.
intros; rew vec.
apply Exists_cons in Hln.
destruct Hln as [ Hln | Hln ].
omega.
specialize (IHln Hln).
destruct (nth_split _ (nil,nil) Hx) as (ll & lr & H3 & H4).
revert H3; generalize (nth x lt (nil,nil)); intros (th, tl) H3.
specialize (IHln (v[(list_nat_bool ln++lc)/c][(th++v#>h)/h][(tl++v#>l)/l])).
spec in IHln; rew vec.
destruct IHln as (w & Hw & Hw1).
exists w; split.
apply sss_compute_trans with (2 := Hw).
apply sss_compute_trans with (1 := H2); auto.
rewrite <- H4 in H1.
solve list eq in H1.
generalize (@decoder_spec_ok i (5+i) ll th tl lr _ _ _ H1 eq_refl).
unfold full_decoder; apply subcode_sss_compute.
subst; subcode_tac; solve list eq.
intros z G1 G2 G3; generalize (Hw1 _ G1 G2 G3); rew vec.
Qed.
Local Fact full_dec_spec_rec2 i k lt v :
v#>c = list_repeat Zero (S k)
-> exists w, (i,full_decoder i lt) // (i,v) ->> (q,w)
/\ forall z, z <> c -> z <> h -> z <> l -> v#>z = w#>z.
Proof.
intros H.
destruct (@decoder_spec_nok_1 i (5+i) lt _ _ H) as (r & Hr).
exists (v[(list_repeat Zero r)/c]); split.
2: intros; rew vec.
generalize (@full_dec_start_spec_1 i lt v); intros H1.
spec in H1.
rewrite H; discriminate.
apply sss_compute_trans with (1 := H1); auto.
revert Hr.
unfold full_decoder.
apply subcode_sss_compute; auto.
subcode_tac; solve list eq.
Qed.
(* Correctness lemma for the full decoder when
then input encodes an invalid list of tiles *)
Theorem full_decoder_ko_spec i ln lc lt v :
v#>c = list_nat_bool ln ++ lc
-> (Exists (fun x => length lt <= x) ln
\/ Forall (fun x => x < length lt) ln
/\ exists k, lc = list_repeat Zero (S k))
-> exists w, (i,full_decoder i lt) // (i,v) ->> (q,w)
/\ forall z, z <> c -> z <> h -> z <> l -> v#>z = w#>z.
Proof.
intros H1 [ H2 | (H2 & k & H3) ].
apply full_dec_spec_rec1 with ln lc; auto.
generalize (@full_dec_spec_rec i ln lc lt v H1 H2).
destruct (tile_concat ln lt) as (hh,ll); intros H4.
destruct (@full_dec_spec_rec2 i k lt
(v[lc/c][(hh++v#>h)/h][(ll++v#>l)/l])) as (w & Hw1 & Hw2); rew vec.
exists w; split.
apply sss_compute_trans with (1 := H4); auto.
intros x E1 E2 E3; rewrite <- Hw2; auto; rew vec.
Qed.
End full_decoder.
Hint Rewrite full_decoder_length : length_db.
Section simulator.
Variables (s a h l : pos n) (Hsa : s <> a) (Hsh : s <> h) (Hsl : s <> l)
(Hah : a <> h) (Hal : a <> l) (Hhl : h <> l)
(lt : list ((list bool)*list bool)).
Section increment_erase.
Variable (i p : nat).
(* This code does the following
- increments s (as a list of booleans)
- empties h, l and a
- jumps to p
*)
Definition increment_erase :=
(* i *) increment s a i ++
(* 15+i *) empty_stack h (15+i) ++
(* 18+i *) empty_stack l (18+i) ++
(* 21+i *) empty_stack a (21+i) ++
(* 24+i *) PUSH l Zero :: POP l p p :: nil.
Fact increment_erase_length : length increment_erase = 26.
Proof. auto. Qed.
Fact increment_erase_spec v ln mn w :
list_bool_succ ln mn
-> v#>s = ln
-> w = v[mn/s][nil/h][nil/l][nil/a]
-> (i,increment_erase) // (i,v) ->> (p,w).
Proof.
intros H1 H2 ?; subst w.
unfold increment_erase.
apply sss_compute_trans with (st2 := (15+i,v[mn/s])).
apply subcode_sss_compute with (P := (i,increment s a i )); auto.
apply increment_spec with ln; auto.
apply sss_compute_trans with (st2 := (18+i,v[mn/s][nil/h])).
apply subcode_sss_compute with (P := (15+i,empty_stack h (15+i))); auto.
apply empty_stack_spec.
apply sss_compute_trans with (st2 := (21+i,v[mn/s][nil/h][nil/l])).
apply subcode_sss_compute with (P := (18+i,empty_stack l (18+i))); auto.
apply empty_stack_spec.
apply sss_compute_trans with (st2 := (24+i,v[mn/s][nil/h][nil/l][nil/a])).
apply subcode_sss_compute with (P := (21+i,empty_stack a (21+i))); auto.
apply empty_stack_spec.
bsm sss PUSH with l Zero.
bsm sss POP 0 with l p p nil; rew vec.
bsm sss stop.
f_equal.
apply vec_pos_ext; intros x; dest x l.
Qed.
End increment_erase.
Hint Rewrite increment_erase_length : length_db.
Section main_init.
Variable (i : nat).
(* Self explaining code:
- s becomes Zero::nil
- a, h and l are emptied
*)
Definition main_init :=
(* i *) empty_stack s i ++
(* 3+i *) empty_stack a (3+i) ++
(* 6+i *) empty_stack h (6+i) ++
(* 9+i *) empty_stack l (9+i) ++
(* 12+i *) PUSH s Zero :: nil.
Fact main_init_length : length main_init = 13.
Proof. auto. Qed.
Fact main_init_spec v : (i,main_init) // (i,v) ->> (13+i,v[(Zero::nil)/s][nil/a][nil/h][nil/l]).
Proof.
unfold main_init.
apply subcode_sss_compute_trans with (2 := empty_stack_spec s _ _); auto.
apply subcode_sss_compute_trans with (2 := empty_stack_spec a _ _); auto.
apply subcode_sss_compute_trans with (2 := empty_stack_spec h (6+i) _); auto.
apply subcode_sss_compute_trans with (2 := empty_stack_spec l (9+i) _); auto.
bsm sss PUSH with s Zero.
bsm sss stop.
f_equal.
apply vec_pos_ext; intros x.
dest x a; dest x l; dest x h; dest x s.
Qed.
End main_init.
Section main_loop.
Variables (i p : nat).
Let lFD := length_full_decoder lt.
(* This code does the following:
- copies s to a (temporarily using the empty h stack)
- decodes a as a list of tiles into h/l
* if the list is correct and h = l at the ends, we
have a solution to PCP and we jump to p
* if the list is incorrect, increments s,
clean up of h, l and a and start over (loop)
*)
Definition main_loop :=
(* i *) copy_stack s a h i ++
(* 16+i *) full_decoder a h l (lFD+16+i) (lFD+26+i) (16+i) lt ++
(* lFD+16+i *) compare_stacks h l (lFD+16+i) p (lFD+26+i) ++
(* lFD+26+i *) increment_erase (lFD+26+i) i.
Definition length_main_loop := 52 + lFD.
Fact main_loop_length : length main_loop = length_main_loop.
Proof. unfold main_loop, length_main_loop, lFD; rew length; omega. Qed.
Fact main_loop_size : length_main_loop = 59+3*length lt+size_cards lt.
Proof.
unfold length_main_loop, lFD, length_full_decoder.
rewrite length_decoder_size; omega.
Qed.
Fact main_loop_ok_spec v ln :
v#>h = nil
-> v#>l = nil
-> v#>a = nil
-> v#>s = list_nat_bool ln
-> Forall (fun x => x < length lt) ln
-> (let (hh,ll) := tile_concat ln lt in hh = ll)
-> exists w, (i,main_loop) // (i,v) ->> (p,w)
/\ forall x, x <> a -> x <> h -> x <> l -> v#>x = w#> x.
Proof.
intros H0 H1 H2 H3 H4 H5.
case_eq (tile_concat ln lt).
intros hh ll E; rewrite E in H5.
destruct (compare_stack_eq_spec Hhl (lFD+16+i) p (lFD+26+i) (v[nil/a][hh/h][ll/l]))
as (w & Hw1 & Hw2); rew vec.
exists w; split.
unfold main_loop.
apply sss_compute_trans with (st2 := (16+i,v[(list_nat_bool ln)/a])).
apply subcode_sss_compute with (P := (i,copy_stack s a h i)); auto.
apply copy_stack_spec with (list_nat_bool ln); auto.
rewrite H2, <- app_nil_end; auto.
apply sss_compute_trans with (st2 := (lFD+16+i,v[nil/a][hh/h][ll/l])).
apply subcode_sss_compute with (P := (16+i,full_decoder a h l (lFD+16+i) (lFD+26+i) (16+i) lt)); auto.
generalize (@full_decoder_ok_spec _ _ _ Hah Hal Hhl (lFD+16+i) (lFD+26+i) (16+i) ln lt
(v[(list_nat_bool ln)/a])); intros H6.
do 3 (spec in H6; [ rew vec | ]).
spec in H6; auto.
rewrite E in H6.
eq goal H6; do 2 f_equal; rew vec.
apply subcode_sss_compute with (P := (lFD+16+i,compare_stacks h l (lFD+16+i) p (lFD+26+i))); auto.
intros x E1 E2 E3; generalize (Hw2 _ E2 E3); rew vec.
Qed.
Fact main_loop_ko_spec v ln lc :
v#>h = nil
-> v#>l = nil
-> v#>a = nil
-> v#>s = list_nat_bool ln ++ lc
-> ( ( Exists (fun x => length lt <= x) ln
\/ Forall (fun x => x < length lt) ln /\ exists k, lc = list_repeat Zero (S k) )
\/ Forall (fun x => x < length lt) ln /\ lc = nil
/\ let (hh,ll) := tile_concat ln lt in hh <> ll)
-> (i,main_loop) // (i,v) ->> (i,v[(list_bool_next (v#>s))/s]).
Proof.
intros H0 H1 H2 H3 [ H4 | (H4 & ? & H5) ].
destruct (@full_decoder_ko_spec _ _ _ Hah Hal Hhl (lFD+16+i) (lFD+26+i) (16+i))
with (v := v[(list_nat_bool ln ++ lc)/a]) (2 := H4) as (w & Hw1 & Hw2); rew vec.
unfold main_loop.
apply sss_compute_trans with (st2 := (16+i,v[(list_nat_bool ln++lc)/a])).
apply subcode_sss_compute with (P := (i,copy_stack s a h i)); auto.
apply copy_stack_spec with (list_nat_bool ln++lc); auto.
rewrite H2, <- app_nil_end; auto.
apply subcode_sss_compute_trans with (2 := Hw1); auto.
apply subcode_sss_compute with (P := (lFD+26+i,increment_erase (lFD + 26 + i) i)); auto.
apply increment_erase_spec with (1 := list_bool_next_spec (v#>s)); auto.
rewrite <- Hw2; auto; rew vec.
apply vec_pos_ext; intros x.
dest x a; dest x l; dest x h; dest x s.
rewrite <- Hw2; auto; rew vec.
unfold main_loop.
subst lc.
rewrite <- app_nil_end in H3.
case_eq (tile_concat ln lt).
intros hh ll E; rewrite E in H5.
destruct (compare_stack_neq_spec Hhl (lFD+16+i) p (lFD+26+i) (v[nil/a][hh/h][ll/l]))
as (w & Hw1 & Hw2); rew vec.
apply sss_compute_trans with (st2 := (16+i,v[(list_nat_bool ln)/a])).
apply subcode_sss_compute with (P := (i,copy_stack s a h i)); auto.
apply copy_stack_spec with (list_nat_bool ln); auto.
rewrite H2, <- app_nil_end; auto.
apply sss_compute_trans with (st2 := (lFD+16+i,v[nil/a][hh/h][ll/l])).
apply subcode_sss_compute with (P := (16+i,full_decoder a h l (lFD+16+i) (lFD+26+i) (16+i) lt)); auto.
generalize (@full_decoder_ok_spec _ _ _ Hah Hal Hhl (lFD+16+i) (lFD+26+i) (16+i) ln lt
(v[(list_nat_bool ln)/a])); intros H6.
do 3 (spec in H6; [ rew vec | ]).
spec in H6; auto.
rewrite E in H6.
eq goal H6; do 2 f_equal; rew vec.
apply sss_compute_trans with (st2 := (lFD+26+i,w)).
apply subcode_sss_compute with (P := (lFD+16+i,compare_stacks h l (lFD+16+i) p (lFD+26+i))); auto.
apply subcode_sss_compute with (P := (lFD+26+i,increment_erase (lFD + 26 + i) i)); auto.
apply increment_erase_spec with (1 := list_bool_next_spec (v#>s)); auto.
rewrite <- Hw2; auto; rew vec.
apply vec_pos_ext; intros x.
dest x a; dest x l; dest x h; dest x s.
rewrite <- Hw2; auto; rew vec.
Qed.
Implicit Type (v : vec (list bool) n).
Let pre v := v#>h = nil /\ v#>l = nil /\ v#>a = nil.
Let spec v w := forall x, x <> a -> x <> h -> x <> l -> v#>x = w#> x.
Let f v := v[(list_bool_next (v#>s))/s].
Let Hf v : v <> f v.
Proof.
intros E.
apply (list_bool_succ_neq) with (1 := list_bool_next_spec (v#>s)).
rewrite E at 1.
unfold f; rew vec.
Qed.
Let C2 v := exists ln,
v#>s = list_nat_bool ln
/\ Forall (fun x => x < length lt) ln
/\ (let (hh,ll) := tile_concat ln lt in hh = ll).
Let C1 v := exists ln lc,
v#>s = list_nat_bool ln ++ lc
/\ ( ( Exists (fun x => length lt <= x) ln
\/ Forall (fun x => x < length lt) ln /\ exists k, lc = list_repeat Zero (S k) )
\/ Forall (fun x => x < length lt) ln /\ lc = nil
/\ let (hh,ll) := tile_concat ln lt in hh <> ll).
Let HC v : pre v -> { C1 v } + { C2 v }.
Proof.
unfold C1, C2.
intros _.
generalize (v#>s); clear v; intros m.
destruct (list_bool_valid_dec (length lt) m)
as [ (ln & H1) | (ln & H1) ].
case_eq (tile_concat ln lt); intros hh ll H2.
destruct (list_bool_dec hh ll) as [ H3 | H3 ].
* right.
exists ln.
destruct H1 as (H1 & H4).
rewrite H2; auto.
* left.
destruct H1 as (H1 & H4).
exists ln, nil.
rewrite <- app_nil_end.
split; auto.
right.
rewrite H2; auto.
* left.
destruct H1 as (lc & H1 & H2).
exists ln, lc; split; auto.
Qed.
Hypothesis (Hp : out_code p (i,main_loop)).
Let HP1 : forall x, pre x -> C1 x -> (i,main_loop) // (i,x) ->> (i,f x) /\ pre (f x).
Proof.
intros v (H1 & H2 & H3) (ln & lc & H4 & H5).
split.
apply main_loop_ko_spec with ln lc; auto.
red; unfold f; rew vec; auto.
Qed.
Let HP2 : forall x, pre x -> C2 x -> exists y, (i,main_loop) // (i,x) ->> (p,y) /\ spec x y.
Proof.
intros v (H1 & H2 & H3) (ln & H4 & H5 & H6).
apply main_loop_ok_spec with ln; auto.
Qed.
Let main_loop_sound_rec v :
pre v
-> (exists n, C2 (iter f v n))
-> exists n w, (i,main_loop) // (i,v) ->> (p,w) /\ spec (iter f v n) w.
Proof.
apply sss_loop_sound with (C1 := C1); auto.
Qed.
Let main_loop_complete_rec v w q : pre v
-> out_code q (i,main_loop)
-> (i,main_loop) // (i,v) ->> (q,w)
-> p = q /\ exists n, C2 (iter f v n) /\ spec (iter f v n) w.
Proof.
apply sss_loop_complete with (C1 := C1); auto.
apply bsm_sss_fun.
Qed.
Let iter_f_v v k : iter f v k = v[(iter list_bool_next (v#>s) k)/s].
Proof.
revert v.
unfold f; induction k as [ | k IHk ]; intros v; simpl; [ | rewrite IHk ]; rew vec.
Qed.
Let C2_eq v : v#>s = Zero::nil -> (exists n, C2 (iter f v n)) <-> tiles_solvable lt.
Proof.
unfold tiles_solvable.
intros H1; simpl.
split.
intros (k & Hk).
rewrite iter_f_v, H1 in Hk.
destruct Hk as (ln & H2 & H3 & H4).
revert H2; rew vec; intros H2.
exists ln; repeat split; auto.
intros E.
subst ln.
simpl in H2.
apply iter_list_bool_next_nil in H2.
destruct H2; discriminate.
intros (ln & H2 & H3 & H4).
destruct (@list_bool_next_total (list_nat_bool ln)) as (k & Hk).
destruct ln as [ | [ | u ] ln ]; simpl; auto; discriminate.
exists k.
rewrite iter_f_v, H1, <- Hk.
exists ln; rew vec; auto.
Qed.
Theorem main_loop_sound v :
v#>s = Zero::nil -> v#>h = nil -> v#>l = nil -> v#>a = nil
-> tiles_solvable lt
-> exists w, (i,main_loop) // (i,v) ->> (p,w)
/\ forall x, x <> s -> x <> a -> x <> h -> x <> l -> v#>x = w#>x.
Proof.
intros H1 H2 H3 H4.
rewrite <- (C2_eq _ H1); auto.
intros H5.
destruct main_loop_sound_rec with (2 := H5)
as (k & w & Hw1 & Hw2).
red; auto.
exists w; split; auto.
unfold spec in Hw2 |- *.
intros; rewrite <- Hw2; auto.
rewrite iter_f_v; rew vec.
Qed.
Theorem main_loop_complete v w q :
v#>s = Zero::nil -> v#>h = nil -> v#>l = nil -> v#>a = nil
-> out_code q (i,main_loop)
-> (i,main_loop) // (i,v) ->> (q,w)
-> p = q
/\ (forall x, x <> s -> x <> a -> x <> h -> x <> l -> v#>x = w#>x)
/\ tiles_solvable lt.
Proof.
intros H1 H2 H3 H4 H5 H6.
rewrite <- (C2_eq _ H1); auto.
destruct main_loop_complete_rec with (2 := H5) (3 := H6)
as (G1 & k & G2 & G3).
red; auto.
split; auto.
split; [ | exists k ]; auto.
red in G3.
intros; rewrite <- G3; auto.
rewrite iter_f_v; rew vec.
Qed.
End main_loop.
End simulator.
End Binary_Stack_Machines.