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.

Definition spec1 As B := [fun s : spec As B => pre_app s.1].
Implicit Arguments spec1 [As B].

Definition spec2 As B := [fun s : spec As B => post_app s.2].
Implicit Arguments spec2 [As B].

Module DataType.

(****************************************************************************** 
This module defines a model of data structures.  The components of a data 
structure are: 

T  = a type of logical or abstract states/configurations of the data 
     structure
Op = a type of logical operations on the data structure (i.e., the exposed 
     interface operations)
init : Pred T = a set of distinguished initial logical states
shape : T -> Pred heap = a map from logical states to sets of heaps that 
     implement them
args_of : Op -> seq Type = defines the types of an op's arguments 
res_of : Op -> Type = defines the type of an op's result 
spec_of : \Pi op. spec (args_of op) (res_of op) = defines the specification
     of operation op.  The spec combines a unary precondition on heaps 
     indexed by (args_of op) with a binary /relational/ postcondition on 
     the initial and final heaps of the computation and the computation's 
     result, also indexed by (args_of op).
trans : \Pi op. T -> args (args_of op) -> T * res_of op = defines the 
     logical interpretation of op, as a function from T and the uncurried 
     (args_of op) to a final T and a result of type (res_of op)
shape_inv = requires that shape be invariant under trans/spec_of
********************************************************************************)

Structure datatype := Datatype {
  T : Type; 
  Op : Type;           
  init : T;
  shape : T -> Pred heap;     
  args_of : Op -> seq Type;
  res_of : Op -> Type; 
  spec_of : forall op, spec (args_of op) (res_of op);               
  trans : forall op : Op, T -> args (args_of op) -> T * res_of op; 
  shape_inv : forall aalpha op av1 av2 yy ii mm,
    spec2 (spec_of op) av1 av2 yy ii mm ->
    shape aalpha.1 ii.1 -> shape aalpha.2 ii.2 -> 
    shape (trans aalpha.1 av1).1 mm.1 /\ shape (trans aalpha.2 av2).1 mm.2    
}.

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

Section DataProp. Context (DT : datatype).

Notation "'T'" := (T DT).
Notation "'Op'" := (Op DT).
Notation "'init'" := (init DT).
Notation "'args_of'" := (@args_of DT).
Notation "'res_of'" := (@res_of DT).

Definition ddef ii := def ii.1 /\ def ii.2.

Definition safe op av i := def i /\ i \In (spec1 (@spec_of DT op) av).

Definition ssafe op (av1 av2 : args (args_of op)) ii :=  
  safe av1 ii.1 /\ safe av2 ii.2.

Inductive cmd : seq Type -> Type -> Type :=
| Skip : forall As B, cmd As B
| PrimCom : forall op : Op, cmd (args_of op) (res_of op)
| Lambda : forall A As B (e : cmd As B), cmd (A :: As) B
| SeqCom : forall As B C (e1 : cmd As B) (e2 : cmd (B :: As) C), cmd As C.

Implicit Arguments eq_rect [A x y].

(* coerce a sequence of wellformed ops to a cmd -- this defn. is not useful in
   general (see note below) *)

Fixpoint wf' As ops := 
  if ops is op :: ops' then args_of op = As /\ wf' (res_of op :: As) ops'
  else True.

Lemma wf'1 As op ops : wf' As (op :: ops) -> args_of op = As.
Proof. by case. Qed.

Lemma wf'2 As op ops : wf' As (op :: ops) -> wf' (res_of op :: As) ops.
Proof. by case. Qed.

Definition coerce' {As op} (pf : args_of op = As) 
  : cmd As (res_of op) := eq_rect (fun Ts => cmd Ts (res_of op)) (PrimCom op) pf.

Fixpoint wf'ops_cmd As B ops : wf' As ops -> cmd As B :=
  if ops is op :: ops' then fun pf => 
    SeqCom (coerce' (wf'1 pf)) (wf'ops_cmd B (wf'2 pf))
  else fun _ => Skip As B.
    
(* alternatively, we say a sequence of ops is wellformed if each successive
   operation can be made safe wrt. arguments by ignoring the return value of the
   previous one.  this is more natural than the previous defn.  since in
   general, to execute
   
       inc;; inc;; inc 

   on a counter, for example, we do not want to require one version of inc that 
   takes one argument, one that takes two (the ignored return value of the first 
   inc and its proper argument), one that takes three, etc. *)

Fixpoint wf As ops := 
  if ops is op :: ops' then args_of op = As /\ wf As ops'
  else True.

Definition wf1 As op ops : wf As (op :: ops) -> args_of op = As := 
  fun pf => match pf with conj a _ => a end.
  
Definition wf2 As op ops : wf As (op :: ops) -> wf As ops :=
  fun pf => match pf with conj _ a => a end.

Definition coerce {As op} (pf : args_of op = As) 
  : cmd As (res_of op) := eq_rect (fun Ts => cmd Ts (res_of op)) (PrimCom op) pf.

Fixpoint wfops_cmd As B ops : wf As ops -> cmd As B :=
  if ops is op :: ops' then fun pf : wf As (op :: ops') =>
    SeqCom (coerce (wf1 pf)) (Lambda _ (wfops_cmd B (wf2 pf)))
  else fun _ => Skip As B.

Definition wfops As (B : Type) := {ops : seq Op & wf As ops}.

Definition mkwfops As (B : Type) ops (pf : wf As ops) : wfops As B :=
  existT (fun ops => wf As ops) ops pf. 

Definition wfops2ops As (B : Type) (ops : wfops As B) := projT1 ops.
Coercion wfops2ops : wfops >-> seq.

Definition wfops2cmd As B (ops : wfops As B) := wfops_cmd B (projT2 ops).
Coercion wfops2cmd : wfops >-> cmd.

Section WfopsApp.
Variables (As : seq Type) (B : Type) (ops1 ops2 : wfops As B).

Lemma wfops_app_proof : wf As (ops1 ++ ops2).
Proof.
case: ops1=> ops pf. 
elim: ops pf=> [pf | op ops' IH pf]=>/=; first by apply:(projT2 ops2).
split; first by apply: (wf1 pf). by apply: (IH (wf2 pf)).
Qed.

Definition wfops_app : wfops As B := mkwfops B wfops_app_proof.

End WfopsApp.

(* sequential composition of trans *)

Section FoldTrans.
Variable (As : seq Type) (B : Type).

Definition coerce_args op (pf : args_of op = As) (av : args As) 
  : args (args_of op) := eq_rect (fun Ts => args Ts) av (Logic.eq_sym pf).

Fixpoint fold_trans' alpha (av : args As) ops : wf As ops -> T :=
  match ops as ops' return wf As ops' -> T with
  | op :: ops' => fun pf => 
      fold_trans' (trans alpha (coerce_args (wf1 pf) av)).1 av (wf2 pf)
  | nil => fun pf => alpha
  end.

Definition fold_trans alpha (av : args As) (ops : wfops As B) :=
  fold_trans' alpha av (projT2 ops).

End FoldTrans.

(* sequential composition of specs *)

Section Bind.
Variables (As : seq Type) (B C : Type).
Variables (e1 : spec As B) (e2 : spec (B :: As) C).

Definition bind_s := (Model.bind_pre e1 e2, Model.bind_post e1 e2).

End Bind.

(* interpretation of syntatic specifications *)

Definition lambda As A B (s : spec As B) :=
  Model.inst_s s (fun_lam (fun aas : args (A :: As) => aas.2)).

Fixpoint cmd_interp As B (e : cmd As B) : spec As B :=
  match e with 
  | Skip As B => (pre_lam (fun (av : args As) i => True), 
                  post_lam (fun (av1 av2 : args As) yy ii mm => ii = mm))
  | Lambda A As B e => lambda A (cmd_interp e)
  | PrimCom op => spec_of op
  | SeqCom As B C e1 e2 => bind_s (cmd_interp e1) (cmd_interp e2)
  end.

Definition cmd2spec As B (e : cmd As B) := cmd_interp e.

Coercion cmd2spec : cmd >-> spec.

Definition wfops2spec As (B : Type) := (@cmd2spec As B \o @wfops2cmd As B).

Coercion wfops2spec : wfops >-> spec.

(* at this point in the file, the related active coercions are: 
[wfops2ops] : wfops >-> seq
[wfops2cmd] : wfops >-> cmd
[wfops2cmd; cmd2spec] : wfops >-> spec
[cmd2spec] : cmd >-> spec

in particular, there are coercions from wfops to sequences of operations,
commands, and specs. *)

(* datatype defns. lifted to cmds *)

Section CmdDefs.
Variables (As : seq Type) (B : Type) (e : cmd As B).

Definition cmd_safe av i := def i /\ i \In (spec1 e av).

Definition cmd_ssafe av1 av2 ii := cmd_safe av1 ii.1 /\ cmd_safe av2 ii.2.

Definition cmd_ssafe_ddef av1 av2 ii : cmd_ssafe av1 av2 ii -> ddef ii.
Proof. by case; case=> A _; case=> C _. Qed.

End CmdDefs.

(* sequential composition lemmas *)

Section SeqComLems.
Variables (As : seq Type) (B C : Type) (e1 : cmd As B) (e2 : cmd (B :: As) C).

Lemma cmd_safe_app av i :
  cmd_safe (SeqCom e1 e2) av i =
  (def i /\
    (i \In spec1 e1 av /\
      (forall y m,
        spec2 e1 av av (y, y) (i, i) (m, m) ->
        def m -> m \In spec1 e2 (y, av)))).
Proof. by rewrite /cmd_safe -toPredE /= /bind_pre !pre_beta. Qed.

Lemma cmd_post_app av1 av2 yy ii mm :
  spec2 (SeqCom e1 e2) av1 av2 yy ii mm =
  (exists yy', exists hh,
    spec2 e1 av1 av2 yy' ii hh /\
    def hh.1 /\ def hh.2 /\
    spec2 e2 (yy'.1, av1) (yy'.2, av2) yy hh mm).
Proof. by rewrite /= /Model.bind_post post_beta. Qed.

End SeqComLems.

Section SeqComLems1.
Variables (B : Type) (op : Op) (e : cmd (res_of op :: args_of op) B).

Lemma cmd_safe_safe av i : cmd_safe (SeqCom (PrimCom op) e) av i -> safe av i.
Proof. by rewrite cmd_safe_app; case=> D; case. Qed.

Lemma cmd_ssafe_ssafe av1 av2 ii : 
  cmd_ssafe (SeqCom (PrimCom op) e) av1 av2 ii -> ssafe av1 av2 ii.
Proof. by case=> C D; split; apply: cmd_safe_safe. Qed.

End SeqComLems1.

Section FoldShapeInv.
Variables (As : seq Type) (B : Type).

Lemma fold_shape_inv aalpha (ops : wfops As B) (av1 av2 : args As) yy ii mm :
  spec2 ops av1 av2 yy ii mm ->
  ii.1 \shape aalpha.1 -> ii.2 \shape aalpha.2 ->
  mm.1 \shape (fold_trans aalpha.1 av1 ops) /\ 
  mm.2 \shape (fold_trans aalpha.2 av2 ops).
Proof.
case: ops=> ops pf =>/=; elim: ops pf aalpha ii mm=> [/= pf aalpha ii mm 
|/= op ops' IH [pf_ pf] aalpha ii mm]; first by rewrite post_beta /= => ->.
rewrite /Model.bind_post post_beta /=; case=> yy' [hh][A][C][D]E F G. 
destruct pf_; rewrite post_beta !fun_beta in E=>/=. 
rewrite /coerce /= /eq_rect in A. 
case: (IH pf ((trans aalpha.1 av1).1, (trans aalpha.2 av2).1) _ _ E)=>//;
by case: (shape_inv A F G). 
Qed.

End FoldShapeInv.

(* a uniquely represented datatype is one for which \shape is a functional
   relation.  note that this definition is independent of how we interpret the
   individual datatype operations *)

Definition UR := forall (alpha : T) h h', 
  h \shape alpha -> h' \shape alpha -> h = h'.

(* SHI data structures are oblivious to logically equivalent sequences of
   operations *)

Section StrongHistoryIndependence.

Definition SHI :=
  forall As B (alpha : T) (ops1 ops2 : wfops As B) (av : args As) yy yy' i m1 m2,
    i \shape alpha -> cmd_safe ops1 av i -> cmd_safe ops2 av i ->
    fold_trans alpha av ops1 = fold_trans alpha av ops2 ->
    spec2 ops1 av av yy (i, i) (m1, m1) -> spec2 ops2 av av yy' (i, i) (m2, m2) ->
    m1 = m2.

Theorem UR_SHI : UR -> SHI.
Proof.
move=> U As B alpha ops1 ops2 av yy yy' i m1 m2 C D E F G H.
have C1 : (i, i).1 \shape (alpha, alpha).1 by [].
apply: (U (fold_trans alpha av ops1)); first by case: (fold_shape_inv G C1).
by rewrite F; case: (fold_shape_inv H C1).
Qed.

End StrongHistoryIndependence.

Section WeakHistoryIndependence.

(* weakly history independent (WHI) data structures are oblivious to logically
   equivalent sequences of operations that are executed from the /initial
   state./ WHI is weaker than SHI, and thus is also implied by unique
   representation. *)

Definition WHI :=
  forall As B (ops1 ops2 : wfops As B) (av : args As) yy yy' i m1 m2,
    i \shape init -> cmd_safe ops1 av i -> cmd_safe ops2 av i ->
    fold_trans init av ops1 = fold_trans init av ops2 ->
    spec2 ops1 av av yy (i, i) (m1, m1) -> spec2 ops2 av av yy' (i, i) (m2, m2) ->
    m1 = m2.

Lemma SHI_WHI : SHI -> WHI.
Proof. 
move=> S As B ops1 ops2 av yy yy' i m1 m2 C D E F G H. 
by apply: (S As B init ops1 ops2 av yy yy' i). 
Qed.

Theorem UR_WHI : UR -> WHI.
Proof. by move=> UR'; apply: (SHI_WHI (UR_SHI UR')). Qed.

End WeakHistoryIndependence.

End DataProp.

Section Local.
Variable DT : datatype.

Definition local := 
  forall (aalpha : d (T DT)) (op : Op DT) (av1 av2 : args (args_of op)) 
  yy jj hh ii mm, 
    ii = jj :++ hh -> jj.1 \shape aalpha.1 -> jj.2 \shape aalpha.2 -> 
    spec2 (spec_of op) av1 av2 yy ii mm ->
    exists jj', mm = jj' :++ hh /\ spec2 (spec_of op) av1 av2 yy jj jj'.

End Local. 

(* defines the product of two arbitrary /local/ datatypes *)

Section DataTypeProd.
Variables (d1 d2 : datatype).
Hypothesis (local1 : local d1) (local2 : local d2).

Definition T2 := (T d1 * T d2)%type.

Definition Op2 := (Op d1 + Op d2)%type.

Definition init2 : T2 := (init d1, init d2).

Definition shape2 (aa : T d1 * T d2) := 
  [Pred i : heap | 
    exists j, exists h, i = j :+ h /\ shape aa.1 j /\ shape aa.2 h].

Definition args_of2 (op2 : Op2) :=
  match op2 with inl op => args_of op
  | inr op => args_of op
  end.

Definition res_of2 (op2 : Op2) :=
  match op2 with inl op => res_of op
  | inr op => res_of op
  end.

Definition spec_of2 (op2 : Op2) : spec (args_of2 op2) (res_of2 op2) :=
  match op2 with inl op => spec_of op
  | inr op => spec_of op
  end.

Definition trans2 op2 (aa : T2) 
  : args (args_of2 op2) -> (T d1 * T d2 * res_of2 op2) :=
  match op2 as op2' return args (args_of2 op2') -> (T d1 * T d2 * res_of2 op2') 
    with 
    | inl op => fun av => (((trans aa.1 av).1, aa.2), (trans aa.1 av).2)
    | inr op => fun av => ((aa.1, (trans aa.2 av).1), (trans aa.2 av).2)
  end.

Lemma shape_inv2 aalpha op2 av1 av2 yy ii mm :
  spec2 (spec_of2 op2) av1 av2 yy ii mm -> 
  shape2 aalpha.1 ii.1 -> shape2 aalpha.2 ii.2 -> 
  shape2 (trans2 aalpha.1 av1).1 mm.1 /\ shape2 (trans2 aalpha.2 av2).1 mm.2.
Proof.
move=> /= A [j1][h1][B][C D] [j2][h2][E][F G].
have Eq : ii = (j1, j2) :++ (h1, h2). 
by case: ii A B E; rewrite /plus2 /= => i1 i2 _ -> ->.
elim: op2 av1 av2 yy A =>/= op av1 av2 yy A.
have C0 : (j1, j1).1 \shape (aalpha.1.1, aalpha.2.1).1 by [].
case: (local1 Eq C0 F A)=> [[j1' j2']]; rewrite /plus2 /= => [[-> I]].
case: (shape_inv I C0 F) =>/= J K. split.
by exists j1'; exists h1; split. by exists j2'; exists h2; split.
have D0 : (h1, h1).1 \shape (aalpha.1.2, aalpha.2.2).1 by [].
rewrite unC2 in Eq; case: (local2 Eq D0 G A)=> [[h1' h2']]. 
rewrite /plus2 /= => [[-> I]].
case: (shape_inv I D0 G) =>/= J K. split.
by exists j1; exists h1'; split; [rewrite unC|].
by exists j2; exists h2'; split; [rewrite unC|].
Qed.

Definition DataType2 := @Datatype  T2 _ init2 shape2 _ _ _ _ shape_inv2.

End DataTypeProd.

End DataType.

