Commit f714743d authored by Martin Clochard's avatar Martin Clochard

avl example (WIP)

Freeze the most generic development, which cannot be finished
in why3 yet.
parent 0cb14a43
(* avl-based random-access lists. *)
module RAL
use import int.Int
use import list.NthLengthAppend
use import avl.SelectionTypes
(* Data is trivial (random-access lists are fully polymorphic). *)
namespace Data
type t 'a 'b = 'a
type m 'a 'b = 'a
predicate c (x:'a) = true
function m (x:'a) : 'a = x
end
(* Tree structure. Store additional information for fast index selection. *)
namespace Tree
use import avl.ParamsTypes
(* Store cardinal at every node. *)
type t 'a 'b =
| TEmpty
| TNode (t 'a 'b) 'a int (t 'a 'b) int
function m (t:t 'a 'b) : m_base (Data.m 'a 'b) = match t with
| TEmpty -> Empty
| TNode l d _ r h -> Node (m l) d.Data.m (m r) h
end
function cardinal (t:m_base (Data.m 'a 'b)) : int = match t with
| Empty -> 0
| Node l _ r _ -> cardinal l + cardinal r + 1
end
predicate c (t:t 'a 'b) = match t with
| TEmpty -> true
| TNode l d card r _ -> Data.c d /\ card = cardinal t.m /\ c l /\ c r
end
(* Those clones cannot be done yet... *)
let empty () : t 'a 'b
ensures { result.m = Empty }
ensures { c result }
= TEmpty
let cardinal (t:t 'a 'b) : int
requires { c t }
ensures { result = cardinal t.m }
= match t with TEmpty -> 0 | TNode _ _ c _ _ -> c end
let node (l:t 'a 'b) (d:Data.t 'a 'b) (r:t 'a 'b) (h:int) : t 'a 'b
requires { c l /\ Data.c d /\ c r }
ensures { result.m = Node l.m d.Data.m r.m h }
ensures { c result }
= TNode l d (cardinal l + cardinal r + 1) r h
let view (t:t 'a 'b) : view_base (t 'a 'b) (Data.t 'a 'b)
ensures { match result with
| VEmpty -> t.m = Empty
| VNode l d r h -> t.m = Node l.m d.Data.m r.m h /\
c l /\ Data.c d /\ c r
end }
= match t with TEmpty -> VEmpty | TNode l d _ r h -> VNode l d r h end
end
namespace S
type t 'a 'b = int
type m 'a 'b = int
predicate c (x:int) = true
function m (x:int) : int = x
end
predicate selector_correct (s:S.m 'a 'b) (l:list (Data.m 'a 'b)) =
0 <= s < length l
predicate selected (s:S.m 'a 'b) (e:position_base (Data.m 'a 'b)) =
length e.left = s /\ match e.middle with
| None -> e.right = Nil
| _ -> true
end
clone import avl.Selection as Sel with namespace P.Data = Data,
namespace S = S, predicate selector_correct = selector_correct,
predicate selected = selected,
goal selector_correct_empty
(* This clone cannot be done yet... *)
let selected_way (s:S.t 'a 'b)
(l:t 'a 'b) (d:P.Data.t 'a 'b) (r:t 'a 'b) : way 'a 'b
requires { l.m.inv = r.m.inv }
requires { Data.c d /\ l.m.inv d.Data.m }
requires { c l /\ c r /\ S.c s }
requires { selector_correct s.S.m (node_model l.m.lis d.P.Data.m r.m.lis) }
(* A selected position can be found by following the given way. *)
returns { Here -> selected s.S.m { left = l.m.lis;
middle = Some d.Data.m;
right = r.m.lis }
| Left sl -> selector_correct sl.S.m l.m.lis /\ S.c sl /\
forall e. selected sl.S.m e ->
selected s.S.m { e with right = node_model e.right d.Data.m r.m.lis }
| Right sr -> selector_correct sr.S.m r.m.lis /\ S.c sr /\
forall e. selected sr.S.m e ->
selected s.S.m { e with left = node_model l.m.lis d.Data.m e.left } }
= let cl = cardinal l in
if s < cl
then Left s
else if s > cl
then Right s
else Here
end
(* Association lists. *)
(* Association with respect to an equivalence relation. *)
module Assoc
clone import key_type.KeyType as K
clone import relations_params.EquivalenceParam as Eq with type t = key
use import list.List
use import list.Mem
use import option.Option
use import HighOrd
predicate appear (p:param 'a) (k:key 'a) (l:list (t 'a 'b)) =
exists x. mem x l /\ correct_for p k /\ Eq.rel p k (key x)
(* Correction. *)
predicate correct (p:param 'a) (l:list (t 'a 'b)) = match l with
| Nil -> true
| Cons x q -> let kx = key x in correct_for p kx /\ correct p q
end
(* Unique occurence (a desirable property of an association list). *)
predicate unique (p:param 'a) (l:list (t 'a 'b)) = match l with
| Nil -> true
| Cons x q -> not appear p (key x) q /\ unique p q
end
(* functional update with equivalence classes. *)
function param_update (p:param 'a) (f:key 'a -> 'b)
(k:key 'a) (b:'b) : key 'a -> 'b = \k2.
if Eq.rel p k k2 then b else f k2
(* functional model of an association list. *)
function model (p:param 'a) (l:list (t 'a 'b)) : key 'a -> option (t 'a 'b) =
match l with
| Nil -> \x. None
| Cons d q -> param_update p (model p q) (key d) (Some d)
end
(* A key is bound iff it occurs in the association lists. *)
let rec lemma model_occurence (p:param 'a) (k:key 'a)
(l:list (t 'a 'b)) : unit
requires { correct p l }
requires { correct_for p k }
ensures { appear p k l <-> match model p l k with None -> false
| Some _ -> true end }
variant { l }
= match l with Cons _ q -> model_occurence p k q | _ -> () end
(* A key is bound to a value with an equivalent key. *)
let rec lemma model_link (p:param 'a) (k:key 'a) (l:list (t 'a 'b)) : unit
requires { correct p l }
requires { correct_for p k }
ensures { match model p l k with None -> true
| Some d -> Eq.rel p k (key d) end }
variant { l }
= match l with Cons _ q -> model_link p k q | _ -> () end
(* Two equivalent keys are bound to the same value. *)
let rec lemma model_equal (p:param 'a) (k1 k2:key 'a)
(l:list (t 'a 'b)) : unit
requires { correct p l }
requires { correct_for p k1 /\ correct_for p k2 }
requires { Eq.rel p k1 k2 }
ensures { model p l k1 = model p l k2 }
variant { l }
= match l with Cons _ q -> model_equal p k1 k2 q | _ -> () end
(* If the list satisfies the uniqueness property,
then every value occuring in the list is the image of its key. *)
let rec lemma model_unique (p:param 'a) (k:key 'a) (l:list (t 'a 'b)) : unit
requires { correct p l }
requires { unique p l }
requires { correct_for p k }
ensures { forall d. mem d l -> model p l (key d) = Some d }
variant { l }
= match l with Cons _ q -> model_unique p k q | _ -> () end
end
(* Sorted (increasing) association list. *)
module AssocSorted
use import list.List
use import list.Append
use import list.Mem
use import option.Option
clone import key_type.KeyType as K
clone import preorder.FullParam as O with type t = key
(* The commented out part do not work, unfortunately. *)
clone export Assoc with namespace K = K,(*namespace Eq = O.Eq*)
type Eq.param = O.order,
predicate Eq.correct_for = O.correct_for,
predicate Eq.rel = O.eq,
(* Duplicates, there is no need to keep them. *)
goal Eq.trans,
goal Eq.refl,
goal Eq.symm
clone sorted.Increasing as S with namespace K = K,
(*namespace O = O.Lt*)
type O.param = O.order,
predicate O.correct_for = O.correct_for,
predicate O.rel = O.lt,
goal O.trans
(* Sorted lists are correct association lists with unicity property. *)
let rec lemma increasing_unique_and_correct (o:order 'a)
(l:list (t 'a 'b)) : unit
requires { S.increasing o l }
ensures { correct o l }
ensures { unique o l }
variant { l }
= match l with Cons _ q -> increasing_unique_and_correct o q | _ -> () end
let lemma absent (o:order 'a) (k:key 'a) (l r:list (t 'a 'b)) : unit
requires { correct_for o k }
requires { S.increasing o l }
requires { S.increasing o r }
requires { S.majorate o k l }
requires { S.minorate o k r }
ensures { model o (l++r) k = None }
= assert { S.precede o l r && not appear o k (l++r) &&
match model o (l++r) k with None -> true | _ -> false end }
let lemma present (o:order 'a) (k:key 'a) (l r:list (t 'a 'b))
(d:t 'a 'b) : unit
requires { correct_for o k }
requires { correct_for o (key d) }
requires { S.increasing o l }
requires { S.increasing o r }
requires { S.majorate o k l }
requires { S.minorate o k r }
requires { eq o k (key d) }
ensures { model o (l++Cons d r) k = Some d }
= assert { S.increasing o (l++Cons d r) }
end
This diff is collapsed.
This diff is collapsed.
(* Type with a key. Intended to factor elements/bindings representations
in sets/map-like structures.
Typical instantiation:
- Set elements, t 'a 'b = key 'a, get_key = id:
the only information one can retrieve
from a key is presence.
- Map bindings, t 'a 'b = (key 'a,value 'b),get_key = fst:
one can also retrieve a value from a present binding. *)
theory KeyType
type t 'a 'b
type key 'a
function key (t 'a 'b) : key 'a
end
(* program version. *)
module ProgramKeyType
clone export program_type.Type2
clone program_type.Type1 as Key
function key_m (m 'a 'b) : Key.m 'a
val key (x:t 'a 'b) : Key.t 'a
requires { c x }
ensures { Key.c result }
ensures { x.m.key_m = result.Key.m }
end
<?xml version="1.0" encoding="UTF-8"?>
<!DOCTYPE why3session PUBLIC "-//Why3//proof session v2//EN" "http://why3.lri.fr/why3session.dtd">
<why3session shape_version="4">
<file
name="../key_type.mlw"
verified="true"
expanded="true">
<theory
name="KeyType"
locfile="../key_type.mlw"
loclnum="3" loccnumb="7" loccnume="14"
verified="true"
expanded="true">
</theory>
<theory
name="ProgramKeyType"
locfile="../key_type.mlw"
loclnum="12" loccnumb="7" loccnume="21"
verified="true"
expanded="true">
</theory>
</file>
</why3session>
(* Full preorder theory,
containing lt and eq as well. *)
theory FullParam
type t 'a
type order 'a
predicate le (order 'a) (t 'a) (t 'a)
clone export relations_params.PreOrderParam with type t = t,
type param = order, predicate rel = le
predicate eq (order 'a) (t 'a) (t 'a)
axiom eq_def : forall o:order 'a,x y:t 'a.
correct_for o x /\ correct_for o y ->
(eq o x y <-> le o x y /\ le o y x)
predicate lt (order 'a) (t 'a) (t 'a)
axiom lt_def : forall o:order 'a,x y:t 'a.
correct_for o x /\ correct_for o y ->
(lt o x y <-> le o x y /\ not le o y x)
clone relations_params.EquivalenceParam as Eq with type t = t,
type param = order, predicate correct_for = correct_for,
predicate rel = eq, lemma trans, lemma refl, lemma symm
clone relations_params.PartialStrictOrderParam as Lt with type t = t,
type param = order, predicate correct_for = correct_for,
predicate rel = lt, lemma trans, lemma asymm
end
(* Preorder + corresponding computable comparison. *)
module ComputableParam
use import int.Int
clone export program_type.Type1
clone program_type.Type1 as O
clone export FullParam with type t = m, type order = O.m
(* Comparison is computable. *)
val compare (o:O.t 'a) (x y:t 'a) : int
requires { O.c o }
requires { correct_for o.O.m x.m /\ c x }
requires { correct_for o.O.m y.m /\ c y }
ensures { result > 0 <-> lt o.O.m y.m x.m }
ensures { result < 0 <-> lt o.O.m x.m y.m }
ensures { result = 0 <-> eq o.O.m x.m y.m }
end
<?xml version="1.0" encoding="UTF-8"?>
<!DOCTYPE why3session PUBLIC "-//Why3//proof session v2//EN" "http://why3.lri.fr/why3session.dtd">
<why3session shape_version="4">
<prover
id="0"
name="Alt-Ergo"
version="0.95.2"/>
<file
name="../preorder.mlw"
verified="true"
expanded="false">
<theory
name="FullParam"
locfile="../preorder.mlw"
loclnum="4" loccnumb="7" loccnume="16"
verified="true"
expanded="false">
<goal
name="refl"
locfile="../relations_params.mlw"
loclnum="14" loccnumb="8" loccnume="12"
sum="16f7adfc697259216b2d1f4f975bf261"
proved="true"
expanded="false"
shape="aeqV0V1V1Iacorrect_forV0V1F">
<proof
prover="0"
timelimit="5"
memlimit="1000"
obsolete="false"
archived="false">
<result status="valid" time="0.01"/>
</proof>
</goal>
<goal
name="trans"
locfile="../relations_params.mlw"
loclnum="26" loccnumb="8" loccnume="13"
sum="687df4d536017126286fd2decd0627fe"
proved="true"
expanded="false"
shape="aeqV0V1V3IaeqV0V2V3AaeqV0V1V2Iacorrect_forV0V3Aacorrect_forV0V2Aacorrect_forV0V1F">
<proof
prover="0"
timelimit="5"
memlimit="1000"
obsolete="false"
archived="false">
<result status="valid" time="0.02"/>
</proof>
</goal>
<goal
name="symm"
locfile="../relations_params.mlw"
loclnum="33" loccnumb="8" loccnume="12"
sum="a45949b88a62cfa03ff9331b96331060"
proved="true"
expanded="false"
shape="aeqV0V2V1IaeqV0V1V2Iacorrect_forV0V2Aacorrect_forV0V1F">
<proof
prover="0"
timelimit="5"
memlimit="1000"
obsolete="false"
archived="false">
<result status="valid" time="0.01"/>
</proof>
</goal>
<goal
name="trans"
locfile="../relations_params.mlw"
loclnum="26" loccnumb="8" loccnume="13"
sum="b8987b6c37bc8fc438d2d31c10ea5758"
proved="true"
expanded="false"
shape="altV0V1V3IaltV0V2V3AaltV0V1V2Iacorrect_forV0V3Aacorrect_forV0V2Aacorrect_forV0V1F">
<proof
prover="0"
timelimit="5"
memlimit="1000"
obsolete="false"
archived="false">
<result status="valid" time="0.02"/>
</proof>
</goal>
<goal
name="asymm"
locfile="../relations_params.mlw"
loclnum="39" loccnumb="8" loccnume="13"
sum="2c95d9822b30bcc26431c15fb6a137cc"
proved="true"
expanded="false"
shape="NaltV0V2V1IaltV0V1V2Iacorrect_forV0V2Aacorrect_forV0V1F">
<proof
prover="0"
timelimit="5"
memlimit="1000"
obsolete="false"
archived="false">
<result status="valid" time="0.01"/>
</proof>
</goal>
</theory>
<theory
name="ComputableParam"
locfile="../preorder.mlw"
loclnum="31" loccnumb="7" loccnume="22"
verified="true"
expanded="false">
</theory>
</file>
</why3session>
module Type0
(* Program version of the type. *)
type t
(* Its logical model. *)
type m
(* Type invariant (c for correct). *)
predicate c t
(* get logical model (m for model). *)
function m t : m
end
(* Variants with different number of type variables. *)
module Type1
type t 'a
type m 'a
predicate c (t 'a)
function m (t 'a) : m 'a
end
module Type2
type t 'a 'b
type m 'a 'b
predicate c (t 'a 'b)
function m (t 'a 'b) : m 'a 'b
end
<?xml version="1.0" encoding="UTF-8"?>
<!DOCTYPE why3session PUBLIC "-//Why3//proof session v2//EN" "http://why3.lri.fr/why3session.dtd">
<why3session shape_version="4">
<file
name="../program_type.mlw"
verified="true"
expanded="true">
<theory
name="Type0"
locfile="../program_type.mlw"
loclnum="2" loccnumb="7" loccnume="12"
verified="true"
expanded="true">
</theory>
<theory
name="Type1"
locfile="../program_type.mlw"
loclnum="17" loccnumb="7" loccnume="12"
verified="true"
expanded="true">
</theory>
<theory
name="Type2"
locfile="../program_type.mlw"
loclnum="26" loccnumb="7" loccnume="12"
verified="true"
expanded="true">
</theory>
</file>
</why3session>
(* avl-based random-access lists. *)
module RAL
use import int.Int
use import list.NthLengthAppend
use import avl.SelectionTypes
(* Data is trivial (random-access lists are fully polymorphic). *)
namespace Data
type t 'a 'b = 'a
type m 'a 'b = 'a
predicate c (x:'a) = true
function m (x:'a) : 'a = x
end
(* Tree structure. Store additional information for fast index selection. *)
namespace Tree
use import avl.ParamsTypes
(* Store cardinal at every node. *)
type t 'a 'b =
| TEmpty
| TNode (t 'a 'b) 'a int (t 'a 'b) int
function m (t:t 'a 'b) : m_base (Data.m 'a 'b) = match t with
| TEmpty -> Empty
| TNode l d _ r h -> Node (m l) d.Data.m (m r) h
end
function cardinal (t:m_base (Data.m 'a 'b)) : int = match t with
| Empty -> 0
| Node l _ r _ -> cardinal l + cardinal r + 1
end
predicate c (t:t 'a 'b) = match t with
| TEmpty -> true
| TNode l d card r _ -> Data.c d /\ card = cardinal t.m /\ c l /\ c r
end
(* Those clones cannot be done yet... *)
let empty () : t 'a 'b
ensures { result.m = Empty }
ensures { c result }
= TEmpty
let cardinal (t:t 'a 'b) : int
requires { c t }
ensures { result = cardinal t.m }
= match t with TEmpty -> 0 | TNode _ _ c _ _ -> c end
let node (l:t 'a 'b) (d:Data.t 'a 'b) (r:t 'a 'b) (h:int) : t 'a 'b
requires { c l /\ Data.c d /\ c r }
ensures { result.m = Node l.m d.Data.m r.m h }
ensures { c result }
= TNode l d (cardinal l + cardinal r + 1) r h
let view (t:t 'a 'b) : view_base (t 'a 'b) (Data.t 'a 'b)
ensures { match result with
| VEmpty -> t.m = Empty
| VNode l d r h -> t.m = Node l.m d.Data.m r.m h /\
c l /\ Data.c d /\ c r
end }
= match t with TEmpty -> VEmpty | TNode l d _ r h -> VNode l d r h end
end
namespace S
type t 'a 'b = int
type m 'a 'b = int
predicate c (x:int) = true
function m (x:int) : int = x
end
predicate selector_correct (s:S.m 'a 'b) (l:list (Data.m 'a 'b)) =
0 <= s < length l
predicate selected (s:S.m 'a 'b) (e:position_base (Data.m 'a 'b)) =
length e.left = s /\ match e.middle with
| None -> e.right = Nil
| _ -> true
end
clone import avl.Selection as Sel with namespace P.Data = Data,
namespace S = S, predicate selector_correct = selector_correct,
predicate selected = selected,
goal selector_correct_empty
(* This clone cannot be done yet... *)
let selected_way (s:S.t 'a 'b)
(l:t 'a 'b) (d:P.Data.t 'a 'b) (r:t 'a 'b) : way 'a 'b