src/HOL/Library/comm_ring.ML
author haftmann
Wed Apr 22 19:09:21 2009 +0200 (2009-04-22)
changeset 30960 fec1a04b7220
parent 30510 4120fc59dd85
child 31021 53642251a04f
permissions -rw-r--r--
power operation defined generic
wenzelm@29265
     1
(*  Author:     Amine Chaieb
wenzelm@17516
     2
wenzelm@17516
     3
Tactic for solving equalities over commutative rings.
wenzelm@17516
     4
*)
wenzelm@17516
     5
wenzelm@17516
     6
signature COMM_RING =
wenzelm@17516
     7
sig
wenzelm@20623
     8
  val comm_ring_tac : Proof.context -> int -> tactic
wenzelm@18708
     9
  val setup : theory -> theory
wenzelm@17516
    10
end
wenzelm@17516
    11
wenzelm@17516
    12
structure CommRing: COMM_RING =
wenzelm@17516
    13
struct
wenzelm@17516
    14
wenzelm@17516
    15
(* The Cring exception for erronous uses of cring_tac *)
wenzelm@17516
    16
exception CRing of string;
wenzelm@17516
    17
wenzelm@17516
    18
(* Zero and One of the commutative ring *)
haftmann@22997
    19
fun cring_zero T = Const (@{const_name HOL.zero}, T);
haftmann@22997
    20
fun cring_one T = Const (@{const_name HOL.one}, T);
wenzelm@17516
    21
wenzelm@17516
    22
(* reification functions *)
wenzelm@17516
    23
(* add two polynom expressions *)
haftmann@22950
    24
fun polT t = Type ("Commutative_Ring.pol", [t]);
haftmann@22950
    25
fun polexT t = Type ("Commutative_Ring.polex", [t]);
wenzelm@17516
    26
wenzelm@20623
    27
(* pol *)
haftmann@22950
    28
fun pol_Pc t = Const ("Commutative_Ring.pol.Pc", t --> polT t);
haftmann@22950
    29
fun pol_Pinj t = Const ("Commutative_Ring.pol.Pinj", HOLogic.natT --> polT t --> polT t);
haftmann@22950
    30
fun pol_PX t = Const ("Commutative_Ring.pol.PX", polT t --> HOLogic.natT --> polT t --> polT t);
wenzelm@17516
    31
wenzelm@17516
    32
(* polex *)
haftmann@22950
    33
fun polex_add t = Const ("Commutative_Ring.polex.Add", polexT t --> polexT t --> polexT t);
haftmann@22950
    34
fun polex_sub t = Const ("Commutative_Ring.polex.Sub", polexT t --> polexT t --> polexT t);
haftmann@22950
    35
fun polex_mul t = Const ("Commutative_Ring.polex.Mul", polexT t --> polexT t --> polexT t);
haftmann@22950
    36
fun polex_neg t = Const ("Commutative_Ring.polex.Neg", polexT t --> polexT t);
haftmann@22950
    37
fun polex_pol t = Const ("Commutative_Ring.polex.Pol", polT t --> polexT t);
haftmann@22950
    38
fun polex_pow t = Const ("Commutative_Ring.polex.Pow", polexT t --> HOLogic.natT --> polexT t);
wenzelm@17516
    39
wenzelm@17516
    40
(* reification of polynoms : primitive cring expressions *)
haftmann@22950
    41
fun reif_pol T vs (t as Free _) =
haftmann@22950
    42
      let
haftmann@22950
    43
        val one = @{term "1::nat"};
haftmann@22950
    44
        val i = find_index_eq t vs
haftmann@22950
    45
      in if i = 0
haftmann@22950
    46
        then pol_PX T $ (pol_Pc T $ cring_one T)
haftmann@22950
    47
          $ one $ (pol_Pc T $ cring_zero T)
wenzelm@24630
    48
        else pol_Pinj T $ HOLogic.mk_nat i
haftmann@22950
    49
          $ (pol_PX T $ (pol_Pc T $ cring_one T)
haftmann@22950
    50
            $ one $ (pol_Pc T $ cring_zero T))
wenzelm@17516
    51
        end
haftmann@22950
    52
  | reif_pol T vs t = pol_Pc T $ t;
wenzelm@17516
    53
wenzelm@17516
    54
(* reification of polynom expressions *)
haftmann@22997
    55
fun reif_polex T vs (Const (@{const_name HOL.plus}, _) $ a $ b) =
haftmann@22950
    56
      polex_add T $ reif_polex T vs a $ reif_polex T vs b
haftmann@22997
    57
  | reif_polex T vs (Const (@{const_name HOL.minus}, _) $ a $ b) =
haftmann@22950
    58
      polex_sub T $ reif_polex T vs a $ reif_polex T vs b
haftmann@22997
    59
  | reif_polex T vs (Const (@{const_name HOL.times}, _) $ a $ b) =
haftmann@22950
    60
      polex_mul T $ reif_polex T vs a $ reif_polex T vs b
haftmann@22997
    61
  | reif_polex T vs (Const (@{const_name HOL.uminus}, _) $ a) =
haftmann@22950
    62
      polex_neg T $ reif_polex T vs a
haftmann@24996
    63
  | reif_polex T vs (Const (@{const_name Power.power}, _) $ a $ n) =
haftmann@22950
    64
      polex_pow T $ reif_polex T vs a $ n
haftmann@22950
    65
  | reif_polex T vs t = polex_pol T $ reif_pol T vs t;
wenzelm@17516
    66
wenzelm@17516
    67
(* reification of the equation *)
haftmann@22950
    68
val TFree (_, cr_sort) = @{typ "'a :: {comm_ring, recpower}"};
haftmann@22950
    69
haftmann@22950
    70
fun reif_eq thy (eq as Const("op =", Type("fun", [T, _])) $ lhs $ rhs) =
haftmann@22950
    71
      if Sign.of_sort thy (T, cr_sort) then
haftmann@22950
    72
        let
wenzelm@29265
    73
          val fs = OldTerm.term_frees eq;
haftmann@22950
    74
          val cvs = cterm_of thy (HOLogic.mk_list T fs);
haftmann@22950
    75
          val clhs = cterm_of thy (reif_polex T fs lhs);
haftmann@22950
    76
          val crhs = cterm_of thy (reif_polex T fs rhs);
haftmann@22950
    77
          val ca = ctyp_of thy T;
haftmann@22950
    78
        in (ca, cvs, clhs, crhs) end
wenzelm@26939
    79
      else raise CRing ("reif_eq: not an equation over " ^ Syntax.string_of_sort_global thy cr_sort)
wenzelm@20623
    80
  | reif_eq _ _ = raise CRing "reif_eq: not an equation";
wenzelm@17516
    81
haftmann@22950
    82
(* The cring tactic *)
wenzelm@17516
    83
(* Attention: You have to make sure that no t^0 is in the goal!! *)
wenzelm@17516
    84
(* Use simply rewriting t^0 = 1 *)
wenzelm@20623
    85
val cring_simps =
haftmann@22950
    86
  [@{thm mkPX_def}, @{thm mkPinj_def}, @{thm sub_def}, @{thm power_add},
haftmann@22950
    87
    @{thm even_def}, @{thm pow_if}, sym OF [@{thm power_add}]];
wenzelm@17516
    88
wenzelm@20623
    89
fun comm_ring_tac ctxt = SUBGOAL (fn (g, i) =>
wenzelm@20623
    90
  let
haftmann@22950
    91
    val thy = ProofContext.theory_of ctxt;
haftmann@22950
    92
    val cring_ss = Simplifier.local_simpset_of ctxt  (*FIXME really the full simpset!?*)
haftmann@22950
    93
      addsimps cring_simps;
wenzelm@20623
    94
    val (ca, cvs, clhs, crhs) = reif_eq thy (HOLogic.dest_Trueprop g)
wenzelm@20623
    95
    val norm_eq_th =
haftmann@22950
    96
      simplify cring_ss (instantiate' [SOME ca] [SOME clhs, SOME crhs, SOME cvs] @{thm norm_eq})
wenzelm@20623
    97
  in
wenzelm@20623
    98
    cut_rules_tac [norm_eq_th] i
wenzelm@20623
    99
    THEN (simp_tac cring_ss i)
wenzelm@20623
   100
    THEN (simp_tac cring_ss i)
wenzelm@20623
   101
  end);
wenzelm@20623
   102
wenzelm@20623
   103
val comm_ring_meth =
wenzelm@30510
   104
  Method.ctxt_args (SIMPLE_METHOD' o comm_ring_tac);
wenzelm@17516
   105
wenzelm@17516
   106
val setup =
wenzelm@20623
   107
  Method.add_method ("comm_ring", comm_ring_meth,
wenzelm@20623
   108
    "reflective decision procedure for equalities over commutative rings") #>
wenzelm@20623
   109
  Method.add_method ("algebra", comm_ring_meth,
wenzelm@20623
   110
    "method for proving algebraic properties (same as comm_ring)");
wenzelm@17516
   111
wenzelm@17516
   112
end;