(* -------------------------------------------------------------------------- * The MetaML system is Copyright (c) Tim Sheard, Zino Benaissa, Walid * Taha, and the Oregon Graduate Institute of Science and Technology, 2000, * All rights reserved. It is distributed as free software under the * license in the file "License", which is included in the distribution. * * \RCSHOL.mml,v 1.1 2000/03/02 03:13:50 benaissa Exp * -------------------------------------------------------------------------*) (* -------------------------------------------------------------------------- * This file implements an HOL-like theorem prover for MetaML * A theorem is an instance of the datatype: * * datatype theorem = Thm of list * ; * * which is a predefined type in MetaML. This file uses several * primitive (built in functions) which are aware of this type * and are listed here for reference. force : b> -> -> update : -> int list -> -> get : -> int list -> search : <'b > -> <'a > -> int list list expand : -> expEq : -> -> bool quant1 : ( -> b) -> b quant2 : ( -> -> c) -> c quant3 : ( -> -> -> d) -> d verify1 : ( -> theorem) -> -> theorem verify2 : ( -> -> theorem) -> -> -> theorem show : theorem -> string showCode : -> string haltsPrim : -> bool * -------------------------------------------------------------------------*) (* ********************************************************************** *) (* This file depends upon the safe beta feature of MetaML being disabled *) fun safe_beta_off () = if feature 1 then feature 1 else true (* turn off safe beta *) ; fun safe_beta_on () = if feature 1 then true else feature 1 (* turn on safe beta *) ; val _ = safe_beta_off(); (* ******************************************************************* *) (* Some HOL-specific helper functions and definitions *) fun conclusion (Thm(p,c)) = c; fun premises (Thm(p,c)) = p; fun halts t = true; (* ********************************************************************* *) (* Some simple helper functions *) fun member x [] = false | member x (y::ys) = expEq x y orelse member x ys; (* Staged version of mem *) fun mem [] x = | mem [y] x = < ~x = ~(lift y) > | mem (y::ys) x = ; fun listEq [] [] = true | listEq (x::xs) (y::ys) = expEq x y andalso (listEq xs ys) | listEq x y = false; fun delete x [] = [] | delete x (y::ys) = if expEq x y then ys else x::(delete x ys); fun union [] ys = ys | union (x::xs) ys = if member x ys then union xs ys else x::(union xs ys); fun map f [] = [] | map f (x::xs) = (f x) :: (map f xs); val rec map =(fn f => (fn [] => [] | (x::xs) => (f x) :: (map f xs))); (* ************************************************************************* *) exception HOLex of string; fun test f msg = (f ()) handle (HOLex s) => (print (s^msg^"\n"); raise (HOLex s)); fun example b msg = if b then () else (print msg; raise HOLex msg); (* **************************************************************** *) (* Some tests of the "example" function and the primitives *) val ex1 = example (expEq (get <2+3> [0]) ) "get fails on: (expEq (get <2+3> [0]) )"; val ex2 = example (expEq (get <2+3> [1]) <(2,3) >) "get fails on: (expEq (get <2+3> [1]) <(2,3) >)"; val ex3 = example (expEq (get <2+3> [1,0]) <2 >) "get fails on: (expEq (get <2+3> [1,0]) <2 >)"; val ex4 = example (expEq (get <2+3> [1,1]) <3 >) "get fails on: (expEq (get <2+3> [1,1]) <3 >)"; (* **************************************************************** *) (* Now for some theorem constructors and combinators *) (* ********* PROMOTE to change the order of the premises ************ *) fun promote 0 l = l | promote n (x::l) = let val y::l = promote (n-1) l in y::x::l end | promote _ [] = raise (HOLex "no premises in promote") fun PROMOTE i Thm(p,c) = Thm(promote i p, c); (* ************ HALTS_EVAL, run it and see if it halts *************** *) fun HALTS_EVAL (t as < ~e>) = if halts(run t) then Thm([], ) else Thm([],) (* the second branch of the conditional can't happen *); val ex5 = HALTS_EVAL <[]>; (* ********** ASSUME, e |- e, for all e, by semantics of |- ******** *) fun ASSUME (b) = Thm ([b],b); (* ********************* The Resolution combinator ****************** *) fun RESOLVE (t1 as Thm(p,t)) (Thm(p',t')) = if member t' p then Thm(union (delete t' p) p', t) else error ("Conclusion "^(show t')^" is not a member hypothesis of\n "^(show t1)) (* ***** Discharging an assumption G,p|-c G'|-p=p gives G,G' |- p==>c *) fun DISCH t (Thm(p,c)) = (let val p1 = (delete t p) in Thm( :: p1, < if ~t then ~c else true> ) end) ; (example (expEq (conclusion (DISCH <2=2> (ASSUME <2=2>) )) ) "DISCH"); (* The Modus Ponens Rule G1 |- t1==>t2 G2|-t1 gives G1,G2 |- t2 *) fun MP (Thm(p1,< if ~t1 then ~t2 else true>)) (Thm(p2,tcd)) = if expEq < ~t1> tcd then Thm(union p1 p2, < ~t2>) else raise (HOLex "assumption of implication not equal to conclusion of theorem in MP") (* ************************* Paths ************************** *) (* A path is an int list *) (* A path selects a sub-expression within an expression. *) (* The path primitives are type-unsafe *) (* Paths are primitive, but could be implemented as follows *) (* for a simple subset of ML expressions. *) (* get : -> path -> fun get t1 [] = t1 | get (< ~f ~e>) (0::path) = (get f path) | get (< ~f ~e>) (1::path) = (get e path) | get ( <( ~x,~y)> ) (0::path) = (get x path) | get ( <( ~x,~y)> ) (1::path) = (get y path) | get ( ~(f)> ) (0::path) = get (f) path *************************************************************** *) (* One can define paths for expressions, Theorems etc. *) (* ******************************************************************* *) (* ********** Paths and substitutions over Theorems ****************** *) fun getTh (1::path) thm = get (conclusion thm) path | getTh (0:: n :: path) thm = let fun g 0 (p::ps) = get p path | g n (p::ps) = g (n-1) ps in g n (premises thm) end fun searchTh target (Thm(ps,c)) = let fun f n [] ans = ans | f n (p::ps) ans = (map (fn x => n :: x) (search target p)) @ (f (n+1) ps ans) in (map (fn x => 0 :: x) (f 0 ps [])) @ (map (fn x => 1 :: x) (search target c)) end; fun updateTh (1::path) term (Thm(ps,c)) = (Thm(ps,update c path term)) | updateTh (0:: n :: path) term (Thm(ps,c)) = let fun g 0 (p::ps) = (update p path term) :: ps | g n (p::ps) = p :: (g (n-1) ps) in Thm(g n ps,c) end; (* *************** Substitution Theorem combinator ******************* *) fun SUBSTTh path (Thm(p1,< ~t1 = ~t2>)) thm = if expEq (getTh path thm) t1 then let val Thm(p2,c2) = updateTh path t2 thm in Thm(union p1 p2,c2) end else raise (HOLex "terms don't match in SUBSTTh"); (* *************** Beta reduction in Theorems ********************* *) fun beta_reduce (z as < ~f ~x >) = let val term = force f x in if expEq z term then NONE else SOME term end | beta_reduce _ = NONE; fun down (w as < ~f ~x >) = if is_lambda (cast f) then beta_reduce w else case down (cast f) of NONE => NONE | SOME term => beta_reduce < ~(cast term) ~(cast x)>; fun BETATh (1::path) (Thm(ps,concl)) = let val term = get concl path in case down term of SOME term2 => Thm(ps,update concl path term2) | NONE => raise (HOLex "Beta reduction not possible here in BETATh") end | BETATh (0::n::path) (Thm(ps,concl)) = let fun f 0 (p::ps) = let val term = get p path in case down term of SOME term2 => (update p path term2)::ps | NONE => raise (HOLex "Beta reduction not possible here in BETATh") end | f n (p::ps) = p :: (f (n-1) ps) in Thm(f n ps,concl) end (* ****************** Using Definitions ******************* *) fun DEF_RIGHT path (Thm(ps,c)) = let val t = get c path in Thm(ps, (update c path (expand t))) end; fun DEF_LEFT path (Thm((p::ps),c)) = let val t = get p path in Thm((update p path (expand t))::ps, c) end; fun DEF (1::path) (Thm(ps,concl)) = (* LEFT *) let val t = get concl path in Thm(ps, (update concl path (expand t))) end | DEF (0::n::path) (Thm(ps,concl)) = (* RIGHT *) let fun f 0 (p::ps) = let val t = get p path in (update p path (expand t))::ps end | f n (p::ps) = p :: (f (n-1) ps) in Thm(f n ps,concl) end; (* ******************* A simple Meta program ********************* *) (* One that turns contexts into paths *) fun find f = quant1(fn x => search x (f x)); (* One that Both expands a defintion and then uses BETA *) fun UNFOLD n path thm = let val thm2 = DEF path thm val thm3 = BETATh (take(path,(length path) - n)) thm2 in thm3 end; (* One that does a case analysis when there is an "if" expressions *) fun IFELIM path thm = case getTh path thm of => let val th1 = ASSUME < ~t = true > val th2 = ASSUME < ~t = false > val thTrue = SUBSTTh (path @ [1]) th1 thm val thFalse = SUBSTTh (path @ [1]) th2 thm fun fixpath (0::n::path) = 0 :: (n+1) :: path (* SUBSTTh adds a premise *) | fixpath path = path in (BETATh (fixpath path) thTrue,BETATh (fixpath path) thFalse) end | t => error ("path is not an if in IFELIM:\n " ^(show t)); fun test a b c = ASSUME ; fun test2 a b c = IFELIM [1] (test a b c); (* One that removes an if if the test is known *) fun IFREDUCE path (thm as (Thm(ps,c))) = case getTh path thm of => if member < ~t = true > ps then updateTh path x thm else if member t ps then updateTh path x thm else if member ps then updateTh path y thm else if member <~t = false> ps then updateTh path y thm else error("the test of the if is not in the premises:\n "^(show t)) | t => error ("path is not an if in IFREDUCE:\n " ^(show t)); (* ********* Combinators to remove vacuous premises ********** *) fun HALTS_ALL_PRIM (Thm(prems,concl)) = let fun remove [] = [] | remove ((x as ())::xs) = if haltsPrim e then remove xs else x :: (remove xs) | remove (x :: xs) = x :: (remove xs) in Thm(remove prems,concl) end; fun REMTRUE (Thm(prems,concl)) = let fun remove [] = [] | remove ((x as ())::xs) = remove xs | remove (x :: xs) = x :: (remove xs) in Thm(remove prems,concl) end; (* ************************************************************* *) (* ***************** Axioms for datatypes ********************** *) (* ********************* integers ******************** *) fun commutes f x y = Thm([,],< ~f(~x, ~y) = ~f(~y,~x)>); fun halts_pair f x y = Thm([,],); val axioms_int = {+ = (commutes ), halts = (halts_pair )}; fun induce_int p n (Thm(gs1,c1)) (Thm(gs2,c2)) = if expEq (p <0>) c1 andalso expEq (p < ~ n + 1>) c2 andalso member (p n) gs2 then Thm(union [< ~n >= 0 >] (union gs1 (delete (p n) gs2)), p < ~n >) else raise (HOLex "bad form for induction over integers"); (* **************** booleans ********************** *) fun AXIOMBOOL (Thm(p::ps,c)) (Thm(q::qs,d)) = case (p,q) of (<~a = true>,<~a = false>) => if expEq c d andalso listEq ps qs then Thm(ps,c) else error "don't match in AXIOMBOOL" | _ => error "not form of (x = true) and (x=false) in premisies in AXIOMBOOL"; (* ********************** lists *************************** *) val msg_no_hyp = "Exactly one hypothesis allowed for inductive step in list induction: "; val msg_no_match = "In list inductive step, property to be proved "; fun induct p th1 rule2 = if expEq (p <[]>) (conclusion th1) then quant2 (fn x => fn xs => let val th2 = (rule2 x xs) val hyps = (premises th2) in if null hyps then error(msg_no_hyp ^ show hyps) else if not(expEq (p xs) (hd hyps)) then error(msg_no_match ^ (show (p xs)) ^ " does not match hypothesis " ^ show(hd hyps)) else if not( expEq (p < ~x :: ~xs >) (conclusion th2)) then error(msg_no_match ^ (show(p xs)) ^ " does not match conclusion " ^ (show(conclusion th2))) else fn z => Thm(union (premises th1)( :: (tl hyps)),p z) end) else error("incorrect base case for list induction " ^ (show th1)); val axioms_list = {:: = (halts_pair ), induction = induct}; (* ************************************************************************* *) (* Testing theorems *) fun try3 f = quant3 (fn x => fn y => (fn z => (print (show(f x y z))))); fun try2 f = quant2 (fn x => fn y => (print (show(f x y)))); fun try1 f = quant1 (fn x => print (show (f x))); fun Verify1 f = let val opt = verify1 f in fn x => case opt x of Thm(ps,concl) => Thm( :: ps,concl) end; (* ************************************************************* *) (* ***************** Now some proofs *************************** *) val rec length = fn [] => 0 | (x::xs) => 1 + length xs; val haltslen = let val thm1 = ASSUME (* %halts (%length ([])) |- %halts (%length ([])) *) val thm2 = DEF [0,0,1,0] thm1 (* %halts (case [] of ... ) |- %halts (%length ([])) *) val thm3 = HALTS_EVAL <0> (* %halts 0 *) val thm4 = BETATh [0,0,1] thm2 (* %halts 0 |- %halts (%length ([])) *) val thm5 = RESOLVE thm4 thm3 (* |- %halts (%length ([])) *) fun thm9 x l = ASSUME (* %halts (%length (z::zs)) |- %halts (%length (z::zs)) *) fun thm10 x l = DEF [0,0,1,0] (thm9 x l) (* %halts (case z::zs of ...) |- %halts (%length (z::zs)) *) fun thm11 x l = BETATh [0,0,1] (thm10 x l) (* %halts (1 %+ %length zs) |- %halts (%length (z::zs)) *) fun thm12 x l = ((# halts) axioms_int) <1> (* %halts 1; %halts (%length zs) |- %halts (1 %+ %length zs) *) fun thm13 x l = RESOLVE (thm11 x l) (thm12 x l) (* %halts 1, %halts (%length zs) |- %halts (%length (z::zs)) *) val thm14 = HALTS_EVAL <1> fun thm15 x l = RESOLVE (thm13 x l) thm14 (* %halts (%length zs) |- %halts (%length (z ::zs)) *) fun P x = val thm18 = ((# induction) axioms_list) P thm5 thm15 in thm18 end; (* ****************** Proof about append ************************* *) val rec append = (fn [] => (fn x => x) | (x::xs) => (fn ys => x :: (append xs ys))); fun P xs ys zs = < append zs (append ys xs) = append (append zs ys) xs >; fun thm1 y = ASSUME ; fun thm2 y = DEF_LEFT [1,0,0] (thm1 y); fun thm3 y = BETATh [0,0,1] (thm2 y) (* ****************** Proofs about Sorted ********************** *) val rec sorted = (fn [] => true | x::xs => (case xs of [] => true | (y::ys) => (x:int) <= y andalso sorted xs)); val rec insert = (fn a => (fn [] => [a] | (x::xs) => if a <= x then (a :: (x ::xs)) else x :: (insert a xs))); fun P a x = ; fun thm1 a = ASSUME (P a <[]>); fun thm2 a = DEF [0,0,1,0] (thm1 a); fun thm3 a = BETATh [0,0] (thm2 a); fun thm4 a = DEF [0,0,1,0,0] (thm3 a); fun thm5 a = BETATh [0,0,1] (thm4 a); fun thm6 a = DEF [0,0,0] (thm5 a); fun thm7 a = BETATh [0,0] (thm6 a); fun thm8 a = REMTRUE (thm7 a); fun thm9 a x xs = ASSUME (P a <~x :: ~xs>); fun thm10 a x xs = UNFOLD 2 [0,0,0,0,1,0,0] (thm9 a x xs); fun thm11 a x xs = IFELIM [0,0,0,0,1] (thm10 a x xs); fun thm12 a x xs = let val (t1,t2) = thm11 a x xs val t3 = UNFOLD 1 [0,1,0,0,0] t1 val t4 = IFREDUCE [0,1,0,0] t3 val (t5,t6) = IFELIM [0,1] t4 val t7 = IFREDUCE [0,2] t5 val t8 = REMTRUE t7 val t9 = REMTRUE t6 val t9B = AXIOMBOOL t8 t9 val t10 = UNFOLD 1 [0,1,0,0,0] t2 in t10 end; (* ****************************************************************** *) (* Staged version of mem *) fun mem [] x = | mem [y] x = < ~x = ~(lift y) > | mem (y::ys) x = ;