src/HOL/Decision_Procs/ferrack_tac.ML
changeset 55498 cf829d10d1d4
parent 54742 7a86358a3c0b
child 56245 84fc7dfa3cd4
equal deleted inserted replaced
55497:c0f8aebfb43d 55498:cf829d10d1d4
     2     Author:     Amine Chaieb, TU Muenchen
     2     Author:     Amine Chaieb, TU Muenchen
     3 *)
     3 *)
     4 
     4 
     5 signature FERRACK_TAC =
     5 signature FERRACK_TAC =
     6 sig
     6 sig
     7   val trace: bool Unsynchronized.ref
       
     8   val linr_tac: Proof.context -> bool -> int -> tactic
     7   val linr_tac: Proof.context -> bool -> int -> tactic
     9 end
     8 end
    10 
     9 
    11 structure Ferrack_Tac =
    10 structure Ferrack_Tac: FERRACK_TAC =
    12 struct
    11 struct
    13 
       
    14 val trace = Unsynchronized.ref false;
       
    15 fun trace_msg s = if !trace then tracing s else ();
       
    16 
    12 
    17 val ferrack_ss = let val ths = [@{thm real_of_int_inject}, @{thm real_of_int_less_iff}, 
    13 val ferrack_ss = let val ths = [@{thm real_of_int_inject}, @{thm real_of_int_less_iff}, 
    18                                 @{thm real_of_int_le_iff}]
    14                                 @{thm real_of_int_le_iff}]
    19              in @{context} delsimps ths addsimps (map (fn th => th RS sym) ths)
    15              in @{context} delsimps ths addsimps (map (fn th => th RS sym) ths)
    20              end |> simpset_of;
    16              end |> simpset_of;
    21 
    17 
    22 val binarith = @{thms arith_simps}
    18 val binarith = @{thms arith_simps}
    23 val comp_arith = binarith @ @{thms simp_thms}
    19 val comp_arith = binarith @ @{thms simp_thms}
    24 
    20 
    25 val zdvd_int = @{thm zdvd_int};
    21 fun prepare_for_linr q fm = 
    26 val zdiff_int_split = @{thm zdiff_int_split};
       
    27 val all_nat = @{thm all_nat};
       
    28 val ex_nat = @{thm ex_nat};
       
    29 val split_zdiv = @{thm split_zdiv};
       
    30 val split_zmod = @{thm split_zmod};
       
    31 val mod_div_equality' = @{thm mod_div_equality'};
       
    32 val split_div' = @{thm split_div'};
       
    33 val Suc_eq_plus1 = @{thm Suc_eq_plus1};
       
    34 val imp_le_cong = @{thm imp_le_cong};
       
    35 val conj_le_cong = @{thm conj_le_cong};
       
    36 val mod_add_left_eq = @{thm mod_add_left_eq} RS sym;
       
    37 val mod_add_right_eq = @{thm mod_add_right_eq} RS sym;
       
    38 val nat_div_add_eq = @{thm div_add1_eq} RS sym;
       
    39 val int_div_add_eq = @{thm zdiv_zadd1_eq} RS sym;
       
    40 
       
    41 fun prepare_for_linr sg q fm = 
       
    42   let
    22   let
    43     val ps = Logic.strip_params fm
    23     val ps = Logic.strip_params fm
    44     val hs = map HOLogic.dest_Trueprop (Logic.strip_assums_hyp fm)
    24     val hs = map HOLogic.dest_Trueprop (Logic.strip_assums_hyp fm)
    45     val c = HOLogic.dest_Trueprop (Logic.strip_assums_concl fm)
    25     val c = HOLogic.dest_Trueprop (Logic.strip_assums_concl fm)
    46     fun mk_all ((s, T), (P,n)) =
    26     fun mk_all ((s, T), (P,n)) =
    70         THEN' (REPEAT_DETERM o split_tac [@{thm split_min}, @{thm split_max}, @{thm abs_split}])
    50         THEN' (REPEAT_DETERM o split_tac [@{thm split_min}, @{thm split_max}, @{thm abs_split}])
    71         THEN' SUBGOAL (fn (g, i) =>
    51         THEN' SUBGOAL (fn (g, i) =>
    72   let
    52   let
    73     val thy = Proof_Context.theory_of ctxt
    53     val thy = Proof_Context.theory_of ctxt
    74     (* Transform the term*)
    54     (* Transform the term*)
    75     val (t,np,nh) = prepare_for_linr thy q g
    55     val (t,np,nh) = prepare_for_linr q g
    76     (* Some simpsets for dealing with mod div abs and nat*)
    56     (* Some simpsets for dealing with mod div abs and nat*)
    77     val simpset0 = put_simpset HOL_basic_ss ctxt addsimps comp_arith
    57     val simpset0 = put_simpset HOL_basic_ss ctxt addsimps comp_arith
    78     val ct = cterm_of thy (HOLogic.mk_Trueprop t)
    58     val ct = cterm_of thy (HOLogic.mk_Trueprop t)
    79     (* Theorem for the nat --> int transformation *)
    59     (* Theorem for the nat --> int transformation *)
    80    val pre_thm = Seq.hd (EVERY
    60    val pre_thm = Seq.hd (EVERY
    85     (* The result of the quantifier elimination *)
    65     (* The result of the quantifier elimination *)
    86     val (th, tac) = case prop_of pre_thm of
    66     val (th, tac) = case prop_of pre_thm of
    87         Const ("==>", _) $ (Const (@{const_name Trueprop}, _) $ t1) $ _ =>
    67         Const ("==>", _) $ (Const (@{const_name Trueprop}, _) $ t1) $ _ =>
    88     let val pth = linr_oracle (ctxt, Envir.eta_long [] t1)
    68     let val pth = linr_oracle (ctxt, Envir.eta_long [] t1)
    89     in 
    69     in 
    90           (trace_msg ("calling procedure with term:\n" ^
    70        ((pth RS iffD2) RS pre_thm,
    91              Syntax.string_of_term ctxt t1);
    71         assm_tac (i + 1) THEN (if q then I else TRY) (rtac TrueI i))
    92            ((pth RS iffD2) RS pre_thm,
       
    93             assm_tac (i + 1) THEN (if q then I else TRY) (rtac TrueI i)))
       
    94     end
    72     end
    95       | _ => (pre_thm, assm_tac i)
    73       | _ => (pre_thm, assm_tac i)
    96   in rtac ((mp_step nh o spec_step np) th) i THEN tac end);
    74   in rtac ((mp_step nh o spec_step np) th) i THEN tac end);
    97 
    75 
    98 end
    76 end