CatalaLang/catala
1
1
Fork 0
mirror of https://github.com/CatalaLang/catala.git synced 2024-09-20 00:41:05 +03:00
Code Issues Projects Releases Wiki Activity

Proved one complicated lift

Browse Source
This commit is contained in:
Denis Merigoux 2021-02-15 11:35:51 +01:00
parent adf16489bf
commit 9ffb0c134e
2 changed files with 122 additions and 49 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

40
doc/formalization/Catala.LambdaCalculus.fst
View File

@ -51,6 +51,7 @@ val is_value: exp -> Tot bool
let rec is_value e =
match e with
| EAbs _ _ _ | ELit _ | ENone -> true
| ESome (ELit (LError _)) -> false
| ESome e' -> is_value e'
| EList l -> is_value_list l
| _ -> false
@ -152,15 +153,10 @@ and step_match
and step_list
(e: exp)
(l: list exp{l << e /\ Cons? l})
(l: list exp{l << e})
: Tot (list_step_result) (decreases %[ e; 3; l ]) =
match l with
| [hd] -> if is_value hd then Bad else begin
match step hd with
| None -> Bad
| Some (ELit (LError err)) -> Error (ELit (LError err))
| Some hd' -> Good([hd'])
end
| [] -> Bad
| hd::tl -> begin
if is_value hd then
match step_list e tl with
@ -200,30 +196,29 @@ and step_fold_left
| false, _, _ -> begin
match step f with
| None -> None
| Some (ELit (LError err)) -> Some (ELit (LError err))
| Some f' -> Some (EFoldLeft f' init tau_init l tau_elt)
end
| true, false, _ -> begin
match step init with
| None -> None
| Some (ELit (LError err)) -> Some (ELit (LError err))
| Some init' -> Some (EFoldLeft f init' tau_init l tau_elt)
end
| true, true, false -> begin
match step l with
| None -> None
| Some (ELit (LError err)) -> Some (ELit (LError err))
| Some l' -> Some (EFoldLeft f init tau_init l' tau_elt)
end
| true, true, true -> begin
match l with
| EList [] -> Some init
| EList (hd::tl) ->
match f, init, l with
| ELit (LError err), _ , _
| _, ELit (LError err), _
| _, _, ELit (LError err) -> Some (ELit (LError err))
| _, _, EList [] -> Some init
| _, _, EList (hd::tl) ->
Some (EFoldLeft
f (EApp (EApp f init tau_init) hd tau_elt)
tau_init (EList tl) tau_elt
)
| ELit (LError err) -> Some (ELit (LError err))
| _ -> None
end
@ -231,14 +226,17 @@ and step (e: exp) : Tot (option exp) (decreases %[ e; 6 ]) =
match e with
| EApp e1 e2 tau_arg -> step_app e e1 e2 tau_arg
| EIf e1 e2 e3 -> step_if e e1 e2 e3
| ESome e1 -> if is_value e1 then None else begin
match step e1 with
| None -> None
| Some (ELit (LError err)) -> Some (ELit (LError err))
| Some e1' -> Some (ESome e1')
end
| ESome e1 ->
if is_value e1 then
match e1 with
| ELit (LError err) -> Some (ELit (LError err))
| _ -> None
else begin
match step e1 with
| None -> None
| Some e1' -> Some (ESome e1')
end
| EMatchOption arg tau_some none some -> step_match e arg tau_some none some
| EList [] -> None
| EList l -> begin match step_list e l with
| Bad -> None
| Error err -> Some err

131
doc/formalization/Catala.Translation.fst
View File

@ -434,8 +434,7 @@ let app_arg_lift
Classical.forall_intro (app_arg_lift_is_stepping_agnostic tau_arg tau e1);
app_arg_lift' tau_arg tau e1
(*
#push-options "--fuel 2 --ifuel 0"
#push-options "--fuel 9 --ifuel 2 --z3rlimit 20"
let exceptions_head_lift'
(tau: L.ty)
(tl: list L.exp{L.typing_list L.empty tl (L.TArrow L.TUnit tau)})
@ -443,41 +442,113 @@ let exceptions_head_lift'
(cons: (typed_l_exp tau))
: stepping_context tau tau
=
let e' = 2 in
let a' = 3 in
let e'' = 4 in
fun (hd: typed_l_exp tau) ->
let out = build_default_translation ((L.EAbs L.Silent L.TUnit hd)::tl) just cons tau in
build_default_translation_typing ((L.EAbs L.Silent L.TUnit hd)::tl) just cons tau L.empty;
out
typ_process_exceptions_f L.empty tau;
L.EMatchOption
(L.EFoldLeft
(process_exceptions_f tau)
(L.EApp
(L.EAbs (L.Named e') (L.TOption tau) (
L.EMatchOption L.ENone tau
(L.EVar e')
(L.EAbs (L.Named a') tau (
L.EMatchOption (L.EVar e') tau
L.ENone
(L.EAbs (L.Named e'') tau (L.ELit (L.LError L.ConflictError)))
))
))
(L.ECatchEmptyError
(L.ESome hd) L.ENone)
(L.TOption tau)
)
(L.TOption tau)
(L.EList tl) (L.TArrow L.TUnit tau))
tau
(L.EIf
just cons
(L.ELit (L.LError L.EmptyError)))
(L.EAbs (L.Named 0) tau (L.EVar 0))
#pop-options
#push-options "--fuel 1 --ifuel 1 --z3rlimit 10"
let rec exceptions_head_lift_is_stepping_agnostic
let exceptions_head_lift_is_stepping_agnostic
(tau: L.ty)
(tl: list L.exp{L.typing_list L.empty tl (L.TArrow L.TUnit tau)})
(just: (typed_l_exp L.TBool))
(cons: (typed_l_exp tau))
(n: nat)
(hd: typed_l_exp tau{Some? (take_l_steps tau hd n)})
: Lemma
(requires (True))
(ensures (
step_lift_commute_non_value
tau tau (exceptions_head_lift' tau tl just cons) n hd))
(decreases n)
(hd: typed_l_exp tau)
: Lemma (step_lift_commute_non_value tau tau (exceptions_head_lift' tau tl just cons) hd)
=
if n = 0 then () else begin
L.progress hd tau;
L.progress hd tau;
if L.is_value hd then () else begin
L.preservation hd tau;
let Some hd' = L.step hd in
exceptions_head_lift_is_stepping_agnostic tau tl just cons (n-1) hd';
let open FStar.Tactics in
assert(take_l_steps tau (exceptions_head_lift' tau tl just cons hd) n ==
Some (exceptions_head_lift' tau tl just cons (Some?.v (take_l_steps tau hd n)))) by begin
compute ();
tadmit ()
end
assert_norm(L.step (exceptions_head_lift' tau tl just cons hd) == Some
(exceptions_head_lift' tau tl just cons (Some?.v (L.step hd))))
end
let exceptions_head_lift
(tau: L.ty)
(tl: list L.exp{L.typing_list L.empty tl (L.TArrow L.TUnit tau)})
(just: (typed_l_exp L.TBool))
(cons: (typed_l_exp tau))
: stepping_agnostic_lift tau tau
=
Classical.forall_intro (exceptions_head_lift_is_stepping_agnostic tau tl just cons);
exceptions_head_lift' tau tl just cons
(**** Other helpers *)
#push-options "--fuel 7 --ifuel 2 --z3rlimit 50"
let steps_default_translation_head_error
(tau: L.ty)
(tl: list L.exp{L.typing_list L.empty tl (L.TArrow L.TUnit tau) /\ L.is_value_list tl})
(just: (typed_l_exp L.TBool))
(cons: (typed_l_exp tau))
(n_hd: nat)
(hd: typed_l_exp tau)
: Pure nat
(requires (True))
(ensures (fun extra_steps ->
build_default_translation_typing ((L.EAbs L.Silent L.TUnit hd)::tl) just cons tau L.empty;
take_l_steps tau (build_default_translation ((L.EAbs L.Silent L.TUnit hd)::tl)
just cons tau) (n_hd + extra_steps) ==
Some (L.ELit (L.LError L.ConflictError))))
=
build_default_translation_typing ((L.EAbs L.Silent L.TUnit hd)::tl) just cons tau L.empty;
let e' = 2 in
let a' = 3 in
let e'' = 4 in
let open FStar.Tactics in
assert(take_l_steps (L.TOption tau)
(L.EApp (L.EApp (process_exceptions_f tau) L.ENone (L.TOption tau))
(L.EAbs L.Silent L.TUnit hd) (L.TArrow L.TUnit tau)) 3 == Some
(L.EApp
(L.EAbs (L.Named e') (L.TOption tau) (
L.EMatchOption L.ENone tau
(L.EVar e')
(L.EAbs (L.Named a') tau (
L.EMatchOption (L.EVar e') tau
L.ENone
(L.EAbs (L.Named e'') tau (L.ELit (L.LError L.ConflictError)))
))
))
(L.ECatchEmptyError
(L.ESome hd) L.ENone)
(L.TOption tau)
)
) by begin
compute ()
end;
//assert(take_l_steps tau (build_default_translation ((L.EAbs L.Silent L.TUnit hd)::tl)
// just cons tau) 4 == Some (exceptions_head_lift' tau tl just cons hd)) by begin
// compute ();
// smt ()
//end;
admit()
#pop-options
*)
(**** Main theorems *)
let translation_correctness_value (e: D.exp) : Lemma
@ -497,7 +568,7 @@ let rec_correctness_step_type (de: D.exp) : Type =
))
(decreases df)
#push-options "--fuel 2 --ifuel 1 --z3rlimit 50"
#push-options "--fuel 2 --ifuel 1 --z3rlimit 150"
let translation_correctness_exceptions_left_to_right_step
(de: D.exp)
(dexceptions: list D.exp {dexceptions << de})
@ -559,7 +630,11 @@ let translation_correctness_exceptions_left_to_right_step
n_tl*)
end else begin
match D.step dhd with
| Some (D.ELit D.LConflictError) -> admit()
| Some (D.ELit D.LConflictError) ->
let n_hd = rec_lemma dhd dtau in
translation_preserves_empty_typ dhd dtau;
assert(take_l_steps ltau lhd n_hd == Some (L.ELit (L.LError L.ConflictError)));
admit()
| Some dhd' ->
let lhd' = translate_exp dhd' in
let n_hd = rec_lemma dhd dtau in