src/HOL/Tools/groebner.ML
changeset 74269 f084d599bb44
parent 74249 9d9e7ed01dbb
child 74274 36f2c4a5c21b
equal deleted inserted replaced
74268:d01920a8b082 74269:f084d599bb44
   526  fun mk_exists ctxt v th = Drule.arg_cong_rule (ext ctxt (Thm.typ_of_cterm v))
   526  fun mk_exists ctxt v th = Drule.arg_cong_rule (ext ctxt (Thm.typ_of_cterm v))
   527    (Thm.abstract_rule (getname v) v th)
   527    (Thm.abstract_rule (getname v) v th)
   528  fun simp_ex_conv ctxt =
   528  fun simp_ex_conv ctxt =
   529    Simplifier.rewrite (put_simpset HOL_basic_ss ctxt addsimps @{thms simp_thms(39)})
   529    Simplifier.rewrite (put_simpset HOL_basic_ss ctxt addsimps @{thms simp_thms(39)})
   530 
   530 
   531 fun free_in v t = member op aconvc (Misc_Legacy.cterm_frees t) v;
   531 fun free_in v t = Cterms.defined (Misc_Legacy.cterm_frees t) v;
   532 
   532 
   533 val vsubst = let
   533 val vsubst = let
   534  fun vsubst (t,v) tm =
   534  fun vsubst (t,v) tm =
   535    (Thm.rhs_of o Thm.beta_conversion false) (Thm.apply (Thm.lambda v tm) t)
   535    (Thm.rhs_of o Thm.beta_conversion false) (Thm.apply (Thm.lambda v tm) t)
   536 in fold vsubst end;
   536 in fold vsubst end;
   735     let
   735     let
   736       val T = Thm.typ_of_cterm x;
   736       val T = Thm.typ_of_cterm x;
   737       val all = Thm.cterm_of ctxt (Const (\<^const_name>\<open>All\<close>, (T --> \<^typ>\<open>bool\<close>) --> \<^typ>\<open>bool\<close>))
   737       val all = Thm.cterm_of ctxt (Const (\<^const_name>\<open>All\<close>, (T --> \<^typ>\<open>bool\<close>) --> \<^typ>\<open>bool\<close>))
   738     in Thm.apply all (Thm.lambda x p) end
   738     in Thm.apply all (Thm.lambda x p) end
   739   val avs = Misc_Legacy.cterm_frees tm
   739   val avs = Misc_Legacy.cterm_frees tm
   740   val P' = fold mk_forall avs tm
   740   val P' = fold mk_forall (Cterms.list_set_rev avs) tm
   741   val th1 = initial_conv ctxt (mk_neg P')
   741   val th1 = initial_conv ctxt (mk_neg P')
   742   val (evs,bod) = strip_exists(concl th1) in
   742   val (evs,bod) = strip_exists(concl th1) in
   743    if is_forall bod then raise CTERM("ring: non-universal formula",[tm])
   743    if is_forall bod then raise CTERM("ring: non-universal formula",[tm])
   744    else
   744    else
   745    let
   745    let
   750     val th2 = fold (fn v => fn th => (Thm.forall_intr v th) COMP allI) evs (th2b RS PFalse)
   750     val th2 = fold (fn v => fn th => (Thm.forall_intr v th) COMP allI) evs (th2b RS PFalse)
   751     val th3 =
   751     val th3 =
   752       Thm.equal_elim
   752       Thm.equal_elim
   753         (Simplifier.rewrite (put_simpset HOL_basic_ss ctxt addsimps [not_ex RS sym])
   753         (Simplifier.rewrite (put_simpset HOL_basic_ss ctxt addsimps [not_ex RS sym])
   754           (th2 |> Thm.cprop_of)) th2
   754           (th2 |> Thm.cprop_of)) th2
   755     in specl avs
   755     in specl (Cterms.list_set_rev avs)
   756              ([[[HOLogic.mk_obj_eq th1, th3 RS PFalse'] MRS trans] MRS PFalse] MRS notnotD)
   756              ([[[HOLogic.mk_obj_eq th1, th3 RS PFalse'] MRS trans] MRS PFalse] MRS notnotD)
   757    end
   757    end
   758  end
   758  end
   759 fun ideal tms tm ord =
   759 fun ideal tms tm ord =
   760  let
   760  let
   793   fun is_defined v t =
   793   fun is_defined v t =
   794   let
   794   let
   795    val mons = striplist(dest_binary ring_add_tm) t
   795    val mons = striplist(dest_binary ring_add_tm) t
   796   in member (op aconvc) mons v andalso
   796   in member (op aconvc) mons v andalso
   797     forall (fn m => v aconvc m
   797     forall (fn m => v aconvc m
   798           orelse not(member (op aconvc) (Misc_Legacy.cterm_frees m) v)) mons
   798           orelse not(Cterms.defined (Misc_Legacy.cterm_frees m) v)) mons
   799   end
   799   end
   800 
   800 
   801   fun isolate_variable vars tm =
   801   fun isolate_variable vars tm =
   802   let
   802   let
   803    val th = poly_eq_conv tm
   803    val th = poly_eq_conv tm
   848   end
   848   end
   849 
   849 
   850  fun isolate_monomials vars tm =
   850  fun isolate_monomials vars tm =
   851  let
   851  let
   852   val (cmons,vmons) =
   852   val (cmons,vmons) =
   853     List.partition (fn m => null (inter (op aconvc) vars (Misc_Legacy.cterm_frees m)))
   853     List.partition (fn m => null (inter (op aconvc) vars (Cterms.list_set_rev (Misc_Legacy.cterm_frees m))))
   854                    (striplist ring_dest_add tm)
   854                    (striplist ring_dest_add tm)
   855   val cofactors = map (fn v => find_multipliers v vmons) vars
   855   val cofactors = map (fn v => find_multipliers v vmons) vars
   856   val cnc = if null cmons then zero_tm
   856   val cnc = if null cmons then zero_tm
   857              else Thm.apply ring_neg_tm
   857              else Thm.apply ring_neg_tm
   858                     (list_mk_binop ring_add_tm cmons)
   858                     (list_mk_binop ring_add_tm cmons)