Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

Merge branch 'logging' into standalonetac

  • Loading branch information...
commit beb0771801c1ed8b8b70a571058fc8164e73a40b 2 parents 7926a17 + 3e8ecc5
@xrchz xrchz authored
Showing with 657 additions and 33 deletions.
  1. +1 −0  examples/theorem-prover/Makefile
  2. +2 −2 examples/theorem-prover/README
  3. +84 −0 examples/theorem-prover/lisp-runtime/bytecode/lisp_compilerScript.sml
  4. +2 −0  examples/theorem-prover/lisp-runtime/extract/Holmakefile
  5. +6 −2 examples/theorem-prover/{milawa-prover → lisp-runtime/extract}/lisp_extractLib.sig
  6. +167 −1 examples/theorem-prover/{milawa-prover → lisp-runtime/extract}/lisp_extractLib.sml
  7. +33 −0 examples/theorem-prover/{milawa-prover → lisp-runtime/extract}/lisp_extractScript.sml
  8. +11 −0 examples/theorem-prover/lisp-runtime/extract/lisp_synthesisLib.sig
  9. +50 −0 examples/theorem-prover/lisp-runtime/extract/lisp_synthesisLib.sml
  10. +72 −0 examples/theorem-prover/lisp-runtime/extract/lisp_synthesis_demoScript.sml
  11. +1 −1  examples/theorem-prover/milawa-prover/Holmakefile
  12. +46 −0 examples/theorem-prover/milawa-prover/core.lisp
  13. +2 −0  examples/theorem-prover/milawa-prover/milawa_defsScript.sml
  14. +34 −0 examples/theorem-prover/milawa-prover/milawa_execScript.sml
  15. +141 −20 examples/theorem-prover/milawa-prover/milawa_proofpScript.sml
  16. +1 −0  src/marker/markerScript.sml
  17. +4 −7 src/num/theories/arithmeticScript.sml
View
1  examples/theorem-prover/Makefile
@@ -8,5 +8,6 @@ clean:
cd lisp-runtime/implementation && Holmake cleanAll && cd ../..
cd lisp-runtime/parse && Holmake cleanAll && cd ../..
cd lisp-runtime/spec && Holmake cleanAll && cd ../..
+ cd lisp-runtime/extract && Holmake cleanAll && cd ../..
cd milawa-prover && Holmake cleanAll && cd ..
cd milawa-prover/soundness-thm && Holmake cleanAll && cd ../..
View
4 examples/theorem-prover/README
@@ -19,8 +19,8 @@ Two subdirectories:
The top-level result is in milawa-prover/soundness-thm where a theorem
states: when Milawa is run on top of the verified runtime it will only
-ever prove statements that can be derived from the (sound!) inference
-rules -- no matter how reflection or any other feature is used.
+ever prove statements that are true w.r.t. the semantics of Milawa's
+formulas -- no matter how reflection or any other feature is used.
Copyright Magnus O. Myreen 2012
View
84 examples/theorem-prover/lisp-runtime/bytecode/lisp_compilerScript.sml
@@ -2883,6 +2883,90 @@ val term2sexp_def = tDefine "term2sexp" `
THEN1 (Induct_on `zs` \\ NTAC 2 (SRW_TAC [] [MEM,term_size_def]) \\ RES_TAC \\ DECIDE_TAC)
\\ DECIDE_TAC);
+val fun_name_ok_def = Define `
+ (fun_name_ok (Fun f) = ~MEM f reserved_names) /\
+ (fun_name_ok _ = T)`;
+
+val no_bad_names_def = tDefine "no_bad_names" `
+ (no_bad_names (Const s) = T) /\
+ (no_bad_names (Var v) = ~(v = "T") /\ ~(v = "NIL")) /\
+ (no_bad_names (App fc vs) = fun_name_ok fc /\ EVERY no_bad_names vs) /\
+ (no_bad_names (If x y z) = no_bad_names x /\ no_bad_names y /\ no_bad_names z) /\
+ (no_bad_names (LamApp xs z ys) = no_bad_names z /\ EVERY no_bad_names ys) /\
+ (no_bad_names (Let zs x) = EVERY (\x. no_bad_names (SND x)) zs /\ no_bad_names x) /\
+ (no_bad_names (LetStar zs x) = EVERY (\x. no_bad_names (SND x)) zs /\ no_bad_names x) /\
+ (no_bad_names (Cond qs) = EVERY (\x. no_bad_names (FST x) /\ no_bad_names (SND x)) qs) /\
+ (no_bad_names (Or ts) = EVERY no_bad_names ts) /\
+ (no_bad_names (And ts) = EVERY no_bad_names ts) /\
+ (no_bad_names (List ts) = EVERY no_bad_names ts) /\
+ (no_bad_names (First x) = no_bad_names x) /\
+ (no_bad_names (Second x) = no_bad_names x) /\
+ (no_bad_names (Third x) = no_bad_names x) /\
+ (no_bad_names (Fourth x) = no_bad_names x) /\
+ (no_bad_names (Fifth x) = no_bad_names x) /\
+ (no_bad_names (Defun fname ps s) = T)`
+ (WF_REL_TAC `measure (term_size)` \\ SRW_TAC [] []
+ THEN1 (Induct_on `vs` \\ SRW_TAC [] [MEM,term_size_def] \\ RES_TAC \\ DECIDE_TAC)
+ THEN1 DECIDE_TAC
+ THEN1 DECIDE_TAC
+ THEN1 (Induct_on `qs` \\ NTAC 2 (SRW_TAC [] [MEM,term_size_def]) \\ RES_TAC \\ DECIDE_TAC)
+ THEN1 (Induct_on `qs` \\ NTAC 2 (SRW_TAC [] [MEM,term_size_def]) \\ RES_TAC \\ DECIDE_TAC)
+ THEN1 DECIDE_TAC
+ THEN1 (Induct_on `ts` \\ SRW_TAC [] [MEM,term_size_def] \\ RES_TAC \\ DECIDE_TAC)
+ THEN1 (Induct_on `ts` \\ SRW_TAC [] [MEM,term_size_def] \\ RES_TAC \\ DECIDE_TAC)
+ THEN1 (Induct_on `ts` \\ SRW_TAC [] [MEM,term_size_def] \\ RES_TAC \\ DECIDE_TAC)
+ THEN1 (Induct_on `ys` \\ SRW_TAC [] [MEM,term_size_def] \\ RES_TAC \\ DECIDE_TAC)
+ THEN1 (Induct_on `zs` \\ NTAC 2 (SRW_TAC [] [MEM,term_size_def]) \\ RES_TAC \\ DECIDE_TAC)
+ THEN1 (Induct_on `zs` \\ NTAC 2 (SRW_TAC [] [MEM,term_size_def]) \\ RES_TAC \\ DECIDE_TAC)
+ \\ DECIDE_TAC);
+
+val sexp2list_list2sexp = prove(
+ ``!x. sexp2list (list2sexp x) = x``,
+ Induct \\ EVAL_TAC \\ ASM_SIMP_TAC std_ss []);
+
+val MAP_EQ_IMP = prove(
+ ``!xs f. (!x. MEM x xs ==> (f x = x)) ==> (MAP f xs = xs)``,
+ Induct \\ SIMP_TAC (srw_ss()) [] \\ REPEAT STRIP_TAC \\ METIS_TAC []);
+
+val sexp2term_term2sexp = store_thm("sexp2term_term2sexp",
+ ``!t. no_bad_names t ==> (sexp2term (term2sexp t) = t)``,
+ HO_MATCH_MP_TAC (fetch "-" "term2sexp_ind") \\ REPEAT STRIP_TAC
+ \\ FULL_SIMP_TAC std_ss [no_bad_names_def]
+ THEN1 (EVAL_TAC \\ FULL_SIMP_TAC std_ss [])
+ THEN1 (EVAL_TAC \\ FULL_SIMP_TAC std_ss [])
+ THEN1
+ (SIMP_TAC (srw_ss()) [term2sexp_def,LET_DEF]
+ \\ Cases_on `fc` THEN TRY
+ (ASM_SIMP_TAC (srw_ss()) [func2sexp_def,list2sexp_def,CAR_def,CDR_def,isVal_def,isSym_def]
+ \\ SIMP_TAC (srw_ss()) [Once sexp2term_def,LET_DEF] \\ TRY (Cases_on `l`)
+ \\ ASM_SIMP_TAC (srw_ss()) [list2sexp_def,CAR_def,CDR_def,isVal_def,isSym_def,
+ getSym_def,prim2sym_def,sym2prim_def,sexp2list_list2sexp,
+ MAP_MAP_o,combinTheory.o_DEF,fun_name_ok_def]
+ \\ MATCH_MP_TAC MAP_EQ_IMP \\ FULL_SIMP_TAC std_ss [EVERY_MEM] \\ NO_TAC)
+ \\ FULL_SIMP_TAC (srw_ss()) [func2sexp_def,fun_name_ok_def]
+ \\ FULL_SIMP_TAC (srw_ss()) [reserved_names_def,MEM,APPEND,macro_names_def]
+ \\ SIMP_TAC (srw_ss()) [Once sexp2term_def,LET_DEF]
+ \\ ASM_SIMP_TAC (srw_ss()) [list2sexp_def,CAR_def,CDR_def,isVal_def,isSym_def,
+ getSym_def,prim2sym_def,sym2prim_def,sexp2list_list2sexp,
+ MAP_MAP_o,combinTheory.o_DEF]
+ \\ MATCH_MP_TAC MAP_EQ_IMP \\ FULL_SIMP_TAC std_ss [EVERY_MEM])
+ THEN1
+ (SIMP_TAC (srw_ss()) [term2sexp_def,Once sexp2term_def,LET_DEF]
+ \\ ASM_SIMP_TAC (srw_ss()) [list2sexp_def,CAR_def,CDR_def,isVal_def,isSym_def])
+ THEN
+ (SIMP_TAC (srw_ss()) [term2sexp_def,Once sexp2term_def,LET_DEF]
+ \\ ASM_SIMP_TAC (srw_ss()) [list2sexp_def,CAR_def,CDR_def,isVal_def,isSym_def,
+ getSym_def,sym2prim_def,sexp2list_list2sexp,MAP_MAP_o,combinTheory.o_DEF]
+ \\ MATCH_MP_TAC MAP_EQ_IMP \\ FULL_SIMP_TAC std_ss [EVERY_MEM]));
+
+val verified_string_def = Define `
+ verified_string xs =
+ if ~ALL_DISTINCT (MAP FST xs) then NONE else
+ if ~EVERY (\(name,params,body). no_bad_names body) xs then NONE else
+ SOME (FLAT (MAP ( \ (name,params,body). sexp2string
+ (list2sexp [Sym "DEFUN"; Sym name;
+ list2sexp (MAP Sym params); term2sexp body]) ++ "\n") xs))`
+
(* translation sexp2sexp *)
View
2  examples/theorem-prover/lisp-runtime/extract/Holmakefile
@@ -0,0 +1,2 @@
+INCLUDES = ../parse ../spec ../bytecode
+OPTIONS=QUIT_ON_FAILURE
View
8 .../theorem-prover/milawa-prover/lisp_extractLib.sig → ...m-prover/lisp-runtime/extract/lisp_extractLib.sig
@@ -3,14 +3,18 @@ sig
include Abbrev
- (* main functions *)
+ (* main functions for extraction *)
val pure_extract : string -> tactic option -> thm
val pure_extract_mutual_rec : string list -> tactic option -> thm
val impure_extract : string -> tactic option -> thm
val impure_extract_cut : string -> tactic option -> thm
- (* setting the state *)
+ (* function used for code synthesis *)
+
+ val deep_embeddings : string -> (thm * thm) list -> thm * thm list
+
+ (* setting the state of the extractor *)
val set_lookup_thm : thm -> unit
val install_assum_eq : thm -> unit
View
168 .../theorem-prover/milawa-prover/lisp_extractLib.sml → ...m-prover/lisp-runtime/extract/lisp_extractLib.sml
@@ -78,7 +78,6 @@ fun dest_primitive_op tm =
if tm = ``opSYMBOL_LESS`` then op_SYMBOL_LESS else
if tm = ``opADD`` then op_ADD else
if tm = ``opSUB`` then op_SUB else
- if tm = ``opATOMP`` then op_ATOMP else
if tm = ``opCONSP`` then op_CONSP else
if tm = ``opSYMBOLP`` then op_SYMBOLP else
if tm = ``opNATP`` then op_NATP else
@@ -130,6 +129,85 @@ fun dest_term tm = let
end
+(* mapping from shallow embeddings to deep embeddings *)
+
+infix $$
+val op $$ = mk_comb
+
+val string_uppercase = let
+ fun uppercase_char c =
+ if #"a" <= c andalso c <= #"z" then chr (ord c - (ord #"a" - ord #"A")) else c
+ in String.translate (fn c => implode [uppercase_char c]) end
+
+fun shallow_to_deep tm = let
+ fun fromHOLstring s = string_uppercase (stringSyntax.fromHOLstring s)
+ fun fromMLstring s = stringSyntax.fromMLstring (string_uppercase s)
+ fun is_const tm =
+ (if rator tm = ``Sym`` then can fromHOLstring (rand tm) else
+ if rator tm = ``Val`` then can numSyntax.int_of_term (rand tm) else
+ if rator (rator tm) = ``Dot`` then is_const (rand (rator tm)) andalso
+ is_const (rand tm)
+ else false) handle HOL_ERR _ => false
+ val lisp_primitives =
+ [(``Dot``,``opCONS``),
+ (``LISP_CONS``,``opCONS``),
+ (``LISP_EQUAL:SExp->SExp->SExp``,``opEQUAL``),
+ (``LISP_LESS``,``opLESS``),
+ (``LISP_SYMBOL_LESS``,``opSYMBOL_LESS``),
+ (``LISP_ADD``,``opADD``),
+ (``LISP_SUB``,``opSUB``),
+ (``LISP_CONSP``,``opCONSP``),
+ (``LISP_SYMBOLP``,``opSYMBOLP``),
+ (``LISP_NUMBERP``,``opNATP``),
+ (``CAR``,``opCAR``),
+ (``CDR``,``opCDR``)]
+ fun aux_fail tm =
+ failwith("Unable to translate: \n\n" ^ term_to_string tm ^ "\n\n")
+ fun aux tm =
+ if is_const tm then ``Const`` $$ tm else
+ if can (match_term ``Val n``) tm then aux_fail tm else
+ if can (match_term ``Sym s``) tm then aux_fail tm else
+ if is_var tm then let
+ val (s,ty) = dest_var tm
+ val _ = ty = ``:SExp`` orelse failwith("Variable of wrong type: " ^ s)
+ in ``Var`` $$ fromMLstring s end
+ else if is_cond tm then let
+ val (x1,x2,x3) = dest_cond tm
+ val _ = if rator x1 = ``isTrue`` then () else aux_fail x1
+ in ``If`` $$ aux (rand x1) $$ aux x2 $$ aux x3 end
+ else if can pairSyntax.dest_anylet tm then let
+ val (xs,x) = pairSyntax.dest_anylet tm
+ val ys = map (fn (x,y) => pairSyntax.mk_pair(x |> dest_var |> fst |> fromMLstring, aux y)) xs
+ val y = listSyntax.mk_list(ys,``:string # term``)
+ in ``Let`` $$ y $$ (aux x) end
+ else (* general function application *) let
+ fun list_dest f tm = let val (x,y) = f tm in list_dest f x @ [y] end
+ handle HOL_ERR _ => [tm];
+ val xs = list_dest dest_comb tm
+ val (x,xs) = (hd xs, tl xs)
+ fun lookup x [] = fail()
+ | lookup x ((y,z)::zs) = if x = y then z else lookup x zs
+ val f = ``PrimitiveFun`` $$ lookup x lisp_primitives handle HOL_ERR _ =>
+ ``Fun`` $$ fromMLstring (fst (dest_const x))
+ handle HOL_ERR _ => aux_fail x
+ val ys = map aux xs
+ in ``App`` $$ f $$ listSyntax.mk_list(ys,``:term``) end
+ fun preprocess tm = QCONV (REWRITE_CONV [isTrue_INTRO]) tm
+ val th = preprocess tm
+ val tm2 = rand (concl th)
+ in (aux tm2, th) end
+
+(*
+val tm = ``let x = LISP_ADD x y in let z = y in LISP_SUB x y``
+dest_term (fst (shallow_to_deep tm))
+
+ plan: provide a method which, given a list of definition and
+ induction thm pairs, produces deep embeddings and correspondence
+ proofs.
+
+*)
+
+
(* state of extraction function *)
local
@@ -775,4 +853,92 @@ fun impure_extract name term_tac =
fun impure_extract_cut name term_tac =
impure_extract_aux name term_tac true
+
+(* generator *)
+
+fun deep_embeddings base_name defs_inds = let
+ (* generate deep embeddings *)
+ fun fromMLstring s = stringSyntax.fromMLstring (string_uppercase s)
+ fun parts (def,ind) = let
+ val (x,y) = dest_eq (concl (SPEC_ALL def))
+ val (body,rw) = shallow_to_deep y
+ fun list_dest f tm = let val (x,y) = f tm in list_dest f x @ [y] end
+ handle HOL_ERR _ => [tm];
+ val xs = list_dest dest_comb x
+ val params = xs |> tl |> map (fst o dest_var)
+ val name = xs |> hd |> dest_const |> fst
+ val strs = listSyntax.mk_list(map fromMLstring params,``:string``)
+ val x1 = pairSyntax.mk_pair(strs,body)
+ val x1 = pairSyntax.mk_pair(fromMLstring name,x1)
+ in (name,params,def,ind,body,rw,x1) end;
+ val ps = map parts defs_inds
+ val xs = ps |> map (fn (name,params,def,ind,body,rw,x1) => x1)
+ val xs = listSyntax.mk_list(xs,type_of (hd xs))
+ val x = SPEC xs (Q.SPEC `k` fns_assum_def) |> concl |> dest_eq |> fst
+ val tm = ``v k = ^x``
+ val v = tm |> dest_eq |> fst |> repeat rator
+ val vv = mk_var(base_name,type_of v)
+ val fns_assum = new_definition(base_name^"_def",subst [v|->vv] tm) |> SPEC_ALL
+ (* prove correspondence *)
+ val _ = install_assum_eq fns_assum
+(*
+ val (name,params,def,ind,body,rw,x1) = el 1 ps
+*)
+ fun prove_corr (name,params,def,ind,body,rw,x1) = let
+ val name_tm = fromMLstring name
+ val (ps,t) = ``(k:string |-> string list # term) ' ^name_tm``
+ |> REWRITE_CONV [get_lookup_thm()]
+ |> concl |> rand |> pairSyntax.dest_pair
+ val args = ps |> listSyntax.dest_list |> fst |> map stringSyntax.fromHOLstring
+ |> map (fn s => mk_var(simplify_name s,``:SExp``))
+ |> (fn xs => listSyntax.mk_list(xs,``:SExp``))
+ val v = mk_var("__result__",``:SExp list -> SExp``)
+ val lemma = DISCH_ALL (ASSUME ``R_ap (Fun ^name_tm,args,e,fns,io,ok) (^v args,fns,io,ok)``)
+ val _ = atbl_install (string_uppercase name) lemma
+ fun FORCE_UNDISCH th = UNDISCH th handle HOL_ERR _ => th
+ val mt = dest_term t
+ val th1 = FORCE_UNDISCH (SIMP_RULE std_ss [] (R_ev mt)) |> remove_primes
+ val th2 = CS [R_ap_Fun] ``R_ap (Fun ^name_tm,^args,e,k,io,ok) (ans,k2,io2,ok2)``
+ |> SIMP_RULE std_ss [get_lookup_thm(),LENGTH]
+ val tm2 = th2 |> concl |> rator |> rand
+ val tm1 = th1 |> concl
+ val s = fst (match_term (rator tm1) (rator tm2))
+ val c = DEPTH_CONV eval_fappy_conv
+ val th4 = MATCH_MP th2 (INST s th1) |> DISCH_ALL |> RW [AND_IMP_INTRO]
+ |> CONV_RULE (BINOP_CONV c)
+ (* connect function *)
+ val good_name = simplify_name name
+ val params = listSyntax.dest_list args |> fst
+ val ty = foldr (fn (x,y) => mk_sexp_fun_ty y) ``:SExp`` params
+ val new_fun = def |> concl |> dest_eq |> fst |> repeat rator
+ val lhs = foldl (fn (x,y) => mk_comb(y,x)) new_fun params
+ fun mk_els [] access = []
+ | mk_els (x::xs) access = ((x:term) |-> ``HD ^access``) :: mk_els xs ``TL ^access``
+ val args_var = ``args:SExp list``
+ val tm = mk_abs(args_var,subst (mk_els params args_var) lhs)
+ val th5 = INST [v|->tm] th4 |> SIMP_RULE std_ss [HD,TL,isTrue_if]
+ val def1 = def |> ONCE_REWRITE_RULE [rw]
+ val th6 = th5 |> REWRITE_RULE [lisp_sexpTheory.LISP_CONS_def]
+ |> CONV_RULE ((RAND_CONV o RAND_CONV) (ONCE_REWRITE_CONV [GSYM def1]))
+ (* prove certificate theorem *)
+ val goal = mk_imp(hd (hyp (get_lookup_thm())),th6 |> concl |> rand)
+ val f = foldr mk_abs goal params
+ val forall_goal = foldr mk_forall goal params
+ val result = if concl ind = T then RW [] th6 else let
+ val i = ISPEC f ind |> CONV_RULE (DEPTH_CONV BETA_CONV)
+ val i = REWRITE_RULE [isTrue_INTRO] i
+ val result = prove(i |> concl |> rand,
+ PURE_ONCE_REWRITE_TAC [R_ap_SET_ENV]
+ \\ MATCH_MP_TAC (RW1 [R_ap_SET_ENV] i) \\ REPEAT STRIP_TAC
+ \\ MATCH_MP_TAC (RW1 [R_ap_SET_ENV] th6) \\ ASM_REWRITE_TAC []
+ \\ REPEAT STRIP_TAC \\ METIS_TAC [isTrue_INTRO]) |> SPECL params
+ in result end
+ (* install for future use *)
+ val _ = atbl_install (string_uppercase name) result
+ val _ = save_thm("R_ap_" ^ name,result)
+ in result end;
+ val thms = map prove_corr ps
+ in (fns_assum,thms) end;
+
+
end;
View
33 ...eorem-prover/milawa-prover/lisp_extractScript.sml → ...rover/lisp-runtime/extract/lisp_extractScript.sml
@@ -525,4 +525,37 @@ val FST_SND_IF = store_thm("FST_SND_IF",
val isTrue_T = save_thm("isTrue_T",EVAL ``isTrue (Sym "T")``);
+val isTrue_INTRO = store_thm("isTrue_INTRO",
+ ``((x = y) = isTrue (LISP_EQUAL x y)) /\
+ (isTrue x /\ isTrue y = isTrue (if isTrue x then y else Sym "NIL")) /\
+ (isTrue x \/ isTrue y = isTrue (if isTrue x then Sym "T" else y)) /\
+ (LISP_CONS = Dot) /\
+ (~isTrue x = isTrue (if isTrue x then Sym "NIL" else Sym "T")) /\
+ (getVal x < getVal y = isTrue (LISP_LESS x y)) /\
+ (getVal x > getVal y = isTrue (LISP_LESS y x)) /\
+ (getVal x <= getVal y = ~(getVal x > getVal y)) /\
+ (getVal x >= getVal y = ~(getVal x < getVal y)) /\
+ (getSym x < getSym y = isTrue (LISP_SYMBOL_LESS x y)) /\
+ (isDot x = isTrue (LISP_CONSP x)) /\
+ (isVal x = isTrue (LISP_NUMBERP x)) /\
+ (isSym x = isTrue (LISP_SYMBOLP x))``,
+ SIMP_TAC std_ss [FUN_EQ_THM] \\ EVAL_TAC \\ SRW_TAC [] [] \\ DECIDE_TAC);
+
+val PAIR_LEMMA = prove(
+ ``!x. (x = (FST x,x2)) = (SND x = x2)``,
+ Cases \\ SRW_TAC [] []);
+
+val SND_SND_SND_funcall_IMP = store_thm("SND_SND_SND_funcall_IMP",
+ ``R_ap (Funcall,(Sym f)::xs,ARB,k,io,ok) (x1,x2,x3,ok2) /\
+ SND (SND (SND (funcall ((Sym f)::xs) k io ok))) ==> ok2``,
+ SIMP_TAC std_ss [funcall_def] \\ REPEAT STRIP_TAC
+ \\ `funcall_ok (Sym f::xs) k io ok` by METIS_TAC [funcall_ok_def]
+ \\ FULL_SIMP_TAC std_ss [] \\ Cases_on `ok2` \\ SIMP_TAC std_ss []
+ \\ `!res. R_ap (Funcall,Sym f::xs,ARB,k,io,ok) res =
+ (res = (FST res, FST (SND res), FST (SND (SND res)),F))` by METIS_TAC [R_ap_F_11,pairTheory.PAIR]
+ \\ FULL_SIMP_TAC std_ss [PAIR_LEMMA]
+ \\ `?result:SExp # (string |-> string list # term) # string # bool. ~SND (SND (SND result))` by ALL_TAC
+ THEN1 (Q.EXISTS_TAC `(ARB,ARB,ARB,F)` \\ EVAL_TAC)
+ \\ METIS_TAC []);
+
val _ = export_theory();
View
11 examples/theorem-prover/lisp-runtime/extract/lisp_synthesisLib.sig
@@ -0,0 +1,11 @@
+signature lisp_synthesisLib =
+sig
+
+ include Abbrev
+
+ val lisp_Define : term quotation -> thm
+ val lisp_tDefine : string -> term quotation -> tactic -> thm
+
+ val synthesise_deep_embeddings : unit -> thm
+
+end
View
50 examples/theorem-prover/lisp-runtime/extract/lisp_synthesisLib.sml
@@ -0,0 +1,50 @@
+structure lisp_synthesisLib :> lisp_synthesisLib =
+struct
+
+open HolKernel boolLib bossLib;
+open lisp_extractTheory lisp_extractLib;
+open lisp_compilerTheory;
+
+open stringTheory finite_mapTheory pred_setTheory listTheory sumTheory;
+open optionTheory arithmeticTheory relationTheory;
+open stringLib pairSyntax;
+
+
+(* we define lisp_Define and lisp_tDefine which record definitions
+ that are to be exported to verified deep embeddings *)
+
+local
+ val defs_inds = ref (tl [("",TRUTH,TRUTH)])
+in
+ fun add_def def = let
+ val name = def |> SPEC_ALL |> concl |> dest_eq |> fst |> repeat rator
+ |> dest_const |> fst
+ val ind_name = name ^ "_ind"
+ val ind = fetch "-" ind_name handle HOL_ERR _ => TRUTH
+ val xs = filter (fn (n,def,ind) => not (n = name)) (!defs_inds)
+ val _ = defs_inds := xs @ [(name,def,ind)]
+ in def end
+ fun get_defs_inds () = !defs_inds
+end
+
+fun lisp_Define t = add_def (Define t);
+fun lisp_tDefine name t tac = add_def (tDefine name t tac);
+
+
+(* the main synthesis function: shallow -> deep *)
+
+fun synthesise_deep_embeddings () = let
+ val defs_inds = map (fn (name,def,ind) => (def,ind)) (get_defs_inds())
+ val base_name = "deep_embedding"
+ val (deep,certs) = deep_embeddings base_name defs_inds
+ val deep_simp = SIMP_RULE std_ss [GSYM CONJ_ASSOC,fns_assum_def,EVERY_DEF] deep
+ (* printing in Lisp syntax *)
+ val xs = deep |> SPEC_ALL |> concl |> rand |> rand
+ val tm = EVAL ``verified_string ^xs`` |> concl |> rand
+ val _ = if can (match_term ``NONE:'a option``) tm then () else let
+ val str = stringSyntax.fromHOLstring (rand tm)
+ in print ("\n\nDeep embedding in Lisp syntax:\n\n" ^ str ^ "\n\n") end
+ in LIST_CONJ (deep_simp::certs) end
+
+
+end
View
72 examples/theorem-prover/lisp-runtime/extract/lisp_synthesis_demoScript.sml
@@ -0,0 +1,72 @@
+
+open HolKernel Parse boolLib bossLib; val _ = new_theory "lisp_synthesis_demo";
+
+open arithmeticTheory listTheory pairTheory lisp_sexpTheory lisp_synthesisLib;
+
+infix \\ val op \\ = op THEN;
+
+
+(* we start by proving a lemma which helps with termination proofs *)
+
+val term_lemma = prove(
+ ``!x. isDot x ==> LSIZE (CAR x) < LSIZE x /\ LSIZE (CDR x) < LSIZE x``,
+ Cases \\ EVAL_TAC \\ DECIDE_TAC);
+
+
+(* we define a few shallow embeddings *)
+
+val append_def = lisp_tDefine "append" `
+ append x y = if isDot x then Dot (CAR x) (append (CDR x) y) else y`
+ (WF_REL_TAC `measure (LSIZE o FST)` \\ SIMP_TAC std_ss [term_lemma]);
+
+val rev_def = lisp_tDefine "rev" `
+ rev x = if isDot x then append (rev (CDR x)) (Dot (CAR x) (Sym "NIL")) else x`
+ (WF_REL_TAC `measure (LSIZE)` \\ SIMP_TAC std_ss [term_lemma]);
+
+val len_def = lisp_tDefine "len" `
+ len x = if isDot x then LISP_ADD (len (CDR x)) (Val 1) else Val 0`
+ (WF_REL_TAC `measure (LSIZE)` \\ SIMP_TAC std_ss [term_lemma]);
+
+val part_def = lisp_tDefine "part" `
+ part pivot x res1 res2 =
+ if isDot x then
+ if isTrue (LISP_LESS (CAR x) pivot)
+ then part pivot (CDR x) (Dot (CAR x) res1) res2
+ else part pivot (CDR x) res1 (Dot (CAR x) res2)
+ else Dot res1 res2`
+ (WF_REL_TAC `measure (LSIZE o FST o SND)` \\ SIMP_TAC std_ss [term_lemma]);
+
+val LIZE_EQ_SUC = prove(
+ ``!x. (LSIZE x = SUC n) ==> LSIZE (CAR x) <= n /\ LSIZE (CDR x) <= n``,
+ Cases \\ EVAL_TAC \\ DECIDE_TAC);
+
+val part_LSIZE = prove(
+ ``!y x x1 x2.
+ LSIZE (part x y x1 x2) = SUC (LSIZE y + LSIZE x1 + LSIZE x2)``,
+ REVERSE Induct \\ ONCE_REWRITE_TAC [part_def]
+ \\ SIMP_TAC std_ss [isDot_def,LSIZE_def,CAR_def,CDR_def]
+ \\ SRW_TAC [] [] \\ FULL_SIMP_TAC std_ss [LSIZE_def] \\ DECIDE_TAC)
+ |> Q.SPECL [`b`,`a`,`Sym "NIL"`,`Sym "NIL"`] |> MATCH_MP LIZE_EQ_SUC
+ |> REWRITE_RULE [ADD_0,LSIZE_def];
+
+val NOT_LISP_LESS_TWO = prove(
+ ``!x. ~isTrue (LISP_LESS (len x) (Val 2)) ==> isDot x``,
+ Cases \\ ONCE_REWRITE_TAC [len_def] \\ SIMP_TAC std_ss [isDot_def] \\ EVAL_TAC);
+
+val qsort_def = lisp_tDefine "qsort" `
+ qsort x =
+ if isTrue (LISP_LESS (len x) (Val 2)) then x else
+ let pivot = CAR x in
+ let res = part pivot (CDR x) (Sym "NIL") (Sym "NIL") in
+ append (qsort (CAR res)) (Dot pivot (qsort (CDR res)))`
+ (WF_REL_TAC `measure LSIZE` \\ REPEAT STRIP_TAC
+ \\ IMP_RES_TAC NOT_LISP_LESS_TWO
+ \\ FULL_SIMP_TAC std_ss [isDot_thm,LSIZE_def,CAR_def,CDR_def]
+ \\ STRIP_ASSUME_TAC part_LSIZE \\ DECIDE_TAC)
+
+
+(* we use our tool to derive corresponding deep embeddings *)
+
+val thms = synthesise_deep_embeddings ()
+
+val _ = export_theory();
View
2  examples/theorem-prover/milawa-prover/Holmakefile
@@ -1,4 +1,4 @@
-INCLUDES = ../lisp-runtime/parse ../lisp-runtime/spec $(HOLDIR)/examples/ordinal
+INCLUDES = ../lisp-runtime/parse ../lisp-runtime/spec ../lisp-runtime/extract $(HOLDIR)/examples/ordinal
OPTIONS=QUIT_ON_FAILURE
milawa_coreTheory.ou: core.lisp
View
46 examples/theorem-prover/milawa-prover/core.lisp
@@ -1664,6 +1664,51 @@
(cons new-axiom axioms))))
(|CORE.STATE| axioms thms atbl checker ftbl)))))))
+ (|CORE.EVAL-FUNCTION| (x)
+ (let* ((fn (|LOGIC.FUNCTION-NAME| x))
+ (vals (|LOGIC.UNQUOTE-LIST| (|LOGIC.FUNCTION-ARGS| x)))
+ (n (len vals))
+ (x1 (first vals))
+ (x2 (second vals))
+ (x3 (third vals))
+ (x4 (fourth vals))
+ (x5 (fifth vals)))
+ (list 'quote
+ (cond ((equal n 0) (funcall fn))
+ ((equal n 1) (funcall fn x1))
+ ((equal n 2) (funcall fn x1 x2))
+ ((equal n 3) (funcall fn x1 x2 x3))
+ ((equal n 4) (funcall fn x1 x2 x3 x4))
+ ((equal n 5) (funcall fn x1 x2 x3 x4 x5))
+ (t (error (list 'core-eval-function 'too-many-parameters)))))))
+
+ (|CORE.ADMIT-EVAL|
+ (cmd state)
+ ;; Performs evaluation in the runtime
+ ;; CMD should be (EVAL (fn 'arg1 'arg2 ... 'argN))
+ (let* ((axioms (|CORE.AXIOMS| state))
+ (thms (|CORE.THMS| state))
+ (atbl (|CORE.ATBL| state))
+ (checker (|CORE.CHECKER| state))
+ (ftbl (|CORE.FTBL| state))
+ (lhs (second cmd)))
+ (cond
+ ((not (|LOGIC.TERMP| lhs))
+ (error (list 'admit-eval 'bad-term-on-lhs lhs)))
+ ((not (|LOGIC.FUNCTIONP| lhs))
+ (error (list 'admit-eval 'not-function-on-lhs lhs)))
+ ((not (|LOGIC.CONSTANT-LISTP| (|LOGIC.FUNCTION-ARGS| lhs)))
+ (error (list 'admit-eval 'not-const-list-on-lhs lhs)))
+ ((not (|LOGIC.TERM-ATBLP| lhs atbl))
+ (error (list 'admit-eval 'bad-arity-on-lhs lhs)))
+ ((lookup (|LOGIC.FUNCTION-NAME| lhs) (|CORE.INITIAL-ATBL|))
+ (error (list 'admit-eval 'not-user-defined-function lhs)))
+ (t
+ (let* ((rhs (|CORE.EVAL-FUNCTION| lhs))
+ (new-thm (|LOGIC.PEQUAL| lhs rhs))
+ (thms (cons new-thm thms)))
+ (|CORE.STATE| axioms thms atbl checker ftbl))))))
+
(|CORE.ADMIT-PRINT|
(cmd state)
;; Prints a theorem and returns original state, or calls error
@@ -1689,6 +1734,7 @@
((equal (car cmd) 'skolem) (|CORE.ADMIT-WITNESS| cmd state))
((equal (car cmd) 'switch) (|CORE.ADMIT-SWITCH| cmd state))
((equal (car cmd) 'print) (|CORE.ADMIT-PRINT| cmd state))
+ ((equal (car cmd) 'eval) (|CORE.ADMIT-EVAL| cmd state))
(t
(error (list 'accept-cmd 'invalid-command cmd)))))
View
2  examples/theorem-prover/milawa-prover/milawa_defsScript.sml
@@ -378,6 +378,8 @@ val core_admit_switch_def = impure_extract "CORE.ADMIT-SWITCH" term_tac;
val core_admit_theorem_def = impure_extract "CORE.ADMIT-THEOREM" term_tac;
val core_admit_defun_def = impure_extract "CORE.ADMIT-DEFUN" term_tac;
val core_admit_witness_def = impure_extract "CORE.ADMIT-WITNESS" term_tac;
+val core_eval_function_def = impure_extract "CORE.EVAL-FUNCTION" term_tac;
+val core_admit_eval_def = impure_extract "CORE.ADMIT-EVAL" term_tac;
val core_admit_print_def = impure_extract "CORE.ADMIT-PRINT" term_tac;
val core_accept_command_def = impure_extract "CORE.ACCEPT-COMMAND" term_tac;
val core_accept_commands_def = impure_extract_cut "CORE.ACCEPT-COMMANDS" term_tac;
View
34 examples/theorem-prover/milawa-prover/milawa_execScript.sml
@@ -232,6 +232,40 @@ local
val lemma = MR_ev_ind
|> Q.SPEC `\x y.
+ !f args a ctxt fns ok res ok1 res2 ok2 ok3.
+ (x = (f,args,a,ctxt,fns,ok)) /\ (y = (res,ok1)) /\
+ MR_ap (f,args,a,ctxt,fns,ok) (res2,ok2) ==> (res = res2) /\ (ok1 = ok2)`
+ |> Q.SPEC `\x y.
+ !xs a ctxt fns ok res ok1 res2 ok2 ok3.
+ (x = (xs,a,ctxt,fns,ok)) /\ (y = (res,ok1)) /\
+ MR_evl (xs,a,ctxt,fns,ok) (res2,ok2) ==> (res = res2) /\ (ok1 = ok2)`
+ |> Q.SPEC `\x y.
+ !x1 a ctxt fns ok res ok1 res2 ok2 ok3.
+ (x = (x1,a,ctxt,fns,ok)) /\ (y = (res,ok1)) /\
+ MR_ev (x1,a,ctxt,fns,ok) (res2,ok2) ==> (res = res2) /\ (ok1 = ok2)`
+ |> CONV_RULE (RAND_CONV (SIMP_CONV std_ss [PULL_IMP]))
+
+in
+
+val MR_ev_11_ALL = store_thm("MR_ev_11_ALL",
+ lemma |> concl |> dest_comb |> snd,
+ MATCH_MP_TAC lemma \\ REPEAT STRIP_TAC
+ \\ SIMP_TAC std_ss [] \\ REPEAT STRIP_TAC
+ \\ FULL_SIMP_TAC std_ss []
+ \\ POP_ASSUM MP_TAC \\ ONCE_REWRITE_TAC [MR_ev_cases]
+ \\ ASM_SIMP_TAC (srw_ss()) []
+ \\ REPEAT STRIP_TAC \\ RES_TAC \\ FULL_SIMP_TAC std_ss []
+ \\ FULL_SIMP_TAC std_ss [] \\ RES_TAC \\ FULL_SIMP_TAC std_ss [MEM]
+ \\ NTAC 2 (POP_ASSUM MP_TAC)
+ \\ ONCE_REWRITE_TAC [MR_ev_cases]
+ \\ ASM_SIMP_TAC (srw_ss()) []);
+
+end
+
+local
+
+val lemma = MR_ev_ind
+ |> Q.SPEC `\x y.
!f args a ctxt fns ok res ok1.
(x = (f,args,a,ctxt \\ name,fns,ok)) /\ (y = (res,ok1)) ==>
MR_ap (f,args,a,ctxt,fns,ok) (res,ok1)`
View
161 examples/theorem-prover/milawa-prover/milawa_proofpScript.sml
@@ -1,7 +1,7 @@
open HolKernel Parse boolLib bossLib; val _ = new_theory "milawa_proofp";
-open lisp_sexpTheory lisp_semanticsTheory;
+open lisp_sexpTheory lisp_semanticsTheory lisp_extractTheory;
open milawa_defsTheory milawa_logicTheory milawa_execTheory;
open arithmeticTheory listTheory pred_setTheory finite_mapTheory combinTheory;
@@ -22,13 +22,13 @@ val LISP_TEST_THM = prove(
((LISP_TEST b = Sym "NIL") = ~b) /\ ((LISP_TEST b = Sym "T") = b)``,
Cases \\ FULL_SIMP_TAC std_ss [] \\ EVAL_TAC);
-val _ = add_rws [lisp_extractTheory.isTrue_CLAUSES,
+val _ = add_rws [isTrue_CLAUSES,
CDR_def,CAR_def,getVal_def,SExp_11,SExp_distinct,
isDot_def,isVal_def,isSym_def,LISP_ADD_def,LISP_SUB_def,list2sexp_def,MEM,
EVAL ``LISP_TEST F``,EVAL ``LISP_TEST T``,LISP_CONS_def,LISP_TEST_THM,
- lisp_extractTheory.FIRST_def,lisp_extractTheory.SECOND_def,
- lisp_extractTheory.THIRD_def,lisp_extractTheory.FOURTH_def,
- lisp_extractTheory.FIFTH_def,NOT_CONS_NIL]
+ FIRST_def,SECOND_def,
+ THIRD_def,FOURTH_def,
+ FIFTH_def,NOT_CONS_NIL]
fun SS thms = SIMP_TAC std_ss (thms @ !rw)
fun FS thms = FULL_SIMP_TAC std_ss (thms @ !rw)
@@ -285,12 +285,12 @@ val formula_syntax_ok_def = Define `
val logic_flag_term_vars_Dot =
``logic_flag_term_vars (Sym "LIST") (Dot x y) acc``
|> ONCE_REWRITE_CONV [logic_flag_term_vars_def]
- |> SIMP_RULE (srw_ss()) [lisp_extractTheory.isTrue_CLAUSES,isDot_def,CDR_def,CAR_def]
+ |> SIMP_RULE (srw_ss()) [isTrue_CLAUSES,isDot_def,CDR_def,CAR_def]
val logic_flag_term_vars_Sym =
``logic_flag_term_vars (Sym "LIST") (Sym s) acc``
|> ONCE_REWRITE_CONV [logic_flag_term_vars_def]
- |> SIMP_RULE (srw_ss()) [lisp_extractTheory.isTrue_CLAUSES,isDot_def,CDR_def,CAR_def]
+ |> SIMP_RULE (srw_ss()) [isTrue_CLAUSES,isDot_def,CDR_def,CAR_def]
val PULL_FORALL_IMP = METIS_PROVE [] ``(p ==> !x. q x) = !x. p ==> q x``;
@@ -1580,7 +1580,7 @@ val true_listp_list_fix = prove(
val true_listp_app = prove(
``!x y. isTrue (true_listp (app x y))``,
Induct \\ ONCE_REWRITE_TAC [app_def]
- \\ FULL_SIMP_TAC std_ss [lisp_extractTheory.isTrue_CLAUSES,
+ \\ FULL_SIMP_TAC std_ss [isTrue_CLAUSES,
isDot_def,CAR_def,CDR_def,true_listp_cons,true_listp_list_fix]);
val true_listp_logic_flag_callmap_list = prove(
@@ -2651,9 +2651,9 @@ val core_check_proof_inv_IMP_RAW = prove(
\\ ONCE_REWRITE_TAC [R_ev_cases] \\ SIMP_TAC (srw_ss()) [] \\ METIS_TAC [])
\\ SIMP_TAC std_ss [core_check_proof_side_def]
\\ `funcall_ok [checker; t; axioms; thms; atbl] k io ok` by
- (SIMP_TAC std_ss [lisp_extractTheory.funcall_ok_def] \\ METIS_TAC [])
+ (SIMP_TAC std_ss [funcall_ok_def] \\ METIS_TAC [])
\\ SIMP_TAC std_ss [core_check_proof_def]
- \\ ASM_SIMP_TAC std_ss [lisp_extractTheory.funcall_def]
+ \\ ASM_SIMP_TAC std_ss [funcall_def]
\\ Cases_on `ok2` THEN1
(FULL_SIMP_TAC std_ss [] \\ Q.PAT_ASSUM `io2 = ""` ASSUME_TAC
\\ FULL_SIMP_TAC std_ss [APPEND_NIL]
@@ -2684,10 +2684,10 @@ val core_check_proof_inv_IMP_OK = prove(
val core_check_proof_IMP_OK = prove(
``SND (SND (SND (core_check_proof checker proofs axioms thms atbl k io ok))) ==>
ok``,
- SIMP_TAC std_ss [core_check_proof_def,lisp_extractTheory.funcall_def]
+ SIMP_TAC std_ss [core_check_proof_def,funcall_def]
\\ Cases_on `funcall_ok [checker; proofs; axioms; thms; atbl] k io ok`
\\ FULL_SIMP_TAC std_ss []
- \\ FULL_SIMP_TAC std_ss [lisp_extractTheory.funcall_ok_def]
+ \\ FULL_SIMP_TAC std_ss [funcall_ok_def]
\\ Cases_on `ok` \\ FULL_SIMP_TAC std_ss []
\\ Q.ABBREV_TAC `xxx = R_ap (Funcall,[checker; proofs; axioms; thms; atbl],ARB,k,io,F)`
\\ `xxx (@result. xxx result)` by METIS_TAC []
@@ -2708,10 +2708,10 @@ val core_check_proof_list_IMP_OK = prove(
val SUBMAP_core_check_proof = prove(
``k SUBMAP (FST (SND (core_check_proof checker t axioms thms atbl k io ok)))``,
- SIMP_TAC std_ss [core_check_proof_def,lisp_extractTheory.funcall_def]
+ SIMP_TAC std_ss [core_check_proof_def,funcall_def]
\\ Cases_on `funcall_ok [checker; t; axioms; thms; atbl] k io ok` \\ FS []
\\ FULL_SIMP_TAC std_ss [SUBMAP_REFL]
- \\ FULL_SIMP_TAC std_ss [lisp_extractTheory.funcall_ok_def]
+ \\ FULL_SIMP_TAC std_ss [funcall_ok_def]
\\ Q.ABBREV_TAC `xxx = (@result.
R_ap (Funcall,[checker; t; axioms; thms; atbl],ARB,k,io,ok)
result)`
@@ -2930,7 +2930,7 @@ val core_check_proof_thm = prove(
`list2sexp (MAP f2sexp axioms)`,
`list2sexp (MAP f2sexp thms)`,`atbl`,`io`,`ok`])
\\ REPEAT STRIP_TAC
- \\ FULL_SIMP_TAC std_ss [core_check_proof_def,lisp_extractTheory.funcall_def]
+ \\ FULL_SIMP_TAC std_ss [core_check_proof_def,funcall_def]
\\ Q.PAT_ASSUM `checker = Sym name` (ASSUME_TAC)
\\ IMP_RES_TAC Funcall_lemma
\\ Cases_on `ok2` THEN1
@@ -3951,7 +3951,7 @@ val core_admit_defun_thm = prove(
\\ Q.PAT_ASSUM `core_assum kk` MP_TAC
\\ ONCE_REWRITE_TAC [milawa_initTheory.core_assum_def]
\\ MATCH_MP_TAC (METIS_PROVE [] ``(!x. f a x ==> f b x) ==> (f a x ==> f b x)``)
- \\ SIMP_TAC std_ss [lisp_extractTheory.fns_assum_add_def_IMP])
+ \\ SIMP_TAC std_ss [fns_assum_add_def_IMP])
\\ MATCH_MP_TAC (GEN_ALL MR_ev_thm |> Q.SPECL [`result`,`name`,`k2`,`term2t bb`,`ctxt2`,`FunVarBind params args`,`ok'`,`VarBind params args`])
\\ FULL_SIMP_TAC (srw_ss()) []
\\ `ctxt2 \\ name = ctxt` by ALL_TAC
@@ -3985,7 +3985,7 @@ val core_admit_defun_thm = prove(
\\ Q.PAT_ASSUM `core_assum kk` MP_TAC
\\ ONCE_REWRITE_TAC [milawa_initTheory.core_assum_def]
\\ MATCH_MP_TAC (METIS_PROVE [] ``(!x. f a x ==> f b x) ==> (f a x ==> f b x)``)
- \\ SIMP_TAC std_ss [lisp_extractTheory.fns_assum_add_def_IMP]));
+ \\ SIMP_TAC std_ss [fns_assum_add_def_IMP]));
(* admit witness *)
@@ -4335,7 +4335,7 @@ val core_admit_witness_thm = prove(
\\ Q.PAT_ASSUM `core_assum kk` MP_TAC
\\ ONCE_REWRITE_TAC [milawa_initTheory.core_assum_def]
\\ MATCH_MP_TAC (METIS_PROVE [] ``(!x. f a x ==> f b x) ==> (f a x ==> f b x)``)
- \\ SIMP_TAC std_ss [lisp_extractTheory.fns_assum_add_def_IMP]));
+ \\ SIMP_TAC std_ss [fns_assum_add_def_IMP]));
(* admit switch *)
@@ -4551,7 +4551,7 @@ val core_admit_switch_thm = prove(
\\ IMP_RES_TAC (MR_IMP_R |> CONJUNCTS |> hd |> SPEC_ALL |> Q.INST [`f`|->`Fun (x::xs)`])
\\ POP_ASSUM (STRIP_ASSUME_TAC o Q.SPEC `io`)
\\ METIS_TAC [R_ap_T_11,R_ev_logic_conclusion,PAIR_EQ,MR_IMP_R,
- logic_conclusion_def,lisp_extractTheory.SECOND_def])
+ logic_conclusion_def,SECOND_def])
\\ FULL_SIMP_TAC std_ss [] \\ SIMP_TAC std_ss [DISJ_EQ_IMP]
\\ SIMP_TAC std_ss [GSYM isTrue_def]
\\ `R_ap (Fun name,[x1; x2; x3; x4],ARB,k,io,ok)
@@ -4644,6 +4644,125 @@ val core_admit_switch_thm = prove(
\\ FS [] \\ METIS_TAC [logic_proofp_thm]);
+(* admit eval *)
+
+val logic_func2sexp_IN_core_initial_atbl = prove(
+ ``!f. isTrue (lookup (logic_func2sexp f) core_initial_atbl) =
+ ?p. f = mPrimitiveFun p``,
+ Cases THEN1 (Cases_on `l` \\ SIMP_TAC (srw_ss()) [] \\ EVAL_TAC)
+ \\ SIMP_TAC (srw_ss()) [logic_func2sexp_def]
+ \\ SRW_TAC [] [] \\ EVAL_TAC \\ FULL_SIMP_TAC std_ss []);
+
+val core_eval_function_thm = prove(
+ ``milawa_inv ctxt k (axioms,thms,atbl,checker,ftbl) /\
+ term_syntax_ok (mApp (mFun f) (MAP mConst xs)) /\
+ term_ok ctxt (mApp (mFun f) (MAP mConst xs)) ==>
+ ?res io2 ok2 k2.
+ core_eval_function_side (t2sexp (mApp (mFun f) (MAP mConst xs))) k io ok /\
+ (core_eval_function (t2sexp (mApp (mFun f) (MAP mConst xs))) k io ok =
+ (res,k2,io2,ok2)) /\
+ (ok2 ==> (io2 = io) /\ (k2 = k) /\
+ MR_ap (Fun f,xs,ARB,ctxt,k,ok) (EvalApp((mFun f),xs,ctxt),T) /\
+ (res = t2sexp (mConst (EvalApp((mFun f),xs,ctxt)))))``,
+ SIMP_TAC std_ss [core_eval_function_def,core_eval_function_side_def]
+ \\ FS [t2sexp_def,LET_DEF]
+ \\ FULL_SIMP_TAC std_ss [LENGTH,term_ok_def,func_arity_def,EVERY_DEF,LENGTH_MAP]
+ \\ STRIP_TAC \\ FULL_SIMP_TAC (srw_ss()) [func_arity_def]
+ \\ `?x1 x2 x3. ctxt ' f = (x1,x2,x3)` by METIS_TAC [PAIR]
+ \\ FULL_SIMP_TAC std_ss [milawa_inv_def,runtime_inv_def]
+ \\ `LENGTH xs = LENGTH x1` by ALL_TAC THEN1 FS []
+ \\ RES_TAC \\ POP_ASSUM (STRIP_ASSUME_TAC o Q.SPEC `ok`)
+ \\ FS [EvalApp_def,LET_DEF]
+ \\ IMP_RES_TAC (CONJUNCT1 MR_IMP_R) \\ POP_ASSUM (STRIP_ASSUME_TAC o Q.SPEC `io`)
+ \\ `(logic_func2sexp (mFun f) = Sym f)` by ALL_TAC THEN1
+ (FULL_SIMP_TAC std_ss [logic_func2sexp_def,MEM,term_syntax_ok_def,
+ func_syntax_ok_def]) \\ FS []
+ \\ IMP_RES_TAC Funcall_lemma
+ \\ `funcall_ok (Sym f::xs) k io ok` by METIS_TAC [funcall_ok_def]
+ \\ `ok2 ==> (funcall (Sym f::xs) k io ok = (x3 xs,k,STRCAT io io1,ok2))` by
+ (REPEAT STRIP_TAC \\ FULL_SIMP_TAC std_ss [funcall_def] \\ METIS_TAC [R_ap_T_11])
+ \\ FULL_SIMP_TAC std_ss []
+ \\ Cases_on `x1` \\ Cases_on `xs` \\ FULL_SIMP_TAC std_ss [LENGTH,ADD1,APPEND_NIL]
+ THEN1 (STRIP_TAC \\ IMP_RES_TAC SND_SND_SND_funcall_IMP
+ \\ FULL_SIMP_TAC std_ss [APPEND_NIL] \\ METIS_TAC [APPEND_NIL])
+ \\ Cases_on `t` \\ Cases_on `t'` \\ FS [LENGTH,ADD1,APPEND_NIL,list2sexp_def]
+ THEN1 (STRIP_TAC \\ IMP_RES_TAC SND_SND_SND_funcall_IMP
+ \\ FULL_SIMP_TAC std_ss [APPEND_NIL] \\ METIS_TAC [APPEND_NIL])
+ \\ Cases_on `t` \\ Cases_on `t''` \\ FS [LENGTH,ADD1,APPEND_NIL,list2sexp_def]
+ THEN1 (STRIP_TAC \\ IMP_RES_TAC SND_SND_SND_funcall_IMP
+ \\ FULL_SIMP_TAC std_ss [APPEND_NIL] \\ METIS_TAC [APPEND_NIL])
+ \\ Cases_on `t'` \\ Cases_on `t` \\ FS [LENGTH,ADD1,APPEND_NIL,list2sexp_def]
+ THEN1 (STRIP_TAC \\ IMP_RES_TAC SND_SND_SND_funcall_IMP
+ \\ FULL_SIMP_TAC std_ss [APPEND_NIL] \\ METIS_TAC [APPEND_NIL])
+ \\ Cases_on `t''` \\ Cases_on `t'` \\ FS [LENGTH,ADD1,APPEND_NIL,list2sexp_def]
+ THEN1 (STRIP_TAC \\ IMP_RES_TAC SND_SND_SND_funcall_IMP
+ \\ FULL_SIMP_TAC std_ss [APPEND_NIL] \\ METIS_TAC [APPEND_NIL])
+ \\ Cases_on `t''` \\ Cases_on `t` \\ FS [LENGTH,ADD1,APPEND_NIL,list2sexp_def]
+ THEN1 (STRIP_TAC \\ IMP_RES_TAC SND_SND_SND_funcall_IMP
+ \\ FULL_SIMP_TAC std_ss [APPEND_NIL] \\ METIS_TAC [APPEND_NIL])
+ \\ SIMP_TAC std_ss [GSYM ADD_ASSOC,DECIDE ``~(n + 6 = 2:num)``,
+ DECIDE ``~(n + 6 = 3:num)``,DECIDE ``~(n + 6 = 4:num)``,
+ DECIDE ``~(n + 6 = 5:num)``]);
+
+val logic_constant_listp_thm = prove(
+ ``!l. isTrue (logic_constant_listp (list2sexp (MAP t2sexp l))) ==>
+ ?ts. l = MAP mConst ts``,
+ Induct THEN1 (REPEAT STRIP_TAC \\ Q.EXISTS_TAC `[]` \\ EVAL_TAC)
+ \\ FULL_SIMP_TAC std_ss [MAP,list2sexp_def] \\ FS []
+ \\ SIMP_TAC std_ss [Once logic_constant_listp_def] \\ FS []
+ \\ REVERSE (Cases_on `h`) \\ FS [t2sexp_def]
+ \\ REPEAT STRIP_TAC \\ RES_TAC
+ \\ Q.EXISTS_TAC `S'::ts` \\ EVAL_TAC \\ ASM_SIMP_TAC std_ss []);
+
+val core_admit_eval_thm = prove(
+ ``milawa_inv ctxt k (axioms,thms,atbl,checker,ftbl) ==>
+ ?x io2 ok2 k2.
+ core_admit_eval_side cmd (milawa_state (axioms,thms,atbl,checker,ftbl)) k io ok /\
+ (core_admit_eval cmd (milawa_state (axioms,thms,atbl,checker,ftbl)) k io ok =
+ (x,k2,io2,ok2)) /\
+ (ok2 ==> (io2 = io) /\ (k2 = k) /\
+ ?result. (x = milawa_state result) /\ milawa_inv ctxt k result)``,
+ SIMP_TAC std_ss [core_admit_eval_def,core_admit_eval_side_def,LET_DEF] \\ FS []
+ \\ Q.ABBREV_TAC `lhs = CAR (CDR cmd)` \\ STRIP_TAC
+ \\ Cases_on `isTrue (logic_termp lhs)` \\ FULL_SIMP_TAC std_ss []
+ \\ Cases_on `isTrue (logic_function_namep (CAR lhs))` \\ FULL_SIMP_TAC std_ss []
+ \\ Cases_on `isTrue (logic_constant_listp (CDR lhs))` \\ FS []
+ \\ Cases_on `isTrue (logic_term_atblp lhs
+ (CAR (CDR (CDR (milawa_state (axioms,thms,atbl,checker,ftbl))))))` \\ FS []
+ \\ Cases_on `isTrue (lookup (CAR lhs) core_initial_atbl)` \\ FS []
+ \\ IMP_RES_TAC logic_termp_thm
+ \\ FULL_SIMP_TAC std_ss [milawa_state_def] \\ FS [core_state_def]
+ \\ FULL_SIMP_TAC std_ss [milawa_inv_def]
+ \\ IMP_RES_TAC logic_term_atblp_thm
+ \\ Cases_on `t`
+ \\ FS [t2sexp_def,logic_function_namep_def]
+ \\ FULL_SIMP_TAC std_ss [GSYM list2sexp_def,memberp_thm,MEM]
+ \\ FS [] \\ Cases_on `l0` THEN1
+ (CCONTR_TAC
+ \\ Q.PAT_ASSUM `~isTrue
+ (lookup (logic_func2sexp (mPrimitiveFun l'))
+ core_initial_atbl)` MP_TAC
+ \\ Cases_on `l'` \\ EVAL_TAC)
+ \\ FULL_SIMP_TAC std_ss [EXISTS_PROD,milawa_state_def,core_state_def]
+ \\ FS [milawa_inv_def,MAP_f2sexp_11]
+ \\ IMP_RES_TAC logic_constant_listp_thm \\ FULL_SIMP_TAC std_ss []
+ \\ MP_TAC (core_eval_function_thm |> Q.INST [`xs`|->`ts`,`f`|->`s`])
+ \\ FS [term_ok_def,term_syntax_ok_def,milawa_inv_def,t2sexp_def]
+ \\ STRIP_TAC \\ FULL_SIMP_TAC std_ss []
+ \\ STRIP_TAC \\ FULL_SIMP_TAC std_ss []
+ \\ Q.EXISTS_TAC `(Equal (mApp (mFun s) (MAP mConst ts))
+ (mConst (EvalApp (mFun s,ts,ctxt))))::thms`
+ \\ FS [list2sexp_def,MAP,f2sexp_def,t2sexp_def,thms_inv_def,EVERY_DEF]
+ \\ FS [formula_syntax_ok_def,term_syntax_ok_def]
+ \\ FS [runtime_inv_def,func_arity_def]
+ \\ `?x1 x2 x3. ctxt ' s = (x1,x2,x3)` by METIS_TAC [PAIR]
+ \\ FS [LENGTH_MAP] \\ `LENGTH ts = LENGTH x1` by METIS_TAC []
+ \\ RES_TAC \\ FULL_SIMP_TAC std_ss [EvalApp_def,LET_DEF,MilawaTrueFun_def]
+ \\ POP_ASSUM (MP_TAC o Q.SPEC `ok`) \\ STRIP_TAC
+ \\ IMP_RES_TAC MR_ev_11_ALL
+ \\ FULL_SIMP_TAC std_ss []);
+
+
(* admit print *)
val output_line_ok_def = Define `
@@ -4704,6 +4823,7 @@ val core_accept_command_thm = prove(
(ok2 ==> milawa_io_inv io2 /\ (x = milawa_state result) /\ milawa_inv ctxt k2 result)``,
STRIP_TAC \\ STRIP_TAC THEN1
(SIMP_TAC std_ss [core_accept_command_side_def]
+ \\ IMP_RES_TAC core_admit_eval_thm
\\ IMP_RES_TAC core_admit_switch_thm
\\ IMP_RES_TAC core_admit_defun_thm
\\ IMP_RES_TAC core_admit_witness_thm
@@ -4716,7 +4836,8 @@ val core_accept_command_thm = prove(
THEN1 (METIS_TAC [core_admit_defun_thm])
THEN1 (METIS_TAC [core_admit_witness_thm])
THEN1 (METIS_TAC [core_admit_switch_thm])
- THEN1 (METIS_TAC [core_admit_print_thm]));
+ THEN1 (METIS_TAC [core_admit_print_thm])
+ THEN1 (METIS_TAC [core_admit_eval_thm]));
(* loop -- accept commands *)
View
1  src/marker/markerScript.sml
@@ -11,6 +11,7 @@ val _ = new_theory "marker";
---------------------------------------------------------------------- *)
val stmarker_def = new_definition("stmarker_def", ``stmarker (x:'a) = x``);
+val _ = OpenTheoryMap.OpenTheory_const_name{const={Thy="marker",Name="stmarker"},name=(["Unwanted"],"id")}
(* the following move_<dir>_<op> theorems will loop if more than one term
is marked at the same level *)
View
11 src/num/theories/arithmeticScript.sml
@@ -24,12 +24,9 @@ open HolKernel boolLib Parse
local open OpenTheoryMap
val ns = ["Number","Natural"]
- val nsnum = ["Number","Numeral"]
in
fun ot0 x y = OpenTheory_const_name{const={Thy="arithmetic",Name=x},name=(ns,y)}
fun ot x = ot0 x x
- fun otnum0 x y = OpenTheory_const_name{const={Thy="arithmetic",Name=x},name=(nsnum,y)}
- fun otnum x = otnum0 x x
fun otunwanted x = OpenTheory_const_name{const={Thy="arithmetic",Name=x},name=(["Unwanted"],"id")}
end
@@ -83,8 +80,8 @@ val NUMERAL_DEF = new_definition("NUMERAL_DEF", --`NUMERAL (x:num) = x`--);
val ALT_ZERO = new_definition("ALT_ZERO", --`ZERO = 0`--);
local open OpenTheoryMap in
-val _ = OpenTheory_const_name {const={Thy="arithmetic",Name="ZERO"},name=(["Number","Numeral"],"zero")}
-val _ = OpenTheory_const_name {const={Thy="num",Name="0"},name=(["Number","Numeral"],"zero")}
+val _ = OpenTheory_const_name {const={Thy="arithmetic",Name="ZERO"},name=(["Number","Natural"],"zero")}
+val _ = OpenTheory_const_name {const={Thy="num",Name="0"},name=(["Number","Natural"],"zero")}
end
val BIT1 =
@@ -99,8 +96,8 @@ val _ = new_definition(
--`^(mk_var(GrammarSpecials.nat_elim_term, Type`:num->num`)) n = n`--);
val _ = otunwanted "NUMERAL"
-val _ = otnum0 "BIT1" "bit1"
-val _ = otnum0 "BIT2" "bit2"
+val _ = ot0 "BIT1" "bit1"
+val _ = ot0 "BIT2" "bit2"
(*---------------------------------------------------------------------------*
* After this call, numerals parse into `NUMERAL( ... )` *
Please sign in to comment.
Something went wrong with that request. Please try again.