Commit cd95bfe1 authored by Jean-Christophe Filliâtre's avatar Jean-Christophe Filliâtre
Browse files

fm 2012, pbm 3 (in progress)

parent 804f893a
...@@ -16,26 +16,22 @@ module Memory ...@@ -16,26 +16,22 @@ module Memory
type node = { left: pointer; right: pointer; data: int; } type node = { left: pointer; right: pointer; data: int; }
type memory = map pointer node type memory = map pointer node
function get_left (m: memory) (p: pointer) : pointer = (get m p).left
function get_right (m: memory) (p: pointer) : pointer = (get m p).right
function get_data (m: memory) (p: pointer) : int = (get m p).data
(* the global variable mem contains the current state of the memory *) (* the global variable mem contains the current state of the memory *)
val mem: ref memory val mem: ref memory
(* accessor functions to ensure safety i.e. no null pointer dereference *) (* accessor functions to ensure safety i.e. no null pointer dereference *)
let get_left (p: pointer) = let get_left (p: pointer) =
requires { p <> null } requires { p <> null }
ensures { result = (get !mem p).left } ensures { result = !mem[p].left }
(get !mem p).left !mem[p].left
let get_right (p: pointer) = let get_right (p: pointer) =
requires { p <> null } requires { p <> null }
ensures { result = (get !mem p).right } ensures { result = !mem[p].right }
(get !mem p).right !mem[p].right
let get_data (p: pointer) = let get_data (p: pointer) =
requires { p <> null } requires { p <> null }
ensures { result = (get !mem p).data } ensures { result = !mem[p].data }
(get !mem p).data !mem[p].data
end end
...@@ -44,7 +40,6 @@ module Treedel ...@@ -44,7 +40,6 @@ module Treedel
use import Memory use import Memory
use import bintree.Tree use import bintree.Tree
use import bintree.Inorder use import bintree.Inorder
use import bintree.Zipper
use import list.Distinct use import list.Distinct
(* there is a binary tree t rooted at p in memory m *) (* there is a binary tree t rooted at p in memory m *)
...@@ -52,25 +47,27 @@ module Treedel ...@@ -52,25 +47,27 @@ module Treedel
| leaf: forall m: memory. tree m null Empty | leaf: forall m: memory. tree m null Empty
| node: forall m: memory, p: pointer, l r: tree pointer. | node: forall m: memory, p: pointer, l r: tree pointer.
p <> null -> p <> null ->
tree m (get_left m p) l -> tree m m[p].left l ->
tree m (get_right m p) r -> tree m m[p].right r ->
tree m p (Node l p r) tree m p (Node l p r)
(* (* degenerated zipper for a left descent *)
lemma frame: type zipper 'a =
forall m1: memory, p: pointer. | Top
let n = get m1 p in | Left (zipper 'a) 'a (tree 'a)
let m2 = set m1 p { n with left = (get m1 n.left).right } in
forall q: pointer. tree m1 q -> tree m2 q function zip (t: tree 'a) (z: zipper 'a) : tree 'a = match z with
| Top -> t
| Left z x r -> zip (Node t x r) z
end
function leaves (m: memory) (p: pointer) : list pointer lemma inorder_zip:
forall z "induction": zipper 'a, x: 'a, l r: tree 'a.
inorder (zip (Node l x r) z) = inorder l ++ Cons x (inorder (zip r z))
axiom leaves_null: forall m: memory. leaves m null = Nil lemma zip_bottom_left:
axiom leaves_node: forall x: 'a, r: tree 'a, z: zipper 'a.
forall m: memory, p: pointer. tree m p -> p <> null -> inorder (zip (Node Empty x r) z) = Cons x (inorder (zip r z))
leaves m p =
leaves m (get_left m p) ++ (Cons p Nil) ++ leaves m (get_right m p)
*)
let left (t: tree pointer) = let left (t: tree pointer) =
requires { t <> Empty } requires { t <> Empty }
...@@ -82,45 +79,55 @@ module Treedel ...@@ -82,45 +79,55 @@ module Treedel
ensures { match t with Empty -> false | Node _ _ r -> result = r end } ensures { match t with Empty -> false | Node _ _ r -> result = r end }
match t with Empty -> absurd | Node _ _ r -> r end match t with Empty -> absurd | Node _ _ r -> r end
lemma main_lemma:
forall m: memory, t pp p: pointer, r: tree pointer, z: zipper pointer.
let it = zip (Node Empty p r) z in
tree m t it ->
distinct (inorder it) ->
m[pp].left = p ->
let m' = m[pp <- { m[pp] with left = m[p].right }] in
tree m' t (zip r z)
(* specification is as follows: if t is a tree and its list of pointers (* specification is as follows: if t is a tree and its list of pointers
is x::l then, at the end of execution, its list is l and m = x.data *) is x::l then, at the end of execution, its list is l and m = x.data *)
let search_tree_delete_min let search_tree_delete_min
(t: pointer) (ghost x: pointer) (ghost gt: tree pointer) = (t: pointer) (ghost it: tree pointer) (ghost ot: ref (tree pointer)) =
requires { t <> null } requires { t <> null }
requires { tree !mem t gt } requires { tree !mem t it }
requires { match inorder gt with requires { distinct (inorder it) }
ensures { let (t, m) = result in tree !mem t !ot /\
match inorder it with
| Nil -> false | Nil -> false
| Cons p l -> p = x /\ distinct (Cons p l) end } | Cons p l -> m = !mem[p].data /\ inorder !ot = l end }
(*
ensures { let (t, m) = result in
tree !mem t /\ leaves !mem t = l /\ m = get_data !mem x }
*)
let p = ref (get_left t) in let p = ref (get_left t) in
if !p = null then begin if !p = null then begin
let m = get_data t in let m = get_data t in
let tt = get_right t in let tt = get_right t in
ghost match it with Empty -> absurd
| Node l _ r -> assert { l = Empty }; ot := r end;
(tt, m) (tt, m)
end else begin end else begin
let pp = ref t in let pp = ref t in
let tt = ref (get_left !p) in let tt = ref (get_left !p) in
let ghost zipper = ref (Left Top t (right gt)) in let ghost zipper = ref (Left Top t (right it)) in
let ghost subtree = ref (left gt) in let ghost subtree = ref (left it) in
while !tt <> null do while !tt <> null do
invariant { invariant { !pp <> null /\ !mem[!pp].left = !p /\
(* tree !mem !pp /\ !p <> null /\ !mem[!p].left = !tt /\
leaves !mem t = leaves !mem !pp ++ !suffix /\ *) tree !mem !p !subtree /\
!pp <> null /\ get_left !mem !pp = !p /\ zip !subtree !zipper = it }
!p <> null /\ get_left !mem !p = !tt } ghost match !subtree with
zipper := Left !zipper !p (right !subtree); | Empty -> absurd
subtree := left !subtree; | Node l _ r -> zipper := Left !zipper !p r; subtree := l end;
pp := !p; pp := !p;
p := !tt; p := !tt;
tt := get_left !p tt := get_left !p
done; done;
assert { !p = x };
let m = get_data !p in let m = get_data !p in
tt := get_right !p; tt := get_right !p;
mem := set !mem !pp { (get !mem !pp) with left = !tt }; mem := set !mem !pp { !mem[!pp] with left = !tt };
ghost match !subtree with Empty -> absurd
| Node l _ r -> assert { l = Empty }; ot := zip r !zipper end;
(t, m) (t, m)
end end
......
This diff is collapsed.
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment