src/HOL/Tools/SMT/z3_model.ML

normalize Z3 models: assignments to free variables should ideally not refer to other free variables

(*  Title:      HOL/Tools/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) (Term.absdummy (dT', Const ("_", rT')))
      end

fun mk_lambda Ts (t, pats) =
  fold_rev (curry Term.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 SMT.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 SMT.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