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 val arith_split_add: attribute |
9 val lin_arith_simproc: simpset -> term -> thm option |
10 val lin_arith_pre_tac: Proof.context -> int -> tactic |
10 val fast_nat_arith_simproc: simproc |
11 val fast_arith_tac: Proof.context -> int -> tactic |
11 val fast_arith_tac: Proof.context -> int -> tactic |
12 val fast_ex_arith_tac: Proof.context -> bool -> int -> tactic |
12 val fast_ex_arith_tac: Proof.context -> bool -> int -> tactic |
13 val lin_arith_simproc: simpset -> term -> thm option |
|
14 val fast_nat_arith_simproc: simproc |
|
15 val linear_arith_tac: Proof.context -> int -> tactic |
13 val linear_arith_tac: Proof.context -> int -> tactic |
16 end; |
14 end; |
17 |
15 |
18 signature LIN_ARITH = |
16 signature LIN_ARITH = |
19 sig |
17 sig |
20 include BASIC_LIN_ARITH |
18 include BASIC_LIN_ARITH |
|
19 val pre_tac: Proof.context -> int -> tactic |
|
20 val add_inj_thms: thm list -> Context.generic -> Context.generic |
|
21 val add_lessD: thm -> Context.generic -> Context.generic |
|
22 val add_simps: thm list -> Context.generic -> Context.generic |
|
23 val add_simprocs: simproc list -> Context.generic -> Context.generic |
|
24 val add_inj_const: string * typ -> Context.generic -> Context.generic |
21 val add_discrete_type: string -> Context.generic -> Context.generic |
25 val add_discrete_type: string -> Context.generic -> Context.generic |
22 val add_inj_const: string * typ -> Context.generic -> Context.generic |
|
23 val map_data: |
|
24 ({add_mono_thms: thm list, mult_mono_thms: thm list, inj_thms: thm list, |
|
25 lessD: thm list, neqE: thm list, simpset: Simplifier.simpset} -> |
|
26 {add_mono_thms: thm list, mult_mono_thms: thm list, inj_thms: thm list, |
|
27 lessD: thm list, neqE: thm list, simpset: Simplifier.simpset}) -> |
|
28 Context.generic -> Context.generic |
|
29 val setup: Context.generic -> Context.generic |
26 val setup: Context.generic -> Context.generic |
|
27 val global_setup: theory -> theory |
30 val split_limit: int Config.T |
28 val split_limit: int Config.T |
31 val neq_limit: int Config.T |
29 val neq_limit: int Config.T |
32 val warning_count: int ref |
30 val warning_count: int ref |
33 val trace: bool ref |
31 val trace: bool ref |
34 end; |
32 end; |
45 val conjI = conjI; |
43 val conjI = conjI; |
46 val notI = notI; |
44 val notI = notI; |
47 val sym = sym; |
45 val sym = sym; |
48 val not_lessD = @{thm linorder_not_less} RS iffD1; |
46 val not_lessD = @{thm linorder_not_less} RS iffD1; |
49 val not_leD = @{thm linorder_not_le} RS iffD1; |
47 val not_leD = @{thm linorder_not_le} RS iffD1; |
50 val le0 = thm "le0"; |
48 |
51 |
49 fun mk_Eq thm = thm RS Eq_FalseI handle THM _ => thm RS Eq_TrueI; |
52 fun mk_Eq thm = (thm RS Eq_FalseI) handle THM _ => (thm RS Eq_TrueI); |
|
53 |
50 |
54 val mk_Trueprop = HOLogic.mk_Trueprop; |
51 val mk_Trueprop = HOLogic.mk_Trueprop; |
55 |
52 |
56 fun atomize thm = case Thm.prop_of thm of |
53 fun atomize thm = case Thm.prop_of thm of |
57 Const("Trueprop",_) $ (Const("op &",_) $ _ $ _) => |
54 Const ("Trueprop", _) $ (Const (@{const_name "op &"}, _) $ _ $ _) => |
58 atomize(thm RS conjunct1) @ atomize(thm RS conjunct2) |
55 atomize (thm RS conjunct1) @ atomize (thm RS conjunct2) |
59 | _ => [thm]; |
56 | _ => [thm]; |
60 |
57 |
61 fun neg_prop ((TP as Const("Trueprop",_)) $ (Const("Not",_) $ t)) = TP $ t |
58 fun neg_prop ((TP as Const("Trueprop", _)) $ (Const (@{const_name "Not"}, _) $ t)) = TP $ t |
62 | neg_prop ((TP as Const("Trueprop",_)) $ t) = TP $ (HOLogic.Not $t) |
59 | neg_prop ((TP as Const("Trueprop", _)) $ t) = TP $ (HOLogic.Not $t) |
63 | neg_prop t = raise TERM ("neg_prop", [t]); |
60 | neg_prop t = raise TERM ("neg_prop", [t]); |
64 |
61 |
65 fun is_False thm = |
62 fun is_False thm = |
66 let val _ $ t = Thm.prop_of thm |
63 let val _ $ t = Thm.prop_of thm |
67 in t = Const("False",HOLogic.boolT) end; |
64 in t = HOLogic.false_const end; |
68 |
65 |
69 fun is_nat t = (fastype_of1 t = HOLogic.natT); |
66 fun is_nat t = (fastype_of1 t = HOLogic.natT); |
70 |
67 |
71 fun mk_nat_thm sg t = |
68 fun mk_nat_thm thy t = |
72 let val ct = cterm_of sg t and cn = cterm_of sg (Var(("n",0),HOLogic.natT)) |
69 let |
73 in instantiate ([],[(cn,ct)]) le0 end; |
70 val cn = cterm_of thy (Var (("n", 0), HOLogic.natT)) |
|
71 and ct = cterm_of thy t |
|
72 in instantiate ([], [(cn, ct)]) @{thm le0} end; |
74 |
73 |
75 end; |
74 end; |
76 |
75 |
77 |
76 |
78 (* arith context data *) |
77 (* arith context data *) |
79 |
78 |
80 structure ArithContextData = GenericDataFun |
79 structure Lin_Arith_Data = GenericDataFun |
81 ( |
80 ( |
82 type T = {splits: thm list, |
81 type T = {splits: thm list, |
83 inj_consts: (string * typ) list, |
82 inj_consts: (string * typ) list, |
84 discrete: string list}; |
83 discrete: string list}; |
85 val empty = {splits = [], inj_consts = [], discrete = []}; |
84 val empty = {splits = [], inj_consts = [], discrete = []}; |
90 {splits = Library.merge Thm.eq_thm_prop (splits1, splits2), |
89 {splits = Library.merge Thm.eq_thm_prop (splits1, splits2), |
91 inj_consts = Library.merge (op =) (inj_consts1, inj_consts2), |
90 inj_consts = Library.merge (op =) (inj_consts1, inj_consts2), |
92 discrete = Library.merge (op =) (discrete1, discrete2)}; |
91 discrete = Library.merge (op =) (discrete1, discrete2)}; |
93 ); |
92 ); |
94 |
93 |
95 val get_arith_data = ArithContextData.get o Context.Proof; |
94 val get_arith_data = Lin_Arith_Data.get o Context.Proof; |
96 |
95 |
97 val arith_split_add = Thm.declaration_attribute (fn thm => |
96 fun add_split thm = Lin_Arith_Data.map (fn {splits, inj_consts, discrete} => |
98 ArithContextData.map (fn {splits, inj_consts, discrete} => |
97 {splits = update Thm.eq_thm_prop thm splits, |
99 {splits = update Thm.eq_thm_prop thm splits, |
98 inj_consts = inj_consts, discrete = discrete}); |
100 inj_consts = inj_consts, discrete = discrete})); |
99 |
101 |
100 fun add_discrete_type d = Lin_Arith_Data.map (fn {splits, inj_consts, discrete} => |
102 fun add_discrete_type d = ArithContextData.map (fn {splits, inj_consts, discrete} => |
|
103 {splits = splits, inj_consts = inj_consts, |
101 {splits = splits, inj_consts = inj_consts, |
104 discrete = update (op =) d discrete}); |
102 discrete = update (op =) d discrete}); |
105 |
103 |
106 fun add_inj_const c = ArithContextData.map (fn {splits, inj_consts, discrete} => |
104 fun add_inj_const c = Lin_Arith_Data.map (fn {splits, inj_consts, discrete} => |
107 {splits = splits, inj_consts = update (op =) c inj_consts, |
105 {splits = splits, inj_consts = update (op =) c inj_consts, |
108 discrete = discrete}); |
106 discrete = discrete}); |
109 |
107 |
110 val (split_limit, setup1) = Attrib.config_int "linarith_split_limit" 9; |
108 val (split_limit, setup_split_limit) = Attrib.config_int "linarith_split_limit" 9; |
111 val (neq_limit, setup2) = Attrib.config_int "linarith_neq_limit" 9; |
109 val (neq_limit, setup_neq_limit) = Attrib.config_int "linarith_neq_limit" 9; |
112 val setup_options = setup1 #> setup2; |
110 |
113 |
111 |
114 |
112 structure LA_Data = |
115 structure LA_Data_Ref = |
|
116 struct |
113 struct |
117 |
114 |
118 val fast_arith_neq_limit = neq_limit; |
115 val fast_arith_neq_limit = neq_limit; |
119 |
116 |
120 |
117 |
754 (TRY o (etac notE THEN' eq_assume_tac))) |
751 (TRY o (etac notE THEN' eq_assume_tac))) |
755 ) i |
752 ) i |
756 ) |
753 ) |
757 end; |
754 end; |
758 |
755 |
759 end; (* LA_Data_Ref *) |
756 end; (* LA_Data *) |
760 |
757 |
761 |
758 |
762 val lin_arith_pre_tac = LA_Data_Ref.pre_tac; |
759 val pre_tac = LA_Data.pre_tac; |
763 |
760 |
764 structure Fast_Arith = Fast_Lin_Arith(structure LA_Logic = LA_Logic and LA_Data = LA_Data_Ref); |
761 structure Fast_Arith = Fast_Lin_Arith(structure LA_Logic = LA_Logic and LA_Data = LA_Data); |
765 |
762 |
766 val map_data = Fast_Arith.map_data; |
763 val map_data = Fast_Arith.map_data; |
|
764 |
|
765 fun map_inj_thms f {add_mono_thms, mult_mono_thms, inj_thms, lessD, neqE, simpset} = |
|
766 {add_mono_thms = add_mono_thms, mult_mono_thms = mult_mono_thms, inj_thms = f inj_thms, |
|
767 lessD = lessD, neqE = neqE, simpset = simpset}; |
|
768 |
|
769 fun map_lessD f {add_mono_thms, mult_mono_thms, inj_thms, lessD, neqE, simpset} = |
|
770 {add_mono_thms = add_mono_thms, mult_mono_thms = mult_mono_thms, inj_thms = inj_thms, |
|
771 lessD = f lessD, neqE = neqE, simpset = simpset}; |
|
772 |
|
773 fun map_simpset f {add_mono_thms, mult_mono_thms, inj_thms, lessD, neqE, simpset} = |
|
774 {add_mono_thms = add_mono_thms, mult_mono_thms = mult_mono_thms, inj_thms = inj_thms, |
|
775 lessD = lessD, neqE = neqE, simpset = f simpset}; |
|
776 |
|
777 fun add_inj_thms thms = Fast_Arith.map_data (map_inj_thms (append thms)); |
|
778 fun add_lessD thm = Fast_Arith.map_data (map_lessD (fn thms => thms @ [thm])); |
|
779 fun add_simps thms = Fast_Arith.map_data (map_simpset (fn simpset => simpset addsimps thms)); |
|
780 fun add_simprocs procs = Fast_Arith.map_data (map_simpset (fn simpset => simpset addsimprocs procs)); |
767 |
781 |
768 fun fast_arith_tac ctxt = Fast_Arith.lin_arith_tac ctxt false; |
782 fun fast_arith_tac ctxt = Fast_Arith.lin_arith_tac ctxt false; |
769 val fast_ex_arith_tac = Fast_Arith.lin_arith_tac; |
783 val fast_ex_arith_tac = Fast_Arith.lin_arith_tac; |
770 val trace = Fast_Arith.trace; |
784 val trace = Fast_Arith.trace; |
771 val warning_count = Fast_Arith.warning_count; |
785 val warning_count = Fast_Arith.warning_count; |
772 |
786 |
773 (* reduce contradictory <= to False. |
787 (* reduce contradictory <= to False. |
774 Most of the work is done by the cancel tactics. *) |
788 Most of the work is done by the cancel tactics. *) |
775 |
789 |
776 val init_arith_data = |
790 val init_arith_data = |
777 map_data (fn {add_mono_thms, mult_mono_thms, inj_thms, lessD, ...} => |
791 Fast_Arith.map_data (fn {add_mono_thms, mult_mono_thms, inj_thms, lessD, ...} => |
778 {add_mono_thms = @{thms add_mono_thms_ordered_semiring} @ @{thms add_mono_thms_ordered_field} @ add_mono_thms, |
792 {add_mono_thms = @{thms add_mono_thms_ordered_semiring} @ @{thms add_mono_thms_ordered_field} @ add_mono_thms, |
779 mult_mono_thms = @{thm mult_strict_left_mono} :: @{thm mult_left_mono} :: mult_mono_thms, |
793 mult_mono_thms = @{thm mult_strict_left_mono} :: @{thm mult_left_mono} :: mult_mono_thms, |
780 inj_thms = inj_thms, |
794 inj_thms = inj_thms, |
781 lessD = lessD @ [@{thm "Suc_leI"}], |
795 lessD = lessD @ [@{thm "Suc_leI"}], |
782 neqE = [@{thm linorder_neqE_nat}, @{thm linorder_neqE_ordered_idom}], |
796 neqE = [@{thm linorder_neqE_nat}, @{thm linorder_neqE_ordered_idom}], |
889 |
903 |
890 val setup = |
904 val setup = |
891 init_arith_data #> |
905 init_arith_data #> |
892 Simplifier.map_ss (fn ss => ss addsimprocs [fast_nat_arith_simproc] |
906 Simplifier.map_ss (fn ss => ss addsimprocs [fast_nat_arith_simproc] |
893 addSolver (mk_solver' "lin_arith" |
907 addSolver (mk_solver' "lin_arith" |
894 (add_arith_facts #> Fast_Arith.cut_lin_arith_tac))) #> |
908 (add_arith_facts #> Fast_Arith.cut_lin_arith_tac))) |
895 Context.mapping |
909 |
896 (setup_options #> |
910 val global_setup = |
897 Arith_Data.add_tactic "linear arithmetic" gen_linear_arith_tac #> |
911 setup_split_limit #> setup_neq_limit #> |
898 Method.setup @{binding linarith} |
912 Attrib.setup @{binding arith_split} (Scan.succeed (Thm.declaration_attribute add_split)) |
899 (Args.bang_facts >> (fn prems => fn ctxt => |
913 "declaration of split rules for arithmetic procedure" #> |
900 METHOD (fn facts => |
914 Method.setup @{binding linarith} |
901 HEADGOAL (Method.insert_tac (prems @ Arith_Data.get_arith_facts ctxt @ facts) |
915 (Args.bang_facts >> (fn prems => fn ctxt => |
902 THEN' linear_arith_tac ctxt)))) "linear arithmetic" #> |
916 METHOD (fn facts => |
903 Attrib.setup @{binding arith_split} (Scan.succeed arith_split_add) |
917 HEADGOAL (Method.insert_tac (prems @ Arith_Data.get_arith_facts ctxt @ facts) |
904 "declaration of split rules for arithmetic procedure") I; |
918 THEN' linear_arith_tac ctxt)))) "linear arithmetic" #> |
|
919 Arith_Data.add_tactic "linear arithmetic" gen_linear_arith_tac; |
905 |
920 |
906 end; |
921 end; |
907 |
922 |
908 structure Basic_Lin_Arith: BASIC_LIN_ARITH = Lin_Arith; |
923 structure Basic_Lin_Arith: BASIC_LIN_ARITH = Lin_Arith; |
909 open Basic_Lin_Arith; |
924 open Basic_Lin_Arith; |