Definition empty_on_path o p :=
forall lvl, locate_node_in_tr o lvl p = None.
Fixpoint diverge_at_level (p p' : path) (lvl : nat) :=
match lvl with
| 0%nat => False
| S lvl' =>
match p, p' with
| [], [] => False
| (true :: p_tail), (true :: p'_tail) =>
diverge_at_level p_tail p'_tail lvl'
| (false :: p_tail), (false :: p'_tail) =>
diverge_at_level p_tail p'_tail lvl'
| _, _ => True
end
end.
(* off_path id v o p p' means that (id, v) lies on p' and not on p *)
Definition off_path id v o p p' :=
exists lvl,
diverge_at_level p p' lvl /\
match lookup_tree o lvl p' with
| Some (Some bucket) => In (Block id v) bucket
| _ => False
end.

(* Specifications: *)
Lemma lookup_tree_lookup_path_oram_invert o : forall bkt p,
In bkt (lookup_path_oram o p) -> exists lvl,
lookup_tree o lvl p = Some (Some bkt).
Lemma empty_true data o1 o2 p :
empty_on_path (node data o1 o2) (true :: p) ->
empty_on_path o1 p.
Lemma empty_false data o1 o2 p :
empty_on_path (node data o1 o2) (false :: p) ->
empty_on_path o2 p.
Lemma off_path_true id v data o1 o2 p p' :
off_path id v o1 p p' ->
off_path id v (node data o1 o2) (true :: p) (true :: p').
Lemma off_path_false id v data o1 o2 p p' :
off_path id v o2 p p' ->
off_path id v (node data o1 o2) (false :: p) (false :: p').
Lemma empty_off_path id v o : forall p p',
blk_in_p id v o p' ->
empty_on_path o p ->
off_path id v o p p'.
Lemma lookup_tree_update_tree_diverge {X} (o : tree X) : forall
(lvl lvl' : nat) (p p' : path) (x : X),
diverge_at_level p' p lvl ->
lookup_tree (update_tree o lvl' x p') lvl p =
lookup_tree o lvl p.
Lemma off_path_blocks_selection id v s p p' lvl :
off_path id v (state_oram s) p p' ->
off_path id v (state_oram (blocks_selection p lvl s)) p p'.
Lemma iterate_right_ind {X} (P : X -> Prop) (x : X) f p :
P x ->
(forall x n, P x -> P (f p n x)) ->
forall steps start, P (iterate_right start p f steps x).
Lemma iterate_right_inversion {X} (P : X -> Prop) (x : X) f p :
(forall x n, P (f p n x) -> P x) ->
forall steps start, P (iterate_right start p f steps x) ->
P x.
Lemma lookup_tree_lookup_path_oram o : forall bkt lvl p,
lookup_tree o lvl p = Some (Some bkt) ->
In bkt (lookup_path_oram o p).
Lemma off_path_blk_in_p id v o p p' :
off_path id v o p p' ->
blk_in_p id v o p'.
Lemma get_post_wb_st_state_state : forall (id : block_id) (v : nat) (s : state) (p : path),
well_formed s ->
length p = LOP ->
empty_on_path (state_oram s) p ->
blk_in_state id v s ->
blk_in_state id v (get_post_wb_st s p).
Lemma up_oram_tr_inversion id v o : forall lvl delta p p',
blk_in_p id v
(up_oram_tr o lvl delta p) p' ->
blk_in_p id v o p' \/
In (Block id v) delta.
Lemma distribute_via_get_post_wb_st_undef : forall (id : block_id) (s : state) (p : path),
well_formed s ->
length p = LOP ->
empty_on_path (state_oram s) p ->
undef id s ->
undef id (get_post_wb_st s p).
Lemma NoDup_path_oram : forall o p,
NoDup (List.map block_blockid (get_all_blks_tree o)) ->
NoDup (List.map block_blockid (concat (lookup_path_oram o p))).
Lemma get_all_blks_tree_clear_path_weaken : forall o id p,
In id (List.map block_blockid (get_all_blks_tree (clear_path o p))) ->
In id (List.map block_blockid (get_all_blks_tree o)).
Lemma NoDup_clear_path : forall o p,
NoDup (List.map block_blockid (get_all_blks_tree o)) ->
NoDup (List.map block_blockid (get_all_blks_tree (clear_path o p))).
Lemma clear_path_p_b_tree : forall o n p,
is_p_b_tr o n ->
is_p_b_tr (clear_path o p) n.
Lemma on_path_not_off_path: forall o p id,
NoDup (List.map block_blockid (get_all_blks_tree o)) ->
In id (List.map block_blockid (concat (lookup_path_oram o p))) ->
~ In id (List.map block_blockid (get_all_blks_tree (clear_path o p))).
Lemma disjoint_list_dlt : forall o p h,
disjoint_list (List.map block_blockid (get_all_blks_tree o))
(List.map block_blockid h) ->
NoDup (List.map block_blockid (get_all_blks_tree o)) ->
disjoint_list (List.map block_blockid (get_all_blks_tree (clear_path o p)))
(List.map block_blockid (concat (lookup_path_oram o p) ++ h)).
Lemma disjoint_list_sub : forall {A} (l1 l2 l3: list A),
(forall x, In x l1 -> In x l2) ->
disjoint_list l2 l3 ->
disjoint_list l1 l3.
Lemma lookup_off_path : forall o id p p',
NoDup (List.map block_blockid (get_all_blks_tree o)) ->
In id (List.map block_blockid (get_all_blks_tree (clear_path o p))) ->
In id (List.map block_blockid (concat (lookup_path_oram o p'))) ->
In id (List.map block_blockid (concat (lookup_path_oram (clear_path o p) p'))).
Lemma rd_op_wf : forall (id : block_id) (m : position_map) (h : stash) (o : oram) (p p_new : path),
lookup_dict (makeBoolList false LOP) id m = p ->
well_formed (State m h o) -> length p_new = LOP ->
well_formed
{|
state_position_map := update_dict id p_new m;
state_stash := (concat (lookup_path_oram o p) ++ h)%list;
state_oram := clear_path o p
|}.
Lemma not_in_removed : forall l id,
~ In id
(List.map block_blockid
(remove_list (fun blk : block => block_blockid blk =? id)
l)).
Lemma NoDup_remove_list: forall l id,
NoDup (List.map block_blockid l) ->
NoDup
(List.map block_blockid
(remove_list (fun blk : block => block_blockid blk =? id)
l)).
Lemma wr_op_wf : forall (id : block_id) (v : nat) (m : position_map) (h : stash) (o : oram) (p p_new : path),
well_formed (State m h o) -> length p_new = LOP ->
lookup_dict (makeBoolList false LOP) id m = p ->
well_formed
{|
state_position_map := update_dict id p_new m;
state_stash :=
{| block_blockid := id; block_payload := v |}
:: remove_list (fun blk : block => block_blockid blk =? id)
(concat (lookup_path_oram o p) ++ h);
state_oram := clear_path o p
|}.
Lemma get_pre_wb_st_wf : forall (id : block_id) (op : operation) (s : state) (p p_new : path),
well_formed s ->
length p_new = LOP ->
lookup_dict (makeBoolList false LOP) id (state_position_map s) = p ->
well_formed (get_pre_wb_st id op s p p_new).
Lemma get_post_wb_st_wf : forall (s : state) (p : path),
well_formed s ->
length p = LOP ->
well_formed (get_post_wb_st s p).
Lemma zero_sum_stsh_tr_Wr
(s : state) (id : block_id) (v : nat) (p p_new : path):
well_formed s ->
length p = LOP ->
length p_new = LOP ->
blk_in_state id v
(get_post_wb_st
(get_pre_wb_st id (Write v)
s
(calc_path id s) p_new) p).
Lemma zero_sum_stsh_tr_Rd_rev :
forall (id : block_id) (v : nat) (s : state) (p p_new : path),
well_formed s ->
length p = LOP ->
length p_new = LOP ->
blk_in_state id v s  ->
blk_in_state id v (get_post_wb_st
(get_pre_wb_st id Read s
(calc_path id s) p_new) p).
Lemma locate_node_in_tr_clear_path o : forall p lvl,
locate_node_in_tr (clear_path o p) lvl p = None.
Lemma read_access_state_state :
forall (id id' : block_id) (v : nat) (s : state) (p_new : path),
well_formed s ->
length p_new = LOP ->
blk_in_state id v s  ->
blk_in_state id v (get_post_wb_st
(get_pre_wb_st id' Read s
(calc_path id' s) p_new) (calc_path id' s)).
Lemma write_access_state_state :
forall (id id' : block_id) (v v': nat) (s : state) (p_new : path),
id <> id' ->
well_formed s ->
length p_new = LOP ->
blk_in_state id v s  ->
blk_in_state id v (get_post_wb_st
(get_pre_wb_st id' (Write v') s
(calc_path id' s) p_new) (calc_path id' s)).
Lemma zero_sum_stsh_tr_Rd_rev_undef :
forall (id id' : block_id) (s : state) (p_new : path),
well_formed s ->
length p_new = LOP ->
undef id s  ->
undef id (get_post_wb_st
(get_pre_wb_st id' Read s
(calc_path id' s) p_new) (calc_path id' s)).
Lemma zero_sum_stsh_tr_Wr_rev_undef :
forall (id id' : block_id) (v : nat) (s : state) (p_new : path),
well_formed s ->
id <> id' ->
length p_new = LOP ->
undef id' s ->
undef id' (get_post_wb_st
(get_pre_wb_st id (Write v) s
(calc_path id s) p_new) (calc_path id s)).
Lemma lookup_ret_data_block_in_list (id : block_id) (v : nat) (l : list block) :
NoDup (List.map block_blockid l) ->
In (Block id v) l -> lookup_ret_data id l = v.
Lemma zero_sum_stsh_tr_Rd (id : block_id) (v : nat) (m : position_map) (h : stash) (o : oram) :
well_formed (State m h o) ->
blk_in_state id v (State m h o) ->
get_ret_data id h (calc_path id (State m h o)) o = v.
Lemma read_access_just_wf (id : block_id) :
state_plift well_formed well_formed (fun _ => True) (read_access id).
Lemma lookup_ret_data_0 k l :
(forall v, ~ In {| block_blockid := k; block_payload := v |} l) ->
lookup_ret_data k l = 0%nat.
Lemma get_ret_data_0 k s :
well_formed s ->
undef k s ->
get_ret_data k (state_stash s)
(lookup_dict (makeBoolList false LOP) k (state_position_map s))
(state_oram s) = 0%nat.
Lemma read_access_undef_0 k :
state_plift
(fun st => well_formed st /\ undef k st)
well_formed
(has_value 0)
(read_access k).
Lemma read_access_wf (id : block_id)(v : nat) :
state_plift (fun st => well_formed st /\ blk_in_state id v st) (fun st => well_formed st /\ blk_in_state id v st) (has_value v) (read_access id).
Lemma write_access_just_wf (id : block_id) (v : nat) :
state_plift well_formed well_formed (fun _ => True)
(write_access id v).
Lemma write_access_wf (id : block_id) (v : nat) :
state_plift (fun st => well_formed st) (fun st => well_formed st /\ blk_in_state id v st) (fun _ => True) (write_access id v).
Lemma write_and_read_access_lift (id : block_id)(v : nat):
state_plift (well_formed) well_formed (has_value v)
(write_and_read_access id v).
Lemma read_access_state id v id' :
state_plift
(fun st => well_formed st /\ blk_in_state id v st)
(fun st => well_formed st /\ blk_in_state id v st)
(fun _ => True)
(read_access id').
Lemma read_access_undef id id' :
state_plift
(fun s => well_formed s /\ undef id s)
(fun s : state => well_formed s /\ undef id s)
(fun _ => True)
(read_access id').
Lemma write_access_undef id id' v :
id <> id' ->
state_plift
(fun s : state => well_formed s /\ undef id' s)
(fun s : state => well_formed s /\ undef id' s)
(fun _ => True) (write_access id v).
Lemma extract_payload (id : block_id) (v : nat) (s : state) :
plift (fun '(x, s') => has_value v x /\ well_formed s') (write_and_read_access id v s) ->
get_payload (write_and_read_access id v s) = v.
Theorem PathORAM_simulates_RAM_idx_eq (i : block_id) (v : nat) (s : state) :
well_formed s ->
get_payload(write_and_read_access i v s) = v.
Lemma write_access_neq : forall i k v v',
i <> k ->
state_plift (fun s : state => well_formed s /\ blk_in_state i v' s)
(fun st : state => well_formed st /\ blk_in_state i v' st)
(fun _ =>  True)
(write_access k v).
Theorem PathORAM_simulates_RAM_idx_neq :
forall (i k : block_id) (v v' : nat),
i <> k ->
state_plift
(fun s => well_formed s /\ blk_in_state i v' s)
(fun s => well_formed s /\ blk_in_state i v' s)
(has_value v')
(_ <- write_access k v ;; read_access i).