File abel_cancel.ML (Isabelle2005: October 2005)

# File abel_cancel.ML

    (*  Title:      HOL/OrderedGroup.ML
        ID:         $Id: abel_cancel.ML,v 1.20 2005/08/01 17:20:26 wenzelm Exp $
        Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
        Copyright   1998  University of Cambridge

    Simplification procedures for abelian groups (e.g. integers, reals)

    - Cancel complementary terms in sums
    - Cancel like terms on opposite sides of relations

    Modification in May 2004 by Steven Obua: polymorphic types work also now
    Modification in June 2005 by Tobias Nipkow: cancel_sums works in general now
    (using Clemens Ballarin's code for ordered rewriting in abelian groups)
    and the whole file is reduced to a fraction of its former size.
    *)

    signature ABEL_CANCEL =
    sig
      val cancel_ss       : simpset       (*abelian group cancel simpset*)
      val thy_ref         : theory_ref    (*signature of the theory of the group*)
      val T               : typ           (*the type of group elements*)
      val eq_reflection   : thm           (*object-equality to meta-equality*)
      val eqI_rules       : thm list
      val dest_eqI        : thm -> term
    end;

    functor Abel_Cancel (Data: ABEL_CANCEL) =
    struct

    open Data;

     fun zero t = Const ("0", t);
     fun minus t = Const ("uminus", t --> t);

     fun add_terms pos (Const ("op +", _) $ x $ y, ts) =
             add_terms pos (x, add_terms pos (y, ts))
       | add_terms pos (Const ("op -", _) $ x $ y, ts) =
             add_terms pos (x, add_terms (not pos) (y, ts))
       | add_terms pos (Const ("uminus", _) $ x, ts) =
             add_terms (not pos) (x, ts)
       | add_terms pos (x, ts) = (pos,x) :: ts;

     fun terms fml = add_terms true (fml, []);

    fun zero1 pt (u as (c as Const("op +",_)) $ x $ y) =
          (case zero1 pt x of NONE => (case zero1 pt y of NONE => NONE
                                       | SOME z => SOME(c $ x $ z))
           | SOME z => SOME(c $ z $ y))
      | zero1 (pos,t) (u as (c as Const("op -",_)) $ x $ y) =
          (case zero1 (pos,t) x of
             NONE => (case zero1 (not pos,t) y of NONE => NONE
                      | SOME z => SOME(c $ x $ z))
           | SOME z => SOME(c $ z $ y))
      | zero1 (pos,t) (u as (c as Const("uminus",_)) $ x) =
          (case zero1 (not pos,t) x of NONE => NONE
           | SOME z => SOME(c $ z))
      | zero1 (pos,t) u =
          if pos andalso (t aconv u) then SOME(zero(fastype_of t)) else NONE

     exception Cancel;

     val trace = ref false;

    fun find_common _ [] _ = raise Cancel
      | find_common opp ((p,l)::ls) rs =
          let val pr = if opp then not p else p
          in if exists (fn (q,r) => pr = q andalso l aconv r) rs then (p,l)
             else find_common opp ls rs
          end

    (* turns t1(t) OP t2(t) into t1(0) OP t2(0) where OP can be +, -, =, etc.
       If OP = +, it must be t2(-t) rather than t2(t)
    *)
    fun cancel sg t =
      let val _ = if !trace
                  then tracing ("Abel cancel: " ^ string_of_cterm (cterm_of sg t))
                  else ()
          val c $ lhs $ rhs = t
          val opp = case c of Const("op +",_) => true | _ => false;
          val (pos,l) = find_common opp (terms lhs) (terms rhs)
          val posr = if opp then not pos else pos
          val t' = c $ (the(zero1 (pos,l) lhs)) $ (the(zero1 (posr,l) rhs))
          val _ = if !trace
                  then tracing ("cancelled: " ^ string_of_cterm (cterm_of sg t'))
                  else ()
      in t' end;

    (* A simproc to cancel complementary terms in arbitrary sums. *)

    fun sum_proc sg ss t =
       let val t' = cancel sg t
           val thm = Tactic.prove sg [] [] (Logic.mk_equals (t, t'))
                       (fn _ => simp_tac (Simplifier.inherit_bounds ss cancel_ss) 1)
       in SOME thm end
       handle Cancel => NONE;

     val sum_conv =
         Simplifier.mk_simproc "cancel_sums"
           (map (Drule.cterm_fun Logic.varify o Thm.read_cterm (Theory.deref thy_ref))
            [("x + y", Data.T), ("x - y", Data.T)])  (* FIXME depends on concrete syntax !???!!??! *)
           sum_proc;

     (*A simproc to cancel like terms on the opposite sides of relations:
         (x + y - z < -z + x) = (y < 0)
       Works for (=) and (<=) as well as (<), if the necessary rules are supplied.
       Reduces the problem to subtraction.
     *)

     fun rel_proc sg ss t =
       let val t' = cancel sg t
           val thm = Tactic.prove sg [] [] (Logic.mk_equals (t, t'))
                       (fn _ => rtac eq_reflection 1 THEN
                                resolve_tac eqI_rules 1 THEN
                                simp_tac (Simplifier.inherit_bounds ss cancel_ss) 1)
       in SOME thm end
       handle Cancel => NONE;

     val rel_conv =
         Simplifier.simproc_i (Theory.deref thy_ref) "cancel_relations"
           (map Data.dest_eqI eqI_rules) rel_proc;

    end;