src/HOL/Tools/lin_arith.ML
changeset 30686 47a32dd1b86e
parent 30528 7173bf123335
child 30722 623d4831c8cf
equal deleted inserted replaced
30685:dd5fe091ff04 30686:47a32dd1b86e
     4 HOL setup for linear arithmetic (see Provers/Arith/fast_lin_arith.ML).
     4 HOL setup for linear arithmetic (see Provers/Arith/fast_lin_arith.ML).
     5 *)
     5 *)
     6 
     6 
     7 signature BASIC_LIN_ARITH =
     7 signature BASIC_LIN_ARITH =
     8 sig
     8 sig
     9   type arith_tactic
       
    10   val mk_arith_tactic: string -> (Proof.context -> int -> tactic) -> arith_tactic
       
    11   val eq_arith_tactic: arith_tactic * arith_tactic -> bool
       
    12   val arith_split_add: attribute
     9   val arith_split_add: attribute
    13   val arith_discrete: string -> Context.generic -> Context.generic
    10   val arith_discrete: string -> Context.generic -> Context.generic
    14   val arith_inj_const: string * typ -> Context.generic -> Context.generic
    11   val arith_inj_const: string * typ -> Context.generic -> Context.generic
    15   val arith_tactic_add: arith_tactic -> Context.generic -> Context.generic
       
    16   val fast_arith_split_limit: int Config.T
    12   val fast_arith_split_limit: int Config.T
    17   val fast_arith_neq_limit: int Config.T
    13   val fast_arith_neq_limit: int Config.T
    18   val lin_arith_pre_tac: Proof.context -> int -> tactic
    14   val lin_arith_pre_tac: Proof.context -> int -> tactic
    19   val fast_arith_tac: Proof.context -> int -> tactic
    15   val fast_arith_tac: Proof.context -> int -> tactic
    20   val fast_ex_arith_tac: Proof.context -> bool -> int -> tactic
    16   val fast_ex_arith_tac: Proof.context -> bool -> int -> tactic
    21   val trace_arith: bool ref
    17   val trace_arith: bool ref
    22   val lin_arith_simproc: simpset -> term -> thm option
    18   val lin_arith_simproc: simpset -> term -> thm option
    23   val fast_nat_arith_simproc: simproc
    19   val fast_nat_arith_simproc: simproc
    24   val simple_arith_tac: Proof.context -> int -> tactic
    20   val linear_arith_tac: Proof.context -> int -> tactic
    25   val arith_tac: Proof.context -> int -> tactic
       
    26   val silent_arith_tac: Proof.context -> int -> tactic
       
    27 end;
    21 end;
    28 
    22 
    29 signature LIN_ARITH =
    23 signature LIN_ARITH =
    30 sig
    24 sig
    31   include BASIC_LIN_ARITH
    25   include BASIC_LIN_ARITH
    37     Context.generic -> Context.generic
    31     Context.generic -> Context.generic
    38   val warning_count: int ref
    32   val warning_count: int ref
    39   val setup: Context.generic -> Context.generic
    33   val setup: Context.generic -> Context.generic
    40 end;
    34 end;
    41 
    35 
    42 structure LinArith: LIN_ARITH =
    36 structure Lin_Arith: LIN_ARITH =
    43 struct
    37 struct
    44 
    38 
    45 (* Parameters data for general linear arithmetic functor *)
    39 (* Parameters data for general linear arithmetic functor *)
    46 
    40 
    47 structure LA_Logic: LIN_ARITH_LOGIC =
    41 structure LA_Logic: LIN_ARITH_LOGIC =
    70 
    64 
    71 fun is_False thm =
    65 fun is_False thm =
    72   let val _ $ t = Thm.prop_of thm
    66   let val _ $ t = Thm.prop_of thm
    73   in t = Const("False",HOLogic.boolT) end;
    67   in t = Const("False",HOLogic.boolT) end;
    74 
    68 
    75 fun is_nat(t) = fastype_of1 t = HOLogic.natT;
    69 fun is_nat t = (fastype_of1 t = HOLogic.natT);
    76 
    70 
    77 fun mk_nat_thm sg t =
    71 fun mk_nat_thm sg t =
    78   let val ct = cterm_of sg t  and cn = cterm_of sg (Var(("n",0),HOLogic.natT))
    72   let val ct = cterm_of sg t  and cn = cterm_of sg (Var(("n",0),HOLogic.natT))
    79   in instantiate ([],[(cn,ct)]) le0 end;
    73   in instantiate ([],[(cn,ct)]) le0 end;
    80 
    74 
    81 end;
    75 end;
    82 
    76 
    83 
    77 
    84 (* arith context data *)
    78 (* arith context data *)
    85 
       
    86 datatype arith_tactic =
       
    87   ArithTactic of {name: string, tactic: Proof.context -> int -> tactic, id: stamp};
       
    88 
       
    89 fun mk_arith_tactic name tactic = ArithTactic {name = name, tactic = tactic, id = stamp ()};
       
    90 
       
    91 fun eq_arith_tactic (ArithTactic {id = id1, ...}, ArithTactic {id = id2, ...}) = (id1 = id2);
       
    92 
    79 
    93 structure ArithContextData = GenericDataFun
    80 structure ArithContextData = GenericDataFun
    94 (
    81 (
    95   type T = {splits: thm list,
    82   type T = {splits: thm list,
    96             inj_consts: (string * typ) list,
    83             inj_consts: (string * typ) list,
    97             discrete: string list,
    84             discrete: string list};
    98             tactics: arith_tactic list};
    85   val empty = {splits = [], inj_consts = [], discrete = []};
    99   val empty = {splits = [], inj_consts = [], discrete = [], tactics = []};
       
   100   val extend = I;
    86   val extend = I;
   101   fun merge _
    87   fun merge _
   102    ({splits= splits1, inj_consts= inj_consts1, discrete= discrete1, tactics= tactics1},
    88    ({splits= splits1, inj_consts= inj_consts1, discrete= discrete1},
   103     {splits= splits2, inj_consts= inj_consts2, discrete= discrete2, tactics= tactics2}) : T =
    89     {splits= splits2, inj_consts= inj_consts2, discrete= discrete2}) : T =
   104    {splits = Library.merge Thm.eq_thm_prop (splits1, splits2),
    90    {splits = Library.merge Thm.eq_thm_prop (splits1, splits2),
   105     inj_consts = Library.merge (op =) (inj_consts1, inj_consts2),
    91     inj_consts = Library.merge (op =) (inj_consts1, inj_consts2),
   106     discrete = Library.merge (op =) (discrete1, discrete2),
    92     discrete = Library.merge (op =) (discrete1, discrete2)};
   107     tactics = Library.merge eq_arith_tactic (tactics1, tactics2)};
       
   108 );
    93 );
   109 
    94 
   110 val get_arith_data = ArithContextData.get o Context.Proof;
    95 val get_arith_data = ArithContextData.get o Context.Proof;
   111 
    96 
   112 val arith_split_add = Thm.declaration_attribute (fn thm =>
    97 val arith_split_add = Thm.declaration_attribute (fn thm =>
   113   ArithContextData.map (fn {splits, inj_consts, discrete, tactics} =>
    98   ArithContextData.map (fn {splits, inj_consts, discrete} =>
   114     {splits = update Thm.eq_thm_prop thm splits,
    99     {splits = update Thm.eq_thm_prop thm splits,
   115      inj_consts = inj_consts, discrete = discrete, tactics = tactics}));
   100      inj_consts = inj_consts, discrete = discrete}));
   116 
   101 
   117 fun arith_discrete d = ArithContextData.map (fn {splits, inj_consts, discrete, tactics} =>
   102 fun arith_discrete d = ArithContextData.map (fn {splits, inj_consts, discrete} =>
   118   {splits = splits, inj_consts = inj_consts,
   103   {splits = splits, inj_consts = inj_consts,
   119    discrete = update (op =) d discrete, tactics = tactics});
   104    discrete = update (op =) d discrete});
   120 
   105 
   121 fun arith_inj_const c = ArithContextData.map (fn {splits, inj_consts, discrete, tactics} =>
   106 fun arith_inj_const c = ArithContextData.map (fn {splits, inj_consts, discrete} =>
   122   {splits = splits, inj_consts = update (op =) c inj_consts,
   107   {splits = splits, inj_consts = update (op =) c inj_consts,
   123    discrete = discrete, tactics= tactics});
   108    discrete = discrete});
   124 
       
   125 fun arith_tactic_add tac = ArithContextData.map (fn {splits, inj_consts, discrete, tactics} =>
       
   126   {splits = splits, inj_consts = inj_consts, discrete = discrete,
       
   127    tactics = update eq_arith_tactic tac tactics});
       
   128 
       
   129 
   109 
   130 val (fast_arith_split_limit, setup1) = Attrib.config_int "fast_arith_split_limit" 9;
   110 val (fast_arith_split_limit, setup1) = Attrib.config_int "fast_arith_split_limit" 9;
   131 val (fast_arith_neq_limit, setup2) = Attrib.config_int "fast_arith_neq_limit" 9;
   111 val (fast_arith_neq_limit, setup2) = Attrib.config_int "fast_arith_neq_limit" 9;
   132 val setup_options = setup1 #> setup2;
   112 val setup_options = setup1 #> setup2;
   133 
   113 
   792 
   772 
   793 (* reduce contradictory <= to False.
   773 (* reduce contradictory <= to False.
   794    Most of the work is done by the cancel tactics. *)
   774    Most of the work is done by the cancel tactics. *)
   795 
   775 
   796 val init_arith_data =
   776 val init_arith_data =
   797  Fast_Arith.map_data (fn {add_mono_thms, mult_mono_thms, inj_thms, lessD, ...} =>
   777  map_data (fn {add_mono_thms, mult_mono_thms, inj_thms, lessD, ...} =>
   798    {add_mono_thms = add_mono_thms @
   778    {add_mono_thms = add_mono_thms @
   799     @{thms add_mono_thms_ordered_semiring} @ @{thms add_mono_thms_ordered_field},
   779     @{thms add_mono_thms_ordered_semiring} @ @{thms add_mono_thms_ordered_field},
   800     mult_mono_thms = mult_mono_thms,
   780     mult_mono_thms = mult_mono_thms,
   801     inj_thms = inj_thms,
   781     inj_thms = inj_thms,
   802     lessD = lessD @ [thm "Suc_leI"],
   782     lessD = lessD @ [thm "Suc_leI"],
   813        (*abel_cancel helps it work in abstract algebraic domains*)
   793        (*abel_cancel helps it work in abstract algebraic domains*)
   814       addsimprocs Nat_Arith.nat_cancel_sums_add}) #>
   794       addsimprocs Nat_Arith.nat_cancel_sums_add}) #>
   815   arith_discrete "nat";
   795   arith_discrete "nat";
   816 
   796 
   817 fun add_arith_facts ss =
   797 fun add_arith_facts ss =
   818   add_prems (ArithFacts.get (MetaSimplifier.the_context ss)) ss;
   798   add_prems (Arith_Data.get_arith_facts (MetaSimplifier.the_context ss)) ss;
   819 
   799 
   820 val lin_arith_simproc = add_arith_facts #> Fast_Arith.lin_arith_simproc;
   800 val lin_arith_simproc = add_arith_facts #> Fast_Arith.lin_arith_simproc;
   821 
   801 
   822 val fast_nat_arith_simproc =
   802 val fast_nat_arith_simproc =
   823   Simplifier.simproc (the_context ()) "fast_nat_arith"
   803   Simplifier.simproc (the_context ()) "fast_nat_arith"
   893     (* Therefore splitting outside of fast_arith_tac may allow us to prove   *)
   873     (* Therefore splitting outside of fast_arith_tac may allow us to prove   *)
   894     (* some goals that fast_arith_tac alone would fail on.                   *)
   874     (* some goals that fast_arith_tac alone would fail on.                   *)
   895     (REPEAT_DETERM o split_tac (#splits (get_arith_data ctxt)))
   875     (REPEAT_DETERM o split_tac (#splits (get_arith_data ctxt)))
   896     (fast_ex_arith_tac ctxt ex);
   876     (fast_ex_arith_tac ctxt ex);
   897 
   877 
   898 fun more_arith_tacs ctxt =
       
   899   let val tactics = #tactics (get_arith_data ctxt)
       
   900   in FIRST' (map (fn ArithTactic {tactic, ...} => tactic ctxt) tactics) end;
       
   901 
       
   902 in
   878 in
   903 
   879 
   904 fun simple_arith_tac ctxt = FIRST' [fast_arith_tac ctxt,
   880 fun gen_linear_arith_tac ex ctxt = FIRST' [fast_arith_tac ctxt,
   905   ObjectLogic.full_atomize_tac THEN' (REPEAT_DETERM o rtac impI) THEN' raw_arith_tac ctxt true];
   881   ObjectLogic.full_atomize_tac THEN' (REPEAT_DETERM o rtac impI) THEN' raw_arith_tac ctxt ex];
   906 
   882 
   907 fun arith_tac ctxt = FIRST' [fast_arith_tac ctxt,
   883 val linear_arith_tac = gen_linear_arith_tac true;
   908   ObjectLogic.full_atomize_tac THEN' (REPEAT_DETERM o rtac impI) THEN' raw_arith_tac ctxt true,
   884 
   909   more_arith_tacs ctxt];
   885 val linarith_method = Args.bang_facts >> (fn prems => fn ctxt =>
   910 
   886   METHOD (fn facts => HEADGOAL (Method.insert_tac (prems @ Arith_Data.get_arith_facts ctxt @ facts)
   911 fun silent_arith_tac ctxt = FIRST' [fast_arith_tac ctxt,
   887     THEN' linear_arith_tac ctxt)));
   912   ObjectLogic.full_atomize_tac THEN' (REPEAT_DETERM o rtac impI) THEN' raw_arith_tac ctxt false,
       
   913   more_arith_tacs ctxt];
       
   914 
       
   915 val arith_method = Args.bang_facts >>
       
   916   (fn prems => fn ctxt => METHOD (fn facts =>
       
   917       HEADGOAL (Method.insert_tac (prems @ ArithFacts.get ctxt @ facts)
       
   918       THEN' arith_tac ctxt)));
       
   919 
   888 
   920 end;
   889 end;
   921 
   890 
   922 
   891 
   923 (* context setup *)
   892 (* context setup *)
   927   Simplifier.map_ss (fn ss => ss addsimprocs [fast_nat_arith_simproc]
   896   Simplifier.map_ss (fn ss => ss addsimprocs [fast_nat_arith_simproc]
   928     addSolver (mk_solver' "lin_arith"
   897     addSolver (mk_solver' "lin_arith"
   929       (add_arith_facts #> Fast_Arith.cut_lin_arith_tac))) #>
   898       (add_arith_facts #> Fast_Arith.cut_lin_arith_tac))) #>
   930   Context.mapping
   899   Context.mapping
   931    (setup_options #>
   900    (setup_options #>
   932     Method.setup @{binding arith} arith_method "decide linear arithmetic" #>
   901     Arith_Data.add_tactic "linear arithmetic" gen_linear_arith_tac #>
       
   902     Method.setup @{binding linarith} linarith_method "linear arithmetic" #>
   933     Attrib.setup @{binding arith_split} (Scan.succeed arith_split_add)
   903     Attrib.setup @{binding arith_split} (Scan.succeed arith_split_add)
   934       "declaration of split rules for arithmetic procedure") I;
   904       "declaration of split rules for arithmetic procedure") I;
   935 
   905 
   936 end;
   906 end;
   937 
   907 
   938 structure BasicLinArith: BASIC_LIN_ARITH = LinArith;
   908 structure Basic_Lin_Arith: BASIC_LIN_ARITH = Lin_Arith;
   939 open BasicLinArith;
   909 open Basic_Lin_Arith;