(**************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(**************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(**************************************************************)
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.
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.  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.  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.
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.  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.  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.  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).  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.
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.
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.
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.
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.
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]).
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]).
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.
Fact length_decoder_size lt : length_decoder lt = 2+3*length lt+size_cards lt.
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.
(* 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]).
(* 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]).
(* 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.
Local Fact full_dec_start_spec_1 i lt v :
v#>c <> nil
-> (i,full_decoder i lt) // (i,v) ->> (5+i,v).
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]).
(* Correctness lemma for the full decoder when then input actually encodes a valid list of tiles *)

(* Specifications: *)
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]).