Commit 68d0207b authored by Martin Clochard's avatar Martin Clochard
Browse files

AVL example: cleanup+alpha-renaming

parent 32b418b9
......@@ -931,7 +931,7 @@
memlimit="1000"
obsolete="false"
archived="false">
<result status="valid" time="1.53"/>
<result status="valid" time="1.80"/>
</proof>
</goal>
<goal
......@@ -992,7 +992,7 @@
memlimit="1000"
obsolete="false"
archived="false">
<result status="valid" time="1.23"/>
<result status="valid" time="0.93"/>
</proof>
</goal>
<goal
......
......@@ -130,8 +130,8 @@ module AssocSorted
let lemma model_cut (k:key) (l r:list (t 'a)) : unit
requires { S.increasing r }
requires { S.increasing l }
requires { S.majorate k l }
requires { S.minorate k r }
requires { S.upper_bound k l }
requires { S.lower_bound k r }
ensures { forall k2. eq k k2 -> model (l++r) k2 = None }
ensures { forall k2. lt k k2 -> model (l++r) k2 = model r k2 }
ensures { forall k2. le k2 k -> model r k2 = None }
......@@ -160,8 +160,8 @@ module AssocSorted
let lemma model_split (d:t 'a) (l r:list (t 'a)) : unit
requires { S.increasing l }
requires { S.increasing r }
requires { S.majorate d.key l }
requires { S.minorate d.key r }
requires { S.upper_bound d.key l }
requires { S.lower_bound d.key r }
ensures { forall k2. eq d.key k2 -> model (l++Cons d r) k2 = Some d }
ensures { forall k2. lt d.key k2 -> model (l++Cons d r) k2 = model r k2 }
ensures { forall k2. le k2 d.key -> model r k2 = None }
......
This diff is collapsed.
This source diff could not be displayed because it is too large. You can view the blob instead.
......@@ -43,20 +43,20 @@ module MapBase
type m = unit
type t = unit
constant zero : unit = ()
function add (x y:unit) : unit = ()
function op (x y:unit) : unit = ()
let lemma neutral_ (x:unit) : unit
ensures { add zero x = x = add x zero }
ensures { op zero x = x = op x zero }
= match x with _ -> () end
clone export monoid.Monoid with type t = m,
constant zero = zero,function add = add,lemma assoc,lemma neutral
constant zero = zero,function op = op,lemma assoc,lemma neutral
clone export monoid.MonoidListDef with type M.t = m,
constant M.zero = zero,function M.add = add,goal M.assoc,goal M.neutral
constant M.zero = zero,function M.op = op,goal M.assoc,goal M.neutral
function m (x:'a) : 'a = x
predicate c (x:'a) = true
let zero () : unit
ensures { result = () }
= ()
let add (x y:unit) : unit
let op (x y:unit) : unit
ensures { result = () }
= ()
end
......@@ -67,18 +67,21 @@ module MapBase
(* Correction of a selector with respect to a list:
The list is sorted. *)
predicate selector_correct (s:K.t) (l:list (D.m 'b)) =
predicate selection_possible (s:K.t) (l:list (D.m 'b)) =
A.S.increasing l /\ K.c s
predicate selected (s:K.t) (e:position (D.m 'b)) (l:list (D.m 'b)) =
(A.S.majorate s.K.m e.left /\ A.S.minorate s.K.m e.right /\
A.S.increasing e.left /\ A.S.increasing e.right /\
predicate selected (s:K.t) (e:split (D.m 'b)) (l:list (D.m 'b)) =
(A.S.upper_bound s.K.m e.left /\ A.S.lower_bound s.K.m e.right /\
match e.middle with
| None -> true
| Some d2 -> CO.eq s.K.m d2.key
end) /\ rebuild e = l /\ selector_correct s l
end)
(* Strictly speaking, not necessary because derivable from the context,
but makes easier to write some lemmas. *)
/\ A.S.increasing e.left /\ A.S.increasing e.right /\
rebuild e = l /\ selection_possible s l
predicate selected_sem (s:K.t) (e:position (D.m 'b)) (l:list (D.m 'b)) =
predicate selected_sem (s:K.t) (e:split (D.m 'b)) (l:list (D.m 'b)) =
forall k:K.m. (CO.lt k s.K.m -> A.model l k = A.model e.left k) /\
(CO.lt s.K.m k -> A.model l k = A.model e.right k) /\
(CO.eq k s.K.m -> A.model l k = e.middle) /\
......@@ -86,7 +89,7 @@ module MapBase
(CO.le k s.K.m -> A.model e.right k = None)
let lemma selected_sem (s:K.t)
(e:position (D.m 'b)) (l:list (D.m 'b)) : unit
(e:split (D.m 'b)) (l:list (D.m 'b)) : unit
requires { selected s e l }
ensures { selected_sem s e l }
= match e.middle with
......@@ -94,22 +97,21 @@ module MapBase
| Some dm -> A.model_split dm e.left e.right
end
let selected_way (ghost p:type_params 'a 'b)
let selected_part (ghost p:type_params 'a 'b)
(ghost base:list (D.m 'b))
(ghost llis:list (D.m 'b))
(ghost rlis:list (D.m 'b))
(s:K.t) (l:'e) (d:D.t 'a 'b) (r:'f) : way_base K.t
(s:K.t) (l:'e) (d:D.t 'a 'b) (r:'f) : part_base K.t
requires { p.D.mp.inv d }
requires { base = llis ++ Cons (p.D.mp.mdl d) rlis }
requires { selector_correct s base }
(* A selected position can be found by following the given way. *)
requires { selection_possible s base }
returns { Here -> let e2 = { left = llis;
middle = Some (p.D.mp.mdl d);
right = rlis } in selected s e2 base
| Left sl -> selector_correct sl llis /\
| Left sl -> selection_possible sl llis /\
forall e. selected sl e llis ->
selected s (right_extend e (p.D.mp.mdl d) rlis) base
| Right sr -> selector_correct sr rlis /\
| Right sr -> selection_possible sr rlis /\
forall e. selected sr e rlis ->
selected s (left_extend llis (p.D.mp.mdl d) e) base }
= let kd = get_key p d in
......@@ -122,10 +124,10 @@ module MapBase
(* Full clone of the avl module. *)
clone avl.AVL as Sel with type selector = selector,
predicate selector_correct = selector_correct,
predicate selection_possible = selection_possible,
predicate selected = selected,
val selected_way = selected_way,
goal selector_correct_empty,
val selected_part = selected_part,
goal selection_empty,
constant balancing = balancing,
goal balancing_positive,
type D.t = D.t,
......@@ -138,14 +140,14 @@ module MapBase
function M.m = M.m,
predicate M.c = M.c,
constant M.zero = M.zero,
function M.add = M.add,
function M.op = M.op,
goal M.assoc,
goal M.neutral,
function M.sum = M.sum,
goal M.sum_def_nil,
goal M.sum_def_cons,
val M.zero = M.zero,
val M.add = M.add
val M.op = M.op
type t 'a 'b = Sel.t 'a 'b
......@@ -300,10 +302,10 @@ module MapBase
| Some d -> t.dprm.inv d /\ t.m.card > 0 /\ let dm = t.dprm.mdl d in
CO.eq dm.key k.K.m /\ (forall k2. CO.eq k.K.m k2 ->
t.m.func k2 = Some dm) && t.m.func k.K.m = Some dm = t.m.func dm.key }
= let r = Sel.default_position () in
= let r = Sel.default_split () in
Sel.get r k t
let add (d:D.t 'a 'b) (t:t 'a 'b) : t 'a 'b
let insert (d:D.t 'a 'b) (t:t 'a 'b) : t 'a 'b
requires { c t /\ t.dprm.inv d }
ensures { c result /\ result.prm = t.prm }
ensures { let dm = t.dprm.mdl d in
......@@ -313,9 +315,9 @@ module MapBase
(forall k:K.m. (CO.eq k dm.key -> result.m.func k = Some dm) /\
(not CO.eq k dm.key -> result.m.func k = t.m.func k)) &&
result.m.func dm.key = Some dm }
= let r = Sel.default_position () in
= let r = Sel.default_split () in
let k = get_key t.prm d in
Sel.add r k d t
Sel.insert r k d t
let remove (k:K.t) (t:t 'a 'b) : t 'a 'b
requires { c t /\ K.c k }
......@@ -326,7 +328,7 @@ module MapBase
(forall k2:K.m. (CO.eq k2 k.K.m -> result.m.func k2 = None) /\
(not CO.eq k2 k.K.m -> result.m.func k2 = t.m.func k2)) &&
result.m.func k.K.m = None }
= let r = Sel.default_position () in
= let r = Sel.default_split () in
Sel.remove r k t
let split (k:K.t) (t:t 'a 'b) : (t 'a 'b,option (D.t 'a 'b),t 'a 'b)
......@@ -348,10 +350,12 @@ module MapBase
(forall k2:K.m. CO.le k.K.m k2 -> lf.m.func k2 = None) /\
(forall k2:K.m. CO.lt k.K.m k2 -> rg.m.func k2 = t.m.func k2) /\
(forall k2:K.m. CO.le k2 k.K.m -> rg.m.func k2 = None) }
= let r = Sel.default_position () in
= let r = Sel.default_split () in
Sel.split r k t
(* Internal, but makes set-theoretic routines easier. *)
(* Extension: set-theoretic-like routines. *)
(* Internal, but makes those routines easier. *)
let view (t:t 'a 'b) : Sel.view 'a 'b
requires { c t }
......@@ -660,7 +664,8 @@ module Map
t.m.func k.K.m = None &&
result.m.func k.K.m = Some vm }
ensures { result.m.card = 1 + t.m.card }
= MB.add_min (k,v) t
= assert { t.prm.D.mp.mdl (k,v) = (K.m k,t.prm.mdl v) };
MB.add_min (k,v) t
let add_max (t:t 'a 'b) (k:K.t) (v:'a) : t 'a 'b
requires { c t /\ K.c k /\ t.prm.inv v }
......@@ -671,7 +676,8 @@ module Map
(CO.eq k.K.m k2 -> result.m.func k2 = Some vm) /\
(not CO.eq k2 k.K.m -> result.m.func k2 = t.m.func k2) }
ensures { result.m.card = 1 + t.m.card }
= MB.add_max t (k,v)
= assert { t.prm.D.mp.mdl (k,v) = (K.m k,t.prm.mdl v) };
MB.add_max t (k,v)
let concat (l r:t 'a 'b) : t 'a 'b
requires { c l /\ c r /\ l.prm = r.prm }
......@@ -703,7 +709,7 @@ module Map
| Some (_,v) -> Some v
end
let add (k:K.t) (v:'a) (t:t 'a 'b) : t 'a 'b
let insert (k:K.t) (v:'a) (t:t 'a 'b) : t 'a 'b
requires { c t /\ K.c k /\ t.prm.inv v }
ensures { c result /\ result.prm = t.prm }
ensures { let vm = t.prm.mdl v in result.m.card >= t.m.card /\
......@@ -714,7 +720,7 @@ module Map
(not CO.eq k2 k.K.m -> result.m.func k2 = t.m.func k2)) &&
result.m.func k.K.m = Some vm }
= let d = (k,v) in
let res = MB.add (k,v) t in
let res = MB.insert (k,v) t in
assert { t.MB.dprm.mdl d = (k.K.m,t.prm.mdl v) };
res
......@@ -922,7 +928,7 @@ module Set
(t.m.set k2 -> result.m.set k2) /\
(not CO.eq k2 k.K.m -> result.m.set k2 -> t.m.set k2)) &&
result.m.set k.K.m }
= MB.add k t
= MB.insert k t
let remove (k:K.t) (t:t) : t
requires { c t /\ K.c k }
......@@ -957,6 +963,8 @@ module Set
match o with None -> false | _ -> true end end in
(lf,o,rg)
(* Extension: set-theoretic routines. *)
let union (a b:t) : t
requires { c a /\ c b }
ensures { c result }
......
......@@ -4,10 +4,10 @@ module Monoid
type t
constant zero : t
function add (a b:t) : t
function op (a b:t) : t
axiom assoc : forall a b c:t. add a (add b c) = add (add a b) c
axiom neutral : forall x:t. add x zero = x = add zero x
axiom assoc : forall a b c:t. op a (op b c) = op (op a b) c
axiom neutral : forall x:t. op x zero = x = op zero x
end
......@@ -21,10 +21,10 @@ module MonoidList
function sum (f:'a -> t) (l:list 'a) : t
axiom sum_def_nil : forall f:'a -> t. sum f Nil = zero
axiom sum_def_cons : forall f:'a -> t,x,q.
sum f (Cons x q) = add (f x) (sum f q)
sum f (Cons x q) = op (f x) (sum f q)
let rec lemma sum_append (f:'a -> t) (l r:list 'a) : unit
ensures { sum f (l ++ r) = add (sum f l) (sum f r) }
ensures { sum f (l ++ r) = op (sum f l) (sum f r) }
variant { l }
= match l with Cons _ q -> sum_append f q r | _ -> () end
......@@ -37,14 +37,14 @@ module MonoidListDef
namespace M
type t
constant zero : t
function add (a b:t) : t
function op (a b:t) : t
end
function sum (f:'a -> M.t) (l:list 'a) : M.t = match l with
| Nil -> M.zero
| Cons x q -> M.add (f x) (sum f q)
| Cons x q -> M.op (f x) (sum f q)
end
clone export MonoidList with type M.t = M.t,constant M.zero = M.zero,
function M.add = M.add,function sum = sum,
function M.op = M.op,function sum = sum,
goal sum_def_nil,goal sum_def_cons
end
......@@ -58,9 +58,9 @@ module ComputableMonoid
val zero () : t
ensures { c result /\ result.m = zero }
val add (a b:t) : t
val op (a b:t) : t
requires { c a /\ c b }
ensures { c result /\ result.m = add a.m b.m }
ensures { c result /\ result.m = op a.m b.m }
end
......@@ -30,7 +30,7 @@ module Heap
type m = option K.m
type t = option K.t
constant zero : m = None
function add (x y:m) : m = match x with
function op (x y:m) : m = match x with
| None -> y
| Some a -> match y with
| None -> x
......@@ -40,7 +40,7 @@ module Heap
end
end
let lemma assoc_m (x y z:m) : unit
ensures { add x (add y z) = add (add x y) z }
ensures { op x (op y z) = op (op x y) z }
= match x , y , z with
| None , _ , _ -> assert { true }
| _ , None , _ -> assert { true }
......@@ -48,20 +48,20 @@ module Heap
| _ -> ()
end
let lemma neutral_m (x:m) : unit
ensures { add x zero = x = add zero x }
ensures { op x zero = x = op zero x }
= match x with None -> () | _ -> assert { true } end
clone export monoid.Monoid with type t = m,
constant zero = zero,function add = add,lemma assoc,lemma neutral
constant zero = zero,function op = op,lemma assoc,lemma neutral
clone export monoid.MonoidListDef with type M.t = m,
constant M.zero = zero,function M.add = add,goal M.assoc,goal M.neutral
constant M.zero = zero,function M.op = op,goal M.assoc,goal M.neutral
function m (x:t) : m = match x with None -> None | Some x -> Some x.K.m end
predicate c (x:t) = match x with None -> true | Some x -> K.c x end
let zero () : t
ensures { result = None }
= None
let add (x y:t) : t
let op (x y:t) : t
requires { c x /\ c y }
ensures { result.m = add x.m y.m }
ensures { result.m = op x.m y.m }
ensures { c result }
= match x with
| None -> y
......@@ -75,7 +75,8 @@ module Heap
end
namespace D
(* ARGHH ! *)
(* Axiomatized to avoid an harmful behavior happening when
inlining meet higher-order. *)
function measure (d:D.m 'b) : M.m
axiom measure_def : forall d:D.m 'b. measure d = Some d.key
let measure (ghost p:type_params 'a 'b) (d:D.t 'a 'b) : M.t
......@@ -91,40 +92,40 @@ module Heap
(* Correction of a selector with respect to an avl:
the avl list is non-empty. *)
predicate selector_correct 'e (l:list 'g) = l <> Nil
predicate selection_possible 'e (l:list 'g) = l <> Nil
predicate selected 'e (e:position (D.m 'b)) (l:list (D.m 'b)) =
predicate selected 'e (e:split (D.m 'b)) (l:list (D.m 'b)) =
match e.middle with
| None -> false
| Some d -> S.minorate d.key e.left /\ S.minorate d.key e.right
| Some d -> S.lower_bound d.key e.left /\ S.lower_bound d.key e.right
end /\ rebuild e = l
let rec lemma monoid_sum_is_min (l:list (D.m 'b)) : unit
ensures { let x = M.sum D.measure l in
match x with
| None -> l = Nil
| Some a -> S.minorate a l /\ (exists d. mem d l /\ CO.eq d.key a)
| Some a -> S.lower_bound a l /\ (exists d. mem d l /\ CO.eq d.key a)
end }
variant { l }
= match l with Cons _ q -> monoid_sum_is_min q | _ -> () end
let lemma selected_is_min (s:'d) (e:position (D.m 'b))
let lemma selected_is_min (s:'d) (e:split (D.m 'b))
(l:list (D.m 'b)) : unit
requires { selected s e l }
ensures { match e.middle with
| None -> false
| Some d -> S.minorate d.key l && match M.sum D.measure l with
| Some d -> S.lower_bound d.key l && match M.sum D.measure l with
| None -> false
| Some k -> CO.eq d.key k
end
end }
= ()
let selected_way (ghost p:type_params 'a 'b)
let selected_part (ghost p:type_params 'a 'b)
(ghost base:list (D.m 'b))
(ghost llis:list (D.m 'b))
(ghost rlis:list (D.m 'b))
(s:unit) (sl:M.t) (d:D.t 'a 'b) (sr:M.t) : way_base unit
(s:unit) (sl:M.t) (d:D.t 'a 'b) (sr:M.t) : part_base unit
requires { p.D.mp.inv d }
requires { base = llis ++ Cons (p.D.mp.mdl d) rlis }
requires { sl.M.m = M.sum D.measure llis /\ sr.M.m = M.sum D.measure rlis }
......@@ -133,10 +134,10 @@ module Heap
returns { Here -> let e2 = { left = llis;
middle = Some (p.D.mp.mdl d);
right = rlis } in selected s e2 base
| Left sl -> selector_correct sl llis /\
| Left sl -> selection_possible sl llis /\
forall e. selected sl e llis ->
selected s (right_extend e (p.D.mp.mdl d) rlis) base
| Right sr -> selector_correct sr rlis /\
| Right sr -> selection_possible sr rlis /\
forall e. selected sr e rlis ->
selected s (left_extend llis (p.D.mp.mdl d) e) base }
= let kd = get_key p d in
......@@ -151,7 +152,7 @@ module Heap
assert { forall e. selected () e rlis ->
match e.middle with
| None -> false
| Some d -> CO.eq d.key b.K.m && S.minorate d.key llis
| Some d -> CO.eq d.key b.K.m && S.lower_bound d.key llis
end };
Right ()
end
......@@ -160,7 +161,7 @@ module Heap
assert { forall e. selected () e llis ->
match e.middle with
| None -> false
| Some d -> CO.eq d.key a.K.m && S.minorate d.key rlis
| Some d -> CO.eq d.key a.K.m && S.lower_bound d.key rlis
end };
Left ()
end
......@@ -168,7 +169,7 @@ module Heap
assert { forall e. selected () e rlis ->
match e.middle with
| None -> false
| Some d -> CO.eq d.key b.K.m && S.minorate d.key llis
| Some d -> CO.eq d.key b.K.m && S.lower_bound d.key llis
end };
Right ()
end
......@@ -176,10 +177,10 @@ module Heap
(* Full clone of the avl module. *)
clone avl.AVL as Sel with type selector = selector,
predicate selector_correct = selector_correct,
predicate selection_possible = selection_possible,
predicate selected = selected,
val selected_way = selected_way,
goal selector_correct_empty,
val selected_part = selected_part,
goal selection_empty,
constant balancing = balancing,
goal balancing_positive,
type D.t = D.t,
......@@ -192,21 +193,21 @@ module Heap
function M.m = M.m,
predicate M.c = M.c,
constant M.zero = M.zero,
function M.add = M.add,
function M.op = M.op,
goal M.assoc,
goal M.neutral,
function M.sum = M.sum,
goal M.sum_def_nil,
goal M.sum_def_cons,
val M.zero = M.zero,
val M.add = M.add
val M.op = M.op
type t 'a 'b = Sel.t 'a 'b
(* Model: a bag of data. *)
type m 'b = {
count : D.m 'b -> int;
bag : D.m 'b -> int;
card : int;
}
......@@ -245,15 +246,15 @@ module Heap
= match l with Nil -> () | Cons _ q -> as_bag_membership d q end
function m (t:t 'a 'b) : m 'b =
{ count = as_bag t.Sel.m.Sel.lis;
{ bag = as_bag t.Sel.m.Sel.lis;
card = length t.Sel.m.Sel.lis }
let ghost m (t:t 'a 'b) : m 'b
ensures { result = t.m }
= { count = as_bag t.Sel.m.Sel.lis;
= { bag = as_bag t.Sel.m.Sel.lis;
card = length t.Sel.m.Sel.lis }
let lemma m_def (t:t 'a 'b) : unit
ensures { t.m.count = as_bag t.Sel.m.Sel.lis }
ensures { t.m.bag = as_bag t.Sel.m.Sel.lis }
ensures { t.m.card = length t.Sel.m.Sel.lis }
= ()
......@@ -265,12 +266,12 @@ module Heap
(* Should be the exported part of the invariant. *)
let lemma correction (t:t 'a 'b) : unit
requires { c t }
ensures { forall d:D.m 'b. 0 <= t.m.count d <= t.m.card }
ensures { forall d:D.m 'b. 0 <= t.m.bag d <= t.m.card }
ensures { t.m.card >= 0 }
= ()
let empty (ghost p:type_params 'a 'b) : t 'a 'b
ensures { forall d:D.m 'b. result.m.count d = 0 }
ensures { forall d:D.m 'b. result.m.bag d = 0 }
ensures { result.m.card = 0 }
ensures { c result /\ result.prm = p }
= Sel.empty p
......@@ -278,16 +279,16 @@ module Heap
let singleton (ghost p:type_params 'a 'b) (d:D.t 'a 'b) : t 'a 'b
requires { p.D.mp.inv d }
ensures { let dm = p.D.mp.mdl d in
result.m.count dm = 1 /\
forall d2:D.m 'b. d2 <> dm -> result.m.count d2 = 0 }
result.m.bag dm = 1 /\
forall d2:D.m 'b. d2 <> dm -> result.m.bag d2 = 0 }
ensures { result.m.card = 1 }
ensures { c result /\ result.prm = p }
= Sel.singleton p d
let is_empty (ghost rd:ref (D.m 'b)) (t:t 'a 'b) : bool
requires { c t }
ensures { result -> forall d:D.m 'b. t.m.count d = 0 }
ensures { not result -> t.m.count !rd > 0 }
ensures { result -> forall d:D.m 'b. t.m.bag d = 0 }
ensures { not result -> t.m.bag !rd > 0 }
ensures { result <-> t.m.card = 0 }
= let res = Sel.is_empty t in
ghost if not res
......@@ -301,7 +302,7 @@ module Heap
requires { c l /\ c r /\ l.prm = r.prm }
ensures { c result /\ result.prm = l.prm }
ensures { result.m.card = l.m.card + r.m.card }
ensures { forall d. result.m.count d = l.m.count d + r.m.count d }
ensures { forall d. result.m.bag d = l.m.bag d + r.m.bag d }
= Sel.concat l r
let lemma remove_count (l:list 'a) (d:'a) (r:list 'a) : unit
......@@ -311,15 +312,15 @@ module Heap
let extract_min (t:t 'a 'b) : option (D.t 'a 'b,t 'a 'b)
requires { c t }
returns { None -> t.m.card = 0 /\ (forall d. t.m.count d = 0)
returns { None -> t.m.card = 0 /\ (forall d. t.m.bag d = 0)
| Some (d,e) -> c e /\ e.prm = t.prm /\ t.dprm.inv d /\
t.m.card = e.m.card + 1 /\ let dm = t.dprm.mdl d in
t.m.count dm = e.m.count dm + 1 /\
(forall d2. d2 <> dm -> t.m.count d2 = e.m.count d2) /\
(forall d2. t.m.count d2 > 0 -> CO.le dm.key d2.key) }
t.m.bag dm = e.m.bag dm + 1 /\
(forall d2. d2 <> dm -> t.m.bag d2 = e.m.bag d2) /\
(forall d2. t.m.bag d2 > 0 -> CO.le dm.key d2.key) }
= if Sel.is_empty t
then None
else let (o,e) = Sel.extract (Sel.default_position ()) () t in
else let (o,e) = Sel.extract (Sel.default_split ()) () t in
match o with
| None -> absurd
| Some d -> Some (d,e)
......@@ -328,9 +329,9 @@ module Heap
let min (t:t 'a 'b) : D.t 'a 'b
requires { c t /\ t.m.card >= 1 }
ensures { t.dprm.inv result /\ let dm = t.dprm.mdl result in
t.m.count dm > 0 /\ t.m.card > 0 /\
(forall d2. t.m.count d2 > 0 -> CO.le dm.key d2.key) }
= match Sel.get (Sel.default_position ()) () t with
t.m.bag dm > 0 /\ t.m.card > 0 /\
(forall d2. t.m.bag d2 > 0 -> CO.le dm.key d2.key) }
= match Sel.get (Sel.default_split ()) () t with
| None -> absurd
| Some d -> d
end
......@@ -338,10 +339,10 @@ module Heap
let pop_min (ghost r:ref (D.m 'b)) (t:t 'a 'b) : t 'a 'b
requires { c t /\ t.m.card >= 1 }
ensures { c result /\ result.prm = t.prm /\ t.m.card = result.m.card + 1 /\
t.m.count !r = result.m.count !r + 1 /\
(forall d2. d2 <> !r -> t.m.count d2 = result.m.count d2) /\
(forall d2. t.m.count d2 > 0 -> CO.le !r.key d2.key) }
= let r0 = Sel.default_position () in
t.m.bag !r = result.m.bag !r + 1 /\
(forall d2. d2 <> !r -> t.m.bag d2 = result.m.bag d2) /\
(forall d2. t.m.bag d2 > 0 -> CO.le !r.key d2.key) }
= let r0 = Sel.default_split () in
let res = Sel.remove r0 () t in
r := match !r0.middle with None -> absurd | Some d -> d end;
res
......@@ -351,8 +352,8 @@ module Heap
ensures { c result /\ result.prm = t.prm }
ensures { result.m.card = t.m.card + 1 }
ensures { let dm = t.dprm.mdl d in
result.m.count dm = t.m.count dm + 1 /\
(forall d2. d2 <> dm -> result.m.count d2 = t.m.count d2) }
result.m.bag dm = t.m.bag dm + 1 /\
(forall d2. d2 <> dm -> result.m.bag d2 = t.m.bag d2) }
= Sel.cons d t
end
......
(* Parameterize program types by their invariants and logical model.
This additional parameterization is rather administrative. *)
module TypeParams
use import HighOrd
......@@ -18,6 +21,8 @@ module TypeParams
(* For purely logical types. *)
constant default_params : type_params 'a 'a
(* Definition axiomatized to avoid a very harmful effect
due to combination of inlining and higher-order. *)