Load loadpath.
Require Import ssreflect ssrbool ssrnat ssrfun eqtype seq.
Require Import prelude heaps rels hprop domains secmod seclog.
Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

(******************************************************************************
Definitions of simple datatypes and their properties.  We ignore Golovin's
"initial randomness."  The datatypes are simple because they don't support
implementations in a programming language in which programs can get stuck (i.e. 
a realistic programming language like RHTT).  For a theory of datatypes that 
permits realistic implementations, see the forthcoming datatypes.v.
*******************************************************************************)

Structure datatype := Datatype {
(*the type of logical states*)
  Alpha : Type; 
(*the type of machine states*)
  Gamma : Type; 
(*the type of logical operations*)
  Op : Type; 
(*the initial state*)
  init : Alpha;
(*a representation function mapping logical states to sets of machine states*)
  rep : Alpha -> Pred Gamma;
(*a transition function mapping logical states and operations to logical 
  states*)
  trans : Alpha -> Op -> Alpha; 
(*the "compilation" function mapping operations to programs*)
  f : Gamma -> Op -> Gamma;
(*Correctness of the compilation function:
  For any operation taking the data structure from logical state a1 to logical 
  state a2, the compilation of that operation takes any machine representation 
  of logical state a1 to a machine state representing a2.*)
  f_correct : forall alpha op gamma, 
                rep alpha gamma -> rep (trans alpha op) (f gamma op)
}.


Delimit Scope datatype_scope with DATA.
Notation "gamma '\rep' alpha" := 
  (rep alpha gamma) (at level 11, no associativity) : DATA.
Local Open Scope DATA.

Section datatype_properties.
Variable (d: datatype).

(*lift the transition and compilation functions to sequences*)
Fixpoint trans_star (a: Alpha d) s :=
  if s is op :: s' then trans_star (trans a op) s' else a.
Notation "'trans*'" := trans_star.

Lemma trans_star_nil a : trans* a nil = a. 
Proof. done. Qed.
Lemma trans_star_cons a op s : trans* a (op :: s) = trans* (trans a op) s. 
Proof. done. Qed.
Lemma trans_star_cat a s1 s2 : trans* (trans* a s1) s2 = trans* a (s1 ++ s2). 
Proof. by move: a s2; elim s1 =>/=. Qed.

Fixpoint f_star (g: Gamma d) s :=
  if s is op :: s' then f_star (f g op) s' else g.
Notation "'f*'" := f_star.

Lemma f_star_nil a : f* a nil = a. Proof. done. Qed.

Lemma f_star_cons a op s : f* a (op :: s) = f* (f a op) s. Proof. done. Qed.

Lemma f_star_cat g s1 s2 : f* (f* g s1) s2 = f* g (s1 ++ s2).
Proof. by elim: s1 g s2=>/=. Qed.

Lemma f_star_correct a g s : g \rep a -> f* g s \rep trans* a s.
Proof. by elim: s a g=>[//=|o s' IH] a g R; apply: IH; apply: f_correct. Qed.

(*A uniquely represented data structure is one for which \rep is a functional 
  relation.*)
Definition uniquely_represented := 
  forall (a: Alpha d) g g', 
          g \rep a -> g' \rep a -> g = g'.

(*Strong history independence: For any g \rep a, and for any two sequences of
  operations X and Y that take the data structure from a to the same logical
  state, the programs given by X and Y take the machine state from g to
  the same machine state.*)
Definition strongly_history_independent := 
  forall a g X Y, 
          g \rep a -> 
          trans* a X = trans* a Y -> 
          f* g X = f* g Y.

Notation SHI := strongly_history_independent.

Theorem uniquely_represented_SHI : uniquely_represented -> SHI.
Proof.
rewrite /uniquely_represented /SHI => UR a1 c1 X Y R T.
have H0: rep (trans_star a1 X) (f_star c1 X) by apply: f_star_correct.
have H1: rep (trans_star a1 Y) (f_star c1 Y) by apply: f_star_correct.
by apply: UR H1; rewrite -T.
Qed.

Definition reachable a1 a2 g1 g2 :=
  g1 \rep a1 -> g2 \rep a2 -> 
  exists X, a2 = trans* a1 X /\ g2 = f* g1 X.

Definition mutually_reachable a1 a2 g1 g2 := 
          reachable a1 a2 g1 g2 /\ reachable a2 a1 g2 g1.

Definition logically_reachable a1 a2 :=
          exists X, a2 = trans* a1 X.

Definition logically_mutually_reachable a1 a2 :=
          logically_reachable a1 a2 /\ logically_reachable a2 a1.

Definition reversible := forall a1 a2, logically_reachable a1 a2.

Definition all_initially_reachable :=
          forall a g g', g \rep init d -> g' \rep a -> 
          reachable (init d) a g g'.

Definition initially_unique := 
          forall g g', g \rep init d -> g' \rep init d -> g = g'.
 
Lemma SHI_reachable_eq a g g' : 
  SHI -> reachable a a g g' -> g \rep a -> g' \rep a -> g = g'.
Proof.
rewrite /SHI /reachable => SHI REACH R1 R2.
case: (REACH R1 R2)=>X [T ->].
by rewrite -(SHI _ _ [::] _ R1).
Qed.

Lemma reachableT a1 a2 a3 g1 g2 c3 :
          g1 \rep a1 -> g2 \rep a2 -> c3 \rep a3 ->
          reachable a1 a2 g1 g2 -> reachable a2 a3 g2 c3 -> 
          reachable a1 a3 g1 c3.
Proof.
move=> R1 R2 R3 RR1 RR2.
case: (RR1 R1 R2) (RR2 R2 R3)=> X [T1 U1][Y][T2 U2] _ _.
by exists (X ++ Y); rewrite -trans_star_cat -T1 -f_star_cat -U1.
Qed.

Lemma mutually_reachableT a1 a2 a3 g1 g2 g3 :
          g1 \rep a1 -> g2 \rep a2 -> g3 \rep a3 ->
          mutually_reachable a1 a2 g1 g2 -> mutually_reachable a2 a3 g2 g3 ->
          mutually_reachable a1 a3 g1 g3.
Proof.
move=>R1 R2 R3 [H I][J K]; 
by split; [move: J | move: I]; apply: reachableT.
Qed.

Lemma mutually_reachableS a1 a2 g1 g2 :
          mutually_reachable a1 a2 g1 g2 ->
          mutually_reachable a2 a1 g2 g1.
Proof. by case. Qed.

Lemma logically_reachableT a1 a2 a3 :
          logically_reachable a1 a2 -> logically_reachable a2 a3 ->
          logically_reachable a1 a3.
Proof.
move=> [X H][Y I]; exists (X ++ Y). 
by rewrite -trans_star_cat -H.
Qed.

Lemma SHI_mutually_reachable_eq a1 a2 g1 g2 :
          SHI -> g1 \rep a1 -> g2 \rep a2 -> mutually_reachable a1 a2 g1 g2 ->
          forall g2', g2' \rep a2 ->
                      (mutually_reachable a1 a2 g1 g2' <-> g2 = g2').
Proof.
rewrite /SHI; move=> SHI R1 R2 MR g2' R2'; split=> MR'.
have: reachable a2 a2 g2 g2'
  by case MR=> RR1 RR2; case MR'=> RR1' RR2'; clear MR MR'; 
     apply reachableT with (a2:=a1)(g2:=g1); auto. 
move=> RR1; apply: SHI_reachable_eq; eauto.
subst g2' =>//=.
Qed.

Lemma reversible_logically_mutually_reachable a1 a2 :
          reversible -> logically_mutually_reachable a1 a2.
Proof. by move=> R; split. Qed.

(*Hartline et al. assume all concrete states are initially reachable (p.60).
  Reversible means all /logical/ states are interreachable.  It says nothing
  about concrete states.  To prove this direction, it is also sufficient 
  to assume the stronger condition that all concrete states are 
  interreachable.*)
Lemma SHI_reversible_uniquely_represented :
          SHI -> reversible -> all_initially_reachable -> 
          uniquely_represented.
Proof.
rewrite /uniquely_represented; move=> SHI REV IR a g g' R R'.
(*By SHI_mutually_reachable_eq, it suffices to show that g and g' are 
  interreachable.*)
suff: mutually_reachable a a g g' => [H|].
- have I: mutually_reachable a a g g.
  apply: mutually_reachableT; eauto.
  by apply: mutually_reachableS.
rewrite <- SHI_mutually_reachable_eq; eauto.
case (REV a (init d)) => X H.
(*g : A ----> f* g X : init d*)
have I: reachable a (init d) g (f* g X) by eexists; eauto.
(*g' : A ----> f* g' X : init d*)
have J: reachable a (init d) g' (f* g' X) by eexists; eauto.
(*f* g X : init d ----> g' by all_initially_reachable*)
have K: reachable (init d) a (f* g X) g'.
- case (IR a (f* g X) g') => //; 
  try solve [rewrite H; apply f_star_correct =>//]; eexists; eauto.
(*f* g' X : init d ----> g by all_initially_reachable*)
have L: reachable (init d) a (f* g' X) g.
- case (IR a (f* g' X) g) => //; 
  try solve [rewrite H; apply f_star_correct =>//]; eexists; eauto.
(*The result follows by transitivity of reachable.*)
by split; [ apply reachableT with (a2:=init d)(g2:=f* g X); eauto; 
            rewrite H; apply f_star_correct
          | apply reachableT with (a2:=init d)(g2:=f* g' X); eauto;
            rewrite H; apply f_star_correct ].
Qed.

(*Hartline et al.'s main theorem connecting SHI and unique representation.*)
Theorem reversible_SHI_iff_uniquely_represented : 
          reversible -> all_initially_reachable -> 
          (SHI <-> uniquely_represented).
Proof.
move=> REV IR; split=> H. 
apply: SHI_reversible_uniquely_represented =>//.
apply: uniquely_represented_SHI =>//.
Qed.

(*Weak history independence: For any g \rep /initial/ a, and for any two
  sequences of operations X and Y that take the data structure from a to
  the same logical state, the programs given by X and Y take the machine
  state from g to the same machine state.*)
Definition weakly_history_independent := 
          forall g X Y, 
          g \rep init d -> trans* (init d) X = trans* (init d) Y ->
          f* g X = f* g Y.

Notation WHI := weakly_history_independent.

Theorem SHI_WHI : SHI -> WHI.
Proof. 
move=> SHI; rewrite /WHI. 
by intros until Y; move=> R T; apply: (SHI (init d) g X Y R T). 
Qed.

End datatype_properties.


(*Sanity check: our definition of datatype doesn't require unique
  representation.*)
Module datatype_nontrivial.

(*The following datatype has just a single abstract state, tt,
  but tracks in memory the number of operations performed.  Below, we prove that
  the datatype is not uniquely represented: there are an infinite number of
  machine states, each of which is a valid representative of the single
  abstract state tt.*)

Definition rep := fun (_: unit) (_: nat) => True.
Definition trans := fun (_: unit) (_: unit) => tt.
Definition f := fun (n: nat) (_: unit) => n.+1.
Definition f_correct : forall a op g, rep a g -> rep (trans a op) (f g op).
Proof. done. Qed.

Canonical Structure NontrivialDatatype := Datatype tt f_correct.

Lemma NontrivialDatatype_nontrivial : 
  uniquely_represented NontrivialDatatype -> False.
Proof.
rewrite /uniquely_represented =>H.
have I: forall a g, rep a g by done.
specialize (H tt 0 1 (I _ _) (I _ _)). inversion H.
Qed.

End datatype_nontrivial.


