--- a/src/HOL/Library/Old_SMT/z3_model.ML Thu Aug 28 00:40:38 2014 +0200
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,337 +0,0 @@
-(* Title: HOL/Library/Old_SMT/z3_model.ML
- Author: Sascha Boehme and Philipp Meyer, TU Muenchen
-
-Parser for counterexamples generated by Z3.
-*)
-
-signature Z3_MODEL =
-sig
- val parse_counterex: Proof.context -> SMT_Translate.recon -> string list ->
- term list * term list
-end
-
-structure Z3_Model: Z3_MODEL =
-struct
-
-
-(* counterexample expressions *)
-
-datatype expr = True | False | Number of int * int option | Value of int |
- Array of array | App of string * expr list
-and array = Fresh of expr | Store of (array * expr) * expr
-
-
-(* parsing *)
-
-val space = Scan.many Symbol.is_ascii_blank
-fun spaced p = p --| space
-fun in_parens p = spaced (Scan.$$ "(") |-- p --| spaced (Scan.$$ ")")
-fun in_braces p = spaced (Scan.$$ "{") |-- p --| spaced (Scan.$$ "}")
-
-val digit = (fn
- "0" => SOME 0 | "1" => SOME 1 | "2" => SOME 2 | "3" => SOME 3 |
- "4" => SOME 4 | "5" => SOME 5 | "6" => SOME 6 | "7" => SOME 7 |
- "8" => SOME 8 | "9" => SOME 9 | _ => NONE)
-
-val nat_num = spaced (Scan.repeat1 (Scan.some digit) >>
- (fn ds => fold (fn d => fn i => i * 10 + d) ds 0))
-val int_num = spaced (Scan.optional ($$ "-" >> K (fn i => ~i)) I :|--
- (fn sign => nat_num >> sign))
-
-val is_char = Symbol.is_ascii_letter orf Symbol.is_ascii_digit orf
- member (op =) (raw_explode "_+*-/%~=<>$&|?!.@^#")
-val name = spaced (Scan.many1 is_char >> implode)
-
-fun $$$ s = spaced (Scan.this_string s)
-
-fun array_expr st = st |> in_parens (
- $$$ "const" |-- expr >> Fresh ||
- $$$ "store" |-- array_expr -- expr -- expr >> Store)
-
-and expr st = st |> (
- $$$ "true" >> K True ||
- $$$ "false" >> K False ||
- int_num -- Scan.option ($$$ "/" |-- int_num) >> Number ||
- $$$ "val!" |-- nat_num >> Value ||
- name >> (App o rpair []) ||
- array_expr >> Array ||
- in_parens (name -- Scan.repeat1 expr) >> App)
-
-fun args st = ($$$ "->" >> K [] || expr ::: args) st
-val args_case = args -- expr
-val else_case = $$$ "else" -- $$$ "->" |-- expr >> pair ([] : expr list)
-
-val func =
- let fun cases st = (else_case >> single || args_case ::: cases) st
- in in_braces cases end
-
-val cex = space |--
- Scan.repeat (name --| $$$ "->" -- (func || expr >> (single o pair [])))
-
-fun resolve terms ((n, k), cases) =
- (case Symtab.lookup terms n of
- NONE => NONE
- | SOME t => SOME ((t, k), cases))
-
-fun annotate _ (_, []) = NONE
- | annotate terms (n, [([], c)]) = resolve terms ((n, 0), (c, []))
- | annotate _ (_, [_]) = NONE
- | annotate terms (n, cases as (args, _) :: _) =
- let val (cases', (_, else_case)) = split_last cases
- in resolve terms ((n, length args), (else_case, cases')) end
-
-fun read_cex terms ls =
- maps (cons "\n" o raw_explode) ls
- |> try (fst o Scan.finite Symbol.stopper cex)
- |> the_default []
- |> map_filter (annotate terms)
-
-
-(* translation into terms *)
-
-fun max_value vs =
- let
- fun max_val_expr (Value i) = Integer.max i
- | max_val_expr (App (_, es)) = fold max_val_expr es
- | max_val_expr (Array a) = max_val_array a
- | max_val_expr _ = I
-
- and max_val_array (Fresh e) = max_val_expr e
- | max_val_array (Store ((a, e1), e2)) =
- max_val_array a #> max_val_expr e1 #> max_val_expr e2
-
- fun max_val (_, (ec, cs)) =
- max_val_expr ec #> fold (fn (es, e) => fold max_val_expr (e :: es)) cs
-
- in fold max_val vs ~1 end
-
-fun with_context terms f vs = fst (fold_map f vs (terms, max_value vs + 1))
-
-fun get_term n T es (cx as (terms, next_val)) =
- (case Symtab.lookup terms n of
- SOME t => ((t, es), cx)
- | NONE =>
- let val t = Var (("skolem", next_val), T)
- in ((t, []), (Symtab.update (n, t) terms, next_val + 1)) end)
-
-fun trans_expr _ True = pair @{const True}
- | trans_expr _ False = pair @{const False}
- | trans_expr T (Number (i, NONE)) = pair (HOLogic.mk_number T i)
- | trans_expr T (Number (i, SOME j)) =
- pair (Const (@{const_name divide}, [T, T] ---> T) $
- HOLogic.mk_number T i $ HOLogic.mk_number T j)
- | trans_expr T (Value i) = pair (Var (("value", i), T))
- | trans_expr T (Array a) = trans_array T a
- | trans_expr T (App (n, es)) = get_term n T es #-> (fn (t, es') =>
- let val Ts = fst (SMT_Utils.dest_funT (length es') (Term.fastype_of t))
- in
- fold_map (uncurry trans_expr) (Ts ~~ es') #>> Term.list_comb o pair t
- end)
-
-and trans_array T a =
- let val (dT, rT) = Term.dest_funT T
- in
- (case a of
- Fresh e => trans_expr rT e #>> (fn t => Abs ("x", dT, t))
- | Store ((a', e1), e2) =>
- trans_array T a' ##>> trans_expr dT e1 ##>> trans_expr rT e2 #>>
- (fn ((m, k), v) =>
- Const (@{const_name fun_upd}, [T, dT, rT] ---> T) $ m $ k $ v))
- end
-
-fun trans_pattern T ([], e) = trans_expr T e #>> pair []
- | trans_pattern T (arg :: args, e) =
- trans_expr (Term.domain_type T) arg ##>>
- trans_pattern (Term.range_type T) (args, e) #>>
- (fn (arg', (args', e')) => (arg' :: args', e'))
-
-fun mk_fun_upd T U = Const (@{const_name fun_upd}, [T --> U, T, U, T] ---> U)
-
-fun mk_update ([], u) _ = u
- | mk_update ([t], u) f =
- uncurry mk_fun_upd (Term.dest_funT (Term.fastype_of f)) $ f $ t $ u
- | mk_update (t :: ts, u) f =
- let
- val (dT, rT) = Term.dest_funT (Term.fastype_of f)
- val (dT', rT') = Term.dest_funT rT
- in
- mk_fun_upd dT rT $ f $ t $
- mk_update (ts, u) (absdummy dT' (Const ("_", rT')))
- end
-
-fun mk_lambda Ts (t, pats) =
- fold_rev absdummy Ts t |> fold mk_update pats
-
-fun translate ((t, k), (e, cs)) =
- let
- val T = Term.fastype_of t
- val (Us, U) = SMT_Utils.dest_funT k (Term.fastype_of t)
-
- fun mk_full_def u' pats =
- pats
- |> filter_out (fn (_, u) => u aconv u')
- |> HOLogic.mk_eq o pair t o mk_lambda Us o pair u'
-
- fun mk_eq (us, u) = HOLogic.mk_eq (Term.list_comb (t, us), u)
- fun mk_eqs u' [] = [HOLogic.mk_eq (t, u')]
- | mk_eqs _ pats = map mk_eq pats
- in
- trans_expr U e ##>>
- (if k = 0 then pair [] else fold_map (trans_pattern T) cs) #>>
- (fn (u', pats) => (mk_eqs u' pats, mk_full_def u' pats))
- end
-
-
-(* normalization *)
-
-fun partition_eqs f =
- let
- fun part t (xs, ts) =
- (case try HOLogic.dest_eq t of
- SOME (l, r) => (case f l r of SOME x => (x::xs, ts) | _ => (xs, t::ts))
- | NONE => (xs, t :: ts))
- in (fn ts => fold part ts ([], [])) end
-
-fun first_eq pred =
- let
- fun part _ [] = NONE
- | part us (t :: ts) =
- (case try (pred o HOLogic.dest_eq) t of
- SOME (SOME lr) => SOME (lr, fold cons us ts)
- | _ => part (t :: us) ts)
- in (fn ts => part [] ts) end
-
-fun replace_vars tab =
- let
- fun repl v = the_default v (AList.lookup (op aconv) tab v)
- fun replace (v as Var _) = repl v
- | replace (v as Free _) = repl v
- | replace t = t
- in map (Term.map_aterms replace) end
-
-fun remove_int_nat_coercions (eqs, defs) =
- let
- fun mk_nat_num t i =
- (case try HOLogic.dest_number i of
- SOME (_, n) => SOME (t, HOLogic.mk_number @{typ nat} n)
- | NONE => NONE)
- fun nat_of (@{const of_nat (int)} $ (t as Var _)) i = mk_nat_num t i
- | nat_of (@{const nat} $ i) (t as Var _) = mk_nat_num t i
- | nat_of _ _ = NONE
- val (nats, eqs') = partition_eqs nat_of eqs
-
- fun is_coercion t =
- (case try HOLogic.dest_eq t of
- SOME (@{const of_nat (int)}, _) => true
- | SOME (@{const nat}, _) => true
- | _ => false)
- in pairself (replace_vars nats) (eqs', filter_out is_coercion defs) end
-
-fun unfold_funapp (eqs, defs) =
- let
- fun unfold_app (Const (@{const_name fun_app}, _) $ f $ t) = f $ t
- | unfold_app t = t
- fun unfold_eq ((eq as Const (@{const_name HOL.eq}, _)) $ t $ u) =
- eq $ unfold_app t $ u
- | unfold_eq t = t
-
- fun is_fun_app t =
- (case try HOLogic.dest_eq t of
- SOME (Const (@{const_name fun_app}, _), _) => true
- | _ => false)
-
- in (map unfold_eq eqs, filter_out is_fun_app defs) end
-
-val unfold_eqs =
- let
- val is_ground = not o Term.exists_subterm Term.is_Var
- fun is_non_rec (v, t) = not (Term.exists_subterm (equal v) t)
-
- fun rewr_var (l as Var _, r) = if is_ground r then SOME (l, r) else NONE
- | rewr_var (r, l as Var _) = if is_ground r then SOME (l, r) else NONE
- | rewr_var _ = NONE
-
- fun rewr_free' e = if is_non_rec e then SOME e else NONE
- fun rewr_free (e as (Free _, _)) = rewr_free' e
- | rewr_free (e as (_, Free _)) = rewr_free' (swap e)
- | rewr_free _ = NONE
-
- fun is_trivial (Const (@{const_name HOL.eq}, _) $ t $ u) = t aconv u
- | is_trivial _ = false
-
- fun replace r = replace_vars [r] #> filter_out is_trivial
-
- fun unfold_vars (es, ds) =
- (case first_eq rewr_var es of
- SOME (lr, es') => unfold_vars (pairself (replace lr) (es', ds))
- | NONE => (es, ds))
-
- fun unfold_frees ues (es, ds) =
- (case first_eq rewr_free es of
- SOME (lr, es') =>
- pairself (replace lr) (es', ds)
- |> unfold_frees (HOLogic.mk_eq lr :: replace lr ues)
- | NONE => (ues @ es, ds))
-
- in unfold_vars #> unfold_frees [] end
-
-fun swap_free ((eq as Const (@{const_name HOL.eq}, _)) $ t $ (u as Free _)) =
- eq $ u $ t
- | swap_free t = t
-
-fun frees_for_vars ctxt (eqs, defs) =
- let
- fun fresh_free i T (cx as (frees, ctxt)) =
- (case Inttab.lookup frees i of
- SOME t => (t, cx)
- | NONE =>
- let
- val (n, ctxt') = yield_singleton Variable.variant_fixes "" ctxt
- val t = Free (n, T)
- in (t, (Inttab.update (i, t) frees, ctxt')) end)
-
- fun repl_var (Var ((_, i), T)) = fresh_free i T
- | repl_var (t $ u) = repl_var t ##>> repl_var u #>> op $
- | repl_var (Abs (n, T, t)) = repl_var t #>> (fn t' => Abs (n, T, t'))
- | repl_var t = pair t
- in
- (Inttab.empty, ctxt)
- |> fold_map repl_var eqs
- ||>> fold_map repl_var defs
- |> fst
- end
-
-
-(* overall procedure *)
-
-val is_free_constraint = Term.exists_subterm (fn Free _ => true | _ => false)
-
-fun is_free_def (Const (@{const_name HOL.eq}, _) $ Free _ $ _) = true
- | is_free_def _ = false
-
-fun defined tp =
- try (pairself (fst o HOLogic.dest_eq)) tp
- |> the_default false o Option.map (op aconv)
-
-fun add_free_defs free_cs defs =
- let val (free_defs, defs') = List.partition is_free_def defs
- in (free_cs @ filter_out (member defined free_cs) free_defs, defs') end
-
-fun is_const_def (Const (@{const_name HOL.eq}, _) $ Const _ $ _) = true
- | is_const_def _ = false
-
-fun parse_counterex ctxt ({terms, ...} : SMT_Translate.recon) ls =
- read_cex terms ls
- |> with_context terms translate
- |> apfst flat o split_list
- |> remove_int_nat_coercions
- |> unfold_funapp
- |> unfold_eqs
- |>> map swap_free
- |>> filter is_free_constraint
- |-> add_free_defs
- |> frees_for_vars ctxt
- ||> filter is_const_def
-
-end
-