# HG changeset patch
# User paulson
# Date 977138514 -3600
# Node ID 5c44de6aadf44bb54a6fe435306913ad57560b80
# Parent  4cf4bbc2526734d6fdfc02bf99b7b42c1a3a6de8
loads the new simproc extract_common_term

diff -r 4cf4bbc25267 -r 5c44de6aadf4 src/HOL/ROOT.ML
--- a/src/HOL/ROOT.ML	Sat Dec 16 21:43:28 2000 +0100
+++ b/src/HOL/ROOT.ML	Mon Dec 18 12:21:54 2000 +0100
@@ -34,6 +34,7 @@
 use "~~/src/Provers/Arith/cancel_numerals.ML";
 use "~~/src/Provers/Arith/combine_numerals.ML";
 use "~~/src/Provers/Arith/cancel_numeral_factor.ML";
+use "~~/src/Provers/Arith/extract_common_term.ML";
 
 with_path "Integ" use_thy "Main";
 
diff -r 4cf4bbc25267 -r 5c44de6aadf4 src/HOL/Real/RealArith.ML
--- a/src/HOL/Real/RealArith.ML	Sat Dec 16 21:43:28 2000 +0100
+++ b/src/HOL/Real/RealArith.ML	Mon Dec 18 12:21:54 2000 +0100
@@ -208,6 +208,11 @@
 by (asm_full_simp_tac (HOL_ss addsimps real_mult_ac) 1); 
 qed "real_mult_div_cancel1";
 
+(*For ExtractCommonTerm*)
+Goal "(k*m) / (k*n) = (if k = (#0::real) then #0 else m/n)";
+by (simp_tac (simpset() addsimps [real_mult_div_cancel1]) 1); 
+qed "real_mult_div_cancel_disj";
+
 
 local
   open Real_Numeral_Simprocs
@@ -324,6 +329,77 @@
 test "-x <= #-23 * (y::real)";
 *)
 
+
+(** Declarations for ExtractCommonTerm **)
+
+local
+  open Real_Numeral_Simprocs
+in
+
+structure CancelFactorCommon =
+  struct
+  val mk_sum    	= long_mk_prod
+  val dest_sum		= dest_prod
+  val mk_coeff		= mk_coeff
+  val dest_coeff	= dest_coeff
+  val find_first	= find_first []
+  val trans_tac         = trans_tac
+  val norm_tac = ALLGOALS (simp_tac (HOL_ss addsimps mult_1s@real_mult_ac))
+  end;
+
+structure EqCancelFactor = ExtractCommonTermFun
+ (open CancelFactorCommon
+  val prove_conv = prove_conv "real_eq_cancel_factor"
+  val mk_bal   = HOLogic.mk_eq
+  val dest_bal = HOLogic.dest_bin "op =" HOLogic.realT
+  val simplify_meta_eq  = cancel_simplify_meta_eq real_mult_eq_cancel1
+);
+
+
+structure DivideCancelFactor = ExtractCommonTermFun
+ (open CancelFactorCommon
+  val prove_conv = prove_conv "real_divide_cancel_factor"
+  val mk_bal   = HOLogic.mk_binop "HOL.divide"
+  val dest_bal = HOLogic.dest_bin "HOL.divide" HOLogic.realT
+  val simplify_meta_eq  = cancel_simplify_meta_eq real_mult_div_cancel_disj
+);
+
+val real_cancel_factor = 
+  map prep_simproc
+   [("real_eq_cancel_factor",
+     prep_pats ["(l::real) * m = n", "(l::real) = m * n"], 
+     EqCancelFactor.proc),
+    ("real_divide_cancel_factor", 
+     prep_pats ["((l::real) * m) / n", "(l::real) / (m * n)"], 
+     DivideCancelFactor.proc)];
+
+end;
+
+Addsimprocs real_cancel_factor;
+
+
+(*examples:
+print_depth 22;
+set timing;
+set trace_simp;
+fun test s = (Goal s; by (Asm_simp_tac 1)); 
+
+test "x*k = k*(y::real)";
+test "k = k*(y::real)"; 
+test "a*(b*c) = (b::real)";
+test "a*(b*c) = d*(b::real)*(x*a)";
+
+
+test "(x*k) / (k*(y::real)) = (uu::real)";
+test "(k) / (k*(y::real)) = (uu::real)"; 
+test "(a*(b*c)) / ((b::real)) = (uu::real)";
+test "(a*(b*c)) / (d*(b::real)*(x*a)) = (uu::real)";
+
+(*FIXME: what do we do about this?*)
+test "a*(b*c)/(y*z) = d*(b::real)*(x*a)/z";
+*)
+
+
 (*** Simplification of inequalities involving literal divisors ***)
 
 Goal "#0<z ==> ((x::real) <= y/z) = (x*z <= y)";
diff -r 4cf4bbc25267 -r 5c44de6aadf4 src/HOL/Real/RealBin.ML
--- a/src/HOL/Real/RealBin.ML	Sat Dec 16 21:43:28 2000 +0100
+++ b/src/HOL/Real/RealBin.ML	Mon Dec 18 12:21:54 2000 +0100
@@ -485,6 +485,26 @@
 		  prep_pats ["(i::real) + j", "(i::real) - j"],
 		  CombineNumerals.proc);
 
+
+(** Declarations for ExtractCommonTerm **)
+
+(*this version ALWAYS includes a trailing one*)
+fun long_mk_prod []        = one
+  | long_mk_prod (t :: ts) = mk_times (t, mk_prod ts);
+
+(*Find first term that matches u*)
+fun find_first past u []         = raise TERM("find_first", []) 
+  | find_first past u (t::terms) =
+	if u aconv t then (rev past @ terms)
+        else find_first (t::past) u terms
+	handle TERM _ => find_first (t::past) u terms;
+
+(*Final simplification: cancel + and *  *)
+fun cancel_simplify_meta_eq cancel_th th = 
+    Int_Numeral_Simprocs.simplify_meta_eq 
+        [real_mult_1, real_mult_1_right] 
+        (([th, cancel_th]) MRS trans);
+
 end;