Commit 024abf5d authored by Heiko Becker's avatar Heiko Becker

WIP state of IV validator

parent b1a6c8eb
......@@ -109,6 +109,6 @@ val DaisyMapTree_empty_def = Define `
DaisyMapTree_empty = LeafN `;
val _ = type_abbrev ("typeMap", ``:(real exp # mType) binTree``);
val _ = type_abbrev ("DaisyMap", ``:(real exp # ((real # real) # real)) binTree``);
val _ = type_abbrev ("analysisResult", ``:(real exp # ((real # real) # real)) binTree``);
val _ = export_theory();
......@@ -11,6 +11,7 @@ val _ = new_theory "ExpressionAbbrevs"
We treat a function mapping an expression arguing on fractions as value type
to pairs of intervals on rationals and rational errors as the analysis result
**)
val _ = type_abbrev("analysisResult", ``:real exp->(interval # real)``);
(* val _ = type_abbrev("analysisResult", ``:real exp->(interval # real)``); *)
val _ = export_theory()
......@@ -112,61 +112,80 @@ fun daisy_eval_tac t :tactic=
\\ fs[sptreeTheory.lookup_def]
end;
fun case_destruct_tac thm =
let
val conclusion = concl thm;
val caseTerm = find_term TypeBase.is_case conclusion;
val (_, caseOn, _) = TypeBase.dest_case caseTerm
val _ = print ("Case analysis on ")
val _ = print_term caseOn in
BasicProvers.Cases_on `^caseOn`
end;
fun case_compute_tac pat =
qpat_x_assum pat
(fn thm => REPEAT (case_destruct_tac thm \\ fs[]));
fun type_manip f cst =
let
val holObj = dest_thy_const cst;
val t = #Ty holObj;
val (_, typeParamsList) = dest_type t in
f typeParamsList
end
(* Daisy Compute Tactic as in Coq dev to simplify goals involving computations *)
fun iter n s f =
if n = 0 then s
else iter (n - 1) (f s) f;
fun id x = x
fun getArgTypeList t num lst =
let val (name, list) = dest_type t in
case name of
"fun" =>
let
val (hdty, tylist) = (hd list, tl list) in
getArgTypeList (hd tylist) (num + 1) (hdty :: lst)
end
| _ => (num, rev lst)
end
fun foo t =
fun getPatTerm t =
let
val decl_list = decls (term_to_string t);
val num_list = map (type_manip length) decl_list;
val type_list = map (type_manip id) decl_list in
if length num_list = 1
val argTypes_list = map (fn t => getArgTypeList (#Ty (dest_thy_const t)) 0 []) decl_list in
if length decl_list = 1
then
let val cnt = hd num_list;
val ty = hd(hd type_list) in
iter cnt (t, ty)
(fn (t,ty) =>
let val (name, tyList) = dest_type ty;
val var = mk_var ("_",hd tyList);
val _ = print_term var;
val _ = print_term t in
(mk_comb (t, var), hd(tl tyList))
let
val (cnt, tyList) = hd argTypes_list
in
iter cnt (hd decl_list, tyList)
(fn (t,tyList) =>
let
val var = mk_var ("_",hd tyList) in
(* val _ = print_term var; *)
(* val _ = print_term t in *)
(mk_comb (t, var), tl tyList)
end)
end
else raise ERR "Too many constants" ""
end;
(* TODO PATTERN GENERATION!*)
foo ``typeCheck``
dest_comb (mk_comb (``typeCheck``,``_:real exp``))
dest_type (#Ty (dest_thy_const ``typeCheck``));
(* dest_term ``typeCheck _`` *)
(* This variable is supposed to hold all defined functions *)
val eval_funs:term list ref = ref [];
fun add_unevaluated_function (t:term) :unit =
eval_funs := t :: (!eval_funs);
fun Daisy_compute t =
let
val eval_thm = DB.theorem ((term_to_string t)^"_def");
val (pat,_) = getPatTerm t in
TRY (
Tactical.PAT_X_ASSUM
pat
(fn thm =>
let
val rwthm = ONCE_REWRITE_RULE [eval_thm] thm;
val compute_thm = computeLib.RESTR_EVAL_RULE (!eval_funs) rwthm in
assume_tac compute_thm end)
\\ fs[]
\\ TRY (
REPEAT (
qpat_assum `option_CASE _ _ _`
(fn thm =>
let
val (t,t2,_) = optionSyntax.dest_option_case (concl thm) in
Cases_on `^t2` \\ fs[] end)
\\ split_pair_case_tac \\ fs[])))
end;
(* val Daisy_compute:tactic = *)
(* fn (g:goal) => *)
(* let *)
(* val terms_to_eval = !eval_funs in *)
(* if (length terms_to_eval = 0) *)
(* then let val _ = print "Nothing to evaluate" in ALL_TAC g end *)
(* else *)
(* Daisy_compute_steps terms_to_eval g *)
(* end; *)
end
This diff is collapsed.
......@@ -27,6 +27,15 @@ val REAL_INV_LE_ANTIMONO_IMPR = store_thm ("REAL_INV_LE_ANTIMONO_IMPR",
``! x y. 0 < x /\ 0 < y /\ y <= x ==> inv x <= inv y``,
rpt strip_tac \\ fs[REAL_INV_LE_ANTIMONO]);
val REAL_INV_LE_ANTIMONO_IMPL = store_thm ("REAL_INV_LE_ANTIMONO_IMPL",
``! x y. x <0 /\ y < 0 /\ y <= x ==> inv x <= inv y``,
rpt strip_tac
\\ once_rewrite_tac [GSYM REAL_LE_NEG]
\\ `- inv y = inv (- y)` by (irule REAL_NEG_INV \\ REAL_ASM_ARITH_TAC)
\\ `- inv x = inv (- x)` by (irule REAL_NEG_INV \\ REAL_ASM_ARITH_TAC)
\\ ntac 2(FIRST_X_ASSUM (fn thm => once_rewrite_tac [ thm]))
\\ irule REAL_INV_LE_ANTIMONO_IMPR \\ fs[]);
val REAL_MUL_LE_COMPAT_NEG_L = store_thm( "REAL_MUL_LE_COMPAT_NEG_L",
``!(a:real) b c. a <= &0 /\ b <= c ==> a * c <= a * b``,
rpt strip_tac
......
open preamble miscTheory
open DaisyTactics
open realTheory realLib sptreeTheory ExpressionsTheory MachineTypeTheory
CommandsTheory DaisyMapTheory
IntervalValidationTheory CommandsTheory DaisyMapTheory
val _ = new_theory "Typing";
val typeExpression_def = Define `
val typeExpression_def = FDefine ``typeExpression`` `
typeExpression (Gamma: num -> mType option) (e: real exp) : mType option =
case e of
| Var v => Gamma v
......@@ -21,7 +21,7 @@ val typeExpression_def = Define `
let tm1 = typeExpression Gamma e1 in
case tm1 of
| SOME m1 => if (morePrecise m1 m) then SOME m else NONE
| NONE => NONE`
| NONE => NONE`;
(* val typeMap_def = Define ` *)
(* typeMap (Gamma: num -> mType option) (e: real exp) (e': real exp) : mType option = *)
......@@ -37,7 +37,7 @@ val typeExpression_def = Define `
(* | NONE, NONE => NONE) *)
(* | Downcast m e1 => if e = e' then typeExpression Gamma (Downcast m e1) else typeMap Gamma e1 e'` *)
val typeMap_def = Define `
val typeMap_def = FDefine ``typeMap`` `
typeMap (Gamma:num -> mType option) (e:real exp) (tMap:typeMap) =
if (DaisyMapTree_mem e tMap)
then tMap
......@@ -70,7 +70,7 @@ val typeMap_def = Define `
else DaisyMapTree_empty)
| _ => DaisyMapTree_empty)`;
val typeCmd_def = Define `
val typeCmd_def = FDefine ``typeCmd`` `
typeCmd (Gamma: num -> mType option) (f: real cmd) : mType option =
case f of
| Let m n e c => (case typeExpression Gamma e of
......@@ -95,7 +95,7 @@ val typeCmd_def = Define `
(* | NONE, NONE => NONE) *)
(* | Ret e => typeMap Gamma e f'` *)
val typeMapCmd_def = Define `
val typeMapCmd_def = FDefine ``typeMapCmd`` `
typeMapCmd (Gamma:num -> mType option) (f:real cmd) (tMap:typeMap) =
case f of
| Let m n e c =>
......@@ -110,7 +110,7 @@ val typeMapCmd_def = Define `
| _ => DaisyMapTree_empty)
| Ret e => typeMap Gamma e tMap`;
val typeCheck_def = Define `
val typeCheck_def = FDefine ``typeCheck`` `
typeCheck (e:real exp) (Gamma: num -> mType option) (tMap:typeMap) : bool =
case e of
| Var v => (case DaisyMapTree_find e tMap, Gamma v of
......@@ -134,7 +134,7 @@ val typeCheck_def = Define `
/\ typeCheck e1 Gamma tMap
| _, _ => F)`
val typeCheckCmd_def = Define `
val typeCheckCmd_def = FDefine ``typeCheckCmd`` `
typeCheckCmd (c: real cmd) (Gamma: num -> mType option) (tMap:typeMap) : bool =
case c of
| Let m x e g => if (typeCheck e Gamma tMap)
......@@ -153,18 +153,8 @@ val typingSoundnessExp = store_thm("typingSoundnessExp",
(DaisyMapTree_find e expTypes = SOME m)``,
Induct_on `e`
\\ rpt strip_tac
\\ inversion `eval_exp E Gamma _ _ _` eval_exp_cases \\ fs[]
\\ qpat_x_assum `typeCheck _ _ _`
(fn thm =>
assume_tac (computeLib.RESTR_EVAL_RULE (decls "typeCheck") (ONCE_REWRITE_RULE [typeCheck_def] thm)))
\\ TRY ( REPEAT (
qpat_assum `option_CASE _ _ _`
(fn thm =>
let
val (t,t2,_) = optionLib.dest_option_case (concl thm);
val _ = print_term t2 in
Cases_on `^t2` \\ fs[] end)))
\\ rveq
\\ Daisy_compute ``typeCheck``
\\ inversion `eval_exp E Gamma _ _ _` eval_exp_cases \\ fs[] \\ rveq
>- (first_x_assum drule
\\ fs[]
\\ rpt (disch_then drule) \\ fs[])
......@@ -177,24 +167,15 @@ val typingSoundnessExp = store_thm("typingSoundnessExp",
\\ fs[] \\ rpt (disch_then drule) \\ fs[join_def]);
val typingSoundnessCmd = store_thm("typingSoundnessCmd",
``!(c:real cmd) (Gamma:num -> mType option) (E:env) (v:real) (m:mType) (expTypes:real exp -> mType option).
``!(c:real cmd) (Gamma:num -> mType option) (E:env) (v:real) (m:mType) (expTypes:typeMap).
typeCheckCmd c Gamma expTypes /\
bstep c E Gamma v m ==>
(expTypes (getRetExp c) = SOME m)``,
Induct_on `c` \\ rpt strip_tac \\ fs []
>- (qpat_x_assum `typeCheckCmd _ _ _` (fn thm => assume_tac (ONCE_REWRITE_RULE [typeCheckCmd_def] thm))
\\ fs []
\\ Cases_on `expTypes (Var n)` \\ fs []
\\ Cases_on `expTypes e` \\ fs []
\\ once_rewrite_tac [getRetExp_def] \\ fs []
\\ inversion `bstep _ _ _ _ _` bstep_cases
\\ res_tac
\\ first_x_assum irule
\\ rveq
(DaisyMapTree_find (getRetExp c) expTypes = SOME m)``,
Induct_on `c` \\ rpt strip_tac \\ Daisy_compute ``typeCheckCmd``
\\ inversion `bstep _ _ _ _ _` bstep_cases
\\ fs [getRetExp_def] \\ rveq
>- (first_x_assum drule \\ disch_then drule
\\ fs[])
>- (fs [getRetExp_def]
\\ qpat_x_assum `typeCheckCmd _ _ _` (fn thm => assume_tac (ONCE_REWRITE_RULE [typeCheckCmd_def] thm)) \\ fs []
\\ inversion `bstep _ _ _ _ _` bstep_cases
\\ metis_tac [typingSoundnessExp]));
\\ metis_tac [typingSoundnessExp]);
val _ = export_theory();
Subproject commit 4273d509b99f86716a40d18895a091bbd043f24d
Subproject commit c760e35a371970c83a07a154bb67d4b842115a1f
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