Skip to content
GitLab
Projects
Groups
Snippets
/
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in / Register
Toggle navigation
Menu
Open sidebar
Iris
Actris
Commits
6f8d5cfb
Commit
6f8d5cfb
authored
Jun 27, 2019
by
jihgfee
Browse files
WIP list sort elem
parent
00b05a4b
Changes
1
Hide whitespace changes
Inline
Side-by-side
theories/examples/list_sort_elem.v
View file @
6f8d5cfb
...
...
@@ -4,126 +4,61 @@ From iris.heap_lang Require Import proofmode notation.
From
iris
.
heap_lang
Require
Import
assert
.
From
osiris
.
utils
Require
Import
list
.
Definition
compareZ
:
val
:
=
λ
:
"x"
"y"
,
"x"
≤
"y"
.
Definition
cont
:
=
true
.
Definition
stop
:
=
false
.
Definition
list_sort_service_split
:
val
:
=
rec
:
"go"
"c"
"c1"
"c2"
:
=
match
:
recv
"c"
with
NONE
=>
send
"c1"
NONE
;;
send
"c2"
NONE
|
SOME
"x"
=>
send
"c1"
(
SOME
"x"
)
;;
"go"
"c"
"c2"
"c1"
end
.
if
:
~(
recv
"c"
)
then
send
"c1"
#
stop
;;
send
"c2"
#
stop
else
let
:
"x"
:
=
recv
"c"
in
send
"c1"
#
cont
;;
send
"c1"
"x"
;;
"go"
"c"
"c2"
"c1"
.
Definition
list_sort_service_copy
:
val
:
=
rec
:
"go"
"c"
"cin"
:
=
match
:
recv
"cin"
with
NONE
=>
send
"c"
NONE
|
SOME
"x"
=>
send
"c"
(
SOME
"x"
)
;;
"go"
"c"
"cin"
end
.
if
:
~(
recv
"cin"
)
then
send
"c"
NONE
else
let
:
"x"
:
=
recv
"cin"
in
send
"c"
"x"
;;
"go"
"c"
"cin"
.
Definition
list_sort_service_merge
:
val
:
=
rec
:
"go"
"cmp"
"c"
"x1"
"c1"
"c2"
:
=
match
:
recv
"c2"
with
NONE
=>
send
"c"
(
SOME
"x1"
)
;;
list_sort_service_copy
"c"
"c1"
|
SOME
"x2"
=>
if
:
"cmp"
"x1"
"x2"
then
send
"c"
(
SOME
"x1"
)
;;
"go"
"cmp"
"c"
"x2"
"c2"
"c1"
else
send
"c"
(
SOME
"x2"
)
;;
"go"
"cmp"
"c"
"x1"
"c1"
"c2"
end
.
rec
:
"go"
"c"
"x1"
"c1"
"c2"
:
=
if
:
~recv
"c2"
then
send
"c"
#
cont
;;
send
"c"
"x1"
;;
list_sort_service_copy
"c"
"c1"
else
let
:
"x2"
:
=
recv
"c2"
in
if
:
compareZ
"x1"
"x2"
then
send
"c"
#
cont
;;
send
"c"
"x1"
;;
"go"
"c"
"x2"
"c2"
"c1"
else
send
"c"
#
cont
;;
send
"c"
"x2"
;;
"go"
"c"
"x1"
"c1"
"c2"
.
Definition
list_sort_service
:
val
:
=
rec
:
"go"
"cmp"
"c"
:
=
match
:
recv
"c"
with
NONE
=>
send
"c"
NONE
|
SOME
"x1"
=>
match
:
recv
"c"
with
NONE
=>
send
"c"
(
SOME
"x1"
)
;;
send
"c"
NONE
|
SOME
"x2"
=>
let
:
"c1"
:
=
start_chan
(
"go"
"cmp"
)
in
let
:
"c2"
:
=
start_chan
(
"go"
"cmp"
)
in
send
"c1"
(
SOME
"x1"
)
;;
send
"c2"
(
SOME
"x2"
)
;;
list_sort_service_split
"c"
"c1"
"c2"
;;
let
:
"x"
:
=
match
:
recv
"c1"
with
NONE
=>
assert
#
false
|
SOME
"x"
=>
"x"
end
in
list_sort_service_merge
"cmp"
"c"
"x"
"c1"
"c2"
end
end
.
rec
:
"go"
"c"
:
=
if
:
~(
recv
"c"
)
then
send
"c"
#
stop
else
let
:
"x"
:
=
recv
"c"
in
if
:
~(
recv
"c"
)
then
send
"c"
#
cont
;;
send
"c"
"x"
;;
send
"c"
#
stop
else
let
:
"y"
:
=
recv
"c"
in
let
:
"c1"
:
=
start_chan
(
"go"
)
in
let
:
"c2"
:
=
start_chan
(
"go"
)
in
send
"c1"
#
cont
;;
send
"c1"
"x"
;;
send
"c2"
#
cont
;;
send
"c2"
"y"
;;
list_sort_service_split
"c"
"c1"
"c2"
;;
let
:
"x"
:
=
(
if
:
recv
"c1"
then
recv
"c1"
else
assert
#
false
)
in
list_sort_service_merge
"c"
"x"
"c1"
"c2"
.
Section
list_sort_elem
.
Context
`
{!
heapG
Σ
,
!
proto_chanG
Σ
}
(
N
:
namespace
).
(*
tail xs ys n := if n > 0 then ?y.tail xs (y::ys) (n-1) else end
helper xs n := (!x.helper (x :: xs) (S N)) <+> (tail (rev xs) [] n)
prot = helper [] 0
*)
(*
tail xs ys n :=
if n > 0
then ?Some y.tail xs (y::ys) (n-1)
else ?None{ sorted_of (rev ys) xs }.end
helper xs n :=
!v. match v with
| Some v => helper (x :: xs) (S N))
| None => (tail (rev xs) [] n)
end
prot = helper [] 0
*)
(* Definition test (rec : Z -d> iProto Σ) : (Z -d> iProto Σ) := *)
(* λ x, (<?> o (n:Z), MSG o; (rec : _ -> iProto Σ) n)%proto. *)
(* (* No "Branching" *) *)
(* Definition tail_protocol_aux (rec : nat -d> list Z -d> list Z -d> iProto Σ) *)
(* : (nat -d> list Z -d> list Z -d> iProto Σ) := *)
(* λ n xs ys, *)
(* (match n with *)
(* | S n => <?> (x:Z), MSG (SOMEV (LitV $ LitInt x)); rec n xs ys *)
(* | O => <?> (a:unit) , *)
(* MSG NONEV {{ ⌜ Sorted (≤) (rev ys) ⌝ ∗ ⌜ (rev ys) ≡ₚ xs ⌝ }}; END *)
(* end)%proto. *)
(* Check tail_protocol_aux. *)
(* Instance tail_protocol_aux_contractive : Contractive (tail_protocol_aux). *)
(* Proof. *)
(* intros n p p' Hp. rewrite /tail_protocol_aux. *)
(* intros x xs ys. simpl. *)
(* destruct x. *)
(* - done. *)
(* - admit. *)
(* Admitted. *)
(* Definition tail_protocol : (nat -d> list Z -d> list Z -d> iProto Σ) := fixpoint (tail_protocol_aux). *)
(* Lemma tail_protocol_unfold : *)
(* tail_protocol ≡ tail_protocol_aux tail_protocol. *)
(* Proof. apply (fixpoint_unfold tail_protocol_aux). Qed. *)
(* (* helper n xs := *) *)
(* (* !v. match v with *) *)
(* (* | Some x => helper (x :: xs) (S N)) *) *)
(* (* | None => (tail n (rev xs) []) *) *)
(* (* end *) *)
(* Definition helper_protocol_aux (rec : nat -d> list Z -d> iProto Σ) *)
(* : (nat -d> list Z -d> iProto Σ) := *)
(* λ n xs, *)
(* (<!> (z:Z) o, MSG o {{ ⌜o = NONEV ∨ o = SOMEV (LitV $ LitInt z)⌝ }}; *)
(* match o with *)
(* | SOMEV v => rec (S n) (z :: xs) *)
(* | NONEV => tail_protocol n (rev xs) [] *)
(* | _ => END *)
(* end)%proto. *)
(* "Branching" *)
Definition
tail_protocol_aux
(
rec
:
list
Z
-
d
>
list
Z
-
d
>
iProto
Σ
)
:
(
list
Z
-
d
>
list
Z
-
d
>
iProto
Σ
)
:
=
λ
xs
ys
,
(<?>
(
b
:
bool
),
MSG
#
b
{{
if
b
then
True
else
⌜
Sorted
(
≤
)
(
rev
ys
)
⌝
∗
⌜
(
rev
ys
)
≡
ₚ
xs
⌝
}}
;
{{
if
b
then
True
else
⌜
Sorted
(
≤
)
ys
⌝
∗
⌜
ys
≡
ₚ
xs
⌝
}}
;
if
b
then
<?>
(
y
:
Z
),
MSG
#
y
;
(
rec
:
_
->
_
->
iProto
Σ
)
xs
(
y
::
ys
)
then
<?>
(
y
:
Z
),
MSG
#
y
{{
(* y ≤ ys *)
True
}}
;
(
rec
:
_
->
_
->
iProto
Σ
)
xs
(
y
s
++[
y
]
)
else
END
)%
proto
.
Instance
tail_protocol_aux_contractive
:
Contractive
(
tail_protocol_aux
).
...
...
@@ -148,8 +83,8 @@ Section list_sort_elem.
λ
xs
,
(<!>
(
b
:
bool
),
MSG
#
b
;
if
b
then
<!>
(
x
:
Z
),
MSG
#
x
;
(
rec
:
_
→
iProto
Σ
)
(
x
::
xs
)
else
tail_protocol
(
rev
xs
)
[])%
proto
.
then
<!>
(
x
:
Z
),
MSG
#
x
;
(
rec
:
_
→
iProto
Σ
)
(
x
s
++[
x
]
)
else
tail_protocol
xs
[])%
proto
.
Instance
helper_protocol_aux_contractive
:
Contractive
(
helper_protocol_aux
).
Proof
.
...
...
@@ -170,4 +105,212 @@ Section list_sort_elem.
Definition
list_sort_elem_protocol
:
=
helper_protocol
[].
Lemma
loop_sort_service_split_spec
c
c1
c2
(
xs
xs1
xs2
:
list
Z
)
:
{{{
c
↣
iProto_dual
(
helper_protocol
xs
)
@
N
∗
c1
↣
helper_protocol
xs1
@
N
∗
c2
↣
helper_protocol
xs2
@
N
}}}
list_sort_service_split
c
c1
c2
{{{
xs'
xs1'
xs2'
,
RET
#()
;
c
↣
iProto_dual
(
tail_protocol
(
xs
++
xs'
)
[])
@
N
∗
c1
↣
tail_protocol
(
xs1
++
xs1'
)
[]
@
N
∗
c2
↣
tail_protocol
(
xs2
++
xs2'
)
[]
@
N
∗
⌜
xs'
≡
ₚ
xs1'
++
xs2'
⌝
}}}.
Proof
.
iIntros
(
Ψ
)
"(Hc & Hc1 & Hc2) HΨ"
.
iL
ö
b
as
"IH"
forall
(
c
c1
c2
xs
xs1
xs2
Ψ
).
wp_rec
.
rewrite
helper_protocol_unfold
.
wp_apply
(
recv_proto_spec
N
with
"Hc"
)=>
//=.
iIntros
(
b
)
"Hc _"
.
destruct
b
.
-
wp_apply
(
recv_proto_spec
N
with
"Hc"
)=>
//=.
iIntros
(
x
)
"Hc _"
.
wp_pures
.
rewrite
(
helper_protocol_unfold
xs1
).
wp_apply
(
send_proto_spec
N
with
"Hc1"
)=>
//=.
iExists
cont
.
iSplit
;
first
done
;
iSplit
;
first
done
;
iIntros
"!> Hc1"
.
wp_apply
(
send_proto_spec
N
with
"Hc1"
)=>
//=.
iExists
x
.
iSplit
;
first
done
;
iSplit
;
first
done
;
iIntros
"!> Hc1"
.
wp_apply
(
"IH"
with
"[Hc] [Hc2] [Hc1]"
)=>
//.
iIntros
(
xs'
xs1'
xs2'
)
"(Hc & Hc2 & Hc1 & Hperm)"
.
iApply
"HΨ"
.
iSplitL
"Hc"
.
rewrite
-
app_assoc
.
rewrite
-
cons_middle
.
iApply
"Hc"
.
iSplitL
"Hc1"
.
rewrite
-
app_assoc
.
rewrite
-
cons_middle
.
iApply
"Hc1"
.
iFrame
.
iDestruct
"Hperm"
as
%
Hperm
.
iPureIntro
.
simpl
.
apply
Permutation_cons
.
rewrite
Hperm
.
apply
Permutation_app_comm
.
-
rewrite
(
helper_protocol_unfold
xs1
).
wp_apply
(
send_proto_spec
N
with
"Hc1"
)=>
//=.
iExists
stop
.
iSplit
;
first
done
;
iSplit
;
first
done
;
iIntros
"!> Hc1"
.
rewrite
(
helper_protocol_unfold
xs2
).
wp_apply
(
send_proto_spec
N
with
"Hc2"
)=>
//=.
iExists
stop
.
iSplit
;
first
done
;
iSplit
;
first
done
;
iIntros
"!> Hc2"
.
iSpecialize
(
"HΨ"
$![]
[]
[]).
iApply
"HΨ"
.
repeat
rewrite
app_nil_r
.
iFrame
.
done
.
Qed
.
Lemma
cmp_spec
:
(
∀
x
y
,
{{{
True
}}}
compareZ
#
x
#
y
{{{
RET
#(
bool_decide
(
x
≤
y
))
;
True
}}})%
I
.
Proof
.
Admitted
.
Lemma
loop_sort_service_merge_spec
c
c1
c2
xs
xs1
xs2
y1
ys1
ys2
:
{{{
c
↣
iProto_dual
(
tail_protocol
xs
(
list_merge
(
≤
)
ys1
ys2
))
@
N
∗
c1
↣
tail_protocol
xs1
(
ys1
++[
y1
])
@
N
∗
c2
↣
tail_protocol
xs2
ys2
@
N
∗
⌜
xs
≡
ₚ
xs1
++
xs2
⌝
}}}
list_sort_service_merge
c
#
y1
c1
c2
{{{
RET
#()
;
c
↣
END
@
N
∗
c1
↣
END
@
N
∗
c2
↣
END
@
N
}}}.
Proof
.
iIntros
(
Ψ
)
"(Hc & Hc1 & Hc2 & Hperm) HΨ"
.
iL
ö
b
as
"IH"
forall
(
c1
c2
xs1
xs2
y1
ys1
ys2
Ψ
).
wp_rec
.
wp_pures
.
rewrite
(
tail_protocol_unfold
xs
).
rewrite
(
tail_protocol_unfold
xs2
).
wp_apply
(
recv_proto_spec
N
with
"Hc2"
)=>
//=.
iIntros
(
b
)
"Hc2 HP"
.
destruct
b
.
-
iClear
"HP"
.
wp_pures
.
wp_apply
(
recv_proto_spec
N
with
"Hc2"
)=>
//=.
iIntros
(
x
)
"Hc2 _"
.
wp_pures
.
wp_apply
(
cmp_spec
)=>
//.
iIntros
(
_
).
case_bool_decide
.
+
wp_apply
(
send_proto_spec
N
with
"Hc"
)=>
//=.
iExists
cont
.
iSplit
;
first
done
;
iSplit
;
first
done
;
iIntros
"!> Hc"
.
wp_apply
(
send_proto_spec
N
with
"Hc"
)=>
//=.
iExists
y1
.
iSplit
;
first
done
;
iSplit
;
first
done
;
iIntros
"!> Hc"
.
iDestruct
"Hperm"
as
%
Hperm
.
wp_apply
(
"IH"
with
"[Hc] [Hc2] [Hc1]"
)=>
//
;
first
last
.
iIntros
"(HC & Hc2 & Hc1)"
.
iApply
"HΨ"
.
iFrame
.
iPureIntro
.
rewrite
Hperm
.
apply
Permutation_app_comm
.
admit
.
+
wp_apply
(
send_proto_spec
N
with
"Hc"
)=>
//=.
iExists
cont
.
iSplit
;
first
done
;
iSplit
;
first
done
;
iIntros
"!> Hc"
.
wp_apply
(
send_proto_spec
N
with
"Hc"
)=>
//=.
iExists
x
.
iSplit
;
first
done
;
iSplit
;
first
done
;
iIntros
"!> Hc"
.
iDestruct
"Hperm"
as
%
Hperm
.
wp_apply
(
"IH"
with
"[Hc] [Hc1] [Hc2]"
)=>
//
;
first
last
.
admit
.
-
wp_apply
(
send_proto_spec
N
with
"Hc"
)=>
//=.
iExists
cont
.
iSplit
;
first
done
;
iSplit
;
first
done
;
iIntros
"!> Hc"
.
wp_apply
(
send_proto_spec
N
with
"Hc"
)=>
//=.
iExists
y1
.
iSplit
;
first
done
;
iSplit
;
first
done
;
iIntros
"!> Hc"
.
wp_pures
.
admit
.
Qed
.
Lemma
list_sort_service_elem_spec
c
:
{{{
c
↣
iProto_dual
list_sort_elem_protocol
@
N
}}}
list_sort_service
c
{{{
RET
#()
;
c
↣
END
@
N
}}}.
Proof
.
iIntros
(
Ψ
)
"Hc HΨ"
.
iL
ö
b
as
"IH"
forall
(
c
Ψ
).
wp_rec
.
rewrite
/
list_sort_elem_protocol
.
rewrite
{
2
}
helper_protocol_unfold
.
wp_apply
(
recv_proto_spec
N
with
"Hc"
)=>
//=.
iIntros
(
b
)
"Hc _"
.
destruct
b
.
-
wp_apply
(
recv_proto_spec
N
with
"Hc"
)=>
//=.
iIntros
(
x1
)
"Hc _"
.
rewrite
(
helper_protocol_unfold
[
x1
]).
wp_apply
(
recv_proto_spec
N
with
"Hc"
)=>
//=.
iIntros
(
b
)
"Hc _"
.
destruct
b
.
+
wp_apply
(
recv_proto_spec
N
with
"[Hc]"
)=>
//=.
iIntros
(
x2
)
"Hc _"
.
wp_apply
(
start_chan_proto_spec
N
(
list_sort_elem_protocol
)).
{
iIntros
(
cy
)
"Hcy"
.
iApply
(
"IH"
with
"Hcy"
)=>//.
iNext
.
iIntros
"Hcy"
.
done
.
}
iIntros
(
cy
)
"Hcy"
.
wp_apply
(
start_chan_proto_spec
N
(
list_sort_elem_protocol
)).
{
iIntros
(
cz
)
"Hcz"
.
iApply
(
"IH"
with
"Hcz"
)=>//.
iNext
.
iIntros
"Hcz"
.
done
.
}
iIntros
(
cz
)
"Hcz"
.
rewrite
/
list_sort_elem_protocol
.
rewrite
{
2
}(
helper_protocol_unfold
[]).
wp_apply
(
send_proto_spec
N
with
"Hcy"
)=>
//=.
iExists
cont
.
iSplit
;
first
done
;
iSplit
;
first
done
;
iIntros
"!> Hcy"
.
wp_apply
(
send_proto_spec
N
with
"Hcy"
)=>
//=.
iExists
x1
.
iSplit
;
first
done
;
iSplit
;
first
done
;
iIntros
"!> Hcy"
.
rewrite
{
2
}(
helper_protocol_unfold
[]).
wp_apply
(
send_proto_spec
N
with
"Hcz"
)=>
//=.
iExists
cont
.
iSplit
;
first
done
;
iSplit
;
first
done
;
iIntros
"!> Hcz"
.
wp_apply
(
send_proto_spec
N
with
"Hcz"
)=>
//=.
iExists
x2
.
iSplit
;
first
done
;
iSplit
;
first
done
;
iIntros
"!> Hcz"
.
wp_apply
(
loop_sort_service_split_spec
with
"[Hc Hcy Hcz]"
)=>
//.
iFrame
.
iIntros
(
xs'
xs1'
xs2'
)
"(Hc & Hcy & Hcz & Hperm)"
.
iDestruct
"Hperm"
as
%
Hperm
.
wp_pures
.
rewrite
(
tail_protocol_unfold
([
x1
]
++
xs1'
)).
wp_apply
(
recv_proto_spec
N
with
"[Hcy]"
)=>
//=.
iIntros
(
b
)
"Hcy HP"
.
destruct
b
;
last
first
.
{
iRevert
"HP"
.
iIntros
([
Hsorted
Hperm'
]).
apply
Permutation_nil_cons
in
Hperm'
.
inversion
Hperm'
.
}
iClear
"HP"
.
wp_apply
(
recv_proto_spec
N
with
"[Hcy]"
)=>
//=.
iIntros
(
x
)
"Hcy _"
.
wp_apply
(
loop_sort_service_merge_spec
_
_
_
(
x1
::
x2
::
xs'
)
(
x1
::
xs1'
)
(
x2
::
xs2'
)
_
[]
[]
with
"[Hc Hcy Hcz]"
)=>
//.
simpl
.
rewrite
-
Permutation_middle
.
apply
Permutation_cons
.
apply
Permutation_cons
.
done
.
simpl
.
iFrame
.
iIntros
"(Hc & Hcy & Hcz)"
.
by
iApply
"HΨ"
.
+
rewrite
(
tail_protocol_unfold
[
x1
]
[]).
wp_apply
(
send_proto_spec
N
with
"[Hc]"
)=>
//=.
iExists
cont
.
iSplitR
=>
//.
iSplitR
=>
//.
iNext
.
iIntros
"Hc"
.
wp_apply
(
send_proto_spec
N
with
"[Hc]"
)=>
//=.
iExists
x1
.
iSplitR
=>
//.
iSplitR
=>
//.
iNext
.
iIntros
"Hc"
.
rewrite
(
tail_protocol_unfold
[
x1
]
[
x1
]).
wp_apply
(
send_proto_spec
N
with
"[Hc]"
)=>
//=.
iExists
stop
.
iSplitR
=>
//.
iSplitR
=>
//=.
*
eauto
10
with
iFrame
.
*
iNext
.
iIntros
"Hc"
.
by
iApply
"HΨ"
.
-
wp_pures
.
rewrite
(
tail_protocol_unfold
[]
[]).
wp_apply
(
send_proto_spec
N
with
"[Hc]"
)=>
//=.
iExists
false
.
iSplitR
=>//.
iSplitR
=>//.
iNext
.
iIntros
"Hc"
.
iApply
"HΨ"
.
iApply
"Hc"
.
Qed
.
End
list_sort_elem
.
\ No newline at end of file
Write
Preview
Supports
Markdown
0%
Try again
or
attach a new file
.
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment