src/HOL/Tools/Qelim/cooper.ML
author boehmes
Mon Aug 24 10:44:03 2009 +0200 (2009-08-24)
changeset 32398 40a0760a00ea
parent 32264 0be31453f698
child 32429 54758ca53fd6
permissions -rw-r--r--
stricter condition for (binary) integer relation
     1 (*  Title:      HOL/Tools/Qelim/cooper.ML
     2     Author:     Amine Chaieb, TU Muenchen
     3 *)
     4 
     5 signature COOPER =
     6  sig
     7   val cooper_conv : Proof.context -> conv
     8   exception COOPER of string * exn
     9 end;
    10 
    11 structure Cooper: COOPER =
    12 struct
    13 
    14 open Conv;
    15 open Normalizer;
    16 
    17 exception COOPER of string * exn;
    18 fun simp_thms_conv ctxt =
    19   Simplifier.rewrite (Simplifier.context ctxt HOL_basic_ss addsimps simp_thms);
    20 val FWD = Drule.implies_elim_list;
    21 
    22 val true_tm = @{cterm "True"};
    23 val false_tm = @{cterm "False"};
    24 val zdvd1_eq = @{thm "zdvd1_eq"};
    25 val presburger_ss = @{simpset} addsimps [zdvd1_eq];
    26 val lin_ss = presburger_ss addsimps (@{thm dvd_eq_mod_eq_0} :: zdvd1_eq :: @{thms zadd_ac});
    27 
    28 val iT = HOLogic.intT
    29 val bT = HOLogic.boolT;
    30 val dest_numeral = HOLogic.dest_number #> snd;
    31 
    32 val [miconj, midisj, mieq, mineq, milt, mile, migt, mige, midvd, mindvd, miP] = 
    33     map(instantiate' [SOME @{ctyp "int"}] []) @{thms "minf"};
    34 
    35 val [infDconj, infDdisj, infDdvd,infDndvd,infDP] = 
    36     map(instantiate' [SOME @{ctyp "int"}] []) @{thms "inf_period"};
    37 
    38 val [piconj, pidisj, pieq,pineq,pilt,pile,pigt,pige,pidvd,pindvd,piP] = 
    39     map (instantiate' [SOME @{ctyp "int"}] []) @{thms "pinf"};
    40 
    41 val [miP, piP] = map (instantiate' [SOME @{ctyp "bool"}] []) [miP, piP];
    42 
    43 val infDP = instantiate' (map SOME [@{ctyp "int"}, @{ctyp "bool"}]) [] infDP;
    44 
    45 val [[asetconj, asetdisj, aseteq, asetneq, asetlt, asetle, 
    46       asetgt, asetge, asetdvd, asetndvd,asetP],
    47      [bsetconj, bsetdisj, bseteq, bsetneq, bsetlt, bsetle, 
    48       bsetgt, bsetge, bsetdvd, bsetndvd,bsetP]]  = [@{thms "aset"}, @{thms "bset"}];
    49 
    50 val [miex, cpmi, piex, cppi] = [@{thm "minusinfinity"}, @{thm "cpmi"}, 
    51                                 @{thm "plusinfinity"}, @{thm "cppi"}];
    52 
    53 val unity_coeff_ex = instantiate' [SOME @{ctyp "int"}] [] @{thm "unity_coeff_ex"};
    54 
    55 val [zdvd_mono,simp_from_to,all_not_ex] = 
    56      [@{thm "zdvd_mono"}, @{thm "simp_from_to"}, @{thm "all_not_ex"}];
    57 
    58 val [dvd_uminus, dvd_uminus'] = @{thms "uminus_dvd_conv"};
    59 
    60 val eval_ss = presburger_ss addsimps [simp_from_to] delsimps [insert_iff,bex_triv];
    61 val eval_conv = Simplifier.rewrite eval_ss;
    62 
    63 (* recognising cterm without moving to terms *)
    64 
    65 datatype fm = And of cterm*cterm| Or of cterm*cterm| Eq of cterm | NEq of cterm 
    66             | Lt of cterm | Le of cterm | Gt of cterm | Ge of cterm
    67             | Dvd of cterm*cterm | NDvd of cterm*cterm | Nox
    68 
    69 fun whatis x ct = 
    70 ( case (term_of ct) of 
    71   Const("op &",_)$_$_ => And (Thm.dest_binop ct)
    72 | Const ("op |",_)$_$_ => Or (Thm.dest_binop ct)
    73 | Const ("op =",ty)$y$_ => if term_of x aconv y then Eq (Thm.dest_arg ct) else Nox
    74 | Const (@{const_name Not},_) $ (Const ("op =",_)$y$_) => 
    75   if term_of x aconv y then NEq (funpow 2 Thm.dest_arg ct) else Nox
    76 | Const (@{const_name HOL.less}, _) $ y$ z =>
    77    if term_of x aconv y then Lt (Thm.dest_arg ct) 
    78    else if term_of x aconv z then Gt (Thm.dest_arg1 ct) else Nox
    79 | Const (@{const_name HOL.less_eq}, _) $ y $ z => 
    80    if term_of x aconv y then Le (Thm.dest_arg ct) 
    81    else if term_of x aconv z then Ge (Thm.dest_arg1 ct) else Nox
    82 | Const (@{const_name Ring_and_Field.dvd},_)$_$(Const(@{const_name HOL.plus},_)$y$_) =>
    83    if term_of x aconv y then Dvd (Thm.dest_binop ct ||> Thm.dest_arg) else Nox 
    84 | Const (@{const_name Not},_) $ (Const (@{const_name Ring_and_Field.dvd},_)$_$(Const(@{const_name "HOL.plus"},_)$y$_)) =>
    85    if term_of x aconv y then 
    86    NDvd (Thm.dest_binop (Thm.dest_arg ct) ||> Thm.dest_arg) else Nox 
    87 | _ => Nox)
    88   handle CTERM _ => Nox; 
    89 
    90 fun get_pmi_term t = 
    91   let val (x,eq) = 
    92      (Thm.dest_abs NONE o Thm.dest_arg o snd o Thm.dest_abs NONE o Thm.dest_arg)
    93         (Thm.dest_arg t)
    94 in (Thm.cabs x o Thm.dest_arg o Thm.dest_arg) eq end;
    95 
    96 val get_pmi = get_pmi_term o cprop_of;
    97 
    98 val p_v' = @{cpat "?P' :: int => bool"}; 
    99 val q_v' = @{cpat "?Q' :: int => bool"};
   100 val p_v = @{cpat "?P:: int => bool"};
   101 val q_v = @{cpat "?Q:: int => bool"};
   102 
   103 fun myfwd (th1, th2, th3) p q 
   104       [(th_1,th_2,th_3), (th_1',th_2',th_3')] = 
   105   let  
   106    val (mp', mq') = (get_pmi th_1, get_pmi th_1')
   107    val mi_th = FWD (instantiate ([],[(p_v,p),(q_v,q), (p_v',mp'),(q_v',mq')]) th1) 
   108                    [th_1, th_1']
   109    val infD_th = FWD (instantiate ([],[(p_v,mp'), (q_v, mq')]) th3) [th_3,th_3']
   110    val set_th = FWD (instantiate ([],[(p_v,p), (q_v,q)]) th2) [th_2, th_2']
   111   in (mi_th, set_th, infD_th)
   112   end;
   113 
   114 val inst' = fn cts => instantiate' [] (map SOME cts);
   115 val infDTrue = instantiate' [] [SOME true_tm] infDP;
   116 val infDFalse = instantiate' [] [SOME false_tm] infDP;
   117 
   118 val cadd =  @{cterm "op + :: int => _"}
   119 val cmulC =  @{cterm "op * :: int => _"}
   120 val cminus =  @{cterm "op - :: int => _"}
   121 val cone =  @{cterm "1 :: int"}
   122 val cneg = @{cterm "uminus :: int => _"}
   123 val [addC, mulC, subC, negC] = map term_of [cadd, cmulC, cminus, cneg]
   124 val [zero, one] = [@{term "0 :: int"}, @{term "1 :: int"}];
   125 
   126 val is_numeral = can dest_numeral; 
   127 
   128 fun numeral1 f n = HOLogic.mk_number iT (f (dest_numeral n)); 
   129 fun numeral2 f m n = HOLogic.mk_number iT (f (dest_numeral m) (dest_numeral n));
   130 
   131 val [minus1,plus1] = 
   132     map (fn c => fn t => Thm.capply (Thm.capply c t) cone) [cminus,cadd];
   133 
   134 fun decomp_pinf x dvd inS [aseteq, asetneq, asetlt, asetle, 
   135                            asetgt, asetge,asetdvd,asetndvd,asetP,
   136                            infDdvd, infDndvd, asetconj,
   137                            asetdisj, infDconj, infDdisj] cp =
   138  case (whatis x cp) of
   139   And (p,q) => ([p,q], myfwd (piconj, asetconj, infDconj) (Thm.cabs x p) (Thm.cabs x q))
   140 | Or (p,q) => ([p,q], myfwd (pidisj, asetdisj, infDdisj) (Thm.cabs x p) (Thm.cabs x q))
   141 | Eq t => ([], K (inst' [t] pieq, FWD (inst' [t] aseteq) [inS (plus1 t)], infDFalse))
   142 | NEq t => ([], K (inst' [t] pineq, FWD (inst' [t] asetneq) [inS t], infDTrue))
   143 | Lt t => ([], K (inst' [t] pilt, FWD (inst' [t] asetlt) [inS t], infDFalse))
   144 | Le t => ([], K (inst' [t] pile, FWD (inst' [t] asetle) [inS (plus1 t)], infDFalse))
   145 | Gt t => ([], K (inst' [t] pigt, (inst' [t] asetgt), infDTrue))
   146 | Ge t => ([], K (inst' [t] pige, (inst' [t] asetge), infDTrue))
   147 | Dvd (d,s) => 
   148    ([],let val dd = dvd d
   149 	     in K (inst' [d,s] pidvd, FWD (inst' [d,s] asetdvd) [dd],FWD (inst' [d,s] infDdvd) [dd]) end)
   150 | NDvd(d,s) => ([],let val dd = dvd d
   151 	      in K (inst' [d,s] pindvd, FWD (inst' [d,s] asetndvd) [dd], FWD (inst' [d,s] infDndvd) [dd]) end)
   152 | _ => ([], K (inst' [cp] piP, inst' [cp] asetP, inst' [cp] infDP));
   153 
   154 fun decomp_minf x dvd inS [bseteq,bsetneq,bsetlt, bsetle, bsetgt,
   155                            bsetge,bsetdvd,bsetndvd,bsetP,
   156                            infDdvd, infDndvd, bsetconj,
   157                            bsetdisj, infDconj, infDdisj] cp =
   158  case (whatis x cp) of
   159   And (p,q) => ([p,q], myfwd (miconj, bsetconj, infDconj) (Thm.cabs x p) (Thm.cabs x q))
   160 | Or (p,q) => ([p,q], myfwd (midisj, bsetdisj, infDdisj) (Thm.cabs x p) (Thm.cabs x q))
   161 | Eq t => ([], K (inst' [t] mieq, FWD (inst' [t] bseteq) [inS (minus1 t)], infDFalse))
   162 | NEq t => ([], K (inst' [t] mineq, FWD (inst' [t] bsetneq) [inS t], infDTrue))
   163 | Lt t => ([], K (inst' [t] milt, (inst' [t] bsetlt), infDTrue))
   164 | Le t => ([], K (inst' [t] mile, (inst' [t] bsetle), infDTrue))
   165 | Gt t => ([], K (inst' [t] migt, FWD (inst' [t] bsetgt) [inS t], infDFalse))
   166 | Ge t => ([], K (inst' [t] mige,FWD (inst' [t] bsetge) [inS (minus1 t)], infDFalse))
   167 | Dvd (d,s) => ([],let val dd = dvd d
   168 	      in K (inst' [d,s] midvd, FWD (inst' [d,s] bsetdvd) [dd] , FWD (inst' [d,s] infDdvd) [dd]) end)
   169 | NDvd (d,s) => ([],let val dd = dvd d
   170 	      in K (inst' [d,s] mindvd, FWD (inst' [d,s] bsetndvd) [dd], FWD (inst' [d,s] infDndvd) [dd]) end)
   171 | _ => ([], K (inst' [cp] miP, inst' [cp] bsetP, inst' [cp] infDP))
   172 
   173     (* Canonical linear form for terms, formulae etc.. *)
   174 fun provelin ctxt t = Goal.prove ctxt [] [] t 
   175   (fn _ => EVERY [simp_tac lin_ss 1, TRY (Lin_Arith.tac ctxt 1)]);
   176 fun linear_cmul 0 tm = zero 
   177   | linear_cmul n tm = case tm of  
   178       Const (@{const_name HOL.plus}, _) $ a $ b => addC $ linear_cmul n a $ linear_cmul n b
   179     | Const (@{const_name HOL.times}, _) $ c $ x => mulC $ numeral1 (fn m => n * m) c $ x
   180     | Const (@{const_name HOL.minus}, _) $ a $ b => subC $ linear_cmul n a $ linear_cmul n b
   181     | (m as Const (@{const_name HOL.uminus}, _)) $ a => m $ linear_cmul n a
   182     | _ => numeral1 (fn m => n * m) tm;
   183 fun earlier [] x y = false 
   184 	| earlier (h::t) x y = 
   185     if h aconv y then false else if h aconv x then true else earlier t x y; 
   186 
   187 fun linear_add vars tm1 tm2 = case (tm1, tm2) of 
   188     (Const (@{const_name HOL.plus}, _) $ (Const (@{const_name HOL.times}, _) $ c1 $ x1) $ r1,
   189     Const (@{const_name HOL.plus}, _) $ (Const (@{const_name HOL.times}, _) $ c2 $ x2) $ r2) =>
   190    if x1 = x2 then 
   191      let val c = numeral2 (curry op +) c1 c2
   192       in if c = zero then linear_add vars r1 r2
   193          else addC$(mulC$c$x1)$(linear_add vars r1 r2)
   194      end 
   195      else if earlier vars x1 x2 then addC $ (mulC $ c1 $ x1) $ linear_add vars r1 tm2
   196    else addC $ (mulC $ c2 $ x2) $ linear_add vars tm1 r2
   197  | (Const (@{const_name HOL.plus}, _) $ (Const (@{const_name HOL.times}, _) $ c1 $ x1) $ r1, _) =>
   198       addC $ (mulC $ c1 $ x1) $ linear_add vars r1 tm2
   199  | (_, Const (@{const_name HOL.plus}, _) $ (Const (@{const_name HOL.times}, _) $ c2 $ x2) $ r2) => 
   200       addC $ (mulC $ c2 $ x2) $ linear_add vars tm1 r2
   201  | (_, _) => numeral2 (curry op +) tm1 tm2;
   202  
   203 fun linear_neg tm = linear_cmul ~1 tm; 
   204 fun linear_sub vars tm1 tm2 = linear_add vars tm1 (linear_neg tm2); 
   205 
   206 
   207 fun lint vars tm =  if is_numeral tm then tm  else case tm of 
   208   Const (@{const_name HOL.uminus}, _) $ t => linear_neg (lint vars t)
   209 | Const (@{const_name HOL.plus}, _) $ s $ t => linear_add vars (lint vars s) (lint vars t)
   210 | Const (@{const_name HOL.minus}, _) $ s $ t => linear_sub vars (lint vars s) (lint vars t)
   211 | Const (@{const_name HOL.times}, _) $ s $ t =>
   212   let val s' = lint vars s  
   213       val t' = lint vars t  
   214   in if is_numeral s' then (linear_cmul (dest_numeral s') t') 
   215      else if is_numeral t' then (linear_cmul (dest_numeral t') s') 
   216      else raise COOPER ("Cooper Failed", TERM ("lint: not linear",[tm]))
   217   end 
   218  | _ => addC $ (mulC $ one $ tm) $ zero;
   219 
   220 fun lin (vs as x::_) (Const (@{const_name Not}, _) $ (Const (@{const_name HOL.less}, T) $ s $ t)) = 
   221     lin vs (Const (@{const_name HOL.less_eq}, T) $ t $ s)
   222   | lin (vs as x::_) (Const (@{const_name Not},_) $ (Const(@{const_name HOL.less_eq}, T) $ s $ t)) = 
   223     lin vs (Const (@{const_name HOL.less}, T) $ t $ s)
   224   | lin vs (Const (@{const_name Not},T)$t) = Const (@{const_name Not},T)$ (lin vs t)
   225   | lin (vs as x::_) (Const(@{const_name Ring_and_Field.dvd},_)$d$t) = 
   226     HOLogic.mk_binrel @{const_name Ring_and_Field.dvd} (numeral1 abs d, lint vs t)
   227   | lin (vs as x::_) ((b as Const("op =",_))$s$t) = 
   228      (case lint vs (subC$t$s) of 
   229       (t as a$(m$c$y)$r) => 
   230         if x <> y then b$zero$t
   231         else if dest_numeral c < 0 then b$(m$(numeral1 ~ c)$y)$r
   232         else b$(m$c$y)$(linear_neg r)
   233       | t => b$zero$t)
   234   | lin (vs as x::_) (b$s$t) = 
   235      (case lint vs (subC$t$s) of 
   236       (t as a$(m$c$y)$r) => 
   237         if x <> y then b$zero$t
   238         else if dest_numeral c < 0 then b$(m$(numeral1 ~ c)$y)$r
   239         else b$(linear_neg r)$(m$c$y)
   240       | t => b$zero$t)
   241   | lin vs fm = fm;
   242 
   243 fun lint_conv ctxt vs ct = 
   244 let val t = term_of ct
   245 in (provelin ctxt ((HOLogic.eq_const iT)$t$(lint vs t) |> HOLogic.mk_Trueprop))
   246              RS eq_reflection
   247 end;
   248 
   249 fun is_intrel_type T = T = @{typ "int => int => bool"};
   250 
   251 fun is_intrel (b$_$_) = is_intrel_type (fastype_of b)
   252   | is_intrel (@{term "Not"}$(b$_$_)) = is_intrel_type (fastype_of b)
   253   | is_intrel _ = false;
   254  
   255 fun linearize_conv ctxt vs ct = case term_of ct of
   256   Const(@{const_name Ring_and_Field.dvd},_)$d$t => 
   257   let 
   258     val th = binop_conv (lint_conv ctxt vs) ct
   259     val (d',t') = Thm.dest_binop (Thm.rhs_of th)
   260     val (dt',tt') = (term_of d', term_of t')
   261   in if is_numeral dt' andalso is_numeral tt' 
   262      then Conv.fconv_rule (arg_conv (Simplifier.rewrite presburger_ss)) th
   263      else 
   264      let 
   265       val dth = 
   266       ((if dest_numeral (term_of d') < 0 then 
   267           Conv.fconv_rule (arg_conv (arg1_conv (lint_conv ctxt vs)))
   268                            (Thm.transitive th (inst' [d',t'] dvd_uminus))
   269         else th) handle TERM _ => th)
   270       val d'' = Thm.rhs_of dth |> Thm.dest_arg1
   271      in
   272       case tt' of 
   273         Const(@{const_name HOL.plus},_)$(Const(@{const_name HOL.times},_)$c$_)$_ => 
   274         let val x = dest_numeral c
   275         in if x < 0 then Conv.fconv_rule (arg_conv (arg_conv (lint_conv ctxt vs)))
   276                                        (Thm.transitive dth (inst' [d'',t'] dvd_uminus'))
   277         else dth end
   278       | _ => dth
   279      end
   280   end
   281 | Const (@{const_name Not},_)$(Const(@{const_name Ring_and_Field.dvd},_)$_$_) => arg_conv (linearize_conv ctxt vs) ct
   282 | t => if is_intrel t 
   283       then (provelin ctxt ((HOLogic.eq_const bT)$t$(lin vs t) |> HOLogic.mk_Trueprop))
   284        RS eq_reflection
   285       else reflexive ct;
   286 
   287 val dvdc = @{cterm "op dvd :: int => _"};
   288 
   289 fun unify ctxt q = 
   290  let
   291   val (e,(cx,p)) = q |> Thm.dest_comb ||> Thm.dest_abs NONE
   292   val x = term_of cx 
   293   val ins = insert (op = : int * int -> bool)
   294   fun h (acc,dacc) t = 
   295    case (term_of t) of
   296     Const(s,_)$(Const(@{const_name HOL.times},_)$c$y)$ _ => 
   297     if x aconv y andalso member (op =)
   298       ["op =", @{const_name HOL.less}, @{const_name HOL.less_eq}] s
   299     then (ins (dest_numeral c) acc,dacc) else (acc,dacc)
   300   | Const(s,_)$_$(Const(@{const_name HOL.times},_)$c$y) => 
   301     if x aconv y andalso member (op =)
   302        [@{const_name HOL.less}, @{const_name HOL.less_eq}] s 
   303     then (ins (dest_numeral c) acc, dacc) else (acc,dacc)
   304   | Const(@{const_name Ring_and_Field.dvd},_)$_$(Const(@{const_name HOL.plus},_)$(Const(@{const_name HOL.times},_)$c$y)$_) => 
   305     if x aconv y then (acc,ins (dest_numeral c) dacc) else (acc,dacc)
   306   | Const("op &",_)$_$_ => h (h (acc,dacc) (Thm.dest_arg1 t)) (Thm.dest_arg t)
   307   | Const("op |",_)$_$_ => h (h (acc,dacc) (Thm.dest_arg1 t)) (Thm.dest_arg t)
   308   | Const (@{const_name Not},_)$_ => h (acc,dacc) (Thm.dest_arg t)
   309   | _ => (acc, dacc)
   310   val (cs,ds) = h ([],[]) p
   311   val l = Integer.lcms (cs union ds)
   312   fun cv k ct = 
   313     let val (tm as b$s$t) = term_of ct 
   314     in ((HOLogic.eq_const bT)$tm$(b$(linear_cmul k s)$(linear_cmul k t))
   315          |> HOLogic.mk_Trueprop |> provelin ctxt) RS eq_reflection end
   316   fun nzprop x = 
   317    let 
   318     val th = 
   319      Simplifier.rewrite lin_ss 
   320       (Thm.capply @{cterm Trueprop} (Thm.capply @{cterm "Not"} 
   321            (Thm.capply (Thm.capply @{cterm "op = :: int => _"} (Numeral.mk_cnumber @{ctyp "int"} x)) 
   322            @{cterm "0::int"})))
   323    in equal_elim (Thm.symmetric th) TrueI end;
   324   val notz = let val tab = fold Inttab.update 
   325                                (ds ~~ (map (fn x => nzprop (l div x)) ds)) Inttab.empty 
   326             in 
   327              (fn ct => (valOf (Inttab.lookup tab (ct |> term_of |> dest_numeral)) 
   328                 handle Option => (writeln "noz: Theorems-Table contains no entry for"; 
   329                                     Display.print_cterm ct ; raise Option)))
   330            end
   331   fun unit_conv t = 
   332    case (term_of t) of
   333    Const("op &",_)$_$_ => binop_conv unit_conv t
   334   | Const("op |",_)$_$_ => binop_conv unit_conv t
   335   | Const (@{const_name Not},_)$_ => arg_conv unit_conv t
   336   | Const(s,_)$(Const(@{const_name HOL.times},_)$c$y)$ _ => 
   337     if x=y andalso member (op =)
   338       ["op =", @{const_name HOL.less}, @{const_name HOL.less_eq}] s
   339     then cv (l div dest_numeral c) t else Thm.reflexive t
   340   | Const(s,_)$_$(Const(@{const_name HOL.times},_)$c$y) => 
   341     if x=y andalso member (op =)
   342       [@{const_name HOL.less}, @{const_name HOL.less_eq}] s
   343     then cv (l div dest_numeral c) t else Thm.reflexive t
   344   | Const(@{const_name Ring_and_Field.dvd},_)$d$(r as (Const(@{const_name HOL.plus},_)$(Const(@{const_name HOL.times},_)$c$y)$_)) => 
   345     if x=y then 
   346       let 
   347        val k = l div dest_numeral c
   348        val kt = HOLogic.mk_number iT k
   349        val th1 = inst' [Thm.dest_arg1 t, Thm.dest_arg t] 
   350              ((Thm.dest_arg t |> funpow 2 Thm.dest_arg1 |> notz) RS zdvd_mono)
   351        val (d',t') = (mulC$kt$d, mulC$kt$r)
   352        val thc = (provelin ctxt ((HOLogic.eq_const iT)$d'$(lint [] d') |> HOLogic.mk_Trueprop))
   353                    RS eq_reflection
   354        val tht = (provelin ctxt ((HOLogic.eq_const iT)$t'$(linear_cmul k r) |> HOLogic.mk_Trueprop))
   355                  RS eq_reflection
   356       in Thm.transitive th1 (Thm.combination (Drule.arg_cong_rule dvdc thc) tht) end                 
   357     else Thm.reflexive t
   358   | _ => Thm.reflexive t
   359   val uth = unit_conv p
   360   val clt =  Numeral.mk_cnumber @{ctyp "int"} l
   361   val ltx = Thm.capply (Thm.capply cmulC clt) cx
   362   val th = Drule.arg_cong_rule e (Thm.abstract_rule (fst (dest_Free x )) cx uth)
   363   val th' = inst' [Thm.cabs ltx (Thm.rhs_of uth), clt] unity_coeff_ex
   364   val thf = transitive th 
   365       (transitive (symmetric (beta_conversion true (cprop_of th' |> Thm.dest_arg1))) th')
   366   val (lth,rth) = Thm.dest_comb (cprop_of thf) |>> Thm.dest_arg |>> Thm.beta_conversion true
   367                   ||> beta_conversion true |>> Thm.symmetric
   368  in transitive (transitive lth thf) rth end;
   369 
   370 
   371 val emptyIS = @{cterm "{}::int set"};
   372 val insert_tm = @{cterm "insert :: int => _"};
   373 val mem_tm = Const("op :",[iT , HOLogic.mk_setT iT] ---> bT);
   374 fun mkISet cts = fold_rev (Thm.capply insert_tm #> Thm.capply) cts emptyIS;
   375 val cTrp = @{cterm "Trueprop"};
   376 val eqelem_imp_imp = (thm"eqelem_imp_iff") RS iffD1;
   377 val [A_tm,B_tm] = map (fn th => cprop_of th |> funpow 2 Thm.dest_arg |> Thm.dest_abs NONE |> snd |> Thm.dest_arg1 |> Thm.dest_arg 
   378                                       |> Thm.dest_abs NONE |> snd |> Thm.dest_fun |> Thm.dest_arg)
   379                       [asetP,bsetP];
   380 
   381 val D_tm = @{cpat "?D::int"};
   382 
   383 fun cooperex_conv ctxt vs q = 
   384 let 
   385 
   386  val uth = unify ctxt q
   387  val (x,p) = Thm.dest_abs NONE (Thm.dest_arg (Thm.rhs_of uth))
   388  val ins = insert (op aconvc)
   389  fun h t (bacc,aacc,dacc) = 
   390   case (whatis x t) of
   391     And (p,q) => h q (h p (bacc,aacc,dacc))
   392   | Or (p,q) => h q  (h p (bacc,aacc,dacc))
   393   | Eq t => (ins (minus1 t) bacc, 
   394              ins (plus1 t) aacc,dacc)
   395   | NEq t => (ins t bacc, 
   396               ins t aacc, dacc)
   397   | Lt t => (bacc, ins t aacc, dacc)
   398   | Le t => (bacc, ins (plus1 t) aacc,dacc)
   399   | Gt t => (ins t bacc, aacc,dacc)
   400   | Ge t => (ins (minus1 t) bacc, aacc,dacc)
   401   | Dvd (d,s) => (bacc,aacc,insert (op =) (term_of d |> dest_numeral) dacc)
   402   | NDvd (d,s) => (bacc,aacc,insert (op =) (term_of d|> dest_numeral) dacc)
   403   | _ => (bacc, aacc, dacc)
   404  val (b0,a0,ds) = h p ([],[],[])
   405  val d = Integer.lcms ds
   406  val cd = Numeral.mk_cnumber @{ctyp "int"} d
   407  val dt = term_of cd
   408  fun divprop x = 
   409    let 
   410     val th = 
   411      Simplifier.rewrite lin_ss 
   412       (Thm.capply @{cterm Trueprop} 
   413            (Thm.capply (Thm.capply dvdc (Numeral.mk_cnumber @{ctyp "int"} x)) cd))
   414    in equal_elim (Thm.symmetric th) TrueI end;
   415  val dvd = let val tab = fold Inttab.update
   416                                (ds ~~ (map divprop ds)) Inttab.empty in 
   417            (fn ct => (valOf (Inttab.lookup tab (term_of ct |> dest_numeral)) 
   418                     handle Option => (writeln "dvd: Theorems-Table contains no entry for"; 
   419                                       Display.print_cterm ct ; raise Option)))
   420            end
   421  val dp = 
   422    let val th = Simplifier.rewrite lin_ss 
   423       (Thm.capply @{cterm Trueprop} 
   424            (Thm.capply (Thm.capply @{cterm "op < :: int => _"} @{cterm "0::int"}) cd))
   425    in equal_elim (Thm.symmetric th) TrueI end;
   426     (* A and B set *)
   427    local 
   428      val insI1 = instantiate' [SOME @{ctyp "int"}] [] @{thm "insertI1"}
   429      val insI2 = instantiate' [SOME @{ctyp "int"}] [] @{thm "insertI2"}
   430    in
   431     fun provein x S = 
   432      case term_of S of
   433         Const(@{const_name Orderings.bot}, _) => error "Unexpected error in Cooper, please email Amine Chaieb"
   434       | Const(@{const_name insert}, _) $ y $ _ => 
   435          let val (cy,S') = Thm.dest_binop S
   436          in if term_of x aconv y then instantiate' [] [SOME x, SOME S'] insI1
   437          else implies_elim (instantiate' [] [SOME x, SOME S', SOME cy] insI2) 
   438                            (provein x S')
   439          end
   440    end
   441  
   442  val al = map (lint vs o term_of) a0
   443  val bl = map (lint vs o term_of) b0
   444  val (sl,s0,f,abths,cpth) = 
   445    if length (distinct (op aconv) bl) <= length (distinct (op aconv) al) 
   446    then  
   447     (bl,b0,decomp_minf,
   448      fn B => (map (fn th => implies_elim (Thm.instantiate ([],[(B_tm,B), (D_tm,cd)]) th) dp) 
   449                      [bseteq,bsetneq,bsetlt, bsetle, bsetgt,bsetge])@
   450                    (map (Thm.instantiate ([],[(B_tm,B), (D_tm,cd)])) 
   451                         [bsetdvd,bsetndvd,bsetP,infDdvd, infDndvd,bsetconj,
   452                          bsetdisj,infDconj, infDdisj]),
   453                        cpmi) 
   454      else (al,a0,decomp_pinf,fn A => 
   455           (map (fn th => implies_elim (Thm.instantiate ([],[(A_tm,A), (D_tm,cd)]) th) dp)
   456                    [aseteq,asetneq,asetlt, asetle, asetgt,asetge])@
   457                    (map (Thm.instantiate ([],[(A_tm,A), (D_tm,cd)])) 
   458                    [asetdvd,asetndvd, asetP, infDdvd, infDndvd,asetconj,
   459                          asetdisj,infDconj, infDdisj]),cppi)
   460  val cpth = 
   461   let
   462    val sths = map (fn (tl,t0) => 
   463                       if tl = term_of t0 
   464                       then instantiate' [SOME @{ctyp "int"}] [SOME t0] refl
   465                       else provelin ctxt ((HOLogic.eq_const iT)$tl$(term_of t0) 
   466                                  |> HOLogic.mk_Trueprop)) 
   467                    (sl ~~ s0)
   468    val csl = distinct (op aconvc) (map (cprop_of #> Thm.dest_arg #> Thm.dest_arg1) sths)
   469    val S = mkISet csl
   470    val inStab = fold (fn ct => fn tab => Termtab.update (term_of ct, provein ct S) tab) 
   471                     csl Termtab.empty
   472    val eqelem_th = instantiate' [SOME @{ctyp "int"}] [NONE,NONE, SOME S] eqelem_imp_imp
   473    val inS = 
   474      let 
   475       fun transmem th0 th1 = 
   476        Thm.equal_elim 
   477         (Drule.arg_cong_rule cTrp (Drule.fun_cong_rule (Drule.arg_cong_rule 
   478                ((Thm.dest_fun o Thm.dest_fun o Thm.dest_arg o cprop_of) th1) th0) S)) th1
   479       val tab = fold Termtab.update
   480         (map (fn eq => 
   481                 let val (s,t) = cprop_of eq |> Thm.dest_arg |> Thm.dest_binop 
   482                     val th = if term_of s = term_of t 
   483                              then valOf(Termtab.lookup inStab (term_of s))
   484                              else FWD (instantiate' [] [SOME s, SOME t] eqelem_th) 
   485                                 [eq, valOf(Termtab.lookup inStab (term_of s))]
   486                  in (term_of t, th) end)
   487                   sths) Termtab.empty
   488         in fn ct => 
   489           (valOf (Termtab.lookup tab (term_of ct))
   490            handle Option => (writeln "inS: No theorem for " ; Display.print_cterm ct ; raise Option))
   491         end
   492        val (inf, nb, pd) = divide_and_conquer (f x dvd inS (abths S)) p
   493    in [dp, inf, nb, pd] MRS cpth
   494    end
   495  val cpth' = Thm.transitive uth (cpth RS eq_reflection)
   496 in Thm.transitive cpth' ((simp_thms_conv ctxt then_conv eval_conv) (Thm.rhs_of cpth'))
   497 end;
   498 
   499 fun literals_conv bops uops env cv = 
   500  let fun h t =
   501   case (term_of t) of 
   502    b$_$_ => if member (op aconv) bops b then binop_conv h t else cv env t
   503  | u$_ => if member (op aconv) uops u then arg_conv h t else cv env t
   504  | _ => cv env t
   505  in h end;
   506 
   507 fun integer_nnf_conv ctxt env =
   508  nnf_conv then_conv literals_conv [HOLogic.conj, HOLogic.disj] [] env (linearize_conv ctxt);
   509 
   510 local
   511  val pcv = Simplifier.rewrite 
   512      (HOL_basic_ss addsimps (simp_thms @ (List.take(ex_simps,4)) 
   513                       @ [not_all,all_not_ex, ex_disj_distrib]))
   514  val postcv = Simplifier.rewrite presburger_ss
   515  fun conv ctxt p = 
   516   let val _ = ()
   517   in
   518    Qelim.gen_qelim_conv pcv postcv pcv (cons o term_of) 
   519       (OldTerm.term_frees (term_of p)) (linearize_conv ctxt) (integer_nnf_conv ctxt) 
   520       (cooperex_conv ctxt) p 
   521   end
   522   handle  CTERM s => raise COOPER ("Cooper Failed", CTERM s)
   523         | THM s => raise COOPER ("Cooper Failed", THM s) 
   524         | TYPE s => raise COOPER ("Cooper Failed", TYPE s) 
   525 in val cooper_conv = conv 
   526 end;
   527 end;
   528 
   529 
   530 
   531 structure Coopereif =
   532 struct
   533 
   534 open GeneratedCooper;
   535 
   536 fun cooper s = raise Cooper.COOPER ("Cooper oracle failed", ERROR s);
   537 fun i_of_term vs t = case t
   538  of Free (xn, xT) => (case AList.lookup (op aconv) vs t
   539      of NONE   => cooper "Variable not found in the list!"
   540       | SOME n => Bound n)
   541   | @{term "0::int"} => C 0
   542   | @{term "1::int"} => C 1
   543   | Term.Bound i => Bound i
   544   | Const(@{const_name HOL.uminus},_)$t' => Neg (i_of_term vs t')
   545   | Const(@{const_name HOL.plus},_)$t1$t2 => Add (i_of_term vs t1,i_of_term vs t2)
   546   | Const(@{const_name HOL.minus},_)$t1$t2 => Sub (i_of_term vs t1,i_of_term vs t2)
   547   | Const(@{const_name HOL.times},_)$t1$t2 => 
   548      (Mul (HOLogic.dest_number t1 |> snd, i_of_term vs t2)
   549     handle TERM _ => 
   550        (Mul (HOLogic.dest_number t2 |> snd, i_of_term vs t1)
   551         handle TERM _ => cooper "Reification: Unsupported kind of multiplication"))
   552   | _ => (C (HOLogic.dest_number t |> snd) 
   553            handle TERM _ => cooper "Reification: unknown term");
   554 
   555 fun qf_of_term ps vs t =  case t
   556  of Const("True",_) => T
   557   | Const("False",_) => F
   558   | Const(@{const_name HOL.less},_)$t1$t2 => Lt (Sub (i_of_term vs t1,i_of_term vs t2))
   559   | Const(@{const_name HOL.less_eq},_)$t1$t2 => Le (Sub(i_of_term vs t1,i_of_term vs t2))
   560   | Const(@{const_name Ring_and_Field.dvd},_)$t1$t2 => 
   561       (Dvd(HOLogic.dest_number t1 |> snd, i_of_term vs t2) handle _ => cooper "Reification: unsupported dvd")  (* FIXME avoid handle _ *)
   562   | @{term "op = :: int => _"}$t1$t2 => Eq (Sub (i_of_term vs t1,i_of_term vs t2))
   563   | @{term "op = :: bool => _ "}$t1$t2 => Iff(qf_of_term ps vs t1,qf_of_term ps vs t2)
   564   | Const("op &",_)$t1$t2 => And(qf_of_term ps vs t1,qf_of_term ps vs t2)
   565   | Const("op |",_)$t1$t2 => Or(qf_of_term ps vs t1,qf_of_term ps vs t2)
   566   | Const("op -->",_)$t1$t2 => Imp(qf_of_term ps vs t1,qf_of_term ps vs t2)
   567   | Const (@{const_name Not},_)$t' => Not(qf_of_term ps vs t')
   568   | Const("Ex",_)$Abs(xn,xT,p) => 
   569      let val (xn',p') = variant_abs (xn,xT,p)
   570          val vs' = (Free (xn',xT), 0) :: (map (fn(v,n) => (v,1+ n)) vs)
   571      in E (qf_of_term ps vs' p')
   572      end
   573   | Const("All",_)$Abs(xn,xT,p) => 
   574      let val (xn',p') = variant_abs (xn,xT,p)
   575          val vs' = (Free (xn',xT), 0) :: (map (fn(v,n) => (v,1+ n)) vs)
   576      in A (qf_of_term ps vs' p')
   577      end
   578   | _ =>(case AList.lookup (op aconv) ps t of 
   579            NONE => cooper "Reification: unknown term!"
   580          | SOME n => Closed n);
   581 
   582 local
   583  val ops = [@{term "op &"}, @{term "op |"}, @{term "op -->"}, @{term "op = :: bool => _"},
   584              @{term "op = :: int => _"}, @{term "op < :: int => _"}, 
   585              @{term "op <= :: int => _"}, @{term "Not"}, @{term "All:: (int => _) => _"}, 
   586              @{term "Ex:: (int => _) => _"}, @{term "True"}, @{term "False"}]
   587 fun ty t = Bool.not (fastype_of t = HOLogic.boolT)
   588 in
   589 fun term_bools acc t =
   590 case t of 
   591     (l as f $ a) $ b => if ty t orelse f mem ops then term_bools (term_bools acc l)b 
   592             else insert (op aconv) t acc
   593   | f $ a => if ty t orelse f mem ops then term_bools (term_bools acc f) a  
   594             else insert (op aconv) t acc
   595   | Abs p => term_bools acc (snd (variant_abs p))
   596   | _ => if ty t orelse t mem ops then acc else insert (op aconv) t acc
   597 end;
   598  
   599 fun myassoc2 l v =
   600     case l of
   601 	[] => NONE
   602       | (x,v')::xs => if v = v' then SOME x
   603 		      else myassoc2 xs v;
   604 
   605 fun term_of_i vs t = case t
   606  of C i => HOLogic.mk_number HOLogic.intT i
   607   | Bound n => the (myassoc2 vs n)
   608   | Neg t' => @{term "uminus :: int => _"} $ term_of_i vs t'
   609   | Add (t1, t2) => @{term "op + :: int => _"} $ term_of_i vs t1 $ term_of_i vs t2
   610   | Sub (t1, t2) => @{term "op - :: int => _"} $ term_of_i vs t1 $ term_of_i vs t2
   611   | Mul (i, t2) => @{term "op * :: int => _"} $
   612       HOLogic.mk_number HOLogic.intT i $ term_of_i vs t2
   613   | Cn (n, i, t') => term_of_i vs (Add (Mul (i, Bound n), t'));
   614 
   615 fun term_of_qf ps vs t = 
   616  case t of 
   617    T => HOLogic.true_const 
   618  | F => HOLogic.false_const
   619  | Lt t' => @{term "op < :: int => _ "}$ term_of_i vs t'$ @{term "0::int"}
   620  | Le t' => @{term "op <= :: int => _ "}$ term_of_i vs t' $ @{term "0::int"}
   621  | Gt t' => @{term "op < :: int => _ "}$ @{term "0::int"}$ term_of_i vs t'
   622  | Ge t' => @{term "op <= :: int => _ "}$ @{term "0::int"}$ term_of_i vs t'
   623  | Eq t' => @{term "op = :: int => _ "}$ term_of_i vs t'$ @{term "0::int"}
   624  | NEq t' => term_of_qf ps vs (Not (Eq t'))
   625  | Dvd(i,t') => @{term "op dvd :: int => _ "} $ 
   626     HOLogic.mk_number HOLogic.intT i $ term_of_i vs t'
   627  | NDvd(i,t')=> term_of_qf ps vs (Not(Dvd(i,t')))
   628  | Not t' => HOLogic.Not$(term_of_qf ps vs t')
   629  | And(t1,t2) => HOLogic.conj$(term_of_qf ps vs t1)$(term_of_qf ps vs t2)
   630  | Or(t1,t2) => HOLogic.disj$(term_of_qf ps vs t1)$(term_of_qf ps vs t2)
   631  | Imp(t1,t2) => HOLogic.imp$(term_of_qf ps vs t1)$(term_of_qf ps vs t2)
   632  | Iff(t1,t2) => @{term "op = :: bool => _"} $ term_of_qf ps vs t1 $ term_of_qf ps vs t2
   633  | Closed n => the (myassoc2 ps n)
   634  | NClosed n => term_of_qf ps vs (Not (Closed n))
   635  | _ => cooper "If this is raised, Isabelle/HOL or code generator is inconsistent!";
   636 
   637 fun cooper_oracle ct =
   638   let
   639     val thy = Thm.theory_of_cterm ct;
   640     val t = Thm.term_of ct;
   641     val (vs, ps) = pairself (map_index swap) (OldTerm.term_frees t, term_bools [] t);
   642   in
   643     Thm.cterm_of thy (Logic.mk_equals (HOLogic.mk_Trueprop t,
   644       HOLogic.mk_Trueprop (term_of_qf ps vs (pa (qf_of_term ps vs t)))))
   645   end;
   646 
   647 end;