new proof method "argo" for a combination of quantifier-free propositional logic with equality and linear real arithmetic
authorboehmes
Thu Sep 29 20:54:44 2016 +0200 (2016-09-29)
changeset 639603daf02070be5
parent 63959 f77dca1abf1b
child 63961 2fd9656c4c82
new proof method "argo" for a combination of quantifier-free propositional logic with equality and linear real arithmetic
src/HOL/Argo.thy
src/HOL/ROOT
src/HOL/Real.thy
src/HOL/Tools/Argo/argo_real.ML
src/HOL/Tools/Argo/argo_tactic.ML
src/HOL/ex/Argo_Examples.thy
src/Tools/Argo/argo_cc.ML
src/Tools/Argo/argo_cdcl.ML
src/Tools/Argo/argo_clausify.ML
src/Tools/Argo/argo_cls.ML
src/Tools/Argo/argo_common.ML
src/Tools/Argo/argo_core.ML
src/Tools/Argo/argo_expr.ML
src/Tools/Argo/argo_heap.ML
src/Tools/Argo/argo_lit.ML
src/Tools/Argo/argo_proof.ML
src/Tools/Argo/argo_rewr.ML
src/Tools/Argo/argo_simplex.ML
src/Tools/Argo/argo_solver.ML
src/Tools/Argo/argo_term.ML
src/Tools/Argo/argo_thy.ML
     1.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     1.2 +++ b/src/HOL/Argo.thy	Thu Sep 29 20:54:44 2016 +0200
     1.3 @@ -0,0 +1,27 @@
     1.4 +(*  Title:      HOL/Argo.thy
     1.5 +    Author:     Sascha Boehme
     1.6 +*)
     1.7 +
     1.8 +theory Argo
     1.9 +imports HOL
    1.10 +begin
    1.11 +
    1.12 +ML_file "~~/src/Tools/Argo/argo_expr.ML"
    1.13 +ML_file "~~/src/Tools/Argo/argo_term.ML"
    1.14 +ML_file "~~/src/Tools/Argo/argo_lit.ML"
    1.15 +ML_file "~~/src/Tools/Argo/argo_proof.ML"
    1.16 +ML_file "~~/src/Tools/Argo/argo_rewr.ML"
    1.17 +ML_file "~~/src/Tools/Argo/argo_cls.ML"
    1.18 +ML_file "~~/src/Tools/Argo/argo_common.ML"
    1.19 +ML_file "~~/src/Tools/Argo/argo_cc.ML"
    1.20 +ML_file "~~/src/Tools/Argo/argo_simplex.ML"
    1.21 +ML_file "~~/src/Tools/Argo/argo_thy.ML"
    1.22 +ML_file "~~/src/Tools/Argo/argo_heap.ML"
    1.23 +ML_file "~~/src/Tools/Argo/argo_cdcl.ML"
    1.24 +ML_file "~~/src/Tools/Argo/argo_core.ML"
    1.25 +ML_file "~~/src/Tools/Argo/argo_clausify.ML"
    1.26 +ML_file "~~/src/Tools/Argo/argo_solver.ML"
    1.27 +
    1.28 +ML_file "Tools/Argo/argo_tactic.ML"
    1.29 +
    1.30 +end
     2.1 --- a/src/HOL/ROOT	Thu Sep 29 18:52:34 2016 +0200
     2.2 +++ b/src/HOL/ROOT	Thu Sep 29 20:54:44 2016 +0200
     2.3 @@ -626,6 +626,7 @@
     2.4      Sudoku
     2.5      Code_Timing
     2.6      Perm_Fragments
     2.7 +    Argo_Examples
     2.8    theories [skip_proofs = false]
     2.9      Meson_Test
    2.10    document_files "root.bib" "root.tex"
     3.1 --- a/src/HOL/Real.thy	Thu Sep 29 18:52:34 2016 +0200
     3.2 +++ b/src/HOL/Real.thy	Thu Sep 29 20:54:44 2016 +0200
     3.3 @@ -10,7 +10,7 @@
     3.4  section \<open>Development of the Reals using Cauchy Sequences\<close>
     3.5  
     3.6  theory Real
     3.7 -imports Rat
     3.8 +imports Rat Argo
     3.9  begin
    3.10  
    3.11  text \<open>
    3.12 @@ -1807,4 +1807,9 @@
    3.13    for x y :: real
    3.14    by auto
    3.15  
    3.16 +
    3.17 +subsection \<open>Setup for Argo\<close>
    3.18 +
    3.19 +ML_file "Tools/Argo/argo_real.ML"
    3.20 +
    3.21  end
     4.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     4.2 +++ b/src/HOL/Tools/Argo/argo_real.ML	Thu Sep 29 20:54:44 2016 +0200
     4.3 @@ -0,0 +1,297 @@
     4.4 +(*  Title:      HOL/Tools/argo_real.ML
     4.5 +    Author:     Sascha Boehme
     4.6 +
     4.7 +Extension of the Argo tactic for the reals.
     4.8 +*)
     4.9 +
    4.10 +structure Argo_Real: sig end =
    4.11 +struct
    4.12 +
    4.13 +(* translating input terms *)
    4.14 +
    4.15 +fun trans_type _ @{typ Real.real} tcx = SOME (Argo_Expr.Real, tcx)
    4.16 +  | trans_type _ _ _ = NONE
    4.17 +
    4.18 +fun trans_term f (@{const Groups.uminus_class.uminus (real)} $ t) tcx =
    4.19 +      tcx |> f t |>> Argo_Expr.mk_neg |> SOME
    4.20 +  | trans_term f (@{const Groups.plus_class.plus (real)} $ t1 $ t2) tcx =
    4.21 +      tcx |> f t1 ||>> f t2 |>> uncurry Argo_Expr.mk_add2 |> SOME
    4.22 +  | trans_term f (@{const Groups.minus_class.minus (real)} $ t1 $ t2) tcx =
    4.23 +      tcx |> f t1 ||>> f t2 |>> uncurry Argo_Expr.mk_sub |> SOME
    4.24 +  | trans_term f (@{const Groups.times_class.times (real)} $ t1 $ t2) tcx =
    4.25 +      tcx |> f t1 ||>> f t2 |>> uncurry Argo_Expr.mk_mul |> SOME
    4.26 +  | trans_term f (@{const Rings.divide_class.divide (real)} $ t1 $ t2) tcx =
    4.27 +      tcx |> f t1 ||>> f t2 |>> uncurry Argo_Expr.mk_div |> SOME
    4.28 +  | trans_term f (@{const Orderings.ord_class.min (real)} $ t1 $ t2) tcx =
    4.29 +      tcx |> f t1 ||>> f t2 |>> uncurry Argo_Expr.mk_min |> SOME
    4.30 +  | trans_term f (@{const Orderings.ord_class.max (real)} $ t1 $ t2) tcx =
    4.31 +      tcx |> f t1 ||>> f t2 |>> uncurry Argo_Expr.mk_max |> SOME
    4.32 +  | trans_term f (@{const Groups.abs_class.abs (real)} $ t) tcx =
    4.33 +      tcx |> f t |>> Argo_Expr.mk_abs |> SOME
    4.34 +  | trans_term f (@{const Orderings.ord_class.less (real)} $ t1 $ t2) tcx =
    4.35 +      tcx |> f t1 ||>> f t2 |>> uncurry Argo_Expr.mk_lt |> SOME
    4.36 +  | trans_term f (@{const Orderings.ord_class.less_eq (real)} $ t1 $ t2) tcx =
    4.37 +      tcx |> f t1 ||>> f t2 |>> uncurry Argo_Expr.mk_le |> SOME
    4.38 +  | trans_term _ t tcx =
    4.39 +      (case try HOLogic.dest_number t of
    4.40 +        SOME (@{typ Real.real}, n) => SOME (Argo_Expr.mk_num (Rat.of_int n), tcx)
    4.41 +      | _ => NONE)
    4.42 +
    4.43 +
    4.44 +(* reverse translation *)
    4.45 +
    4.46 +fun mk_plus t1 t2 = @{const Groups.plus_class.plus (real)} $ t1 $ t2
    4.47 +fun mk_sum ts = uncurry (fold_rev mk_plus) (split_last ts)
    4.48 +fun mk_times t1 t2 = @{const Groups.times_class.times (real)} $ t1 $ t2
    4.49 +fun mk_divide t1 t2 = @{const Rings.divide_class.divide (real)} $ t1 $ t2
    4.50 +fun mk_le t1 t2 = @{const Orderings.ord_class.less_eq (real)} $ t1 $ t2
    4.51 +fun mk_lt t1 t2 = @{const Orderings.ord_class.less (real)} $ t1 $ t2
    4.52 +
    4.53 +fun mk_real_num i = HOLogic.mk_number @{typ Real.real} i
    4.54 +
    4.55 +fun mk_number n =
    4.56 +  let val (p, q) = Rat.dest n
    4.57 +  in if q = 1 then mk_real_num p else mk_divide (mk_real_num p) (mk_real_num q) end
    4.58 +
    4.59 +fun term_of _ (Argo_Expr.E (Argo_Expr.Num n, _)) = SOME (mk_number n)
    4.60 +  | term_of f (Argo_Expr.E (Argo_Expr.Neg, [e])) =
    4.61 +      SOME (@{const Groups.uminus_class.uminus (real)} $ f e)
    4.62 +  | term_of f (Argo_Expr.E (Argo_Expr.Add, es)) = SOME (mk_sum (map f es))
    4.63 +  | term_of f (Argo_Expr.E (Argo_Expr.Sub, [e1, e2])) =
    4.64 +      SOME (@{const Groups.minus_class.minus (real)} $ f e1 $ f e2)
    4.65 +  | term_of f (Argo_Expr.E (Argo_Expr.Mul, [e1, e2])) = SOME (mk_times (f e1) (f e2))
    4.66 +  | term_of f (Argo_Expr.E (Argo_Expr.Div, [e1, e2])) = SOME (mk_divide (f e1) (f e2))
    4.67 +  | term_of f (Argo_Expr.E (Argo_Expr.Min, [e1, e2])) =
    4.68 +      SOME (@{const Orderings.ord_class.min (real)} $ f e1 $ f e2)
    4.69 +  | term_of f (Argo_Expr.E (Argo_Expr.Max, [e1, e2])) =
    4.70 +      SOME (@{const Orderings.ord_class.max (real)} $ f e1 $ f e2)
    4.71 +  | term_of f (Argo_Expr.E (Argo_Expr.Abs, [e])) = SOME (@{const Groups.abs_class.abs (real)} $ f e)
    4.72 +  | term_of f (Argo_Expr.E (Argo_Expr.Le, [e1, e2])) = SOME (mk_le (f e1) (f e2))
    4.73 +  | term_of f (Argo_Expr.E (Argo_Expr.Lt, [e1, e2])) = SOME (mk_lt (f e1) (f e2))
    4.74 +  | term_of _ _ = NONE
    4.75 +
    4.76 +
    4.77 +(* proof replay for rewrite steps *)
    4.78 +
    4.79 +fun mk_rewr thm = thm RS @{thm eq_reflection}
    4.80 +
    4.81 +fun by_simp ctxt t = 
    4.82 +  let fun prove {context, ...} = HEADGOAL (Simplifier.simp_tac context)
    4.83 +  in Goal.prove ctxt [] [] (HOLogic.mk_Trueprop t) prove end
    4.84 +
    4.85 +fun prove_num_pred ctxt n =
    4.86 +  by_simp ctxt (uncurry mk_lt (apply2 mk_number (if @0 < n then (@0, n) else (n, @0))))
    4.87 +
    4.88 +fun simp_conv ctxt t = Conv.rewr_conv (mk_rewr (by_simp ctxt t))
    4.89 +
    4.90 +fun nums_conv mk f ctxt n m =
    4.91 +  simp_conv ctxt (HOLogic.mk_eq (mk (mk_number n) (mk_number m), mk_number (f (n, m))))
    4.92 +
    4.93 +val add_nums_conv = nums_conv mk_plus (op +)
    4.94 +val mul_nums_conv = nums_conv mk_times (op *)
    4.95 +val div_nums_conv = nums_conv mk_divide (op /)
    4.96 +
    4.97 +fun cmp_nums_conv ctxt b ct =
    4.98 +  let val t = if b then @{const HOL.True} else @{const HOL.False}
    4.99 +  in simp_conv ctxt (HOLogic.mk_eq (Thm.term_of ct, t)) ct end
   4.100 +
   4.101 +local
   4.102 +
   4.103 +fun is_add2 (@{const Groups.plus_class.plus (real)} $ _ $ _) = true
   4.104 +  | is_add2 _ = false
   4.105 +
   4.106 +fun is_add3 (@{const Groups.plus_class.plus (real)} $ _ $ t) = is_add2 t
   4.107 +  | is_add3 _ = false
   4.108 +
   4.109 +val flatten_thm = mk_rewr @{lemma "(a::real) + b + c = a + (b + c)" by simp}
   4.110 +  
   4.111 +fun flatten_conv ct =
   4.112 +  if is_add2 (Thm.term_of ct) then Argo_Tactic.flatten_conv flatten_conv flatten_thm ct
   4.113 +  else Conv.all_conv ct
   4.114 +
   4.115 +val swap_conv = Conv.rewrs_conv (map mk_rewr @{lemma 
   4.116 +  "(a::real) + (b + c) = b + (a + c)"
   4.117 +  "(a::real) + b = b + a"
   4.118 +  by simp_all})
   4.119 +
   4.120 +val assoc_conv = Conv.rewr_conv (mk_rewr @{lemma "(a::real) + (b + c) = (a + b) + c" by simp})
   4.121 +
   4.122 +val norm_monom_thm = mk_rewr @{lemma "1 * (a::real) = a" by simp}
   4.123 +fun norm_monom_conv n = if n = @1 then Conv.rewr_conv norm_monom_thm else Conv.all_conv
   4.124 +
   4.125 +val add2_thms = map mk_rewr @{lemma
   4.126 +  "n * (a::real) + m * a = (n + m) * a"
   4.127 +  "n * (a::real) + a = (n + 1) * a"
   4.128 +  "(a::real) + m * a = (1 + m) * a"
   4.129 +  "(a::real) + a = (1 + 1) * a"
   4.130 +  by algebra+}
   4.131 +
   4.132 +val add3_thms = map mk_rewr @{lemma
   4.133 +  "n * (a::real) + (m * a + b) = (n + m) * a + b"
   4.134 +  "n * (a::real) + (a + b) = (n + 1) * a + b"
   4.135 +  "(a::real) + (m * a + b) = (1 + m) * a + b"
   4.136 +  "(a::real) + (a + b) = (1 + 1) * a + b"
   4.137 +  by algebra+}
   4.138 +
   4.139 +fun choose_conv cv2 cv3 ct = if is_add3 (Thm.term_of ct) then cv3 ct else cv2 ct
   4.140 +
   4.141 +fun join_num_conv ctxt n m =
   4.142 +  let val conv = add_nums_conv ctxt n m
   4.143 +  in choose_conv conv (assoc_conv then_conv Conv.arg1_conv conv) end
   4.144 +
   4.145 +fun join_monom_conv ctxt n m =
   4.146 +  let
   4.147 +    val conv = Conv.arg1_conv (add_nums_conv ctxt n m) then_conv norm_monom_conv (n + m)
   4.148 +    fun seq_conv thms cv = Conv.rewrs_conv thms then_conv cv
   4.149 +  in choose_conv (seq_conv add2_thms conv) (seq_conv add3_thms (Conv.arg1_conv conv)) end
   4.150 +
   4.151 +fun join_conv NONE = join_num_conv
   4.152 +  | join_conv (SOME _) = join_monom_conv
   4.153 +
   4.154 +fun bubble_down_conv _ _ [] ct = Conv.no_conv ct
   4.155 +  | bubble_down_conv _ _ [_] ct = Conv.all_conv ct
   4.156 +  | bubble_down_conv ctxt i ((m1 as (n1, i1)) :: (m2 as (n2, i2)) :: ms) ct =
   4.157 +      if i1 = i then
   4.158 +        if i2 = i then
   4.159 +          (join_conv i ctxt n1 n2 then_conv bubble_down_conv ctxt i ((n1 + n2, i) :: ms)) ct
   4.160 +        else (swap_conv then_conv Conv.arg_conv (bubble_down_conv ctxt i (m1 :: ms))) ct
   4.161 +      else Conv.arg_conv (bubble_down_conv ctxt i (m2 :: ms)) ct
   4.162 +
   4.163 +fun drop_var i ms = filter_out (fn (_, i') => i' = i) ms
   4.164 +
   4.165 +fun permute_conv _ [] [] ct = Conv.all_conv ct
   4.166 +  | permute_conv ctxt (ms as ((_, i) :: _)) [] ct =
   4.167 +      (bubble_down_conv ctxt i ms then_conv permute_conv ctxt (drop_var i ms) []) ct
   4.168 +  | permute_conv ctxt ms1 ms2 ct =
   4.169 +      let val (ms2', (_, i)) = split_last ms2
   4.170 +      in (bubble_down_conv ctxt i ms1 then_conv permute_conv ctxt (drop_var i ms1) ms2') ct end
   4.171 +
   4.172 +val no_monom_conv = Conv.rewr_conv (mk_rewr @{lemma "0 * (a::real) = 0" by simp})
   4.173 +
   4.174 +val norm_sum_conv = Conv.rewrs_conv (map mk_rewr @{lemma
   4.175 +  "0 * (a::real) + b = b"
   4.176 +  "(a::real) + 0 * b = a"
   4.177 +  "0 + (a::real) = a"
   4.178 +  "(a::real) + 0 = a"
   4.179 +  by simp_all})
   4.180 +
   4.181 +fun drop0_conv ct =
   4.182 +  if is_add2 (Thm.term_of ct) then
   4.183 +    ((norm_sum_conv then_conv drop0_conv) else_conv Conv.arg_conv drop0_conv) ct
   4.184 +  else Conv.try_conv no_monom_conv ct
   4.185 +
   4.186 +fun full_add_conv ctxt ms1 ms2 =
   4.187 +  if eq_list (op =) (ms1, ms2) then flatten_conv
   4.188 +  else flatten_conv then_conv permute_conv ctxt ms1 ms2 then_conv drop0_conv
   4.189 +
   4.190 +in
   4.191 +
   4.192 +fun add_conv ctxt (ms1, ms2 as [(n, NONE)]) =
   4.193 +      if n = @0 then full_add_conv ctxt ms1 [] else full_add_conv ctxt ms1 ms2
   4.194 +  | add_conv ctxt (ms1, ms2) = full_add_conv ctxt ms1 ms2
   4.195 +
   4.196 +end
   4.197 +
   4.198 +val mul_sum_thm = mk_rewr @{lemma "(x::real) * (y + z) = x * y + x * z" by (rule ring_distribs)}
   4.199 +fun mul_sum_conv ct =
   4.200 +  Conv.try_conv (Conv.rewr_conv mul_sum_thm then_conv Conv.binop_conv mul_sum_conv) ct
   4.201 +
   4.202 +fun var_of_add_cmp (_ $ _ $ (_ $ _ $ (_ $ _ $ Var v))) = v
   4.203 +  | var_of_add_cmp t = raise TERM ("var_of_add_cmp", [t])
   4.204 +
   4.205 +fun add_cmp_conv ctxt n thm =
   4.206 +  let val v = var_of_add_cmp (Thm.prop_of thm)
   4.207 +  in Conv.rewr_conv (Thm.instantiate ([], [(v, Thm.cterm_of ctxt (mk_number n))]) thm) end
   4.208 +
   4.209 +fun mul_cmp_conv ctxt n pos_thm neg_thm =
   4.210 +  let val thm = if @0 < n then pos_thm else neg_thm
   4.211 +  in Conv.rewr_conv (prove_num_pred ctxt n RS thm) end
   4.212 +
   4.213 +val neg_thm = mk_rewr @{lemma "-(x::real) = -1 * x" by simp}
   4.214 +val sub_thm = mk_rewr @{lemma "(x::real) - y = x + -1 * y" by simp}
   4.215 +val mul_zero_thm = mk_rewr @{lemma "0 * (x::real) = 0" by (rule mult_zero_left)}
   4.216 +val mul_one_thm = mk_rewr @{lemma "1 * (x::real) = x" by (rule mult_1)}
   4.217 +val mul_comm_thm = mk_rewr @{lemma "(x::real) * y = y * x" by simp}
   4.218 +val mul_assoc_thm = mk_rewr @{lemma "(x::real) * (y * z) = (x * y) * z" by simp}
   4.219 +val div_zero_thm = mk_rewr @{lemma "0 / (x::real) = 0" by simp}
   4.220 +val div_one_thm = mk_rewr @{lemma "(x::real) / 1 = x" by simp}
   4.221 +val div_mul_thm = mk_rewr @{lemma "(x::real) / y = x * (1 / y)" by simp}
   4.222 +val div_inv_thm = mk_rewr @{lemma "(x::real) / y = (1 / y) * x" by simp}
   4.223 +val div_left_thm = mk_rewr @{lemma "((x::real) * y) / z = x * (y / z)" by simp}
   4.224 +val div_right_thm = mk_rewr @{lemma "(x::real) / (y * z) = (1 / y) * (x / z)" by simp}
   4.225 +val min_thm = mk_rewr @{lemma "min (x::real) y = (if x <= y then x else y)" by (rule min_def)}
   4.226 +val max_thm = mk_rewr @{lemma "max (x::real) y = (if x <= y then y else x)" by (rule max_def)}
   4.227 +val abs_thm = mk_rewr @{lemma "abs (x::real) = (if 0 <= x then x else -x)" by simp}
   4.228 +val eq_le_thm = mk_rewr @{lemma "((x::real) = y) = ((x <= y) & (y <= x))" by (rule order_eq_iff)}
   4.229 +val add_le_thm = mk_rewr @{lemma "((x::real) <= y) = (x + n <= y + n)" by simp}
   4.230 +val add_lt_thm = mk_rewr @{lemma "((x::real) < y) = (x + n < y + n)" by simp}
   4.231 +val sub_le_thm = mk_rewr @{lemma "((x::real) <= y) = (x - y <= 0)" by simp}
   4.232 +val sub_lt_thm = mk_rewr @{lemma "((x::real) < y) = (x - y < 0)" by simp}
   4.233 +val pos_mul_le_thm = mk_rewr @{lemma "0 < n ==> ((x::real) <= y) = (n * x <= n * y)" by simp}
   4.234 +val neg_mul_le_thm = mk_rewr @{lemma "n < 0 ==> ((x::real) <= y) = (n * y <= n * x)" by simp}
   4.235 +val pos_mul_lt_thm = mk_rewr @{lemma "0 < n ==> ((x::real) < y) = (n * x < n * y)" by simp}
   4.236 +val neg_mul_lt_thm = mk_rewr @{lemma "n < 0 ==> ((x::real) < y) = (n * y < n * x)" by simp}
   4.237 +val not_le_thm = mk_rewr @{lemma "(~((x::real) <= y)) = (y < x)" by auto}
   4.238 +val not_lt_thm = mk_rewr @{lemma "(~((x::real) < y)) = (y <= x)" by auto}
   4.239 +
   4.240 +fun replay_rewr _ Argo_Proof.Rewr_Neg = Conv.rewr_conv neg_thm
   4.241 +  | replay_rewr ctxt (Argo_Proof.Rewr_Add ps) = add_conv ctxt ps
   4.242 +  | replay_rewr _ Argo_Proof.Rewr_Sub = Conv.rewr_conv sub_thm
   4.243 +  | replay_rewr _ Argo_Proof.Rewr_Mul_Zero = Conv.rewr_conv mul_zero_thm
   4.244 +  | replay_rewr _ Argo_Proof.Rewr_Mul_One = Conv.rewr_conv mul_one_thm
   4.245 +  | replay_rewr ctxt (Argo_Proof.Rewr_Mul_Nums (n, m)) = mul_nums_conv ctxt n m
   4.246 +  | replay_rewr _ Argo_Proof.Rewr_Mul_Comm = Conv.rewr_conv mul_comm_thm
   4.247 +  | replay_rewr _ Argo_Proof.Rewr_Mul_Assoc = Conv.rewr_conv mul_assoc_thm
   4.248 +  | replay_rewr _ Argo_Proof.Rewr_Mul_Sum = mul_sum_conv
   4.249 +  | replay_rewr ctxt (Argo_Proof.Rewr_Div_Nums (n, m)) = div_nums_conv ctxt n m
   4.250 +  | replay_rewr _ Argo_Proof.Rewr_Div_Zero = Conv.rewr_conv div_zero_thm
   4.251 +  | replay_rewr _ Argo_Proof.Rewr_Div_One = Conv.rewr_conv div_one_thm
   4.252 +  | replay_rewr _ Argo_Proof.Rewr_Div_Mul = Conv.rewr_conv div_mul_thm
   4.253 +  | replay_rewr _ Argo_Proof.Rewr_Div_Inv = Conv.rewr_conv div_inv_thm
   4.254 +  | replay_rewr _ Argo_Proof.Rewr_Div_Left = Conv.rewr_conv div_left_thm
   4.255 +  | replay_rewr _ Argo_Proof.Rewr_Div_Right = Conv.rewr_conv div_right_thm
   4.256 +  | replay_rewr _ Argo_Proof.Rewr_Min = Conv.rewr_conv min_thm
   4.257 +  | replay_rewr _ Argo_Proof.Rewr_Max = Conv.rewr_conv max_thm
   4.258 +  | replay_rewr _ Argo_Proof.Rewr_Abs = Conv.rewr_conv abs_thm
   4.259 +  | replay_rewr _ Argo_Proof.Rewr_Eq_Le = Conv.rewr_conv eq_le_thm
   4.260 +  | replay_rewr ctxt (Argo_Proof.Rewr_Ineq_Nums (_, b)) = cmp_nums_conv ctxt b
   4.261 +  | replay_rewr ctxt (Argo_Proof.Rewr_Ineq_Add (Argo_Proof.Le, n)) =
   4.262 +      add_cmp_conv ctxt n add_le_thm
   4.263 +  | replay_rewr ctxt (Argo_Proof.Rewr_Ineq_Add (Argo_Proof.Lt, n)) =
   4.264 +      add_cmp_conv ctxt n add_lt_thm
   4.265 +  | replay_rewr _ (Argo_Proof.Rewr_Ineq_Sub Argo_Proof.Le) = Conv.rewr_conv sub_le_thm
   4.266 +  | replay_rewr _ (Argo_Proof.Rewr_Ineq_Sub Argo_Proof.Lt) = Conv.rewr_conv sub_lt_thm
   4.267 +  | replay_rewr ctxt (Argo_Proof.Rewr_Ineq_Mul (Argo_Proof.Le, n)) =
   4.268 +      mul_cmp_conv ctxt n pos_mul_le_thm neg_mul_le_thm
   4.269 +  | replay_rewr ctxt (Argo_Proof.Rewr_Ineq_Mul (Argo_Proof.Lt, n)) =
   4.270 +      mul_cmp_conv ctxt n pos_mul_lt_thm neg_mul_lt_thm
   4.271 +  | replay_rewr _ (Argo_Proof.Rewr_Not_Ineq Argo_Proof.Le) = Conv.rewr_conv not_le_thm
   4.272 +  | replay_rewr _ (Argo_Proof.Rewr_Not_Ineq Argo_Proof.Lt) = Conv.rewr_conv not_lt_thm
   4.273 +  | replay_rewr _ _ = Conv.no_conv
   4.274 +
   4.275 +
   4.276 +(* proof replay *)
   4.277 +
   4.278 +val combine_thms = @{lemma
   4.279 +  "(a::real) < b ==> c < d ==> a + c < b + d"
   4.280 +  "(a::real) < b ==> c <= d ==> a + c < b + d"
   4.281 +  "(a::real) <= b ==> c < d ==> a + c < b + d"
   4.282 +  "(a::real) <= b ==> c <= d ==> a + c <= b + d"
   4.283 +  by auto}
   4.284 +
   4.285 +fun combine thm1 thm2 = hd (Argo_Tactic.discharges thm2 (Argo_Tactic.discharges thm1 combine_thms))
   4.286 +
   4.287 +fun replay _ _ Argo_Proof.Linear_Comb prems = SOME (uncurry (fold_rev combine) (split_last prems))
   4.288 +  | replay _ _ _ _ = NONE
   4.289 +
   4.290 +
   4.291 +(* real extension of the Argo solver *)
   4.292 +
   4.293 +val _ = Theory.setup (Argo_Tactic.add_extension {
   4.294 +  trans_type = trans_type,
   4.295 +  trans_term = trans_term,
   4.296 +  term_of = term_of,
   4.297 +  replay_rewr = replay_rewr,
   4.298 +  replay = replay})
   4.299 +
   4.300 +end
     5.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     5.2 +++ b/src/HOL/Tools/Argo/argo_tactic.ML	Thu Sep 29 20:54:44 2016 +0200
     5.3 @@ -0,0 +1,730 @@
     5.4 +(*  Title:      HOL/Tools/argo_tactic.ML
     5.5 +    Author:     Sascha Boehme
     5.6 +
     5.7 +HOL method and tactic for the Argo solver.
     5.8 +*)
     5.9 +
    5.10 +signature ARGO_TACTIC =
    5.11 +sig
    5.12 +  val trace: string Config.T
    5.13 +  val timeout: real Config.T
    5.14 +
    5.15 +  (* extending the tactic *)
    5.16 +  type trans_context =
    5.17 +    Name.context * Argo_Expr.typ Typtab.table * (string * Argo_Expr.typ) Termtab.table
    5.18 +  type ('a, 'b) trans = 'a -> trans_context -> 'b * trans_context
    5.19 +  type ('a, 'b) trans' = 'a -> trans_context -> ('b * trans_context) option
    5.20 +  type extension = {
    5.21 +    trans_type: (typ, Argo_Expr.typ) trans -> (typ, Argo_Expr.typ) trans',
    5.22 +    trans_term: (term, Argo_Expr.expr) trans -> (term, Argo_Expr.expr) trans',
    5.23 +    term_of: (Argo_Expr.expr -> term) -> Argo_Expr.expr -> term option,
    5.24 +    replay_rewr: Proof.context -> Argo_Proof.rewrite -> conv,
    5.25 +    replay: (Argo_Expr.expr -> cterm) -> Proof.context -> Argo_Proof.rule -> thm list -> thm option}
    5.26 +  val add_extension: extension -> theory -> theory
    5.27 +
    5.28 +  (* proof utilities *)
    5.29 +  val discharges: thm -> thm list -> thm list
    5.30 +  val flatten_conv: conv -> thm -> conv
    5.31 +
    5.32 +  (* interface to the tactic as well as the underlying checker and prover *)
    5.33 +  datatype result = Satisfiable of term -> bool option | Unsatisfiable
    5.34 +  val check: term list -> Proof.context -> result * Proof.context
    5.35 +  val prove: thm list -> Proof.context -> thm option * Proof.context
    5.36 +  val argo_tac: Proof.context -> thm list -> int -> tactic
    5.37 +end
    5.38 +
    5.39 +structure Argo_Tactic: ARGO_TACTIC =
    5.40 +struct
    5.41 +
    5.42 +(* readable fresh names for terms *)
    5.43 +
    5.44 +fun fresh_name n = Name.variant (case Long_Name.base_name n of "" => "x" | n' => n')
    5.45 +
    5.46 +fun fresh_type_name (Type (n, _)) = fresh_name n
    5.47 +  | fresh_type_name (TFree (n, _)) = fresh_name n
    5.48 +  | fresh_type_name (TVar ((n, i), _)) = fresh_name (n ^ "." ^ string_of_int i)
    5.49 +
    5.50 +fun fresh_term_name (Const (n, _)) = fresh_name n
    5.51 +  | fresh_term_name (Free (n, _)) = fresh_name n
    5.52 +  | fresh_term_name (Var ((n, i), _)) = fresh_name (n ^ "." ^ string_of_int i)
    5.53 +  | fresh_term_name _ = fresh_name ""
    5.54 +
    5.55 +
    5.56 +(* tracing *)
    5.57 +
    5.58 +datatype mode = None | Basic | Full
    5.59 +
    5.60 +fun string_of_mode None = "none"
    5.61 +  | string_of_mode Basic = "basic"
    5.62 +  | string_of_mode Full = "full"
    5.63 +
    5.64 +fun requires_mode None = []
    5.65 +  | requires_mode Basic = [Basic, Full]
    5.66 +  | requires_mode Full = [Full]
    5.67 +
    5.68 +val trace = Attrib.setup_config_string @{binding argo_trace} (K (string_of_mode None))
    5.69 +
    5.70 +fun allows_mode ctxt = exists (equal (Config.get ctxt trace) o string_of_mode) o requires_mode
    5.71 +
    5.72 +fun output mode ctxt msg = if allows_mode ctxt mode then Output.tracing ("Argo: " ^ msg) else ()
    5.73 +val tracing = output Basic
    5.74 +val full_tracing = output Full
    5.75 +
    5.76 +fun with_mode mode ctxt f = if allows_mode ctxt mode then f ctxt else ()
    5.77 +val with_tracing = with_mode Basic
    5.78 +val with_full_tracing = with_mode Full
    5.79 +
    5.80 +
    5.81 +(* timeout *)
    5.82 +
    5.83 +val timeout = Attrib.setup_config_real @{binding argo_timeout} (K 10.0)
    5.84 +
    5.85 +fun time_of_timeout ctxt = Time.fromReal (Config.get ctxt timeout)
    5.86 +
    5.87 +fun with_timeout ctxt f x = Timeout.apply (time_of_timeout ctxt) f x
    5.88 +
    5.89 +
    5.90 +(* extending the tactic *)
    5.91 +
    5.92 +type trans_context =
    5.93 +  Name.context * Argo_Expr.typ Typtab.table * (string * Argo_Expr.typ) Termtab.table
    5.94 +
    5.95 +type ('a, 'b) trans = 'a -> trans_context -> 'b * trans_context
    5.96 +type ('a, 'b) trans' = 'a -> trans_context -> ('b * trans_context) option
    5.97 +
    5.98 +type extension = {
    5.99 +  trans_type: (typ, Argo_Expr.typ) trans -> (typ, Argo_Expr.typ) trans',
   5.100 +  trans_term: (term, Argo_Expr.expr) trans -> (term, Argo_Expr.expr) trans',
   5.101 +  term_of: (Argo_Expr.expr -> term) -> Argo_Expr.expr -> term option,
   5.102 +  replay_rewr: Proof.context -> Argo_Proof.rewrite -> conv,
   5.103 +  replay: (Argo_Expr.expr -> cterm) -> Proof.context -> Argo_Proof.rule -> thm list -> thm option}
   5.104 +
   5.105 +fun eq_extension ((serial1, _), (serial2, _)) = (serial1 = serial2)
   5.106 +
   5.107 +structure Extensions = Theory_Data
   5.108 +(
   5.109 +  type T = (serial * extension) list
   5.110 +  val empty = []
   5.111 +  val extend = I
   5.112 +  val merge = merge eq_extension 
   5.113 +)
   5.114 +
   5.115 +fun add_extension ext = Extensions.map (insert eq_extension (serial (), ext))
   5.116 +fun get_extensions ctxt = Extensions.get (Proof_Context.theory_of ctxt)
   5.117 +fun apply_first ctxt f = get_first (fn (_, e) => f e) (get_extensions ctxt)
   5.118 +
   5.119 +fun ext_trans sel ctxt f x tcx = apply_first ctxt (fn ext => sel ext f x tcx)
   5.120 +
   5.121 +val ext_trans_type = ext_trans (fn {trans_type, ...}: extension => trans_type)
   5.122 +val ext_trans_term = ext_trans (fn {trans_term, ...}: extension => trans_term)
   5.123 +
   5.124 +fun ext_term_of ctxt f e = apply_first ctxt (fn {term_of, ...}: extension => term_of f e)
   5.125 +
   5.126 +fun ext_replay_rewr ctxt r = 
   5.127 +  get_extensions ctxt
   5.128 +  |> map (fn (_, {replay_rewr, ...}: extension) => replay_rewr ctxt r)
   5.129 +  |> Conv.first_conv
   5.130 +
   5.131 +fun ext_replay cprop_of ctxt rule prems =
   5.132 +  (case apply_first ctxt (fn {replay, ...}: extension => replay cprop_of ctxt rule prems) of
   5.133 +    SOME thm => thm
   5.134 +  | NONE => raise THM ("failed to replay " ^ quote (Argo_Proof.string_of_rule rule), 0, []))
   5.135 +
   5.136 +
   5.137 +(* translating input terms *)
   5.138 +
   5.139 +fun add_new_type T (names, types, terms) =
   5.140 +  let
   5.141 +    val (n, names') = fresh_type_name T names
   5.142 +    val ty = Argo_Expr.Type n
   5.143 +  in (ty, (names', Typtab.update (T, ty) types, terms)) end
   5.144 +
   5.145 +fun add_type T (tcx as (_, types, _)) =
   5.146 +  (case Typtab.lookup types T of
   5.147 +    SOME ty => (ty, tcx)
   5.148 +  | NONE => add_new_type T tcx)
   5.149 +
   5.150 +fun trans_type _ @{typ HOL.bool} = pair Argo_Expr.Bool
   5.151 +  | trans_type ctxt (Type (@{type_name "fun"}, [T1, T2])) =
   5.152 +      trans_type ctxt T1 ##>> trans_type ctxt T2 #>> Argo_Expr.Func
   5.153 +  | trans_type ctxt T = (fn tcx =>
   5.154 +      (case ext_trans_type ctxt (trans_type ctxt) T tcx of
   5.155 +        SOME result => result
   5.156 +      | NONE => add_type T tcx))
   5.157 +
   5.158 +fun add_new_term ctxt t T tcx =
   5.159 +  let
   5.160 +    val (ty, (names, types, terms)) = trans_type ctxt T tcx
   5.161 +    val (n, names') = fresh_term_name t names
   5.162 +    val c = (n, ty)
   5.163 +  in (Argo_Expr.mk_con c, (names', types, Termtab.update (t, c) terms)) end
   5.164 +
   5.165 +fun add_term ctxt t (tcx as (_, _, terms)) =
   5.166 +  (case Termtab.lookup terms t of
   5.167 +    SOME c => (Argo_Expr.mk_con c, tcx)
   5.168 +  | NONE => add_new_term ctxt t (Term.fastype_of t) tcx)
   5.169 +
   5.170 +fun mk_eq @{typ HOL.bool} = Argo_Expr.mk_iff
   5.171 +  | mk_eq _ = Argo_Expr.mk_eq
   5.172 +
   5.173 +fun trans_term _ @{const HOL.True} = pair Argo_Expr.true_expr
   5.174 +  | trans_term _ @{const HOL.False} = pair Argo_Expr.false_expr
   5.175 +  | trans_term ctxt (@{const HOL.Not} $ t) = trans_term ctxt t #>> Argo_Expr.mk_not
   5.176 +  | trans_term ctxt (@{const HOL.conj} $ t1 $ t2) =
   5.177 +      trans_term ctxt t1 ##>> trans_term ctxt t2 #>> uncurry Argo_Expr.mk_and2
   5.178 +  | trans_term ctxt (@{const HOL.disj} $ t1 $ t2) =
   5.179 +      trans_term ctxt t1 ##>> trans_term ctxt t2 #>> uncurry Argo_Expr.mk_or2
   5.180 +  | trans_term ctxt (@{const HOL.implies} $ t1 $ t2) =
   5.181 +      trans_term ctxt t1 ##>> trans_term ctxt t2 #>> uncurry Argo_Expr.mk_imp
   5.182 +  | trans_term ctxt (Const (@{const_name HOL.If}, _) $ t1 $ t2 $ t3) =
   5.183 +      trans_term ctxt t1 ##>> trans_term ctxt t2 ##>> trans_term ctxt t3 #>>
   5.184 +      (fn ((u1, u2), u3) => Argo_Expr.mk_ite u1 u2 u3)
   5.185 +  | trans_term ctxt (Const (@{const_name HOL.eq}, T) $ t1 $ t2) =
   5.186 +      trans_term ctxt t1 ##>> trans_term ctxt t2 #>> uncurry (mk_eq (Term.domain_type T))
   5.187 +  | trans_term ctxt (t as (t1 $ t2)) = (fn tcx =>
   5.188 +      (case ext_trans_term ctxt (trans_term ctxt) t tcx of
   5.189 +        SOME result => result
   5.190 +      | NONE => tcx |> trans_term ctxt t1 ||>> trans_term ctxt t2 |>> uncurry Argo_Expr.mk_app))
   5.191 +  | trans_term ctxt t = (fn tcx =>
   5.192 +      (case ext_trans_term ctxt (trans_term ctxt) t tcx of
   5.193 +        SOME result => result
   5.194 +      | NONE => add_term ctxt t tcx))
   5.195 +
   5.196 +fun translate ctxt prop = trans_term ctxt (HOLogic.dest_Trueprop prop)
   5.197 +
   5.198 +
   5.199 +(* invoking the solver *)
   5.200 +
   5.201 +type data = {
   5.202 +  names: Name.context,
   5.203 +  types: Argo_Expr.typ Typtab.table,
   5.204 +  terms: (string * Argo_Expr.typ) Termtab.table,
   5.205 +  argo: Argo_Solver.context}
   5.206 +
   5.207 +fun mk_data names types terms argo: data = {names=names, types=types, terms=terms, argo=argo}
   5.208 +val empty_data = mk_data Name.context Typtab.empty Termtab.empty Argo_Solver.context
   5.209 +
   5.210 +structure Solver_Data = Proof_Data
   5.211 +(
   5.212 +  type T = data option
   5.213 +  fun init _ = SOME empty_data
   5.214 +)
   5.215 +
   5.216 +datatype ('m, 'p) solver_result = Model of 'm | Proof of 'p
   5.217 +
   5.218 +fun raw_solve es argo = Model (Argo_Solver.assert es argo)
   5.219 +  handle Argo_Proof.UNSAT proof => Proof proof
   5.220 +
   5.221 +fun value_of terms model t =
   5.222 +  (case Termtab.lookup terms t of
   5.223 +    SOME c => model c
   5.224 +  | _ => NONE)
   5.225 +
   5.226 +fun trace_props props ctxt =
   5.227 +  tracing ctxt (Pretty.string_of (Pretty.big_list "using these propositions:"
   5.228 +    (map (Syntax.pretty_term ctxt) props)))
   5.229 +
   5.230 +fun trace_result ctxt ({elapsed, ...}: Timing.timing) msg =
   5.231 +  tracing ctxt ("found a " ^ msg ^ " in " ^ string_of_int (Time.toMilliseconds elapsed) ^ " ms")
   5.232 +
   5.233 +fun solve props ctxt =
   5.234 +  (case Solver_Data.get ctxt of
   5.235 +    NONE => error "bad Argo solver context"
   5.236 +  | SOME {names, types, terms, argo} =>
   5.237 +      let
   5.238 +        val _ = with_tracing ctxt (trace_props props)
   5.239 +        val (es, (names', types', terms')) = fold_map (translate ctxt) props (names, types, terms)
   5.240 +        val _ = tracing ctxt "starting the prover"
   5.241 +      in
   5.242 +        (case Timing.timing (raw_solve es) argo of
   5.243 +          (time, Proof proof) =>
   5.244 +            let val _ = trace_result ctxt time "proof"
   5.245 +            in (Proof (terms', proof), Solver_Data.put NONE ctxt) end
   5.246 +        | (time, Model argo') =>
   5.247 +            let
   5.248 +              val _ = trace_result ctxt time "model"
   5.249 +              val model = value_of terms' (Argo_Solver.model_of argo')
   5.250 +            in (Model model, Solver_Data.put (SOME (mk_data names' types' terms' argo')) ctxt) end)
   5.251 +      end)
   5.252 +
   5.253 +
   5.254 +(* reverse translation *)
   5.255 +
   5.256 +structure Contab = Table(type key = string * Argo_Expr.typ val ord = Argo_Expr.con_ord)
   5.257 +
   5.258 +fun mk_nary f ts = uncurry (fold_rev (curry f)) (split_last ts)
   5.259 +
   5.260 +fun mk_nary' d _ [] = d
   5.261 +  | mk_nary' _ f ts = mk_nary f ts
   5.262 +
   5.263 +fun mk_ite t1 t2 t3 =
   5.264 +  let
   5.265 +    val T = Term.fastype_of t2
   5.266 +    val ite = Const (@{const_name HOL.If}, [@{typ HOL.bool}, T, T] ---> T)
   5.267 +  in ite $ t1 $ t2 $ t3 end
   5.268 +
   5.269 +fun term_of _ (Argo_Expr.E (Argo_Expr.True, _)) = @{const HOL.True}
   5.270 +  | term_of _ (Argo_Expr.E (Argo_Expr.False, _)) = @{const HOL.False}
   5.271 +  | term_of cx (Argo_Expr.E (Argo_Expr.Not, [e])) = HOLogic.mk_not (term_of cx e)
   5.272 +  | term_of cx (Argo_Expr.E (Argo_Expr.And, es)) =
   5.273 +      mk_nary' @{const HOL.True} HOLogic.mk_conj (map (term_of cx) es)
   5.274 +  | term_of cx (Argo_Expr.E (Argo_Expr.Or, es)) =
   5.275 +      mk_nary' @{const HOL.False} HOLogic.mk_disj (map (term_of cx) es)
   5.276 +  | term_of cx (Argo_Expr.E (Argo_Expr.Imp, [e1, e2])) =
   5.277 +      HOLogic.mk_imp (term_of cx e1, term_of cx e2)
   5.278 +  | term_of cx (Argo_Expr.E (Argo_Expr.Iff, [e1, e2])) =
   5.279 +      HOLogic.mk_eq (term_of cx e1, term_of cx e2)
   5.280 +  | term_of cx (Argo_Expr.E (Argo_Expr.Ite, [e1, e2, e3])) =
   5.281 +      mk_ite (term_of cx e1) (term_of cx e2) (term_of cx e3)
   5.282 +  | term_of cx (Argo_Expr.E (Argo_Expr.Eq, [e1, e2])) =
   5.283 +      HOLogic.mk_eq (term_of cx e1, term_of cx e2)
   5.284 +  | term_of cx (Argo_Expr.E (Argo_Expr.App, [e1, e2])) =
   5.285 +      term_of cx e1 $ term_of cx e2
   5.286 +  | term_of (_, cons) (Argo_Expr.E (Argo_Expr.Con (c as (n, _)), _)) =
   5.287 +      (case Contab.lookup cons c of
   5.288 +        SOME t => t
   5.289 +      | NONE => error ("Unexpected expression named " ^ quote n))
   5.290 +  | term_of (cx as (ctxt, _)) e =
   5.291 +      (case ext_term_of ctxt (term_of cx) e of
   5.292 +        SOME t => t
   5.293 +      | NONE => raise Fail "bad expression")
   5.294 +
   5.295 +fun as_prop ct = Thm.apply @{cterm HOL.Trueprop} ct
   5.296 +
   5.297 +fun cterm_of ctxt cons e = Thm.cterm_of ctxt (term_of (ctxt, cons) e)
   5.298 +fun cprop_of ctxt cons e = as_prop (cterm_of ctxt cons e)
   5.299 +
   5.300 +
   5.301 +(* generic proof tools *)
   5.302 +
   5.303 +fun discharge thm rule = thm INCR_COMP rule
   5.304 +fun discharge2 thm1 thm2 rule = discharge thm2 (discharge thm1 rule)
   5.305 +fun discharges thm rules = [thm] RL rules
   5.306 +
   5.307 +fun under_assumption f ct =
   5.308 +  let val cprop = as_prop ct
   5.309 +  in Thm.implies_intr cprop (f (Thm.assume cprop)) end
   5.310 +
   5.311 +fun instantiate cv ct = Thm.instantiate ([], [(Term.dest_Var (Thm.term_of cv), ct)])
   5.312 +
   5.313 +
   5.314 +(* proof replay for tautologies *)
   5.315 +
   5.316 +fun prove_taut ctxt ns t = Goal.prove ctxt ns [] (HOLogic.mk_Trueprop t)
   5.317 +  (fn {context, ...} => HEADGOAL (Classical.fast_tac context))
   5.318 +
   5.319 +fun with_frees ctxt n mk =
   5.320 +  let
   5.321 +    val ns = map (fn i => "P" ^ string_of_int i) (0 upto (n - 1))
   5.322 +    val ts = map (Free o rpair @{typ bool}) ns
   5.323 +    val t = mk_nary HOLogic.mk_disj (mk ts)
   5.324 +  in prove_taut ctxt ns t end
   5.325 +
   5.326 +fun taut_and1_term ts = mk_nary HOLogic.mk_conj ts :: map HOLogic.mk_not ts
   5.327 +fun taut_and2_term i ts = [HOLogic.mk_not (mk_nary HOLogic.mk_conj ts), nth ts i]
   5.328 +fun taut_or1_term i ts = [mk_nary HOLogic.mk_disj ts, HOLogic.mk_not (nth ts i)]
   5.329 +fun taut_or2_term ts = HOLogic.mk_not (mk_nary HOLogic.mk_disj ts) :: ts
   5.330 +
   5.331 +val iff_1_taut = @{lemma "P = Q | P | Q" by fast}
   5.332 +val iff_2_taut = @{lemma "P = Q | (~P) | (~Q)" by fast}
   5.333 +val iff_3_taut = @{lemma "~(P = Q) | (~P) | Q" by fast}
   5.334 +val iff_4_taut = @{lemma "~(P = Q) | P | (~Q)" by fast}
   5.335 +val ite_then_taut = @{lemma "~P | (if P then t else u) = t" by auto}
   5.336 +val ite_else_taut = @{lemma "P | (if P then t else u) = u" by auto}
   5.337 +
   5.338 +fun taut_rule_of ctxt (Argo_Proof.Taut_And_1 n) = with_frees ctxt n taut_and1_term
   5.339 +  | taut_rule_of ctxt (Argo_Proof.Taut_And_2 (i, n)) = with_frees ctxt n (taut_and2_term i)
   5.340 +  | taut_rule_of ctxt (Argo_Proof.Taut_Or_1 (i, n)) = with_frees ctxt n (taut_or1_term i)
   5.341 +  | taut_rule_of ctxt (Argo_Proof.Taut_Or_2 n) = with_frees ctxt n taut_or2_term
   5.342 +  | taut_rule_of _ Argo_Proof.Taut_Iff_1 = iff_1_taut
   5.343 +  | taut_rule_of _ Argo_Proof.Taut_Iff_2 = iff_2_taut
   5.344 +  | taut_rule_of _ Argo_Proof.Taut_Iff_3 = iff_3_taut
   5.345 +  | taut_rule_of _ Argo_Proof.Taut_Iff_4 = iff_4_taut
   5.346 +  | taut_rule_of _ Argo_Proof.Taut_Ite_Then = ite_then_taut
   5.347 +  | taut_rule_of _ Argo_Proof.Taut_Ite_Else = ite_else_taut
   5.348 +
   5.349 +fun replay_taut ctxt k ct =
   5.350 +  let val rule = taut_rule_of ctxt k
   5.351 +  in Thm.instantiate (Thm.match (Thm.cprop_of rule, ct)) rule end
   5.352 +
   5.353 +
   5.354 +(* proof replay for conjunct extraction *)
   5.355 +
   5.356 +fun replay_conjunct 0 1 thm = thm
   5.357 +  | replay_conjunct 0 _ thm = discharge thm @{thm conjunct1}
   5.358 +  | replay_conjunct 1 2 thm = discharge thm @{thm conjunct2}
   5.359 +  | replay_conjunct i n thm = replay_conjunct (i - 1) (n - 1) (discharge thm @{thm conjunct2})
   5.360 +
   5.361 +
   5.362 +(* proof replay for rewrite steps *)
   5.363 +
   5.364 +fun mk_rewr thm = thm RS @{thm eq_reflection}
   5.365 +
   5.366 +fun not_nary_conv rule i ct =
   5.367 +  if i > 1 then (Conv.rewr_conv rule then_conv Conv.arg_conv (not_nary_conv rule (i - 1))) ct
   5.368 +  else Conv.all_conv ct
   5.369 +
   5.370 +val flatten_and_thm = @{lemma "(P1 & P2) & P3 == P1 & P2 & P3" by simp}
   5.371 +val flatten_or_thm = @{lemma "(P1 | P2) | P3 == P1 | P2 | P3" by simp}
   5.372 +
   5.373 +fun flatten_conv cv rule ct = (
   5.374 +  Conv.try_conv (Conv.arg_conv cv) then_conv
   5.375 +  Conv.try_conv (Conv.rewr_conv rule then_conv cv)) ct
   5.376 +
   5.377 +fun flat_conj_conv ct =
   5.378 +  (case Thm.term_of ct of
   5.379 +    @{const HOL.conj} $ _ $ _ => flatten_conv flat_conj_conv flatten_and_thm ct
   5.380 +  | _ => Conv.all_conv ct)
   5.381 +
   5.382 +fun flat_disj_conv ct =
   5.383 +  (case Thm.term_of ct of
   5.384 +    @{const HOL.disj} $ _ $ _ => flatten_conv flat_disj_conv flatten_or_thm ct
   5.385 +  | _ => Conv.all_conv ct)
   5.386 +
   5.387 +fun explode rule1 rule2 thm =
   5.388 +  explode rule1 rule2 (thm RS rule1) @ explode rule1 rule2 (thm RS rule2) handle THM _ => [thm]
   5.389 +val explode_conj = explode @{thm conjunct1} @{thm conjunct2}
   5.390 +val explode_ndis = explode @{lemma "~(P | Q) ==> ~P" by auto} @{lemma "~(P | Q) ==> ~Q" by auto}
   5.391 +
   5.392 +fun pick_false i thms = nth thms i
   5.393 +
   5.394 +fun pick_dual rule (i1, i2) thms =
   5.395 +  rule OF [nth thms i1, nth thms i2] handle THM _ => rule OF [nth thms i2, nth thms i1]
   5.396 +val pick_dual_conj = pick_dual @{lemma "~P ==> P ==> False" by auto}
   5.397 +val pick_dual_ndis = pick_dual @{lemma "~P ==> P ==> ~True" by auto}
   5.398 +
   5.399 +fun join thm0 rule is thms =
   5.400 +  let
   5.401 +    val l = length thms
   5.402 +    val thms' = fold (fn i => cons (if 0 <= i andalso i < l then nth thms i else thm0)) is []
   5.403 +  in fold (fn thm => fn thm' => discharge2 thm thm' rule) (tl thms') (hd thms') end
   5.404 +
   5.405 +val join_conj = join @{lemma "True" by auto} @{lemma "P ==> Q ==> P & Q" by auto}
   5.406 +val join_ndis = join @{lemma "~False" by auto} @{lemma "~P ==> ~Q ==> ~(P | Q)" by auto}
   5.407 +
   5.408 +val false_thm = @{lemma "False ==> P" by auto}
   5.409 +val ntrue_thm = @{lemma "~True ==> P" by auto}
   5.410 +val iff_conj_thm = @{lemma "(P ==> Q) ==> (Q ==> P) ==> P = Q" by auto}
   5.411 +val iff_ndis_thm = @{lemma "(~P ==> ~Q) ==> (~Q ==> ~P) ==> P = Q" by auto}
   5.412 +
   5.413 +fun iff_intro rule lf rf ct =
   5.414 +  let
   5.415 +    val lhs = under_assumption lf ct
   5.416 +    val rhs = rf (Thm.dest_arg (snd (Thm.dest_implies (Thm.cprop_of lhs))))
   5.417 +  in mk_rewr (discharge2 lhs rhs rule) end
   5.418 +
   5.419 +fun with_conj f g ct = iff_intro iff_conj_thm (f o explode_conj) g ct
   5.420 +fun with_ndis f g ct = iff_intro iff_ndis_thm (f o explode_ndis) g (Thm.apply @{cterm HOL.Not} ct)
   5.421 +
   5.422 +fun swap_indices n iss = map (fn i => find_index (fn is => member (op =) is i) iss) (0 upto (n - 1))
   5.423 +fun sort_nary w f g (n, iss) = w (f (map hd iss)) (under_assumption (f (swap_indices n iss) o g))
   5.424 +val sort_conj = sort_nary with_conj join_conj explode_conj
   5.425 +val sort_ndis = sort_nary with_ndis join_ndis explode_ndis 
   5.426 +
   5.427 +val not_true_thm = mk_rewr @{lemma "(~True) = False" by auto}
   5.428 +val not_false_thm = mk_rewr @{lemma "(~False) = True" by auto}
   5.429 +val not_not_thm = mk_rewr @{lemma "(~~P) = P" by auto}
   5.430 +val not_and_thm = mk_rewr @{lemma "(~(P & Q)) = (~P | ~Q)" by auto}
   5.431 +val not_or_thm = mk_rewr @{lemma "(~(P | Q)) = (~P & ~Q)" by auto}
   5.432 +val not_iff_thms = map mk_rewr
   5.433 +  @{lemma "(~((~P) = Q)) = (P = Q)" "(~(P = (~Q))) = (P = Q)" "(~(P = Q)) = ((~P) = Q)" by auto}
   5.434 +val iff_true_thms = map mk_rewr @{lemma "(True = P) = P" "(P = True) = P" by auto}
   5.435 +val iff_false_thms = map mk_rewr @{lemma "(False = P) = (~P)" "(P = False) = (~P)" by auto}
   5.436 +val iff_not_not_thm = mk_rewr @{lemma "((~P) = (~Q)) = (P = Q)" by auto}
   5.437 +val iff_refl_thm = mk_rewr @{lemma "(P = P) = True" by auto}
   5.438 +val iff_symm_thm = mk_rewr @{lemma "(P = Q) = (Q = P)" by auto}
   5.439 +val iff_dual_thms = map mk_rewr @{lemma "(P = (~P)) = False" "((~P) = P) = False" by auto}
   5.440 +val imp_thm = mk_rewr @{lemma "(P --> Q) = (~P | Q)" by auto}
   5.441 +val ite_prop_thm = mk_rewr @{lemma "(If P Q R) = ((~P | Q) & (P | R) & (Q | R))" by auto}
   5.442 +val ite_true_thm = mk_rewr @{lemma "(If True t u) = t" by auto}
   5.443 +val ite_false_thm = mk_rewr @{lemma "(If False t u) = u" by auto}
   5.444 +val ite_eq_thm = mk_rewr @{lemma "(If P t t) = t" by auto}
   5.445 +val eq_refl_thm = mk_rewr @{lemma "(t = t) = True" by auto}
   5.446 +val eq_symm_thm = mk_rewr @{lemma "(t1 = t2) = (t2 = t1)" by auto}
   5.447 +
   5.448 +fun replay_rewr _ Argo_Proof.Rewr_Not_True = Conv.rewr_conv not_true_thm
   5.449 +  | replay_rewr _ Argo_Proof.Rewr_Not_False = Conv.rewr_conv not_false_thm
   5.450 +  | replay_rewr _ Argo_Proof.Rewr_Not_Not = Conv.rewr_conv not_not_thm
   5.451 +  | replay_rewr _ (Argo_Proof.Rewr_Not_And i) = not_nary_conv not_and_thm i
   5.452 +  | replay_rewr _ (Argo_Proof.Rewr_Not_Or i) = not_nary_conv not_or_thm i
   5.453 +  | replay_rewr _ Argo_Proof.Rewr_Not_Iff = Conv.rewrs_conv not_iff_thms
   5.454 +  | replay_rewr _ (Argo_Proof.Rewr_And_False i) = with_conj (pick_false i) (K false_thm)
   5.455 +  | replay_rewr _ (Argo_Proof.Rewr_And_Dual ip) = with_conj (pick_dual_conj ip) (K false_thm)
   5.456 +  | replay_rewr _ (Argo_Proof.Rewr_And_Sort is) = flat_conj_conv then_conv sort_conj is
   5.457 +  | replay_rewr _ (Argo_Proof.Rewr_Or_True i) = with_ndis (pick_false i) (K ntrue_thm)
   5.458 +  | replay_rewr _ (Argo_Proof.Rewr_Or_Dual ip) = with_ndis (pick_dual_ndis ip) (K ntrue_thm)
   5.459 +  | replay_rewr _ (Argo_Proof.Rewr_Or_Sort is) = flat_disj_conv then_conv sort_ndis is
   5.460 +  | replay_rewr _ Argo_Proof.Rewr_Iff_True = Conv.rewrs_conv iff_true_thms
   5.461 +  | replay_rewr _ Argo_Proof.Rewr_Iff_False = Conv.rewrs_conv iff_false_thms
   5.462 +  | replay_rewr _ Argo_Proof.Rewr_Iff_Not_Not = Conv.rewr_conv iff_not_not_thm
   5.463 +  | replay_rewr _ Argo_Proof.Rewr_Iff_Refl = Conv.rewr_conv iff_refl_thm
   5.464 +  | replay_rewr _ Argo_Proof.Rewr_Iff_Symm = Conv.rewr_conv iff_symm_thm
   5.465 +  | replay_rewr _ Argo_Proof.Rewr_Iff_Dual  = Conv.rewrs_conv iff_dual_thms
   5.466 +  | replay_rewr _ Argo_Proof.Rewr_Imp = Conv.rewr_conv imp_thm
   5.467 +  | replay_rewr _ Argo_Proof.Rewr_Ite_Prop = Conv.rewr_conv ite_prop_thm
   5.468 +  | replay_rewr _ Argo_Proof.Rewr_Ite_True = Conv.rewr_conv ite_true_thm
   5.469 +  | replay_rewr _ Argo_Proof.Rewr_Ite_False = Conv.rewr_conv ite_false_thm
   5.470 +  | replay_rewr _ Argo_Proof.Rewr_Ite_Eq = Conv.rewr_conv ite_eq_thm
   5.471 +  | replay_rewr _ Argo_Proof.Rewr_Eq_Refl = Conv.rewr_conv eq_refl_thm
   5.472 +  | replay_rewr _ Argo_Proof.Rewr_Eq_Symm = Conv.rewr_conv eq_symm_thm
   5.473 +  | replay_rewr ctxt r = ext_replay_rewr ctxt r
   5.474 +
   5.475 +fun binop_conv cv1 cv2 = Conv.combination_conv (Conv.arg_conv cv1) cv2
   5.476 +
   5.477 +fun replay_conv _ Argo_Proof.Keep_Conv ct = Conv.all_conv ct
   5.478 +  | replay_conv ctxt (Argo_Proof.Then_Conv (c1, c2)) ct = 
   5.479 +      (replay_conv ctxt c1 then_conv replay_conv ctxt c2) ct
   5.480 +  | replay_conv ctxt (Argo_Proof.Args_Conv cs) ct = replay_args_conv ctxt cs ct
   5.481 +  | replay_conv ctxt (Argo_Proof.Rewr_Conv r) ct = replay_rewr ctxt r ct
   5.482 +
   5.483 +and replay_args_conv _ [] ct = Conv.all_conv ct
   5.484 +  | replay_args_conv ctxt [c] ct = Conv.arg_conv (replay_conv ctxt c) ct
   5.485 +  | replay_args_conv ctxt [c1, c2] ct = binop_conv (replay_conv ctxt c1) (replay_conv ctxt c2) ct
   5.486 +  | replay_args_conv ctxt (c :: cs) ct =
   5.487 +      (case Term.head_of (Thm.term_of ct) of
   5.488 +        Const (@{const_name HOL.If}, _) =>
   5.489 +          let val (cs', c') = split_last cs
   5.490 +          in Conv.combination_conv (replay_args_conv ctxt (c :: cs')) (replay_conv ctxt c') ct end
   5.491 +      | _ => binop_conv (replay_conv ctxt c) (replay_args_conv ctxt cs) ct)
   5.492 +
   5.493 +fun replay_rewrite ctxt c thm = Conv.fconv_rule (HOLogic.Trueprop_conv (replay_conv ctxt c)) thm
   5.494 +
   5.495 +
   5.496 +(* proof replay for clauses *)
   5.497 +
   5.498 +val prep_clause_rule = @{lemma "P ==> ~P ==> False" by fast}
   5.499 +val extract_lit_rule = @{lemma "(~(P | Q) ==> False) ==> ~P ==> ~Q ==> False" by fast}
   5.500 +
   5.501 +fun add_lit i thm lits =
   5.502 +  let val ct = Thm.cprem_of thm 1
   5.503 +  in (Thm.implies_elim thm (Thm.assume ct), (i, ct) :: lits) end
   5.504 +
   5.505 +fun extract_lits [] _ = error "Bad clause"
   5.506 +  | extract_lits [i] (thm, lits) = add_lit i thm lits
   5.507 +  | extract_lits (i :: is) (thm, lits) =
   5.508 +      extract_lits is (add_lit i (discharge thm extract_lit_rule) lits)
   5.509 +
   5.510 +fun lit_ord ((l1, _), (l2, _)) = int_ord (abs l1, abs l2)
   5.511 +
   5.512 +fun replay_with_lits [] thm lits = (thm, lits)
   5.513 +  | replay_with_lits is thm lits =
   5.514 +      extract_lits is (discharge thm prep_clause_rule, lits)
   5.515 +      ||> Ord_List.make lit_ord
   5.516 +
   5.517 +fun replay_clause is thm = replay_with_lits is thm []
   5.518 +
   5.519 +
   5.520 +(* proof replay for unit resolution *)
   5.521 +
   5.522 +val unit_rule = @{lemma "(P ==> False) ==> (~P ==> False) ==> False" by fast}
   5.523 +val unit_rule_var = Thm.dest_arg (Thm.dest_arg1 (Thm.cprem_of unit_rule 1))
   5.524 +val bogus_ct = @{cterm HOL.True}
   5.525 +
   5.526 +fun replay_unit_res lit (pthm, plits) (nthm, nlits) =
   5.527 +  let
   5.528 +    val plit = the (AList.lookup (op =) plits lit)
   5.529 +    val nlit = the (AList.lookup (op =) nlits (~lit))
   5.530 +    val prune = Ord_List.remove lit_ord (lit, bogus_ct)
   5.531 +  in
   5.532 +    unit_rule
   5.533 +    |> instantiate unit_rule_var (Thm.dest_arg plit)
   5.534 +    |> Thm.elim_implies (Thm.implies_intr plit pthm)
   5.535 +    |> Thm.elim_implies (Thm.implies_intr nlit nthm)
   5.536 +    |> rpair (Ord_List.union lit_ord (prune nlits) (prune plits))
   5.537 +  end
   5.538 +
   5.539 +
   5.540 +(* proof replay for hypothesis *)
   5.541 +
   5.542 +val dneg_rule = @{lemma "~~P ==> P" by auto}
   5.543 +
   5.544 +fun replay_hyp i ct =
   5.545 +  if i < 0 then (Thm.assume ct, [(~i, ct)])
   5.546 +  else
   5.547 +    let val cu = as_prop (Thm.apply @{cterm HOL.Not} (Thm.apply @{cterm HOL.Not} (Thm.dest_arg ct)))
   5.548 +    in (discharge (Thm.assume cu) dneg_rule, [(~i, cu)]) end
   5.549 +
   5.550 +
   5.551 +(* proof replay for lemma *)
   5.552 +
   5.553 +fun replay_lemma is (thm, lits) = replay_with_lits is thm lits
   5.554 +
   5.555 +
   5.556 +(* proof replay for reflexivity *)
   5.557 +
   5.558 +val refl_rule = @{thm refl}
   5.559 +val refl_rule_var = Thm.dest_arg1 (Thm.dest_arg (Thm.cprop_of refl_rule))
   5.560 +
   5.561 +fun replay_refl ct = Thm.instantiate (Thm.match (refl_rule_var, ct)) refl_rule
   5.562 +
   5.563 +
   5.564 +(* proof replay for symmetry *)
   5.565 +
   5.566 +val symm_rules = @{lemma "a = b ==> b = a" "~(a = b) ==> ~(b = a)" by simp_all}
   5.567 +
   5.568 +fun replay_symm thm = hd (discharges thm symm_rules)
   5.569 +
   5.570 +
   5.571 +(* proof replay for transitivity *)
   5.572 +
   5.573 +val trans_rules = @{lemma
   5.574 +  "~(a = b) ==> b = c ==> ~(a = c)"
   5.575 +  "a = b ==> ~(b = c) ==> ~(a = c)"
   5.576 +  "a = b ==> b = c ==> a = c"
   5.577 +  by simp_all}
   5.578 +
   5.579 +fun replay_trans thm1 thm2 = hd (discharges thm2 (discharges thm1 trans_rules))
   5.580 +
   5.581 +
   5.582 +(* proof replay for congruence *)
   5.583 +
   5.584 +fun replay_cong thm1 thm2 = discharge thm2 (discharge thm1 @{thm cong})
   5.585 +
   5.586 +
   5.587 +(* proof replay for substitution *)
   5.588 +
   5.589 +val subst_rule1 = @{lemma "~(p a) ==> p = q ==> a = b ==> ~(q b)" by simp}
   5.590 +val subst_rule2 = @{lemma "p a ==> p = q ==> a = b ==> q b" by simp}
   5.591 +
   5.592 +fun replay_subst thm1 thm2 thm3 =
   5.593 +  subst_rule1 OF [thm1, thm2, thm3] handle THM _ => subst_rule2 OF [thm1, thm2, thm3]
   5.594 +
   5.595 +
   5.596 +(* proof replay *)
   5.597 +
   5.598 +structure Thm_Cache = Table(type key = Argo_Proof.proof_id val ord = Argo_Proof.proof_id_ord)
   5.599 +
   5.600 +val unclausify_rule1 = @{lemma "(~P ==> False) ==> P" by auto}
   5.601 +val unclausify_rule2 = @{lemma "(P ==> False) ==> ~P" by auto}
   5.602 +
   5.603 +fun unclausify (thm, lits) ls =
   5.604 +  (case (Thm.prop_of thm, lits) of
   5.605 +    (@{const HOL.Trueprop} $ @{const HOL.False}, [(_, ct)]) =>
   5.606 +      let val thm = Thm.implies_intr ct thm
   5.607 +      in (discharge thm unclausify_rule1 handle THM _ => discharge thm unclausify_rule2, ls) end
   5.608 +  | _ => (thm, Ord_List.union lit_ord lits ls))
   5.609 +
   5.610 +fun with_thms f tps = fold_map unclausify tps [] |>> f
   5.611 +
   5.612 +fun bad_premises () = raise Fail "bad number of premises"
   5.613 +fun with_thms1 f = with_thms (fn [thm] => f thm | _ => bad_premises ())
   5.614 +fun with_thms2 f = with_thms (fn [thm1, thm2] => f thm1 thm2 | _ => bad_premises ())
   5.615 +fun with_thms3 f = with_thms (fn [thm1, thm2, thm3] => f thm1 thm2 thm3 | _ => bad_premises ())
   5.616 +
   5.617 +fun replay_rule (ctxt, cons, facts) prems rule =
   5.618 +  (case rule of
   5.619 +    Argo_Proof.Axiom i => (nth facts i, [])
   5.620 +  | Argo_Proof.Taut (k, concl) => (replay_taut ctxt k (cprop_of ctxt cons concl), [])
   5.621 +  | Argo_Proof.Conjunct (i, n) => with_thms1 (replay_conjunct i n) prems
   5.622 +  | Argo_Proof.Rewrite c => with_thms1 (replay_rewrite ctxt c) prems
   5.623 +  | Argo_Proof.Clause is => replay_clause is (fst (hd prems))
   5.624 +  | Argo_Proof.Unit_Res i => replay_unit_res i (hd prems) (hd (tl prems))
   5.625 +  | Argo_Proof.Hyp (i, concl) => replay_hyp i (cprop_of ctxt cons concl)
   5.626 +  | Argo_Proof.Lemma is => replay_lemma is (hd prems)
   5.627 +  | Argo_Proof.Refl concl => (replay_refl (cterm_of ctxt cons concl), [])
   5.628 +  | Argo_Proof.Symm => with_thms1 replay_symm prems
   5.629 +  | Argo_Proof.Trans => with_thms2 replay_trans prems
   5.630 +  | Argo_Proof.Cong => with_thms2 replay_cong prems
   5.631 +  | Argo_Proof.Subst => with_thms3 replay_subst prems
   5.632 +  | _ => with_thms (ext_replay (cprop_of ctxt cons) ctxt rule) prems)
   5.633 +
   5.634 +fun with_cache f proof thm_cache =
   5.635 +  (case Thm_Cache.lookup thm_cache (Argo_Proof.id_of proof) of
   5.636 +    SOME thm => (thm, thm_cache)
   5.637 +  | NONE =>
   5.638 +      let val (thm, thm_cache') = f proof thm_cache
   5.639 +      in (thm, Thm_Cache.update (Argo_Proof.id_of proof, thm) thm_cache') end)
   5.640 +
   5.641 +fun trace_step ctxt proof_id rule proofs = with_full_tracing ctxt (fn ctxt' =>
   5.642 +  let
   5.643 +    val id = Argo_Proof.string_of_proof_id proof_id
   5.644 +    val ids = map (Argo_Proof.string_of_proof_id o Argo_Proof.id_of) proofs
   5.645 +    val rule_string = Argo_Proof.string_of_rule rule
   5.646 +  in full_tracing ctxt' ("  " ^ id ^ " <- " ^ space_implode " " ids ^ " . " ^ rule_string) end)
   5.647 +
   5.648 +fun replay_bottom_up (env as (ctxt, _, _)) proof thm_cache =
   5.649 +  let
   5.650 +    val (proof_id, rule, proofs) = Argo_Proof.dest proof
   5.651 +    val (prems, thm_cache) = fold_map (with_cache (replay_bottom_up env)) proofs thm_cache
   5.652 +    val _ = trace_step ctxt proof_id rule proofs
   5.653 +  in (replay_rule env prems rule, thm_cache) end
   5.654 +
   5.655 +fun replay_proof env proof = with_cache (replay_bottom_up env) proof Thm_Cache.empty
   5.656 +
   5.657 +fun replay ctxt terms facts proof =
   5.658 +  let
   5.659 +    val env = (ctxt, Termtab.fold (Contab.update o swap) terms Contab.empty, facts)
   5.660 +    val _ = tracing ctxt "replaying the proof"
   5.661 +    val ({elapsed=t, ...}, ((thm, _), _)) = Timing.timing (replay_proof env) proof
   5.662 +    val _ = tracing ctxt ("replayed the proof in " ^ string_of_int (Time.toMilliseconds t) ^ " ms")
   5.663 +  in thm end
   5.664 +
   5.665 +
   5.666 +(* normalizing goals *)
   5.667 +
   5.668 +fun instantiate_elim_rule thm =
   5.669 +  let val ct = Drule.strip_imp_concl (Thm.cprop_of thm)
   5.670 +  in
   5.671 +    (case Thm.term_of ct of
   5.672 +      @{const HOL.Trueprop} $ Var (_, @{typ HOL.bool}) =>
   5.673 +        instantiate (Thm.dest_arg ct) @{cterm HOL.False} thm
   5.674 +    | Var _ => instantiate ct @{cprop HOL.False} thm
   5.675 +    | _ => thm)
   5.676 +  end
   5.677 +
   5.678 +fun atomize_conv ctxt ct =
   5.679 +  (case Thm.term_of ct of
   5.680 +    @{const HOL.Trueprop} $ _ => Conv.all_conv
   5.681 +  | @{const Pure.imp} $ _ $ _ =>
   5.682 +      Conv.binop_conv (atomize_conv ctxt) then_conv
   5.683 +      Conv.rewr_conv @{thm atomize_imp}
   5.684 +  | Const (@{const_name Pure.eq}, _) $ _ $ _ =>
   5.685 +      Conv.binop_conv (atomize_conv ctxt) then_conv
   5.686 +      Conv.rewr_conv @{thm atomize_eq}
   5.687 +  | Const (@{const_name Pure.all}, _) $ Abs _ =>
   5.688 +      Conv.binder_conv (atomize_conv o snd) ctxt then_conv
   5.689 +      Conv.rewr_conv @{thm atomize_all}
   5.690 +  | _ => Conv.all_conv) ct
   5.691 +
   5.692 +fun normalize ctxt thm =
   5.693 +  thm
   5.694 +  |> instantiate_elim_rule
   5.695 +  |> Conv.fconv_rule (Thm.beta_conversion true then_conv Thm.eta_conversion)
   5.696 +  |> Drule.forall_intr_vars
   5.697 +  |> Conv.fconv_rule (atomize_conv ctxt)
   5.698 +
   5.699 +
   5.700 +(* prover, tactic and method *)
   5.701 +
   5.702 +datatype result = Satisfiable of term -> bool option | Unsatisfiable
   5.703 +
   5.704 +fun check props ctxt =
   5.705 +  (case solve props ctxt of
   5.706 +    (Proof _, ctxt') => (Unsatisfiable, ctxt')
   5.707 +  | (Model model, ctxt') => (Satisfiable model, ctxt'))
   5.708 +
   5.709 +fun prove thms ctxt =
   5.710 +  let val thms' = map (normalize ctxt) thms
   5.711 +  in
   5.712 +    (case solve (map Thm.prop_of thms') ctxt of
   5.713 +      (Model _, ctxt') => (NONE, ctxt')
   5.714 +    | (Proof (terms, proof), ctxt') => (SOME (replay ctxt' terms thms' proof), ctxt'))
   5.715 +  end
   5.716 +
   5.717 +fun argo_tac ctxt thms =
   5.718 +  CONVERSION (Conv.params_conv ~1 (K (Conv.concl_conv ~1
   5.719 +    (Conv.try_conv (Conv.rewr_conv @{thm atomize_eq})))) ctxt)
   5.720 +  THEN' Tactic.resolve_tac ctxt [@{thm ccontr}]
   5.721 +  THEN' Subgoal.FOCUS (fn {context, prems, ...} =>
   5.722 +    (case with_timeout context (prove (thms @ prems)) context of
   5.723 +      (SOME thm, _) => Tactic.resolve_tac context [thm] 1
   5.724 +    | (NONE, _) => Tactical.no_tac)) ctxt
   5.725 +
   5.726 +val _ =
   5.727 +  Theory.setup (Method.setup @{binding argo}
   5.728 +    (Scan.optional Attrib.thms [] >>
   5.729 +      (fn thms => fn ctxt => METHOD (fn facts =>
   5.730 +        HEADGOAL (argo_tac ctxt (thms @ facts)))))
   5.731 +    "Applies the Argo prover")
   5.732 +
   5.733 +end
     6.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     6.2 +++ b/src/HOL/ex/Argo_Examples.thy	Thu Sep 29 20:54:44 2016 +0200
     6.3 @@ -0,0 +1,1328 @@
     6.4 +(*  Title:      HOL/ex/Argo_Examples.thy
     6.5 +    Author:     Sascha Boehme
     6.6 +*)
     6.7 +
     6.8 +section \<open>Argo\<close>
     6.9 +
    6.10 +theory Argo_Examples
    6.11 +imports Complex_Main
    6.12 +begin
    6.13 +
    6.14 +text \<open>
    6.15 +  This theory is intended to showcase and test different features of the \<open>argo\<close> proof method.
    6.16 +
    6.17 +  The \<open>argo\<close> proof method can be applied to propositional problems, problems involving equality
    6.18 +  reasoning and problems of linear real arithmetic.
    6.19 +
    6.20 +  The \<open>argo\<close> proof method provides two options. To specify an upper limit of the proof methods
    6.21 +  run time in seconds, use the option \<open>argo_timeout\<close>. To specify the amount of output, use the
    6.22 +  option \<open>argo_trace\<close> with value \<open>none\<close> for no tracing output, value \<open>basic\<close> for viewing the
    6.23 +  underlying propositions and some timings, and value \<open>full\<close> for additionally inspecting the
    6.24 +  proof replay steps.
    6.25 +\<close>
    6.26 +
    6.27 +declare[[argo_trace = full]]
    6.28 +
    6.29 +subsection \<open>Propositional logic\<close>
    6.30 +
    6.31 +notepad
    6.32 +begin
    6.33 +  have "True" by argo
    6.34 +next
    6.35 +  have "~False" by argo
    6.36 +next
    6.37 +  fix P :: bool
    6.38 +  assume "False"
    6.39 +  then have "P" by argo
    6.40 +next
    6.41 +  fix P :: bool
    6.42 +  assume "~True"
    6.43 +  then have "P" by argo
    6.44 +next
    6.45 +  fix P :: bool
    6.46 +  assume "P"
    6.47 +  then have "P" by argo
    6.48 +next
    6.49 +  fix P :: bool
    6.50 +  assume "~~P"
    6.51 +  then have "P" by argo
    6.52 +next
    6.53 +  fix P Q R :: bool
    6.54 +  assume "P & Q & R"
    6.55 +  then have "R & P & Q" by argo
    6.56 +next
    6.57 +  fix P Q R :: bool
    6.58 +  assume "P & (Q & True & R) & (Q & P) & True"
    6.59 +  then have "R & P & Q" by argo
    6.60 +next
    6.61 +  fix P Q1 Q2 Q3 Q4 Q5 :: bool
    6.62 +  assume "Q1 & (Q2 & P & Q3) & (Q4 & ~P & Q5)"
    6.63 +  then have "~True" by argo
    6.64 +next
    6.65 +  fix P Q1 Q2 Q3  :: bool
    6.66 +  assume "(Q1 & False) & Q2 & Q3"
    6.67 +  then have "P::bool" by argo
    6.68 +next
    6.69 +  fix P Q R :: bool
    6.70 +  assume "P | Q | R"
    6.71 +  then have "R | P | Q" by argo
    6.72 +next
    6.73 +  fix P Q R :: bool
    6.74 +  assume "P | (Q | False | R) | (Q | P) | False"
    6.75 +  then have "R | P | Q" by argo
    6.76 +next
    6.77 +  fix P Q1 Q2 Q3 Q4 :: bool
    6.78 +  have "(Q1 & P & Q2) --> False | (Q3 | (Q4 | P) | False)" by argo
    6.79 +next
    6.80 +  fix Q1 Q2 Q3 Q4 :: bool
    6.81 +  have "Q1 | (Q2 | True | Q3) | Q4" by argo
    6.82 +next
    6.83 +  fix P Q R :: bool
    6.84 +  assume "(P & Q) | (P & ~Q) | (P & R) | (P & ~R)"
    6.85 +  then have "P" by argo
    6.86 +next
    6.87 +  fix P :: bool
    6.88 +  assume "P = True"
    6.89 +  then have "P" by argo
    6.90 +next
    6.91 +  fix P :: bool
    6.92 +  assume "False = P"
    6.93 +  then have "~P" by argo
    6.94 +next
    6.95 +  fix P Q :: bool
    6.96 +  assume "P = (~P)"
    6.97 +  then have "Q" by argo
    6.98 +next
    6.99 +  fix P :: bool
   6.100 +  have "(~P) = (~P)" by argo
   6.101 +next
   6.102 +  fix P Q :: bool
   6.103 +  assume "P" and "~Q"
   6.104 +  then have "P = (~Q)" by argo
   6.105 +next
   6.106 +  fix P Q :: bool
   6.107 +  assume "((P::bool) = Q) | (Q = P)"
   6.108 +  then have "(P --> Q) & (Q --> P)" by argo
   6.109 +next
   6.110 +  fix P Q :: bool
   6.111 +  assume "(P::bool) = Q"
   6.112 +  then have "Q = P" by argo
   6.113 +next
   6.114 +  fix P Q R :: bool
   6.115 +  assume "if P then Q else R"
   6.116 +  then have "Q | R" by argo
   6.117 +next
   6.118 +  fix P Q :: bool
   6.119 +  assume "P | Q"
   6.120 +     and "P | ~Q"
   6.121 +     and "~P | Q"
   6.122 +     and "~P | ~Q"
   6.123 +  then have "False" by argo
   6.124 +next
   6.125 +  fix P Q R :: bool
   6.126 +  assume "P | Q | R"
   6.127 +     and "P | Q | ~R"
   6.128 +     and "P | ~Q | R"
   6.129 +     and "P | ~Q | ~R"
   6.130 +     and "~P | Q | R"
   6.131 +     and "~P | Q | ~R"
   6.132 +     and "~P | ~Q | R"
   6.133 +     and "~P | ~Q | ~R"
   6.134 +  then have "False" by argo
   6.135 +next
   6.136 +  fix a b c d e f g h i j k l m n p q :: bool
   6.137 +  assume "(a & b | c & d) & (e & f | g & h) | (i & j | k & l) & (m & n | p & q)"
   6.138 +  then have "(a & b | c & d) & (e & f | g & h) | (i & j | k & l) & (m & n | p & q)" by argo
   6.139 +next
   6.140 +  fix P :: bool
   6.141 +  have "P=P=P=P=P=P=P=P=P=P" by argo
   6.142 +next
   6.143 +  fix a b c d e f p q x :: bool
   6.144 +  assume "a | b | c | d"
   6.145 +     and "e | f | (a & d)"
   6.146 +     and "~(a | (c & ~c)) | b"
   6.147 +     and "~(b & (x | ~x)) | c"
   6.148 +     and "~(d | False) | c"
   6.149 +     and "~(c | (~p & (p | (q & ~q))))"
   6.150 +  then have "False" by argo
   6.151 +end
   6.152 +
   6.153 +
   6.154 +subsection \<open>Equality, congruence and predicates\<close>
   6.155 +
   6.156 +notepad
   6.157 +begin
   6.158 +  fix t :: "'a"
   6.159 +  have "t = t" by argo
   6.160 +next
   6.161 +  fix t u :: "'a"
   6.162 +  assume "t = u"
   6.163 +  then have "u = t" by argo
   6.164 +next
   6.165 +  fix s t u :: "'a"
   6.166 +  assume "s = t" and "t = u"
   6.167 +  then have "s = u" by argo
   6.168 +next
   6.169 +  fix s t u v :: "'a"
   6.170 +  assume "s = t" and "t = u" and "u = v" and "u = s"
   6.171 +  then have "s = v" by argo
   6.172 +next
   6.173 +  fix s t u v w :: "'a"
   6.174 +  assume "s = t" and "t = u" and "s = v" and "v = w"
   6.175 +  then have "w = u" by argo
   6.176 +next
   6.177 +  fix s t u a b c :: "'a"
   6.178 +  assume "s = t" and "t = u" and "a = b" and "b = c"
   6.179 +  then have "s = a --> c = u" by argo
   6.180 +next
   6.181 +  fix a b c d :: "'a"
   6.182 +  assume "(a = b & b = c) | (a = d & d = c)"
   6.183 +  then have "a = c" by argo
   6.184 +next
   6.185 +  fix a b1 b2 b3 b4 c d :: "'a"
   6.186 +  assume "(a = b1 & ((b1 = b2 & b2 = b3) | (b1 = b4 & b4 = b3)) & b3 = c) | (a = d & d = c)"
   6.187 +  then have "a = c" by argo
   6.188 +next
   6.189 +  fix a b :: "'a"
   6.190 +  have "(if True then a else b) = a" by argo
   6.191 +next
   6.192 +  fix a b :: "'a"
   6.193 +  have "(if False then a else b) = b" by argo
   6.194 +next
   6.195 +  fix a b :: "'a"
   6.196 +  have "(if \<not>True then a else b) = b" by argo
   6.197 +next
   6.198 +  fix a b :: "'a"
   6.199 +  have "(if \<not>False then a else b) = a" by argo
   6.200 +next
   6.201 +  fix P :: "bool"
   6.202 +  fix a :: "'a"
   6.203 +  have "(if P then a else a) = a" by argo
   6.204 +next
   6.205 +  fix P :: "bool"
   6.206 +  fix a b c :: "'a"
   6.207 +  assume "P" and "a = c"
   6.208 +  then have "(if P then a else b) = c" by argo
   6.209 +next
   6.210 +  fix P :: "bool"
   6.211 +  fix a b c :: "'a"
   6.212 +  assume "~P" and "b = c"
   6.213 +  then have "(if P then a else b) = c" by argo
   6.214 +next
   6.215 +  fix P Q :: "bool"
   6.216 +  fix a b c d :: "'a"
   6.217 +  assume "P" and "Q" and "a = d"
   6.218 +  then have "(if P then (if Q then a else b) else c) = d" by argo
   6.219 +next
   6.220 +  fix a b c :: "'a"
   6.221 +  assume "a \<noteq> b" and "b = c"
   6.222 +  then have "a \<noteq> c" by argo
   6.223 +next
   6.224 +  fix a b c :: "'a"
   6.225 +  assume "a \<noteq> b" and "a = c"
   6.226 +  then have "c \<noteq> b" by argo
   6.227 +next
   6.228 +  fix a b c d :: "'a"
   6.229 +  assume "a = b" and "c = d" and "b \<noteq> d"
   6.230 +  then have "a \<noteq> c" by argo
   6.231 +next
   6.232 +  fix a b c d :: "'a"
   6.233 +  assume "a = b" and "c = d" and "d \<noteq> b"
   6.234 +  then have "a \<noteq> c" by argo
   6.235 +next
   6.236 +  fix a b c d :: "'a"
   6.237 +  assume "a = b" and "c = d" and "b \<noteq> d"
   6.238 +  then have "c \<noteq> a" by argo
   6.239 +next
   6.240 +  fix a b c d :: "'a"
   6.241 +  assume "a = b" and "c = d" and "d \<noteq> b"
   6.242 +  then have "c \<noteq> a" by argo
   6.243 +next
   6.244 +  fix a b c d e f :: "'a"
   6.245 +  assume "a \<noteq> b" and "b = c" and "b = d" and "d = e" and "a = f"
   6.246 +  then have "f \<noteq> e" by argo
   6.247 +next
   6.248 +  fix a b :: "'a" and f :: "'a \<Rightarrow> 'a"
   6.249 +  assume "a = b"
   6.250 +  then have "f a = f b" by argo
   6.251 +next
   6.252 +  fix a b c :: "'a" and f :: "'a \<Rightarrow> 'a"
   6.253 +  assume "f a = f b" and "b = c"
   6.254 +  then have "f a = f c" by argo
   6.255 +next
   6.256 +  fix a :: "'a" and f :: "'a \<Rightarrow> 'a"
   6.257 +  assume "f a = a"
   6.258 +  then have "f (f a) = a" by argo
   6.259 +next
   6.260 +  fix a b :: "'a" and f g :: "'a \<Rightarrow> 'a"
   6.261 +  assume "a = b"
   6.262 +  then have "g (f a) = g (f b)" by argo
   6.263 +next
   6.264 +  fix a b :: "'a" and f g :: "'a \<Rightarrow> 'a"
   6.265 +  assume "f a = b" and "g b = a"
   6.266 +  then have "f (g (f a)) = b" by argo
   6.267 +next
   6.268 +  fix a b :: "'a" and g :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"
   6.269 +  assume "a = b"
   6.270 +  then have "g a b = g b a" by argo
   6.271 +next
   6.272 +  fix a b :: "'a" and f :: "'a \<Rightarrow> 'a" and g :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"
   6.273 +  assume "f a = b"
   6.274 +  then have "g (f a) b = g b (f a)" by argo
   6.275 +next
   6.276 +  fix a b c d e g h :: "'a" and f :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"
   6.277 +  assume "c = d" and "e = c" and "e = b" and "b = h" and "f g h = d" and "f g d = a"
   6.278 +  then have "a = b" by argo
   6.279 +next
   6.280 +  fix a b :: "'a" and P :: "'a \<Rightarrow> bool"
   6.281 +  assume "P a" and "a = b"
   6.282 +  then have "P b" by argo
   6.283 +next
   6.284 +  fix a b :: "'a" and P :: "'a \<Rightarrow> bool"
   6.285 +  assume "~ P a" and "a = b"
   6.286 +  then have "~ P b" by argo
   6.287 +next
   6.288 +  fix a b c d :: "'a" and P :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
   6.289 +  assume "P a b" and "a = c" and "b = d"
   6.290 +  then have "P c d" by argo
   6.291 +next
   6.292 +  fix a b c d :: "'a" and P :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
   6.293 +  assume "~ P a b" and "a = c" and "b = d"
   6.294 +  then have "~ P c d" by argo
   6.295 +end
   6.296 +
   6.297 +
   6.298 +subsection \<open>Linear real arithmetic\<close>
   6.299 +
   6.300 +subsubsection \<open>Negation and subtraction\<close>
   6.301 +
   6.302 +notepad
   6.303 +begin
   6.304 +  fix a b :: real
   6.305 +  have
   6.306 +    "-a = -1 * a"
   6.307 +    "-(-a) = a"
   6.308 +    "a - b = a + -1 * b"
   6.309 +    "a - (-b) = a + b"
   6.310 +    by argo+
   6.311 +end
   6.312 +
   6.313 +
   6.314 +subsubsection \<open>Multiplication\<close>
   6.315 +
   6.316 +notepad
   6.317 +begin
   6.318 +  fix a b c d :: real
   6.319 +  have
   6.320 +    "(2::real) * 3 = 6"
   6.321 +    "0 * a = 0"
   6.322 +    "a * 0 = 0"
   6.323 +    "1 * a = a"
   6.324 +    "a * 1 = a"
   6.325 +    "2 * a = a * 2"
   6.326 +    "2 * a * 3 = 6 * a"
   6.327 +    "2 * a * 3 * 5 = 30 * a"
   6.328 +    "a * 0 * b = 0"
   6.329 +    "a * (0 * b) = 0"
   6.330 +    "a * (b * c) = (a * b) * c"
   6.331 +    "a * (b * (c * d)) = ((a * b) * c) * d"
   6.332 +    "a * (b + c + d) = a * b + a * c + a * d"
   6.333 +    by argo+
   6.334 +end
   6.335 +
   6.336 +
   6.337 +subsubsection \<open>Division\<close>
   6.338 +
   6.339 +notepad
   6.340 +begin
   6.341 +  fix a b c :: real
   6.342 +  have
   6.343 +    "(6::real) / 2 = 3"
   6.344 +    "a / 0 = a / 0"
   6.345 +    "a / 0 <= a / 0"
   6.346 +    "~(a / 0 < a / 0)"
   6.347 +    "0 / a = 0"
   6.348 +    "a / 1 = a"
   6.349 +    "a / 3 = 1/3 * a"
   6.350 +    "6 * a / 2 = 3 * a"
   6.351 +    "a / ((5 * b) / 2) = 2/5 * a / b"
   6.352 +    "a / (5 * (b / 2)) = 2/5 * a / b"
   6.353 +    "(a / 5) * (b / 2) = 1/10 * a * b"
   6.354 +    "a / (3 * b) = 1/3 * a / b"
   6.355 +    "(a + b) / 5 = 1/5 * a + 1/5 * b"
   6.356 +    "a / (5 * 1/5) = a"
   6.357 +    by argo+
   6.358 +end
   6.359 +
   6.360 +
   6.361 +subsubsection \<open>Addition\<close>
   6.362 +
   6.363 +notepad
   6.364 +begin
   6.365 +  fix a b c d :: real
   6.366 +  have
   6.367 +    "a + b = b + a"
   6.368 +    "a + b + c = c + b + a"
   6.369 +    "a + b + c + d = d + c + b + a"
   6.370 +    "a + (b + (c + d)) = ((a + b) + c) + d"
   6.371 +    "(5::real) + -3 = 2"
   6.372 +    "(3::real) + 5 + -1 = 7"
   6.373 +    "2 + a = a + 2"
   6.374 +    "a + b + a = b + 2 * a"
   6.375 +    "-1 + a + -1 + 2 + b + 5/3 + b + 1/3 + 5 * b + 2/3 = 8/3 + a + 7 * b"
   6.376 +    "1 + b + b + 5 * b + 3 * a + 7 + a + 2 = 10 + 4 * a + 7 * b"
   6.377 +    by argo+
   6.378 +end
   6.379 +
   6.380 +
   6.381 +subsubsection \<open>Minimum and maximum\<close>
   6.382 +
   6.383 +notepad
   6.384 +begin
   6.385 +  fix a b :: real
   6.386 +  have
   6.387 +    "min (3::real) 5 = 3"
   6.388 +    "min (5::real) 3 = 3"
   6.389 +    "min (3::real) (-5) = -5"
   6.390 +    "min (-5::real) 3 = -5"
   6.391 +    "min a a = a"
   6.392 +    "a \<le> b \<longrightarrow> min a b = a"
   6.393 +    "a > b \<longrightarrow> min a b = b"
   6.394 +    "min a b \<le> a"
   6.395 +    "min a b \<le> b"
   6.396 +    "min a b = min b a"
   6.397 +    by argo+
   6.398 +next
   6.399 +  fix a b :: real
   6.400 +  have
   6.401 +    "max (3::real) 5 = 5"
   6.402 +    "max (5::real) 3 = 5"
   6.403 +    "max (3::real) (-5) = 3"
   6.404 +    "max (-5::real) 3 = 3"
   6.405 +    "max a a = a"
   6.406 +    "a \<le> b \<longrightarrow> max a b = b"
   6.407 +    "a > b \<longrightarrow> max a b = a"
   6.408 +    "a \<le> max a b"
   6.409 +    "b \<le> max a b"
   6.410 +    "max a b = max b a"
   6.411 +    by argo+
   6.412 +next
   6.413 +  fix a b :: real
   6.414 +  have
   6.415 +    "min a b \<le> max a b"
   6.416 +    "min a b + max a b = a + b"
   6.417 +    "a < b \<longrightarrow> min a b < max a b"
   6.418 +    by argo+
   6.419 +end
   6.420 +
   6.421 +
   6.422 +subsubsection \<open>Absolute value\<close>
   6.423 +
   6.424 +notepad
   6.425 +begin
   6.426 +  fix a :: real
   6.427 +  have
   6.428 +    "abs (3::real) = 3"
   6.429 +    "abs (-3::real) = 3"
   6.430 +    "0 \<le> abs a"
   6.431 +    "a \<le> abs a"
   6.432 +    "a \<ge> 0 \<longrightarrow> abs a = a"
   6.433 +    "a < 0 \<longrightarrow> abs a = -a"
   6.434 +    "abs (abs a) = abs a"
   6.435 +    by argo+
   6.436 +end
   6.437 +
   6.438 +
   6.439 +subsubsection \<open>Equality\<close>
   6.440 +
   6.441 +notepad
   6.442 +begin
   6.443 +  fix a b c d :: real
   6.444 +  have
   6.445 +    "(3::real) = 3"
   6.446 +    "~((3::real) = 4)"
   6.447 +    "~((4::real) = 3)"
   6.448 +    "3 * a = 5 --> a = 5/3"
   6.449 +    "-3 * a = 5 --> -5/3 = a"
   6.450 +    "5 = 3 * a --> 5/3  = a "
   6.451 +    "5 = -3 * a --> a = -5/3"
   6.452 +    "2 + 3 * a = 4 --> a = 2/3"
   6.453 +    "4 = 2 + 3 * a --> 2/3 = a"
   6.454 +    "2 + 3 * a + 5 * b + c = 4 --> 3 * a + 5 * b + c = 2"
   6.455 +    "4 = 2 + 3 * a + 5 * b + c --> 2 = 3 * a + 5 * b + c"
   6.456 +    "-2 * a + b + -3 * c = 7 --> -7 = 2 * a + -1 * b + 3 * c"
   6.457 +    "7 = -2 * a + b + -3 * c --> 2 * a + -1 * b + 3 * c = -7"
   6.458 +    "-2 * a + b + -3 * c + 4 * d = 7 --> -7 = 2 * a + -1 * b + 3 * c + -4 * d"
   6.459 +    "7 = -2 * a + b + -3 * c + 4 * d --> 2 * a + -1 * b + 3 * c + -4 * d = -7"
   6.460 +    "a + 3 * b = 5 * c + b --> a + 2 * b + -5 * c = 0"
   6.461 +    by argo+
   6.462 +end
   6.463 +
   6.464 +
   6.465 +subsubsection \<open>Less-equal\<close>
   6.466 +
   6.467 +notepad
   6.468 +begin
   6.469 +  fix a b c d :: real
   6.470 +  have
   6.471 +    "(3::real) <= 3"
   6.472 +    "(3::real) <= 4"
   6.473 +    "~((4::real) <= 3)"
   6.474 +    "3 * a <= 5 --> a <= 5/3"
   6.475 +    "-3 * a <= 5 --> -5/3 <= a"
   6.476 +    "5 <= 3 * a --> 5/3  <= a "
   6.477 +    "5 <= -3 * a --> a <= -5/3"
   6.478 +    "2 + 3 * a <= 4 --> a <= 2/3"
   6.479 +    "4 <= 2 + 3 * a --> 2/3 <= a"
   6.480 +    "2 + 3 * a + 5 * b + c <= 4 --> 3 * a + 5 * b + c <= 2"
   6.481 +    "4 <= 2 + 3 * a + 5 * b + c --> 2 <= 3 * a + 5 * b + c"
   6.482 +    "-2 * a + b + -3 * c <= 7 --> -7 <= 2 * a + -1 * b + 3 * c"
   6.483 +    "7 <= -2 * a + b + -3 * c --> 2 * a + -1 * b + 3 * c <= -7"
   6.484 +    "-2 * a + b + -3 * c + 4 * d <= 7 --> -7 <= 2 * a + -1 * b + 3 * c + -4 * d"
   6.485 +    "7 <= -2 * a + b + -3 * c + 4 * d --> 2 * a + -1 * b + 3 * c + -4 * d <= -7"
   6.486 +    "a + 3 * b <= 5 * c + b --> a + 2 * b + -5 * c <= 0"
   6.487 +    by argo+
   6.488 +end
   6.489 +
   6.490 +subsubsection \<open>Less\<close>
   6.491 +
   6.492 +notepad
   6.493 +begin
   6.494 +  fix a b c d :: real
   6.495 +  have
   6.496 +    "(3::real) < 4"
   6.497 +    "~((3::real) < 3)"
   6.498 +    "~((4::real) < 3)"
   6.499 +    "3 * a < 5 --> a < 5/3"
   6.500 +    "-3 * a < 5 --> -5/3 < a"
   6.501 +    "5 < 3 * a --> 5/3  < a "
   6.502 +    "5 < -3 * a --> a < -5/3"
   6.503 +    "2 + 3 * a < 4 --> a < 2/3"
   6.504 +    "4 < 2 + 3 * a --> 2/3 < a"
   6.505 +    "2 + 3 * a + 5 * b + c < 4 --> 3 * a + 5 * b + c < 2"
   6.506 +    "4 < 2 + 3 * a + 5 * b + c --> 2 < 3 * a + 5 * b + c"
   6.507 +    "-2 * a + b + -3 * c < 7 --> -7 < 2 * a + -1 * b + 3 * c"
   6.508 +    "7 < -2 * a + b + -3 * c --> 2 * a + -1 * b + 3 * c < -7"
   6.509 +    "-2 * a + b + -3 * c + 4 * d < 7 --> -7 < 2 * a + -1 * b + 3 * c + -4 * d"
   6.510 +    "7 < -2 * a + b + -3 * c + 4 * d --> 2 * a + -1 * b + 3 * c + -4 * d < -7"
   6.511 +    "a + 3 * b < 5 * c + b --> a + 2 * b + -5 * c < 0"
   6.512 +    by argo+
   6.513 +end
   6.514 +
   6.515 +
   6.516 +subsubsection \<open>Other examples\<close>
   6.517 +
   6.518 +notepad
   6.519 +begin
   6.520 +  have
   6.521 +    "(0::real) < 1"
   6.522 +    "(47::real) + 11 < 8 * 15"
   6.523 +    by argo+
   6.524 +next
   6.525 +  fix a :: real
   6.526 +  assume "a < 3"
   6.527 +  then have "a < 5" "a <= 5" "~(5 < a)" "~(5 <= a)" by argo+
   6.528 +next
   6.529 +  fix a :: real
   6.530 +  assume "a <= 3"
   6.531 +  then have "a < 5" "a <= 5" "~(5 < a)" "~(5 <= a)" by argo+
   6.532 +next
   6.533 +  fix a :: real
   6.534 +  assume "~(3 < a)"
   6.535 +  then have "a < 5" "a <= 5" "~(5 < a)" "~(5 <= a)" by argo+
   6.536 +next
   6.537 +  fix a :: real
   6.538 +  assume "~(3 <= a)"
   6.539 +  then have "a < 5" "a <= 5" "~(5 < a)" "~(5 <= a)" by argo+
   6.540 +next
   6.541 +  fix a :: real
   6.542 +  have "a < 3 | a = 3 | a > 3" by argo
   6.543 +next
   6.544 +  fix a b :: real
   6.545 +  assume "0 < a" and "a < b"
   6.546 +  then have "0 < b" by argo
   6.547 +next
   6.548 +  fix a b :: real
   6.549 +  assume "0 < a" and "a \<le> b"
   6.550 +  then have "0 \<le> b" by argo
   6.551 +next
   6.552 +  fix a b :: real
   6.553 +  assume "0 \<le> a" and "a < b"
   6.554 +  then have "0 \<le> b" by argo
   6.555 +next
   6.556 +  fix a b :: real
   6.557 +  assume "0 \<le> a" and "a \<le> b"
   6.558 +  then have "0 \<le> b" by argo
   6.559 +next
   6.560 +  fix a b c :: real
   6.561 +  assume "2 \<le> a" and "3 \<le> b" and "c \<le> 5"
   6.562 +  then have "-2 * a + -3 * b + 5 * c < 13" by argo
   6.563 +next
   6.564 +  fix a b c :: real
   6.565 +  assume "2 \<le> a" and "3 \<le> b" and "c \<le> 5"
   6.566 +  then have "-2 * a + -3 * b + 5 * c \<le> 12" by argo
   6.567 +next
   6.568 +  fix a b :: real
   6.569 +  assume "a = 2" and "b = 3"
   6.570 +  then have "a + b > 5 \<or> a < b" by argo
   6.571 +next
   6.572 +  fix a b c :: real
   6.573 +  assume "5 < b + c" and "a + c < 0" and "a > 0"
   6.574 +  then have "b > 0" by argo
   6.575 +next
   6.576 +  fix a b c :: real
   6.577 +  assume "a + b < 7" and "5 < b + c" and "a + c < 0" and "a > 0"
   6.578 +  then have "0 < b \<and> b < 7" by argo
   6.579 +next
   6.580 +  fix a b c :: real
   6.581 +  assume "a < b" and "b < c" and "c < a"
   6.582 +  then have "False" by argo
   6.583 +next
   6.584 +  fix a b :: real
   6.585 +  assume "a - 5 > b"
   6.586 +  then have "b < a" by argo
   6.587 +next
   6.588 +  fix a b :: real
   6.589 +  have "(a - b) - a = (a - a) - b" by argo
   6.590 +next
   6.591 +  fix n m n' m' :: real
   6.592 +  have "
   6.593 +    (n < m & m < n') | (n < m & m = n') | (n < n' & n' < m) |
   6.594 +    (n = n' & n' < m) | (n = m & m < n') |
   6.595 +    (n' < m & m < n) | (n' < m & m = n) |
   6.596 +    (n' < n & n < m) | (n' = n & n < m) | (n' = m & m < n) |
   6.597 +    (m < n & n < n') | (m < n & n' = n) | (m < n' & n' < n) |
   6.598 +    (m = n & n < n') | (m = n' & n' < n) |
   6.599 +    (n' = m & m = n)"
   6.600 +    by argo
   6.601 +end
   6.602 +
   6.603 +
   6.604 +subsection \<open>Larger examples\<close>
   6.605 +
   6.606 +declare[[argo_trace = basic, argo_timeout = 60]]
   6.607 +
   6.608 +
   6.609 +text \<open>Translated from TPTP problem library: PUZ015-2.006.dimacs\<close>
   6.610 +
   6.611 +lemma assumes 1: "~x0"
   6.612 +  and 2: "~x30"
   6.613 +  and 3: "~x29"
   6.614 +  and 4: "~x59"
   6.615 +  and 5: "x1 | x31 | x0"
   6.616 +  and 6: "x2 | x32 | x1"
   6.617 +  and 7: "x3 | x33 | x2"
   6.618 +  and 8: "x4 | x34 | x3"
   6.619 +  and 9: "x35 | x4"
   6.620 +  and 10: "x5 | x36 | x30"
   6.621 +  and 11: "x6 | x37 | x5 | x31"
   6.622 +  and 12: "x7 | x38 | x6 | x32"
   6.623 +  and 13: "x8 | x39 | x7 | x33"
   6.624 +  and 14: "x9 | x40 | x8 | x34"
   6.625 +  and 15: "x41 | x9 | x35"
   6.626 +  and 16: "x10 | x42 | x36"
   6.627 +  and 17: "x11 | x43 | x10 | x37"
   6.628 +  and 18: "x12 | x44 | x11 | x38"
   6.629 +  and 19: "x13 | x45 | x12 | x39"
   6.630 +  and 20: "x14 | x46 | x13 | x40"
   6.631 +  and 21: "x47 | x14 | x41"
   6.632 +  and 22: "x15 | x48 | x42"
   6.633 +  and 23: "x16 | x49 | x15 | x43"
   6.634 +  and 24: "x17 | x50 | x16 | x44"
   6.635 +  and 25: "x18 | x51 | x17 | x45"
   6.636 +  and 26: "x19 | x52 | x18 | x46"
   6.637 +  and 27: "x53 | x19 | x47"
   6.638 +  and 28: "x20 | x54 | x48"
   6.639 +  and 29: "x21 | x55 | x20 | x49"
   6.640 +  and 30: "x22 | x56 | x21 | x50"
   6.641 +  and 31: "x23 | x57 | x22 | x51"
   6.642 +  and 32: "x24 | x58 | x23 | x52"
   6.643 +  and 33: "x59 | x24 | x53"
   6.644 +  and 34: "x25 | x54"
   6.645 +  and 35: "x26 | x25 | x55"
   6.646 +  and 36: "x27 | x26 | x56"
   6.647 +  and 37: "x28 | x27 | x57"
   6.648 +  and 38: "x29 | x28 | x58"
   6.649 +  and 39: "~x1 | ~x31"
   6.650 +  and 40: "~x1 | ~x0"
   6.651 +  and 41: "~x31 | ~x0"
   6.652 +  and 42: "~x2 | ~x32"
   6.653 +  and 43: "~x2 | ~x1"
   6.654 +  and 44: "~x32 | ~x1"
   6.655 +  and 45: "~x3 | ~x33"
   6.656 +  and 46: "~x3 | ~x2"
   6.657 +  and 47: "~x33 | ~x2"
   6.658 +  and 48: "~x4 | ~x34"
   6.659 +  and 49: "~x4 | ~x3"
   6.660 +  and 50: "~x34 | ~x3"
   6.661 +  and 51: "~x35 | ~x4"
   6.662 +  and 52: "~x5 | ~x36"
   6.663 +  and 53: "~x5 | ~x30"
   6.664 +  and 54: "~x36 | ~x30"
   6.665 +  and 55: "~x6 | ~x37"
   6.666 +  and 56: "~x6 | ~x5"
   6.667 +  and 57: "~x6 | ~x31"
   6.668 +  and 58: "~x37 | ~x5"
   6.669 +  and 59: "~x37 | ~x31"
   6.670 +  and 60: "~x5 | ~x31"
   6.671 +  and 61: "~x7 | ~x38"
   6.672 +  and 62: "~x7 | ~x6"
   6.673 +  and 63: "~x7 | ~x32"
   6.674 +  and 64: "~x38 | ~x6"
   6.675 +  and 65: "~x38 | ~x32"
   6.676 +  and 66: "~x6 | ~x32"
   6.677 +  and 67: "~x8 | ~x39"
   6.678 +  and 68: "~x8 | ~x7"
   6.679 +  and 69: "~x8 | ~x33"
   6.680 +  and 70: "~x39 | ~x7"
   6.681 +  and 71: "~x39 | ~x33"
   6.682 +  and 72: "~x7 | ~x33"
   6.683 +  and 73: "~x9 | ~x40"
   6.684 +  and 74: "~x9 | ~x8"
   6.685 +  and 75: "~x9 | ~x34"
   6.686 +  and 76: "~x40 | ~x8"
   6.687 +  and 77: "~x40 | ~x34"
   6.688 +  and 78: "~x8 | ~x34"
   6.689 +  and 79: "~x41 | ~x9"
   6.690 +  and 80: "~x41 | ~x35"
   6.691 +  and 81: "~x9 | ~x35"
   6.692 +  and 82: "~x10 | ~x42"
   6.693 +  and 83: "~x10 | ~x36"
   6.694 +  and 84: "~x42 | ~x36"
   6.695 +  and 85: "~x11 | ~x43"
   6.696 +  and 86: "~x11 | ~x10"
   6.697 +  and 87: "~x11 | ~x37"
   6.698 +  and 88: "~x43 | ~x10"
   6.699 +  and 89: "~x43 | ~x37"
   6.700 +  and 90: "~x10 | ~x37"
   6.701 +  and 91: "~x12 | ~x44"
   6.702 +  and 92: "~x12 | ~x11"
   6.703 +  and 93: "~x12 | ~x38"
   6.704 +  and 94: "~x44 | ~x11"
   6.705 +  and 95: "~x44 | ~x38"
   6.706 +  and 96: "~x11 | ~x38"
   6.707 +  and 97: "~x13 | ~x45"
   6.708 +  and 98: "~x13 | ~x12"
   6.709 +  and 99: "~x13 | ~x39"
   6.710 +  and 100: "~x45 | ~x12"
   6.711 +  and 101: "~x45 | ~x39"
   6.712 +  and 102: "~x12 | ~x39"
   6.713 +  and 103: "~x14 | ~x46"
   6.714 +  and 104: "~x14 | ~x13"
   6.715 +  and 105: "~x14 | ~x40"
   6.716 +  and 106: "~x46 | ~x13"
   6.717 +  and 107: "~x46 | ~x40"
   6.718 +  and 108: "~x13 | ~x40"
   6.719 +  and 109: "~x47 | ~x14"
   6.720 +  and 110: "~x47 | ~x41"
   6.721 +  and 111: "~x14 | ~x41"
   6.722 +  and 112: "~x15 | ~x48"
   6.723 +  and 113: "~x15 | ~x42"
   6.724 +  and 114: "~x48 | ~x42"
   6.725 +  and 115: "~x16 | ~x49"
   6.726 +  and 116: "~x16 | ~x15"
   6.727 +  and 117: "~x16 | ~x43"
   6.728 +  and 118: "~x49 | ~x15"
   6.729 +  and 119: "~x49 | ~x43"
   6.730 +  and 120: "~x15 | ~x43"
   6.731 +  and 121: "~x17 | ~x50"
   6.732 +  and 122: "~x17 | ~x16"
   6.733 +  and 123: "~x17 | ~x44"
   6.734 +  and 124: "~x50 | ~x16"
   6.735 +  and 125: "~x50 | ~x44"
   6.736 +  and 126: "~x16 | ~x44"
   6.737 +  and 127: "~x18 | ~x51"
   6.738 +  and 128: "~x18 | ~x17"
   6.739 +  and 129: "~x18 | ~x45"
   6.740 +  and 130: "~x51 | ~x17"
   6.741 +  and 131: "~x51 | ~x45"
   6.742 +  and 132: "~x17 | ~x45"
   6.743 +  and 133: "~x19 | ~x52"
   6.744 +  and 134: "~x19 | ~x18"
   6.745 +  and 135: "~x19 | ~x46"
   6.746 +  and 136: "~x52 | ~x18"
   6.747 +  and 137: "~x52 | ~x46"
   6.748 +  and 138: "~x18 | ~x46"
   6.749 +  and 139: "~x53 | ~x19"
   6.750 +  and 140: "~x53 | ~x47"
   6.751 +  and 141: "~x19 | ~x47"
   6.752 +  and 142: "~x20 | ~x54"
   6.753 +  and 143: "~x20 | ~x48"
   6.754 +  and 144: "~x54 | ~x48"
   6.755 +  and 145: "~x21 | ~x55"
   6.756 +  and 146: "~x21 | ~x20"
   6.757 +  and 147: "~x21 | ~x49"
   6.758 +  and 148: "~x55 | ~x20"
   6.759 +  and 149: "~x55 | ~x49"
   6.760 +  and 150: "~x20 | ~x49"
   6.761 +  and 151: "~x22 | ~x56"
   6.762 +  and 152: "~x22 | ~x21"
   6.763 +  and 153: "~x22 | ~x50"
   6.764 +  and 154: "~x56 | ~x21"
   6.765 +  and 155: "~x56 | ~x50"
   6.766 +  and 156: "~x21 | ~x50"
   6.767 +  and 157: "~x23 | ~x57"
   6.768 +  and 158: "~x23 | ~x22"
   6.769 +  and 159: "~x23 | ~x51"
   6.770 +  and 160: "~x57 | ~x22"
   6.771 +  and 161: "~x57 | ~x51"
   6.772 +  and 162: "~x22 | ~x51"
   6.773 +  and 163: "~x24 | ~x58"
   6.774 +  and 164: "~x24 | ~x23"
   6.775 +  and 165: "~x24 | ~x52"
   6.776 +  and 166: "~x58 | ~x23"
   6.777 +  and 167: "~x58 | ~x52"
   6.778 +  and 168: "~x23 | ~x52"
   6.779 +  and 169: "~x59 | ~x24"
   6.780 +  and 170: "~x59 | ~x53"
   6.781 +  and 171: "~x24 | ~x53"
   6.782 +  and 172: "~x25 | ~x54"
   6.783 +  and 173: "~x26 | ~x25"
   6.784 +  and 174: "~x26 | ~x55"
   6.785 +  and 175: "~x25 | ~x55"
   6.786 +  and 176: "~x27 | ~x26"
   6.787 +  and 177: "~x27 | ~x56"
   6.788 +  and 178: "~x26 | ~x56"
   6.789 +  and 179: "~x28 | ~x27"
   6.790 +  and 180: "~x28 | ~x57"
   6.791 +  and 181: "~x27 | ~x57"
   6.792 +  and 182: "~x29 | ~x28"
   6.793 +  and 183: "~x29 | ~x58"
   6.794 +  and 184: "~x28 | ~x58"
   6.795 +  shows "False"
   6.796 +    using assms
   6.797 +    by argo
   6.798 +
   6.799 +
   6.800 +text \<open>Translated from TPTP problem library: MSC007-1.008.dimacs\<close>
   6.801 +
   6.802 +lemma assumes 1: "x0 | x1 | x2 | x3 | x4 | x5 | x6"
   6.803 +  and 2: "x7 | x8 | x9 | x10 | x11 | x12 | x13"
   6.804 +  and 3: "x14 | x15 | x16 | x17 | x18 | x19 | x20"
   6.805 +  and 4: "x21 | x22 | x23 | x24 | x25 | x26 | x27"
   6.806 +  and 5: "x28 | x29 | x30 | x31 | x32 | x33 | x34"
   6.807 +  and 6: "x35 | x36 | x37 | x38 | x39 | x40 | x41"
   6.808 +  and 7: "x42 | x43 | x44 | x45 | x46 | x47 | x48"
   6.809 +  and 8: "x49 | x50 | x51 | x52 | x53 | x54 | x55"
   6.810 +  and 9: "~x0 | ~x7"
   6.811 +  and 10: "~x0 | ~x14"
   6.812 +  and 11: "~x0 | ~x21"
   6.813 +  and 12: "~x0 | ~x28"
   6.814 +  and 13: "~x0 | ~x35"
   6.815 +  and 14: "~x0 | ~x42"
   6.816 +  and 15: "~x0 | ~x49"
   6.817 +  and 16: "~x7 | ~x14"
   6.818 +  and 17: "~x7 | ~x21"
   6.819 +  and 18: "~x7 | ~x28"
   6.820 +  and 19: "~x7 | ~x35"
   6.821 +  and 20: "~x7 | ~x42"
   6.822 +  and 21: "~x7 | ~x49"
   6.823 +  and 22: "~x14 | ~x21"
   6.824 +  and 23: "~x14 | ~x28"
   6.825 +  and 24: "~x14 | ~x35"
   6.826 +  and 25: "~x14 | ~x42"
   6.827 +  and 26: "~x14 | ~x49"
   6.828 +  and 27: "~x21 | ~x28"
   6.829 +  and 28: "~x21 | ~x35"
   6.830 +  and 29: "~x21 | ~x42"
   6.831 +  and 30: "~x21 | ~x49"
   6.832 +  and 31: "~x28 | ~x35"
   6.833 +  and 32: "~x28 | ~x42"
   6.834 +  and 33: "~x28 | ~x49"
   6.835 +  and 34: "~x35 | ~x42"
   6.836 +  and 35: "~x35 | ~x49"
   6.837 +  and 36: "~x42 | ~x49"
   6.838 +  and 37: "~x1 | ~x8"
   6.839 +  and 38: "~x1 | ~x15"
   6.840 +  and 39: "~x1 | ~x22"
   6.841 +  and 40: "~x1 | ~x29"
   6.842 +  and 41: "~x1 | ~x36"
   6.843 +  and 42: "~x1 | ~x43"
   6.844 +  and 43: "~x1 | ~x50"
   6.845 +  and 44: "~x8 | ~x15"
   6.846 +  and 45: "~x8 | ~x22"
   6.847 +  and 46: "~x8 | ~x29"
   6.848 +  and 47: "~x8 | ~x36"
   6.849 +  and 48: "~x8 | ~x43"
   6.850 +  and 49: "~x8 | ~x50"
   6.851 +  and 50: "~x15 | ~x22"
   6.852 +  and 51: "~x15 | ~x29"
   6.853 +  and 52: "~x15 | ~x36"
   6.854 +  and 53: "~x15 | ~x43"
   6.855 +  and 54: "~x15 | ~x50"
   6.856 +  and 55: "~x22 | ~x29"
   6.857 +  and 56: "~x22 | ~x36"
   6.858 +  and 57: "~x22 | ~x43"
   6.859 +  and 58: "~x22 | ~x50"
   6.860 +  and 59: "~x29 | ~x36"
   6.861 +  and 60: "~x29 | ~x43"
   6.862 +  and 61: "~x29 | ~x50"
   6.863 +  and 62: "~x36 | ~x43"
   6.864 +  and 63: "~x36 | ~x50"
   6.865 +  and 64: "~x43 | ~x50"
   6.866 +  and 65: "~x2 | ~x9"
   6.867 +  and 66: "~x2 | ~x16"
   6.868 +  and 67: "~x2 | ~x23"
   6.869 +  and 68: "~x2 | ~x30"
   6.870 +  and 69: "~x2 | ~x37"
   6.871 +  and 70: "~x2 | ~x44"
   6.872 +  and 71: "~x2 | ~x51"
   6.873 +  and 72: "~x9 | ~x16"
   6.874 +  and 73: "~x9 | ~x23"
   6.875 +  and 74: "~x9 | ~x30"
   6.876 +  and 75: "~x9 | ~x37"
   6.877 +  and 76: "~x9 | ~x44"
   6.878 +  and 77: "~x9 | ~x51"
   6.879 +  and 78: "~x16 | ~x23"
   6.880 +  and 79: "~x16 | ~x30"
   6.881 +  and 80: "~x16 | ~x37"
   6.882 +  and 81: "~x16 | ~x44"
   6.883 +  and 82: "~x16 | ~x51"
   6.884 +  and 83: "~x23 | ~x30"
   6.885 +  and 84: "~x23 | ~x37"
   6.886 +  and 85: "~x23 | ~x44"
   6.887 +  and 86: "~x23 | ~x51"
   6.888 +  and 87: "~x30 | ~x37"
   6.889 +  and 88: "~x30 | ~x44"
   6.890 +  and 89: "~x30 | ~x51"
   6.891 +  and 90: "~x37 | ~x44"
   6.892 +  and 91: "~x37 | ~x51"
   6.893 +  and 92: "~x44 | ~x51"
   6.894 +  and 93: "~x3 | ~x10"
   6.895 +  and 94: "~x3 | ~x17"
   6.896 +  and 95: "~x3 | ~x24"
   6.897 +  and 96: "~x3 | ~x31"
   6.898 +  and 97: "~x3 | ~x38"
   6.899 +  and 98: "~x3 | ~x45"
   6.900 +  and 99: "~x3 | ~x52"
   6.901 +  and 100: "~x10 | ~x17"
   6.902 +  and 101: "~x10 | ~x24"
   6.903 +  and 102: "~x10 | ~x31"
   6.904 +  and 103: "~x10 | ~x38"
   6.905 +  and 104: "~x10 | ~x45"
   6.906 +  and 105: "~x10 | ~x52"
   6.907 +  and 106: "~x17 | ~x24"
   6.908 +  and 107: "~x17 | ~x31"
   6.909 +  and 108: "~x17 | ~x38"
   6.910 +  and 109: "~x17 | ~x45"
   6.911 +  and 110: "~x17 | ~x52"
   6.912 +  and 111: "~x24 | ~x31"
   6.913 +  and 112: "~x24 | ~x38"
   6.914 +  and 113: "~x24 | ~x45"
   6.915 +  and 114: "~x24 | ~x52"
   6.916 +  and 115: "~x31 | ~x38"
   6.917 +  and 116: "~x31 | ~x45"
   6.918 +  and 117: "~x31 | ~x52"
   6.919 +  and 118: "~x38 | ~x45"
   6.920 +  and 119: "~x38 | ~x52"
   6.921 +  and 120: "~x45 | ~x52"
   6.922 +  and 121: "~x4 | ~x11"
   6.923 +  and 122: "~x4 | ~x18"
   6.924 +  and 123: "~x4 | ~x25"
   6.925 +  and 124: "~x4 | ~x32"
   6.926 +  and 125: "~x4 | ~x39"
   6.927 +  and 126: "~x4 | ~x46"
   6.928 +  and 127: "~x4 | ~x53"
   6.929 +  and 128: "~x11 | ~x18"
   6.930 +  and 129: "~x11 | ~x25"
   6.931 +  and 130: "~x11 | ~x32"
   6.932 +  and 131: "~x11 | ~x39"
   6.933 +  and 132: "~x11 | ~x46"
   6.934 +  and 133: "~x11 | ~x53"
   6.935 +  and 134: "~x18 | ~x25"
   6.936 +  and 135: "~x18 | ~x32"
   6.937 +  and 136: "~x18 | ~x39"
   6.938 +  and 137: "~x18 | ~x46"
   6.939 +  and 138: "~x18 | ~x53"
   6.940 +  and 139: "~x25 | ~x32"
   6.941 +  and 140: "~x25 | ~x39"
   6.942 +  and 141: "~x25 | ~x46"
   6.943 +  and 142: "~x25 | ~x53"
   6.944 +  and 143: "~x32 | ~x39"
   6.945 +  and 144: "~x32 | ~x46"
   6.946 +  and 145: "~x32 | ~x53"
   6.947 +  and 146: "~x39 | ~x46"
   6.948 +  and 147: "~x39 | ~x53"
   6.949 +  and 148: "~x46 | ~x53"
   6.950 +  and 149: "~x5 | ~x12"
   6.951 +  and 150: "~x5 | ~x19"
   6.952 +  and 151: "~x5 | ~x26"
   6.953 +  and 152: "~x5 | ~x33"
   6.954 +  and 153: "~x5 | ~x40"
   6.955 +  and 154: "~x5 | ~x47"
   6.956 +  and 155: "~x5 | ~x54"
   6.957 +  and 156: "~x12 | ~x19"
   6.958 +  and 157: "~x12 | ~x26"
   6.959 +  and 158: "~x12 | ~x33"
   6.960 +  and 159: "~x12 | ~x40"
   6.961 +  and 160: "~x12 | ~x47"
   6.962 +  and 161: "~x12 | ~x54"
   6.963 +  and 162: "~x19 | ~x26"
   6.964 +  and 163: "~x19 | ~x33"
   6.965 +  and 164: "~x19 | ~x40"
   6.966 +  and 165: "~x19 | ~x47"
   6.967 +  and 166: "~x19 | ~x54"
   6.968 +  and 167: "~x26 | ~x33"
   6.969 +  and 168: "~x26 | ~x40"
   6.970 +  and 169: "~x26 | ~x47"
   6.971 +  and 170: "~x26 | ~x54"
   6.972 +  and 171: "~x33 | ~x40"
   6.973 +  and 172: "~x33 | ~x47"
   6.974 +  and 173: "~x33 | ~x54"
   6.975 +  and 174: "~x40 | ~x47"
   6.976 +  and 175: "~x40 | ~x54"
   6.977 +  and 176: "~x47 | ~x54"
   6.978 +  and 177: "~x6 | ~x13"
   6.979 +  and 178: "~x6 | ~x20"
   6.980 +  and 179: "~x6 | ~x27"
   6.981 +  and 180: "~x6 | ~x34"
   6.982 +  and 181: "~x6 | ~x41"
   6.983 +  and 182: "~x6 | ~x48"
   6.984 +  and 183: "~x6 | ~x55"
   6.985 +  and 184: "~x13 | ~x20"
   6.986 +  and 185: "~x13 | ~x27"
   6.987 +  and 186: "~x13 | ~x34"
   6.988 +  and 187: "~x13 | ~x41"
   6.989 +  and 188: "~x13 | ~x48"
   6.990 +  and 189: "~x13 | ~x55"
   6.991 +  and 190: "~x20 | ~x27"
   6.992 +  and 191: "~x20 | ~x34"
   6.993 +  and 192: "~x20 | ~x41"
   6.994 +  and 193: "~x20 | ~x48"
   6.995 +  and 194: "~x20 | ~x55"
   6.996 +  and 195: "~x27 | ~x34"
   6.997 +  and 196: "~x27 | ~x41"
   6.998 +  and 197: "~x27 | ~x48"
   6.999 +  and 198: "~x27 | ~x55"
  6.1000 +  and 199: "~x34 | ~x41"
  6.1001 +  and 200: "~x34 | ~x48"
  6.1002 +  and 201: "~x34 | ~x55"
  6.1003 +  and 202: "~x41 | ~x48"
  6.1004 +  and 203: "~x41 | ~x55"
  6.1005 +  and 204: "~x48 | ~x55"
  6.1006 +  shows "False"
  6.1007 +    using assms
  6.1008 +    by argo
  6.1009 +
  6.1010 +
  6.1011 +lemma "0 \<le> (yc::real) \<and>
  6.1012 +       0 \<le> yd \<and> 0 \<le> yb \<and> 0 \<le> ya \<Longrightarrow>
  6.1013 +       0 \<le> yf \<and>
  6.1014 +       0 \<le> xh \<and> 0 \<le> ye \<and> 0 \<le> yg \<Longrightarrow>
  6.1015 +       0 \<le> yw \<and> 0 \<le> xs \<and> 0 \<le> yu \<Longrightarrow>
  6.1016 +       0 \<le> aea \<and> 0 \<le> aee \<and> 0 \<le> aed \<Longrightarrow>
  6.1017 +       0 \<le> zy \<and> 0 \<le> xz \<and> 0 \<le> zw \<Longrightarrow>
  6.1018 +       0 \<le> zb \<and>
  6.1019 +       0 \<le> za \<and> 0 \<le> yy \<and> 0 \<le> yz \<Longrightarrow>
  6.1020 +       0 \<le> zp \<and> 0 \<le> zo \<and> 0 \<le> yq \<Longrightarrow>
  6.1021 +       0 \<le> adp \<and> 0 \<le> aeb \<and> 0 \<le> aec \<Longrightarrow>
  6.1022 +       0 \<le> acm \<and> 0 \<le> aco \<and> 0 \<le> acn \<Longrightarrow>
  6.1023 +       0 \<le> abl \<Longrightarrow>
  6.1024 +       0 \<le> zr \<and> 0 \<le> zq \<and> 0 \<le> abh \<Longrightarrow>
  6.1025 +       0 \<le> abq \<and> 0 \<le> zd \<and> 0 \<le> abo \<Longrightarrow>
  6.1026 +       0 \<le> acd \<and>
  6.1027 +       0 \<le> acc \<and> 0 \<le> xi \<and> 0 \<le> acb \<Longrightarrow>
  6.1028 +       0 \<le> acp \<and> 0 \<le> acr \<and> 0 \<le> acq \<Longrightarrow>
  6.1029 +       0 \<le> xw \<and>
  6.1030 +       0 \<le> xr \<and> 0 \<le> xv \<and> 0 \<le> xu \<Longrightarrow>
  6.1031 +       0 \<le> zc \<and> 0 \<le> acg \<and> 0 \<le> ach \<Longrightarrow>
  6.1032 +       0 \<le> zt \<and> 0 \<le> zs \<and> 0 \<le> xy \<Longrightarrow>
  6.1033 +       0 \<le> ady \<and> 0 \<le> adw \<and> 0 \<le> zg \<Longrightarrow>
  6.1034 +       0 \<le> abd \<and>
  6.1035 +       0 \<le> abc \<and> 0 \<le> yr \<and> 0 \<le> abb \<Longrightarrow>
  6.1036 +       0 \<le> adi \<and>
  6.1037 +       0 \<le> x \<and> 0 \<le> adh \<and> 0 \<le> xa \<Longrightarrow>
  6.1038 +       0 \<le> aak \<and> 0 \<le> aai \<and> 0 \<le> aad \<Longrightarrow>
  6.1039 +       0 \<le> aba \<and> 0 \<le> zh \<and> 0 \<le> aay \<Longrightarrow>
  6.1040 +       0 \<le> abg \<and> 0 \<le> ys \<and> 0 \<le> abe \<Longrightarrow>
  6.1041 +       0 \<le> abs1 \<and>
  6.1042 +       0 \<le> yt \<and> 0 \<le> abr \<and> 0 \<le> zu \<Longrightarrow>
  6.1043 +       0 \<le> abv \<and>
  6.1044 +       0 \<le> zn \<and> 0 \<le> abw \<and> 0 \<le> zm \<Longrightarrow>
  6.1045 +       0 \<le> adl \<and> 0 \<le> adn \<Longrightarrow>
  6.1046 +       0 \<le> acf \<and> 0 \<le> aca \<Longrightarrow>
  6.1047 +       0 \<le> ads \<and> 0 \<le> aaq \<Longrightarrow>
  6.1048 +       0 \<le> ada \<Longrightarrow>
  6.1049 +       0 \<le> aaf \<and> 0 \<le> aac \<and> 0 \<le> aag \<Longrightarrow>
  6.1050 +       0 \<le> aal \<and>
  6.1051 +       0 \<le> acu \<and> 0 \<le> acs \<and> 0 \<le> act \<Longrightarrow>
  6.1052 +       0 \<le> aas \<and> 0 \<le> xb \<and> 0 \<le> aat \<Longrightarrow>
  6.1053 +       0 \<le> zk \<and> 0 \<le> zj \<and> 0 \<le> zi \<Longrightarrow>
  6.1054 +       0 \<le> ack \<and>
  6.1055 +       0 \<le> acj \<and> 0 \<le> xc \<and> 0 \<le> aci \<Longrightarrow>
  6.1056 +       0 \<le> aav \<and> 0 \<le> aah \<and> 0 \<le> xd \<Longrightarrow>
  6.1057 +       0 \<le> abt \<and>
  6.1058 +       0 \<le> xo \<and> 0 \<le> abu \<and> 0 \<le> xn \<Longrightarrow>
  6.1059 +       0 \<le> adc \<and>
  6.1060 +       0 \<le> abz \<and> 0 \<le> adc \<and> 0 \<le> abz \<Longrightarrow>
  6.1061 +       0 \<le> xt \<and>
  6.1062 +       0 \<le> zz \<and> 0 \<le> aab \<and> 0 \<le> aaa \<Longrightarrow>
  6.1063 +       0 \<le> adq \<and>
  6.1064 +       0 \<le> xl \<and> 0 \<le> adr \<and> 0 \<le> adb \<Longrightarrow>
  6.1065 +       0 \<le> zf \<and> 0 \<le> yh \<and> 0 \<le> yi \<Longrightarrow>
  6.1066 +       0 \<le> aao \<and> 0 \<le> aam \<and> 0 \<le> xe \<Longrightarrow>
  6.1067 +       0 \<le> abk \<and>
  6.1068 +       0 \<le> aby \<and> 0 \<le> abj \<and> 0 \<le> abx \<Longrightarrow>
  6.1069 +       0 \<le> yp \<Longrightarrow>
  6.1070 +       0 \<le> yl \<and> 0 \<le> yj \<and> 0 \<le> ym \<Longrightarrow>
  6.1071 +       0 \<le> acw \<Longrightarrow>
  6.1072 +       0 \<le> adk \<and>
  6.1073 +       0 \<le> adg \<and> 0 \<le> adj \<and> 0 \<le> adf \<Longrightarrow>
  6.1074 +       0 \<le> adv \<and> 0 \<le> xf \<and> 0 \<le> adu \<Longrightarrow>
  6.1075 +       yc + yd + yb + ya = 1 \<Longrightarrow>
  6.1076 +       yf + xh + ye + yg = 1 \<Longrightarrow>
  6.1077 +       yw + xs + yu = 1 \<Longrightarrow>
  6.1078 +       aea + aee + aed = 1 \<Longrightarrow>
  6.1079 +       zy + xz + zw = 1 \<Longrightarrow>
  6.1080 +       zb + za + yy + yz = 1 \<Longrightarrow>
  6.1081 +       zp + zo + yq = 1 \<Longrightarrow>
  6.1082 +       adp + aeb + aec = 1 \<Longrightarrow>
  6.1083 +       acm + aco + acn = 1 \<Longrightarrow>
  6.1084 +       abl + abl = 1 \<Longrightarrow>
  6.1085 +       zr + zq + abh = 1 \<Longrightarrow>
  6.1086 +       abq + zd + abo = 1 \<Longrightarrow>
  6.1087 +       acd + acc + xi + acb = 1 \<Longrightarrow>
  6.1088 +       acp + acr + acq = 1 \<Longrightarrow>
  6.1089 +       xw + xr + xv + xu = 1 \<Longrightarrow>
  6.1090 +       zc + acg + ach = 1 \<Longrightarrow>
  6.1091 +       zt + zs + xy = 1 \<Longrightarrow>
  6.1092 +       ady + adw + zg = 1 \<Longrightarrow>
  6.1093 +       abd + abc + yr + abb = 1 \<Longrightarrow>
  6.1094 +       adi + x + adh + xa = 1 \<Longrightarrow>
  6.1095 +       aak + aai + aad = 1 \<Longrightarrow>
  6.1096 +       aba + zh + aay = 1 \<Longrightarrow>
  6.1097 +       abg + ys + abe = 1 \<Longrightarrow>
  6.1098 +       abs1 + yt + abr + zu = 1 \<Longrightarrow>
  6.1099 +       abv + zn + abw + zm = 1 \<Longrightarrow>
  6.1100 +       adl + adn = 1 \<Longrightarrow>
  6.1101 +       acf + aca = 1 \<Longrightarrow>
  6.1102 +       ads + aaq = 1 \<Longrightarrow>
  6.1103 +       ada + ada = 1 \<Longrightarrow>
  6.1104 +       aaf + aac + aag = 1 \<Longrightarrow>
  6.1105 +       aal + acu + acs + act = 1 \<Longrightarrow>
  6.1106 +       aas + xb + aat = 1 \<Longrightarrow>
  6.1107 +       zk + zj + zi = 1 \<Longrightarrow>
  6.1108 +       ack + acj + xc + aci = 1 \<Longrightarrow>
  6.1109 +       aav + aah + xd = 1 \<Longrightarrow>
  6.1110 +       abt + xo + abu + xn = 1 \<Longrightarrow>
  6.1111 +       adc + abz + adc + abz = 1 \<Longrightarrow>
  6.1112 +       xt + zz + aab + aaa = 1 \<Longrightarrow>
  6.1113 +       adq + xl + adr + adb = 1 \<Longrightarrow>
  6.1114 +       zf + yh + yi = 1 \<Longrightarrow>
  6.1115 +       aao + aam + xe = 1 \<Longrightarrow>
  6.1116 +       abk + aby + abj + abx = 1 \<Longrightarrow>
  6.1117 +       yp + yp = 1 \<Longrightarrow>
  6.1118 +       yl + yj + ym = 1 \<Longrightarrow>
  6.1119 +       acw + acw + acw + acw = 1 \<Longrightarrow>
  6.1120 +       adk + adg + adj + adf = 1 \<Longrightarrow>
  6.1121 +       adv + xf + adu = 1 \<Longrightarrow>
  6.1122 +       yd = 0 \<or> yb = 0 \<Longrightarrow>
  6.1123 +       xh = 0 \<or> ye = 0 \<Longrightarrow>
  6.1124 +       yy = 0 \<or> za = 0 \<Longrightarrow>
  6.1125 +       acc = 0 \<or> xi = 0 \<Longrightarrow>
  6.1126 +       xv = 0 \<or> xr = 0 \<Longrightarrow>
  6.1127 +       yr = 0 \<or> abc = 0 \<Longrightarrow>
  6.1128 +       zn = 0 \<or> abw = 0 \<Longrightarrow>
  6.1129 +       xo = 0 \<or> abu = 0 \<Longrightarrow>
  6.1130 +       xl = 0 \<or> adr = 0 \<Longrightarrow>
  6.1131 +       (yr + abd < abl \<or>
  6.1132 +        yr + (abd + abb) < 1) \<or>
  6.1133 +       yr + abd = abl \<and>
  6.1134 +       yr + (abd + abb) = 1 \<Longrightarrow>
  6.1135 +       adb + adr < xn + abu \<or>
  6.1136 +       adb + adr = xn + abu \<Longrightarrow>
  6.1137 +       (abl < abt \<or> abl < abt + xo) \<or>
  6.1138 +       abl = abt \<and> abl = abt + xo \<Longrightarrow>
  6.1139 +       yd + yc < abc + abd \<or>
  6.1140 +       yd + yc = abc + abd \<Longrightarrow>
  6.1141 +       aca < abb + yr \<or> aca = abb + yr \<Longrightarrow>
  6.1142 +       acb + acc < xu + xv \<or>
  6.1143 +       acb + acc = xu + xv \<Longrightarrow>
  6.1144 +       (yq < xu + xr \<or>
  6.1145 +        yq + zp < xu + (xr + xw)) \<or>
  6.1146 +       yq = xu + xr \<and>
  6.1147 +       yq + zp = xu + (xr + xw) \<Longrightarrow>
  6.1148 +       (zw < xw \<or>
  6.1149 +        zw < xw + xv \<or>
  6.1150 +        zw + zy < xw + (xv + xu)) \<or>
  6.1151 +       zw = xw \<and>
  6.1152 +       zw = xw + xv \<and>
  6.1153 +       zw + zy = xw + (xv + xu) \<Longrightarrow>
  6.1154 +       xs + yw < zs + zt \<or>
  6.1155 +       xs + yw = zs + zt \<Longrightarrow>
  6.1156 +       aab + xt < ye + yf \<or>
  6.1157 +       aab + xt = ye + yf \<Longrightarrow>
  6.1158 +       (ya + yb < yg + ye \<or>
  6.1159 +        ya + (yb + yc) < yg + (ye + yf)) \<or>
  6.1160 +       ya + yb = yg + ye \<and>
  6.1161 +       ya + (yb + yc) = yg + (ye + yf) \<Longrightarrow>
  6.1162 +       (xu + xv < acb + acc \<or>
  6.1163 +        xu + (xv + xw) < acb + (acc + acd)) \<or>
  6.1164 +       xu + xv = acb + acc \<and>
  6.1165 +       xu + (xv + xw) = acb + (acc + acd) \<Longrightarrow>
  6.1166 +       (zs < xz + zy \<or>
  6.1167 +        zs + xy < xz + (zy + zw)) \<or>
  6.1168 +       zs = xz + zy \<and>
  6.1169 +       zs + xy = xz + (zy + zw) \<Longrightarrow>
  6.1170 +       (zs + zt < xz + zy \<or>
  6.1171 +        zs + (zt + xy) < xz + (zy + zw)) \<or>
  6.1172 +       zs + zt = xz + zy \<and>
  6.1173 +       zs + (zt + xy) = xz + (zy + zw) \<Longrightarrow>
  6.1174 +       yg + ye < ya + yb \<or>
  6.1175 +       yg + ye = ya + yb \<Longrightarrow>
  6.1176 +       (abd < yc \<or> abd + abc < yc + yd) \<or>
  6.1177 +       abd = yc \<and> abd + abc = yc + yd \<Longrightarrow>
  6.1178 +       (ye + yf < adr + adq \<or>
  6.1179 +        ye + (yf + yg) < adr + (adq + adb)) \<or>
  6.1180 +       ye + yf = adr + adq \<and>
  6.1181 +       ye + (yf + yg) = adr + (adq + adb) \<Longrightarrow>
  6.1182 +       yh + yi < ym + yj \<or>
  6.1183 +       yh + yi = ym + yj \<Longrightarrow>
  6.1184 +       (abq < yl \<or> abq + abo < yl + ym) \<or>
  6.1185 +       abq = yl \<and> abq + abo = yl + ym \<Longrightarrow>
  6.1186 +       (yp < zp \<or>
  6.1187 +        yp < zp + zo \<or> 1 < zp + (zo + yq)) \<or>
  6.1188 +       yp = zp \<and>
  6.1189 +       yp = zp + zo \<and> 1 = zp + (zo + yq) \<Longrightarrow>
  6.1190 +       (abb + yr < aca \<or>
  6.1191 +        abb + (yr + abd) < aca + acf) \<or>
  6.1192 +       abb + yr = aca \<and>
  6.1193 +       abb + (yr + abd) = aca + acf \<Longrightarrow>
  6.1194 +       adw + zg < abe + ys \<or>
  6.1195 +       adw + zg = abe + ys \<Longrightarrow>
  6.1196 +       zd + abq < ys + abg \<or>
  6.1197 +       zd + abq = ys + abg \<Longrightarrow>
  6.1198 +       yt + abs1 < aby + abk \<or>
  6.1199 +       yt + abs1 = aby + abk \<Longrightarrow>
  6.1200 +       (yu < abx \<or>
  6.1201 +        yu < abx + aby \<or>
  6.1202 +        yu + yw < abx + (aby + abk)) \<or>
  6.1203 +       yu = abx \<and>
  6.1204 +       yu = abx + aby \<and>
  6.1205 +       yu + yw = abx + (aby + abk) \<Longrightarrow>
  6.1206 +       aaf < adv \<or> aaf = adv \<Longrightarrow>
  6.1207 +       abj + abk < yy + zb \<or>
  6.1208 +       abj + abk = yy + zb \<Longrightarrow>
  6.1209 +       (abb < yz \<or>
  6.1210 +        abb + abc < yz + za \<or>
  6.1211 +        abb + (abc + abd) < yz + (za + zb)) \<or>
  6.1212 +       abb = yz \<and>
  6.1213 +       abb + abc = yz + za \<and>
  6.1214 +       abb + (abc + abd) = yz + (za + zb) \<Longrightarrow>
  6.1215 +       (acg + zc < zd + abq \<or>
  6.1216 +        acg + (zc + ach)
  6.1217 +        < zd + (abq + abo)) \<or>
  6.1218 +       acg + zc = zd + abq \<and>
  6.1219 +       acg + (zc + ach) =
  6.1220 +       zd + (abq + abo) \<Longrightarrow>
  6.1221 +       zf < acm \<or> zf = acm \<Longrightarrow>
  6.1222 +       (zg + ady < acn + acm \<or>
  6.1223 +        zg + (ady + adw)
  6.1224 +        < acn + (acm + aco)) \<or>
  6.1225 +       zg + ady = acn + acm \<and>
  6.1226 +       zg + (ady + adw) =
  6.1227 +       acn + (acm + aco) \<Longrightarrow>
  6.1228 +       aay + zh < zi + zj \<or>
  6.1229 +       aay + zh = zi + zj \<Longrightarrow>
  6.1230 +       zy < zk \<or> zy = zk \<Longrightarrow>
  6.1231 +       (adn < zm + zn \<or>
  6.1232 +        adn + adl < zm + (zn + abv)) \<or>
  6.1233 +       adn = zm + zn \<and>
  6.1234 +       adn + adl = zm + (zn + abv) \<Longrightarrow>
  6.1235 +       zo + zp < zs + zt \<or>
  6.1236 +       zo + zp = zs + zt \<Longrightarrow>
  6.1237 +       zq + zr < zs + zt \<or>
  6.1238 +       zq + zr = zs + zt \<Longrightarrow>
  6.1239 +       (aai < adi \<or> aai < adi + adh) \<or>
  6.1240 +       aai = adi \<and> aai = adi + adh \<Longrightarrow>
  6.1241 +       (abr < acj \<or>
  6.1242 +        abr + (abs1 + zu)
  6.1243 +        < acj + (aci + ack)) \<or>
  6.1244 +       abr = acj \<and>
  6.1245 +       abr + (abs1 + zu) =
  6.1246 +       acj + (aci + ack) \<Longrightarrow>
  6.1247 +       (abl < zw \<or> 1 < zw + zy) \<or>
  6.1248 +       abl = zw \<and> 1 = zw + zy \<Longrightarrow>
  6.1249 +       (zz + aaa < act + acu \<or>
  6.1250 +        zz + (aaa + aab)
  6.1251 +        < act + (acu + aal)) \<or>
  6.1252 +       zz + aaa = act + acu \<and>
  6.1253 +       zz + (aaa + aab) =
  6.1254 +       act + (acu + aal) \<Longrightarrow>
  6.1255 +       (aam < aac \<or> aam + aao < aac + aaf) \<or>
  6.1256 +       aam = aac \<and> aam + aao = aac + aaf \<Longrightarrow>
  6.1257 +       (aak < aaf \<or> aak + aad < aaf + aag) \<or>
  6.1258 +       aak = aaf \<and> aak + aad = aaf + aag \<Longrightarrow>
  6.1259 +       (aah < aai \<or> aah + aav < aai + aak) \<or>
  6.1260 +       aah = aai \<and> aah + aav = aai + aak \<Longrightarrow>
  6.1261 +       act + (acu + aal) < aam + aao \<or>
  6.1262 +       act + (acu + aal) = aam + aao \<Longrightarrow>
  6.1263 +       (ads < aat \<or> 1 < aat + aas) \<or>
  6.1264 +       ads = aat \<and> 1 = aat + aas \<Longrightarrow>
  6.1265 +       (aba < aas \<or> aba + aay < aas + aat) \<or>
  6.1266 +       aba = aas \<and> aba + aay = aas + aat \<Longrightarrow>
  6.1267 +       acm < aav \<or> acm = aav \<Longrightarrow>
  6.1268 +       (ada < aay \<or> 1 < aay + aba) \<or>
  6.1269 +       ada = aay \<and> 1 = aay + aba \<Longrightarrow>
  6.1270 +       abb + (abc + abd) < abe + abg \<or>
  6.1271 +       abb + (abc + abd) = abe + abg \<Longrightarrow>
  6.1272 +       (abh < abj \<or> abh < abj + abk) \<or>
  6.1273 +       abh = abj \<and> abh = abj + abk \<Longrightarrow>
  6.1274 +       1 < abo + abq \<or> 1 = abo + abq \<Longrightarrow>
  6.1275 +       (acj < abr \<or> acj + aci < abr + abs1) \<or>
  6.1276 +       acj = abr \<and> acj + aci = abr + abs1 \<Longrightarrow>
  6.1277 +       (abt < abv \<or> abt + abu < abv + abw) \<or>
  6.1278 +       abt = abv \<and> abt + abu = abv + abw \<Longrightarrow>
  6.1279 +       (abx < adc \<or> abx + aby < adc + abz) \<or>
  6.1280 +       abx = adc \<and> abx + aby = adc + abz \<Longrightarrow>
  6.1281 +       (acf < acd \<or>
  6.1282 +        acf < acd + acc \<or>
  6.1283 +        1 < acd + (acc + acb)) \<or>
  6.1284 +       acf = acd \<and>
  6.1285 +       acf = acd + acc \<and>
  6.1286 +       1 = acd + (acc + acb) \<Longrightarrow>
  6.1287 +       acc + acd < acf \<or> acc + acd = acf \<Longrightarrow>
  6.1288 +       (acg < acq \<or> acg + ach < acq + acr) \<or>
  6.1289 +       acg = acq \<and> acg + ach = acq + acr \<Longrightarrow>
  6.1290 +       aci + (acj + ack) < acr + acp \<or>
  6.1291 +       aci + (acj + ack) = acr + acp \<Longrightarrow>
  6.1292 +       (acm < acp \<or>
  6.1293 +        acm + acn < acp + acq \<or>
  6.1294 +        acm + (acn + aco)
  6.1295 +        < acp + (acq + acr)) \<or>
  6.1296 +       acm = acp \<and>
  6.1297 +       acm + acn = acp + acq \<and>
  6.1298 +       acm + (acn + aco) =
  6.1299 +       acp + (acq + acr) \<Longrightarrow>
  6.1300 +       (acs + act < acw + acw \<or>
  6.1301 +        acs + (act + acu)
  6.1302 +        < acw + (acw + acw)) \<or>
  6.1303 +       acs + act = acw + acw \<and>
  6.1304 +       acs + (act + acu) =
  6.1305 +       acw + (acw + acw) \<Longrightarrow>
  6.1306 +       (ada < adb + adr \<or>
  6.1307 +        1 < adb + (adr + adq)) \<or>
  6.1308 +       ada = adb + adr \<and>
  6.1309 +       1 = adb + (adr + adq) \<Longrightarrow>
  6.1310 +       (adc + adc < adf + adg \<or>
  6.1311 +        adc + (adc + abz)
  6.1312 +        < adf + (adg + adk)) \<or>
  6.1313 +       adc + adc = adf + adg \<and>
  6.1314 +       adc + (adc + abz) =
  6.1315 +       adf + (adg + adk) \<Longrightarrow>
  6.1316 +       adh + adi < adj + adk \<or>
  6.1317 +       adh + adi = adj + adk \<Longrightarrow>
  6.1318 +       (adl < aec \<or> 1 < aec + adp) \<or>
  6.1319 +       adl = aec \<and> 1 = aec + adp \<Longrightarrow>
  6.1320 +       (adq < ads \<or> adq + adr < ads) \<or>
  6.1321 +       adq = ads \<and> adq + adr = ads \<Longrightarrow>
  6.1322 +       adu + adv < aed + aea \<or>
  6.1323 +       adu + adv = aed + aea \<Longrightarrow>
  6.1324 +       (adw < aee \<or> adw + ady < aee + aea) \<or>
  6.1325 +       adw = aee \<and> adw + ady = aee + aea \<Longrightarrow>
  6.1326 +       (aeb < aed \<or> aeb + aec < aed + aee) \<or>
  6.1327 +       aeb = aed \<and> aeb + aec = aed + aee \<Longrightarrow>
  6.1328 +       False"
  6.1329 +       by argo
  6.1330 +
  6.1331 +end
     7.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     7.2 +++ b/src/Tools/Argo/argo_cc.ML	Thu Sep 29 20:54:44 2016 +0200
     7.3 @@ -0,0 +1,654 @@
     7.4 +(*  Title:      Tools/Argo/argo_cc.ML
     7.5 +    Author:     Sascha Boehme
     7.6 +    Author:     Dmitriy Traytel and Matthias Franze, TU Muenchen
     7.7 +
     7.8 +Equality reasoning based on congurence closure. It features:
     7.9 +
    7.10 +  * congruence closure for any term that participates in equalities
    7.11 +  * support for predicates
    7.12 +
    7.13 +These features might be added:
    7.14 +
    7.15 +  * caching of explanations while building proofs to obtain shorter proofs
    7.16 +    and faster proof checking
    7.17 +  * propagating relevant merges of equivalence classes to all other theory solvers
    7.18 +  * propagating new relevant negated equalities to all other theory solvers
    7.19 +  * creating lemma "f ~= g | a ~= b | f a = g b" for asserted negated equalities
    7.20 +    between "f a" and "g b" (dynamic ackermannization)
    7.21 +
    7.22 +The implementation is inspired by:
    7.23 +
    7.24 +  Robert Nieuwenhuis and Albert Oliveras. Fast Congruence Closure and
    7.25 +  Extensions. In Information and Computation, volume 205(4),
    7.26 +  pages 557-580, 2007.
    7.27 +
    7.28 +  Harald Ganzinger, George Hagen, Robert Nieuwenhuis, Albert Oliveras,
    7.29 +  Cesare Tinelli. DPLL(T): Fast decision procedures. In Lecture Notes in
    7.30 +  Computer Science, volume 3114, pages 175-188. Springer, 2004.
    7.31 +*)
    7.32 +
    7.33 +signature ARGO_CC =
    7.34 +sig
    7.35 +  (* context *)
    7.36 +  type context
    7.37 +  val context: context
    7.38 +
    7.39 +  (* simplification *)
    7.40 +  val simplify: Argo_Rewr.context -> Argo_Rewr.context
    7.41 +  
    7.42 +  (* enriching the context *)
    7.43 +  val add_atom: Argo_Term.term -> context -> Argo_Lit.literal option * context
    7.44 +
    7.45 +  (* main operations *)
    7.46 +  val assume: Argo_Common.literal -> context -> Argo_Lit.literal Argo_Common.implied * context
    7.47 +  val check: context -> Argo_Lit.literal Argo_Common.implied * context
    7.48 +  val explain: Argo_Lit.literal -> context -> (Argo_Cls.clause * context) option
    7.49 +  val add_level: context -> context
    7.50 +  val backtrack: context -> context
    7.51 +end
    7.52 +
    7.53 +structure Argo_Cc: ARGO_CC =
    7.54 +struct
    7.55 +
    7.56 +(* tables indexed by pairs of terms *)
    7.57 +
    7.58 +val term2_ord = prod_ord Argo_Term.term_ord Argo_Term.term_ord
    7.59 +
    7.60 +structure Argo_Term2tab = Table(type key = Argo_Term.term * Argo_Term.term val ord = term2_ord)
    7.61 +
    7.62 +
    7.63 +(* equality certificates *)
    7.64 +
    7.65 +(*
    7.66 +  The solver keeps assumed equalities to produce explanations later on.
    7.67 +
    7.68 +  A flat equality (lp, (t1, t2)) consists of the assumed literal and its proof
    7.69 +  as well as the terms t1 and t2 that are assumed to be equal. The literal expresses
    7.70 +  the equality t1 = t2.
    7.71 +
    7.72 +  A congruence equality (t1, t2) is an equality t1 = t2 where both terms are
    7.73 +  applications (f a) and (g b).
    7.74 +
    7.75 +  A symmetric equality eq is a marker for applying the symmetry rule to eq.
    7.76 +*)
    7.77 +
    7.78 +datatype eq =
    7.79 +  Flat of Argo_Common.literal * (Argo_Term.term * Argo_Term.term) |
    7.80 +  Cong of Argo_Term.term * Argo_Term.term |
    7.81 +  Symm of eq
    7.82 +
    7.83 +fun dest_eq (Flat (_, tp)) = tp
    7.84 +  | dest_eq (Cong tp) = tp
    7.85 +  | dest_eq (Symm eq) = swap (dest_eq eq)
    7.86 +
    7.87 +fun symm (Symm eq) = eq
    7.88 +  | symm eq = Symm eq
    7.89 +
    7.90 +fun negate (Flat ((lit, p), tp)) = Flat ((Argo_Lit.negate lit, p), tp)
    7.91 +  | negate (Cong tp) = Cong tp
    7.92 +  | negate (Symm eq) = Symm (negate eq)
    7.93 +
    7.94 +fun dest_app (Argo_Term.T (_, Argo_Expr.App, [t1, t2])) = (t1, t2)
    7.95 +  | dest_app _ = raise Fail "bad application"
    7.96 +
    7.97 +
    7.98 +(* context *)
    7.99 +
   7.100 +(*
   7.101 +  Each representative keeps track of the yet unimplied atoms in which this any member of
   7.102 +  this representative's equivalence class occurs. An atom is either a list of equalities
   7.103 +  between two terms, a list of predicates or a certificate. The certificate denotes that
   7.104 +  this equivalence class contains already implied predicates, and the literal accompanying
   7.105 +  the certificate specifies the polarity of these predicates.
   7.106 +*)
   7.107 +
   7.108 +datatype atoms =
   7.109 +  Eqs of (Argo_Term.term * Argo_Term.term) list |
   7.110 +  Preds of Argo_Term.term list |
   7.111 +  Cert of Argo_Common.literal
   7.112 +
   7.113 +(*
   7.114 +  Each representative has an associated ritem that contains the members of the
   7.115 +  equivalence class, the yet unimplied atoms and further information.
   7.116 +*)
   7.117 +
   7.118 +type ritem = {
   7.119 +  size: int, (* the size of the equivalence class *)
   7.120 +  class: Argo_Term.term list, (* the equivalence class as a list of distinct terms *)
   7.121 +  occs: Argo_Term.term list, (* a list of all application terms in which members of
   7.122 +    the equivalence class occur either as function or as argument *)
   7.123 +  neqs: (Argo_Term.term * eq) list, (* a list of terms from disjoint equivalence classes,
   7.124 +    for each term of this list there is a certificate of a negated equality that is
   7.125 +    required to explain why the equivalence classes are disjoint *)
   7.126 +  atoms: atoms} (* the atoms of the representative *)
   7.127 +
   7.128 +type repr = Argo_Term.term Argo_Termtab.table
   7.129 +type rdata = ritem Argo_Termtab.table
   7.130 +type apps = Argo_Term.term Argo_Term2tab.table
   7.131 +type trace = (Argo_Term.term * eq) Argo_Termtab.table
   7.132 +
   7.133 +type context = {
   7.134 +  repr: repr, (* a table mapping terms to their representatives *)
   7.135 +  rdata: rdata, (* a table mapping representatives to their ritems *)
   7.136 +  apps: apps, (* a table mapping a function and an argument to their application *)
   7.137 +  trace: trace, (* the proof forest used to trace assumed and implied equalities *)
   7.138 +  prf: Argo_Proof.context, (* the proof context *)
   7.139 +  back: (repr * rdata * apps * trace) list} (* backtracking information *)
   7.140 +
   7.141 +fun mk_context repr rdata apps trace prf back: context =
   7.142 +  {repr=repr, rdata=rdata, apps=apps, trace=trace, prf=prf, back=back}
   7.143 +
   7.144 +val context =
   7.145 +  mk_context Argo_Termtab.empty Argo_Termtab.empty Argo_Term2tab.empty Argo_Termtab.empty
   7.146 +    Argo_Proof.cc_context []
   7.147 +
   7.148 +fun repr_of repr t = the_default t (Argo_Termtab.lookup repr t)
   7.149 +fun repr_of' ({repr, ...}: context) = repr_of repr
   7.150 +fun put_repr t r = Argo_Termtab.update (t, r)
   7.151 +
   7.152 +fun mk_ritem size class occs neqs atoms: ritem =
   7.153 +  {size=size, class=class, occs=occs, neqs=neqs, atoms=atoms}
   7.154 +
   7.155 +fun as_ritem t = mk_ritem 1 [t] [] [] (Eqs [])
   7.156 +fun as_pred_ritem t = mk_ritem 1 [t] [] [] (Preds [t])
   7.157 +fun gen_ritem_of mk rdata r = the_default (mk r) (Argo_Termtab.lookup rdata r)
   7.158 +fun ritem_of rdata = gen_ritem_of as_ritem rdata
   7.159 +fun ritem_of_pred rdata = gen_ritem_of as_pred_ritem rdata
   7.160 +fun ritem_of' ({rdata, ...}: context) = ritem_of rdata
   7.161 +fun put_ritem r ri = Argo_Termtab.update (r, ri)
   7.162 +
   7.163 +fun add_occ r occ = Argo_Termtab.map_default (r, as_ritem r)
   7.164 +  (fn {size, class, occs, neqs, atoms}: ritem => mk_ritem size class (occ :: occs) neqs atoms)
   7.165 +
   7.166 +fun put_atoms atoms ({size, class, occs, neqs, ...}: ritem) = mk_ritem size class occs neqs atoms
   7.167 +
   7.168 +fun add_eq_atom r atom = Argo_Termtab.map_default (r, as_ritem r)
   7.169 +  (fn ri as {atoms=Eqs atoms, ...}: ritem => put_atoms (Eqs (atom :: atoms)) ri
   7.170 +    | ri => put_atoms (Eqs [atom]) ri)
   7.171 +
   7.172 +fun lookup_app apps tp = Argo_Term2tab.lookup apps tp
   7.173 +fun put_app tp app = Argo_Term2tab.update_new (tp, app)
   7.174 +
   7.175 +
   7.176 +(* traces for explanations *)
   7.177 +
   7.178 +(*
   7.179 +  Assumed and implied equalities are collected in a proof forest for being able to
   7.180 +  produce explanations. For each equivalence class there is one proof tree. The
   7.181 +  equality certificates are oriented towards a root term, that is not necessarily
   7.182 +  the representative of the equivalence class.
   7.183 +*)
   7.184 +
   7.185 +(*
   7.186 +  Whenever two equivalence classes are merged due to an equality t1 = t2, the shorter
   7.187 +  of the two paths, either from t1 to its root or t2 to its root, is re-oriented such
   7.188 +  that the relevant ti becomes the new root of its tree. Then, a new edge between ti
   7.189 +  and the other term of the equality t1 = t2 is added to connect the two proof trees.
   7.190 +*)
   7.191 +
   7.192 +fun depth_of trace t =
   7.193 +  (case Argo_Termtab.lookup trace t of
   7.194 +    NONE => 0
   7.195 +  | SOME (t', _) => 1 + depth_of trace t')
   7.196 +
   7.197 +fun reorient t trace =
   7.198 +  (case Argo_Termtab.lookup trace t of
   7.199 +    NONE => trace
   7.200 +  | SOME (t', eq) => Argo_Termtab.update (t', (t, symm eq)) (reorient t' trace))
   7.201 +
   7.202 +fun new_edge from to eq trace = Argo_Termtab.update (from, (to, eq)) (reorient from trace)
   7.203 +
   7.204 +fun with_shortest f (t1, t2) eq trace =
   7.205 +  (if depth_of trace t1 <= depth_of trace t2 then f t1 t2 eq else f t2 t1 (symm eq)) trace
   7.206 +
   7.207 +fun add_edge eq trace = with_shortest new_edge (dest_eq eq) eq trace
   7.208 +
   7.209 +(*
   7.210 +  To produce an explanation that t1 and t2 are equal, the paths to their root are
   7.211 +  extracted from the proof forest. Common ancestors in both paths are dropped.
   7.212 +*)
   7.213 +
   7.214 +fun path_to_root trace path t =
   7.215 +  (case Argo_Termtab.lookup trace t of
   7.216 +    NONE => (t, path)
   7.217 +  | SOME (t', _) => path_to_root trace (t :: path) t')
   7.218 +
   7.219 +fun drop_common root (t1 :: path1) (t2 :: path2) =
   7.220 +      if Argo_Term.eq_term (t1, t2) then drop_common t1 path1 path2 else root
   7.221 +  | drop_common root _ _ = root
   7.222 +
   7.223 +fun common_ancestor trace t1 t2 =
   7.224 +  let val ((root, path1), (_, path2)) = apply2 (path_to_root trace []) (t1, t2)
   7.225 +  in drop_common root path1 path2 end
   7.226 +
   7.227 +(*
   7.228 +  The proof of an assumed literal is typically a hypothesis. If the assumed literal is
   7.229 +  already known to be a unit literal, then there is already a proof for it.
   7.230 +*)
   7.231 +
   7.232 +fun proof_of (lit, NONE) lits prf =
   7.233 +      (insert Argo_Lit.eq_lit (Argo_Lit.negate lit) lits, Argo_Proof.mk_hyp lit prf)
   7.234 +  | proof_of (_, SOME p) lits prf = (lits, (p, prf))
   7.235 +
   7.236 +(*
   7.237 +  The explanation of equality between two terms t1 and t2 is computed based on the
   7.238 +  paths from t1 and t2 to their common ancestor t in the proof forest. For each of
   7.239 +  the two paths, a transitive proof of equality t1 = t and t = t2 is constructed,
   7.240 +  such that t1 = t2 follows by transitivity.
   7.241 +  
   7.242 +  Each edge of the paths denotes an assumed or implied equality. Implied equalities
   7.243 +  might be due to congruences (f a = g b) for which the equalities f = g and a = b
   7.244 +  need to be explained recursively.
   7.245 +*)
   7.246 +
   7.247 +fun mk_eq_proof trace t1 t2 lits prf =
   7.248 +  if Argo_Term.eq_term (t1, t2) then (lits, Argo_Proof.mk_refl t1 prf)
   7.249 +  else
   7.250 +    let
   7.251 +      val root = common_ancestor trace t1 t2
   7.252 +      val (lits, (p1, prf)) = trans_proof I I trace t1 root lits prf
   7.253 +      val (lits, (p2, prf)) = trans_proof swap symm trace t2 root lits prf
   7.254 +    in (lits, Argo_Proof.mk_trans p1 p2 prf) end
   7.255 +
   7.256 +and trans_proof sw sy trace t root lits prf =
   7.257 +  if Argo_Term.eq_term (t, root) then (lits, Argo_Proof.mk_refl t prf)
   7.258 +  else
   7.259 +    (case Argo_Termtab.lookup trace t of
   7.260 +      NONE => raise Fail "bad trace"
   7.261 +    | SOME (t', eq) => 
   7.262 +        let
   7.263 +          val (lits, (p1, prf)) = proof_step trace (sy eq) lits prf
   7.264 +          val (lits, (p2, prf)) = trans_proof sw sy trace t' root lits prf
   7.265 +        in (lits, uncurry Argo_Proof.mk_trans (sw (p1, p2)) prf) end)
   7.266 +
   7.267 +and proof_step _ (Flat (cert, _)) lits prf = proof_of cert lits prf
   7.268 +  | proof_step trace (Cong tp) lits prf =
   7.269 +      let
   7.270 +        val ((t1, t2), (u1, u2)) = apply2 dest_app tp
   7.271 +        val (lits, (p1, prf)) = mk_eq_proof trace t1 u1 lits prf
   7.272 +        val (lits, (p2, prf)) = mk_eq_proof trace t2 u2 lits prf
   7.273 +      in (lits, Argo_Proof.mk_cong p1 p2 prf) end
   7.274 +  | proof_step trace (Symm eq) lits prf =
   7.275 +      proof_step trace eq lits prf ||> uncurry Argo_Proof.mk_symm
   7.276 +
   7.277 +(*
   7.278 +  All clauses produced by a theory solver are expected to be a lemma.
   7.279 +  The lemma proof must hence be the last proof step.
   7.280 +*)
   7.281 +
   7.282 +fun close_proof lit lits (p, prf) = (lit :: lits, Argo_Proof.mk_lemma [lit] p prf)
   7.283 +
   7.284 +(*
   7.285 +  The explanation for the equality of t1 and t2 used the above algorithm.
   7.286 +*)
   7.287 +
   7.288 +fun explain_eq lit t1 t2 ({repr, rdata, apps, trace, prf, back}: context) =
   7.289 +  let val (lits, (p, prf)) = mk_eq_proof trace t1 t2 [] prf |-> close_proof lit
   7.290 +  in ((lits, p), mk_context repr rdata apps trace prf back) end
   7.291 +
   7.292 +(*
   7.293 +  The explanation that t1 and t2 are distinct uses the negated equality u1 ~= u2 that
   7.294 +  explains why the equivalence class containing t1 and u1 and the equivalence class
   7.295 +  containing t2 and u2 are disjoint. The explanations for t1 = u1 and u2 = t2 are
   7.296 +  constructed using the above algorithm. By transitivity, it follows that t1 ~= t2.  
   7.297 +*)
   7.298 +
   7.299 +fun finish_proof (Flat ((lit, _), _)) lits p prf = close_proof lit lits (p, prf)
   7.300 +  | finish_proof (Cong _) _ _ _ = raise Fail "bad equality"
   7.301 +  | finish_proof (Symm eq) lits p prf = Argo_Proof.mk_symm p prf |-> finish_proof eq lits
   7.302 +
   7.303 +fun explain_neq eq eq' ({repr, rdata, apps, trace, prf, back}: context) =
   7.304 +  let
   7.305 +    val (t1, t2) = dest_eq eq
   7.306 +    val (u1, u2) = dest_eq eq'
   7.307 +
   7.308 +    val (lits, (p, prf)) = proof_step trace eq' [] prf
   7.309 +    val (lits, (p1, prf)) = mk_eq_proof trace t1 u1 lits prf
   7.310 +    val (lits, (p2, prf)) = mk_eq_proof trace u2 t2 lits prf
   7.311 +    val (lits, (p, prf)) = 
   7.312 +      Argo_Proof.mk_trans p p2 prf |-> Argo_Proof.mk_trans p1 |-> finish_proof eq lits
   7.313 +  in ((lits, p), mk_context repr rdata apps trace prf back) end
   7.314 +
   7.315 +
   7.316 +(* propagating new equalities *)
   7.317 +
   7.318 +exception CONFLICT of Argo_Cls.clause * context
   7.319 +
   7.320 +(*
   7.321 +  comment missing
   7.322 +*)
   7.323 +
   7.324 +fun same_repr repr r (t, _) = Argo_Term.eq_term (r, repr_of repr t)
   7.325 +
   7.326 +fun has_atom rdata r eq =
   7.327 +  (case #atoms (ritem_of rdata r) of
   7.328 +    Eqs eqs => member (Argo_Term.eq_term o snd) eqs eq
   7.329 +  | _ => false)
   7.330 +
   7.331 +fun add_implied mk_lit repr rdata r neqs (atom as (t, eq)) (eqs, ls) =
   7.332 +  let val r' = repr_of repr t
   7.333 +  in
   7.334 +    if Argo_Term.eq_term (r, r') then (eqs, insert Argo_Lit.eq_lit (mk_lit eq) ls)
   7.335 +    else if exists (same_repr repr r') neqs andalso has_atom rdata r' eq then
   7.336 +      (eqs, Argo_Lit.Neg eq :: ls)
   7.337 +    else (atom :: eqs, ls)
   7.338 +  end
   7.339 +
   7.340 +(*
   7.341 +  comment missing
   7.342 +*)
   7.343 +
   7.344 +fun copy_occ repr app (eqs, occs, apps) =
   7.345 +  let val rp = apply2 (repr_of repr) (dest_app app)
   7.346 +  in
   7.347 +    (case lookup_app apps rp of
   7.348 +      SOME app' => (Cong (app, app') :: eqs, occs, apps)
   7.349 +    | NONE => (eqs, app :: occs, put_app rp app apps))
   7.350 +  end
   7.351 +
   7.352 +(*
   7.353 +  comment missing
   7.354 +*)
   7.355 +
   7.356 +fun add_lits (Argo_Lit.Pos _, _) = fold (cons o Argo_Lit.Pos)
   7.357 +  | add_lits (Argo_Lit.Neg _, _) = fold (cons o Argo_Lit.Neg)
   7.358 +
   7.359 +fun join_atoms f (Eqs eqs1) (Eqs eqs2) ls = f eqs1 eqs2 ls
   7.360 +  | join_atoms _ (Preds ts1) (Preds ts2) ls = (Preds (union Argo_Term.eq_term ts1 ts2), ls)
   7.361 +  | join_atoms _ (Preds ts) (Cert lp) ls = (Cert lp, add_lits lp ts ls)
   7.362 +  | join_atoms _ (Cert lp) (Preds ts) ls = (Cert lp, add_lits lp ts ls)
   7.363 +  | join_atoms _ (Cert lp) (Cert _) ls = (Cert lp, ls)
   7.364 +  | join_atoms _ _ _ _ = raise Fail "bad atoms"
   7.365 +
   7.366 +(*
   7.367 +  comment missing
   7.368 +*)
   7.369 +
   7.370 +fun join r1 ri1 r2 ri2 eq (eqs, ls, {repr, rdata, apps, trace, prf, back}: context) =
   7.371 +  let
   7.372 +    val {size=size1, class=class1, occs=occs1, neqs=neqs1, atoms=atoms1}: ritem = ri1
   7.373 +    val {size=size2, class=class2, occs=occs2, neqs=neqs2, atoms=atoms2}: ritem = ri2
   7.374 +
   7.375 +    val repr = fold (fn t => put_repr t r1) class2 repr
   7.376 +    val class = fold cons class2 class1
   7.377 +    val (eqs, occs, apps) = fold (copy_occ repr) occs2 (eqs, occs1, apps)
   7.378 +    val trace = add_edge eq trace
   7.379 +    val neqs = AList.merge Argo_Term.eq_term (K true) (neqs1, neqs2)
   7.380 +    fun add r neqs = fold (add_implied Argo_Lit.Pos repr rdata r neqs)
   7.381 +    fun adds eqs1 eqs2 ls = ([], ls) |> add r2 neqs2 eqs1 |> add r1 neqs1 eqs2 |>> Eqs
   7.382 +    val (atoms, ls) = join_atoms adds atoms1 atoms2 ls
   7.383 +    (* TODO: make sure that all implied literals are propagated *)
   7.384 +    val rdata = put_ritem r1 (mk_ritem (size1 + size2) class occs neqs atoms) rdata
   7.385 +  in (eqs, ls, mk_context repr rdata apps trace prf back) end
   7.386 +
   7.387 +(*
   7.388 +  comment missing
   7.389 +*)
   7.390 +
   7.391 +fun find_neq ({repr, ...}: context) ({neqs, ...}: ritem) r = find_first (same_repr repr r) neqs
   7.392 +
   7.393 +fun check_join (r1, r2) (ri1, ri2) eq (ecx as (_, _, cx)) =
   7.394 +  (case find_neq cx ri2 r1 of
   7.395 +    SOME (_, eq') => raise CONFLICT (explain_neq (negate (symm eq)) eq' cx)
   7.396 +  | NONE =>
   7.397 +      (case find_neq cx ri1 r2 of
   7.398 +        SOME (_, eq') => raise CONFLICT (explain_neq (negate eq) eq' cx)
   7.399 +      | NONE => join r1 ri1 r2 ri2 eq ecx))
   7.400 +
   7.401 +(*
   7.402 +  comment missing
   7.403 +*)
   7.404 +
   7.405 +fun with_max_class f (rp as (r1, r2)) (rip as (ri1: ritem, ri2: ritem)) eq =
   7.406 +  if #size ri1 >= #size ri2 then f rp rip eq else f (r2, r1) (ri2, ri1) (symm eq)
   7.407 +
   7.408 +(*
   7.409 +  comment missing
   7.410 +*)
   7.411 +
   7.412 +fun propagate ([], ls, cx) = (rev ls, cx)
   7.413 +  | propagate (eq :: eqs, ls, cx) =
   7.414 +      let val rp = apply2 (repr_of' cx) (dest_eq eq)
   7.415 +      in 
   7.416 +        if Argo_Term.eq_term rp then propagate (eqs, ls, cx)
   7.417 +        else propagate (with_max_class check_join rp (apply2 (ritem_of' cx) rp) eq (eqs, ls, cx))
   7.418 +      end
   7.419 +
   7.420 +fun without lit (lits, cx) = (Argo_Common.Implied (remove Argo_Lit.eq_lit lit lits), cx)
   7.421 +
   7.422 +fun flat_merge (lp as (lit, _)) eq cx = without lit (propagate ([Flat (lp, eq)], [], cx))
   7.423 +  handle CONFLICT (cls, cx) => (Argo_Common.Conflict cls, cx)
   7.424 +
   7.425 +(*
   7.426 +  comment missing
   7.427 +*)
   7.428 +
   7.429 +fun app_merge app tp (cx as {repr, rdata, apps, trace, prf, back}: context) =
   7.430 +  let val rp as (r1, r2) = apply2 (repr_of repr) tp
   7.431 +  in
   7.432 +    (case lookup_app apps rp of
   7.433 +      SOME app' =>
   7.434 +        (case propagate ([Cong (app, app')], [], cx) of
   7.435 +          ([], cx) => cx
   7.436 +        | _ => raise Fail "bad application merge")
   7.437 +    | NONE =>
   7.438 +        let val rdata = add_occ r1 app (add_occ r2 app rdata)
   7.439 +        in mk_context repr rdata (put_app rp app apps) trace prf back end)
   7.440 +  end
   7.441 +
   7.442 +(*
   7.443 +  A negated equality between t1 and t2 is only recorded if t1 and t2 are not already known
   7.444 +  to belong to the same class. In that case, a conflict is raised with an explanation
   7.445 +  why t1 and t2 are equal. Otherwise, the classes of t1 and t2 are marked as disjoint by
   7.446 +  storing the negated equality in the ritems of t1's and t2's representative. All equalities
   7.447 +  between terms of t1's and t2's class are implied as negated equalities. Those equalities
   7.448 +  are found in the ritems of t1's and t2's representative.
   7.449 +*)
   7.450 +
   7.451 +fun note_neq eq (r1, r2) (t1, t2) ({repr, rdata, apps, trace, prf, back}: context) =
   7.452 +  let
   7.453 +    val {size=size1, class=class1, occs=occs1, neqs=neqs1, atoms=atoms1}: ritem = ritem_of rdata r1
   7.454 +    val {size=size2, class=class2, occs=occs2, neqs=neqs2, atoms=atoms2}: ritem = ritem_of rdata r2
   7.455 +
   7.456 +    fun add r (Eqs eqs) ls = fold (add_implied Argo_Lit.Neg repr rdata r []) eqs ([], ls) |>> Eqs
   7.457 +      | add _ _ _ = raise Fail "bad negated equality between predicates"
   7.458 +    val ((atoms1, atoms2), ls) = [] |> add r2 atoms1 ||>> add r1 atoms2
   7.459 +    val ri1 = mk_ritem size1 class1 occs1 ((t2, eq) :: neqs1) atoms1
   7.460 +    val ri2 = mk_ritem size2 class2 occs2 ((t1, symm eq) :: neqs2) atoms2
   7.461 +  in (ls, mk_context repr (put_ritem r1 ri1 (put_ritem r2 ri2 rdata)) apps trace prf back) end
   7.462 +
   7.463 +fun flat_neq (lp as (lit, _)) (tp as (t1, t2)) cx =
   7.464 +  let val rp = apply2 (repr_of' cx) tp
   7.465 +  in
   7.466 +    if Argo_Term.eq_term rp then
   7.467 +      let val (cls, cx) = explain_eq (Argo_Lit.negate lit) t1 t2 cx
   7.468 +      in (Argo_Common.Conflict cls, cx) end
   7.469 +    else without lit (note_neq (Flat (lp, tp)) rp tp cx)
   7.470 +  end
   7.471 +
   7.472 +
   7.473 +(* simplification *)
   7.474 +
   7.475 +(*
   7.476 +  Only equalities are subject to normalizations. An equality between two expressions e1 and e2
   7.477 +  is normalized, if e1 is less than e2 based on the expression ordering. If e1 and e2 are
   7.478 +  syntactically equal, the equality between these two expressions is normalized to the true
   7.479 +  expression.
   7.480 +*)
   7.481 +
   7.482 +fun norm_eq env =
   7.483 +  let val e1 = Argo_Rewr.get env 1 and e2 = Argo_Rewr.get env 2
   7.484 +  in
   7.485 +    (case Argo_Expr.expr_ord (e1, e2) of
   7.486 +      EQUAL => SOME (Argo_Proof.Rewr_Eq_Refl, Argo_Rewr.E Argo_Expr.true_expr)
   7.487 +    | LESS => NONE
   7.488 +    | GREATER => SOME (Argo_Proof.Rewr_Eq_Symm, Argo_Rewr.E (Argo_Expr.mk_eq e2 e1)))
   7.489 +  end
   7.490 +
   7.491 +val simplify = Argo_Rewr.func "(eq (? 1) (? 2))" norm_eq
   7.492 +
   7.493 +
   7.494 +(* declaring atoms *)
   7.495 +
   7.496 +(*
   7.497 +  Only a genuinely new equality term t for the equality "t1 = t2" is added. If t1 and t2 belong
   7.498 +  to the same equality class or if the classes of t1 and t2 are known to be disjoint, the
   7.499 +  respective literal is returned together with an unmodified context.
   7.500 +*)
   7.501 +
   7.502 +fun add_eq_term t t1 t2 (rp as (r1, r2)) (cx as {repr, rdata, apps, trace, prf, back}: context) =
   7.503 +  if Argo_Term.eq_term rp then (SOME (Argo_Lit.Pos t), cx)
   7.504 +  else if is_some (find_neq cx (ritem_of rdata r1) r2) then (SOME (Argo_Lit.Neg t), cx)
   7.505 +  else
   7.506 +    let val rdata = add_eq_atom r1 (t2, t) (add_eq_atom r2 (t1, t) rdata)
   7.507 +    in (NONE, mk_context repr rdata apps trace prf back) end
   7.508 +
   7.509 +(*
   7.510 +  Only a genuinely new predicate t, which is an application "t1 t2", is added.
   7.511 +  If there is a predicate that is known to be congruent to the representatives of t1 and t2,
   7.512 +  and that predicate or its negation has already been assummed, the respective literal of t
   7.513 +  is returned together with an unmodified context.
   7.514 +*)
   7.515 +
   7.516 +fun add_pred_term t rp (cx as {repr, rdata, apps, trace, prf, back}: context) =
   7.517 +  (case lookup_app apps rp of
   7.518 +    NONE => (NONE, mk_context repr (put_ritem t (as_pred_ritem t) rdata) apps trace prf back)
   7.519 +  | SOME app =>
   7.520 +      (case `(ritem_of_pred rdata) (repr_of repr app) of
   7.521 +        ({atoms=Cert (Argo_Lit.Pos _, _), ...}: ritem, _) => (SOME (Argo_Lit.Pos t), cx)
   7.522 +      | ({atoms=Cert (Argo_Lit.Neg _, _), ...}: ritem, _) => (SOME (Argo_Lit.Neg t), cx)
   7.523 +      | (ri as {atoms=Preds ts, ...}: ritem, r) =>
   7.524 +          let val rdata = put_ritem r (put_atoms (Preds (t :: ts)) ri) rdata
   7.525 +          in (NONE, mk_context repr rdata apps trace prf back) end
   7.526 +      | ({atoms=Eqs _, ...}: ritem, _) => raise Fail "bad predicate"))
   7.527 +
   7.528 +(*
   7.529 +  For each term t that is an application "t1 t2", the reflexive equality t = t1 t2 is added
   7.530 +  to the context. This is required for propagations of congruences.
   7.531 +*)
   7.532 +
   7.533 +fun flatten (t as Argo_Term.T (_, Argo_Expr.App, [t1, t2])) cx =
   7.534 +      flatten t1 (flatten t2 (app_merge t (t1, t2) cx))
   7.535 +  | flatten _ cx = cx
   7.536 +
   7.537 +(*
   7.538 +  Atoms to be added to the context must either be an equality "t1 = t2" or
   7.539 +  an application "t1 t2" (a predicate). Besides adding the equality or the application,
   7.540 +  reflexive equalities for for all applications in the terms t1 and t2 are added.
   7.541 +*)
   7.542 +
   7.543 +fun add_atom (t as Argo_Term.T (_, Argo_Expr.Eq, [t1, t2])) cx =
   7.544 +      add_eq_term t t1 t2 (apply2 (repr_of' cx) (t1, t2)) (flatten t1 (flatten t2 cx))
   7.545 +  | add_atom (t as Argo_Term.T (_, Argo_Expr.App, [t1, t2])) cx =
   7.546 +      let val cx = flatten t1 (flatten t2 (app_merge t (t1, t2) cx))
   7.547 +      in add_pred_term t (apply2 (repr_of' cx) (t1, t2)) cx end
   7.548 +  | add_atom _ cx = (NONE, cx)
   7.549 +
   7.550 +
   7.551 +(* assuming external knowledge *)
   7.552 +
   7.553 +(*
   7.554 +  Assuming a predicate r replaces all predicate atoms of r's ritem with the assumed certificate.
   7.555 +  The predicate atoms are implied, either with positive or with negative polarity based on
   7.556 +  the assumption.
   7.557 +
   7.558 +  There must not be a certificate for r since otherwise r would have been assumed before already.
   7.559 +*)
   7.560 +
   7.561 +fun assume_pred lit mk_lit cert r ({repr, rdata, apps, trace, prf, back}: context) =
   7.562 +  (case ritem_of_pred rdata r of
   7.563 +    {size, class, occs, neqs, atoms=Preds ts}: ritem =>
   7.564 +      let val rdata = put_ritem r (mk_ritem size class occs neqs cert) rdata
   7.565 +      in without lit (map mk_lit ts, mk_context repr rdata apps trace prf back) end
   7.566 +  | _ => raise Fail "bad predicate assumption")
   7.567 +
   7.568 +(*
   7.569 +  Assumed equalities "t1 = t2" are treated as flat equalities between terms t1 and t2.
   7.570 +  If t1 and t2 are applications, congruences are propagated as part of the merge between t1 and t2.
   7.571 +  Negated equalities are handled likewise.
   7.572 +
   7.573 +  Assumed predicates do not trigger congruences. Only predicates of the same class are implied.
   7.574 +*)
   7.575 +
   7.576 +fun assume (lp as (Argo_Lit.Pos (Argo_Term.T (_, Argo_Expr.Eq, [t1, t2])), _)) cx =
   7.577 +      flat_merge lp (t1, t2) cx
   7.578 +  | assume (lp as (Argo_Lit.Neg (Argo_Term.T (_, Argo_Expr.Eq, [t1, t2])), _)) cx =
   7.579 +      flat_neq lp (t1, t2) cx
   7.580 +  | assume (lp as (lit as Argo_Lit.Pos (t as Argo_Term.T (_, Argo_Expr.App, [_, _])), _)) cx =
   7.581 +      assume_pred lit Argo_Lit.Pos (Cert lp) (repr_of' cx t) cx
   7.582 +  | assume (lp as (lit as Argo_Lit.Neg (t as Argo_Term.T (_, Argo_Expr.App, [_, _])), _)) cx =
   7.583 +      assume_pred lit Argo_Lit.Neg (Cert lp) (repr_of' cx t) cx
   7.584 +  | assume _ cx = (Argo_Common.Implied [], cx)
   7.585 +
   7.586 +
   7.587 +(* checking for consistency and pending implications *)
   7.588 +
   7.589 +(*
   7.590 +  The internal model is always kept consistent. All implications are propagated as soon as
   7.591 +  new information is assumed. Hence, there is nothing to be done here.
   7.592 +*)
   7.593 +
   7.594 +fun check cx = (Argo_Common.Implied [], cx)
   7.595 +
   7.596 +
   7.597 +(* explanations *)
   7.598 +
   7.599 +(*
   7.600 +  The explanation for the predicate t, which is an application of t1 and t2, is constructed
   7.601 +  from the explanation of the predicate application "u1 u2" as well as the equalities "u1 = t1"
   7.602 +  and "u2 = t2" which both are constructed from the proof forest. The substitution rule is
   7.603 +  the proof step that concludes "t1 t2" from "u1 u2" and the two equalities "u1 = t1"
   7.604 +  and "u2 = t2".
   7.605 +
   7.606 +  The atoms part of the ritem of t's representative must be a certificate of an already
   7.607 +  assumed predicate for otherwise there would be no explanation for t.
   7.608 +*)
   7.609 +
   7.610 +fun explain_pred lit t t1 t2 ({repr, rdata, apps, trace, prf, back}: context) =
   7.611 +  (case ritem_of_pred rdata (repr_of repr t) of
   7.612 +    {atoms=Cert (cert as (lit', _)), ...}: ritem =>
   7.613 +      let
   7.614 +        val (u1, u2) = dest_app (Argo_Lit.term_of lit')
   7.615 +        val (lits, (p, prf)) = proof_of cert [] prf
   7.616 +        val (lits, (p1, prf)) = mk_eq_proof trace u1 t1 lits prf
   7.617 +        val (lits, (p2, prf)) = mk_eq_proof trace u2 t2 lits prf
   7.618 +        val (lits, (p, prf)) = Argo_Proof.mk_subst p p1 p2 prf |> close_proof lit lits
   7.619 +      in ((lits, p), mk_context repr rdata apps trace prf back) end
   7.620 +  | _ => raise Fail "no explanation for bad predicate")
   7.621 +
   7.622 +(*
   7.623 +  Explanations are produced based on the proof forest that is constructed while assuming new
   7.624 +  information and propagating this among the internal data structures.
   7.625 +  
   7.626 +  For predicates, no distinction between both polarities needs to be done here. The atoms
   7.627 +  part of the relevant ritem knows the assumed polarity.
   7.628 +*)
   7.629 +
   7.630 +fun explain (lit as Argo_Lit.Pos (Argo_Term.T (_, Argo_Expr.Eq, [t1, t2]))) cx =
   7.631 +      SOME (explain_eq lit t1 t2 cx)
   7.632 +  | explain (lit as Argo_Lit.Neg (Argo_Term.T (_, Argo_Expr.Eq, [t1, t2]))) cx =
   7.633 +      let val (_, eq) = the (find_neq cx (ritem_of' cx (repr_of' cx t1)) (repr_of' cx t2))
   7.634 +      in SOME (explain_neq (Flat ((lit, NONE), (t1, t2))) eq cx) end
   7.635 +  | explain (lit as (Argo_Lit.Pos (t as Argo_Term.T (_, Argo_Expr.App, [t1, t2])))) cx =
   7.636 +      SOME (explain_pred lit t t1 t2 cx)
   7.637 +  | explain (lit as (Argo_Lit.Neg (t as Argo_Term.T (_, Argo_Expr.App, [t1, t2])))) cx =
   7.638 +      SOME (explain_pred lit t t1 t2 cx)
   7.639 +  | explain _ _ = NONE
   7.640 +
   7.641 +
   7.642 +(* backtracking *)
   7.643 +
   7.644 +(*
   7.645 +  All information that needs to be reconstructed on backtracking is stored on the backtracking
   7.646 +  stack. On backtracking any current information is replaced by what was stored before. No copying
   7.647 +  nor subtle updates are required thanks to immutable data structures.
   7.648 +*)
   7.649 +
   7.650 +fun add_level ({repr, rdata, apps, trace, prf, back}: context) =
   7.651 +  mk_context repr rdata apps trace prf ((repr, rdata, apps, trace) :: back)
   7.652 +
   7.653 +fun backtrack ({back=[], ...}: context) = raise Empty
   7.654 +  | backtrack ({prf, back=(repr, rdata, apps, trace) :: back, ...}: context) =
   7.655 +      mk_context repr rdata apps trace prf back
   7.656 +
   7.657 +end
     8.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     8.2 +++ b/src/Tools/Argo/argo_cdcl.ML	Thu Sep 29 20:54:44 2016 +0200
     8.3 @@ -0,0 +1,477 @@
     8.4 +(*  Title:      Tools/Argo/argo_cdcl.ML
     8.5 +    Author:     Sascha Boehme
     8.6 +
     8.7 +Propositional satisfiability solver in the style of conflict-driven
     8.8 +clause-learning (CDCL). It features:
     8.9 +
    8.10 + * conflict analysis and clause learning based on the first unique implication point
    8.11 + * nonchronological backtracking
    8.12 + * dynamic variable ordering (VSIDS)
    8.13 + * restarting
    8.14 + * polarity caching
    8.15 + * propagation via two watched literals
    8.16 + * special propagation of binary clauses 
    8.17 + * minimizing learned clauses
    8.18 + * support for external knowledge
    8.19 +
    8.20 +These features might be added:
    8.21 +
    8.22 + * pruning of unnecessary learned clauses
    8.23 + * rebuilding the variable heap
    8.24 + * aligning the restart level with the decision heuristics: keep decisions that would
    8.25 +   be recovered instead of backjumping to level 0
    8.26 +
    8.27 +The implementation is inspired by:
    8.28 +
    8.29 +  Niklas E'en and Niklas S"orensson. An Extensible SAT-solver. In Enrico
    8.30 +  Giunchiglia and Armando Tacchella, editors, Theory and Applications of
    8.31 +  Satisfiability Testing. Volume 2919 of Lecture Notes in Computer
    8.32 +  Science, pages 502-518. Springer, 2003.
    8.33 +
    8.34 +  Niklas S"orensson and Armin Biere. Minimizing Learned Clauses. In
    8.35 +  Oliver Kullmann, editor, Theory and Applications of Satisfiability
    8.36 +  Testing. Volume 5584 of Lecture Notes in Computer Science,
    8.37 +  pages 237-243. Springer, 2009.
    8.38 +*)
    8.39 +
    8.40 +signature ARGO_CDCL =
    8.41 +sig
    8.42 +  (* types *)
    8.43 +  type 'a explain = Argo_Lit.literal -> 'a -> Argo_Cls.clause * 'a
    8.44 +
    8.45 +  (* context *)
    8.46 +  type context
    8.47 +  val context: context
    8.48 +  val assignment_of: context -> Argo_Lit.literal -> bool option
    8.49 +
    8.50 +  (* enriching the context *)
    8.51 +  val add_atom: Argo_Term.term -> context -> context
    8.52 +  val add_axiom: Argo_Cls.clause -> context -> int * context
    8.53 +
    8.54 +  (* main operations *)
    8.55 +  val assume: 'a explain -> Argo_Lit.literal -> context -> 'a ->
    8.56 +    Argo_Cls.clause option * context * 'a
    8.57 +  val propagate: context -> Argo_Common.literal Argo_Common.implied * context
    8.58 +  val decide: context -> context option
    8.59 +  val analyze: 'a explain -> Argo_Cls.clause -> context -> 'a -> int * context * 'a
    8.60 +  val restart: context -> int * context
    8.61 +end
    8.62 +
    8.63 +structure Argo_Cdcl: ARGO_CDCL =
    8.64 +struct
    8.65 +
    8.66 +(* basic types and operations *)
    8.67 +
    8.68 +type 'a explain = Argo_Lit.literal -> 'a -> Argo_Cls.clause * 'a
    8.69 +
    8.70 +datatype reason =
    8.71 +  Level0 of Argo_Proof.proof |
    8.72 +  Decided of int * int * (bool * reason) Argo_Termtab.table |
    8.73 +  Implied of int * int * (Argo_Lit.literal * reason) list * Argo_Proof.proof |
    8.74 +  External of int
    8.75 +
    8.76 +fun level_of (Level0 _) = 0
    8.77 +  | level_of (Decided (l, _, _)) = l
    8.78 +  | level_of (Implied (l, _, _, _)) = l
    8.79 +  | level_of (External l) = l
    8.80 +
    8.81 +type justified = Argo_Lit.literal * reason
    8.82 +
    8.83 +type watches = Argo_Cls.clause list * Argo_Cls.clause list
    8.84 +
    8.85 +fun get_watches wts t = Argo_Termtab.lookup wts t
    8.86 +fun map_watches f t wts = Argo_Termtab.map_default (t, ([], [])) f wts
    8.87 +
    8.88 +fun map_lit_watches f (Argo_Lit.Pos t) = map_watches (apsnd f) t
    8.89 +  | map_lit_watches f (Argo_Lit.Neg t) = map_watches (apfst f) t
    8.90 +
    8.91 +fun watches_of wts (Argo_Lit.Pos t) = (case get_watches wts t of SOME (ws, _) => ws | NONE => [])
    8.92 +  | watches_of wts (Argo_Lit.Neg t) = (case get_watches wts t of SOME (_, ws) => ws | NONE => [])
    8.93 +
    8.94 +fun attach cls lit = map_lit_watches (cons cls) lit
    8.95 +fun detach cls lit = map_lit_watches (remove Argo_Cls.eq_clause cls) lit
    8.96 +
    8.97 +
    8.98 +(* literal values *)
    8.99 +
   8.100 +fun raw_val_of vals lit = Argo_Termtab.lookup vals (Argo_Lit.term_of lit)
   8.101 +
   8.102 +fun val_of vals (Argo_Lit.Pos t) = Argo_Termtab.lookup vals t
   8.103 +  | val_of vals (Argo_Lit.Neg t) = Option.map (apfst not) (Argo_Termtab.lookup vals t)
   8.104 +
   8.105 +fun value_of vals (Argo_Lit.Pos t) = Option.map fst (Argo_Termtab.lookup vals t)
   8.106 +  | value_of vals (Argo_Lit.Neg t) = Option.map (not o fst) (Argo_Termtab.lookup vals t)
   8.107 +
   8.108 +fun justified vals lit = Option.map (pair lit o snd) (raw_val_of vals lit)
   8.109 +fun the_reason_of vals lit = snd (the (raw_val_of vals lit))
   8.110 +
   8.111 +fun assign (Argo_Lit.Pos t) r = Argo_Termtab.update (t, (true, r))
   8.112 +  | assign (Argo_Lit.Neg t) r = Argo_Termtab.update (t, (false, r))
   8.113 +
   8.114 +
   8.115 +(* context *)
   8.116 +
   8.117 +type trail = int * justified list (* the trail height and the sequence of assigned literals *)
   8.118 +
   8.119 +type context = {
   8.120 +  units: Argo_Common.literal list, (* the literals that await propagation *)
   8.121 +  level: int, (* the decision level *)
   8.122 +  trail: int * justified list, (* the trail height and the sequence of assigned literals *)
   8.123 +  vals: (bool * reason) Argo_Termtab.table, (* mapping of terms to polarity and reason *)
   8.124 +  wts: watches Argo_Termtab.table, (* clauses watched by terms *)
   8.125 +  heap: Argo_Heap.heap, (* max-priority heap for decision heuristics *)
   8.126 +  clss: Argo_Cls.table, (* information about clauses *)
   8.127 +  prf: Argo_Proof.context} (* the proof context *)
   8.128 +
   8.129 +fun mk_context units level trail vals wts heap clss prf: context =
   8.130 +  {units=units, level=level, trail=trail, vals=vals, wts=wts, heap=heap, clss=clss, prf=prf}
   8.131 +
   8.132 +val context =
   8.133 +  mk_context [] 0 (0, []) Argo_Termtab.empty Argo_Termtab.empty Argo_Heap.heap
   8.134 +    Argo_Cls.table Argo_Proof.cdcl_context
   8.135 +
   8.136 +fun drop_levels n (Decided (l, h, vals)) trail heap =
   8.137 +      if l = n + 1 then ((h, trail), vals, heap) else drop_literal n trail heap
   8.138 +  | drop_levels n _ tr heap = drop_literal n tr heap
   8.139 +
   8.140 +and drop_literal n ((lit, r) :: trail) heap = drop_levels n r trail (Argo_Heap.insert lit heap)
   8.141 +  | drop_literal _ [] _ = raise Fail "bad trail"
   8.142 +
   8.143 +fun backjump_to new_level (cx as {level, trail=(_, tr), wts, heap, clss, prf, ...}: context) =
   8.144 +  if new_level >= level then (0, cx)
   8.145 +  else
   8.146 +    let val (trail, vals, heap) = drop_literal (Integer.max 0 new_level) tr heap
   8.147 +    in (level - new_level, mk_context [] new_level trail vals wts heap clss prf) end
   8.148 +
   8.149 +
   8.150 +(* proofs *)
   8.151 +
   8.152 +fun tag_clause (lits, p) prf = Argo_Proof.mk_clause lits p prf |>> pair lits
   8.153 +
   8.154 +fun level0_unit_proof (lit, Level0 p') (p, prf) = Argo_Proof.mk_unit_res lit p p' prf
   8.155 +  | level0_unit_proof _ _ = raise Fail "bad reason"
   8.156 +
   8.157 +fun level0_unit_proofs lrs p prf = fold level0_unit_proof lrs (p, prf)
   8.158 +
   8.159 +fun unsat ({vals, prf, ...}: context) (lits, p) =
   8.160 +  let val lrs = map (fn lit => (lit, the_reason_of vals lit)) lits
   8.161 +  in Argo_Proof.unsat (fst (level0_unit_proofs lrs p prf)) end
   8.162 +
   8.163 +
   8.164 +(* literal operations *)
   8.165 +
   8.166 +fun push lit p reason prf ({units, level, trail=(h, tr), vals, wts, heap, clss, ...}: context) =
   8.167 +  let val vals = assign lit reason vals
   8.168 +  in mk_context ((lit, p) :: units) level (h + 1, (lit, reason) :: tr) vals wts heap clss prf end
   8.169 +
   8.170 +fun push_level0 lit p lrs (cx as {prf, ...}: context) =
   8.171 +  let val (p, prf) = level0_unit_proofs lrs p prf
   8.172 +  in push lit (SOME p) (Level0 p) prf cx end
   8.173 +
   8.174 +fun push_implied lit p lrs (cx as {level, trail=(h, _), prf, ...}: context) =
   8.175 +  if level > 0 then push lit NONE (Implied (level, h, lrs, p)) prf cx
   8.176 +  else push_level0 lit p lrs cx
   8.177 +
   8.178 +fun push_decided lit (cx as {level, trail=(h, _), vals, prf, ...}: context) =
   8.179 +  push lit NONE (Decided (level, h, vals)) prf cx
   8.180 +
   8.181 +fun assignment_of ({vals, ...}: context) = value_of vals
   8.182 +
   8.183 +fun replace_watches old new cls ({units, level, trail, vals, wts, heap, clss, prf}: context) =
   8.184 +  mk_context units level trail vals (attach cls new (detach cls old wts)) heap clss prf
   8.185 +
   8.186 +
   8.187 +(* clause operations *)
   8.188 +
   8.189 +fun as_clause cls ({units, level, trail, vals, wts, heap, clss, prf}: context) =
   8.190 +  let val (cls, prf) = tag_clause cls prf
   8.191 +  in (cls, mk_context units level trail vals wts heap clss prf) end
   8.192 +
   8.193 +fun note_watches ([_, _], _) _ clss = clss
   8.194 +  | note_watches cls lp clss = Argo_Cls.put_watches cls lp clss
   8.195 +
   8.196 +fun attach_clause lit1 lit2 (cls as (lits, _)) cx =
   8.197 +  let
   8.198 +    val {units, level, trail, vals, wts, heap, clss, prf}: context = cx
   8.199 +    val wts = attach cls lit1 (attach cls lit2 wts)
   8.200 +    val clss = note_watches cls (lit1, lit2) clss
   8.201 +  in mk_context units level trail vals wts (fold Argo_Heap.count lits heap) clss prf end
   8.202 +
   8.203 +fun change_watches _ (false, _, _) cx = cx
   8.204 +  | change_watches cls (true, l1, l2) ({units, level, trail, vals, wts, heap, clss, prf}: context) =
   8.205 +      mk_context units level trail vals wts heap (Argo_Cls.put_watches cls (l1, l2) clss) prf
   8.206 +
   8.207 +fun add_asserting lit lit' (cls as (_, p)) lrs cx =
   8.208 +  attach_clause lit lit' cls (push_implied lit p lrs cx)
   8.209 +
   8.210 +(*
   8.211 +  When learning a non-unit clause, the context is backtracked to the highest decision level
   8.212 +  of the assigned literals.
   8.213 +*)
   8.214 +
   8.215 +fun learn_clause _ ([lit], p) cx = backjump_to 0 cx ||> push_level0 lit p []
   8.216 +  | learn_clause lrs (cls as (lits, _)) cx =
   8.217 +      let
   8.218 +        fun max_level (l, r) (ll as (_, lvl)) = if level_of r > lvl then (l, level_of r) else ll
   8.219 +        val (lit, lvl) = fold max_level lrs (hd lits, 0)
   8.220 +      in backjump_to lvl cx ||> add_asserting (hd lits) lit cls lrs end
   8.221 +
   8.222 +(*
   8.223 +  An axiom with one unassigned literal and all remaining literals being assigned to
   8.224 +  false is asserting. An axiom with all literals assigned to false on level 0 makes the
   8.225 +  context unsatisfiable. An axiom with all literals assigned to false on higher levels
   8.226 +  causes backjumping before the highest level, and then the axiom might be asserting if
   8.227 +  only one literal is unassigned on that level.
   8.228 +*)
   8.229 +
   8.230 +fun min lit i NONE = SOME (lit, i)
   8.231 +  | min lit i (SOME (lj as (_, j))) = SOME (if i < j then (lit, i) else lj)
   8.232 +
   8.233 +fun level_ord ((_, r1), (_, r2)) = int_ord (level_of r2, level_of r1)
   8.234 +fun add_max lr lrs = Ord_List.insert level_ord lr lrs
   8.235 +
   8.236 +fun part [] [] t us fs = (t, us, fs)
   8.237 +  | part (NONE :: vs) (l :: ls) t us fs = part vs ls t (l :: us) fs
   8.238 +  | part (SOME (true, r) :: vs) (l :: ls) t us fs = part vs ls (min l (level_of r) t) us fs
   8.239 +  | part (SOME (false, r) :: vs) (l :: ls) t us fs = part vs ls t us (add_max (l, r) fs)
   8.240 +  | part _ _ _ _ _ = raise Fail "mismatch between values and literals"
   8.241 +
   8.242 +fun backjump_add (lit, r) (lit', r') cls lrs cx =
   8.243 +  let
   8.244 +    val add =
   8.245 +      if level_of r = level_of r' then attach_clause lit lit' cls
   8.246 +      else add_asserting lit lit' cls lrs
   8.247 +  in backjump_to (level_of r - 1) cx ||> add end
   8.248 +
   8.249 +fun analyze_axiom vs (cls as (lits, p), cx) =
   8.250 +  (case part vs lits NONE [] [] of
   8.251 +    (SOME (lit, lvl), [], []) =>
   8.252 +      if lvl > 0 then backjump_to 0 cx ||> push_implied lit p [] else (0, cx)
   8.253 +  | (SOME (lit, lvl), [], (lit', _) :: _) => (0, cx |> (lvl > 0) ? attach_clause lit lit' cls)
   8.254 +  | (SOME (lit, lvl), lit' :: _, _) => (0, cx |> (lvl > 0) ? attach_clause lit lit' cls)
   8.255 +  | (NONE, [], (_, Level0 _) :: _) => unsat cx cls
   8.256 +  | (NONE, [], [(lit, _)]) => backjump_to 0 cx ||> push_implied lit p []
   8.257 +  | (NONE, [], lrs as (lr :: lr' :: _)) => backjump_add lr lr' cls lrs cx
   8.258 +  | (NONE, [lit], []) => backjump_to 0 cx ||> push_implied lit p []
   8.259 +  | (NONE, [lit], lrs as (lit', _) :: _) => (0, add_asserting lit lit' cls lrs cx)
   8.260 +  | (NONE, lit1 :: lit2 :: _, _) => (0, attach_clause lit1 lit2 cls cx)
   8.261 +  | _ => raise Fail "bad clause")
   8.262 +
   8.263 +
   8.264 +(* enriching the context *)
   8.265 +
   8.266 +fun add_atom t ({units, level, trail, vals, wts, heap, clss, prf}: context) =
   8.267 +  let val heap = Argo_Heap.insert (Argo_Lit.Pos t) heap
   8.268 +  in mk_context units level trail vals wts heap clss prf end
   8.269 +
   8.270 +fun add_axiom ([], p) _ = Argo_Proof.unsat p
   8.271 +  | add_axiom (cls as (lits, _)) (cx as {vals, ...}: context) =
   8.272 +      if has_duplicates Argo_Lit.eq_lit lits then raise Fail "clause with duplicate literals"
   8.273 +      else if has_duplicates Argo_Lit.dual_lit lits then (0, cx)
   8.274 +      else analyze_axiom (map (val_of vals) lits) (as_clause cls cx)
   8.275 +
   8.276 +
   8.277 +(* external knowledge *)
   8.278 +
   8.279 +fun assume explain lit (cx as {level, vals, prf, ...}: context) x =
   8.280 +  (case value_of vals lit of
   8.281 +    SOME true => (NONE, cx, x)
   8.282 +  | SOME false => 
   8.283 +      let val (cls, x) = explain lit x
   8.284 +      in if level = 0 then unsat cx cls else (SOME cls, cx, x) end
   8.285 +  | NONE =>
   8.286 +      if level = 0 then
   8.287 +        let val ((lits, p), x) = explain lit x
   8.288 +        in (NONE, push_level0 lit p (map_filter (justified vals) lits) cx, x) end
   8.289 +      else (NONE, push lit NONE (External level) prf cx, x))
   8.290 +
   8.291 +
   8.292 +(* propagation *)
   8.293 +
   8.294 +exception CONFLICT of Argo_Cls.clause * context
   8.295 +
   8.296 +fun order_lits_by lit (l1, l2) =
   8.297 +  if Argo_Lit.eq_id (l1, lit) then (true, l2, l1) else (false, l1, l2)
   8.298 +
   8.299 +fun prop_binary (_, implied_lit, other_lit) (cls as (_, p)) (cx as {level, vals, ...}: context) =
   8.300 +  (case value_of vals implied_lit of
   8.301 +    NONE => push_implied implied_lit p [(other_lit, the_reason_of vals other_lit)] cx
   8.302 +  | SOME true => cx
   8.303 +  | SOME false => if level = 0 then unsat cx cls else raise CONFLICT (cls, cx))
   8.304 +
   8.305 +datatype next = Lit of Argo_Lit.literal | None of justified list
   8.306 +
   8.307 +fun with_non_false f l (SOME (false, r)) lrs = f ((l, r) :: lrs)
   8.308 +  | with_non_false _ l _ _ = Lit l
   8.309 +
   8.310 +fun first_non_false _ _ [] lrs = None lrs
   8.311 +  | first_non_false vals lit (l :: ls) lrs =
   8.312 +      if Argo_Lit.eq_lit (l, lit) then first_non_false vals lit ls lrs
   8.313 +      else with_non_false (first_non_false vals lit ls) l (val_of vals l) lrs
   8.314 +
   8.315 +fun prop_nary (lp as (_, lit1, lit2)) (cls as (lits, p)) (cx as {level, vals, ...}: context) =
   8.316 +  let val v = value_of vals lit1
   8.317 +  in
   8.318 +    if v = SOME true then change_watches cls lp cx
   8.319 +    else
   8.320 +      (case first_non_false vals lit1 lits [] of
   8.321 +        Lit lit2' => change_watches cls (true, lit1, lit2') (replace_watches lit2 lit2' cls cx)
   8.322 +      | None lrs =>
   8.323 +          if v = NONE then push_implied lit1 p lrs (change_watches cls lp cx)
   8.324 +          else if level = 0 then unsat cx cls
   8.325 +          else raise CONFLICT (cls, change_watches cls lp cx))
   8.326 +  end
   8.327 +
   8.328 +fun prop_cls lit (cls as ([l1, l2], _)) cx = prop_binary (order_lits_by lit (l1, l2)) cls cx
   8.329 +  | prop_cls lit cls (cx as {clss, ...}: context) =
   8.330 +      prop_nary (order_lits_by lit (Argo_Cls.get_watches clss cls)) cls cx
   8.331 +
   8.332 +fun prop_lit (lp as (lit, _)) (lps, cx as {wts, ...}: context) =
   8.333 +  (lp :: lps, fold (prop_cls lit) (watches_of wts lit) cx)
   8.334 +
   8.335 +fun prop lps (cx as {units=[], ...}: context) = (Argo_Common.Implied (rev lps), cx)
   8.336 +  | prop lps ({units, level, trail, vals, wts, heap, clss, prf}: context) =
   8.337 +      fold_rev prop_lit units (lps, mk_context [] level trail vals wts heap clss prf) |-> prop
   8.338 +
   8.339 +fun propagate cx = prop [] cx
   8.340 +  handle CONFLICT (cls, cx) => (Argo_Common.Conflict cls, cx)
   8.341 +
   8.342 +
   8.343 +(* decisions *)
   8.344 +
   8.345 +(*
   8.346 +  Decisions are based on an activity heuristics. The most active variable that is
   8.347 +  still unassigned is chosen.
   8.348 +*)
   8.349 +
   8.350 +fun decide ({units, level, trail, vals, wts, heap, clss, prf}: context) =
   8.351 +  let
   8.352 +    fun check NONE = NONE
   8.353 +      | check (SOME (lit, heap)) =
   8.354 +          if Argo_Termtab.defined vals (Argo_Lit.term_of lit) then check (Argo_Heap.extract heap)
   8.355 +          else SOME (push_decided lit (mk_context units (level + 1) trail vals wts heap clss prf))
   8.356 +  in check (Argo_Heap.extract heap) end
   8.357 +
   8.358 +
   8.359 +(* conflict analysis and clause learning *)
   8.360 +
   8.361 +(*
   8.362 +  Learned clauses often contain literals that are redundant, because they are
   8.363 +  subsumed by other literals of the clause. By analyzing the implication graph beyond
   8.364 +  the unique implication point, such redundant literals can be identified and hence
   8.365 +  removed from the learned clause. Only literals occurring in the learned clause and
   8.366 +  their reasons need to be analyzed.
   8.367 +*)
   8.368 +
   8.369 +exception ESSENTIAL of unit
   8.370 +
   8.371 +fun history_ord ((h1, lit1, _), (h2, lit2, _)) =
   8.372 +  if h1 < 0 andalso h2 < 0 then int_ord (apply2 Argo_Lit.signed_id_of (lit1, lit2))
   8.373 +  else int_ord (h2, h1)
   8.374 +
   8.375 +fun rec_redundant stop (lit, Implied (lvl, h, lrs, p)) lps =
   8.376 +      if stop lit lvl then lps
   8.377 +      else fold (rec_redundant stop) lrs ((h, lit, p) :: lps)
   8.378 +  | rec_redundant stop (lit, Decided (lvl, _, _)) lps =
   8.379 +      if stop lit lvl then lps
   8.380 +      else raise ESSENTIAL ()
   8.381 +  | rec_redundant _ (lit, Level0 p) lps = ((~1, lit, p) :: lps)
   8.382 +  | rec_redundant _ _ _ = raise ESSENTIAL ()
   8.383 +
   8.384 +fun redundant stop (lr as (lit, Implied (_, h, lrs, p))) (lps, essential_lrs) = (
   8.385 +      (fold (rec_redundant stop) lrs ((h, lit, p) :: lps), essential_lrs)
   8.386 +      handle ESSENTIAL () => (lps, lr :: essential_lrs))
   8.387 +  | redundant _ lr (lps, essential_lrs) = (lps, lr :: essential_lrs)
   8.388 +
   8.389 +fun resolve_step (_, l, p') (p, prf) = Argo_Proof.mk_unit_res l p p' prf
   8.390 +
   8.391 +fun reduce lrs p prf =
   8.392 +  let
   8.393 +    val lits = map fst lrs
   8.394 +    val levels = fold (insert (op =) o level_of o snd) lrs []
   8.395 +    fun stop lit level =
   8.396 +      if member Argo_Lit.eq_lit lits lit then true
   8.397 +      else if member (op =) levels level then false
   8.398 +      else raise ESSENTIAL ()
   8.399 +
   8.400 +    val (lps, lrs) = fold (redundant stop) lrs ([], [])
   8.401 +  in (lrs, fold resolve_step (sort_distinct history_ord lps) (p, prf)) end
   8.402 +
   8.403 +(*
   8.404 +  Literals that are candidates for the learned lemma are marked and unmarked while
   8.405 +  traversing backwards through the trail. The last remaining marked literal is the first
   8.406 +  unique implication point.
   8.407 +*)
   8.408 +
   8.409 +fun unmark lit ms = remove Argo_Lit.eq_id lit ms
   8.410 +fun marked ms lit = member Argo_Lit.eq_id ms lit
   8.411 +
   8.412 +(*
   8.413 +  Whenever an implication is recorded, the reason for the false literals of the
   8.414 +  asserting clause are known. It is reasonable to store this justification list as part
   8.415 +  of the implication reason. Consequently, the implementation of conflict analysis can
   8.416 +  benefit from this information, which does not need to be re-computed here.
   8.417 +*)
   8.418 +
   8.419 +fun justification_for _ _ _ (Implied (_, _, lrs, p)) x = (lrs, p, x)
   8.420 +  | justification_for explain vals lit (External _) x =
   8.421 +      let val ((lits, p), x) = explain lit x
   8.422 +      in (map_filter (justified vals) lits, p, x) end
   8.423 +  | justification_for _ _ _ _ _ = raise Fail "bad reason"
   8.424 +
   8.425 +fun first_lit pred ((lr as (lit, _)) :: lrs) = if pred lit then (lr, lrs) else first_lit pred lrs
   8.426 +  | first_lit _ _ = raise Empty
   8.427 +
   8.428 +(*
   8.429 +  Beginning from the conflicting clause, the implication graph is traversed to the first
   8.430 +  unique implication point. This breadth-first search is controlled by the topological order of
   8.431 +  the trail, which is traversed backwards. While traversing through the trail, the conflict
   8.432 +  literals of lower levels are collected to form the conflict lemma together with the unique
   8.433 +  implication point. Conflict literals assigned on level 0 are excluded from the conflict lemma.
   8.434 +  Conflict literals assigned on the current level are candidates for the first unique
   8.435 +  implication point.
   8.436 +*)
   8.437 +
   8.438 +fun analyze explain cls (cx as {level, trail, vals, wts, heap, clss, prf, ...}: context) x =
   8.439 +  let
   8.440 +    fun from_clause [] trail ms lrs h p prf x =
   8.441 +          from_trail (first_lit (marked ms) trail) ms lrs h p prf x
   8.442 +      | from_clause ((lit, r) :: clause_lrs) trail ms lrs h p prf x =
   8.443 +          from_reason r lit clause_lrs trail ms lrs h p prf x
   8.444 + 
   8.445 +    and from_reason (Level0 p') lit clause_lrs trail ms lrs h p prf x =
   8.446 +          let val (p, prf) = Argo_Proof.mk_unit_res lit p p' prf
   8.447 +          in from_clause clause_lrs trail ms lrs h p prf x end
   8.448 +      | from_reason r lit clause_lrs trail ms lrs h p prf x =
   8.449 +          if level_of r = level then
   8.450 +            if marked ms lit then from_clause clause_lrs trail ms lrs h p prf x
   8.451 +            else from_clause clause_lrs trail (lit :: ms) lrs (Argo_Heap.increase lit h) p prf x
   8.452 +          else
   8.453 +            let
   8.454 +              val (lrs, h) =
   8.455 +                if AList.defined Argo_Lit.eq_id lrs lit then (lrs, h)
   8.456 +                else ((lit, r) :: lrs, Argo_Heap.increase lit h)
   8.457 +            in from_clause clause_lrs trail ms lrs h p prf x end
   8.458 +
   8.459 +    and from_trail ((lit, _), _) [_] lrs h p prf x =
   8.460 +          let val (lrs, (p, prf)) = reduce lrs p prf
   8.461 +          in (Argo_Lit.negate lit :: map fst lrs, lrs, h, p, prf, x) end
   8.462 +      | from_trail ((lit, r), trail) ms lrs h p prf x =
   8.463 +          let
   8.464 +            val (clause_lrs, p', x) = justification_for explain vals lit r x
   8.465 +            val (p, prf) = Argo_Proof.mk_unit_res lit p' p prf
   8.466 +          in from_clause clause_lrs trail (unmark lit ms) lrs h p prf x end
   8.467 +
   8.468 +    val (ls, p) = cls
   8.469 +    val lrs = if level = 0 then unsat cx cls else map (fn l => (l, the_reason_of vals l)) ls
   8.470 +    val (lits, lrs, heap, p, prf, x) = from_clause lrs (snd trail) [] [] heap p prf x
   8.471 +    val heap = Argo_Heap.decay heap
   8.472 +    val (levels, cx) = learn_clause lrs (lits, p) (mk_context [] level trail vals wts heap clss prf)
   8.473 +  in (levels, cx, x) end
   8.474 +
   8.475 +
   8.476 +(* restarting *)
   8.477 +
   8.478 +fun restart cx = backjump_to 0 cx
   8.479 +
   8.480 +end
     9.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     9.2 +++ b/src/Tools/Argo/argo_clausify.ML	Thu Sep 29 20:54:44 2016 +0200
     9.3 @@ -0,0 +1,168 @@
     9.4 +(*  Title:      Tools/Argo/argo_clausify.ML
     9.5 +    Author:     Sascha Boehme
     9.6 +
     9.7 +Conversion of propositional formulas to definitional CNF.
     9.8 +
     9.9 +The clausification implementation is based on:
    9.10 +
    9.11 +  G. S. Tseitin. On the complexity of derivation in propositional
    9.12 +  calculus.  In A. O. Slisenko (editor) Structures in Constructive
    9.13 +  Mathematics and Mathematical Logic, Part II, Seminars in Mathematics,
    9.14 +  pages 115-125. Steklov Mathematic Institute, 1968.
    9.15 +
    9.16 +  D. A. Plaisted and S. Greenbaum. A Structure-Preserving Clause Form
    9.17 +  Translation. Journal of Symbolic Computation, 1986.
    9.18 +
    9.19 +  L. de Moura and N. Bj\orner. Proofs and Refutations, and Z3. In
    9.20 +  P. Rudnicki and G. Sutcliffe and B. Konev and R. A. Schmidt and
    9.21 +  S. Schulz (editors) International Workshop on the Implementation of
    9.22 +  Logics. CEUR Workshop Proceedings, 2008.
    9.23 +*)
    9.24 +
    9.25 +signature ARGO_CLAUSIFY =
    9.26 +sig
    9.27 +  val clausify: Argo_Rewr.context -> Argo_Expr.expr * Argo_Proof.proof ->
    9.28 +    Argo_Proof.context * Argo_Core.context -> Argo_Proof.context * Argo_Core.context
    9.29 +end
    9.30 +
    9.31 +structure Argo_Clausify: ARGO_CLAUSIFY =
    9.32 +struct
    9.33 +
    9.34 +(* lifting of if-then-else expressions *)
    9.35 +
    9.36 +(*
    9.37 +  It is assumed that expressions are free of if-then-else expressions whose then- and else-branch
    9.38 +  have boolean type. Such if-then-else expressions can be rewritten to expressions using only
    9.39 +  negation, conjunction and disjunction.
    9.40 +
    9.41 +  All other modules treat if-then-else expressions as constant expressions. They do not analyze or
    9.42 +  decend into sub-expressions of an if-then-else expression.
    9.43 +
    9.44 +  Lifting an if-then-else expression (ite P t u) introduces two new clauses
    9.45 +    (or (not P) (= (ite P t u) t)) and
    9.46 +    (or P (= (ite P t u) u))
    9.47 +*)
    9.48 +
    9.49 +fun ite_clause simp k es (eps, (prf, core)) =
    9.50 +  let
    9.51 +    val e = Argo_Expr.mk_or es
    9.52 +    val (p, prf) = Argo_Proof.mk_taut k e prf 
    9.53 +    val (ep, prf) = Argo_Rewr.with_proof (Argo_Rewr.args (Argo_Rewr.rewrite_top simp)) (e, p) prf
    9.54 +  in (ep :: eps, (prf, core)) end
    9.55 +
    9.56 +fun check_ite simp t (e as Argo_Expr.E (Argo_Expr.Ite, [e1, e2, e3])) (eps, (prf, core)) =
    9.57 +      (case Argo_Core.identify (Argo_Term.Term t) core of
    9.58 +        (Argo_Term.Known _, core) => (eps, (prf, core))
    9.59 +      | (Argo_Term.New _, core) =>
    9.60 +          (eps, (prf, core))
    9.61 +          |> ite_clause simp Argo_Proof.Taut_Ite_Then [Argo_Expr.mk_not e1, Argo_Expr.mk_eq e e2]
    9.62 +          |> ite_clause simp Argo_Proof.Taut_Ite_Else [e1, Argo_Expr.mk_eq e e3])
    9.63 +  | check_ite _ _ _ cx = cx
    9.64 +
    9.65 +fun lift_ites simp (t as Argo_Term.T (_, _, ts)) =
    9.66 +  check_ite simp t (Argo_Term.expr_of t) #>
    9.67 +  fold (lift_ites simp) ts
    9.68 +
    9.69 +
    9.70 +(* tagged expressions and terms *)
    9.71 +
    9.72 +fun pos x = (true, x)
    9.73 +fun neg x = (false, x)
    9.74 +
    9.75 +fun mk_lit true t = Argo_Lit.Pos t
    9.76 +  | mk_lit false t = Argo_Lit.Neg t
    9.77 +
    9.78 +fun expr_of (true, t) = Argo_Term.expr_of t
    9.79 +  | expr_of (false, t) = Argo_Expr.mk_not (Argo_Term.expr_of t)
    9.80 +
    9.81 +
    9.82 +(* adding literals *)
    9.83 +
    9.84 +fun lit_for (polarity, x) (new_atoms, core) =
    9.85 +  (case Argo_Core.add_atom x core of
    9.86 +    (Argo_Term.Known t, core) => (mk_lit polarity t, (new_atoms, core))
    9.87 +  | (Argo_Term.New t, core) => (mk_lit polarity t, (t :: new_atoms, core)))
    9.88 +
    9.89 +fun lit_of (Argo_Expr.E (Argo_Expr.Not, [e])) = lit_for (neg (Argo_Term.Expr e))
    9.90 +  | lit_of e = lit_for (pos (Argo_Term.Expr e))
    9.91 +
    9.92 +fun lit_of' (pol, Argo_Term.T (_, Argo_Expr.Not, [t])) = lit_for (not pol, Argo_Term.Term t)
    9.93 +  | lit_of' (pol, t) = lit_for (pol, Argo_Term.Term t)
    9.94 +
    9.95 +
    9.96 +(* adding clauses *)
    9.97 +
    9.98 +fun add_clause f xs p (new_atoms, (prf, core)) =
    9.99 +  let val (lits, (new_atoms, core)) = fold_map f xs (new_atoms, core)
   9.100 +  in (new_atoms, (prf, Argo_Core.add_axiom (lits, p) core)) end
   9.101 +
   9.102 +fun simp_lit (e as Argo_Expr.E (Argo_Expr.Not, [Argo_Expr.E (Argo_Expr.Not, [e'])])) =
   9.103 +      Argo_Rewr.rewr Argo_Proof.Rewr_Not_Not e' e
   9.104 +  | simp_lit e = Argo_Rewr.keep e
   9.105 +
   9.106 +fun simp_clause (e as Argo_Expr.E (Argo_Expr.Or, _)) = Argo_Rewr.args simp_lit e
   9.107 +  | simp_clause e = Argo_Rewr.keep e
   9.108 +
   9.109 +fun new_clause k ls (new_atoms, (prf, core)) =
   9.110 +  let
   9.111 +    val e = Argo_Expr.mk_or (map expr_of ls)
   9.112 +    val (p, prf) = Argo_Proof.mk_taut k e prf
   9.113 +    val ((_, p), prf) = Argo_Rewr.with_proof simp_clause (e, p) prf
   9.114 +  in add_clause lit_of' ls p (new_atoms, (prf, core)) end
   9.115 +
   9.116 +
   9.117 +(* clausifying propositions *)
   9.118 +
   9.119 +fun clausify_and t ts cx =
   9.120 +  let
   9.121 +    val n = length ts
   9.122 +    val k1 = Argo_Proof.Taut_And_1 n and k2 = Argo_Proof.Taut_And_2 o rpair n
   9.123 +  in
   9.124 +    cx
   9.125 +    |> new_clause k1 (pos t :: map neg ts)
   9.126 +    |> fold_index (fn (i, t') => new_clause (k2 i) [neg t, pos t']) ts
   9.127 +  end
   9.128 +
   9.129 +fun clausify_or t ts cx =
   9.130 +  let
   9.131 +    val n = length ts
   9.132 +    val k1 = Argo_Proof.Taut_Or_1 o rpair n and k2 = Argo_Proof.Taut_Or_2 n
   9.133 +  in
   9.134 +    cx
   9.135 +    |> fold_index (fn (i, t') => new_clause (k1 i) [pos t, neg t']) ts
   9.136 +    |> new_clause k2 (neg t :: map pos ts)
   9.137 +  end
   9.138 +
   9.139 +fun clausify_iff t t1 t2 cx =
   9.140 +  cx
   9.141 +  |> new_clause Argo_Proof.Taut_Iff_1 [pos t, pos t1, pos t2]
   9.142 +  |> new_clause Argo_Proof.Taut_Iff_2 [pos t, neg t1, neg t2]
   9.143 +  |> new_clause Argo_Proof.Taut_Iff_3 [neg t, neg t1, pos t2]
   9.144 +  |> new_clause Argo_Proof.Taut_Iff_4 [neg t, pos t1, neg t2]
   9.145 +
   9.146 +fun clausify_lit (t as Argo_Term.T (_, Argo_Expr.And, ts)) = clausify_and t ts
   9.147 +  | clausify_lit (t as Argo_Term.T (_, Argo_Expr.Or, ts)) = clausify_or t ts
   9.148 +  | clausify_lit (t as Argo_Term.T (_, Argo_Expr.Iff, [t1, t2])) = clausify_iff t t1 t2
   9.149 +  | clausify_lit _ = I
   9.150 +
   9.151 +fun exhaust_new_atoms ([], cx) = cx
   9.152 +  | exhaust_new_atoms (t :: new_atoms, cx) = exhaust_new_atoms (clausify_lit t (new_atoms, cx))
   9.153 +
   9.154 +fun clausify_expr _ (Argo_Expr.E (Argo_Expr.True, _), _) cx = cx
   9.155 +  | clausify_expr _ (Argo_Expr.E (Argo_Expr.False, _), p) _ = Argo_Proof.unsat p
   9.156 +  | clausify_expr f (Argo_Expr.E (Argo_Expr.And, es), p) cx =
   9.157 +      fold_index (clausify_conj f (length es) p) es cx
   9.158 +  | clausify_expr f (Argo_Expr.E (Argo_Expr.Or, es), p) cx = add_clausify f es p cx
   9.159 +  | clausify_expr f (e, p) cx = add_clausify f [e] p cx
   9.160 +
   9.161 +and clausify_conj f n p (i, e) (prf, core) =
   9.162 +  let val (p, prf) = Argo_Proof.mk_conj i n p prf
   9.163 +  in clausify_expr f (e, p) (prf, core) end
   9.164 +
   9.165 +and add_clausify f es p cx =
   9.166 +  let val ecx as (new_atoms, _) = add_clause lit_of es p ([], cx)
   9.167 +  in fold f new_atoms ([], exhaust_new_atoms ecx) |-> fold (clausify_expr (K I)) end
   9.168 +
   9.169 +fun clausify simp ep cx = clausify_expr (lift_ites simp) ep cx
   9.170 +
   9.171 +end
    10.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    10.2 +++ b/src/Tools/Argo/argo_cls.ML	Thu Sep 29 20:54:44 2016 +0200
    10.3 @@ -0,0 +1,45 @@
    10.4 +(*  Title:      Tools/Argo/argo_cls.ML
    10.5 +    Author:     Sascha Boehme
    10.6 +
    10.7 +Representation of clauses. Clauses are disjunctions of literals with a proof that explains
    10.8 +why the disjunction holds.
    10.9 +*)
   10.10 +
   10.11 +signature ARGO_CLS =
   10.12 +sig
   10.13 +  type clause = Argo_Lit.literal list * Argo_Proof.proof
   10.14 +  val eq_clause: clause * clause -> bool
   10.15 +
   10.16 +  (* two-literal watches for clauses *)
   10.17 +  type table
   10.18 +  val table: table
   10.19 +  val put_watches: clause -> Argo_Lit.literal * Argo_Lit.literal -> table -> table
   10.20 +  val get_watches: table -> clause -> Argo_Lit.literal * Argo_Lit.literal
   10.21 +end
   10.22 +
   10.23 +structure Argo_Cls: ARGO_CLS =
   10.24 +struct
   10.25 +
   10.26 +type clause = Argo_Lit.literal list * Argo_Proof.proof
   10.27 +
   10.28 +fun eq_clause ((_, p1), (_, p2)) = Argo_Proof.eq_proof_id (apply2 Argo_Proof.id_of (p1, p2))
   10.29 +fun clause_ord ((_, p1), (_, p2)) = Argo_Proof.proof_id_ord (apply2 Argo_Proof.id_of (p1, p2))
   10.30 +
   10.31 +
   10.32 +(* two-literal watches for clauses *)
   10.33 +
   10.34 +(*
   10.35 +  The CDCL solver keeps a mapping of some literals to clauses. Exactly two literals
   10.36 +  of a clause are used to index the clause.
   10.37 +*)
   10.38 +
   10.39 +structure Clstab = Table(type key = clause val ord = clause_ord)
   10.40 +
   10.41 +type table = (Argo_Lit.literal * Argo_Lit.literal) Clstab.table
   10.42 +
   10.43 +val table: table = Clstab.empty
   10.44 +
   10.45 +fun put_watches cls lp table = Clstab.update (cls, lp) table
   10.46 +fun get_watches table cls = the (Clstab.lookup table cls)
   10.47 +
   10.48 +end
    11.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    11.2 +++ b/src/Tools/Argo/argo_common.ML	Thu Sep 29 20:54:44 2016 +0200
    11.3 @@ -0,0 +1,25 @@
    11.4 +(*  Title:      Tools/Argo/argo_common.ML
    11.5 +    Author:     Sascha Boehme
    11.6 +
    11.7 +Common infrastructure for the decision procedures of Argo.
    11.8 +*)
    11.9 +
   11.10 +signature ARGO_COMMON =
   11.11 +sig
   11.12 +  type literal = Argo_Lit.literal * Argo_Proof.proof option
   11.13 +  datatype 'a implied = Implied of 'a list | Conflict of Argo_Cls.clause
   11.14 +end
   11.15 +
   11.16 +structure Argo_Common: ARGO_COMMON =
   11.17 +struct
   11.18 +
   11.19 +type literal = Argo_Lit.literal * Argo_Proof.proof option
   11.20 +  (* Implied new knowledge accompanied with an optional proof. If there is no proof,
   11.21 +     the literal is to be treated hypothetically. If there is a proof, the literal is
   11.22 +     to be treated as uni clause. *)
   11.23 +
   11.24 +datatype 'a implied = Implied of 'a list | Conflict of Argo_Cls.clause
   11.25 +  (* A result of a step of a decision procedure, either an implication of new knowledge
   11.26 +     or clause whose literals are known to be false. *)
   11.27 +
   11.28 +end
    12.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    12.2 +++ b/src/Tools/Argo/argo_core.ML	Thu Sep 29 20:54:44 2016 +0200
    12.3 @@ -0,0 +1,159 @@
    12.4 +(*  Title:      Tools/Argo/argo_core.ML
    12.5 +    Author:     Sascha Boehme
    12.6 +
    12.7 +Core of the Argo theorem prover implementing the DPLL(T) loop.
    12.8 +
    12.9 +The implementation is based on:
   12.10 +
   12.11 +  Harald Ganzinger, George Hagen, Robert Nieuwenhuis, Albert Oliveras,
   12.12 +  Cesare Tinelli. DPLL(T): Fast decision procedures. In Lecture Notes in
   12.13 +  Computer Science, volume 3114, pages 175-188. Springer, 2004.
   12.14 +
   12.15 +  Robert Nieuwenhuis, Albert Oliveras, Cesare Tinelli. Solving SAT and
   12.16 +  SAT modulo theories: From an abstract Davis-Putnam-Logemann-Loveland
   12.17 +  procedure to DPLL(T). In Journal of the ACM, volume 53(6), pages
   12.18 +  937-977.  ACM, 2006.
   12.19 +*)
   12.20 +
   12.21 +signature ARGO_CORE =
   12.22 +sig
   12.23 +  (* context *)
   12.24 +  type context
   12.25 +  val context: context
   12.26 +
   12.27 +  (* enriching the context *)
   12.28 +  val identify: Argo_Term.item -> context -> Argo_Term.identified * context
   12.29 +  val add_atom: Argo_Term.item -> context -> Argo_Term.identified * context
   12.30 +  val add_axiom: Argo_Cls.clause -> context -> context
   12.31 +
   12.32 +  (* DPLL(T) loop *)
   12.33 +  val run: context -> context (* raises Argo_Proof.UNSAT *)
   12.34 +
   12.35 +  (* model *)
   12.36 +  val model_of: context -> string * Argo_Expr.typ -> bool option
   12.37 +end
   12.38 +
   12.39 +structure Argo_Core: ARGO_CORE =
   12.40 +struct
   12.41 +
   12.42 +(* context *)
   12.43 +
   12.44 +type context = {
   12.45 +  terms: Argo_Term.context, (* the term context to identify equal expressions *)
   12.46 +  iter: int, (* the current iteration of the search *)
   12.47 +  cdcl: Argo_Cdcl.context, (* the context of the propositional solver *)
   12.48 +  thy: Argo_Thy.context} (* the context of the theory solver *)
   12.49 +
   12.50 +fun mk_context terms iter cdcl thy: context = {terms=terms, iter=iter, cdcl=cdcl, thy=thy}
   12.51 +
   12.52 +val context = mk_context Argo_Term.context 1 Argo_Cdcl.context Argo_Thy.context
   12.53 +
   12.54 +fun backjump levels = funpow levels Argo_Thy.backtrack
   12.55 +
   12.56 +
   12.57 +(* enriching the context *)
   12.58 +
   12.59 +fun identify i ({terms, iter, cdcl, thy}: context) =
   12.60 +  let val (identified, terms) = Argo_Term.identify_item i terms
   12.61 +  in (identified, mk_context terms iter cdcl thy) end
   12.62 +
   12.63 +fun add_atom i cx =
   12.64 +  (case identify i cx of
   12.65 +    known as (Argo_Term.Known _, _) => known
   12.66 +  | (atom as Argo_Term.New t, {terms, iter, cdcl, thy}: context) =>
   12.67 +      (case (Argo_Cdcl.add_atom t cdcl, Argo_Thy.add_atom t thy) of
   12.68 +        (cdcl, (NONE, thy)) => (atom, mk_context terms iter cdcl thy)
   12.69 +      | (cdcl, (SOME lit, thy)) =>
   12.70 +          (case Argo_Cdcl.assume Argo_Thy.explain lit cdcl thy of
   12.71 +            (NONE, cdcl, thy) => (atom, mk_context terms iter cdcl thy)
   12.72 +          | (SOME _, _, _) => raise Fail "bad conflict with new atom")))
   12.73 +
   12.74 +fun add_axiom cls ({terms, iter, cdcl, thy}: context) =
   12.75 +  let val (levels, cdcl) = Argo_Cdcl.add_axiom cls cdcl
   12.76 +  in mk_context terms iter cdcl (backjump levels thy) end
   12.77 +
   12.78 +
   12.79 +(* DPLL(T) loop: CDCL with theories *)
   12.80 +
   12.81 +datatype implications = None | Implications | Conflict of Argo_Cls.clause
   12.82 +
   12.83 +fun cdcl_assume [] cdcl thy = (NONE, cdcl, thy)
   12.84 +  | cdcl_assume (lit :: lits) cdcl thy =
   12.85 +      (* assume an assignment deduced by the theory solver *)
   12.86 +      (case Argo_Cdcl.assume Argo_Thy.explain lit cdcl thy of
   12.87 +        (NONE, cdcl, thy) => cdcl_assume lits cdcl thy
   12.88 +      | (SOME cls, cdcl, thy) => (SOME cls, cdcl, thy))
   12.89 +
   12.90 +fun theory_deduce _ (conflict as (Conflict _, _, _)) = conflict
   12.91 +  | theory_deduce f (result, cdcl, thy) =
   12.92 +      (case f thy of
   12.93 +        (Argo_Common.Implied [], thy) => (result, cdcl, thy)
   12.94 +      | (Argo_Common.Implied lits, thy) => 
   12.95 +          (* turn all implications of the theory solver into propositional assignments *)
   12.96 +          (case cdcl_assume lits cdcl thy of
   12.97 +            (NONE, cdcl, thy) => (Implications, cdcl, thy)
   12.98 +          | (SOME cls, cdcl, thy) => (Conflict cls, cdcl, thy))
   12.99 +      | (Argo_Common.Conflict cls, thy) => (Conflict cls, cdcl, thy))
  12.100 +
  12.101 +fun theory_assume [] cdcl thy = (None, cdcl, thy)
  12.102 +  | theory_assume lps cdcl thy =
  12.103 +      (None, cdcl, thy)
  12.104 +      (* propagate all propositional implications to the theory solver *)
  12.105 +      |> fold (theory_deduce o Argo_Thy.assume) lps
  12.106 +      (* check the consistency of the theory model *)
  12.107 +      |> theory_deduce Argo_Thy.check
  12.108 +
  12.109 +fun search limit cdcl thy =
  12.110 +  (* collect all propositional implications of the last assignments *)
  12.111 +  (case Argo_Cdcl.propagate cdcl of
  12.112 +    (Argo_Common.Implied lps, cdcl) =>
  12.113 +      (* propagate all propositional implications to the theory solver *)
  12.114 +      (case theory_assume lps cdcl thy of
  12.115 +        (None, cdcl, thy) =>
  12.116 +          (* stop searching if the conflict limit has been exceeded *)
  12.117 +          if limit <= 0 then (false, cdcl, thy)
  12.118 +          else
  12.119 +            (* no further propositional assignments, choose a value for the next unassigned atom *)
  12.120 +            (case Argo_Cdcl.decide cdcl of
  12.121 +              NONE => (true, cdcl, thy) (* the context is satisfiable *)
  12.122 +            | SOME cdcl => search limit cdcl (Argo_Thy.add_level thy))
  12.123 +      | (Implications, cdcl, thy) => search limit cdcl thy
  12.124 +      | (Conflict ([], p), _, _) => Argo_Proof.unsat p
  12.125 +      | (Conflict cls, cdcl, thy) => analyze cls limit cdcl thy)
  12.126 +  | (Argo_Common.Conflict cls, cdcl) => analyze cls limit cdcl thy)
  12.127 +
  12.128 +and analyze cls limit cdcl thy =
  12.129 +  (* analyze the conflict, probably using lazy explanations from the theory solver *)
  12.130 +  let val (levels, cdcl, thy) = Argo_Cdcl.analyze Argo_Thy.explain cls cdcl thy
  12.131 +  in search (limit - 1) cdcl (backjump levels thy) end
  12.132 +
  12.133 +fun luby_number i =
  12.134 +  let
  12.135 +    fun mult p = if p < i + 1 then mult (2 * p) else p
  12.136 +    val p = mult 2
  12.137 +  in if i = p - 1 then p div 2 else luby_number (i - (p div 2) + 1) end
  12.138 +
  12.139 +fun next_restart_limit iter = 100 * luby_number iter
  12.140 +
  12.141 +fun loop iter cdcl thy =
  12.142 +  (* perform a limited search that is stopped after a certain number of conflicts *)
  12.143 +  (case search (next_restart_limit iter) cdcl thy of
  12.144 +    (true, cdcl, thy) => (iter + 1, cdcl, thy)
  12.145 +  | (false, cdcl, thy) =>
  12.146 +      (* restart the solvers to avoid that they get stuck in a fruitless search *)
  12.147 +      let val (levels, cdcl) = Argo_Cdcl.restart cdcl
  12.148 +      in loop (iter + 1) cdcl (backjump levels thy) end)
  12.149 +
  12.150 +fun run ({terms, iter, cdcl, thy}: context) =
  12.151 +  let val (iter, cdcl, thy) = loop iter cdcl (Argo_Thy.prepare thy)
  12.152 +  in mk_context terms iter cdcl thy end
  12.153 +
  12.154 +
  12.155 +(* model *)
  12.156 +
  12.157 +fun model_of ({terms, cdcl, ...}: context) c =
  12.158 +  (case Argo_Term.identify_item (Argo_Term.Expr (Argo_Expr.E (Argo_Expr.Con c, []))) terms of
  12.159 +    (Argo_Term.Known t, _) => Argo_Cdcl.assignment_of cdcl (Argo_Lit.Pos t)
  12.160 +  | (Argo_Term.New _, _) => NONE)
  12.161 +
  12.162 +end
    13.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    13.2 +++ b/src/Tools/Argo/argo_expr.ML	Thu Sep 29 20:54:44 2016 +0200
    13.3 @@ -0,0 +1,244 @@
    13.4 +(*  Title:      Tools/Argo/sid_expr.ML
    13.5 +    Author:     Sascha Boehme
    13.6 +
    13.7 +The input language of the Argo solver.
    13.8 +*)
    13.9 +
   13.10 +signature ARGO_EXPR =
   13.11 +sig
   13.12 +  (* data types *)
   13.13 +  datatype typ = Bool | Real | Func of typ * typ | Type of string
   13.14 +  datatype kind =
   13.15 +    True | False | Not | And | Or | Imp | Iff | Ite | Eq | App | Con of string * typ |
   13.16 +    Le | Lt | Num of Rat.rat | Neg | Add | Sub | Mul | Div | Min | Max | Abs
   13.17 +  datatype expr = E of kind * expr list
   13.18 +
   13.19 +  (* indices, equalities, orders *)
   13.20 +  val int_of_kind: kind -> int
   13.21 +  val con_ord: (string * typ) * (string * typ) -> order
   13.22 +  val eq_kind: kind * kind -> bool
   13.23 +  val kind_ord: kind * kind -> order
   13.24 +  val eq_expr: expr * expr -> bool
   13.25 +  val expr_ord: expr * expr -> order
   13.26 +  val dual_expr: expr -> expr -> bool
   13.27 +
   13.28 +  (* constructors *)
   13.29 +  val kind_of_string: string -> kind
   13.30 +  val true_expr: expr
   13.31 +  val false_expr: expr
   13.32 +  val mk_not: expr -> expr
   13.33 +  val mk_and: expr list -> expr
   13.34 +  val mk_and2: expr -> expr -> expr
   13.35 +  val mk_or: expr list -> expr
   13.36 +  val mk_or2: expr -> expr -> expr
   13.37 +  val mk_imp: expr -> expr -> expr
   13.38 +  val mk_iff: expr -> expr -> expr
   13.39 +  val mk_ite: expr -> expr -> expr -> expr
   13.40 +  val mk_eq: expr -> expr -> expr
   13.41 +  val mk_app: expr -> expr -> expr
   13.42 +  val mk_con: string * typ -> expr
   13.43 +  val mk_le: expr -> expr -> expr
   13.44 +  val mk_lt: expr -> expr -> expr
   13.45 +  val mk_num: Rat.rat -> expr
   13.46 +  val mk_neg: expr -> expr
   13.47 +  val mk_add: expr list -> expr
   13.48 +  val mk_add2: expr -> expr -> expr
   13.49 +  val mk_sub: expr -> expr -> expr
   13.50 +  val mk_mul: expr -> expr -> expr
   13.51 +  val mk_div: expr -> expr -> expr
   13.52 +  val mk_min: expr -> expr -> expr
   13.53 +  val mk_max: expr -> expr -> expr
   13.54 +  val mk_abs: expr -> expr
   13.55 +
   13.56 +  (* type checking *)
   13.57 +  exception TYPE of expr
   13.58 +  exception EXPR of expr
   13.59 +  val type_of: expr -> typ (* raises EXPR *)
   13.60 +  val check: expr -> bool (* raises TYPE and EXPR *)
   13.61 +end
   13.62 +
   13.63 +structure Argo_Expr: ARGO_EXPR =
   13.64 +struct
   13.65 +
   13.66 +(* data types *)
   13.67 +
   13.68 +datatype typ = Bool | Real | Func of typ * typ | Type of string
   13.69 +
   13.70 +datatype kind =
   13.71 +  True | False | Not | And | Or | Imp | Iff | Ite | Eq | App | Con of string * typ |
   13.72 +  Le | Lt | Num of Rat.rat | Neg | Add | Sub | Mul | Div | Min | Max | Abs
   13.73 +
   13.74 +datatype expr = E of kind * expr list
   13.75 +
   13.76 +
   13.77 +(* indices, equalities, orders *)
   13.78 +
   13.79 +fun int_of_type Bool = 0
   13.80 +  | int_of_type Real = 1
   13.81 +  | int_of_type (Func _) = 2
   13.82 +  | int_of_type (Type _) = 3
   13.83 +
   13.84 +fun int_of_kind True = 0
   13.85 +  | int_of_kind False = 1
   13.86 +  | int_of_kind Not = 2
   13.87 +  | int_of_kind And = 3
   13.88 +  | int_of_kind Or = 4
   13.89 +  | int_of_kind Imp = 5
   13.90 +  | int_of_kind Iff = 6
   13.91 +  | int_of_kind Ite = 7
   13.92 +  | int_of_kind Eq = 8
   13.93 +  | int_of_kind App = 9
   13.94 +  | int_of_kind (Con _) = 10
   13.95 +  | int_of_kind Le = 11
   13.96 +  | int_of_kind Lt = 12
   13.97 +  | int_of_kind (Num _) = 13
   13.98 +  | int_of_kind Neg = 14
   13.99 +  | int_of_kind Add = 15
  13.100 +  | int_of_kind Sub = 16
  13.101 +  | int_of_kind Mul = 17
  13.102 +  | int_of_kind Div = 18
  13.103 +  | int_of_kind Min = 19
  13.104 +  | int_of_kind Max = 20
  13.105 +  | int_of_kind Abs = 21
  13.106 +
  13.107 +fun eq_type (Bool, Bool) = true
  13.108 +  | eq_type (Real, Real) = true
  13.109 +  | eq_type (Func tys1, Func tys2) = eq_pair eq_type eq_type (tys1, tys2)
  13.110 +  | eq_type (Type n1, Type n2) = (n1 = n2)
  13.111 +  | eq_type _ = false
  13.112 +
  13.113 +fun type_ord (Bool, Bool) = EQUAL
  13.114 +  | type_ord (Real, Real) = EQUAL
  13.115 +  | type_ord (Type n1, Type n2) = fast_string_ord (n1, n2)
  13.116 +  | type_ord (Func tys1, Func tys2) = prod_ord type_ord type_ord (tys1, tys2)
  13.117 +  | type_ord (ty1, ty2) = int_ord (int_of_type ty1, int_of_type ty2)
  13.118 +
  13.119 +fun eq_con cp = eq_pair (op =) eq_type cp
  13.120 +fun con_ord cp = prod_ord fast_string_ord type_ord cp
  13.121 +
  13.122 +fun eq_kind (Con c1, Con c2) = eq_con (c1, c2)
  13.123 +  | eq_kind (Num n1, Num n2) = n1 = n2
  13.124 +  | eq_kind (k1, k2) = (k1 = k2)
  13.125 +
  13.126 +fun kind_ord (Con c1, Con c2) = con_ord (c1, c2)
  13.127 +  | kind_ord (Num n1, Num n2) = Rat.ord (n1, n2)
  13.128 +  | kind_ord (k1, k2) = int_ord (int_of_kind k1, int_of_kind k2)
  13.129 +
  13.130 +fun eq_expr (E e1, E e2) = eq_pair eq_kind (eq_list eq_expr) (e1, e2)
  13.131 +fun expr_ord (E e1, E e2) = prod_ord kind_ord (list_ord expr_ord) (e1, e2)
  13.132 +
  13.133 +fun dual_expr (E (Not, [e1])) e2 = eq_expr (e1, e2)
  13.134 +  | dual_expr e1 (E (Not, [e2])) = eq_expr (e1, e2)
  13.135 +  | dual_expr _ _ = false
  13.136 +
  13.137 +
  13.138 +(* constructors *)
  13.139 +
  13.140 +val kind_of_string = the o Symtab.lookup (Symtab.make [
  13.141 +  ("true", True),("false", False), ("not", Not), ("and", And), ("or", Or), ("imp", Imp),
  13.142 +  ("iff", Iff), ("ite", Ite), ("eq", Eq), ("app", App), ("le", Le), ("lt", Lt), ("neg", Neg),
  13.143 +  ("add", Add), ("sub", Sub), ("mul", Mul), ("div", Div), ("min", Min), ("max", Max), ("abs", Abs)])
  13.144 +
  13.145 +val true_expr = E (True, [])
  13.146 +val false_expr = E (False, [])
  13.147 +fun mk_not e = E (Not, [e])
  13.148 +fun mk_and es = E (And, es)
  13.149 +fun mk_and2 e1 e2 = mk_and [e1, e2]
  13.150 +fun mk_or es = E (Or, es)
  13.151 +fun mk_or2 e1 e2 = mk_or [e1, e2]
  13.152 +fun mk_imp e1 e2 = E (Imp, [e1, e2])
  13.153 +fun mk_iff e1 e2 = E (Iff, [e1, e2])
  13.154 +fun mk_ite e1 e2 e3 = E (Ite, [e1, e2, e3])
  13.155 +fun mk_eq e1 e2 = E (Eq, [e1, e2])
  13.156 +fun mk_app e1 e2 = E (App, [e1, e2])
  13.157 +fun mk_con n = E (Con n, [])
  13.158 +fun mk_le e1 e2 = E (Le, [e1, e2])
  13.159 +fun mk_lt e1 e2 = E (Lt, [e1, e2])
  13.160 +fun mk_num r = E (Num r, [])
  13.161 +fun mk_neg e = E (Neg, [e])
  13.162 +fun mk_add es = E (Add, es)
  13.163 +fun mk_add2 e1 e2 = mk_add [e1, e2]
  13.164 +fun mk_sub e1 e2 = E (Sub, [e1, e2])
  13.165 +fun mk_mul e1 e2 = E (Mul, [e1, e2])
  13.166 +fun mk_div e1 e2 = E (Div, [e1, e2])
  13.167 +fun mk_min e1 e2 = E (Min, [e1, e2])
  13.168 +fun mk_max e1 e2 = E (Max, [e1, e2])
  13.169 +fun mk_abs e = E (Abs, [e])
  13.170 +
  13.171 +
  13.172 +(* type checking *)
  13.173 +
  13.174 +exception TYPE of expr
  13.175 +exception EXPR of expr
  13.176 +
  13.177 +fun dest_func_type _ (Func tys) = tys
  13.178 +  | dest_func_type e _ = raise TYPE e
  13.179 +
  13.180 +fun type_of (E (True, _)) = Bool
  13.181 +  | type_of (E (False, _)) = Bool
  13.182 +  | type_of (E (Not, _)) = Bool
  13.183 +  | type_of (E (And, _)) = Bool
  13.184 +  | type_of (E (Or, _)) = Bool
  13.185 +  | type_of (E (Imp, _)) = Bool
  13.186 +  | type_of (E (Iff, _)) = Bool
  13.187 +  | type_of (E (Ite, [_, e, _])) = type_of e
  13.188 +  | type_of (E (Eq, _)) = Bool
  13.189 +  | type_of (E (App, [e, _])) = snd (dest_func_type e (type_of e))
  13.190 +  | type_of (E (Con (_, ty), _)) = ty
  13.191 +  | type_of (E (Le, _)) = Bool
  13.192 +  | type_of (E (Lt, _)) = Bool
  13.193 +  | type_of (E (Num _, _)) = Real
  13.194 +  | type_of (E (Neg, _)) = Real
  13.195 +  | type_of (E (Add, _)) = Real
  13.196 +  | type_of (E (Sub, _)) = Real
  13.197 +  | type_of (E (Mul, _)) = Real
  13.198 +  | type_of (E (Div, _)) = Real
  13.199 +  | type_of (E (Min, _)) = Real
  13.200 +  | type_of (E (Max, _)) = Real
  13.201 +  | type_of (E (Abs, _)) = Real
  13.202 +  | type_of e = raise EXPR e
  13.203 +
  13.204 +fun all_type ty (E (_, es)) = forall (curry eq_type ty o type_of) es
  13.205 +val all_bool = all_type Bool
  13.206 +val all_real = all_type Real
  13.207 +
  13.208 +(*
  13.209 +  Types as well as proper arities are checked.
  13.210 +  Exception TYPE is raised for invalid types.
  13.211 +  Exception EXPR is raised for invalid expressions and invalid arities.
  13.212 +*)
  13.213 +
  13.214 +fun check (e as E (_, es)) = (forall check es andalso raw_check e) orelse raise TYPE e
  13.215 +
  13.216 +and raw_check (E (True, [])) = true
  13.217 +  | raw_check (E (False, [])) = true
  13.218 +  | raw_check (e as E (Not, [_])) = all_bool e
  13.219 +  | raw_check (e as E (And, _ :: _)) = all_bool e
  13.220 +  | raw_check (e as E (Or, _ :: _)) = all_bool e
  13.221 +  | raw_check (e as E (Imp, [_, _])) = all_bool e
  13.222 +  | raw_check (e as E (Iff, [_, _])) = all_bool e
  13.223 +  | raw_check (E (Ite, [e1, e2, e3])) =
  13.224 +      let val ty1 = type_of e1 and ty2 = type_of e2 and ty3 = type_of e3
  13.225 +      in eq_type (ty1, Bool) andalso eq_type (ty2, ty3) end
  13.226 +  | raw_check (E (Eq, [e1, e2])) =
  13.227 +      let val ty1 = type_of e1 and ty2 = type_of e2
  13.228 +      in eq_type (ty1, ty2) andalso not (eq_type (ty1, Bool)) end
  13.229 +  | raw_check (E (App, [e1, e2])) =
  13.230 +      eq_type (fst (dest_func_type e1 (type_of e1)), type_of e2)
  13.231 +  | raw_check (E (Con _, [])) = true
  13.232 +  | raw_check (E (Num _, [])) = true
  13.233 +  | raw_check (e as E (Le, [_, _])) = all_real e
  13.234 +  | raw_check (e as E (Lt, [_, _])) = all_real e
  13.235 +  | raw_check (e as E (Neg, [_])) = all_real e
  13.236 +  | raw_check (e as E (Add, _)) = all_real e
  13.237 +  | raw_check (e as E (Sub, [_, _])) = all_real e
  13.238 +  | raw_check (e as E (Mul, [_, _])) = all_real e
  13.239 +  | raw_check (e as E (Div, [_, _])) = all_real e
  13.240 +  | raw_check (e as E (Min, [_, _])) = all_real e
  13.241 +  | raw_check (e as E (Max, [_, _])) = all_real e
  13.242 +  | raw_check (e as E (Abs, [_])) = all_real e
  13.243 +  | raw_check e = raise EXPR e
  13.244 +
  13.245 +end
  13.246 +
  13.247 +structure Argo_Exprtab = Table(type key = Argo_Expr.expr val ord = Argo_Expr.expr_ord)
    14.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    14.2 +++ b/src/Tools/Argo/argo_heap.ML	Thu Sep 29 20:54:44 2016 +0200
    14.3 @@ -0,0 +1,186 @@
    14.4 +(*  Title:      Tools/Argo/argo_heap.ML
    14.5 +    Author:     Sascha Boehme
    14.6 +
    14.7 +A maximum-priority heap for literals with integer priorities and with inverse indices.
    14.8 +The heap is intended to be used as VSIDS-like decision heuristics. This implementation
    14.9 +is based on pairing heaps described in:
   14.10 +
   14.11 +  Chris Okasaki. Purely Functional Data Structures. Chapter 5.
   14.12 +  Cambridge University Press, 1998.
   14.13 +*)
   14.14 +
   14.15 +signature ARGO_HEAP =
   14.16 +sig
   14.17 +  type heap
   14.18 +  val heap: heap
   14.19 +  val insert: Argo_Lit.literal -> heap -> heap
   14.20 +  val extract: heap -> (Argo_Lit.literal * heap) option
   14.21 +  val increase: Argo_Lit.literal -> heap -> heap
   14.22 +  val count: Argo_Lit.literal -> heap -> heap
   14.23 +  val decay: heap -> heap
   14.24 +  val rebuild: (Argo_Term.term -> bool) -> heap -> heap
   14.25 +end
   14.26 +
   14.27 +structure Argo_Heap: ARGO_HEAP =
   14.28 +struct
   14.29 +
   14.30 +(* heuristic activity constants *)
   14.31 +
   14.32 +val min_incr = 128
   14.33 +fun decay_incr i = (i * 11) div 10
   14.34 +val max_activity = Integer.pow 24 2
   14.35 +val activity_rescale = Integer.pow 14 2
   14.36 +
   14.37 +
   14.38 +(* data structures and basic operations *)
   14.39 +
   14.40 +datatype tree = E | T of Argo_Term.term * bool * tree list
   14.41 +
   14.42 +datatype parent = None | Root | Some of Argo_Term.term
   14.43 +
   14.44 +type heap = {
   14.45 +  incr: int, (* the increment to apply in an increase operation *)
   14.46 +  vals: ((int * int) * parent) Argo_Termtab.table, (* weights and parents of the stored terms *)
   14.47 +  tree: tree} (* the pairing heap of literals; note: the tree caches literal polarities *)
   14.48 +
   14.49 +fun mk_heap incr vals tree: heap = {incr=incr, vals=vals, tree=tree}
   14.50 +fun mk_heap' incr (tree, vals) = mk_heap incr vals tree
   14.51 +
   14.52 +val heap = mk_heap min_incr Argo_Termtab.empty E
   14.53 +
   14.54 +val empty_value = ((0, 0), None)
   14.55 +fun value_of vals t = the_default empty_value (Argo_Termtab.lookup vals t)
   14.56 +fun map_value t = Argo_Termtab.map_default (t, empty_value)
   14.57 +
   14.58 +
   14.59 +(* weight operations *)
   14.60 +
   14.61 +(*
   14.62 +  The weight of a term is a pair of activity and count. The activity describes how
   14.63 +  often a term participated in conflicts. The count describes how often a term occurs
   14.64 +  in clauses.
   14.65 +*)
   14.66 +
   14.67 +val weight_ord = prod_ord int_ord int_ord
   14.68 +
   14.69 +fun weight_of vals t = fst (value_of vals t)
   14.70 +
   14.71 +fun less_than vals t1 t2 = weight_ord (weight_of vals t1, weight_of vals t2) = LESS
   14.72 +
   14.73 +fun rescale activity = activity div activity_rescale
   14.74 +
   14.75 +fun incr_activity incr t = map_value t (apfst (apfst (Integer.add incr)))
   14.76 +fun incr_count t = map_value t (apfst (apsnd (Integer.add 1)))
   14.77 +
   14.78 +fun rescale_activities a incr vals =
   14.79 +  if a <= max_activity then (incr, vals)
   14.80 +  else (rescale incr, Argo_Termtab.map (fn _ => apfst (apfst rescale)) vals)
   14.81 +
   14.82 +
   14.83 +(* reverse index operations *)
   14.84 +
   14.85 +(*
   14.86 +  The reverse index is required to retrieve elements when increasing their priorities.
   14.87 +*)
   14.88 +
   14.89 +fun contains vals t =
   14.90 +  (case value_of vals t of
   14.91 +    (_, None) => false
   14.92 +  | _ => true)
   14.93 +
   14.94 +fun path_to vals t parents =
   14.95 +  (case value_of vals t of
   14.96 +    (_, Root) => parents
   14.97 +  | (_, Some parent) => path_to vals parent (t :: parents)
   14.98 +  | _ => raise Fail "bad heap")
   14.99 +
  14.100 +fun put_parent t parent = map_value t (apsnd (K parent))
  14.101 +fun delete t = put_parent t None
  14.102 +fun root t = put_parent t Root
  14.103 +
  14.104 +fun as_root (tree as T (t, _, _), vals) = (tree, root t vals)
  14.105 +  | as_root x = x
  14.106 +
  14.107 +
  14.108 +(* pairing heap operations *)
  14.109 +
  14.110 +fun merge E tree vals = (tree, vals)
  14.111 +  | merge tree E vals = (tree, vals)
  14.112 +  | merge (tree1 as T (t1, p1, trees1)) (tree2 as T (t2, p2, trees2)) vals =
  14.113 +      if less_than vals t1 t2 then (T (t2, p2, tree1 :: trees2), put_parent t1 (Some t2) vals)
  14.114 +      else (T (t1, p1, tree2 :: trees1), put_parent t2 (Some t1) vals)
  14.115 +
  14.116 +fun merge_pairs [] vals = (E, vals)
  14.117 +  | merge_pairs [tree] vals = (tree, vals)
  14.118 +  | merge_pairs (tree1 :: tree2 :: trees) vals =
  14.119 +      vals |> merge tree1 tree2 ||>> merge_pairs trees |-> uncurry merge
  14.120 +
  14.121 +
  14.122 +(* cutting subtrees specified by a path *)
  14.123 +
  14.124 +(*
  14.125 +  The extractions are performed in such a way that the heap is changed in as few positions
  14.126 +  as possible.
  14.127 +*)
  14.128 +
  14.129 +fun with_index f u ((tree as T (t, _, _)) :: trees) =
  14.130 +      if Argo_Term.eq_term (t, u) then f tree ||> (fn E => trees | tree => tree :: trees)
  14.131 +      else with_index f u trees ||> cons tree
  14.132 +  | with_index _ _ _ = raise Fail "bad heap"
  14.133 +
  14.134 +fun lift_index f u (T (t, p, trees)) = with_index f u trees ||> (fn trees => T (t, p, trees))
  14.135 +  | lift_index _ _ E = raise Fail "bad heap"
  14.136 +
  14.137 +fun cut t [] tree = lift_index (fn tree => (tree, E)) t tree
  14.138 +  | cut t (parent :: ts) tree = lift_index (cut t ts) parent tree
  14.139 +
  14.140 +
  14.141 +(* filtering the heap *)
  14.142 +
  14.143 +val proper_trees = filter (fn E => false | T _ => true)
  14.144 +
  14.145 +fun filter_tree _ E vals = (E, vals)
  14.146 +  | filter_tree pred (T (t, p, ts)) vals =
  14.147 +      let val (ts, vals) = fold_map (filter_tree pred) ts vals |>> proper_trees
  14.148 +      in if pred t then (T (t, p, ts), vals) else merge_pairs ts (delete t vals) end
  14.149 +
  14.150 +
  14.151 +(* exported heap operations *)
  14.152 +
  14.153 +fun insert lit (h as {incr, vals, tree}: heap) = 
  14.154 +  let val (t, p) = Argo_Lit.dest lit
  14.155 +  in if contains vals t then h else mk_heap' incr (merge tree (T (t, p, [])) (root t vals)) end
  14.156 +
  14.157 +fun extract ({tree=E, ...}: heap) = NONE
  14.158 +  | extract ({incr, vals, tree=T (t, p, ts)}: heap) =
  14.159 +      SOME (Argo_Lit.literal t p, mk_heap' incr (as_root (merge_pairs ts (delete t vals))))
  14.160 +
  14.161 +fun with_term lit f = f (Argo_Lit.term_of lit)
  14.162 +
  14.163 +(*
  14.164 +  If the changed weight violates the heap property, the corresponding tree
  14.165 +  is extracted and merged with the root.
  14.166 +*)
  14.167 +
  14.168 +fun fix t (w, Some parent) (incr, vals) tree =
  14.169 +      if weight_ord (weight_of vals parent, w) = LESS then
  14.170 +        let val (tree1, tree2) = cut t (path_to vals parent []) tree
  14.171 +        in mk_heap' incr (merge tree1 tree2 (root t vals)) end
  14.172 +      else mk_heap incr vals tree
  14.173 +  | fix _ _ (incr, vals) tree = mk_heap incr vals tree
  14.174 +
  14.175 +fun increase lit ({incr, vals, tree}: heap) = with_term lit (fn t =>
  14.176 +  let
  14.177 +    val vals = incr_activity incr t vals
  14.178 +    val value as ((a, _), _) = value_of vals t
  14.179 +  in fix t value (rescale_activities a incr vals) tree end)
  14.180 +
  14.181 +fun count lit ({incr, vals, tree}: heap) = with_term lit (fn t =>
  14.182 +  let val vals = incr_count t vals
  14.183 +  in fix t (value_of vals t) (incr, vals) tree end)
  14.184 +
  14.185 +fun decay ({incr, vals, tree}: heap) = mk_heap (decay_incr incr) vals tree
  14.186 +
  14.187 +fun rebuild pred ({incr, vals, tree}: heap) = mk_heap' incr (filter_tree pred tree vals)
  14.188 +
  14.189 +end
    15.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    15.2 +++ b/src/Tools/Argo/argo_lit.ML	Thu Sep 29 20:54:44 2016 +0200
    15.3 @@ -0,0 +1,64 @@
    15.4 +(*  Title:      Tools/Argo/argo_lit.ML
    15.5 +    Author:     Sascha Boehme
    15.6 +
    15.7 +Representation of literals. Literals are terms with a polarity, either positive or negative.
    15.8 +A literal for term t with positive polarity is equivalent to t.
    15.9 +A literal for term t with negative polarity is equivalent to the propositional negation of t.
   15.10 +*)
   15.11 +
   15.12 +signature ARGO_LIT =
   15.13 +sig
   15.14 +  datatype literal = Pos of Argo_Term.term | Neg of Argo_Term.term
   15.15 +  val literal: Argo_Term.term -> bool -> literal
   15.16 +  val dest: literal -> Argo_Term.term * bool
   15.17 +  val term_of: literal -> Argo_Term.term
   15.18 +  val signed_id_of: literal -> int
   15.19 +  val signed_expr_of: literal -> Argo_Expr.expr
   15.20 +  val negate: literal -> literal
   15.21 +  val eq_id: literal * literal -> bool
   15.22 +  val eq_lit: literal * literal -> bool
   15.23 +  val dual_lit: literal * literal -> bool
   15.24 +end
   15.25 +
   15.26 +structure Argo_Lit: ARGO_LIT =
   15.27 +struct
   15.28 +
   15.29 +(* data type *)
   15.30 +
   15.31 +datatype literal = Pos of Argo_Term.term | Neg of Argo_Term.term
   15.32 +
   15.33 +
   15.34 +(* operations *)
   15.35 +
   15.36 +fun literal t true = Pos t
   15.37 +  | literal t false = Neg t
   15.38 +
   15.39 +fun dest (Pos t) = (t, true)
   15.40 +  | dest (Neg t) = (t, false)
   15.41 +
   15.42 +fun term_of (Pos t) = t
   15.43 +  | term_of (Neg t) = t
   15.44 +
   15.45 +fun signed_id_of (Pos t) = Argo_Term.id_of t
   15.46 +  | signed_id_of (Neg t) = ~(Argo_Term.id_of t)
   15.47 +
   15.48 +fun signed_expr_of (Pos t) = Argo_Term.expr_of t
   15.49 +  | signed_expr_of (Neg t) = Argo_Expr.mk_not (Argo_Term.expr_of t)
   15.50 +
   15.51 +fun id_of (Pos t) = Argo_Term.id_of t
   15.52 +  | id_of (Neg t) = Argo_Term.id_of t
   15.53 +
   15.54 +fun negate (Pos t) = Neg t
   15.55 +  | negate (Neg t) = Pos t
   15.56 +
   15.57 +fun eq_id (lit1, lit2) = (id_of lit1 = id_of lit2)
   15.58 +
   15.59 +fun eq_lit (Pos t1, Pos t2) = Argo_Term.eq_term (t1, t2)
   15.60 +  | eq_lit (Neg t1, Neg t2) = Argo_Term.eq_term (t1, t2)
   15.61 +  | eq_lit _ = false
   15.62 +
   15.63 +fun dual_lit (Pos t1, Neg t2) = Argo_Term.eq_term (t1, t2)
   15.64 +  | dual_lit (Neg t1, Pos t2) = Argo_Term.eq_term (t1, t2)
   15.65 +  | dual_lit _ = false
   15.66 +
   15.67 +end
    16.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    16.2 +++ b/src/Tools/Argo/argo_proof.ML	Thu Sep 29 20:54:44 2016 +0200
    16.3 @@ -0,0 +1,387 @@
    16.4 +(*  Title:      Tools/Argo/argo_proof.ML
    16.5 +    Author:     Sascha Boehme
    16.6 +
    16.7 +The proof language of the Argo solver.
    16.8 +
    16.9 +Proofs trace the inferences of the solver. They can be used to check unsatisfiability results.
   16.10 +
   16.11 +The proof language is inspired by:
   16.12 +
   16.13 +  Leonardo  de  Moura  and  Nikolaj  Bj/orner. Proofs and Refutations, and Z3. In
   16.14 +  Proceedings of the LPAR 2008 Workshops, Knowledge Exchange: Automated Provers and Proof
   16.15 +  Assistants, and the 7th International Workshop on the Implementation of Logics,
   16.16 +  volume 418 of CEUR Workshop Proceedings. CEUR-WS.org, 2008.
   16.17 +*)
   16.18 +
   16.19 +signature ARGO_PROOF =
   16.20 +sig
   16.21 +  (* types *)
   16.22 +  type proof_id
   16.23 +  datatype tautology =
   16.24 +    Taut_And_1 of int | Taut_And_2 of int * int | Taut_Or_1 of int * int | Taut_Or_2 of int |
   16.25 +    Taut_Iff_1 | Taut_Iff_2 | Taut_Iff_3 | Taut_Iff_4 | Taut_Ite_Then | Taut_Ite_Else
   16.26 +  datatype inequality = Le | Lt
   16.27 +  datatype rewrite =
   16.28 +    Rewr_Not_True | Rewr_Not_False | Rewr_Not_Not | Rewr_Not_And of int | Rewr_Not_Or of int |
   16.29 +    Rewr_Not_Iff |
   16.30 +    Rewr_And_False of int | Rewr_And_Dual of int * int | Rewr_And_Sort of int * int list list |
   16.31 +    Rewr_Or_True of int | Rewr_Or_Dual of int * int | Rewr_Or_Sort of int * int list list |
   16.32 +    Rewr_Iff_True | Rewr_Iff_False | Rewr_Iff_Not_Not | Rewr_Iff_Refl | Rewr_Iff_Symm |
   16.33 +    Rewr_Iff_Dual |
   16.34 +    Rewr_Imp | Rewr_Ite_Prop | Rewr_Ite_True | Rewr_Ite_False | Rewr_Ite_Eq |
   16.35 +    Rewr_Eq_Refl | Rewr_Eq_Symm |
   16.36 +    Rewr_Neg | Rewr_Add of (Rat.rat * int option) list * (Rat.rat * int option) list | Rewr_Sub |
   16.37 +    Rewr_Mul_Nums of Rat.rat * Rat.rat | Rewr_Mul_Zero | Rewr_Mul_One | Rewr_Mul_Comm |
   16.38 +    Rewr_Mul_Assoc | Rewr_Mul_Sum | Rewr_Div_Nums of Rat.rat * Rat.rat | Rewr_Div_Zero |
   16.39 +    Rewr_Div_One | Rewr_Div_Mul | Rewr_Div_Inv | Rewr_Div_Left | Rewr_Div_Right | Rewr_Min |
   16.40 +    Rewr_Max | Rewr_Abs | Rewr_Eq_Le | Rewr_Ineq_Nums of inequality * bool |
   16.41 +    Rewr_Ineq_Add of inequality * Rat.rat | Rewr_Ineq_Sub of inequality |
   16.42 +    Rewr_Ineq_Mul of inequality * Rat.rat | Rewr_Not_Ineq of inequality
   16.43 +  datatype conv =
   16.44 +    Keep_Conv | Then_Conv of conv * conv | Args_Conv of conv list | Rewr_Conv of rewrite
   16.45 +  datatype rule =
   16.46 +    Axiom of int | Taut of tautology * Argo_Expr.expr | Conjunct of int * int | Rewrite of conv |
   16.47 +    Hyp of int * Argo_Expr.expr | Clause of int list | Lemma of int list | Unit_Res of int |
   16.48 +    Refl of Argo_Expr.expr | Symm | Trans | Cong | Subst | Linear_Comb
   16.49 +  type proof
   16.50 +
   16.51 +  (* equalities and orders *)
   16.52 +  val eq_proof_id: proof_id * proof_id -> bool
   16.53 +  val proof_id_ord: proof_id * proof_id -> order
   16.54 +
   16.55 +  (* conversion constructors *)
   16.56 +  val keep_conv: conv
   16.57 +  val mk_then_conv: conv -> conv -> conv
   16.58 +  val mk_args_conv: conv list -> conv
   16.59 +  val mk_rewr_conv: rewrite -> conv
   16.60 +
   16.61 +  (* context *)
   16.62 +  type context
   16.63 +  val cdcl_context: context
   16.64 +  val cc_context: context
   16.65 +  val simplex_context: context
   16.66 +  val solver_context: context
   16.67 +
   16.68 +  (* proof constructors *)
   16.69 +  val mk_axiom: int -> context -> proof * context
   16.70 +  val mk_taut: tautology -> Argo_Expr.expr -> context -> proof * context
   16.71 +  val mk_conj: int -> int -> proof -> context -> proof * context
   16.72 +  val mk_rewrite: conv -> proof -> context -> proof * context
   16.73 +  val mk_hyp: Argo_Lit.literal -> context -> proof * context
   16.74 +  val mk_clause: Argo_Lit.literal list -> proof -> context -> proof * context
   16.75 +  val mk_lemma: Argo_Lit.literal list -> proof -> context -> proof * context
   16.76 +  val mk_unit_res: Argo_Lit.literal -> proof -> proof -> context -> proof * context
   16.77 +  val mk_refl: Argo_Term.term -> context -> proof * context
   16.78 +  val mk_symm: proof -> context -> proof * context
   16.79 +  val mk_trans: proof -> proof -> context -> proof * context
   16.80 +  val mk_cong: proof -> proof -> context -> proof * context
   16.81 +  val mk_subst: proof -> proof -> proof -> context -> proof * context
   16.82 +  val mk_linear_comb: proof list -> context -> proof * context
   16.83 +
   16.84 +  (* proof destructors *)
   16.85 +  val id_of: proof -> proof_id
   16.86 +  val dest: proof -> proof_id * rule * proof list
   16.87 +
   16.88 +  (* string representations *)
   16.89 +  val string_of_proof_id: proof_id -> string
   16.90 +  val string_of_taut: tautology -> string
   16.91 +  val string_of_rule: rule -> string
   16.92 +
   16.93 +  (* unsatisfiability *)
   16.94 +  exception UNSAT of proof
   16.95 +  val unsat: proof -> 'a (* raises UNSAT *)
   16.96 +end
   16.97 +
   16.98 +structure Argo_Proof: ARGO_PROOF =
   16.99 +struct
  16.100 +
  16.101 +(* types *)
  16.102 +
  16.103 +datatype tautology =
  16.104 +  Taut_And_1 of int | Taut_And_2 of int * int | Taut_Or_1 of int * int | Taut_Or_2 of int |
  16.105 +  Taut_Iff_1 | Taut_Iff_2 | Taut_Iff_3 | Taut_Iff_4 | Taut_Ite_Then | Taut_Ite_Else
  16.106 +
  16.107 +datatype inequality = Le | Lt
  16.108 +
  16.109 +datatype rewrite =
  16.110 +  Rewr_Not_True | Rewr_Not_False | Rewr_Not_Not | Rewr_Not_And of int | Rewr_Not_Or of int |
  16.111 +  Rewr_Not_Iff |
  16.112 +  Rewr_And_False of int | Rewr_And_Dual of int * int | Rewr_And_Sort of int * int list list |
  16.113 +  Rewr_Or_True of int | Rewr_Or_Dual of int * int | Rewr_Or_Sort of int * int list list |
  16.114 +  Rewr_Iff_True | Rewr_Iff_False | Rewr_Iff_Not_Not | Rewr_Iff_Refl | Rewr_Iff_Symm |
  16.115 +  Rewr_Iff_Dual |
  16.116 +  Rewr_Imp | Rewr_Ite_Prop | Rewr_Ite_True | Rewr_Ite_False | Rewr_Ite_Eq |
  16.117 +  Rewr_Eq_Refl | Rewr_Eq_Symm |
  16.118 +  Rewr_Neg | Rewr_Add of (Rat.rat * int option) list * (Rat.rat * int option) list | Rewr_Sub |
  16.119 +  Rewr_Mul_Nums of Rat.rat * Rat.rat | Rewr_Mul_Zero | Rewr_Mul_One | Rewr_Mul_Comm |
  16.120 +  Rewr_Mul_Assoc | Rewr_Mul_Sum | Rewr_Div_Nums of Rat.rat * Rat.rat | Rewr_Div_Zero |
  16.121 +  Rewr_Div_One | Rewr_Div_Mul | Rewr_Div_Inv | Rewr_Div_Left | Rewr_Div_Right | Rewr_Min |
  16.122 +  Rewr_Max | Rewr_Abs | Rewr_Eq_Le | Rewr_Ineq_Nums of inequality * bool |
  16.123 +  Rewr_Ineq_Add of inequality * Rat.rat | Rewr_Ineq_Sub of inequality |
  16.124 +  Rewr_Ineq_Mul of inequality * Rat.rat | Rewr_Not_Ineq of inequality
  16.125 +
  16.126 +datatype conv =
  16.127 +  Keep_Conv | Then_Conv of conv * conv | Args_Conv of conv list | Rewr_Conv of rewrite
  16.128 +
  16.129 +datatype rule =
  16.130 +  Axiom of int | Taut of tautology * Argo_Expr.expr | Conjunct of int * int | Rewrite of conv |
  16.131 +  Hyp of int * Argo_Expr.expr | Clause of int list | Lemma of int list | Unit_Res of int |
  16.132 +  Refl of Argo_Expr.expr | Symm | Trans | Cong | Subst | Linear_Comb
  16.133 +
  16.134 +(*
  16.135 +  Proof identifiers are intentially hidden to prevent that functions outside of this structure
  16.136 +  are able to build proofs. Proof can hence only be built by the functions provided by
  16.137 +  this structure.
  16.138 +*)
  16.139 +
  16.140 +datatype proof_id = Cdcl of int | Cc of int | Simplex of int | Solver of int
  16.141 +
  16.142 +datatype proof = Proof of proof_id * rule * proof list
  16.143 +
  16.144 +
  16.145 +(* internal functions *)
  16.146 +
  16.147 +val proof_id_card = 4
  16.148 +
  16.149 +fun raw_proof_id (Cdcl i) = i
  16.150 +  | raw_proof_id (Cc i) = i
  16.151 +  | raw_proof_id (Simplex i) = i
  16.152 +  | raw_proof_id (Solver i) = i
  16.153 +
  16.154 +
  16.155 +(* equalities and orders *)
  16.156 +
  16.157 +fun int_of_proof_id (Cdcl _) = 0
  16.158 +  | int_of_proof_id (Cc _) = 1
  16.159 +  | int_of_proof_id (Simplex _) = 2
  16.160 +  | int_of_proof_id (Solver _) = 3
  16.161 +
  16.162 +fun eq_proof_id (Cdcl i1, Cdcl i2) = (i1 = i2)
  16.163 +  | eq_proof_id (Cc i1, Cc i2) = (i1 = i2)
  16.164 +  | eq_proof_id (Simplex i1, Simplex i2) = (i1 = i2)
  16.165 +  | eq_proof_id (Solver i1, Solver i2) = (i1 = i2)
  16.166 +  | eq_proof_id _ = false
  16.167 +
  16.168 +fun proof_id_ord (Cdcl i1, Cdcl i2) = int_ord (i1, i2)
  16.169 +  | proof_id_ord (Cc i1, Cc i2) = int_ord (i1, i2)
  16.170 +  | proof_id_ord (Simplex i1, Simplex i2) = int_ord (i1, i2)
  16.171 +  | proof_id_ord (Solver i1, Solver i2) = int_ord (i1, i2)
  16.172 +  | proof_id_ord (id1, id2) = int_ord (int_of_proof_id id1, int_of_proof_id id2)
  16.173 +
  16.174 +
  16.175 +(* conversion constructors *)
  16.176 +
  16.177 +val keep_conv = Keep_Conv
  16.178 +
  16.179 +fun mk_then_conv Keep_Conv c = c
  16.180 +  | mk_then_conv c Keep_Conv = c
  16.181 +  | mk_then_conv c1 c2 = Then_Conv (c1, c2)
  16.182 +
  16.183 +fun mk_args_conv cs =
  16.184 +  if forall (fn Keep_Conv => true | _ => false) cs then Keep_Conv
  16.185 +  else Args_Conv cs
  16.186 +
  16.187 +fun mk_rewr_conv r = Rewr_Conv r
  16.188 +
  16.189 +
  16.190 +(* context *)
  16.191 +
  16.192 +(*
  16.193 +  The proof context stores the next unused identifier. Incidentally, the same type as
  16.194 +  for the proof identifier can be used as context. Every proof-producing module of the
  16.195 +  solver has its own proof identifier domain to ensure globally unique identifiers
  16.196 +  without sharing a single proof context.
  16.197 +*)
  16.198 +
  16.199 +type context = proof_id
  16.200 +
  16.201 +val cdcl_context = Cdcl 0
  16.202 +val cc_context = Cc 0
  16.203 +val simplex_context = Simplex 0
  16.204 +val solver_context = Solver 0
  16.205 +
  16.206 +fun next_id (id as Cdcl i) = (id, Cdcl (i + 1))
  16.207 +  | next_id (id as Cc i) = (id, Cc (i + 1))
  16.208 +  | next_id (id as Simplex i) = (id, Simplex (i + 1))
  16.209 +  | next_id (id as Solver i) = (id, Solver (i + 1))
  16.210 +
  16.211 +
  16.212 +(* proof destructors *)
  16.213 +
  16.214 +fun id_of (Proof (id, _, _)) = id
  16.215 +
  16.216 +fun dest (Proof p) = p
  16.217 +
  16.218 +
  16.219 +(* proof constructors *)
  16.220 +
  16.221 +fun mk_proof r ps cx =
  16.222 +  let val (id, cx) = next_id cx
  16.223 +  in (Proof (id, r, ps), cx) end
  16.224 +
  16.225 +fun mk_axiom i = mk_proof (Axiom i) []
  16.226 +fun mk_taut t e = mk_proof (Taut (t, e)) []
  16.227 +fun mk_conj i n p = mk_proof (Conjunct (i, n)) [p]
  16.228 +
  16.229 +fun mk_rewrite Keep_Conv p cx = (p, cx)
  16.230 +  | mk_rewrite c p cx = mk_proof (Rewrite c) [p] cx
  16.231 +
  16.232 +fun mk_hyp lit = mk_proof (Hyp (Argo_Lit.signed_id_of lit, Argo_Lit.signed_expr_of lit)) []
  16.233 +fun mk_clause lits p cx = mk_proof (Clause (map Argo_Lit.signed_id_of lits)) [p] cx
  16.234 +fun mk_lemma lits p = mk_proof (Lemma (map Argo_Lit.signed_id_of lits)) [p]
  16.235 +
  16.236 +(*
  16.237 +  Replay of unit-resolution steps can be optimized if all premises follow a specific form.
  16.238 +  Therefore, each premise is checked if it is in clausal form.
  16.239 +*)
  16.240 +
  16.241 +fun check_clause (p as Proof (_, Clause _, _)) = p
  16.242 +  | check_clause (p as Proof (_, Lemma _, _)) = p
  16.243 +  | check_clause (p as Proof (_, Unit_Res _, _)) = p
  16.244 +  | check_clause _ = raise Fail "bad clause proof"
  16.245 +
  16.246 +fun mk_unit t p1 p2 = mk_proof (Unit_Res (Argo_Term.id_of t)) (map check_clause [p1, p2])
  16.247 +
  16.248 +fun mk_unit_res (Argo_Lit.Pos t) p1 p2 = mk_unit t p1 p2
  16.249 +  | mk_unit_res (Argo_Lit.Neg t) p1 p2 = mk_unit t p2 p1
  16.250 +
  16.251 +fun mk_refl t = mk_proof (Refl (Argo_Term.expr_of t)) []
  16.252 +fun mk_symm p = mk_proof Symm [p]
  16.253 +
  16.254 +fun mk_trans (Proof (_, Refl _, _)) p2 = pair p2
  16.255 +  | mk_trans p1 (Proof (_, Refl _, _)) = pair p1
  16.256 +  | mk_trans p1 p2 = mk_proof Trans [p1, p2]
  16.257 +
  16.258 +fun mk_cong p1 p2 = mk_proof Cong [p1, p2]
  16.259 +
  16.260 +fun mk_subst p1 (Proof (_, Refl _, _)) (Proof (_, Refl _, _)) = pair p1
  16.261 +  | mk_subst p1 p2 p3 = mk_proof Subst [p1, p2, p3]
  16.262 +
  16.263 +fun mk_linear_comb ps = mk_proof Linear_Comb ps
  16.264 +
  16.265 +
  16.266 +(* string representations *)
  16.267 +
  16.268 +fun string_of_proof_id id = string_of_int (proof_id_card * raw_proof_id id + int_of_proof_id id)
  16.269 +
  16.270 +fun string_of_list l r f xs = enclose l r (space_implode ", " (map f xs))
  16.271 +fun parens f xs = string_of_list "(" ")" f xs
  16.272 +fun brackets f xs = string_of_list "[" "]" f xs
  16.273 +
  16.274 +fun string_of_taut (Taut_And_1 n) = "and " ^ string_of_int n
  16.275 +  | string_of_taut (Taut_And_2 (i, n)) = "and " ^ parens string_of_int [i, n]
  16.276 +  | string_of_taut (Taut_Or_1 (i, n)) = "or " ^ parens string_of_int [i, n]
  16.277 +  | string_of_taut (Taut_Or_2 n) = "or " ^ string_of_int n
  16.278 +  | string_of_taut Taut_Iff_1 = "(p1 == p2) | p1 | p2"
  16.279 +  | string_of_taut Taut_Iff_2 = "(p1 == p2) | ~p1 | ~p2"
  16.280 +  | string_of_taut Taut_Iff_3 = "~(p1 == p2) | ~p1 | p2"
  16.281 +  | string_of_taut Taut_Iff_4 = "~(p1 == p2) | p1 | ~p2"
  16.282 +  | string_of_taut Taut_Ite_Then = "~p | (ite p t1 t2) = t1"
  16.283 +  | string_of_taut Taut_Ite_Else = "p | (ite p t1 t2) = t2"
  16.284 +
  16.285 +fun string_of_rewr Rewr_Not_True = "~T = F"
  16.286 +  | string_of_rewr Rewr_Not_False = "~F = T"
  16.287 +  | string_of_rewr Rewr_Not_Not = "~~p = p"
  16.288 +  | string_of_rewr (Rewr_Not_And n) =
  16.289 +      "~(and [" ^ string_of_int n ^ "]) = (or [" ^ string_of_int n ^ "])" 
  16.290 +  | string_of_rewr (Rewr_Not_Or n) =
  16.291 +      "~(or [" ^ string_of_int n ^ "]) = (and [" ^ string_of_int n ^ "])"
  16.292 +  | string_of_rewr Rewr_Not_Iff = "~(p1 == p2) = (~p1 == ~p2)"
  16.293 +  | string_of_rewr (Rewr_And_False i) = "(and ... F(" ^ string_of_int i ^ ") ...) = F"
  16.294 +  | string_of_rewr (Rewr_And_Dual (i1, i2)) =
  16.295 +      "(and ... p(" ^ string_of_int i1 ^ ") ... ~p(" ^ string_of_int i2 ^ ") ...) = F"
  16.296 +  | string_of_rewr (Rewr_And_Sort (n, iss)) =
  16.297 +      "(and [" ^ string_of_int n ^ "]) = " ^
  16.298 +      "(and " ^ brackets (brackets string_of_int) iss ^ ")" 
  16.299 +  | string_of_rewr (Rewr_Or_True i) = "(or ... T(" ^ string_of_int i ^ ") ...) = T"
  16.300 +  | string_of_rewr (Rewr_Or_Dual (i1, i2)) =
  16.301 +      "(or ... p(" ^ string_of_int i1 ^ ") ... ~p(" ^ string_of_int i2 ^ ") ...) = T"
  16.302 +  | string_of_rewr (Rewr_Or_Sort (n, iss)) =
  16.303 +      "(or [" ^ string_of_int n ^ "]) = " ^
  16.304 +      "(or " ^ brackets (brackets string_of_int) iss ^ ")" 
  16.305 +  | string_of_rewr Rewr_Iff_True = "(p == T) = p"
  16.306 +  | string_of_rewr Rewr_Iff_False = "(p == F) = ~p"
  16.307 +  | string_of_rewr Rewr_Iff_Not_Not = "(~p1 == ~p2) = (p1 == p2)"
  16.308 +  | string_of_rewr Rewr_Iff_Refl = "(p == p) = T"
  16.309 +  | string_of_rewr Rewr_Iff_Symm = "(p1 == p2) = (p2 == p1)"
  16.310 +  | string_of_rewr Rewr_Iff_Dual = "(p == ~p) = F"
  16.311 +  | string_of_rewr Rewr_Imp = "(p1 --> p2) = (~p1 | p2)"
  16.312 +  | string_of_rewr Rewr_Ite_Prop = "(if p1 p2 p2) = ((~p1 | p2) & (p1 | p3) & (p2 | p3))"
  16.313 +  | string_of_rewr Rewr_Ite_True = "(if T t1 t2) = t1"
  16.314 +  | string_of_rewr Rewr_Ite_False = "(if F t1 t2) = t2"
  16.315 +  | string_of_rewr Rewr_Ite_Eq = "(if p t t) = t"
  16.316 +  | string_of_rewr Rewr_Eq_Refl = "(e = e) = T"
  16.317 +  | string_of_rewr Rewr_Eq_Symm = "(e1 = e2) = (e2 = e1)"
  16.318 +  | string_of_rewr Rewr_Neg = "-e = -1 * e"
  16.319 +  | string_of_rewr (Rewr_Add (p1, p2)) =
  16.320 +      let
  16.321 +        fun string_of_monom (n, NONE) = Rat.string_of_rat n
  16.322 +          | string_of_monom (n, SOME i) =
  16.323 +              (if n = @1 then "" else Rat.string_of_rat n ^ " * ") ^ "e" ^ string_of_int i
  16.324 +        fun string_of_polynom ms = space_implode " + " (map string_of_monom ms)
  16.325 +      in string_of_polynom p1 ^ " = " ^ string_of_polynom p2 end
  16.326 +  | string_of_rewr Rewr_Sub = "e1 - e2 = e1 + -1 * e2"
  16.327 +  | string_of_rewr (Rewr_Mul_Nums (n1, n2)) =
  16.328 +      Rat.string_of_rat n1 ^ " * " ^ Rat.string_of_rat n2 ^ " = " ^ Rat.string_of_rat (n1 * n2)
  16.329 +  | string_of_rewr Rewr_Mul_Zero = "0 * e = 0"
  16.330 +  | string_of_rewr Rewr_Mul_One = "1 * e = e"
  16.331 +  | string_of_rewr Rewr_Mul_Comm = "e1 * e2 = e2 * e1"
  16.332 +  | string_of_rewr Rewr_Mul_Assoc = "n1 * (n2 * e) = (n1 * n2) * e"
  16.333 +  | string_of_rewr Rewr_Mul_Sum = "n * (e1 + ... + em) = n * e1 + ... n * em"
  16.334 +  | string_of_rewr (Rewr_Div_Nums (n1, n2)) =
  16.335 +      Rat.string_of_rat n1 ^ " / " ^ Rat.string_of_rat n2 ^ " = " ^ Rat.string_of_rat (n1 / n2)
  16.336 +  | string_of_rewr Rewr_Div_Zero = "0 / e = 0"
  16.337 +  | string_of_rewr Rewr_Div_One = "e / 1 = e"
  16.338 +  | string_of_rewr Rewr_Div_Mul = "n / e = n * (1 / e)"
  16.339 +  | string_of_rewr Rewr_Div_Inv = "e / n = 1/n * e"
  16.340 +  | string_of_rewr Rewr_Div_Left = "(n * e1) / e2 = n * (e1 / e2)"
  16.341 +  | string_of_rewr Rewr_Div_Right = "e1 / (n * e2) = 1/n * (e1 / e2)"
  16.342 +  | string_of_rewr Rewr_Min = "min e1 e2 = (if e1 <= e2 then e1 else e2)"
  16.343 +  | string_of_rewr Rewr_Max = "max e1 e2 = (if e1 < e2 then e2 else e1)"
  16.344 +  | string_of_rewr Rewr_Abs = "abs e = (if 0 <= e then e else -e)"
  16.345 +  | string_of_rewr Rewr_Eq_Le = "(e1 = e2) = (and (e1 <= e2) (e2 <= e1))"
  16.346 +  | string_of_rewr (Rewr_Ineq_Nums (Le, true)) = "(n1 <= n2) = true"
  16.347 +  | string_of_rewr (Rewr_Ineq_Nums (Le, false)) = "(n1 <= n2) = false"
  16.348 +  | string_of_rewr (Rewr_Ineq_Nums (Lt, true)) = "(n1 < n2) = true"
  16.349 +  | string_of_rewr (Rewr_Ineq_Nums (Lt, false)) = "(n1 < n2) = false"
  16.350 +  | string_of_rewr (Rewr_Ineq_Add (Le, _)) = "(e1 <= e2) = (e1 + n <= e2 + n)"
  16.351 +  | string_of_rewr (Rewr_Ineq_Add (Lt, _)) = "(e1 < e2) = (e1 + n < e2 + n)"
  16.352 +  | string_of_rewr (Rewr_Ineq_Sub Le) = "(e1 <= e2) = (e1 - e2 <= 0)"
  16.353 +  | string_of_rewr (Rewr_Ineq_Sub Lt) = "(e1 < e2) = (e1 - e2 < 0)"
  16.354 +  | string_of_rewr (Rewr_Ineq_Mul (Le, _)) = "(e1 <= e2) = (n * e1 <= n * e2)"
  16.355 +  | string_of_rewr (Rewr_Ineq_Mul (Lt, _)) = "(e1 < e2) = (n * e1 < n * e2)"
  16.356 +  | string_of_rewr (Rewr_Not_Ineq Le) = "~(e1 <= e2) = (e2 < e1)"
  16.357 +  | string_of_rewr (Rewr_Not_Ineq Lt) = "~(e1 < e2) = (e2 <= e1)"
  16.358 +
  16.359 +fun flatten_then_conv (Then_Conv (c1, c2)) = flatten_then_conv c1 @ flatten_then_conv c2
  16.360 +  | flatten_then_conv c = [c]
  16.361 +
  16.362 +fun string_of_conv Keep_Conv = "_"
  16.363 +  | string_of_conv (c as Then_Conv _) =
  16.364 +      space_implode " then " (map (enclose "(" ")" o string_of_conv) (flatten_then_conv c))
  16.365 +  | string_of_conv (Args_Conv cs) = "args " ^ brackets string_of_conv cs
  16.366 +  | string_of_conv (Rewr_Conv r) = string_of_rewr r
  16.367 +
  16.368 +fun string_of_rule (Axiom i) = "axiom " ^ string_of_int i
  16.369 +  | string_of_rule (Taut (t, _)) = "tautology: " ^ string_of_taut t
  16.370 +  | string_of_rule (Conjunct (i, n)) = "conjunct " ^ string_of_int i ^ " of " ^ string_of_int n
  16.371 +  | string_of_rule (Rewrite c) = "rewrite: " ^ string_of_conv c
  16.372 +  | string_of_rule (Hyp (i, _)) = "hypothesis " ^ string_of_int i
  16.373 +  | string_of_rule (Clause is) = "clause " ^ brackets string_of_int is
  16.374 +  | string_of_rule (Lemma is) = "lemma " ^ brackets string_of_int is
  16.375 +  | string_of_rule (Unit_Res i) = "unit-resolution " ^ string_of_int i
  16.376 +  | string_of_rule (Refl _) = "reflexivity"
  16.377 +  | string_of_rule Symm = "symmetry"
  16.378 +  | string_of_rule Trans = "transitivity"
  16.379 +  | string_of_rule Cong = "congruence"
  16.380 +  | string_of_rule Subst = "substitution"
  16.381 +  | string_of_rule Linear_Comb = "linear-combination"
  16.382 +
  16.383 +
  16.384 +(* unsatisfiability *)
  16.385 +
  16.386 +exception UNSAT of proof
  16.387 +
  16.388 +fun unsat p = raise UNSAT p
  16.389 +
  16.390 +end
    17.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    17.2 +++ b/src/Tools/Argo/argo_rewr.ML	Thu Sep 29 20:54:44 2016 +0200
    17.3 @@ -0,0 +1,266 @@
    17.4 +(*  Title:      Tools/Argo/argo_rewr.ML
    17.5 +    Author:     Sascha Boehme
    17.6 +
    17.7 +Bottom-up rewriting of expressions based on rewrite rules and rewrite functions.
    17.8 +*)
    17.9 +
   17.10 +signature ARGO_REWR =
   17.11 +sig
   17.12 +  (* patterns *)
   17.13 +  datatype pattern =
   17.14 +    V of int |
   17.15 +    E of Argo_Expr.expr |
   17.16 +    A of Argo_Expr.kind |
   17.17 +    P of Argo_Expr.kind * pattern list |
   17.18 +    M of pattern |
   17.19 +    X
   17.20 +
   17.21 +  (* scanning patterns from strings *)
   17.22 +  val scan: string -> pattern
   17.23 +
   17.24 +  (* pattern matching *)
   17.25 +  type env
   17.26 +  val get_all: env -> Argo_Expr.expr list
   17.27 +  val get: env -> int -> Argo_Expr.expr
   17.28 +
   17.29 +  (* conversions *)
   17.30 +  type conv = Argo_Expr.expr -> Argo_Expr.expr * Argo_Proof.conv
   17.31 +  val keep: conv
   17.32 +  val seq: conv list -> conv
   17.33 +  val args: conv -> conv
   17.34 +  val rewr: Argo_Proof.rewrite -> Argo_Expr.expr -> conv
   17.35 +
   17.36 +  (* context *)
   17.37 +  type context
   17.38 +  val context: context
   17.39 +  val flat: string ->
   17.40 +    (int -> Argo_Expr.expr list -> (Argo_Proof.rewrite * Argo_Expr.expr) option) ->
   17.41 +    context -> context
   17.42 +  val func: string -> (env -> (Argo_Proof.rewrite * pattern) option) -> context -> context
   17.43 +  val rule: Argo_Proof.rewrite -> string -> string -> context -> context
   17.44 +
   17.45 +  (* rewriting *)
   17.46 +  val rewrite: context -> conv
   17.47 +  val rewrite_top: context -> conv
   17.48 +  val with_proof: conv -> Argo_Expr.expr * Argo_Proof.proof -> Argo_Proof.context ->
   17.49 +    (Argo_Expr.expr * Argo_Proof.proof) * Argo_Proof.context
   17.50 +end
   17.51 +
   17.52 +structure Argo_Rewr: ARGO_REWR =
   17.53 +struct
   17.54 +
   17.55 +(* patterns *)
   17.56 +
   17.57 +(*
   17.58 +  Patterns are used for matching against expressions and as a schema to construct
   17.59 +  expressions. For matching, only V, E, A and P must be used. For the schema,
   17.60 +  additionally M and X can be used.
   17.61 +*)
   17.62 +
   17.63 +datatype pattern =
   17.64 +  V of int | (* indexed placeholder where the index must be greater than 0 *)
   17.65 +  E of Argo_Expr.expr | (* expression without placeholders *)
   17.66 +  A of Argo_Expr.kind | (* placeholder for the arguments of an n-ary expression *)
   17.67 +  P of Argo_Expr.kind * pattern list | (* expression with optional placeholders *)
   17.68 +  M of pattern | (* mapping operator to iterate over an argument list of an n-ary expression *)
   17.69 +  X (* closure argument under a mapping operator representing an expression *)
   17.70 +
   17.71 +fun int_of_pattern (E _) = 0
   17.72 +  | int_of_pattern (P _) = 1
   17.73 +  | int_of_pattern (A _) = 2
   17.74 +  | int_of_pattern (V _) = 3
   17.75 +  | int_of_pattern _ = raise Fail "bad pattern"
   17.76 +
   17.77 +(*
   17.78 +  Specific patterns are ordered before generic patterns, since pattern matching
   17.79 +  performs a linear search for the most suitable pattern.
   17.80 +*)
   17.81 +
   17.82 +fun pattern_ord (E e1, E e2) = Argo_Expr.expr_ord (e1, e2)
   17.83 +  | pattern_ord (P (k1, ps1), P (k2, ps2)) =
   17.84 +      (case Argo_Expr.kind_ord (k1, k2) of EQUAL => list_ord pattern_ord (ps1, ps2) | x => x)
   17.85 +  | pattern_ord (A k1, A k2) = Argo_Expr.kind_ord (k1, k2)
   17.86 +  | pattern_ord (V i1, V i2) = int_ord (i1, i2)
   17.87 +  | pattern_ord (p1, p2) = int_ord (int_of_pattern p1, int_of_pattern p2)
   17.88 +
   17.89 +
   17.90 +(* scanning patterns from strings *)
   17.91 +
   17.92 +(*
   17.93 +  The pattern language is cumbersome to use in other structures. Strings are a more
   17.94 +  lightweight representation. Scanning patterns from strings should be performed at
   17.95 +  compile time to avoid the parsing overhead at runtime.
   17.96 +*)
   17.97 +
   17.98 +val kind = Scan.many1 Symbol.is_ascii_letter >> (Argo_Expr.kind_of_string o implode)
   17.99 +val num = Scan.many1 Symbol.is_ascii_digit >> (the o Int.fromString o implode)
  17.100 +val integer = $$ "-" |-- num >> ~ || num
  17.101 +val blank = Scan.many1 Symbol.is_ascii_blank >> K ()
  17.102 +
  17.103 +fun pattern xs = (
  17.104 +  kind >> (P o rpair []) ||
  17.105 +  $$ "!" >> K X ||
  17.106 +  $$ "(" -- $$ "#" -- blank |-- pattern --| $$ ")" >> M ||
  17.107 +  $$ "(" -- $$ "?" -- blank |-- num --| $$ ")" >> V ||
  17.108 +  $$ "(" -- Scan.this_string "num" -- blank |-- integer --| $$ ")" >>
  17.109 +    (E o Argo_Expr.mk_num o Rat.of_int) ||
  17.110 +  $$ "(" |-- kind --| blank --| $$ "_" --| $$ ")" >> A ||
  17.111 +  $$ "(" |-- kind -- Scan.repeat1 (blank |-- pattern) --| $$ ")" >> P) xs
  17.112 +
  17.113 +fun scan s = fst (pattern (map str (String.explode s) @ [""]))
  17.114 +
  17.115 +
  17.116 +(* pattern matching *)
  17.117 +
  17.118 +exception PATTERN of unit
  17.119 +
  17.120 +(*
  17.121 +  The environment stores the matched expressions for the pattern placeholders.
  17.122 +  The expression for an indexed placeholder (V i) can be retrieved by "get env i".
  17.123 +  The argument expressions for an n-ary placeholder (A k) can be retrieved by "get_all env".
  17.124 +*)
  17.125 +
  17.126 +type env = Argo_Expr.expr list Inttab.table
  17.127 +
  17.128 +val empty_env: env = Inttab.empty
  17.129 +fun get_all env = Inttab.lookup_list env 0
  17.130 +fun get env i = hd (Inttab.lookup_list env i)
  17.131 +
  17.132 +fun depth_of (V _) = 0
  17.133 +  | depth_of (E _) = 0
  17.134 +  | depth_of (A _) = 1
  17.135 +  | depth_of (P (_, ps)) = 1 + fold (Integer.max o depth_of) ps 0
  17.136 +  | depth_of (M p) = depth_of p
  17.137 +  | depth_of X = 0
  17.138 +
  17.139 +fun match_list f k k' env = if k = k' then f env else raise PATTERN ()
  17.140 +
  17.141 +fun match (V i) e env = Inttab.update_new (i, [e]) env
  17.142 +  | match (A k) (Argo_Expr.E (k', es)) env = match_list (Inttab.update_new (0, es)) k k' env
  17.143 +  | match (P (k, ps)) (Argo_Expr.E (k', es)) env = match_list (fold2 match ps es) k k' env
  17.144 +  | match _ _ _ = raise Fail "bad pattern"
  17.145 +
  17.146 +fun unfold_index env (V i) _ = get env i
  17.147 +  | unfold_index _ (E e) _ = e
  17.148 +  | unfold_index env (P (k, ps)) e = Argo_Expr.E (k, map (fn p => unfold_index env p e) ps)
  17.149 +  | unfold_index _ X e = e
  17.150 +  | unfold_index _ _ _ = raise Fail "bad pattern"
  17.151 +
  17.152 +fun unfold_pattern env (V i) = get env i
  17.153 +  | unfold_pattern _ (E e) = e
  17.154 +  | unfold_pattern env (A k) = Argo_Expr.E (k, get_all env)
  17.155 +  | unfold_pattern env (P (k, [M p])) = Argo_Expr.E (k, map (unfold_index env p) (get_all env))
  17.156 +  | unfold_pattern env (P (k, ps)) = Argo_Expr.E (k, map (unfold_pattern env) ps)
  17.157 +  | unfold_pattern _ _ = raise Fail "bad pattern"
  17.158 +
  17.159 +
  17.160 +(* conversions *)
  17.161 +
  17.162 +(*
  17.163 +  Conversions are atomic rewrite steps. For every conversion there is a corresponding
  17.164 +  inference step.
  17.165 +*)
  17.166 +
  17.167 +type conv = Argo_Expr.expr -> Argo_Expr.expr * Argo_Proof.conv
  17.168 +
  17.169 +fun keep e = (e, Argo_Proof.keep_conv)
  17.170 +
  17.171 +fun seq [] e = keep e
  17.172 +  | seq [cv] e = cv e
  17.173 +  | seq (cv :: cvs) e =
  17.174 +      let val ((e, c2), c1) = cv e |>> seq cvs
  17.175 +      in (e, Argo_Proof.mk_then_conv c1 c2) end
  17.176 +
  17.177 +fun args cv (Argo_Expr.E (k, es)) =
  17.178 +  let val (es, cs) = split_list (map cv es)
  17.179 +  in (Argo_Expr.E (k, es), Argo_Proof.mk_args_conv cs) end
  17.180 +
  17.181 +fun rewr r e _ = (e, Argo_Proof.mk_rewr_conv r)
  17.182 +
  17.183 +
  17.184 +(* context *)
  17.185 +
  17.186 +(*
  17.187 +  The context stores functions to flatten expressions and functions to rewrite expressions.
  17.188 +  Flattening an n-ary expression of kind k produces an expression whose arguments are not
  17.189 +  of kind k. For instance, flattening (and p (and q r)) produces (and p q r) where p, q and r
  17.190 +  are not conjunctions.
  17.191 +*)
  17.192 +
  17.193 +structure Pattab = Table(type key = pattern val ord = pattern_ord)
  17.194 +
  17.195 +type context = {
  17.196 +  flats:
  17.197 +    (Argo_Expr.kind * (int -> Argo_Expr.expr list -> (Argo_Proof.rewrite * Argo_Expr.expr) option))
  17.198 +      list, (* expressions that should be flattened before rewriting *)
  17.199 +  rewrs: (env -> (Argo_Proof.rewrite * pattern) option) list Pattab.table}
  17.200 +    (* Looking up matching rules is O(n). This could be optimized. *)
  17.201 +
  17.202 +fun mk_context flats rewrs: context = {flats=flats, rewrs=rewrs}
  17.203 +val context = mk_context [] Pattab.empty
  17.204 +
  17.205 +fun map_context map_flats map_rewrs ({flats, rewrs}: context) =
  17.206 +  mk_context (map_flats flats) (map_rewrs rewrs)
  17.207 +
  17.208 +fun flat lhs f =
  17.209 +  (case scan lhs of
  17.210 +    A k => map_context (cons (k, f)) I
  17.211 +  | _ => raise Fail "bad pattern")
  17.212 +
  17.213 +fun func lhs f = map_context I (Pattab.map_default (scan lhs, []) (fn fs => fs @ [f]))
  17.214 +fun rule r lhs rhs = func lhs (K (SOME (r, scan rhs)))
  17.215 +
  17.216 +
  17.217 +(* rewriting *)
  17.218 +
  17.219 +(*
  17.220 +  Rewriting proceeds bottom-up. Whenever a rewrite rule with placeholders is used,
  17.221 +  the arguments are again rewritten, but only up to depth of the placeholders within the
  17.222 +  matched pattern.
  17.223 +*)
  17.224 +
  17.225 +fun rewr_rule r env p = rewr r (unfold_pattern env p)
  17.226 +
  17.227 +fun try_apply p e f =
  17.228 +  let val env = match p e empty_env
  17.229 +  in (case f env of NONE => NONE | SOME (r, p) => SOME (r, env, p)) end
  17.230 +  handle PATTERN () => NONE
  17.231 +
  17.232 +fun all_args cv k (e as Argo_Expr.E (k', _)) = if k = k' then args (all_args cv k) e else cv e
  17.233 +fun all_args_of k (e as Argo_Expr.E (k', es)) = if k = k' then maps (all_args_of k) es else [e]
  17.234 +fun kind_depth_of k (Argo_Expr.E (k', es)) =
  17.235 +  if k = k' then 1 + fold (Integer.max o kind_depth_of k) es 0 else 0
  17.236 +
  17.237 +fun descend cv flats (e as Argo_Expr.E (k, _)) =
  17.238 +  if AList.defined Argo_Expr.eq_kind flats k then all_args cv k e
  17.239 +  else args cv e
  17.240 +
  17.241 +fun flatten flats (e as Argo_Expr.E (k, _)) =
  17.242 +  (case AList.lookup Argo_Expr.eq_kind flats k of
  17.243 +    NONE => keep e
  17.244 +  | SOME f =>
  17.245 +      (case f (kind_depth_of k e) (all_args_of k e) of
  17.246 +        NONE => keep e
  17.247 +      | SOME (r, e') => rewr r e' e))
  17.248 +
  17.249 +fun exhaust cv rewrs e =
  17.250 +  (case Pattab.get_first (fn (p, fs) => get_first (try_apply p e) fs) rewrs of
  17.251 +    NONE => keep e
  17.252 +  | SOME (r, env, p) => seq [rewr_rule r env p, cv (depth_of p)] e)
  17.253 +
  17.254 +fun norm (cx as {flats, rewrs}: context) d e =
  17.255 +  seq [
  17.256 +    if d = 0 then keep else descend (norm cx (d - 1)) flats,
  17.257 +    flatten flats,
  17.258 +    exhaust (norm cx) rewrs] e
  17.259 +
  17.260 +fun rewrite cx = norm cx ~1   (* bottom-up rewriting *)
  17.261 +fun rewrite_top cx = norm cx 0   (* top-down rewriting *)
  17.262 +
  17.263 +fun with_proof cv (e, p) prf =
  17.264 +  let
  17.265 +    val (e, c) = cv e
  17.266 +    val (p, prf) = Argo_Proof.mk_rewrite c p prf
  17.267 +  in ((e, p), prf) end
  17.268 +
  17.269 +end
    18.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    18.2 +++ b/src/Tools/Argo/argo_simplex.ML	Thu Sep 29 20:54:44 2016 +0200
    18.3 @@ -0,0 +1,672 @@
    18.4 +(*  Title:      Tools/Argo/argo_simplex.ML
    18.5 +    Author:     Sascha Boehme
    18.6 +
    18.7 +Linear arithmetic reasoning based on the simplex algorithm. It features:
    18.8 +
    18.9 + * simplification and normalization of arithmetic expressions
   18.10 + * decision procedure for reals
   18.11 +
   18.12 +These features might be added:
   18.13 +
   18.14 + * propagating implied inequality literals while assuming external knowledge
   18.15 + * propagating equalities for fixed variables to all other theory solvers
   18.16 + * pruning the tableau after new atoms have been added: eliminate unnecessary
   18.17 +   variables
   18.18 +
   18.19 +The implementation is inspired by:
   18.20 +
   18.21 +  Bruno Dutertre and Leonardo de Moura. A fast linear-arithmetic solver
   18.22 +  for DPLL(T). In Computer Aided Verification, pages 81-94. Springer, 2006.
   18.23 +*)
   18.24 +
   18.25 +signature ARGO_SIMPLEX =
   18.26 +sig
   18.27 +  (* simplification *)
   18.28 +  val simplify: Argo_Rewr.context -> Argo_Rewr.context
   18.29 +  
   18.30 +  (* context *)
   18.31 +  type context
   18.32 +  val context: context
   18.33 +
   18.34 +  (* enriching the context *)
   18.35 +  val add_atom: Argo_Term.term -> context -> Argo_Lit.literal option * context
   18.36 +
   18.37 +  (* main operations *)
   18.38 +  val prepare: context -> context
   18.39 +  val assume: Argo_Common.literal -> context -> Argo_Lit.literal Argo_Common.implied * context
   18.40 +  val check: context -> Argo_Lit.literal Argo_Common.implied * context
   18.41 +  val explain: Argo_Lit.literal -> context -> (Argo_Cls.clause * context) option
   18.42 +  val add_level: context -> context
   18.43 +  val backtrack: context -> context
   18.44 +end
   18.45 +
   18.46 +structure Argo_Simplex: ARGO_SIMPLEX =
   18.47 +struct
   18.48 +
   18.49 +(* expression functions *)
   18.50 +
   18.51 +fun mk_mul n e =
   18.52 +  if n = @0 then Argo_Expr.mk_num n
   18.53 +  else if n = @1 then e
   18.54 +  else Argo_Expr.mk_mul (Argo_Expr.mk_num n) e
   18.55 +
   18.56 +fun dest_mul (Argo_Expr.E (Argo_Expr.Mul, [Argo_Expr.E (Argo_Expr.Num n, _), e])) = (n, e)
   18.57 +  | dest_mul e = (@1, e)
   18.58 +
   18.59 +fun dest_factor e = fst (dest_mul e)
   18.60 +
   18.61 +fun mk_add [] = raise Fail "bad addition"
   18.62 +  | mk_add [e] = e
   18.63 +  | mk_add es = Argo_Expr.mk_add es
   18.64 +
   18.65 +fun dest_ineq (Argo_Expr.E (Argo_Expr.Le, [e1, e2])) = SOME (false, e1, e2)
   18.66 +  | dest_ineq (Argo_Expr.E (Argo_Expr.Lt, [e1, e2])) = SOME (true, e1, e2)
   18.67 +  | dest_ineq _ = NONE
   18.68 +
   18.69 +
   18.70 +(* simplification *)
   18.71 +
   18.72 +(*
   18.73 +  Products are normalized either to a number or to the monomial form
   18.74 +    a * x
   18.75 +  where a is a non-zero number and x is a variable. If x is a product,
   18.76 +  it contains no number factors. The coefficient a is dropped if it is equal
   18.77 +  to one; instead of 1 * x the expression x is used.
   18.78 +
   18.79 +  No further normalization to non-linear products is applied. Hence, the
   18.80 +  products x * y and y * x will be treated as two different variables by the
   18.81 +  arithmetic decision procedure.
   18.82 +*)
   18.83 +
   18.84 +val mul_comm_rhs = Argo_Rewr.scan "(mul (? 2) (? 1))"
   18.85 +
   18.86 +fun norm_mul env =
   18.87 +  (case apply2 (Argo_Rewr.get env) (1, 2) of
   18.88 +    (Argo_Expr.E (Argo_Expr.Num n1, _), Argo_Expr.E (Argo_Expr.Num n2, _)) =>
   18.89 +      SOME (Argo_Proof.Rewr_Mul_Nums (n1, n2), Argo_Rewr.E (Argo_Expr.mk_num (n1 * n2)))
   18.90 +  | (Argo_Expr.E (Argo_Expr.Num n, _), _) =>
   18.91 +      if n = @0 then SOME (Argo_Proof.Rewr_Mul_Zero, Argo_Rewr.V 1)
   18.92 +      else if n = @1 then SOME (Argo_Proof.Rewr_Mul_One, Argo_Rewr.V 2)
   18.93 +      else NONE
   18.94 +  | (_, Argo_Expr.E (Argo_Expr.Num _, _)) => SOME (Argo_Proof.Rewr_Mul_Comm, mul_comm_rhs)
   18.95 +  | _ => NONE)
   18.96 +
   18.97 +(*
   18.98 +  Quotients are normalized either to a number or to the monomial form
   18.99 +    a * x
  18.100 +  where a is a non-zero number and x is a variable. If x is a quotient,
  18.101 +  both divident and divisor are not a number. The coefficient a is dropped
  18.102 +  if it is equal to one; instead of 1 * x the expression x is used.
  18.103 +
  18.104 +  No further normalization to quotients is applied. Hence, the
  18.105 +  expressions (x * z) / y and x * (z / y) will be treated as two different
  18.106 +  variables by the arithmetic decision procedure.
  18.107 +*)
  18.108 +
  18.109 +fun div_mul_rhs n e =
  18.110 +  let val pat = Argo_Rewr.P (Argo_Expr.Div, [Argo_Rewr.E e, Argo_Rewr.V 2])
  18.111 +  in Argo_Rewr.P (Argo_Expr.Mul, [Argo_Rewr.E (Argo_Expr.mk_num n), pat])  end
  18.112 +
  18.113 +fun div_inv_rhs n pat =
  18.114 +  let val inv_pat = Argo_Rewr.P (Argo_Expr.Div, map (Argo_Rewr.E o Argo_Expr.mk_num) [@1, n]) 
  18.115 +  in Argo_Rewr.P (Argo_Expr.Mul, [inv_pat, pat]) end
  18.116 +
  18.117 +fun norm_div env =
  18.118 +  (case apply2 (Argo_Rewr.get env) (1, 2) of
  18.119 +    (Argo_Expr.E (Argo_Expr.Num n1, _), Argo_Expr.E (Argo_Expr.Num n2, _)) =>
  18.120 +      if n2 = @0 then NONE
  18.121 +      else SOME (Argo_Proof.Rewr_Div_Nums (n1, n2), Argo_Rewr.E (Argo_Expr.mk_num (n1 / n2)))
  18.122 +  | (Argo_Expr.E (Argo_Expr.Num n, _), _) =>
  18.123 +      if n = @0 then SOME (Argo_Proof.Rewr_Div_Zero, Argo_Rewr.E (Argo_Expr.mk_num @0))
  18.124 +      else if n = @1 then NONE
  18.125 +      else SOME (Argo_Proof.Rewr_Div_Mul, div_mul_rhs n (Argo_Expr.mk_num @1))
  18.126 +  | (Argo_Expr.E (Argo_Expr.Mul, [Argo_Expr.E (Argo_Expr.Num n, _), e]), _) =>
  18.127 +      if n = @1 then NONE
  18.128 +      else SOME (Argo_Proof.Rewr_Div_Left, div_mul_rhs n e)
  18.129 +  | (_, Argo_Expr.E (Argo_Expr.Num n, _)) =>
  18.130 +      if n = @0 then NONE
  18.131 +      else if n = @1 then SOME (Argo_Proof.Rewr_Div_One, Argo_Rewr.V 1)
  18.132 +      else SOME (Argo_Proof.Rewr_Div_Inv, div_inv_rhs n (Argo_Rewr.V 1))
  18.133 +  | (_, Argo_Expr.E (Argo_Expr.Mul, [Argo_Expr.E (Argo_Expr.Num n, _), e])) =>
  18.134 +      let val pat = Argo_Rewr.P (Argo_Expr.Div, [Argo_Rewr.V 1, Argo_Rewr.E e])
  18.135 +      in SOME (Argo_Proof.Rewr_Div_Right, div_inv_rhs n pat) end
  18.136 +  | _ => NONE)
  18.137 +
  18.138 +(*
  18.139 +  Sums are flatten and normalized to the polynomial form
  18.140 +    a_0 + a_1 * x_1 + ... + a_n * x_n
  18.141 +  where all variables x_i are disjoint and where all coefficients a_i are
  18.142 +  non-zero numbers. Coefficients equal to one are dropped; instead of 1 * x_i
  18.143 +  the reduced monom x_i is used. The variables x_i are ordered based on the
  18.144 +  expression order to reduce the number of problem literals by sharing equal
  18.145 +  expressions.
  18.146 +*)
  18.147 +
  18.148 +fun add_monom_expr i n e (p, s, etab) =
  18.149 +  let val etab = Argo_Exprtab.map_default (e, (i, @0)) (apsnd (Rat.add n)) etab
  18.150 +  in ((n, Option.map fst (Argo_Exprtab.lookup etab e)) :: p, s, etab) end
  18.151 +
  18.152 +fun add_monom (_, Argo_Expr.E (Argo_Expr.Num n, _)) (p, s, etab) = ((n, NONE) :: p, s + n, etab)
  18.153 +  | add_monom (i, Argo_Expr.E (Argo_Expr.Mul, [Argo_Expr.E (Argo_Expr.Num n, _), e])) x =
  18.154 +      add_monom_expr i n e x
  18.155 +  | add_monom (i, e) x = add_monom_expr i @1 e x
  18.156 +
  18.157 +fun norm_add d es =
  18.158 +  let
  18.159 +    val (p1, s, etab) = fold_index add_monom es ([], @0, Argo_Exprtab.empty)
  18.160 +    val (p2, es) =
  18.161 +      []
  18.162 +      |> Argo_Exprtab.fold_rev (fn (e, (i, n)) => n <> @0 ? cons ((n, SOME i), mk_mul n e)) etab
  18.163 +      |> s <> @0 ? cons ((s, NONE), Argo_Expr.mk_num s)
  18.164 +      |> (fn [] => [((@0, NONE), Argo_Expr.mk_num @0)] | xs => xs)
  18.165 +      |> split_list
  18.166 +    val ps = (rev p1, p2)
  18.167 +  in
  18.168 +    if d = 1 andalso eq_list (op =) ps then NONE
  18.169 +    else SOME (Argo_Proof.Rewr_Add ps, mk_add es)
  18.170 +  end
  18.171 +
  18.172 +(*
  18.173 +  An equation between two arithmetic expressions is rewritten to a conjunction of two
  18.174 +  non-strict inequalities.
  18.175 +*)
  18.176 +
  18.177 +val eq_rhs = Argo_Rewr.scan "(and (le (? 1) (? 2)) (le (? 2) (? 1)))"
  18.178 +fun is_arith e = member (op =) [Argo_Expr.Real] (Argo_Expr.type_of e)
  18.179 +
  18.180 +fun norm_eq env =
  18.181 +  if is_arith (Argo_Rewr.get env 1) then SOME (Argo_Proof.Rewr_Eq_Le, eq_rhs)
  18.182 +  else NONE
  18.183 +
  18.184 +(*
  18.185 +  Arithmetic inequalities (less and less-than) are normalized to the normal form
  18.186 +    a_0 + a_1 * x_1 + ... + a_n * x_n ~ b
  18.187 +  or
  18.188 +    b ~ a_0 + a_1 * x_1 + ... + a_n * x_n
  18.189 +  such that most of the coefficients a_i are positive.
  18.190 +
  18.191 +  Arithmetic inequalities of the form
  18.192 +    a * x ~ b
  18.193 +  or
  18.194 +    b ~ a * x
  18.195 +  are normalized to the form
  18.196 +    x ~ c
  18.197 +  or
  18.198 +    c ~ x
  18.199 +  where c is a number.
  18.200 +*)
  18.201 +
  18.202 +fun mk_num_pat n = Argo_Rewr.E (Argo_Expr.mk_num n)
  18.203 +fun mk_cmp_pat k ps = Argo_Rewr.P (k, ps)
  18.204 +
  18.205 +fun norm_cmp_mul k r n =
  18.206 +  let
  18.207 +    fun mult i = Argo_Rewr.P (Argo_Expr.Mul, [mk_num_pat n, Argo_Rewr.V i])
  18.208 +    val ps = if n > @0 then [mult 1, mult 2] else [mult 2, mult 1]
  18.209 +  in SOME (Argo_Proof.Rewr_Ineq_Mul (r, n), mk_cmp_pat k ps) end
  18.210 +
  18.211 +fun count_factors pred es = fold (fn e => if pred (dest_factor e) then Integer.add 1 else I) es 0
  18.212 +
  18.213 +fun norm_cmp_swap k r es =
  18.214 +  let
  18.215 +    val pos = count_factors (fn n => n > @0) es
  18.216 +    val neg = count_factors (fn n => n < @0) es
  18.217 +    val keep = pos > neg orelse (pos = neg andalso dest_factor (hd es) > @0)
  18.218 +  in if keep then NONE else norm_cmp_mul k r @~1 end
  18.219 +
  18.220 +fun norm_cmp1 k r (Argo_Expr.E (Argo_Expr.Mul, [Argo_Expr.E (Argo_Expr.Num n, _), _])) =
  18.221 +      norm_cmp_mul k r (Rat.inv n)
  18.222 +  | norm_cmp1 k r (Argo_Expr.E (Argo_Expr.Add, Argo_Expr.E (Argo_Expr.Num n, _) :: _)) =
  18.223 +      let fun mk i = Argo_Rewr.P (Argo_Expr.Add, [Argo_Rewr.V i, mk_num_pat (~ n)])
  18.224 +      in SOME (Argo_Proof.Rewr_Ineq_Add (r, ~ n), mk_cmp_pat k [mk 1, mk 2]) end
  18.225 +  | norm_cmp1 k r (Argo_Expr.E (Argo_Expr.Add, es)) = norm_cmp_swap k r es
  18.226 +  | norm_cmp1 _ _ _ = NONE
  18.227 +
  18.228 +val nums_true_rhs = Argo_Rewr.scan "true"
  18.229 +val nums_false_rhs = Argo_Rewr.scan "false"
  18.230 +
  18.231 +val cmp_sub_rhs = map Argo_Rewr.scan ["(sub (? 1) (? 2))", "(num 0)"]
  18.232 +
  18.233 +fun norm_cmp k r pred env =
  18.234 +  (case apply2 (Argo_Rewr.get env) (1, 2) of
  18.235 +    (Argo_Expr.E (Argo_Expr.Num n1, _), Argo_Expr.E (Argo_Expr.Num n2, _)) =>
  18.236 +      let val b = pred n1 n2
  18.237 +      in SOME (Argo_Proof.Rewr_Ineq_Nums (r, b), if b then nums_true_rhs else nums_false_rhs) end
  18.238 +  | (Argo_Expr.E (Argo_Expr.Num _, _), e) => norm_cmp1 k r e
  18.239 +  | (e, Argo_Expr.E (Argo_Expr.Num _, _)) => norm_cmp1 k r e
  18.240 +  | _ => SOME (Argo_Proof.Rewr_Ineq_Sub r, mk_cmp_pat k cmp_sub_rhs))
  18.241 +
  18.242 +(*
  18.243 +  Arithmetic expressions are normalized in order to reduce the number of
  18.244 +  problem literals. Arithmetically equal expressions are normalized into
  18.245 +  syntactically equal expressions as much as possible.
  18.246 +*)
  18.247 +
  18.248 +val simplify =
  18.249 +  Argo_Rewr.rule Argo_Proof.Rewr_Neg
  18.250 +    "(neg (? 1))"
  18.251 +    "(mul (num -1) (? 1))" #>
  18.252 +  Argo_Rewr.rule Argo_Proof.Rewr_Sub
  18.253 +    "(sub (? 1) (? 2))"
  18.254 +    "(add (? 1) (mul (num -1) (? 2)))" #>
  18.255 +  Argo_Rewr.func "(mul (? 1) (? 2))" norm_mul #>
  18.256 +  Argo_Rewr.rule Argo_Proof.Rewr_Mul_Assoc
  18.257 +    "(mul (? 1) (mul (? 2) (? 3)))"
  18.258 +    "(mul (mul (? 1) (? 2)) (? 3))" #>
  18.259 +  Argo_Rewr.rule Argo_Proof.Rewr_Mul_Sum
  18.260 +    "(mul (? 1) (add _))"
  18.261 +    "(add (# (mul (? 1) !)))" #>
  18.262 +  Argo_Rewr.func "(div (? 1) (? 2))" norm_div #>
  18.263 +  Argo_Rewr.flat "(add _)" norm_add #>
  18.264 +  Argo_Rewr.rule Argo_Proof.Rewr_Min
  18.265 +    "(min (? 1) (? 2))"
  18.266 +    "(ite (le (? 1) (? 2)) (? 1) (? 2))" #>
  18.267 +  Argo_Rewr.rule Argo_Proof.Rewr_Max
  18.268 +    "(max (? 1) (? 2))"
  18.269 +    "(ite (le (? 1) (? 2)) (? 2) (? 1))" #>
  18.270 +  Argo_Rewr.rule Argo_Proof.Rewr_Abs
  18.271 +    "(abs (? 1))"
  18.272 +    "(ite (le (num 0) (? 1)) (? 1) (neg (? 1)))" #>
  18.273 +  Argo_Rewr.func "(eq (? 1) (? 2))" norm_eq #>
  18.274 +  Argo_Rewr.func "(le (? 1) (? 2))" (norm_cmp Argo_Expr.Le Argo_Proof.Le Rat.le) #>
  18.275 +  Argo_Rewr.func "(lt (? 1) (? 2))" (norm_cmp Argo_Expr.Lt Argo_Proof.Lt Rat.lt)
  18.276 +
  18.277 +
  18.278 +(* extended rationals *)
  18.279 +
  18.280 +(*
  18.281 +  Extended rationals (c, k) are reals (c + k * e) where e is some small positive real number.
  18.282 +  Extended rationals are used to represent a strict inequality by a non-strict inequality:
  18.283 +    c < x  ~~  c + k * e <= e
  18.284 +    x < c  ~~  x <= c - k * e
  18.285 +*)
  18.286 +
  18.287 +type erat = Rat.rat * Rat.rat
  18.288 +
  18.289 +val erat_zero = (@0, @0)
  18.290 +
  18.291 +fun add (c1, k1) (c2, k2) = (c1 + c2, k1 + k2)
  18.292 +fun sub (c1, k1) (c2, k2) = (c1 - c2, k1 - k2)
  18.293 +fun mul n (c, k) = (n * c, n * k)
  18.294 +
  18.295 +val erat_ord = prod_ord Rat.ord Rat.ord
  18.296 +
  18.297 +fun less_eq n1 n2 = (erat_ord (n1, n2) <> GREATER)
  18.298 +fun less n1 n2 = (erat_ord (n1, n2) = LESS)
  18.299 +
  18.300 +
  18.301 +(* term functions *)
  18.302 +
  18.303 +fun dest_monom (Argo_Term.T (_, Argo_Expr.Mul, [Argo_Term.T (_, Argo_Expr.Num n, _), t])) = (t, n)
  18.304 +  | dest_monom t = (t, @1)
  18.305 +
  18.306 +datatype node = Var of Argo_Term.term | Num of Rat.rat
  18.307 +datatype ineq = Lower of Argo_Term.term * erat | Upper of Argo_Term.term * erat
  18.308 +
  18.309 +fun dest_node (Argo_Term.T (_, Argo_Expr.Num n, _)) = Num n
  18.310 +  | dest_node t = Var t
  18.311 +
  18.312 +fun dest_atom true (k as Argo_Expr.Le) t1 t2 = SOME (k, dest_node t1, dest_node t2)
  18.313 +  | dest_atom true (k as Argo_Expr.Lt) t1 t2 = SOME (k, dest_node t1, dest_node t2)
  18.314 +  | dest_atom false Argo_Expr.Le t1 t2 = SOME (Argo_Expr.Lt, dest_node t2, dest_node t1)
  18.315 +  | dest_atom false Argo_Expr.Lt t1 t2 = SOME (Argo_Expr.Le, dest_node t2, dest_node t1)
  18.316 +  | dest_atom _ _ _ _ = NONE
  18.317 +
  18.318 +fun ineq_of pol (Argo_Term.T (_, k, [t1, t2])) =
  18.319 +      (case dest_atom pol k t1 t2 of
  18.320 +        SOME (Argo_Expr.Le, Var x, Num n) => SOME (Upper (x, (n, @0)))
  18.321 +      | SOME (Argo_Expr.Le, Num n, Var x) => SOME (Lower (x, (n, @0)))
  18.322 +      | SOME (Argo_Expr.Lt, Var x, Num n) => SOME (Upper (x, (n, @~1)))
  18.323 +      | SOME (Argo_Expr.Lt, Num n, Var x) => SOME (Lower (x, (n, @1)))
  18.324 +      | _ => NONE)
  18.325 +  | ineq_of _ _ = NONE
  18.326 +
  18.327 +
  18.328 +(* proofs *)
  18.329 +
  18.330 +(*
  18.331 +  comment missing
  18.332 +*)
  18.333 +
  18.334 +fun mk_ineq is_lt = if is_lt then Argo_Expr.mk_lt else Argo_Expr.mk_le
  18.335 +fun ineq_rule_of is_lt = if is_lt then Argo_Proof.Lt else Argo_Proof.Le
  18.336 +
  18.337 +fun rewrite_top f = Argo_Rewr.rewrite_top (f Argo_Rewr.context)
  18.338 +
  18.339 +fun unnegate_conv (e as Argo_Expr.E (Argo_Expr.Not, [Argo_Expr.E (Argo_Expr.Le, [e1, e2])])) =
  18.340 +      Argo_Rewr.rewr (Argo_Proof.Rewr_Not_Ineq Argo_Proof.Le) (Argo_Expr.mk_lt e2 e1) e
  18.341 +  | unnegate_conv (e as Argo_Expr.E (Argo_Expr.Not, [Argo_Expr.E (Argo_Expr.Lt, [e1, e2])])) =
  18.342 +      Argo_Rewr.rewr (Argo_Proof.Rewr_Not_Ineq Argo_Proof.Lt) (Argo_Expr.mk_le e2 e1) e
  18.343 +  | unnegate_conv e = Argo_Rewr.keep e
  18.344 +
  18.345 +val norm_scale_conv = rewrite_top (
  18.346 +  Argo_Rewr.rule Argo_Proof.Rewr_Mul_Sum
  18.347 +    "(mul (? 1) (add _))"
  18.348 +    "(add (# (mul (? 1) !)))" #>
  18.349 +  Argo_Rewr.func "(mul (? 1) (? 2))" norm_mul)
  18.350 +
  18.351 +fun scale_conv r mk n e1 e2 =
  18.352 +  let
  18.353 +    fun scale e = Argo_Expr.mk_mul (Argo_Expr.mk_num n) e
  18.354 +    val (e1, e2) = if n > @0 then (scale e1, scale e2) else (scale e2, scale e1)
  18.355 +    val conv = Argo_Rewr.rewr (Argo_Proof.Rewr_Ineq_Mul (r, n)) (mk e1 e2)
  18.356 +  in Argo_Rewr.seq [conv, Argo_Rewr.args norm_scale_conv] end
  18.357 +
  18.358 +fun scale_ineq_conv n e =
  18.359 +  if n = @1 then Argo_Rewr.keep e
  18.360 +  else
  18.361 +    (case dest_ineq e of
  18.362 +      NONE => raise Fail "bad inequality"
  18.363 +    | SOME (is_lt, e1, e2) => scale_conv (ineq_rule_of is_lt) (mk_ineq is_lt) n e1 e2 e)
  18.364 +
  18.365 +fun simp_lit (n, (lit, p)) =
  18.366 +  let val conv = Argo_Rewr.seq [unnegate_conv, scale_ineq_conv n]
  18.367 +  in Argo_Rewr.with_proof conv (Argo_Lit.signed_expr_of lit, p) end
  18.368 +
  18.369 +val combine_conv = rewrite_top (Argo_Rewr.flat "(add _)" norm_add)
  18.370 +fun reduce_conv r = Argo_Rewr.rewr (Argo_Proof.Rewr_Ineq_Nums (r, false)) Argo_Expr.false_expr
  18.371 +
  18.372 +fun simp_combine es p prf =
  18.373 +  let
  18.374 +    fun dest e (is_lt, (es1, es2)) =
  18.375 +      let val (is_lt', e1, e2) = the (dest_ineq e)
  18.376 +      in (is_lt orelse is_lt', (e1 :: es1, e2 :: es2)) end
  18.377 +    val (is_lt, (es1, es2)) = fold_rev dest es (false, ([], []))
  18.378 +    val e = uncurry (mk_ineq is_lt) (apply2 Argo_Expr.mk_add (es1, es2))
  18.379 +    val conv = Argo_Rewr.seq [Argo_Rewr.args combine_conv, reduce_conv (ineq_rule_of is_lt)]
  18.380 +  in prf |> Argo_Rewr.with_proof conv (e, p) |>> snd end
  18.381 +
  18.382 +fun linear_combination nlps prf =
  18.383 +  let val ((es, ps), prf) = fold_map simp_lit nlps prf |>> split_list
  18.384 +  in prf |> Argo_Proof.mk_linear_comb ps |-> simp_combine es |-> Argo_Proof.mk_lemma [] end
  18.385 +
  18.386 +fun proof_of (lit, SOME p) (ls, prf) = ((lit, p), (ls, prf))
  18.387 +  | proof_of (lit, NONE) (ls, prf) =
  18.388 +      let val (p, prf) = Argo_Proof.mk_hyp lit prf
  18.389 +      in ((lit, p), (Argo_Lit.negate lit :: ls, prf)) end
  18.390 +
  18.391 +
  18.392 +(* tableau *)
  18.393 +
  18.394 +(*
  18.395 +  The tableau consists of equations x_i = a_i1 * x_1 + ... a_ik * x_k where
  18.396 +  the variable on the left-hand side is called a basic variable and
  18.397 +  the variables on the right-hand side are called non-basic variables.
  18.398 +
  18.399 +  For each basic variable, the polynom on the right-hand side is stored as a map
  18.400 +  from variables to coefficients. Only variables with non-zero coefficients are stored.
  18.401 +  The map is sorted by the term order of the variables for a deterministic order when
  18.402 +  analyzing a polynom.
  18.403 +
  18.404 +  Additionally, for each basic variable a boolean flag is kept that, when false,
  18.405 +  indicates that the current value of the basic variable might be outside its bounds.
  18.406 +  The value of a non-basic variable is always within its bounds.
  18.407 +
  18.408 +  The tableau is stored as a table indexed by variables. For each variable,
  18.409 +  both basic and non-basic, its current value is stored as extended rational
  18.410 +  along with either the equations or the occurrences.
  18.411 +*)
  18.412 +
  18.413 +type basic = bool * (Argo_Term.term * Rat.rat) Ord_List.T
  18.414 +type entry = erat * basic option
  18.415 +type tableau = entry Argo_Termtab.table
  18.416 +
  18.417 +fun dirty ms = SOME (false, ms)
  18.418 +fun checked ms = SOME (true, ms)
  18.419 +
  18.420 +fun basic_entry ms = (erat_zero, dirty ms)
  18.421 +val non_basic_entry: entry = (erat_zero, NONE)
  18.422 +
  18.423 +fun value_of tableau x =
  18.424 +  (case Argo_Termtab.lookup tableau x of
  18.425 +    NONE => erat_zero
  18.426 +  | SOME (v, _) => v)
  18.427 +
  18.428 +fun first_unchecked_basic tableau =
  18.429 +  Argo_Termtab.get_first (fn (y, (v, SOME (false, ms))) => SOME (y, v, ms) | _ => NONE) tableau
  18.430 +
  18.431 +local
  18.432 +
  18.433 +fun coeff_of ms x = the (AList.lookup Argo_Term.eq_term ms x)
  18.434 +
  18.435 +val eq_var = Argo_Term.eq_term
  18.436 +fun monom_ord sp = prod_ord Argo_Term.term_ord (K EQUAL) sp
  18.437 +
  18.438 +fun add_monom m ms = Ord_List.insert monom_ord m ms
  18.439 +fun update_monom (m as (x, a)) = if a = @0 then AList.delete eq_var x else AList.update eq_var m
  18.440 +
  18.441 +fun add_scaled_monom n (x, a) ms =
  18.442 +  (case AList.lookup eq_var ms x of
  18.443 +    NONE => add_monom (x, n * a) ms
  18.444 +  | SOME b => update_monom (x, n * a + b) ms)
  18.445 +
  18.446 +fun replace_polynom x n ms' ms = fold (add_scaled_monom n) ms' (AList.delete eq_var x ms)
  18.447 +
  18.448 +fun map_basic f (v, SOME (_, ms)) = f v ms
  18.449 +  | map_basic _ e = e
  18.450 +
  18.451 +fun map_basic_entries x f =
  18.452 +  let
  18.453 +    fun apply (e as (v, SOME (_, ms))) = if AList.defined eq_var ms x then f v ms else e
  18.454 +      | apply ve = ve
  18.455 +  in Argo_Termtab.map (K apply) end
  18.456 +
  18.457 +fun put_entry x e = Argo_Termtab.update (x, e)
  18.458 +
  18.459 +fun add_new_entry (y as Argo_Term.T (_, Argo_Expr.Add, ts)) tableau =
  18.460 +      let val ms = Ord_List.make monom_ord (map dest_monom ts)
  18.461 +      in fold (fn (x, _) => put_entry x non_basic_entry) ms (put_entry y (basic_entry ms) tableau) end
  18.462 +  | add_new_entry x tableau = put_entry x non_basic_entry tableau
  18.463 +
  18.464 +fun with_non_basic update_basic x f tableau =
  18.465 +  (case Argo_Termtab.lookup tableau x of
  18.466 +    NONE => tableau
  18.467 +  | SOME (v, NONE) => f v tableau
  18.468 +  | SOME (v, SOME (_, ms)) => if update_basic then put_entry x (v, dirty ms) tableau else tableau)
  18.469 +
  18.470 +in
  18.471 +
  18.472 +fun add_entry x tableau =
  18.473 +  if Argo_Termtab.defined tableau x then tableau
  18.474 +  else add_new_entry x tableau
  18.475 +
  18.476 +fun basic_within_bounds y = Argo_Termtab.map_entry y (map_basic (fn v => fn ms => (v, checked ms)))
  18.477 +
  18.478 +fun eliminate _ tableau = tableau
  18.479 +
  18.480 +fun update_non_basic pred x v' = with_non_basic true x (fn v =>
  18.481 +  let fun update_basic n v ms = (add v (mul (coeff_of ms x) n), dirty ms)
  18.482 +  in pred v ? put_entry x (v', NONE) o map_basic_entries x (update_basic (sub v' v)) end)
  18.483 +
  18.484 +fun update_pivot y vy ms x c v = with_non_basic false x (fn vx =>
  18.485 +  let
  18.486 +    val a = Rat.inv c
  18.487 +    val v' = mul a (sub v vy)
  18.488 +
  18.489 +    fun scale_or_drop (x', b) = if Argo_Term.eq_term (x', x) then NONE else SOME (x', ~ a * b)
  18.490 +    val ms = add_monom (y, a) (map_filter scale_or_drop ms)
  18.491 +
  18.492 +    fun update_basic v ms' =
  18.493 +      let val n = coeff_of ms' x
  18.494 +      in (add v (mul n v'), dirty (replace_polynom x n ms ms')) end
  18.495 +  in
  18.496 +    put_entry x (add vx v', dirty ms) #>
  18.497 +    put_entry y (v, NONE) #>
  18.498 +    map_basic_entries x update_basic
  18.499 +  end)
  18.500 +
  18.501 +end
  18.502 +
  18.503 +
  18.504 +(* bounds *)
  18.505 +
  18.506 +(*
  18.507 +  comment missing
  18.508 +*)
  18.509 +
  18.510 +type bound = (erat * Argo_Common.literal) option
  18.511 +type atoms = (erat * Argo_Term.term) list
  18.512 +type bounds_atoms = ((bound * bound) * (atoms * atoms))
  18.513 +type bounds = bounds_atoms Argo_Termtab.table
  18.514 +
  18.515 +val empty_bounds_atoms: bounds_atoms = ((NONE, NONE), ([], []))
  18.516 +
  18.517 +fun on_some pred (SOME (n, _)) = pred n
  18.518 +  | on_some _ NONE = false
  18.519 +
  18.520 +fun none_or_some pred (SOME (n, _)) = pred n
  18.521 +  | none_or_some _ NONE = true
  18.522 +
  18.523 +fun bound_of (SOME (n, _)) = n
  18.524 +  | bound_of NONE = raise Fail "bad bound"
  18.525 +
  18.526 +fun reason_of (SOME (_, r)) = r
  18.527 +  | reason_of NONE = raise Fail "bad reason"
  18.528 +
  18.529 +fun bounds_atoms_of bounds x = the_default empty_bounds_atoms (Argo_Termtab.lookup bounds x)
  18.530 +fun bounds_of bounds x = fst (bounds_atoms_of bounds x)
  18.531 +
  18.532 +fun put_bounds x bs bounds = Argo_Termtab.map_default (x, empty_bounds_atoms) (apfst (K bs)) bounds
  18.533 +
  18.534 +fun has_bound_atoms bounds x =
  18.535 +  (case Argo_Termtab.lookup bounds x of
  18.536 +    NONE => false
  18.537 +  | SOME (_, ([], [])) => false
  18.538 +  | _ => true)
  18.539 +
  18.540 +fun add_new_atom f x n t =
  18.541 +  let val ins = f (insert (eq_snd Argo_Term.eq_term) (n, t))
  18.542 +  in Argo_Termtab.map_default (x, empty_bounds_atoms) (apsnd ins) end
  18.543 +
  18.544 +fun del_atom x t =
  18.545 +  let fun eq_atom (t1, (_, t2)) = Argo_Term.eq_term (t1, t2)
  18.546 +  in Argo_Termtab.map_entry x (apsnd (apply2 (remove eq_atom t))) end
  18.547 +
  18.548 +
  18.549 +(* context *)
  18.550 +
  18.551 +type context = {
  18.552 +  tableau: tableau, (* values of variables and tableau entries for each variable *)
  18.553 +  bounds: bounds, (* bounds and unassigned atoms for each variable *)
  18.554 +  prf: Argo_Proof.context, (* proof context *)
  18.555 +  back: bounds list} (* stack storing previous bounds and unassigned atoms *)
  18.556 +
  18.557 +fun mk_context tableau bounds prf back: context =
  18.558 +  {tableau=tableau, bounds=bounds, prf=prf, back=back}
  18.559 +
  18.560 +val context = mk_context Argo_Termtab.empty Argo_Termtab.empty Argo_Proof.simplex_context []
  18.561 +
  18.562 +
  18.563 +(* declaring atoms *)
  18.564 +
  18.565 +fun add_ineq_atom f t x n ({tableau, bounds, prf, back}: context) =
  18.566 +  (* TODO: check whether the atom is already known to hold *)
  18.567 +  (NONE, mk_context (add_entry x tableau) (add_new_atom f x n t bounds) prf back)
  18.568 +
  18.569 +fun add_atom t cx =
  18.570 +  (case ineq_of true t of
  18.571 +    SOME (Lower (x, n)) => add_ineq_atom apfst t x n cx
  18.572 +  | SOME (Upper (x, n)) => add_ineq_atom apsnd t x n cx
  18.573 +  | NONE => (NONE, cx))
  18.574 +
  18.575 +
  18.576 +(* preparing the solver after new atoms have been added *)
  18.577 +
  18.578 +(*
  18.579 +  Variables that do not directly occur in atoms can be eliminated from the tableau
  18.580 +  since no bounds will ever limit their value. This can reduce the tableau size
  18.581 +  substantially.
  18.582 +*)
  18.583 +
  18.584 +fun prepare ({tableau, bounds, prf, back}: context) =
  18.585 +  let fun drop (xe as (x, _)) = not (has_bound_atoms bounds x) ? eliminate xe
  18.586 +  in mk_context (Argo_Termtab.fold drop tableau tableau) bounds prf back end
  18.587 +
  18.588 +
  18.589 +(* assuming external knowledge *)
  18.590 +
  18.591 +fun bounds_conflict r1 r2 ({tableau, bounds, prf, back}: context) =
  18.592 +  let
  18.593 +    val ((lp2, lp1), (lits, prf)) = ([], prf) |> proof_of r2 ||>> proof_of r1
  18.594 +    val (p, prf) = linear_combination [(@~1, lp1), (@1, lp2)] prf
  18.595 +  in (Argo_Common.Conflict (lits, p), mk_context tableau bounds prf back) end
  18.596 +
  18.597 +fun assume_bounds order x c bs ({tableau, bounds, prf, back}: context) =
  18.598 +  let
  18.599 +    val lits = []
  18.600 +    val bounds = put_bounds x bs bounds
  18.601 +    val tableau = update_non_basic (fn v => erat_ord (v, c) = order) x c tableau
  18.602 +  in (Argo_Common.Implied lits, mk_context tableau bounds prf back) end
  18.603 +
  18.604 +fun assume_lower r x c (low, upp) cx =
  18.605 +  if on_some (fn l => less_eq c l) low then (Argo_Common.Implied [], cx)
  18.606 +  else if on_some (fn u => less u c) upp then bounds_conflict r (reason_of upp) cx
  18.607 +  else assume_bounds LESS x c (SOME (c, r), upp) cx
  18.608 +
  18.609 +fun assume_upper r x c (low, upp) cx =
  18.610 +  if on_some (fn u => less_eq u c) upp then (Argo_Common.Implied [], cx)
  18.611 +  else if on_some (fn l => less c l) low then bounds_conflict (reason_of low) r cx
  18.612 +  else assume_bounds GREATER x c (low, SOME (c, r)) cx
  18.613 +
  18.614 +fun with_bounds r t f x n ({tableau, bounds, prf, back}: context) =
  18.615 +  f r x n (bounds_of bounds x) (mk_context tableau (del_atom x t bounds) prf back)
  18.616 +
  18.617 +fun choose f (SOME (Lower (x, n))) cx = f assume_lower x n cx
  18.618 +  | choose f (SOME (Upper (x, n))) cx = f assume_upper x n cx
  18.619 +  | choose _ NONE cx = (Argo_Common.Implied [], cx)
  18.620 +
  18.621 +fun assume (r as (lit, _)) cx =
  18.622 +  let val (t, pol) = Argo_Lit.dest lit
  18.623 +  in choose (with_bounds r t) (ineq_of pol t) cx end
  18.624 +
  18.625 +
  18.626 +(* checking for consistency and pending implications *)
  18.627 +
  18.628 +fun basic_bounds_conflict lower y ms ({tableau, bounds, prf, back}: context) =
  18.629 +  let
  18.630 +    val (a, low, upp) = if lower then (@1, fst, snd) else (@~1, snd, fst)
  18.631 +    fun coeff_proof f a x = apfst (pair a) o proof_of (reason_of (f (bounds_of bounds x)))
  18.632 +    fun monom_proof (x, a) = coeff_proof (if a < @0 then low else upp) a x
  18.633 +    val ((alp, alps), (lits, prf)) = ([], prf) |> coeff_proof low a y ||>> fold_map monom_proof ms
  18.634 +    val (p, prf) = linear_combination (alp :: alps) prf
  18.635 +  in (Argo_Common.Conflict (lits, p), mk_context tableau bounds prf back) end
  18.636 +
  18.637 +fun can_compensate ord tableau bounds (x, a) =
  18.638 +  let val (low, upp) = bounds_of bounds x
  18.639 +  in
  18.640 +    if Rat.ord (a, @0) = ord then none_or_some (fn u => less (value_of tableau x) u) upp
  18.641 +    else none_or_some (fn l => less l (value_of tableau x)) low
  18.642 +  end
  18.643 +
  18.644 +fun check (cx as {tableau, bounds, prf, back}: context) =
  18.645 +  (case first_unchecked_basic tableau of
  18.646 +    NONE => (Argo_Common.Implied [], cx)
  18.647 +  | SOME (y, v, ms) =>
  18.648 +      let val (low, upp) = bounds_of bounds y
  18.649 +      in
  18.650 +        if on_some (fn l => less v l) low then adjust GREATER true y v ms (bound_of low) cx
  18.651 +        else if on_some (fn u => less u v) upp then adjust LESS false y v ms (bound_of upp) cx
  18.652 +        else check (mk_context (basic_within_bounds y tableau) bounds prf back)
  18.653 +      end)
  18.654 +
  18.655 +and adjust ord lower y vy ms v (cx as {tableau, bounds, prf, back}: context) =
  18.656 +  (case find_first (can_compensate ord tableau bounds) ms of
  18.657 +    NONE => basic_bounds_conflict lower y ms cx
  18.658 +  | SOME (x, a) => check (mk_context (update_pivot y vy ms x a v tableau) bounds prf back))
  18.659 +
  18.660 +
  18.661 +(* explanations *)
  18.662 +
  18.663 +fun explain _ _ = NONE
  18.664 +
  18.665 +
  18.666 +(* backtracking *)
  18.667 +
  18.668 +fun add_level ({tableau, bounds, prf, back}: context) =
  18.669 +  mk_context tableau bounds prf (bounds :: back)
  18.670 +
  18.671 +fun backtrack ({back=[], ...}: context) = raise Empty
  18.672 +  | backtrack ({tableau, prf, back=bounds :: back, ...}: context) =
  18.673 +      mk_context tableau bounds prf back
  18.674 +
  18.675 +end
    19.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    19.2 +++ b/src/Tools/Argo/argo_solver.ML	Thu Sep 29 20:54:44 2016 +0200
    19.3 @@ -0,0 +1,168 @@
    19.4 +(*  Title:      Tools/Argo/argo_solver.ML
    19.5 +    Author:     Sascha Boehme
    19.6 +
    19.7 +The main interface to the Argo solver.
    19.8 +
    19.9 +The solver performs satisfiability checking for a given set of assertions. If these assertions
   19.10 +are unsatisfiable, a proof trace is returned. If these assertions are satisfiable, the computed
   19.11 +model can be queried or further assertions may be added.
   19.12 +*)
   19.13 +
   19.14 +signature ARGO_SOLVER =
   19.15 +sig
   19.16 +  type context
   19.17 +  val context: context
   19.18 +  val assert: Argo_Expr.expr list -> context -> context (* raises Argo_Expr.TYPE, Argo_Expr.EXPR
   19.19 +    and Argo_Proof.UNSAT *)
   19.20 +  val model_of: context -> string * Argo_Expr.typ -> bool option
   19.21 +end
   19.22 +
   19.23 +structure Argo_Solver: ARGO_SOLVER =
   19.24 +struct
   19.25 +
   19.26 +(* context *)
   19.27 +
   19.28 +type context = {
   19.29 +  next_axiom: int,
   19.30 +  prf: Argo_Proof.context,
   19.31 +  core: Argo_Core.context}
   19.32 +
   19.33 +fun mk_context next_axiom prf core: context = {next_axiom=next_axiom, prf=prf, core=core}
   19.34 +
   19.35 +val context = mk_context 0 Argo_Proof.solver_context Argo_Core.context
   19.36 +
   19.37 +
   19.38 +(* negation normal form *)
   19.39 +
   19.40 +fun nnf_nary r rhs env = SOME (r (length (Argo_Rewr.get_all env)), rhs)
   19.41 +
   19.42 +val not_and_rhs = Argo_Rewr.scan "(or (# (not !)))"
   19.43 +val not_or_rhs = Argo_Rewr.scan "(and (# (not !)))"
   19.44 +
   19.45 +val nnf =
   19.46 +  Argo_Rewr.rule Argo_Proof.Rewr_Not_True "(not true)" "false" #>
   19.47 +  Argo_Rewr.rule Argo_Proof.Rewr_Not_False "(not false)" "true" #>
   19.48 +  Argo_Rewr.rule Argo_Proof.Rewr_Not_Not "(not (not (? 1)))" "(? 1)" #>
   19.49 +  Argo_Rewr.func "(not (and _))" (nnf_nary Argo_Proof.Rewr_Not_And not_and_rhs) #>
   19.50 +  Argo_Rewr.func "(not (or _))" (nnf_nary Argo_Proof.Rewr_Not_Or not_or_rhs) #>
   19.51 +  Argo_Rewr.rule Argo_Proof.Rewr_Not_Iff "(not (iff (not (? 1)) (? 2)))" "(iff (? 1) (? 2))" #>
   19.52 +  Argo_Rewr.rule Argo_Proof.Rewr_Not_Iff "(not (iff (? 1) (not (? 2))))" "(iff (? 1) (? 2))" #>
   19.53 +  Argo_Rewr.rule Argo_Proof.Rewr_Not_Iff "(not (iff (? 1) (? 2)))" "(iff (not (? 1)) (? 2))"
   19.54 +
   19.55 +
   19.56 +(* propositional normalization *)
   19.57 +
   19.58 +(*
   19.59 +  Propositional expressions are transformed into literals in the clausifier. Having
   19.60 +  fewer literals results in faster solver execution. Normalizing propositional expressions
   19.61 +  turns similar expressions into equal expressions, for which the same literal can be used.
   19.62 +  The clausifier expects that only negation, disjunction, conjunction and equivalence form
   19.63 +  propositional expressions. Expressions may be simplified to truth or falsity, but both
   19.64 +  truth and falsity eventually occur nowhere inside expressions.
   19.65 +*)
   19.66 +
   19.67 +val e_true = Argo_Expr.true_expr
   19.68 +val e_false = Argo_Expr.false_expr
   19.69 +
   19.70 +fun first_index pred xs =
   19.71 +  let val i = find_index pred xs
   19.72 +  in if i >= 0 then SOME i else NONE end
   19.73 +
   19.74 +fun find_zero r_zero zero es =
   19.75 +  Option.map (fn i => (r_zero i, zero)) (first_index (curry Argo_Expr.eq_expr zero) es)
   19.76 +
   19.77 +fun find_duals _ _ _ [] = NONE
   19.78 +  | find_duals _ _ _ [_] = NONE
   19.79 +  | find_duals r_dual zero i (e :: es) =
   19.80 +      (case first_index (Argo_Expr.dual_expr e) es of
   19.81 +        SOME i' => SOME (r_dual (i, i + i' + 1), zero)
   19.82 +      | NONE => find_duals r_dual zero (i + 1) es)
   19.83 +
   19.84 +fun sort_nary r_sort one mk l es =
   19.85 +  let
   19.86 +    val n = length es
   19.87 +    fun add (i, e) = if Argo_Expr.eq_expr (e, one) then I else Argo_Exprtab.cons_list (e, i)
   19.88 +    fun dest (e, i) (es, is) = (e :: es, i :: is)
   19.89 +    val (es, iss) = Argo_Exprtab.fold_rev dest (fold_index add es Argo_Exprtab.empty) ([], [])
   19.90 +    fun identity is = length is = n andalso forall (op =) (map_index I is)
   19.91 +  in if l = 1 andalso identity (map hd iss) then NONE else (SOME (r_sort (n, iss), mk es)) end
   19.92 +
   19.93 +fun apply_first fs es = get_first (fn f => f es) fs
   19.94 +
   19.95 +fun norm_nary r_zero r_dual r_sort zero one mk l =
   19.96 +  apply_first [find_zero r_zero zero, find_duals r_dual zero 0, sort_nary r_sort one mk l]
   19.97 +
   19.98 +val norm_and = norm_nary Argo_Proof.Rewr_And_False Argo_Proof.Rewr_And_Dual Argo_Proof.Rewr_And_Sort
   19.99 +  e_false e_true Argo_Expr.mk_and
  19.100 +val norm_or = norm_nary Argo_Proof.Rewr_Or_True Argo_Proof.Rewr_Or_Dual Argo_Proof.Rewr_Or_Sort
  19.101 +  e_true e_false Argo_Expr.mk_or
  19.102 +
  19.103 +fun norm_iff env =
  19.104 +  let val e1 = Argo_Rewr.get env 1 and e2 = Argo_Rewr.get env 2
  19.105 +  in
  19.106 +    if Argo_Expr.dual_expr e1 e2 then SOME (Argo_Proof.Rewr_Iff_Dual, Argo_Rewr.E e_false)
  19.107 +    else
  19.108 +      (case Argo_Expr.expr_ord (e1, e2) of
  19.109 +        EQUAL => SOME (Argo_Proof.Rewr_Iff_Refl, Argo_Rewr.E e_true)
  19.110 +      | LESS => NONE
  19.111 +      | GREATER => SOME (Argo_Proof.Rewr_Iff_Symm, Argo_Rewr.E (Argo_Expr.mk_iff e2 e1)))
  19.112 +  end
  19.113 +
  19.114 +val norm_prop =
  19.115 +  Argo_Rewr.flat "(and _)" norm_and #>
  19.116 +  Argo_Rewr.flat "(or _)" norm_or #>
  19.117 +  Argo_Rewr.rule Argo_Proof.Rewr_Imp "(imp (? 1) (? 2))" "(or (not (? 1)) (? 2))" #>
  19.118 +  Argo_Rewr.rule Argo_Proof.Rewr_Iff_True "(iff true (? 1))" "(? 1)" #>
  19.119 +  Argo_Rewr.rule Argo_Proof.Rewr_Iff_False "(iff false (? 1))" "(not (? 1))" #>
  19.120 +  Argo_Rewr.rule Argo_Proof.Rewr_Iff_True "(iff (? 1) true)" "(? 1)" #>
  19.121 +  Argo_Rewr.rule Argo_Proof.Rewr_Iff_False "(iff (? 1) false)" "(not (? 1))" #>
  19.122 +  Argo_Rewr.rule Argo_Proof.Rewr_Iff_Not_Not "(iff (not (? 1)) (not (? 2)))" "(iff (? 1) (? 2))" #>
  19.123 +  Argo_Rewr.func "(iff (? 1) (? 2))" norm_iff
  19.124 +
  19.125 +
  19.126 +(* normalization of if-then-else expressions *)
  19.127 +
  19.128 +val simp_prop_ite_result =
  19.129 +  Argo_Rewr.scan "(and (or (not (? 1)) (? 2)) (or (? 1) (? 3)) (or (? 2) (? 3)))"
  19.130 +
  19.131 +val simp_ite_eq_result = Argo_Rewr.scan "(? 2)"
  19.132 +
  19.133 +fun simp_ite env =
  19.134 +  if Argo_Expr.type_of (Argo_Rewr.get env 2) = Argo_Expr.Bool then
  19.135 +    SOME (Argo_Proof.Rewr_Ite_Prop, simp_prop_ite_result)
  19.136 +  else if Argo_Expr.eq_expr (Argo_Rewr.get env 2, Argo_Rewr.get env 3) then
  19.137 +    SOME (Argo_Proof.Rewr_Ite_Eq, simp_ite_eq_result)
  19.138 +  else NONE
  19.139 +
  19.140 +val norm_ite =
  19.141 +  Argo_Rewr.rule Argo_Proof.Rewr_Ite_True "(ite true (? 1) (? 2))" "(? 1)" #>
  19.142 +  Argo_Rewr.rule Argo_Proof.Rewr_Ite_False "(ite false (? 1) (? 2))" "(? 2)" #>
  19.143 +  Argo_Rewr.func "(ite (? 1) (? 2) (? 3))" simp_ite
  19.144 +
  19.145 +
  19.146 +(* rewriting and normalizing axioms *)
  19.147 +
  19.148 +val simp_context = Argo_Rewr.context |> nnf |> norm_prop |> norm_ite |> Argo_Thy.simplify
  19.149 +val simp_axiom = Argo_Rewr.with_proof (Argo_Rewr.rewrite simp_context)
  19.150 +
  19.151 +
  19.152 +(* asserting axioms *)
  19.153 +
  19.154 +fun add_axiom e ({next_axiom, prf, core}: context) =
  19.155 +  let
  19.156 +    val _ = Argo_Expr.check e
  19.157 +    val (p, prf) = Argo_Proof.mk_axiom next_axiom prf
  19.158 +    val (ep, prf) = simp_axiom (e, p) prf 
  19.159 +    val (prf, core) = Argo_Clausify.clausify simp_context ep (prf, core)
  19.160 +  in mk_context (next_axiom + 1) prf core end
  19.161 +
  19.162 +fun assert es cx =
  19.163 +  let val {next_axiom, prf, core}: context = fold add_axiom es cx
  19.164 +  in mk_context next_axiom prf (Argo_Core.run core) end
  19.165 +
  19.166 +
  19.167 +(* models *)
  19.168 +
  19.169 +fun model_of ({core, ...}: context) = Argo_Core.model_of core
  19.170 +
  19.171 +end
    20.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    20.2 +++ b/src/Tools/Argo/argo_term.ML	Thu Sep 29 20:54:44 2016 +0200
    20.3 @@ -0,0 +1,152 @@
    20.4 +(*  Title:      Tools/Argo/argo_term.ML
    20.5 +    Author:     Sascha Boehme
    20.6 +
    20.7 +Internal language of the Argo solver.
    20.8 +
    20.9 +Terms are fully-shared via hash-consing. Alpha-equivalent terms have the same identifier.
   20.10 +*)
   20.11 +
   20.12 +signature ARGO_TERM =
   20.13 +sig
   20.14 +  (* data types *)
   20.15 +  type meta
   20.16 +  datatype term = T of meta * Argo_Expr.kind * term list
   20.17 +
   20.18 +  (* term operations *)
   20.19 +  val id_of: term -> int
   20.20 +  val expr_of: term -> Argo_Expr.expr
   20.21 +  val type_of: term -> Argo_Expr.typ
   20.22 +  val eq_term: term * term -> bool
   20.23 +  val term_ord: term * term -> order
   20.24 +
   20.25 +  (* context *)
   20.26 +  type context
   20.27 +  val context: context
   20.28 +
   20.29 +  (* identifying expressions *)
   20.30 +  datatype item = Expr of Argo_Expr.expr | Term of term
   20.31 +  datatype identified = New of term | Known of term
   20.32 +  val identify_item: item -> context -> identified * context
   20.33 +end
   20.34 +
   20.35 +structure Argo_Term: ARGO_TERM =
   20.36 +struct
   20.37 +
   20.38 +(* data types *)
   20.39 +
   20.40 +(*
   20.41 +  The type meta is intentionally hidden to prevent that functions outside of this structure
   20.42 +  are able to build terms. Meta stores the identifier of the term as well as the complete
   20.43 +  expression underlying the term.
   20.44 +*)
   20.45 +
   20.46 +datatype meta = M of int * Argo_Expr.expr
   20.47 +datatype term = T of meta * Argo_Expr.kind * term list
   20.48 +
   20.49 +
   20.50 +(* term operations *)
   20.51 +
   20.52 +fun id_of (T (M (id, _), _, _)) = id
   20.53 +fun expr_of (T (M (_, e), _, _)) = e
   20.54 +fun type_of t = Argo_Expr.type_of (expr_of t)
   20.55 +
   20.56 +(*
   20.57 +  Comparing terms is fast as only the identifiers are compared. No expressions need to
   20.58 +  be taken into account.
   20.59 +*)
   20.60 +
   20.61 +fun eq_term (t1, t2) = (id_of t1 = id_of t2)
   20.62 +fun term_ord (t1, t2) = int_ord (id_of t1, id_of t2)
   20.63 +
   20.64 +
   20.65 +(* sharing of terms *)
   20.66 +
   20.67 +(*
   20.68 +  Kinds are short representation of expressions. Constants and numbers carry additional
   20.69 +  information and have no arguments. Their kind is hence similar to them. All other expressions
   20.70 +  are stored in a flat way with identifiers of shared terms as arguments instead of expression
   20.71 +  as arguments.
   20.72 +*)
   20.73 +
   20.74 +datatype kind =
   20.75 +  Con of string * Argo_Expr.typ |
   20.76 +  Num of Rat.rat |
   20.77 +  Exp of int list
   20.78 +
   20.79 +fun kind_of (Argo_Expr.E (Argo_Expr.Con c, _)) _ = Con c
   20.80 +  | kind_of (Argo_Expr.E (Argo_Expr.Num n, _)) _ = Num n
   20.81 +  | kind_of (Argo_Expr.E (k, _)) is = Exp (Argo_Expr.int_of_kind k :: is)
   20.82 +
   20.83 +fun int_of_kind (Con _) = 1
   20.84 +  | int_of_kind (Num _) = 2
   20.85 +  | int_of_kind (Exp _) = 3
   20.86 +
   20.87 +fun kind_ord (Con c1, Con c2) = Argo_Expr.con_ord (c1, c2)
   20.88 +  | kind_ord (Num n1, Num n2) = Rat.ord (n1, n2)
   20.89 +  | kind_ord (Exp is1, Exp is2) = dict_ord int_ord (is1, is2)
   20.90 +  | kind_ord (k1, k2) = int_ord (int_of_kind k1, int_of_kind k2)
   20.91 +
   20.92 +structure Kindtab = Table(type key = kind val ord = kind_ord)
   20.93 +
   20.94 +(*
   20.95 +  The context keeps track of the next unused identifier as well as all shared terms,
   20.96 +  which are indexed by their unique kind. For each term, a boolean marker flag is stored.
   20.97 +  When set to true on an atom, the atom is already asserted to the solver core. When set to
   20.98 +  true on an if-then-else term, the term has already been lifted.
   20.99 +
  20.100 +  Zero is intentionally avoided as identifier, since literals use term identifiers
  20.101 +  with a sign as literal identifiers.
  20.102 +*)
  20.103 +
  20.104 +type context = {
  20.105 +  next_id: int,
  20.106 +  terms: (term * bool) Kindtab.table}
  20.107 +
  20.108 +fun mk_context next_id terms: context = {next_id=next_id, terms=terms}
  20.109 +
  20.110 +val context = mk_context 1 Kindtab.empty
  20.111 +
  20.112 +fun note_atom true kind (t, false) ({next_id, terms}: context) =
  20.113 +      mk_context next_id (Kindtab.update (kind, (t, true)) terms)
  20.114 +  | note_atom _ _ _ cx = cx
  20.115 +
  20.116 +fun with_unique_id kind is_atom (e as Argo_Expr.E (k, _)) ts ({next_id, terms}: context) =
  20.117 +  let val t = T (M (next_id, e), k, ts)
  20.118 +  in ((t, false), mk_context (next_id + 1) (Kindtab.update (kind, (t, is_atom)) terms)) end
  20.119 +
  20.120 +fun unique kind is_atom e ts (cx as {terms, ...}: context) =
  20.121 +  (case Kindtab.lookup terms kind of
  20.122 +    SOME tp => (tp, note_atom is_atom kind tp cx)
  20.123 +  | NONE => with_unique_id kind is_atom e ts cx)
  20.124 +
  20.125 +
  20.126 +(* identifying expressions *)
  20.127 +
  20.128 +(*
  20.129 +  Only atoms, i.e., boolean propositons, and if-then-else expressions need to be identified.
  20.130 +  Other terms are identified implicitly. The identification process works bottom-up.
  20.131 +
  20.132 +  The solver core needs to know whether an atom has already been added. Likewise, the clausifier
  20.133 +  needs to know whether an if-then-else expression has already been lifted. Therefore,
  20.134 +  the identified term is marked as either "new" when identified for the first time or
  20.135 +  "known" when it has already been identified before.
  20.136 +*)
  20.137 +
  20.138 +datatype item = Expr of Argo_Expr.expr | Term of term
  20.139 +datatype identified = New of term | Known of term
  20.140 +
  20.141 +fun identify_head is_atom e (ts, cx) = unique (kind_of e (map id_of ts)) is_atom e ts cx
  20.142 +
  20.143 +fun identify is_atom (e as Argo_Expr.E (_, es)) cx =
  20.144 +  identify_head is_atom e (fold_map (apfst fst oo identify false) es cx)
  20.145 +
  20.146 +fun identified (t, true) = Known t
  20.147 +  | identified (t, false) = New t
  20.148 +
  20.149 +fun identify_item (Expr e) cx = identify true e cx |>> identified
  20.150 +  | identify_item (Term (t as T (_, _, ts))) cx =
  20.151 +      identify_head true (expr_of t) (ts, cx) |>> identified
  20.152 +
  20.153 +end
  20.154 +
  20.155 +structure Argo_Termtab = Table(type key = Argo_Term.term val ord = Argo_Term.term_ord)
    21.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    21.2 +++ b/src/Tools/Argo/argo_thy.ML	Thu Sep 29 20:54:44 2016 +0200
    21.3 @@ -0,0 +1,125 @@
    21.4 +(*  Title:      Tools/Argo/argo_theory.ML
    21.5 +    Author:     Sascha Boehme
    21.6 +
    21.7 +Combination of all theory solvers.
    21.8 +
    21.9 +Currently, it is assumed that theories have distinct domains. Theory solvers do not
   21.10 +exchange knowledge among each other. This should be changed in the future. Relevant work is:
   21.11 +
   21.12 +  Greg Nelson and Derek C. Oppen. Simplification by cooperating decision procedures. In ACM
   21.13 +  Transactions on Programming Languages and Systems, 1(2):245-257, 1979.
   21.14 +
   21.15 +  Leonardo de Moura and Nikolaj Bj/orner. Model-based Theory Combination. In Electronic Notes
   21.16 +  in Theoretical Computer Science, volume 198(2), pages 37-49, 2008.
   21.17 +*)
   21.18 +
   21.19 +signature ARGO_THY =
   21.20 +sig
   21.21 +  (* context *)
   21.22 +  type context
   21.23 +  val context: context
   21.24 +
   21.25 +  (* simplification *)
   21.26 +  val simplify: Argo_Rewr.context -> Argo_Rewr.context
   21.27 +  
   21.28 +  (* enriching the context *)
   21.29 +  val add_atom: Argo_Term.term -> context -> Argo_Lit.literal option * context
   21.30 +
   21.31 +  (* main operations *)
   21.32 +  val prepare: context -> context
   21.33 +  val assume: Argo_Common.literal -> context -> Argo_Lit.literal Argo_Common.implied * context
   21.34 +  val check: context -> Argo_Lit.literal Argo_Common.implied * context
   21.35 +  val explain: Argo_Lit.literal -> context -> Argo_Cls.clause * context
   21.36 +  val add_level: context -> context
   21.37 +  val backtrack: context -> context
   21.38 +end
   21.39 +
   21.40 +structure Argo_Thy: ARGO_THY =
   21.41 +struct
   21.42 +
   21.43 +(* context *)
   21.44 +
   21.45 +type context = Argo_Cc.context * Argo_Simplex.context
   21.46 +
   21.47 +val context = (Argo_Cc.context, Argo_Simplex.context)
   21.48 +
   21.49 +fun map_cc f (cc, simplex) =
   21.50 +  let val (x, cc) = f cc
   21.51 +  in (x, (cc, simplex)) end
   21.52 +
   21.53 +fun map_simplex f (cc, simplex) =
   21.54 +  let val (x, simplex) = f simplex
   21.55 +  in (x, (cc, simplex)) end
   21.56 +
   21.57 +
   21.58 +(* simplification *)
   21.59 +
   21.60 +val simplify = Argo_Cc.simplify #> Argo_Simplex.simplify
   21.61 +
   21.62 +
   21.63 +(* enriching the context *)
   21.64 +
   21.65 +fun add_atom t (cc, simplex) =
   21.66 +  let
   21.67 +    val (lit1, cc) = Argo_Cc.add_atom t cc
   21.68 +    val (lit2, simplex) = Argo_Simplex.add_atom t simplex
   21.69 +  in
   21.70 +    (case fold (union Argo_Lit.eq_lit o the_list) [lit1, lit2] [] of
   21.71 +      [] => (NONE, (cc, simplex))
   21.72 +    | [lit] => (SOME lit, (cc, simplex))
   21.73 +    | _ => raise Fail "unsynchronized theory solvers")
   21.74 +  end
   21.75 +    
   21.76 +
   21.77 +
   21.78 +(* main operations *)
   21.79 +
   21.80 +fun prepare (cc, simplex) = (cc, Argo_Simplex.prepare simplex)
   21.81 +
   21.82 +local
   21.83 +
   21.84 +exception CONFLICT of Argo_Cls.clause * context
   21.85 +
   21.86 +datatype tag = All | Cc | Simplex
   21.87 +
   21.88 +fun apply f cx =
   21.89 +  (case f cx of
   21.90 +    (Argo_Common.Conflict cls, cx) => raise CONFLICT (cls, cx)
   21.91 +  | (Argo_Common.Implied lits, cx) => (lits, cx))
   21.92 +
   21.93 +fun with_lits tag f (txs, lits, cx) =
   21.94 +  let val (lits', cx) = f cx
   21.95 +  in (fold (fn l => cons (tag, (l, NONE))) lits' txs, union Argo_Lit.eq_lit lits' lits, cx) end
   21.96 +
   21.97 +fun apply0 (tag, f) = with_lits tag (apply f)
   21.98 +fun apply1 (tag, f) (tag', x) = if tag <> tag' then with_lits tag (apply (f x)) else I
   21.99 +
  21.100 +val assumes = [(Cc, map_cc o Argo_Cc.assume), (Simplex, map_simplex o Argo_Simplex.assume)]
  21.101 +val checks = [(Cc, map_cc Argo_Cc.check), (Simplex, map_simplex Argo_Simplex.check)]
  21.102 +
  21.103 +fun propagate ([], lits, cx) = (Argo_Common.Implied lits, cx)
  21.104 +  | propagate (txs, lits, cx) = propagate (fold_product apply1 assumes txs ([], lits, cx))
  21.105 +
  21.106 +in
  21.107 +
  21.108 +fun assume lp cx = propagate ([(All, lp)], [], cx)
  21.109 +  handle CONFLICT (cls, cx) => (Argo_Common.Conflict cls, cx)
  21.110 +
  21.111 +fun check cx = propagate (fold apply0 checks ([], [], cx))
  21.112 +  handle CONFLICT (cls, cx) => (Argo_Common.Conflict cls, cx)
  21.113 +
  21.114 +end
  21.115 +
  21.116 +fun explain lit (cc, simplex) =
  21.117 +  (case Argo_Cc.explain lit cc of
  21.118 +    SOME (cls, cc) => (cls, (cc, simplex))
  21.119 +  | NONE =>
  21.120 +      (case Argo_Simplex.explain lit simplex of
  21.121 +        SOME (cls, simplex) => (cls, (cc, simplex))
  21.122 +      | NONE => raise Fail "bad literal without explanation"))
  21.123 +
  21.124 +fun add_level (cc, simplex) = (Argo_Cc.add_level cc, Argo_Simplex.add_level simplex)
  21.125 +
  21.126 +fun backtrack (cc, simplex) = (Argo_Cc.backtrack cc, Argo_Simplex.backtrack simplex)
  21.127 +
  21.128 +end