Commit 13438299 authored by Heiko Becker's avatar Heiko Becker

FF CakeML and finish porting of proofs to new finite maps for analysis result and type map

parent b62b0ee7
......@@ -106,7 +106,7 @@ val CertificateCmd_checking_is_sound = store_thm ("CertificateCmd_checking_is_so
\\ rpt strip_tac
\\ `?outVars. ssa f (freeVars f) outVars` by (match_mp_tac validSSA_sound \\ fs[])
\\ qspecl_then
[`f`, `A`, `E1`, `freeVars f`, `LN`, `outVars`, `elo`, `ehi`, `err`, `P`, `defVars`]
[`f`, `A`, `E1`, `freeVars f`, `LN`, `outVars`, `P`, `defVars`]
destruct validIntervalboundsCmd_sound
\\ fs[dVars_range_valid_def, vars_typed_def, fVars_P_sound_def]
\\ qspecl_then
......
open preamble
open MachineTypeTheory ExpressionAbbrevsTheory
open MachineTypeTheory ExpressionAbbrevsTheory DaisyTactics
val _ = new_theory "DaisyMap";
......@@ -32,6 +32,7 @@ val expCompare_def = Define `
else (if u1 = Neg then Lt else Gt)
| Unop _ _, Binop _ _ _ => Lt
| Unop _ _, Downcast _ _ => Lt
| Unop _ _, Fma _ _ _ => Lt
| Unop _ _, _ => Gt
| Downcast m1 e1, Downcast m2 e2 =>
if m1 = m2
......@@ -59,7 +60,24 @@ val expCompare_def = Define `
| Lt => Lt
| Gt => Gt)
| _ => res)
|_ , _ => Gt`;
| Fma e1 e2 e3, Fma e4 e5 e6 =>
(case expCompare e1 e4 of
| Eq =>
(case expCompare e2 e5 of
| Eq => expCompare e3 e6
| Lt => Lt
| Gt => Gt)
| Lt => Lt
| Gt => Gt)
| _ , Fma e1 e2 e3 => Lt
| Fma e1 e2 e3, _ => Gt
|_ , _ => Gt`;
val expCompare_refl = store_thm (
"expCompare_refl",
``!e. expCompare e e = Eq``,
Induct \\ rpt strip_tac \\ simp[ Once expCompare_def]
\\ Cases_on `b` \\ fs[] );
val DaisyMapList_insert_def = Define `
(DaisyMapList_insert e k NIL = [(e,k)]) /\
......@@ -81,12 +99,12 @@ val DaisyMapTree_insert_def = Define `
(DaisyMapTree_insert e k (Leaf (e1,k1)) =
case (expCompare e e1) of
| Lt => Node (e1,k1) (Leaf (e,k)) (LeafN)
| Eq => Leaf (e1,k1)
| Eq => Leaf (e1,k)
| Gt => Node (e1,k1) (LeafN) (Leaf (e,k))) /\
(DaisyMapTree_insert e k (Node (e1,k1) tl tr) =
case (expCompare e e1) of
| Lt => Node (e1,k1) (DaisyMapTree_insert e k tl) tr
| Eq => (Node (e1, k1) tl tr)
| Eq => (Node (e1, k) tl tr)
| Gt => Node (e1,k1) tl (DaisyMapTree_insert e k tr))`;
val DaisyMapTree_find_def = Define `
......@@ -108,6 +126,28 @@ val DaisyMapTree_mem_def = Define `
val DaisyMapTree_empty_def = Define `
DaisyMapTree_empty = LeafN `;
val DaisyMapTree_find_injective = store_thm (
"DaisyMapTree_find_injective",
``!e a b Tree.
DaisyMapTree_find e Tree = SOME a /\
DaisyMapTree_find e Tree = SOME b ==>
a = b``,
rpt strip_tac
\\ Cases_on `Tree` \\ fs[DaisyMapTree_find_def]);
val DaisyMapTree_correct = store_thm (
"DaisyMapTree_correct",
``!Tree k v.
DaisyMapTree_find k (DaisyMapTree_insert k v Tree) = SOME v``,
Induct_on `Tree`
\\ fs[DaisyMapTree_find_def, DaisyMapTree_insert_def]
\\ rpt strip_tac \\ fs[expCompare_refl]
>- (Cases_on `a` \\ fs[DaisyMapTree_insert_def]
\\ Cases_on `expCompare k q` \\ fs[DaisyMapTree_find_def]
\\ first_x_assum irule \\ fs[])
\\ Cases_on `a` \\ fs[DaisyMapTree_insert_def]
\\ Cases_on `expCompare k q` \\ fs[DaisyMapTree_find_def, expCompare_refl]);
val _ = type_abbrev ("typeMap", ``:(real exp # mType) binTree``);
val _ = type_abbrev ("analysisResult", ``:(real exp # ((real # real) # real)) binTree``);
......
This diff is collapsed.
......@@ -379,7 +379,7 @@ val swap_Gamma_bstep = store_thm (
>- (irule swap_Gamma_eval_exp \\ qexists_tac `Gamma1` \\ fs[]));
val validIntervalboundsCmd_sound = store_thm ("validIntervalboundsCmd_sound",
``!f A E fVars dVars outVars elo ehi err P Gamma.
``!f A E fVars dVars outVars P Gamma.
ssa f (union fVars dVars) outVars /\
dVars_range_valid dVars E A /\
fVars_P_sound fVars E P /\
......
......@@ -30,8 +30,6 @@ val typeExpression_def = Define `
| SOME m1 => if (morePrecise m1 m) then SOME m else NONE
| NONE => NONE`;
!eval_funs;
add_unevaluated_function ``typeExpression``;
val typeMap_def = Define `
......
Subproject commit 19c41e5bac090d86a4245e2b6054ef710c42a402
Subproject commit 800745426c5c2ef2f5c5475c26640641dd222f04
open preamble
open simpLib (* realTheory *)realLib RealArith stringTheory
open simpLib realTheory realLib RealArith stringTheory
open ml_translatorTheory ml_translatorLib cfTacticsLib basisProgTheory
......@@ -234,9 +234,12 @@ val validerrorboundcmd_side_def = fetch "-" "validerrorboundcmd_side_def";
val certificatecheckercmd_side_def = fetch "-" "certificatecheckercmd_side_def";
val precond_validIntervalbounds_true = prove (
``!e absenv P (dVars:num_set).
(!v. v IN (domain dVars) ==> valid (FST (absenv (Var v)))) ==>
validintervalbounds_side e absenv P dVars``,
``!e A P (dVars:num_set).
(!v. v IN (domain dVars) ==>
?iv err.
DaisyMapTree_find (Var v) A = SOME (iv, err) /\
valid iv) ==>
validintervalbounds_side e A P dVars``,
recInduct validIntervalbounds_ind
\\ rw[]
\\ once_rewrite_tac [validintervalbounds_side_def]
......@@ -245,37 +248,37 @@ val precond_validIntervalbounds_true = prove (
>- (once_rewrite_tac [GSYM noDivzero_def]
\\ rpt strip_tac
\\ rveq
\\ `valid (FST(absenv e))`
by (irule validIntervalbounds_validates_iv
\\ qexistsl_tac [`P`, `validVars`]
\\ fs[])
\\ rename1 `DaisyMapTree_find e absenv = SOME (iv_e, err_e)`
\\ `valid iv_e`
by (drule validIntervalbounds_validates_iv
\\ disch_then (qspecl_then [`e`, `P`] destruct)
\\ fs[] \\ rveq \\ fs[])
\\ once_rewrite_tac [invertinterval_side_def]
\\ rw_asm `absenv e = _`
\\ Cases_on `x2` \\ rename1 `absenv e = ((elo,ehi),err)`
\\ qpat_x_assum `!v. _` kall_tac
\\ qpat_x_assum `!intv. _` kall_tac
\\ fs [IVlo_def, IVhi_def, valid_def, noDivzero_def]
\\ rpt (qpat_x_assum `!v. _` kall_tac)
\\ fs [valid_def, noDivzero_def]
\\ REAL_ASM_ARITH_TAC)
>- (once_rewrite_tac [GSYM noDivzero_def]
\\ rpt strip_tac
\\ rveq
\\ once_rewrite_tac [divideinterval_side_def]
\\ once_rewrite_tac [invertinterval_side_def]
\\ `valid (FST(absenv e0))`
by (irule validIntervalbounds_validates_iv
\\ qexistsl_tac [`P`, `validVars`]
\\ fs[])
\\ Cases_on `x4` \\ rename1 `absenv e0 = ((elo,ehi),err)`
\\ qpat_x_assum `!v. _` kall_tac
\\ rpt (qpat_x_assum `!intv. _` kall_tac)
\\ qpat_x_assum `absenv e0 = _` (fn thm => fs [thm])
\\ fs [IVlo_def, IVhi_def, valid_def, noDivzero_def]
\\ rename1 `DaisyMapTree_find e0 absenv = SOME (iv_e, err_e)`
\\ `valid iv_e`
by (drule validIntervalbounds_validates_iv
\\ disch_then (qspecl_then [`e0`, `P`] destruct)
\\ fs[] \\ rveq \\ fs[])
\\ once_rewrite_tac [invertinterval_side_def]
\\ rpt (qpat_x_assum `!v. _` kall_tac)
\\ fs [valid_def, noDivzero_def]
\\ REAL_ASM_ARITH_TAC));
val precond_validIntervalboundsCmd_true = prove (
``!f absenv P (dVars:num_set).
(!v. v IN (domain dVars) ==> valid (FST (absenv (Var v)))) ==>
validintervalboundscmd_side f absenv P dVars``,
``!f A P (dVars:num_set).
(!v. v IN (domain dVars) ==>
?iv err.
DaisyMapTree_find (Var v) A = SOME (iv, err) /\
valid iv) ==>
validintervalboundscmd_side f A P dVars``,
recInduct validIntervalboundsCmd_ind
\\ rpt strip_tac
\\ once_rewrite_tac [validintervalboundscmd_side_def]
......@@ -289,10 +292,13 @@ val precond_validIntervalboundsCmd_true = prove (
\\ fs []));
val precond_validErrorbound_true = prove (``
!P f expTypes absenv (dVars:num_set).
(!v. v IN (domain dVars) ==> valid (FST (absenv (Var v)))) /\
validIntervalbounds f absenv P dVars ==>
validerrorbound_side f expTypes absenv dVars ``,
!P f expTypes A (dVars:num_set).
(!v. v IN (domain dVars) ==>
?iv err.
DaisyMapTree_find (Var v) A = SOME (iv, err) /\
valid iv) /\
validIntervalbounds f A P dVars ==>
validerrorbound_side f expTypes A dVars ``,
gen_tac
\\ recInduct validErrorbound_ind
\\ rpt gen_tac
......@@ -302,82 +308,77 @@ val precond_validErrorbound_true = prove (``
\\ once_rewrite_tac [GSYM noDivzero_def]
\\ rpt gen_tac \\ disch_then (fn thm => fs [thm] \\ ASSUME_TAC thm)
\\ rpt gen_tac
\\ ntac 2 (disch_then ASSUME_TAC)
\\ disch_then ASSUME_TAC
\\ rpt gen_tac
\\ rpt (disch_then assume_tac)
\\ rpt gen_tac
\\ conj_tac
>- (rpt strip_tac
\\ rveq
\\ fs[]
\\ first_x_assum irule
\\ rw_thm_asm `validIntervalbounds _ _ _ _` validIntervalbounds_def
\\ rw_asm_star `absenv _ = _`
\\ Cases_on `absenv x15`
\\ fs [])
\\ Daisy_compute ``validIntervalbounds``)
\\ conj_tac
>- (disch_then (fn thm => fs [thm] \\ ASSUME_TAC thm)
\\ conj_tac
>- (conj_tac \\ first_x_assum match_mp_tac
>- (conj_tac \\ rpt strip_tac \\ first_x_assum match_mp_tac
\\ fs [Once validIntervalbounds_def])
>- (disch_then ASSUME_TAC
\\ rpt gen_tac
\\ disch_then (fn thm => fs [thm] \\ ASSUME_TAC thm)
\\ rpt gen_tac
\\ disch_then (fn thm => fs [thm] \\ ASSUME_TAC thm)
\\ rpt (disch_then ASSUME_TAC)
\\ rveq
\\ rename1 `absenv (Binop Div e1 e2) = (ivDiv, errDiv)`
\\ rename1 `absenv e1 = (ive1,err1)`
\\ Cases_on `ive1` \\ rename1 `absenv e1 = ((e1lo,e1hi), err1)`
\\ rename1 `absenv e2 = (ive2,err2)`
\\ Cases_on `ive2` \\ rename1 `absenv e2 = ((e2lo,e2hi), err2)`
\\ rewrite_tac [divideinterval_side_def, widenInterval_def, minAbsFun_def, invertinterval_side_def, IVlo_def, IVhi_def]
\\ `valid (FST(absenv e1)) /\ valid (FST(absenv e2))`
by (conj_tac \\ drule validIntervalbounds_validates_iv
>- (disch_then match_mp_tac
\\ qexists_tac `P`
\\ fs [Once validIntervalbounds_def])
>- (disch_then match_mp_tac
\\ qexists_tac `P`
\\ fs [Once validIntervalbounds_def]))
\\ rw_asm `absenv e1 = _`
\\ rw_asm `absenv e2 = _`
\\ qpat_x_assum `!v. _` kall_tac
\\ `0 <= err2`
by (drule err_always_positive
\\ disch_then (fn thm => qspecl_then [`e2lo,e2hi`, `err2`] match_mp_tac thm)
\\ fs [])
\\ `e2lo - err2 <> 0 /\ e2hi + err2 <> 0`
by (fs [noDivzero_def, IVlo_def, IVhi_def, widenInterval_def, valid_def]
\\ conj_tac \\ REAL_ASM_ARITH_TAC)
\\ `noDivzero (SND (FST (absenv e2))) (FST (FST (absenv e2)))`
by (drule validIntervalbounds_noDivzero_real
\\ fs [])
\\ `abs (e2lo - err2) <> 0 /\ abs (e2hi + err2) <> 0`
by (REAL_ASM_ARITH_TAC)
\\ `min (abs (e2lo - err2)) (abs (e2hi + err2)) <> 0`
by (fs [min_def]
\\ Cases_on `abs (e2lo - err2) <= abs (e2hi + err2)`
\\ fs [] \\ REAL_ASM_ARITH_TAC)
\\ qpat_x_assum `absenv e2 = _` (fn thm => fs [thm])
\\ fs [noDivzero_def, valid_def, IVhi_def, IVlo_def]
\\ REAL_ASM_ARITH_TAC))
\\ disch_then assume_tac
\\ rpt gen_tac
\\ disch_then (fn thm => fs [thm] \\ ASSUME_TAC thm)
\\ rpt gen_tac
\\ disch_then (fn thm => fs [thm] \\ ASSUME_TAC thm)
\\ rpt (disch_then ASSUME_TAC)
\\ ntac 2 (rpt gen_tac \\ rpt (disch_then assume_tac))
\\ rveq
\\ rename1 `Binop Div e1 e2`
\\ rename1 `DaisyMapTree_find e1 A = SOME (iv_e1, err1)`
\\ rename1 `DaisyMapTree_find e2 A = SOME (iv_e2, err2)`
\\ rewrite_tac [divideinterval_side_def, widenInterval_def,
minAbsFun_def, invertinterval_side_def, IVlo_def,
IVhi_def]
\\ `valid iv_e1 /\ valid iv_e2`
by (conj_tac \\ drule validIntervalbounds_validates_iv
>- (disch_then (qspecl_then [`e1`, `P`] destruct)
\\ fs [Once validIntervalbounds_def] \\ rveq \\ fs[])
\\ disch_then (qspecl_then [`e2`, `P`] destruct)
\\ fs [Once validIntervalbounds_def] \\ rveq \\ fs[])
\\ qpat_x_assum `!v. _` kall_tac
\\ `0 <= err2`
by (drule err_always_positive
\\ disch_then (fn thm => qspecl_then [`iv_e2`, `err2`] match_mp_tac thm)
\\ fs [])
\\ `FST iv_e2 - err2 <> 0 /\ SND iv_e2 + err2 <> 0`
by (fs [noDivzero_def, IVlo_def, IVhi_def, widenInterval_def, valid_def]
\\ conj_tac \\ REAL_ASM_ARITH_TAC)
\\ `noDivzero (SND iv_e2) (FST iv_e2)`
by (drule validIntervalbounds_noDivzero_real
\\ fs [])
\\ `abs (FST iv_e2 - err2) <> 0 /\ abs (SND iv_e2 + err2) <> 0`
by (REAL_ASM_ARITH_TAC)
\\ `min (abs (FST iv_e2 - err2)) (abs (SND iv_e2 + err2)) <> 0`
by (fs [min_def]
\\ Cases_on `abs (FST iv_e2 - err2) <= abs (SND iv_e2 + err2)`
\\ fs [] \\ REAL_ASM_ARITH_TAC)
\\ fs [noDivzero_def, valid_def, IVhi_def, IVlo_def]
\\ REAL_ASM_ARITH_TAC)
\\ conj_tac
>- (disch_then (fn thm => fs [thm] \\ ASSUME_TAC thm)
\\ rpt conj_tac \\ first_x_assum match_mp_tac
\\ fs [Once validIntervalbounds_def])
>- (rpt strip_tac
\\ rveq
\\ Daisy_compute ``validIntervalbounds``
\\ first_x_assum irule \\ fs[])
\\ rpt strip_tac
\\ rveq
\\ fs[]
\\ first_x_assum irule
\\ rw_thm_asm `validIntervalbounds _ _ _ _` validIntervalbounds_def
\\ rw_asm_star `absenv _ = _`
\\ rw_asm_star `absenv (Downcast _ _) = _`);
\\ rveq \\ Daisy_compute ``validIntervalbounds``
\\ first_x_assum irule \\ fs[]);
val precond_errorbounds_true = prove (``
!P f expTypes absenv dVars.
(!v. v IN domain dVars ==> valid (FST (absenv (Var v)))) /\
validIntervalboundsCmd f absenv P dVars ==>
validerrorboundcmd_side f expTypes absenv dVars``,
!P f expTypes A dVars.
(!v. v IN (domain dVars) ==>
?iv err.
DaisyMapTree_find (Var v) A = SOME (iv, err) /\
valid iv) /\
validIntervalboundsCmd f A P dVars ==>
validerrorboundcmd_side f expTypes A dVars``,
gen_tac
\\ recInduct validErrorboundCmd_ind
\\ rpt strip_tac
......@@ -386,18 +387,17 @@ val precond_errorbounds_true = prove (``
>- (rpt strip_tac
>- (irule precond_validErrorbound_true \\ fs[]
\\ qexists_tac `P` \\ fs [])
>- (first_x_assum irule
\\ rpt (conj_tac)
\\ fs[]
>- (gen_tac
\\ Cases_on `v = n` \\ fs[]
\\ rveq
\\ rw_sym_asm `env e = _`
\\ drule validIntervalbounds_validates_iv
\\ disch_then drule \\ fs[])
>- (Cases_on `c` \\ fs [Once validIntervalboundsCmd_def])))
>- (irule precond_validErrorbound_true \\ fs[]
\\ qexists_tac `P` \\ fs []));
\\ first_x_assum irule
\\ rpt (conj_tac)
\\ fs[]
>- (gen_tac
\\ Cases_on `v = n` \\ fs[]
\\ rveq
\\ drule validIntervalbounds_validates_iv
\\ disch_then drule \\ fs[])
\\ Cases_on `c` \\ fs [Once validIntervalboundsCmd_def])
\\ irule precond_validErrorbound_true \\ fs[]
\\ qexists_tac `P` \\ fs []);
val precond_is_true = prove (
``!f absenv P expTypes.
......@@ -424,6 +424,7 @@ recInduct str_of_num_ind
\\ match_mp_tac LESS_TRANS
\\ qexists_tac `10 + 48` \\ fs []) |> update_precondition;
val res = translate runChecker_def;
(* -- I/O routines from here onwards -- *)
......
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