├── .gitignore ├── FOL ├── AbGroup.thy ├── Abs.thy ├── AlgStructure.thy ├── ArrowImpossibility.thy ├── Auto2_FOL.thy ├── BigProd.thy ├── BigSet.thy ├── Cardinal.thy ├── Choice.thy ├── Coset.thy ├── Coverings.thy ├── Divides.thy ├── Equipotent.thy ├── EquivRel.thy ├── FOL_Base.thy ├── Field.thy ├── Finite.thy ├── FixedPt.thy ├── Functions.thy ├── Graph.thy ├── Group.thy ├── Homotopy │ ├── FundamentalGroup.thy │ ├── Homotopy.thy │ ├── PathHomotopy.thy │ └── interval_steps.ML ├── Int.thy ├── Interval.thy ├── Lattice.thy ├── Logic_FOL.thy ├── Module.thy ├── Morphism.thy ├── Nat.thy ├── OrderRel.thy ├── Ordinal.thy ├── Pelletier.thy ├── Rat.thy ├── Ring.thy ├── Semiring.thy ├── Set.thy ├── SetSum.thy ├── Structure.thy ├── Topology │ ├── Closure.thy │ ├── CompleteOrder.thy │ ├── Connected.thy │ ├── MetricSpaces.thy │ ├── OrderTopology.thy │ ├── ProductTopology.thy │ ├── Real.thy │ ├── RealTopology.thy │ ├── SeqRing.thy │ ├── Sequence.thy │ └── Topology.thy ├── WellOrder.thy ├── Wfrec.thy ├── alg_abgroup.ML ├── alg_assoc.ML ├── alg_fol.ML ├── alg_group.ML ├── alg_monoid.ML ├── alg_ring.ML ├── alg_ring_test.ML ├── alg_semiring.ML ├── auto2_fol.ML ├── extra_fol.ML ├── field_steps.ML ├── fol_induct.ML ├── fol_var_induct.ML ├── nat_arith.ML ├── ord_ring_steps.ML ├── rat_arith.ML └── structure.ML ├── HOL ├── Arith_Thms.thy ├── Auto2_HOL.thy ├── Auto2_Main.thy ├── Auto2_Test.thy ├── HOL_Base.thy ├── Lists_Thms.thy ├── Logic_Thms.thy ├── Order_Thms.thy ├── Pelletier.thy ├── Primes_Ex.thy ├── Program_Verification │ ├── Functional │ │ ├── Arrays_Ex.thy │ │ ├── BST.thy │ │ ├── Connectivity.thy │ │ ├── Dijkstra.thy │ │ ├── Indexed_PQueue.thy │ │ ├── Interval.thy │ │ ├── Interval_Tree.thy │ │ ├── Lists_Ex.thy │ │ ├── Mapping_Str.thy │ │ ├── Partial_Equiv_Rel.thy │ │ ├── Quicksort.thy │ │ ├── RBTree.thy │ │ ├── Rect_Intersect.thy │ │ └── Union_Find.thy │ └── Imperative │ │ ├── Arrays_Impl.thy │ │ ├── BST_Impl.thy │ │ ├── Connectivity_Impl.thy │ │ ├── Dijkstra_Impl.thy │ │ ├── DynamicArray.thy │ │ ├── GCD_Impl.thy │ │ ├── Indexed_PQueue_Impl.thy │ │ ├── IntervalTree_Impl.thy │ │ ├── LinkedList.thy │ │ ├── Quicksort_Impl.thy │ │ ├── RBTree_Impl.thy │ │ ├── Rect_Intersect_Impl.thy │ │ ├── SepAuto.thy │ │ ├── SepLogic_Base.thy │ │ ├── Sep_Examples.thy │ │ ├── Union_Find_Impl.thy │ │ ├── assn_matcher.ML │ │ ├── list_matcher_test.ML │ │ ├── sep_steps.ML │ │ ├── sep_steps_test.ML │ │ ├── sep_util.ML │ │ └── sep_util_base.ML ├── Set_Thms.thy ├── ac_steps.ML ├── acdata.ML ├── acdata_test.ML ├── arith.ML ├── auto2_hol.ML ├── extra_hol.ML ├── induct_outer.ML ├── list_ac.ML ├── list_ac_test.ML ├── logic_steps_test.ML ├── matcher_test.ML ├── nat_sub.ML ├── nat_sub_test.ML ├── normalize_test.ML ├── order.ML ├── order_test.ML ├── rewrite_test.ML ├── unfolding.ML ├── util_arith.ML └── util_test.ML ├── README ├── ROOT ├── auto2.ML ├── auto2_data.ML ├── auto2_outer.ML ├── auto2_state.ML ├── box_id.ML ├── consts.ML ├── doc.pdf ├── document ├── root.bib └── root.tex ├── items.ML ├── logic_steps.ML ├── matcher.ML ├── normalize.ML ├── proofsteps.ML ├── property.ML ├── propertydata.ML ├── rewrite.ML ├── status.ML ├── util.ML ├── util_base.ML ├── util_logic.ML ├── wellform.ML ├── wfdata.ML └── wfterm.ML /.gitignore: -------------------------------------------------------------------------------- 1 | *~ 2 | -------------------------------------------------------------------------------- /FOL/Auto2_FOL.thy: -------------------------------------------------------------------------------- 1 | (* 2 | File: Auto2_FOL.thy 3 | Author: Bohua Zhan 4 | 5 | Setup of Auto2 for FOL. 6 | *) 7 | 8 | theory Auto2_FOL 9 | imports FOL_Base 10 | keywords "@proof" :: prf_block % "proof" 11 | and "@have" "@case" "@obtain" "@let" "@contradiction" :: prf_decl % "proof" 12 | and "@subgoal" "@endgoal" "@end" :: prf_decl % "proof" 13 | and "@qed" :: qed_block % "proof" 14 | and "@induct" "@strong_induct" "@var_induct" :: prf_decl % "proof" 15 | and "@with" "where" "arbitrary" "@rule" :: quasi_command 16 | begin 17 | 18 | ML_file "../util.ML" 19 | ML_file "../util_base.ML" 20 | ML_file "auto2_fol.ML" 21 | ML_file "../util_logic.ML" 22 | ML_file "../box_id.ML" 23 | ML_file "../consts.ML" 24 | ML_file "../property.ML" 25 | ML_file "../wellform.ML" 26 | ML_file "../wfterm.ML" 27 | ML_file "../rewrite.ML" 28 | ML_file "../propertydata.ML" 29 | ML_file "../matcher.ML" 30 | ML_file "../items.ML" 31 | ML_file "../wfdata.ML" 32 | ML_file "../auto2_data.ML" 33 | ML_file "../status.ML" 34 | ML_file "../normalize.ML" 35 | ML_file "../proofsteps.ML" 36 | ML_file "../auto2_state.ML" 37 | ML_file "../logic_steps.ML" 38 | ML_file "../auto2.ML" 39 | ML_file "../auto2_outer.ML" 40 | 41 | ML_file "extra_fol.ML" 42 | ML_file "fol_induct.ML" 43 | ML_file "alg_assoc.ML" 44 | ML_file "fol_var_induct.ML" 45 | 46 | method_setup auto2 = {* Scan.succeed (SIMPLE_METHOD o Auto2.auto2_tac) *} "auto2 prover" 47 | 48 | attribute_setup forward = {* setup_attrib add_forward_prfstep *} 49 | attribute_setup backward = {* setup_attrib add_backward_prfstep *} 50 | attribute_setup backward1 = {* setup_attrib add_backward1_prfstep *} 51 | attribute_setup backward2 = {* setup_attrib add_backward2_prfstep *} 52 | attribute_setup resolve = {* setup_attrib add_resolve_prfstep *} 53 | attribute_setup rewrite = {* setup_attrib add_rewrite_rule *} 54 | attribute_setup rewrite_back = {* setup_attrib add_rewrite_rule_back *} 55 | attribute_setup rewrite_bidir = {* setup_attrib add_rewrite_rule_bidir *} 56 | attribute_setup typing = {* setup_attrib add_typing_rule *} 57 | attribute_setup typing2 = {* setup_attrib add_typing2_rule *} 58 | attribute_setup script_induct = {* setup_attrib add_script_induct_data *} 59 | attribute_setup strong_induct = {* setup_attrib add_strong_induct_data *} 60 | attribute_setup var_induct = {* setup_attrib add_var_induct_data *} 61 | 62 | end 63 | -------------------------------------------------------------------------------- /FOL/BigSet.thy: -------------------------------------------------------------------------------- 1 | (* 2 | File: BigSet.thy 3 | Author: Bohua Zhan 4 | 5 | Some results about arbitrary union and intersection. 6 | *) 7 | 8 | theory BigSet 9 | imports Functions 10 | begin 11 | 12 | section \Big union\ 13 | 14 | lemma Union_mem_D: "x \ A \ A \ S \ x \ \(S)" by auto2 15 | 16 | lemma Union_subset_iff: "\(A) \ C \ (\x\A. x \ C)" by auto2 17 | 18 | lemma Union_upper: "B \ A \ B \ \(A)" by auto2 19 | 20 | lemma Union_Un_distrib: "\(A \ B) = \(A) \ \(B)" by auto2 21 | 22 | lemma Union_Int_subset: "\(A \ B) \ \(A) \ \(B)" by auto2 23 | 24 | lemma Union_disjoint: "\(C) \ A = \ \ (\B\C. B \ A = \)" by auto2 25 | 26 | section \Big intersection\ 27 | 28 | lemma Inter_Un_distrib: 29 | "A \ \ \ B \ \ \ \(A \ B) = \(A) \ \(B)" by auto2 30 | 31 | section \Parametrized union and intersection\ (* Bourbaki II.4.1 -- II.4.4 *) 32 | 33 | lemma UN_surj [rewrite]: 34 | "surjective(f) \ is_function(B) \ f \ K \ I \ (\x\K. B`(f`x)) = (\x\I. B`x)" 35 | @proof @have (@rule) "\y\I. \x\K. f`x = y" @qed 36 | 37 | lemma INT_surj [rewrite]: 38 | "surjective(f) \ is_function(B) \ f \ K \ I \ I \ \ \ (\x\K. B`(f`x)) = (\x\I. B`x)" 39 | @proof @have (@rule) "\y\I. \x\K. f`x = y" @qed 40 | 41 | lemma UN_image_subset [resolve]: 42 | "\x\I. X(x) \ Y(x) \ (\x\I. X(x)) \ (\x\I. Y(x))" by auto2 43 | 44 | lemma INT_image_subset [backward2]: 45 | "\x\I. X(x) \ Y(x) \ I \ \ \ (\x\I. X(x)) \ (\x\I. Y(x))" by auto2 46 | 47 | lemma UN_source_subset [backward]: 48 | "J \ I \ (\x\J. X(x)) \ (\x\I. X(x))" by auto2 49 | 50 | lemma INT_source_subset [backward2]: 51 | "J \ I \ J \ \ \ (\x\I. X(x)) \ (\x\J. X(x))" by auto2 52 | 53 | lemma UN_double_eq [rewrite_back]: 54 | "(\a\(\x\L. J(x)). X(a)) = (\x\L. \a\J(x). X(a))" by auto2 55 | 56 | lemma UN_nonempty [backward]: 57 | "I \ \ \ \a\I. X(a) \ \ \ (\a\I. X(a)) \ \" by auto2 58 | 59 | lemma INT_double_eq [rewrite_back]: 60 | "\x\L. J(x) \ \ \ L \ \ \ (\a\(\x\L. J(x)). X(a)) = (\x\L. \a\J(x). X(a))" by auto2 61 | 62 | lemma INT_image_eq [rewrite]: 63 | "injective(f) \ I \ \ \ f `` (\a\I. X(a)) = (\a\I. f `` X(a))" by auto2 64 | 65 | lemma INT_vImage [backward]: 66 | "is_function(\) \ I \ \ \ \ -`` (\a\I. X(a)) = (\a\I. \ -`` X(a))" by auto2 67 | 68 | lemma UN_complement: 69 | "I \ \ \ E \ (\a\I. X(a)) = (\a\I. E \ X(a))" by auto2 70 | 71 | lemma INT_complement [rewrite]: 72 | "I \ \ \ E \ (\a\I. X(a)) = (\a\I. E \ X(a))" by auto2 73 | 74 | section \Union and intersection of two sets\ (* Bourbaki II.4.5 *) 75 | 76 | lemma Un_to_UN [rewrite_back]: 77 | "A \ B = (\{A, B})" by auto2 78 | 79 | lemma Int_to_INT [rewrite_back]: 80 | "A \ B = (\{A, B})" by auto2 81 | 82 | lemma Un_distrib [resolve]: 83 | "A \ (B \ C) = (A \ B) \ (A \ C)" by auto2 84 | 85 | lemma Int_distrib [resolve]: 86 | "A \ (B \ C) = (A \ B) \ (A \ C)" by auto2 87 | 88 | lemma Un_complement [rewrite]: 89 | "E \ (A \ B) = (E \ A) \ (E \ B)" by auto2 90 | 91 | lemma Int_complement [rewrite]: 92 | "E \ (A \ B) = (E \ A) \ (E \ B)" by auto2 93 | 94 | lemma Un_with_complement [rewrite]: 95 | "A \ E \ A \ (E \ A) = E" by auto2 96 | 97 | lemma Int_with_complement [rewrite]: 98 | "A \ (E \ A) = \" by auto2 99 | 100 | lemma Int_vImage [rewrite]: 101 | "is_function(f) \ f -`` (A \ B) = (f -`` A) \ (f -`` B)" by auto2 102 | 103 | lemma Diff_vImage [rewrite]: 104 | "is_function(f) \ X \ E \ f -`` (E \ X) = (f -`` E) \ (f -`` X)" by auto2 105 | 106 | lemma Int_image_eq [rewrite]: 107 | "injective(f) \ X \ source(f) \ f `` (source(f) \ X) = image(f) \ f `` X" by auto2 108 | 109 | section \Finite roducts\ 110 | 111 | lemma prod_inter [rewrite]: 112 | "(A \ B) \ (C \ D) = (A \ C) \ (B \ D)" by auto2 113 | 114 | end 115 | -------------------------------------------------------------------------------- /FOL/Choice.thy: -------------------------------------------------------------------------------- 1 | (* 2 | File: Choice.thy 3 | Author: Bohua Zhan 4 | 5 | Axiom of choice. 6 | *) 7 | 8 | theory Choice 9 | imports Structure 10 | begin 11 | 12 | (* Axiom of global choice. *) 13 | axiomatization Choice :: "i \ i" where 14 | choice: "\x. x\S \ Choice(S) \ S" 15 | setup {* add_prfstep_check_req ("Choice(S)", "\x. x\S") *} 16 | setup {* add_forward_prfstep_cond @{thm choice} [with_term "Choice(?S)"] *} 17 | 18 | (* A more useful version *) 19 | definition choiceP :: "i \ (i \ o) \ i" where [rewrite]: 20 | "choiceP(A,P) = Choice({x\A. P(x)})" 21 | 22 | abbreviation choiceP_carrier :: "i \ (i \ o) \ i" where 23 | "choiceP_carrier(S,P) \ choiceP(carrier(S),P)" 24 | 25 | syntax 26 | "_Eps" :: "[pttrn, o, o] => 'a" ("(3SOME _\_./ _)" [0, 10] 10) 27 | "_Eps_carrier" :: "[pttrn, o, o] => 'a" ("(3SOME _\._./ _)" [0, 10] 10) 28 | translations 29 | "SOME x\A. P" == "CONST choiceP(A, \x. P)" 30 | "SOME x\.S. P" == "CONST choiceP_carrier(S, \x. P)" 31 | 32 | lemma someI: "\x\A. P(x) \ (SOME x\A. P(x)) \ A \ P(SOME x\A. P(x))" 33 | @proof 34 | @obtain "x \ A" where "P(x)" @have "x\{x\A. P(x)}" 35 | @have "Choice({x\A. P(x)}) \ {x\A. P(x)}" 36 | @qed 37 | setup {* add_forward_prfstep_cond @{thm someI} [with_term "SOME x\?A. ?P(x)"] *} 38 | 39 | setup {* add_prfstep_check_req ("SOME k\A. P(k)", "\k\A. P(k)") *} 40 | setup {* del_prfstep_thm @{thm choiceP_def} *} 41 | 42 | end 43 | -------------------------------------------------------------------------------- /FOL/Divides.thy: -------------------------------------------------------------------------------- 1 | (* 2 | File: Divides.thy 3 | Author: Bohua Zhan 4 | 5 | Basics of divisibility and prime numbers. 6 | *) 7 | 8 | theory Divides 9 | imports Nat 10 | begin 11 | 12 | section \Divisibility\ 13 | 14 | definition divides :: "i \ i \ i \ o" where [rewrite]: 15 | "divides(R,a,b) \ (a \. R \ b \. R \ (\k\.R. b = a *\<^sub>R k))" 16 | 17 | lemma dividesI [resolve]: 18 | "is_group_raw(R) \ a \. R \ k \. R \ divides(R, a, a *\<^sub>R k)" by auto2 19 | lemma dividesD1 [forward]: "divides(R,a,b) \ a \. R \ b \. R" by auto2 20 | lemma dividesD2 [backward]: "divides(R,a,b) \ \k\.R. b = a *\<^sub>R k" by auto2 21 | setup {* del_prfstep_thm @{thm divides_def} *} 22 | 23 | lemma divides_id [resolve]: "is_semiring(R) \ a \. R \ divides(R,a,a)" 24 | @proof @have "a = a *\<^sub>R \\<^sub>R" @qed 25 | 26 | lemma divides_trans [forward]: 27 | "is_semiring(R) \ divides(R,a,b) \ divides(R,b,c) \ divides(R,a,c)" 28 | @proof 29 | @obtain "k\.R" where "b = a *\<^sub>R k" 30 | @obtain "l\.R" where "c = b *\<^sub>R l" 31 | @have "c = (a *\<^sub>R k) *\<^sub>R l" @have "c = a *\<^sub>R (k *\<^sub>R l)" 32 | @qed 33 | 34 | lemma divides_one [resolve]: 35 | "is_semiring(R) \ a \. R \ divides(R,\\<^sub>R,a)" 36 | @proof @have "a = \\<^sub>R *\<^sub>R a" @qed 37 | 38 | lemma divides_zero [resolve]: 39 | "is_semiring(R) \ a \. R \ divides(R,a,\\<^sub>R)" 40 | @proof @have "\\<^sub>R = a *\<^sub>R \\<^sub>R" @qed 41 | 42 | section \Divides on natural numbers\ 43 | 44 | lemma nat_divides_cancel [forward]: 45 | "a \. \ \ b \. \ \ c \. \ \ c \ 0 \ 46 | divides(\, a *\<^sub>\ c, b *\<^sub>\ c) \ divides(\, a, b)" 47 | @proof 48 | @obtain "k\.\" where "b *\<^sub>\ c = a *\<^sub>\ c *\<^sub>\ k" 49 | @have "a *\<^sub>\ k *\<^sub>\ c = b *\<^sub>\ c" 50 | @qed 51 | 52 | lemma nat_le_prod [backward]: 53 | "a \. \ \ k \. \ \ k \ 0 \ a \\<^sub>\ a *\<^sub>\ k" 54 | @proof @have "k \\<^sub>\ 1" @have "a = a *\<^sub>\ 1" @qed 55 | 56 | lemma nat_divides_le [forward]: 57 | "b \ 0 \ divides(\,a,b) \ 1 \\<^sub>\ a \ a \\<^sub>\ b" 58 | @proof @obtain "k\.\" where "b = a *\<^sub>\ k" @qed 59 | 60 | definition even :: "i \ o" where [rewrite]: 61 | "even(x) \ divides(\,2,x)" 62 | 63 | definition odd :: "i \ o" where [rewrite]: 64 | "odd(x) \ (\divides(\,2,x))" 65 | 66 | section \Quotient and Remainder\ 67 | 68 | lemma quotient_remainder_theorem: 69 | "m >\<^sub>\ 0 \ n \ nat \ \q\nat. \r\nat. n = m *\<^sub>\ q +\<^sub>\ r \ 0 \\<^sub>\ r \ r <\<^sub>\ m" 70 | @proof 71 | @strong_induct "n \ nat" 72 | @case "n <\<^sub>\ m" 73 | @let "n' = n -\<^sub>\ m" 74 | @have "n' <\<^sub>\ n" @with @have "n' +\<^sub>\ m <\<^sub>\ n +\<^sub>\ m" @end 75 | @obtain "q\nat" "r\nat" where "n' = m *\<^sub>\ q +\<^sub>\ r" "0 \\<^sub>\ r" "r <\<^sub>\ m" 76 | @have "n = (m *\<^sub>\ q +\<^sub>\ r) +\<^sub>\ m" 77 | @have "n = (m *\<^sub>\ (q +\<^sub>\ \\<^sub>\)) +\<^sub>\ r" 78 | @qed 79 | 80 | section \Prime\ 81 | 82 | definition prime :: "i \ o" where [rewrite]: 83 | "prime(p) \ (p >\<^sub>\ 1 \ (\m. divides(\,m,p) \ m = 1 \ m = p))" 84 | 85 | lemma primeD1 [forward]: "prime(p) \ p >\<^sub>\ 1" by auto2 86 | lemma primeD2 [forward]: "prime(p) \ divides(\,m,p) \ m = 1 \ m = p" by auto2 87 | setup {* del_prfstep_thm_eqforward @{thm prime_def} *} 88 | 89 | lemma prime_odd_nat: "prime(p) \ p >\<^sub>\ 2 \ odd(p)" by auto2 90 | 91 | lemma exists_prime [resolve]: "\p. prime(p)" 92 | @proof 93 | @have "prime(2)" @with @have "2 \ 0" @end 94 | @qed 95 | 96 | lemma prime_factor_nat: "n \ nat \ n \ 1 \ \p. divides(\,p,n) \ prime(p)" 97 | @proof 98 | @strong_induct "n \ nat" 99 | @case "prime(n)" @with @have "divides(\,n,n)" @end 100 | @case "n = \\<^sub>\" @with 101 | @obtain q where "prime(q)" 102 | @have "divides(\,q,0)" 103 | @end 104 | @qed 105 | 106 | end 107 | -------------------------------------------------------------------------------- /FOL/FOL_Base.thy: -------------------------------------------------------------------------------- 1 | (* 2 | File: FOL_Base.thy 3 | Author: Bohua Zhan 4 | 5 | Theorems in logic needed to setup auto2 for FOL. 6 | *) 7 | 8 | theory FOL_Base 9 | imports FOL 10 | begin 11 | 12 | section \Declare type of sets\ 13 | 14 | declare [[eta_contract = false]] 15 | 16 | (* Type of sets *) 17 | typedecl i 18 | instance i :: "term" .. 19 | 20 | (* Membership relation *) 21 | axiomatization mem :: "[i, i] \ o" (infixl "\" 50) 22 | 23 | (* Bounded quantifiers *) 24 | definition Ball :: "[i, i \ o] \ o" where 25 | "Ball(A, P) \ (\x. x\A \ P(x))" 26 | 27 | definition Bex :: "[i, i \ o] \ o" where 28 | "Bex(A, P) \ (\x. x\A \ P(x))" 29 | 30 | syntax 31 | "_Ball" :: "[pttrn, i, o] \ o" ("(3\_\_./ _)" 10) 32 | "_Bex" :: "[pttrn, i, o] \ o" ("(3\_\_./ _)" 10) 33 | translations 34 | "\x\A. P" \ "CONST Ball(A, \x. P)" 35 | "\x\A. P" \ "CONST Bex(A, \x. P)" 36 | 37 | abbreviation not_mem :: "[i, i] \ o" (infixl "\" 50) where 38 | "x \ y \ \ (x \ y)" 39 | 40 | section \Theorems in logic used in auto2\ 41 | 42 | theorem to_contra_form: "Trueprop (A) \ (\A \ False)" by (rule equal_intr_rule) auto 43 | theorem to_contra_form': "Trueprop (\A) \ (A \ False)" by (rule equal_intr_rule) auto 44 | 45 | theorem iffD: "A \ B \ (A \ B) \ (B \ A)" by auto 46 | theorem contra_triv: "\A \ A \ False" by simp 47 | theorem or_intro1: "\ (P \ Q) \ \ P" by simp 48 | theorem or_intro2: "\ (P \ Q) \ \ Q" by simp 49 | theorem or_cancel1: "\Q \ (P \ Q) \ P" by auto 50 | theorem or_cancel2: "\P \ (P \ Q) \ Q" by auto 51 | theorem not_imp: "\(P \ Q) \ P \ \Q" by auto 52 | theorem exE': "(\x. P(x) \ Q) \ \x. P(x) \ Q" by auto 53 | theorem eq_True: "A \ A \ True" by simp 54 | theorem eq_True_inv: "A \ True \ A" by simp 55 | theorem disj_True1: "(True \ A) \ True" by simp 56 | theorem disj_True2: "(A \ True) \ True" by simp 57 | theorem ex_vardef: "\x. x = a" by simp 58 | theorem nn_create: "A \ \\A" by auto 59 | theorem all_trivial: "(\x. P) \ P" by auto 60 | 61 | theorem obj_sym: "Trueprop (t = s) \ Trueprop (s = t)" by (rule equal_intr_rule) auto 62 | theorem obj_sym_iff: "Trueprop (t \ s) \ Trueprop (s \ t)" by (rule equal_intr_rule) auto 63 | theorem to_meta_eq: "Trueprop (t = s) \ (t \ s)" by (rule equal_intr_rule) auto 64 | theorem to_meta_eq_iff: "Trueprop (t \ s) \ (t \ s)" by (rule equal_intr_rule) auto 65 | 66 | theorem inv_backward: "P \ Q \ \P \ \Q" by simp 67 | theorem backward_conv: "(A \ B) \ (\B \ \A)" by (rule equal_intr_rule) auto 68 | theorem backward1_conv: "(A \ B \ C) \ (\C \ B \ \A)" by (rule equal_intr_rule) auto 69 | theorem backward2_conv: "(A \ B \ C) \ (\C \ A \ \B)" by (rule equal_intr_rule) auto 70 | theorem resolve_conv: "(A \ B) \ (\B \ A \ False)" by (rule equal_intr_rule) auto 71 | 72 | (* Quantifiers: swapping out of ALL or EX *) 73 | theorem swap_ex_conj: "(P \ (\x. Q(x))) \ (\x. P \ Q(x))" by auto 74 | theorem swap_all_disj: "(P \ (\x. Q(x))) \ (\x. P \ Q(x))" by auto 75 | 76 | (* Use these instead of original versions to keep names in abstractions. *) 77 | theorem Bex_def': "(\x\S. P(x)) \ (\x. x \ S \ P(x))" using Bex_def by auto 78 | theorem Ball_def': "(\x\S. P(x)) \ (\x. x \ S \ P(x))" using Ball_def by auto 79 | 80 | (* Taking conjunction of assumptions *) 81 | 82 | theorem atomize_conjL: "(A \ B \ PROP C) \ (A \ B \ PROP C)" 83 | proof 84 | assume 1: "A \ B \ PROP C" and 2: "A \ B" 85 | have 3: "A" using 2 by auto 86 | have 4: "B" using 2 by auto 87 | show "PROP C" using 1[OF 3 4] by assumption 88 | next 89 | assume 1: "A \ B \ PROP C" and 2: A and 3: B 90 | have 4: "A \ B" using 2 3 by auto 91 | show "PROP C" using 1[OF 4] by assumption 92 | qed 93 | 94 | (* Other rules *) 95 | theorem imp_conv_disj: "(P \ Q) \ (\P \ Q)" by auto 96 | theorem not_ex: "\(\x. P(x)) \ (\x. \P(x))" by simp 97 | theorem not_all: "\(\x. P(x)) \ (\x. \P(x))" by simp 98 | 99 | (* AC for conj and disj *) 100 | theorem conj_assoc: "(P \ Q) \ R \ P \ Q \ R" by simp 101 | theorem disj_assoc: "(P \ Q) \ R \ P \ Q \ R" by simp 102 | 103 | end 104 | -------------------------------------------------------------------------------- /FOL/Graph.thy: -------------------------------------------------------------------------------- 1 | (* 2 | File: Graph.thy 3 | Author: Bohua Zhan 4 | 5 | Basics of graph of functions (as represented by a set of ordered pairs). 6 | *) 7 | 8 | theory Graph 9 | imports Set 10 | begin 11 | 12 | section \Graphs\ 13 | 14 | definition is_graph :: "i \ o" where [rewrite]: 15 | "is_graph(G) \ (\x\G. x = \fst(x),snd(x)\)" 16 | 17 | lemma is_graphE [forward]: "is_graph(G) \ x \ G \ x = \fst(x),snd(x)\" by auto2 18 | setup {* del_prfstep_thm_eqforward @{thm is_graph_def} *} 19 | 20 | definition gr_source :: "i \ i" where [rewrite]: 21 | "gr_source(G) = {fst(p). p \ G}" 22 | lemma gr_sourceI [typing2]: "\a,b\ \ G \ a \ gr_source(G)" by auto2 23 | lemma gr_sourceE [backward]: "is_graph(G) \ a \ gr_source(G) \ \b. \a,b\\G" by auto2 24 | setup {* del_prfstep_thm @{thm gr_source_def} *} 25 | 26 | definition gr_target :: "i \ i" where [rewrite]: 27 | "gr_target(G) = {snd(p). p \ G}" 28 | lemma gr_targetI [typing2]: "\a,b\ \ G \ b \ gr_target(G)" by auto2 29 | lemma gr_targetE [backward]: "is_graph(G) \ b \ gr_target(G) \ \a. \a,b\\G" by auto2 30 | setup {* del_prfstep_thm @{thm gr_target_def} *} 31 | 32 | definition gr_field :: "i \ i" where [rewrite]: 33 | "gr_field(G) = gr_source(G) \ gr_target(G)" 34 | lemma gr_fieldI1 [typing2]: "\a,b\ \ G \ a \ gr_field(G)" by auto2 35 | lemma gr_fieldI2 [typing2]: "\a,b\ \ G \ b \ gr_field(G)" by auto2 36 | 37 | definition gr_id :: "i \ i" where [rewrite]: 38 | "gr_id(A) = {\a,a\. a \ A}" 39 | lemma gr_id_is_graph [forward]: "is_graph(gr_id(A))" by auto2 40 | lemma gr_idI [typing2]: "a \ A \ \a,a\ \ gr_id(A)" by auto2 41 | lemma gr_id_iff [rewrite]: "p \ gr_id(A) \ (p\A\A \ fst(p) = snd(p))" by auto2 42 | setup {* del_prfstep_thm @{thm gr_id_def} *} 43 | 44 | definition gr_comp :: "i \ i \ i" (infixr "\\<^sub>g" 60) where [rewrite]: 45 | "s \\<^sub>g r = {p\gr_source(r)\gr_target(s). \z. \fst(p),z\\r \ \z,snd(p)\\s}" 46 | 47 | lemma gr_comp_is_graph [forward]: "is_graph(s \\<^sub>g r)" by auto2 48 | lemma gr_compI [backward2]: 49 | "\x,y\ \ r \ \y,z\ \ s \ \x,z\ \ s \\<^sub>g r" by auto2 50 | lemma gr_compE [forward]: 51 | "p \ s \\<^sub>g r \ \y. \fst(p),y\ \ r \ \y,snd(p)\ \ s" by auto2 52 | setup {* del_prfstep_thm @{thm gr_comp_def} *} 53 | 54 | section \Evaluation on a graph\ 55 | 56 | definition is_func_graph :: "i \ i \ o" where [rewrite]: 57 | "is_func_graph(G,X) \ is_graph(G) \ gr_source(G) = X \ (\a\X. \!y. \a,y\ \ G)" 58 | 59 | definition func_graphs :: "i \ i \ i" where [rewrite]: 60 | "func_graphs(X,Y) = {G\Pow(X\Y). is_func_graph(G,X)}" 61 | 62 | definition graph_eval :: "i \ i \ i" where [rewrite]: 63 | "graph_eval(G,x) = (THE y. \x,y\ \ G)" 64 | 65 | lemma is_func_graphD [forward]: 66 | "is_func_graph(G,X) \ is_graph(G) \ gr_source(G) = X" by auto2 67 | 68 | lemma is_func_graphD2 [forward]: 69 | "is_func_graph(G,X) \ x \ X \ \x, graph_eval(G,x)\ \ G" by auto2 70 | 71 | lemma is_func_graphD3 [forward]: 72 | "is_func_graph(G,X) \ \x,y\ \ G \ x \ X \ graph_eval(G,x) = y" by auto2 73 | 74 | lemma graph_eq [backward1]: 75 | "is_func_graph(G,X) \ is_func_graph(H,X) \ 76 | \x\X. graph_eval(G,x) = graph_eval(H,x) \ G = H" by auto2 77 | 78 | lemma is_func_graph_cons: 79 | "is_func_graph(G,X) \ a \ X \ is_func_graph(cons(\a,b\,G),cons(a,X))" 80 | @proof 81 | @let "H = cons(\a,b\,G)" 82 | @have "is_graph(H)" 83 | @have "\x\gr_source(H). x \ cons(a,X)" @with 84 | @obtain y where "\x,y\ \ H" 85 | @end 86 | @have "\c\cons(a,X). \!y. \c,y\ \ H" @with 87 | @case "c = a" 88 | @end 89 | @qed 90 | 91 | lemma is_func_graph_empty: "is_func_graph(\,\)" 92 | @proof 93 | @have "is_graph(\)" 94 | @have "\x\gr_source(\). x \ \" @with 95 | @obtain y where "\x,y\ \ \" 96 | @end 97 | @qed 98 | 99 | setup {* del_prfstep_thm_eqforward @{thm is_func_graph_def} *} 100 | setup {* del_prfstep_thm @{thm graph_eval_def} *} 101 | 102 | section \Graphs from a relation\ 103 | 104 | definition rel_graph :: "i \ (i \ i \ o) \ i" where [rewrite]: 105 | "rel_graph(S,R) = {p\S\S. R(fst(p),snd(p))}" 106 | 107 | lemma rel_graph_mem [typing]: "rel_graph(S,R) \ Pow(S\S)" by auto2 108 | lemma rel_graph_iff [rewrite]: "\x,y\ \ rel_graph(S,R) \ (x \ S \ y \ S \ R(x,y))" by auto2 109 | 110 | setup {* del_prfstep_thm @{thm rel_graph_def} *} 111 | 112 | end 113 | -------------------------------------------------------------------------------- /FOL/Logic_FOL.thy: -------------------------------------------------------------------------------- 1 | (* 2 | File: Logic_FOL.thy 3 | Author: Bohua Zhan 4 | 5 | Setup for proof steps related to logic. 6 | *) 7 | 8 | theory Logic_FOL 9 | imports Auto2_FOL 10 | begin 11 | 12 | section \Trivial contradictions\ 13 | 14 | setup {* add_resolve_prfstep @{thm refl} *} 15 | setup {* add_forward_prfstep @{thm contra_triv} *} 16 | setup {* add_resolve_prfstep @{thm TrueI} *} 17 | theorem FalseD [resolve]: "\False" by simp 18 | lemma exists_triv_eq [resolve]: "\x. x = x" by auto 19 | 20 | section \If and only iff\ 21 | 22 | setup {* add_gen_prfstep ("iff_intro1", 23 | [WithGoal @{term_pat "?A \ ?B"}, CreateCase @{term_pat "?A::o"}, WithScore 25]) *} 24 | theorem iff_goal: 25 | "\(A \ B) \ A \ \B" "\(A \ B) \ B \ \A" 26 | "\(A \ B) \ \A \ B" "\(A \ B) \ \B \ A" 27 | "\(\A \ B) \ A \ B" "\(A \ \B) \ B \ A" by auto 28 | setup {* fold (fn th => add_forward_prfstep_cond th [with_score 1]) @{thms iff_goal} *} 29 | 30 | section \Unique existence\ 31 | 32 | setup {* add_rewrite_rule @{thm ex1_def} *} 33 | 34 | (* To show \!x. P(x), first show \x. P(x), then name a variable x satisfying P. 35 | Finally show \y. P(y) \ x = y. *) 36 | setup {* add_gen_prfstep ("ex1_case", 37 | [WithGoal @{term_pat "\!x. ?P(x)"}, CreateConcl @{term_pat "\x. ?P(x)"}]) *} 38 | setup {* add_backward2_prfstep @{thm ex_ex1I} *} 39 | theorem ex_ex1I' [backward1]: 40 | "(\y. P(y) \ x = y) \ P(x) \ \!x. P(x)" by auto 41 | theorem ex_ex1D [forward]: 42 | "\!x. P(x) \ \x. P(x)" 43 | "\!x. P(x) \ P(x) \ \y. P(y) \ y = x" by auto 44 | setup {* del_prfstep_thm @{thm ex1_def} *} 45 | 46 | section \Let\ 47 | 48 | setup {* Normalizer.add_rewr_normalizer ("rewr_let", @{thm Let_def}) *} 49 | 50 | end 51 | -------------------------------------------------------------------------------- /FOL/Ordinal.thy: -------------------------------------------------------------------------------- 1 | (* 2 | File: Ordinal.thy 3 | Author: Bohua Zhan 4 | 5 | Basics of ordinal theory. 6 | *) 7 | 8 | theory Ordinal 9 | imports Wfrec 10 | begin 11 | 12 | section \Membership relation is well-founded\ 13 | 14 | definition mem_rel :: "i \ i" where [rewrite]: 15 | "mem_rel(A) = Order(A, \x y. x = y \ x \ y)" 16 | 17 | lemma mem_rel_is_rel [typing]: "mem_rel(A) \ raworder_space(A)" by auto2 18 | lemma mem_rel_eval [rewrite]: 19 | "R = mem_rel(A) \ x \. R \ y \. R \ x \\<^sub>R y \ (x = y \ x \ y)" by auto2 20 | lemma mem_rel_less_eval [rewrite]: 21 | "R = mem_rel(A) \ x \. R \ y \. R \ x <\<^sub>R y \ x \ y" 22 | @proof 23 | @case "x \ y" @with @have "x \ y" @end 24 | @qed 25 | setup {* del_prfstep_thm @{thm mem_rel_def} *} 26 | 27 | lemma wf_mem_rel [forward]: "wf(mem_rel(A))" 28 | @proof 29 | @have "\B. B \ A \ B \ \ \ (\x\B. ord_minimal(mem_rel(A),B,x))" @with 30 | @obtain "x\B" where "x \ B = \" @end 31 | @qed 32 | 33 | lemma refl_mem_rel [forward]: "refl_order(mem_rel(A))" by auto2 34 | 35 | section \Definition of ordinals\ 36 | 37 | definition trans_set :: "i \ o" where [rewrite]: 38 | "trans_set(i) \ (\x\i. x \ i)" 39 | 40 | definition ord :: "i \ o" where [rewrite]: 41 | "ord(i) \ (trans_set(i) \ (\x\i. trans_set(x)))" 42 | 43 | lemma ordI [backward]: "trans_set(i) \ (\j\i. trans_set(j)) \ ord(i)" by auto2 44 | 45 | lemma ord_mem_is_ord [forward]: "ord(i) \ j \ i \ ord(j)" by auto2 46 | lemma ord_is_trans_set [forward]: "ord(i) \ trans_set(i)" by auto2 47 | setup {* del_prfstep_thm @{thm ord_def} *} 48 | 49 | lemma trans_mem_rel [forward]: "ord(i) \ trans(mem_rel(i))" by auto2 50 | 51 | (* succ is an ordinal *) 52 | lemma ord_succ_is_ord [forward]: "ord(i) \ ord(succ(i))" by auto2 53 | 54 | (* Union is an ordinal. *) 55 | lemma union_ord: "\x\S. ord(x) \ ord(\S)" by auto2 56 | lemma union_ordP: "\a\I. ord(X(a)) \ ord(\a\I. X(a))" by auto2 57 | 58 | section \Induction on ordinals\ 59 | 60 | lemma ord_induct' [strong_induct]: 61 | "ord(k) \ i \ k \ \x\k. (\y\x. P(y)) \ P(x) \ P(i)" 62 | @proof @strong_induct "wf(mem_rel(k)) \ i \. mem_rel(k)" @qed 63 | 64 | lemma ord_induct [script_induct]: 65 | "ord(i) \ \x. ord(x) \ (\y\x. P(y)) \ P(x) \ P(i)" 66 | @proof @strong_induct "ord(succ(i)) \ i \ succ(i)" @qed 67 | 68 | lemma ord_double_induct [script_induct]: 69 | "ord(i) \ ord(j) \ 70 | \x y. ord(x) \ ord(y) \ (\x'\x. P(x',y)) \ (\y'\y. P(x,y')) \ P(x,y) \ P(i,j)" 71 | @proof 72 | @induct "ord(i)" "\j. ord(j) \ P(i,j)" @with 73 | @subgoal "P(i',j')" 74 | @induct "ord(j')" "P(i',j')" 75 | @endgoal 76 | @end 77 | @qed 78 | 79 | (* Ordinals are linearly ordered *) 80 | lemma ord_linear [resolve]: 81 | "ord(i) \ ord(j) \ i \ j \ i = j \ j \ i" 82 | @proof 83 | @induct "ord(i) \ ord(j)" "i \ j \ i = j \ j \ i" 84 | @qed 85 | 86 | section \Limit ordinals\ 87 | 88 | definition limit_ord :: "i \ o" where [rewrite]: 89 | "limit_ord(i) \ (ord(i) \ \ \ i \ (\y. y \ i \ succ(y) \ i))" 90 | 91 | lemma limit_ordD [forward]: 92 | "limit_ord(i) \ ord(i)" 93 | "limit_ord(i) \ \ \ i" by auto2+ 94 | 95 | lemma limit_ordD2 [backward]: 96 | "limit_ord(i) \ y \ i \ succ(y) \ i" by auto2 97 | 98 | lemma limit_ord_not_succ [resolve]: 99 | "\limit_ord(succ(a))" by auto2 100 | setup {* del_prfstep_thm_eqforward @{thm limit_ord_def} *} 101 | 102 | end 103 | -------------------------------------------------------------------------------- /FOL/Semiring.thy: -------------------------------------------------------------------------------- 1 | (* 2 | File: Semiring.thy 3 | Author: Bohua Zhan 4 | 5 | Semirings. 6 | *) 7 | 8 | theory Semiring 9 | imports Group AbGroup OrderRel 10 | begin 11 | 12 | (* We define semirings to be commutative (it is only used for Nat). *) 13 | 14 | section \Semirings\ 15 | 16 | definition is_zero_mult :: "i \ o" where [rewrite]: 17 | "is_zero_mult(R) \ (\x\.R. \\<^sub>R *\<^sub>R x = \\<^sub>R \ x *\<^sub>R \\<^sub>R = \\<^sub>R)" 18 | 19 | lemma is_zero_multD [rewrite]: 20 | "is_zero_mult(R) \ x \. R \ \\<^sub>R *\<^sub>R x = \\<^sub>R" 21 | "is_zero_mult(R) \ x \. R \ x *\<^sub>R \\<^sub>R = \\<^sub>R" by auto2+ 22 | setup {* del_prfstep_thm_eqforward @{thm is_zero_mult_def} *} 23 | 24 | definition is_semiring :: "i \ o" where [rewrite]: 25 | "is_semiring(R) \ (is_ring_raw(R) \ is_ab_monoid(R) \ is_monoid(R) \ 26 | is_times_comm(R) \ is_left_distrib(R) \ is_zero_mult(R) \ \\<^sub>R \ \\<^sub>R)" 27 | 28 | lemma is_semiringD [forward]: 29 | "is_semiring(R) \ is_ring_raw(R)" 30 | "is_semiring(R) \ is_ab_monoid(R)" 31 | "is_semiring(R) \ is_monoid(R)" 32 | "is_semiring(R) \ is_times_comm(R)" 33 | "is_semiring(R) \ is_left_distrib(R)" 34 | "is_semiring(R) \ is_zero_mult(R)" by auto2+ 35 | 36 | lemma is_semiringD' [resolve]: "is_semiring(R) \ \\<^sub>R \ \\<^sub>R" by auto2 37 | setup {* del_prfstep_thm_eqforward @{thm is_semiring_def} *} 38 | 39 | ML_file "alg_semiring.ML" 40 | 41 | section \Ordered semirings\ 42 | 43 | definition is_ord_semiring :: "i \ o" where [rewrite]: 44 | "is_ord_semiring(R) \ (is_ord_ring_raw(R) \ is_semiring(R) \ linorder(R) \ 45 | ord_ring_add_left(R) \ ord_semiring_mult_left(R))" 46 | 47 | lemma is_ord_semiringD [forward]: 48 | "is_ord_semiring(R) \ is_ord_ring_raw(R)" 49 | "is_ord_semiring(R) \ is_semiring(R)" 50 | "is_ord_semiring(R) \ linorder(R)" 51 | "is_ord_semiring(R) \ ord_ring_add_left(R)" 52 | "is_ord_semiring(R) \ ord_semiring_mult_left(R)" by auto2+ 53 | setup {* del_prfstep_thm_eqforward @{thm is_ord_semiring_def} *} 54 | 55 | lemma ord_semiring_mult_right [backward]: 56 | "is_ord_semiring(R) \ c \. R \ a \\<^sub>R b \ a *\<^sub>R c \\<^sub>R b *\<^sub>R c" 57 | @proof @have "c *\<^sub>R a \\<^sub>R c *\<^sub>R b" @qed 58 | 59 | lemma ord_semiring_add_right [backward]: 60 | "is_ord_semiring(R) \ c \. R \ a \\<^sub>R b \ a +\<^sub>R c \\<^sub>R b +\<^sub>R c" 61 | @proof @have "c +\<^sub>R a \\<^sub>R c +\<^sub>R b" @qed 62 | 63 | lemma ord_semiring_add_mix [backward1, backward2]: 64 | "is_ord_semiring(R) \ p \\<^sub>R q \ r \\<^sub>R s \ p +\<^sub>R r \\<^sub>R q +\<^sub>R s" 65 | @proof @have "p +\<^sub>R r \\<^sub>R p +\<^sub>R s" @qed 66 | 67 | end 68 | -------------------------------------------------------------------------------- /FOL/SetSum.thy: -------------------------------------------------------------------------------- 1 | (* 2 | File: SetSum.thy 3 | Author: Bohua Zhan 4 | 5 | Sum of two sets. Corresponds to Sum.thy in Isabelle/ZF. 6 | *) 7 | 8 | theory SetSum 9 | imports Nat 10 | begin 11 | 12 | section \Booleans\ 13 | 14 | definition bool :: "i" where 15 | "bool = {0,1}" 16 | 17 | (* Conditional on the first argument, which is a boolean. *) 18 | definition cond :: "i \ i \ i \ i" where 19 | "cond(b,c,d) = (if b = 1 then c else d)" 20 | 21 | definition not :: "i \ i" where 22 | "not(b) = cond(b,0,1)" 23 | 24 | definition "and" :: "i \ i \ i" (infixl "and" 70) where 25 | "a and b = cond(a,b,0)" 26 | 27 | definition "or" :: "i \ i \ i" (infixl "or" 65) where 28 | "a or b = cond(a,1,b)" 29 | 30 | definition "xor" :: "i \ i \ i" (infixl "xor" 65) where 31 | "a xor b = cond(a,not(b),b)" 32 | 33 | setup {* add_rewrite_rule @{thm bool_def} *} 34 | lemma bool_1I [resolve]: "1 \ bool" by auto2 35 | lemma bool_0I [resolve]: "0 \ bool" by auto2 36 | 37 | lemma boolE [forward]: "a \ bool \ a = 0 \ a = 1" by auto2 38 | setup {* del_prfstep_thm @{thm bool_def} *} 39 | 40 | setup {* add_rewrite_rule @{thm cond_def} *} 41 | lemma cond_1 [rewrite]: "cond(1,c,d) = c" by auto2 42 | lemma cond_0 [rewrite]: "cond(0,c,d) = d" by auto2 43 | lemma cond_simple_type: "b \ bool \ c \ A \ d \ A \ cond(b,c,d) \ A" by auto2 44 | setup {* del_prfstep_thm @{thm cond_def} *} 45 | 46 | setup {* add_rewrite_rule @{thm not_def} *} 47 | lemma not_type: "a \ bool \ not(a) \ bool" by auto2 48 | 49 | setup {* add_rewrite_rule @{thm and_def} *} 50 | lemma and_type: "a \ bool \ b \ bool \ a and b \ bool" by auto2 51 | 52 | setup {* add_rewrite_rule @{thm or_def} *} 53 | lemma or_type: "a \ bool \ b \ bool \ a or b \ bool" by auto2 54 | 55 | setup {* add_rewrite_rule @{thm xor_def} *} 56 | lemma xor_type: "a \ bool \ b \ bool \ a xor b \ bool" by auto2 57 | 58 | definition bool_of_o :: "o \ i" where 59 | "bool_of_o(P) = (if P then 1 else 0)" 60 | setup {* add_rewrite_rule @{thm bool_of_o_def} *} 61 | 62 | lemma bool_of_True [rewrite]: "bool_of_o(True) = 1" by auto2 63 | lemma bool_of_False [rewrite]: "bool_of_o(False) = 0" by auto2 64 | lemma bool_of_o_type [resolve]: "bool_of_o(P) \ bool" by auto2 65 | lemma bool_of_P_is_1 [rewrite]: "(bool_of_o(P) = 1) \ P" by auto2 66 | lemma bool_of_P_is_0 [rewrite]: "(bool_of_o(P) = 0) \ \P" by auto2 67 | 68 | section \Disjoint sum\ 69 | 70 | definition sum :: "i \ i \ i" (infixr "+" 65) where 71 | "A + B = {0} \ A \ {1} \ B" 72 | 73 | definition Inl :: "i \ i" where 74 | "Inl(a) = \0,a\" 75 | 76 | definition Inr :: "i \ i" where 77 | "Inr(b) = \1,b\" 78 | 79 | definition "case" :: "[i\i, i\i, i] \ i" where 80 | "case(c,d,p) = cond(fst(p), d(snd(p)), c(snd(p)))" 81 | 82 | subsection \Rules for disjoint sums\ 83 | 84 | setup {* add_rewrite_rule @{thm sum_def} *} 85 | setup {* add_rewrite_rule @{thm Inl_def} *} 86 | setup {* add_rewrite_rule @{thm Inr_def} *} 87 | 88 | lemma Sigma_bool: "Sigma(bool,C) = C(0) + C(1)" by auto2 89 | lemma InlI_type [rewrite]: "Inl(a) \ A + B \ a \ A" by auto2 90 | lemma InrI_type [rewrite]: "Inr(b) \ A + B \ b \ B" by auto2 91 | 92 | lemma sum_iff [forward]: 93 | "u \ A + B \ (\x\A. u = Inl(x)) \ (\y\B. u = Inr(y))" by auto2 94 | 95 | lemma Inl_inj [forward]: "Inl(a) = Inl(b) \ a = b" by auto2 96 | lemma Inr_inj [forward]: "Inr(a) = Inr(b) \ a = b" by auto2 97 | lemma Inl_Inr_neq [resolve]: "Inl(a) \ Inr(b)" by auto2 98 | lemma sum_empty: "\ + \ = \" by auto2 99 | 100 | lemma sum_subset_iff [rewrite]: "A + B \ C + D \ A \ C \ B \ D" 101 | @proof 102 | @case "A + B \ C + D" @with 103 | @have "\x\A. x \ C" @with @have "Inl(x) \ A + B" @end 104 | @have "\y\B. y \ D" @with @have "Inr(y) \ A + B" @end @end 105 | @qed 106 | 107 | lemma sum_equal [forward]: "A + B = C + D \ A = C \ B = D" 108 | @proof @have "A + B \ C + D" @have "C + D \ A + B" @qed 109 | 110 | section \Case\ 111 | 112 | setup {* add_rewrite_rule @{thm case_def} *} 113 | 114 | lemma case_Inl [rewrite]: "case(c, d, Inl(a)) = c(a)" by auto2 115 | lemma case_Inr [rewrite]: "case(c, d, Inr(b)) = d(b)" by auto2 116 | 117 | setup {* del_prfstep_thm @{thm case_def} *} 118 | 119 | end 120 | -------------------------------------------------------------------------------- /FOL/Topology/Closure.thy: -------------------------------------------------------------------------------- 1 | (* 2 | File: Closure.thy 3 | Author: Bohua Zhan 4 | 5 | Closure in topological spaces. 6 | *) 7 | 8 | theory Closure 9 | imports ProductTopology 10 | begin 11 | 12 | definition interior :: "i \ i \ i" where [rewrite]: 13 | "interior(X,A) = \{U\open_sets(X). U \ A}" 14 | setup {* register_wellform_data ("interior(X,A)", ["A \ carrier(X)"]) *} 15 | 16 | lemma interior_subset [resolve]: "interior(X,A) \ A" by auto2 17 | lemma interior_open [resolve]: "is_top_space(X) \ is_open(X,interior(X,A))" by auto2 18 | 19 | definition closure :: "i \ i \ i" where [rewrite]: 20 | "closure(X,A) = \{C\closed_sets(X). A \ C}" 21 | setup {* register_wellform_data ("closure(X,A)", ["A \ carrier(X)"]) *} 22 | 23 | lemma closure_prop: 24 | "is_top_space(X) \ A \ carrier(X) \ A \ closure(X,A) \ is_closed(X,closure(X,A))" 25 | @proof @have "carrier(X) \ {C\closed_sets(X). A \ C}" @qed 26 | setup {* add_forward_prfstep_cond @{thm closure_prop} [with_term "closure(?X,?A)"] *} 27 | 28 | lemma closure_subset' [backward2]: 29 | "is_top_space(X) \ A \ carrier(X) \ is_closed(X,B) \ A \ B \ closure(X,A) \ B" 30 | @proof @have "carrier(X) \ {C\closed_sets(X). A \ C}" @qed 31 | 32 | lemma closure_subspace: 33 | "is_top_space(X) \ Y \ carrier(X) \ A \ Y \ closure(subspace(X,Y),A) = Y \ closure(X,A)" 34 | @proof 35 | @let "B = closure(subspace(X,Y), A)" 36 | @have "B \ Y \ closure(X,A)" @with 37 | @have "is_closed(subspace(X,Y), Y \ closure(X,A))" @end 38 | @obtain "C\closed_sets(X)" where "B = Y \ C" 39 | @have "closure(X,A) \ C" 40 | @have "Y \ closure(X,A) \ Y \ C" 41 | @qed 42 | 43 | lemma closure_mem1 [backward1]: 44 | "is_top_space(X) \ A \ carrier(X) \ x \. X \ x \ closure(X,A) \ \U\neighs(X,x). U \ A = \" 45 | @proof @have "carrier(X) \ closure(X,A) \ neighs(X,x)" @qed 46 | 47 | lemma closure_mem2 [forward]: 48 | "is_top_space(X) \ A \ carrier(X) \ x \. X \ x \ closure(X,A) \ U \ neighs(X,x) \ U \ A \ \" 49 | @proof 50 | @contradiction 51 | @have "is_closed(X, carrier(X) \ U)" 52 | @have "closure(X,A) \ carrier(X) \ U" 53 | @qed 54 | 55 | definition hausdorff :: "i \ o" where [rewrite]: 56 | "hausdorff(X) \ (is_top_space(X) \ (\x\.X. \y\.X. x \ y \ (\U\neighs(X,x). \V\neighs(X,y). U \ V = \)))" 57 | 58 | lemma hausdorffD1 [forward]: "hausdorff(X) \ is_top_space(X)" by auto2 59 | lemma hausdorffD2 [backward]: "hausdorff(X) \ x \. X \ y \. X \ x \ y \ \U\neighs(X,x). \V\neighs(X,y). U \ V = \" by auto2 60 | setup {* del_prfstep_thm_eqforward @{thm hausdorff_def} *} 61 | 62 | definition T1_space :: "i \ o" where [rewrite]: 63 | "T1_space(X) \ (is_top_space(X) \ (\x\.X. is_closed(X,{x})))" 64 | 65 | lemma T1_spaceD1 [forward]: "T1_space(X) \ is_top_space(X)" by auto2 66 | lemma T1_spaceD2: "T1_space(X) \ x \. X \ is_closed(X,{x})" by auto2 67 | setup {* add_forward_prfstep_cond @{thm T1_spaceD2} [with_term "{?x}"] *} 68 | setup {* del_prfstep_thm_eqforward @{thm T1_space_def} *} 69 | 70 | lemma hausdorff_is_T1 [forward]: "hausdorff(X) \ T1_space(X)" 71 | @proof 72 | @have "\x\.X. is_closed(X,{x})" @with 73 | @contradiction 74 | @have "\y\closure(X,{x}). y \ {x}" @with 75 | @contradiction 76 | @obtain "U\neighs(X,x)" "V\neighs(X,y)" where "U \ V = \" @end @end 77 | @qed 78 | 79 | lemma subspace_hausdorff: "hausdorff(X) \ A \ carrier(X) \ hausdorff(subspace(X,A))" 80 | @proof 81 | @let "Y = subspace(X,A)" 82 | @have "\x\.Y. \y\.Y. x \ y \ (\U\neighs(Y,x). \V\neighs(Y,y). U \ V = \)" @with 83 | @obtain "U\neighs(X,x)" "V\neighs(X,y)" where "U \ V = \" 84 | @have "(A \ U) \ (A \ V) = \" @end 85 | @qed 86 | setup {* add_forward_prfstep_cond @{thm subspace_hausdorff} [with_term "subspace(?X,?A)"] *} 87 | 88 | lemma product_hausdorff [forward]: "hausdorff(X) \ hausdorff(Y) \ hausdorff(X \\<^sub>T Y)" 89 | @proof 90 | @let "Z = X \\<^sub>T Y" 91 | @have "\x\.Z. \y\.Z. x \ y \ (\U\neighs(Z,x). \V\neighs(Z,y). U \ V = \)" @with 92 | @case "fst(x) \ fst(y)" @with 93 | @obtain "U\neighs(X,fst(x))" "V\neighs(X,fst(y))" where "U \ V = \" 94 | @have "(U \ carrier(Y)) \ (V \ carrier(Y)) = \" @end 95 | @case "snd(x) \ snd(y)" @with 96 | @obtain "U\neighs(Y,snd(x))" "V\neighs(Y,snd(y))" where "U \ V = \" 97 | @have "(carrier(X) \ U) \ (carrier(X) \ V) = \" @end 98 | @end 99 | @qed 100 | 101 | end 102 | -------------------------------------------------------------------------------- /FOL/alg_assoc.ML: -------------------------------------------------------------------------------- 1 | (* 2 | File: alg_assoc.ML 3 | Author: Bohua Zhan 4 | 5 | Normalization for Associativity (outside structures). 6 | *) 7 | 8 | signature FOL_ASSOC = 9 | sig 10 | val dest_assoc: term -> term -> term list 11 | val normalize_assoc: term * thm -> wfconv 12 | val alg_assoc_prfstep: term * thm -> proofstep 13 | end; 14 | 15 | structure FOL_Assoc : FOL_ASSOC = 16 | struct 17 | 18 | fun dest_assoc fhead t = 19 | if Term.head_of t aconv fhead then 20 | maps (dest_assoc fhead) [dest_arg1 t, dest_arg t] 21 | else [t] 22 | 23 | fun normalize_assoc (fhead, assoc_l) wft = 24 | let 25 | val assoc_l_cv = WfTerm.rewr_obj_eq [fhead] assoc_l 26 | fun normalize wft = 27 | if Term.head_of (WfTerm.term_of wft) aconv fhead then 28 | WfTerm.every_conv [WfTerm.repeat_conv assoc_l_cv, 29 | WfTerm.arg1_conv normalize] wft 30 | else 31 | WfTerm.all_conv wft 32 | in 33 | normalize wft 34 | end 35 | 36 | fun alg_assoc_prfstep_fn (fhead, assoc_l) ctxt item1 item2 = 37 | let 38 | val {id = id1, tname = tname1, ...} = item1 39 | val {id = id2, tname = tname2, ...} = item2 40 | val id = BoxID.merge_boxes ctxt (id1, id2) 41 | val (ct1, ct2) = (the_single tname1, the_single tname2) 42 | val (t1, t2) = (Thm.term_of ct1, Thm.term_of ct2) 43 | val (ts1, ts2) = apply2 (dest_assoc fhead) (t1, t2) 44 | in 45 | if not (eq_list (op aconv) (ts1, ts2)) then [] 46 | else if RewriteTable.is_equiv id ctxt (ct1, ct2) then [] 47 | else let 48 | val wfts1 = WellformData.term_to_wfterm ctxt [fhead] (id, t1) 49 | val wfts2 = WellformData.term_to_wfterm ctxt [fhead] (id, t2) 50 | fun process_wft (id', (wft1, wft2)) = 51 | let 52 | val (_, eq1) = normalize_assoc (fhead, assoc_l) wft1 53 | val (_, eq2) = normalize_assoc (fhead, assoc_l) wft2 54 | val _ = assert (Util.rhs_of eq1 aconv Util.rhs_of eq2) 55 | "alg_assoc_prfstep" 56 | val eq_th = to_obj_eq (Util.transitive_list [eq1, meta_sym eq2]) 57 | in 58 | AddItems {id = id', sc = SOME 1, 59 | raw_items = [Update.thm_to_ritem eq_th]} 60 | end 61 | in 62 | (Util.all_pairs (wfts1, wfts2)) 63 | |> map (fn ((id1, wft1), (id2, wft2)) => 64 | (BoxID.merge_boxes ctxt (id1, id2), (wft1, wft2))) 65 | |> filter (BoxID.has_incr_id o fst) 66 | |> map process_wft 67 | end 68 | end 69 | 70 | fun alg_assoc_prfstep (fhead, assoc_l) = 71 | let 72 | val (c, _) = Term.dest_Const fhead 73 | in 74 | {name = c ^ "@assoc", 75 | args = [TypedUniv TY_TERM, TypedUniv TY_TERM], 76 | func = TwoStep (alg_assoc_prfstep_fn (fhead, assoc_l))} 77 | end 78 | 79 | end (* structure FOL_Assoc *) 80 | -------------------------------------------------------------------------------- /FOL/alg_fol.ML: -------------------------------------------------------------------------------- 1 | (* 2 | File: alg_fol.ML 3 | Author: Bohua Zhan 4 | 5 | Normalization on algebraic structures in FOL. 6 | *) 7 | 8 | signature FOL_ALG_UTIL = 9 | sig 10 | type alg_norm_info 11 | val get_struct_t: term list -> term -> term option 12 | val alg_norm1_prfstep: alg_norm_info -> proofstep 13 | val alg_norm2_prfstep: alg_norm_info -> proofstep 14 | end; 15 | 16 | structure FOLAlgUtil : FOL_ALG_UTIL = 17 | struct 18 | 19 | type alg_norm_info = { 20 | op_heads: term list, 21 | pred_t: term, 22 | norm_t: term -> term -> term, 23 | excl_norm_t: (term -> term -> term) list, 24 | norm_wfcv: thm -> wfconv 25 | } 26 | 27 | fun get_struct_t op_heads t = 28 | if member (op aconv) op_heads (head_of t) then 29 | SOME (hd (Util.dest_args t)) 30 | else NONE 31 | 32 | fun alg_norm1_prfstep_fn norm_info ctxt {id, tname, ...} = 33 | let 34 | val {op_heads, pred_t, norm_t, excl_norm_t, norm_wfcv} = norm_info 35 | val ct = the_single tname 36 | val t = Thm.term_of ct 37 | val G_opt = get_struct_t op_heads t 38 | in 39 | if is_none G_opt then [] 40 | else let 41 | val G = the G_opt 42 | val t' = norm_t G t 43 | in 44 | if member (op aconv) op_heads (head_of t') orelse 45 | RewriteTable.is_equiv id ctxt (ct, Thm.cterm_of ctxt t') orelse 46 | exists (fn f => f G t aconv t') excl_norm_t then [] 47 | else let 48 | val fheads = map (fn t => t $ G) op_heads 49 | val property_infos = PropertyData.get_property_t ctxt (id, pred_t $ G) 50 | 51 | fun process_wft property_th (id', wft) = 52 | let 53 | val wfcv = norm_wfcv property_th 54 | val (_, eq) = wfcv wft 55 | in 56 | if Util.rhs_of eq aconv t' then 57 | AddItems {id = id', sc = SOME 1, 58 | raw_items = [Update.thm_to_ritem (to_obj_eq eq)]} 59 | else let 60 | val _ = trace_tlist ctxt "" [t, Util.rhs_of eq, t'] 61 | val (c, _) = Term.dest_Const pred_t 62 | in 63 | raise Fail ("alg_norm1 for " ^ c) 64 | end 65 | end 66 | 67 | fun process_property_info (id', property_th) = 68 | (WellformData.cterm_to_wfterm ctxt fheads (id', ct)) 69 | |> filter (BoxID.has_incr_id o fst) 70 | |> map (process_wft property_th) 71 | in 72 | maps process_property_info property_infos 73 | end 74 | end 75 | end 76 | 77 | fun alg_norm1_prfstep norm_info = 78 | let 79 | val {pred_t, ...} = norm_info 80 | val (c, _) = Term.dest_Const pred_t 81 | handle TERM _ => raise Fail "alg_norm1_prfstep" 82 | in 83 | {name = c ^ "@norm1", 84 | args = [TypedUniv TY_TERM], 85 | func = OneStep (alg_norm1_prfstep_fn norm_info)} 86 | end 87 | 88 | fun alg_norm2_prfstep_fn norm_info ctxt item1 item2 = 89 | let 90 | val {op_heads, pred_t, norm_t, excl_norm_t, norm_wfcv} = norm_info 91 | val {id = id1, tname = tname1, ...} = item1 92 | val {id = id2, tname = tname2, ...} = item2 93 | val id = BoxID.merge_boxes ctxt (id1, id2) 94 | val (ct1, ct2) = (the_single tname1, the_single tname2) 95 | val (t1, t2) = (Thm.term_of ct1, Thm.term_of ct2) 96 | val (G1_opt, G2_opt) = apply2 (get_struct_t op_heads) (t1, t2) 97 | in 98 | if is_none G1_opt orelse is_none G2_opt orelse 99 | not (the G1_opt aconv the G2_opt) orelse 100 | Term_Ord.term_ord (t2, t1) = LESS then [] 101 | else let 102 | val G = the G1_opt 103 | val t1' = norm_t G t1 104 | val t2' = norm_t G t2 105 | in 106 | if not (t1' aconv t2') orelse 107 | RewriteTable.is_equiv id ctxt (ct1, ct2) orelse 108 | exists (fn f => f G t1 aconv f G t2) excl_norm_t then [] 109 | else let 110 | val fheads = map (fn t => t $ G) op_heads 111 | val property_infos = PropertyData.get_property_t ctxt (id, pred_t $ G) 112 | 113 | fun process_wft property_th (id', (wft1, wft2)) = 114 | let 115 | val wfcv = norm_wfcv property_th 116 | val (_, eq1) = wfcv wft1 117 | val (_, eq2) = wfcv wft2 118 | in 119 | if Util.rhs_of eq1 aconv t1' andalso Util.rhs_of eq2 aconv t2' then 120 | let 121 | val th = to_obj_eq (Util.transitive_list [eq1, meta_sym eq2]) 122 | in 123 | AddItems {id = id', sc = SOME 1, 124 | raw_items = [Update.thm_to_ritem th]} 125 | end 126 | else let 127 | val _ = trace_tlist ctxt "" [t1, Util.rhs_of eq1, t1'] 128 | val _ = trace_tlist ctxt "" [t2, Util.rhs_of eq2, t2'] 129 | val (c, _) = Term.dest_Const pred_t 130 | in 131 | raise Fail ("alg_norm2 for " ^ c) 132 | end 133 | end 134 | 135 | fun process_property_info (id', property_th) = 136 | let 137 | val wfts1 = WellformData.cterm_to_wfterm ctxt fheads (id', ct1) 138 | val wfts2 = WellformData.cterm_to_wfterm ctxt fheads (id', ct2) 139 | in 140 | (Util.all_pairs (wfts1, wfts2)) 141 | |> map (fn ((id1, wft1), (id2, wft2)) => 142 | (BoxID.merge_boxes ctxt (id1, id2), (wft1, wft2))) 143 | |> filter (BoxID.has_incr_id o fst) 144 | |> map (process_wft property_th) 145 | end 146 | in 147 | maps process_property_info property_infos 148 | end 149 | end 150 | end 151 | 152 | fun alg_norm2_prfstep norm_info = 153 | let 154 | val {pred_t, ...} = norm_info 155 | val (c, _) = Term.dest_Const pred_t 156 | in 157 | {name = c ^ "@norm2", 158 | args = [TypedUniv TY_TERM, TypedUniv TY_TERM], 159 | func = TwoStep (alg_norm2_prfstep_fn norm_info)} 160 | end 161 | 162 | end (* structure AlgUtil. *) 163 | -------------------------------------------------------------------------------- /FOL/alg_group.ML: -------------------------------------------------------------------------------- 1 | (* 2 | File: alg_group.ML 3 | Author: Bohua Zhan 4 | 5 | Normalization for groups. 6 | *) 7 | 8 | val inv_t = @{term inv} 9 | 10 | fun is_inv G t = Util.is_head (inv_t $ G) t 11 | fun is_inv_pair_l G (t1, t2) = (t1 aconv inv_t $ G $ t2) 12 | fun is_inv_pair_r G (t1, t2) = (t2 aconv inv_t $ G $ t1) 13 | 14 | signature ALG_GROUP = 15 | sig 16 | type group_info 17 | val group_mult_atom: group_info -> wfconv 18 | val group_mult_monomial: group_info -> wfconv 19 | val normalize_group: group_info -> wfconv 20 | val group_alg_data: thm -> group_info 21 | 22 | val reduce_atom_list: term -> term list -> term list 23 | val mult_atom_list: term -> term list * term list -> term list 24 | val inv_atom_list: term -> term list -> term list 25 | val norm_atom_list: term -> term -> term list 26 | val norm_term: term -> term -> term 27 | val add_group_proofsteps: theory -> theory 28 | end; 29 | 30 | structure AlgGroup : ALG_GROUP = 31 | struct 32 | 33 | type group_info = { 34 | G: term, 35 | assoc_l: wfconv, (* x * (y * z) = (x * y) * z *) 36 | assoc_r: wfconv, (* (x * y) * z = x * (y * z) *) 37 | unit_l: wfconv, (* 1 * x = x *) 38 | unit_r: wfconv, (* x * 1 = x *) 39 | inv_unit: wfconv, (* inv(1) = 1 *) 40 | inv_l: wfconv, (* inv(x) * x = 1 *) 41 | inv_r: wfconv, (* x * inv(x) = 1 *) 42 | inv_inv: wfconv, (* inv(inv(x)) = x *) 43 | inv_distrib: wfconv (* inv(x * y) = inv(y) * inv(x) *) 44 | } 45 | 46 | fun group_mult_atom info wft = 47 | let 48 | val {G, assoc_r, unit_l, unit_r, inv_l, inv_r, ...} = info 49 | val (arg1, arg2) = Util.dest_binop_args (WfTerm.term_of wft) 50 | in 51 | if is_one G arg1 then unit_l wft 52 | else if is_one G arg2 then unit_r wft 53 | else if is_times G arg1 then 54 | if is_inv_pair_l G (dest_arg arg1, arg2) then 55 | WfTerm.every_conv [assoc_r, WfTerm.arg_conv inv_l, unit_r] wft 56 | else if is_inv_pair_r G (dest_arg arg1, arg2) then 57 | WfTerm.every_conv [assoc_r, WfTerm.arg_conv inv_r, unit_r] wft 58 | else 59 | WfTerm.all_conv wft 60 | else 61 | if is_inv_pair_l G (arg1, arg2) then inv_l wft 62 | else if is_inv_pair_r G (arg1, arg2) then inv_r wft 63 | else WfTerm.all_conv wft 64 | end 65 | 66 | fun group_mult_monomial info wft = 67 | let 68 | val {G, assoc_l, ...} = info 69 | val (_, arg2) = Util.dest_binop_args (WfTerm.term_of wft) 70 | in 71 | if is_times G arg2 then 72 | WfTerm.every_conv [ 73 | assoc_l, 74 | WfTerm.arg1_conv (group_mult_monomial info), 75 | group_mult_atom info] wft 76 | else 77 | group_mult_atom info wft 78 | end 79 | 80 | fun normalize_group info wft = 81 | let 82 | val {G, inv_unit, inv_distrib, inv_inv, ...} = info 83 | val t = WfTerm.term_of wft 84 | in 85 | if is_times G t then 86 | WfTerm.every_conv [ 87 | WfTerm.binop_conv (normalize_group info), 88 | group_mult_monomial info] wft 89 | else if is_inv G t then 90 | if is_one G (dest_arg t) then 91 | inv_unit wft 92 | else if is_inv G (dest_arg t) then 93 | WfTerm.every_conv [inv_inv, normalize_group info] wft 94 | else if is_times G (dest_arg t) then 95 | WfTerm.every_conv [ 96 | inv_distrib, 97 | WfTerm.binop_conv (normalize_group info), 98 | group_mult_monomial info] wft 99 | else 100 | WfTerm.all_conv wft 101 | else 102 | WfTerm.all_conv wft 103 | end 104 | 105 | fun group_alg_data group_th = 106 | let 107 | val _ = assert (is_Trueprop (Thm.prop_of group_th) andalso 108 | Term.head_of (prop_of' group_th) aconv @{term is_group}) 109 | "group_alg_data" 110 | val G = dest_arg (prop_of' group_th) 111 | val fheads = [times_t $ G, inv_t $ G] 112 | fun rewr th = WfTerm.rewr_obj_eq fheads th 113 | val monoid_th = group_th RS @{thm is_groupD(1)} 114 | val times_assoc_th = monoid_th RS @{thm is_monoidD(2)} 115 | val times_unit_th = monoid_th RS @{thm is_monoidD(1)} 116 | in 117 | {G = G, 118 | assoc_l = rewr (times_assoc_th RS @{thm times_assoc_left}), 119 | assoc_r = rewr (times_assoc_th RS @{thm times_assoc_right}), 120 | unit_l = rewr (times_unit_th RS @{thm is_mult_id_left}), 121 | unit_r = rewr (times_unit_th RS @{thm is_mult_id_right}), 122 | inv_unit = rewr (monoid_th RS @{thm invD(1)}), 123 | inv_l = rewr (monoid_th RS @{thm invD(2)}), 124 | inv_r = rewr (monoid_th RS @{thm invD(3)}), 125 | inv_inv = rewr (monoid_th RS @{thm unit_inv_inv}), 126 | inv_distrib = rewr (group_th RS @{thm inv_distrib_group})} 127 | end 128 | 129 | (* For simplification on terms, we represent a product of terms as a list. *) 130 | 131 | (* Reduce a list of terms *) 132 | fun reduce_atom_list G l = 133 | if null l then [] 134 | else let 135 | val (head, rest) = (hd l, reduce_atom_list G (tl l)) 136 | in 137 | if null rest then [head] 138 | else if is_inv_pair_l G (head, hd rest) orelse 139 | is_inv_pair_r G (head, hd rest) then tl rest 140 | else head :: rest 141 | end 142 | 143 | fun mult_atom_list G (l1, l2) = 144 | (l1 @ l2) |> reduce_atom_list G 145 | 146 | (* Compute the inverse of a list *) 147 | fun inv_atom_list G l = 148 | let 149 | fun inv_atom atom = 150 | if is_inv G atom then dest_arg atom else inv_t $ G $ atom 151 | in 152 | rev (map inv_atom l) 153 | end 154 | 155 | (* Normalization of a term as a product of terms. *) 156 | fun norm_atom_list G t = 157 | if is_times G t then 158 | mult_atom_list G (norm_atom_list G (dest_arg1 t), 159 | norm_atom_list G (dest_arg t)) 160 | else if is_inv G t then 161 | inv_atom_list G (norm_atom_list G (dest_arg t)) 162 | else if is_one G t then [] 163 | else [t] 164 | 165 | fun norm_term G t = 166 | list_times G (norm_atom_list G t) 167 | 168 | val group_norm_info = { 169 | op_heads = [times_t, inv_t], pred_t = @{term is_group}, norm_t = norm_term, 170 | excl_norm_t = [AlgMonoid.norm_term], 171 | norm_wfcv = normalize_group o group_alg_data} 172 | 173 | val add_group_proofsteps = 174 | fold add_prfstep [ 175 | FOLAlgUtil.alg_norm1_prfstep group_norm_info, 176 | FOLAlgUtil.alg_norm2_prfstep group_norm_info 177 | ] 178 | 179 | end (* structure AlgGroup *) 180 | 181 | val _ = Theory.setup (AlgGroup.add_group_proofsteps) 182 | -------------------------------------------------------------------------------- /FOL/alg_monoid.ML: -------------------------------------------------------------------------------- 1 | (* 2 | File: alg_monoid.ML 3 | Author: Bohua Zhan 4 | 5 | Normalization for monoids. 6 | *) 7 | 8 | val one_t = @{term one} 9 | val times_t = @{term times} 10 | val times_ct = @{cterm times} 11 | 12 | fun is_one G t = t aconv (one_t $ G) 13 | fun is_times G t = Util.is_head (times_t $ G) t 14 | 15 | fun list_times G ts = 16 | let 17 | fun list_rev ts = 18 | case ts of 19 | [] => one_t $ G 20 | | [t] => t 21 | | t :: ts' => times_t $ G $ list_rev ts' $ t 22 | in 23 | list_rev (rev ts) 24 | end 25 | 26 | signature ALG_MONOID = 27 | sig 28 | type monoid_info 29 | val monoid_mult_atom: monoid_info -> wfconv 30 | val monoid_mult_monomial: monoid_info -> wfconv 31 | val normalize_monoid: monoid_info -> wfconv 32 | val monoid_alg_data: thm -> monoid_info 33 | 34 | val norm_atom_list: term -> term -> term list 35 | val norm_term: term -> term -> term 36 | val add_monoid_proofsteps: theory -> theory 37 | end; 38 | 39 | structure AlgMonoid : ALG_MONOID = 40 | struct 41 | 42 | type monoid_info = {G: term, assoc_l: wfconv, unit_l: wfconv, unit_r: wfconv} 43 | 44 | fun monoid_mult_atom info wft = 45 | let 46 | val {G, unit_l, unit_r, ...} = info 47 | val (arg1, arg2) = Util.dest_binop_args (WfTerm.term_of wft) 48 | in 49 | if is_one G arg1 then unit_l wft 50 | else if is_one G arg2 then unit_r wft 51 | else WfTerm.all_conv wft 52 | end 53 | 54 | fun monoid_mult_monomial info wft = 55 | let 56 | val {G, assoc_l, ...} = info 57 | val (_, arg2) = Util.dest_binop_args (WfTerm.term_of wft) 58 | in 59 | if is_times G arg2 then 60 | WfTerm.every_conv [ 61 | assoc_l, 62 | WfTerm.arg1_conv (monoid_mult_monomial info), 63 | monoid_mult_atom info] wft 64 | else 65 | monoid_mult_atom info wft 66 | end 67 | 68 | fun normalize_monoid info wft = 69 | let 70 | val {G, ...} = info 71 | val t = WfTerm.term_of wft 72 | in 73 | if is_times G t then 74 | WfTerm.every_conv [ 75 | WfTerm.binop_conv (normalize_monoid info), 76 | monoid_mult_monomial info] wft 77 | else 78 | WfTerm.all_conv wft 79 | end 80 | 81 | fun monoid_alg_data th = 82 | let 83 | val _ = assert (is_Trueprop (Thm.prop_of th) andalso 84 | Term.head_of (prop_of' th) aconv @{term is_monoid}) 85 | "monoid_alg_data" 86 | val G = dest_arg (prop_of' th) 87 | val fheads = [times_t $ G] 88 | val assoc_l_th = th RS @{thm is_monoidD(2)} RS @{thm times_assoc_left} 89 | val unit_l_th = th RS @{thm is_monoidD(1)} RS @{thm is_mult_id_left} 90 | val unit_r_th = th RS @{thm is_monoidD(1)} RS @{thm is_mult_id_right} 91 | val rewr = WfTerm.rewr_obj_eq fheads 92 | in 93 | {G = G, assoc_l = rewr assoc_l_th, 94 | unit_l = rewr unit_l_th, unit_r = rewr unit_r_th} 95 | end 96 | 97 | (* For simplification on terms, we represent a product of terms as a list. *) 98 | 99 | fun norm_atom_list G t = 100 | if is_times G t then 101 | norm_atom_list G (dest_arg1 t) @ norm_atom_list G (dest_arg t) 102 | else if is_one G t then [] 103 | else [t] 104 | 105 | fun norm_term G t = 106 | list_times G (norm_atom_list G t) 107 | 108 | val monoid_norm_info = { 109 | op_heads = [times_t], pred_t = @{term is_monoid}, norm_t = norm_term, 110 | excl_norm_t = [], norm_wfcv = normalize_monoid o monoid_alg_data} 111 | 112 | val add_monoid_proofsteps = 113 | fold add_prfstep [ 114 | FOLAlgUtil.alg_norm1_prfstep monoid_norm_info, 115 | FOLAlgUtil.alg_norm2_prfstep monoid_norm_info 116 | ] 117 | 118 | end (* structure AlgMonoid. *) 119 | 120 | val _ = Theory.setup (AlgMonoid.add_monoid_proofsteps) 121 | -------------------------------------------------------------------------------- /FOL/alg_ring_test.ML: -------------------------------------------------------------------------------- 1 | (* 2 | File: alg_ring_test.ML 3 | Author: Bohua Zhan 4 | 5 | Unit test for alg_ring.ML. 6 | *) 7 | 8 | local 9 | 10 | val ctxt = @{context} 11 | val G = @{term "G::i"} 12 | val ring_th = Thm.assume @{cprop "is_comm_ring(G)"} 13 | val rat_info = comm_ring_rat_info ring_th 14 | val info = AlgCommRing.comm_ring_alg_data ring_th 15 | val test_wfconv = WfTerm.test_wfconv ctxt (rat_fheads G) 16 | 17 | in 18 | 19 | val test_rat_add = 20 | let 21 | val wfcv = rat_add rat_info 22 | val test_data = [ 23 | ("plus(G,of_nat(G,1),of_nat(G,1))", "of_nat(G,2)"), 24 | ("plus(G,of_nat(G,1),neg(G,of_nat(G,1)))", "of_nat(G,0)") 25 | ] 26 | in 27 | map (test_wfconv wfcv "test_rat_add") test_data 28 | end 29 | 30 | val test_rat_inv = 31 | let 32 | val wfcv = rat_inv rat_info 33 | val test_data = [ 34 | ("inv(G,of_nat(G,1))", "of_nat(G,1)") 35 | ] 36 | in 37 | map (test_wfconv wfcv "test_rat_inv") test_data 38 | end 39 | 40 | val test_rat_uminus = 41 | let 42 | val wfcv = rat_uminus rat_info 43 | val test_data = [ 44 | ("neg(G,of_nat(G,1))", "neg(G,of_nat(G,1))"), 45 | ("neg(G,neg(G,of_nat(G,1)))", "of_nat(G,1)"), 46 | ("neg(G,divide(G,of_nat(G,1),of_nat(G,2)))", 47 | "divide(G,neg(G,of_nat(G,1)),of_nat(G,2))"), 48 | ("neg(G,divide(G,neg(G,of_nat(G,1)),of_nat(G,2)))", 49 | "divide(G,of_nat(G,1),of_nat(G,2))"), 50 | ("neg(G,of_nat(G,0))", "of_nat(G,0)") 51 | ] 52 | in 53 | map (test_wfconv wfcv "test_rat_uminus") test_data 54 | end 55 | 56 | val test_rat_minus = 57 | let 58 | val wfcv = rat_minus rat_info 59 | val test_data = [ 60 | ("minus(G,of_nat(G,2),of_nat(G,1))", "of_nat(G,1)"), 61 | ("minus(G,of_nat(G,1),of_nat(G,2))", "neg(G,of_nat(G,1))") 62 | ] 63 | in 64 | map (test_wfconv wfcv "test_rat_minus") test_data 65 | end 66 | 67 | val test_rat_divide = 68 | let 69 | val wfcv = rat_divide rat_info 70 | val test_data = [ 71 | ("divide(G,of_nat(G,4),of_nat(G,2))", "of_nat(G,2)"), 72 | ("divide(G,of_nat(G,1),neg(G,of_nat(G,2)))", 73 | "divide(G,neg(G,of_nat(G,1)),of_nat(G,2))") 74 | ] 75 | in 76 | map (test_wfconv wfcv "test_rat_divide") test_data 77 | end 78 | 79 | fun test_norm_term G (str1, str2) = 80 | let 81 | val (t1, t2) = (Syntax.read_term ctxt str1, Syntax.read_term ctxt str2) 82 | val t2' = AlgCommRing.norm_term G t1 83 | in 84 | if t2' aconv t2 then () 85 | else let 86 | val _ = trace_t ctxt "Input" t1 87 | val _ = trace_t ctxt "Expected" t2 88 | val _ = trace_t ctxt "Actual" t2' 89 | in 90 | raise Fail "test_norm_term" 91 | end 92 | end 93 | 94 | val test_norm = 95 | let 96 | val wfcv = AlgCommRing.norm_full info 97 | val test_data = [ 98 | ("neg(G,a)", "times(G,a,neg(G,of_nat(G,1)))"), 99 | ("times(G,neg(G,a),neg(G,a))", "times(G,a,a)"), 100 | ("divide(G,a,of_nat(G,2))", 101 | "times(G,a,divide(G,of_nat(G,1),of_nat(G,2)))"), 102 | ("plus(G,divide(G,a,of_nat(G,2)),divide(G,a,of_nat(G,2)))", "a::i"), 103 | ("inv(G,neg(G,a))", "times(G,inv(G,a),neg(G,of_nat(G,1)))"), 104 | ("minus(G,plus(G,a,b),a)", "b::i"), 105 | ("plus(G,of_nat(G,0),a)", "a::i"), 106 | ("plus(G,a,of_nat(G,0))", "a::i"), 107 | ("minus(G,of_nat(G,0),of_nat(G,0))", "of_nat(G,0)"), 108 | ("inv(G,of_nat(G,1))", "of_nat(G,1)"), 109 | ("times(G,a,inv(G,a))", "of_nat(G,1)"), 110 | ("times(G,times(G,a,b),inv(G,a))", "b::i"), 111 | ("inv(G,inv(G,a))", "a::i"), 112 | ("inv(G,times(G,a,inv(G,a)))", "of_nat(G,1)"), 113 | ("plus(G,inv(G,a),inv(G,neg(G,a)))", "of_nat(G,0)"), 114 | ("zero(G)", "of_nat(G,0)"), 115 | ("plus(G,a,zero(G))", "a::i"), 116 | ("plus(G,zero(G),a)", "a::i"), 117 | ("one(G)", "of_nat(G,1)"), 118 | ("times(G,a,one(G))", "a::i"), 119 | ("times(G,one(G),a)", "a::i") 120 | ] 121 | 122 | val _ = map (test_wfconv wfcv "test_norm") test_data 123 | val _ = map (test_norm_term @{term "G::i"}) test_data 124 | in 125 | () 126 | end 127 | 128 | end (* local *) 129 | -------------------------------------------------------------------------------- /FOL/auto2_fol.ML: -------------------------------------------------------------------------------- 1 | (* 2 | File: auto2_fol.ML 3 | Author: Bohua Zhan 4 | 5 | Setup of auto2 for FOL. 6 | *) 7 | 8 | structure UtilBase : UTIL_BASE = 9 | struct 10 | 11 | (* Types *) 12 | 13 | val boolT = @{typ "o"} 14 | val setT = @{typ "i"} 15 | val mk_setT = K setT 16 | 17 | (* Equality *) 18 | 19 | fun dest_eq t = 20 | case t of 21 | Const (@{const_name IFOL.eq}, _) $ lhs $ rhs => (lhs, rhs) 22 | | Const (@{const_name IFOL.iff}, _) $ lhs $ rhs => (lhs, rhs) 23 | | _ => raise Fail "dest_eq" 24 | 25 | fun cdest_eq ct = 26 | case Thm.term_of ct of 27 | Const (@{const_name IFOL.eq}, _) $ _ $ _ => (Thm.dest_arg1 ct, Thm.dest_arg ct) 28 | | Const (@{const_name IFOL.iff}, _) $ _ $ _ => (Thm.dest_arg1 ct, Thm.dest_arg ct) 29 | | _ => raise Fail "dest_eq" 30 | 31 | fun mk_eq (t, u) = 32 | let 33 | val T = fastype_of t 34 | in 35 | Const (@{const_name IFOL.eq}, T --> T --> boolT) $ t $ u 36 | end 37 | 38 | fun is_eq_term t = 39 | let 40 | val _ = assert (fastype_of t = boolT) "is_eq_term: wrong type" 41 | in 42 | case t of Const (@{const_name IFOL.eq}, _) $ _ $ _ => true 43 | | Const (@{const_name IFOL.iff}, _) $ _ $ _ => true 44 | | _ => false 45 | end 46 | 47 | val bTrue = @{term True} 48 | val bFalse = @{term False} 49 | val Trueprop_name = @{const_name IFOL.Trueprop} 50 | val Not_name = @{const_name IFOL.Not} 51 | val Conj_name = @{const_name IFOL.conj} 52 | val Disj_name = @{const_name IFOL.disj} 53 | val Imp_name = @{const_name IFOL.imp} 54 | val All_name = @{const_name IFOL.All} 55 | val Ex_name = @{const_name IFOL.Ex} 56 | 57 | (* If expressions are treated differently. In a term "if a then b else 58 | c", only terms in "a" are considered in the proof state. 59 | *) 60 | fun is_if t = 61 | case t of 62 | Const ("Set.If", _) $ _ $ _ $ _ => true 63 | | Const ("Set.Ifb", _) $ _ $ _ $ _ => true 64 | | _ => false 65 | 66 | val cTrueprop = @{cterm Trueprop} 67 | val cNot = @{cterm Not} 68 | val cConj = @{cterm conj} 69 | val cDisj = @{cterm disj} 70 | 71 | (* Theorems for equality *) 72 | val to_meta_eq_cv = 73 | (Conv.rewr_conv @{thm to_meta_eq}) 74 | else_conv (Conv.rewr_conv @{thm to_meta_eq_iff}) 75 | 76 | val to_obj_eq_cv = 77 | (Conv.rewr_conv @{thm atomize_eq}) 78 | else_conv (Conv.rewr_conv @{thm atomize_iff}) 79 | 80 | val to_obj_eq_iff = 81 | apply_to_thm (Util.concl_conv (Conv.rewr_conv @{thm atomize_iff})) 82 | 83 | val obj_sym_cv = 84 | (Conv.rewr_conv @{thm obj_sym}) 85 | else_conv (Conv.rewr_conv @{thm obj_sym_iff}) 86 | 87 | (* Theorems *) 88 | val true_th = @{thm TrueI} 89 | val iffD_th = @{thm iffD} 90 | val nn_create_th = @{thm nn_create} 91 | val nn_cancel_th = @{thm FOL.cla_simps(12)} 92 | val to_contra_form_th = @{thm to_contra_form} 93 | val to_contra_form_th' = @{thm to_contra_form'} 94 | val atomize_imp_th = @{thm atomize_imp} 95 | val atomize_all_th = @{thm atomize_all} 96 | val conjunct1_th = @{thm conjunct1} 97 | val conjunct2_th = @{thm conjunct2} 98 | val conjI_th = @{thm conjI} 99 | val or_intro1_th = @{thm or_intro1} 100 | val or_intro2_th = @{thm or_intro2} 101 | val iffD1_th = @{thm iffD1} 102 | val iffD2_th = @{thm iffD2} 103 | val inv_back_th = @{thm inv_backward} 104 | val sym_th = @{thm sym} 105 | val exE_th' = @{thm exE'} 106 | val eq_True_th = @{thm eq_True} 107 | val eq_True_inv_th = @{thm eq_True_inv} 108 | val disj_True1_th = @{thm disj_True1} 109 | val disj_True2_th = @{thm disj_True2} 110 | val ex_vardef_th = @{thm ex_vardef} 111 | val imp_conv_disj_th = @{thm imp_conv_disj} 112 | val de_Morgan_conj_th = @{thm de_Morgan_conj} 113 | val de_Morgan_disj_th = @{thm de_Morgan_disj} 114 | val not_ex_th = @{thm not_ex} 115 | val not_all_th = @{thm not_all} 116 | val not_imp_th = @{thm not_imp} 117 | val or_cancel1_th = @{thm or_cancel1} 118 | val or_cancel2_th = @{thm or_cancel2} 119 | val swap_all_disj_th = @{thm swap_all_disj} 120 | val swap_ex_conj_th = @{thm swap_ex_conj} 121 | val all_trivial_th = @{thm all_trivial} 122 | val case_split_th = @{thm case_split} 123 | 124 | val atomize_conjL_th = @{thm FOL_Base.atomize_conjL} 125 | val backward_conv_th = @{thm backward_conv} 126 | val backward1_conv_th = @{thm backward1_conv} 127 | val backward2_conv_th = @{thm backward2_conv} 128 | val resolve_conv_th = @{thm resolve_conv} 129 | val contra_triv_th = @{thm contra_triv} 130 | 131 | val conj_assoc_th = @{thm conj_assoc} 132 | val conj_commute_th = @{thm conj_commute} 133 | val disj_assoc_th = @{thm disj_assoc} 134 | val disj_commute_th = @{thm disj_commute} 135 | 136 | val Mem_name = "FOL_Base.mem" 137 | val Ball_name = "FOL_Base.Ball" 138 | val Bex_name = "FOL_Base.Bex" 139 | val Bex_def_th = @{thm Bex_def'} 140 | val Ball_def_th = @{thm Ball_def'} 141 | 142 | end (* structure UtilBase *) 143 | 144 | structure Basic_UtilBase: BASIC_UTIL_BASE = UtilBase 145 | open Basic_UtilBase 146 | -------------------------------------------------------------------------------- /FOL/extra_fol.ML: -------------------------------------------------------------------------------- 1 | (* 2 | File: extra_fol.ML 3 | Author: Bohua Zhan 4 | 5 | Extra setup for FOL. 6 | *) 7 | 8 | signature EXTRA_FOL = 9 | sig 10 | val add_typing_rule_cond: 11 | thm -> pre_prfstep_descriptor list -> theory -> theory 12 | val add_typing_rule: thm -> theory -> theory 13 | val add_typing2_rule_cond: 14 | thm -> pre_prfstep_descriptor list -> theory -> theory 15 | val add_typing2_rule: thm -> theory -> theory 16 | end; 17 | 18 | structure Extra_FOL : EXTRA_FOL = 19 | struct 20 | 21 | fun add_typing_rule_cond th conds thy = 22 | let 23 | val concl = th |> concl_of' |> strip_conj |> hd 24 | val conds = [with_score 1, K (WithTerm (dest_arg1 concl))] @ conds 25 | in 26 | if is_mem concl then 27 | thy |> add_forward_prfstep_cond th conds 28 | else 29 | error "Add typing rule: concl is not a membership." 30 | end 31 | 32 | fun add_typing_rule th = add_typing_rule_cond th [] 33 | 34 | fun add_typing2_rule_cond th conds thy = 35 | let 36 | val concl = th |> concl_of' |> strip_conj |> hd 37 | in 38 | if is_mem concl then 39 | thy |> add_forward_prfstep_cond th ([K (WithTerm (dest_arg concl))] @ conds) 40 | else 41 | error "Add typing rule: concl is not a membership." 42 | end 43 | 44 | fun add_typing2_rule th = add_typing2_rule_cond th [] 45 | 46 | end (* structure Extra_FOL *) 47 | 48 | open Extra_FOL 49 | -------------------------------------------------------------------------------- /FOL/fol_var_induct.ML: -------------------------------------------------------------------------------- 1 | (* 2 | File: fol_var_induct.ML 3 | Author: Bohua Zhan 4 | 5 | Proof language for induction on variables. 6 | *) 7 | 8 | (* Syntax after @var_induct: either "P(n)" or "n in P(n, ...)". In the 9 | first case, n is the unique free variable in P(n), and is taken to 10 | be the induction variable. In the second case, there are more than 11 | one free variables in P(n, ...), so the induction variable need to 12 | be explicitly stated. 13 | *) 14 | fun read_var_spec ctxt (n, s) = 15 | let 16 | val prem = Syntax.read_term ctxt s 17 | val var = if is_none n then 18 | (Term.add_frees prem []) |> the_single |> Free 19 | handle List.Empty => raise Fail "read_var_spec" 20 | else Syntax.read_term ctxt (the n) 21 | in 22 | (var, prem) 23 | end 24 | 25 | (* Obtain the induction statement. *) 26 | fun get_induct_stmt ctxt (var, prem, stmt, arbitrary) = 27 | case stmt of 28 | NONE => 29 | let 30 | val (_, (As, C)) = ctxt |> Auto2_State.get_subgoal 31 | |> Util.strip_meta_horn 32 | val all_vars = var :: arbitrary 33 | val obj_As = As |> filter (Util.occurs_frees all_vars) 34 | |> map dest_Trueprop 35 | |> remove (op aconv) prem 36 | val obj_C = dest_Trueprop C 37 | in 38 | UtilLogic.list_obj_horn (arbitrary, (obj_As, obj_C)) 39 | end 40 | | SOME s => 41 | UtilLogic.list_obj_horn (arbitrary, ([], Syntax.read_term ctxt s)) 42 | 43 | fun var_induct_cmd ((n, s), t, u, v) state = 44 | let 45 | val {context = ctxt, ...} = Proof.goal state 46 | val thy = Proof_Context.theory_of ctxt 47 | val (var, prem) = read_var_spec ctxt (n, s) 48 | val arbitraries = map (Syntax.read_term ctxt) u 49 | val stmt = get_induct_stmt ctxt (var, prem, t, arbitraries) 50 | val _ = trace_t ctxt "Induct statement" stmt 51 | 52 | val (arbitraries, _) = UtilLogic.strip_obj_horn stmt 53 | 54 | (* Obtain the induction theorem *) 55 | val ind_th = the (ScriptInduct_Data.lookup_induct_data "var_induct" thy prem) 56 | handle Option.Option => error "var induct: cannot find theorem." 57 | 58 | val concl = concl_of' ind_th 59 | val (P, vars) = Term.strip_comb concl 60 | val _ = assert (Term.is_Var P) "var induct: P is not schematic variable." 61 | val P_inst = fold Term.lambda (rev vars) stmt 62 | val inst = Util.update_env (("P", 0), P_inst) fo_init 63 | val ind_th' = Util.subst_thm_thy thy inst ind_th 64 | 65 | (* Obtain list of assumptions *) 66 | val (_, (As, _)) = ctxt |> Auto2_State.get_subgoal 67 | |> Util.strip_meta_horn 68 | val cAs = map (Thm.cterm_of ctxt) As 69 | val use_As = As |> filter_out (Util.occurs_frees (var :: arbitraries)) 70 | 71 | fun retrieve_pat t = 72 | let 73 | val t = dest_Trueprop t 74 | val (vars, (_, C)) = UtilLogic.strip_obj_horn t 75 | val pat_vars = map (fn t => let val (x, T) = dest_Free t in 76 | Var ((x,0), T) 77 | end) vars 78 | val arg = C |> dest_arg |> Term.subst_atomic (vars ~~ pat_vars) 79 | in 80 | mk_eq (var, arg) 81 | end 82 | 83 | val prem = hd (Thm.prems_of ind_th) 84 | val ind_prems = tl (Thm.prems_of ind_th) 85 | val pats = prem :: map retrieve_pat ind_prems 86 | 87 | val prem_goal = (Logic.list_implies (As, prem)) 88 | |> Thm.cterm_of ctxt |> Thm.reflexive 89 | 90 | val ind_goals = 91 | ind_th' |> Thm.prems_of |> tl 92 | |> map (fn t => Logic.list_implies (use_As, t)) 93 | |> map (Thm.cterm_of ctxt) 94 | |> map (UtilLogic.to_meta_conv ctxt) 95 | 96 | val all_goals = prem_goal :: ind_goals 97 | 98 | fun solve_eq eq = 99 | let 100 | val th = Auto2_Outer.auto2_solve ctxt (Thm.rhs_of eq) 101 | in 102 | Thm.equal_elim (meta_sym eq) th 103 | end 104 | 105 | val _ = assert (length pats = length all_goals) 106 | "var_induct: unexpected number of patterns" 107 | in 108 | if is_none v then 109 | let 110 | val ths = (map solve_eq all_goals) |> map Util.send_all_to_hyps 111 | val ind_concl = ind_th' |> fold Thm.elim_implies ths 112 | |> fold Thm.implies_intr (rev cAs) 113 | val after_qed = Auto2_Outer.have_after_qed ctxt ind_concl 114 | in 115 | state |> Proof.map_contexts (Auto2_State.map_head_th after_qed) 116 | end 117 | else 118 | let 119 | (* Create new block with the subgoals *) 120 | fun after_qed ths prop = 121 | let 122 | val ths' = (all_goals ~~ ths) 123 | |> map (fn (eq, th) => Thm.equal_elim (meta_sym eq) th) 124 | |> map Util.send_all_to_hyps 125 | val ind_concl = ind_th' |> fold Thm.elim_implies ths' 126 | |> fold Thm.implies_intr (rev cAs) 127 | in 128 | Auto2_Outer.have_after_qed ctxt ind_concl prop 129 | end 130 | 131 | val new_frame = 132 | Auto2_State.multiple_frame (pats ~~ map Thm.rhs_of all_goals, SOME ([], after_qed)) 133 | in 134 | state |> Proof.map_contexts (Auto2_State.push_head new_frame) 135 | end 136 | end 137 | 138 | val var_spec = 139 | Scan.option (Parse.term --| @{keyword "in"}) -- Parse.term 140 | 141 | val for_stmt = 142 | Scan.option (@{keyword "for"} |-- Parse.term) 143 | 144 | val arbitrary = 145 | Scan.option (@{keyword "arbitrary"} |-- Scan.repeat Parse.term) 146 | 147 | val _ = 148 | Outer_Syntax.command @{command_keyword "@var_induct"} "apply induction" 149 | (var_spec -- for_stmt -- arbitrary -- Scan.option @{keyword "@with"} >> 150 | (fn ((((n, s), t), u), v) => 151 | Toplevel.proof (fn state => var_induct_cmd ((n, s), t, these u, v) state))) 152 | 153 | val add_var_induct_data = ScriptInduct_Data.add_induct_data "var_induct" 154 | val add_var_induct_data_with_prem = 155 | ScriptInduct_Data.add_induct_data_with_prem "var_induct" 156 | -------------------------------------------------------------------------------- /FOL/ord_ring_steps.ML: -------------------------------------------------------------------------------- 1 | (* 2 | File: ord_ring_steps.ML 3 | Author: Bohua Zhan 4 | 5 | Normalization for inequalities on ordered rings. 6 | *) 7 | 8 | val le_t = @{term le} 9 | val less_t = @{term less} 10 | fun ord_heads G = rat_fheads G @ [le_t $ G, less_t $ G] 11 | 12 | fun is_le G t = Util.is_head (le_t $ G) t 13 | fun is_less G t = Util.is_head (less_t $ G) t 14 | fun is_ineq G t = is_le G t orelse is_less G t 15 | fun is_neg_le G t = is_neg t andalso is_le G (dest_not t) 16 | fun is_neg_less G t = is_neg t andalso is_less G (dest_not t) 17 | fun is_neg_ineq G t = is_neg t andalso is_ineq G (dest_not t) 18 | 19 | signature ORD_RING_STEPS = 20 | sig 21 | type ord_ring_info 22 | val normalize_ineq: ord_ring_info -> wfconv 23 | val ord_ring_alg_data: thm -> ord_ring_info 24 | val ord_normalize_le: proofstep 25 | val ord_normalize_less: proofstep 26 | val add_ord_ring_proofsteps: theory -> theory 27 | end; 28 | 29 | 30 | structure OrdRingSteps : ORD_RING_STEPS = 31 | struct 32 | 33 | type ord_ring_info = { 34 | G: term, 35 | ring_info: AlgCommRing.comm_ring_info, 36 | switch_le: wfconv, (* x <= y <--> 0 <= y - x *) 37 | switch_less: wfconv (* x < y <--> 0 < y - x *) 38 | } 39 | 40 | fun normalize_ineq info wft = 41 | let 42 | val {G, ring_info, switch_le, switch_less, ...} = info 43 | val t = WfTerm.term_of wft 44 | in 45 | if is_le G t then 46 | WfTerm.every_conv 47 | [switch_le, WfTerm.arg_conv (AlgCommRing.norm_full ring_info)] wft 48 | else if is_less G t then 49 | WfTerm.every_conv 50 | [switch_less, WfTerm.arg_conv (AlgCommRing.norm_full ring_info)] wft 51 | else 52 | WfTerm.all_conv wft 53 | end 54 | 55 | fun ord_ring_alg_data ord_ring_th = 56 | let 57 | val G = dest_arg (prop_of' ord_ring_th) 58 | val fheads = ord_heads G 59 | fun rewr th = WfTerm.rewr_obj_eq fheads th 60 | val c_ring_th = ord_ring_th RS @{thm is_ord_ringD(2)} 61 | in 62 | {G = G, 63 | ring_info = AlgCommRing.comm_ring_alg_data c_ring_th, 64 | switch_le = rewr (ord_ring_th RS @{thm ord_ring_le_switch_left}), 65 | switch_less = rewr (ord_ring_th RS @{thm ord_ring_less_switch_left}) 66 | } 67 | end 68 | 69 | fun ord_normalize_fn ctxt item1 item2 = 70 | let 71 | val {id = id1, prop = prop1, ...} = item1 72 | val {id = id2, prop = prop2, ...} = item2 73 | val id = BoxID.merge_boxes ctxt (id1, id2) 74 | 75 | (* t1 is the statement of prop1, t2 is statement of prop2 with 76 | negation removed. 77 | *) 78 | val (ct1, ct2) = (cprop_of' prop1, Thm.dest_arg (cprop_of' prop2)) 79 | val (t1, t2) = (Thm.term_of ct1, Thm.term_of ct2) 80 | val (x1, y1) = Util.dest_binop_args t1 81 | val (x2, y2) = Util.dest_binop_args t2 82 | val G = hd (Util.dest_args (Thm.term_of ct1)) 83 | val diff1 = AlgCommRing.norm_term G (minus_t $ G $ y1 $ x1) 84 | val diff2 = AlgCommRing.norm_term G (minus_t $ G $ y2 $ x2) 85 | in 86 | if not (diff1 aconv diff2) then [] 87 | else let 88 | val pred_t = @{term is_ord_ring} 89 | val fheads = ord_heads G 90 | val property_infos = PropertyData.get_property_t ctxt (id, pred_t $ G) 91 | 92 | fun process_wft property_th (id', (wft1, wft2)) = 93 | let 94 | val wfcv = normalize_ineq (ord_ring_alg_data property_th) 95 | val (_, eq1) = wfcv wft1 96 | val (_, eq2) = wfcv wft2 97 | in 98 | if not (Util.rhs_of eq1 aconv Util.rhs_of eq2) then [] 99 | else let 100 | val prop1' = 101 | apply_to_thm' (Conv.rewr_conv eq1) prop1 102 | val prop2' = 103 | apply_to_thm' (Conv.arg_conv (Conv.rewr_conv eq2)) prop2 104 | val contra_th = [prop2', prop1'] MRS @{thm contra_triv} 105 | in 106 | [Update.thm_update (id', contra_th)] 107 | end 108 | end 109 | 110 | fun process_property_info (id', property_th) = 111 | let 112 | val wfts1 = WellformData.cterm_to_wfterm ctxt fheads (id', ct1) 113 | val wfts2 = WellformData.cterm_to_wfterm ctxt fheads (id', ct2) 114 | in 115 | (Util.all_pairs (wfts1, wfts2)) 116 | |> map (fn ((id1, wft1), (id2, wft2)) => 117 | (BoxID.merge_boxes ctxt (id1, id2), (wft1, wft2))) 118 | |> filter (BoxID.has_incr_id o fst) 119 | |> maps (process_wft property_th) 120 | end 121 | in 122 | maps process_property_info property_infos 123 | end 124 | end 125 | 126 | val ord_normalize_le = 127 | {name = "ord_normalize_le", 128 | args = [TypedMatch (TY_PROP, @{term_pat "le(?G,?A,?B)"}), 129 | TypedMatch (TY_PROP, @{term_pat "~le(?G,?C,?D)"})], 130 | func = TwoStep ord_normalize_fn} 131 | 132 | val ord_normalize_less = 133 | {name = "ord_normalize_less", 134 | args = [TypedMatch (TY_PROP, @{term_pat "less(?G,?A,?B)"}), 135 | TypedMatch (TY_PROP, @{term_pat "~less(?G,?C,?D)"})], 136 | func = TwoStep ord_normalize_fn} 137 | 138 | val add_ord_ring_proofsteps = 139 | fold add_prfstep [ 140 | ord_normalize_le, ord_normalize_less 141 | ] 142 | 143 | end (* OrdRingSteps *) 144 | 145 | val _ = Theory.setup OrdRingSteps.add_ord_ring_proofsteps 146 | -------------------------------------------------------------------------------- /HOL/Auto2_HOL.thy: -------------------------------------------------------------------------------- 1 | (* 2 | File: Auto2_HOL.thy 3 | Author: Bohua Zhan 4 | 5 | Main file for auto2 setup in HOL. 6 | *) 7 | 8 | theory Auto2_HOL 9 | imports HOL_Base 10 | keywords "@proof" :: prf_block % "proof" 11 | and "@have" "@case" "@obtain" "@let" "@contradiction" "@strong_induct" :: prf_decl % "proof" 12 | and "@unfold" :: prf_decl % "proof" 13 | and "@induct" "@fun_induct" "@case_induct" "@prop_induct" "@cases" :: prf_decl % "proof" 14 | and "@apply_induct_hyp" :: prf_decl % "proof" 15 | and "@subgoal" "@endgoal" "@end" :: prf_decl % "proof" 16 | and "@qed" :: qed_block % "proof" 17 | and "@with" "where" "arbitrary" "@rule" :: quasi_command 18 | begin 19 | 20 | ML_file \../util.ML\ 21 | ML_file \../util_base.ML\ 22 | ML_file \auto2_hol.ML\ 23 | ML_file \../util_logic.ML\ 24 | ML_file \../box_id.ML\ 25 | ML_file \../consts.ML\ 26 | ML_file \../property.ML\ 27 | ML_file \../wellform.ML\ 28 | ML_file \../wfterm.ML\ 29 | ML_file \../rewrite.ML\ 30 | ML_file \../propertydata.ML\ 31 | ML_file \../matcher.ML\ 32 | ML_file \../items.ML\ 33 | ML_file \../wfdata.ML\ 34 | ML_file \../auto2_data.ML\ 35 | ML_file \../status.ML\ 36 | ML_file \../normalize.ML\ 37 | ML_file \../proofsteps.ML\ 38 | ML_file \../auto2_state.ML\ 39 | ML_file \../logic_steps.ML\ 40 | ML_file \../auto2.ML\ 41 | ML_file \../auto2_outer.ML\ 42 | 43 | ML_file \acdata.ML\ 44 | ML_file \ac_steps.ML\ 45 | ML_file \unfolding.ML\ 46 | ML_file \induct_outer.ML\ 47 | ML_file \extra_hol.ML\ 48 | 49 | method_setup auto2 = \Scan.succeed (SIMPLE_METHOD o Auto2.auto2_tac)\ "auto2 prover" 50 | 51 | attribute_setup forward = \setup_attrib add_forward_prfstep\ 52 | attribute_setup backward = \setup_attrib add_backward_prfstep\ 53 | attribute_setup backward1 = \setup_attrib add_backward1_prfstep\ 54 | attribute_setup backward2 = \setup_attrib add_backward2_prfstep\ 55 | attribute_setup resolve = \setup_attrib add_resolve_prfstep\ 56 | attribute_setup rewrite = \setup_attrib add_rewrite_rule\ 57 | attribute_setup rewrite_back = \setup_attrib add_rewrite_rule_back\ 58 | attribute_setup rewrite_bidir = \setup_attrib add_rewrite_rule_bidir\ 59 | attribute_setup forward_arg1 = \setup_attrib add_forward_arg1_prfstep\ 60 | attribute_setup forward_arg = \setup_attrib add_forward_arg_prfstep\ 61 | attribute_setup rewrite_arg = \setup_attrib add_rewrite_arg_rule\ 62 | 63 | end 64 | -------------------------------------------------------------------------------- /HOL/Auto2_Main.thy: -------------------------------------------------------------------------------- 1 | (* 2 | File: Auto2_Main.thy 3 | Author: Bohua Zhan 4 | 5 | Setup of auto2 for basic theorems in Main. 6 | *) 7 | 8 | theory Auto2_Main 9 | imports Arith_Thms Lists_Thms 10 | begin 11 | 12 | end 13 | -------------------------------------------------------------------------------- /HOL/Auto2_Test.thy: -------------------------------------------------------------------------------- 1 | (* 2 | File: Auto2_Test.thy 3 | Author: Bohua Zhan 4 | 5 | Unit tests for auto2. 6 | *) 7 | 8 | theory Auto2_Test 9 | imports Auto2_Main 10 | begin 11 | 12 | ML_file \util_test.ML\ 13 | ML_file \rewrite_test.ML\ 14 | ML_file \matcher_test.ML\ 15 | ML_file \normalize_test.ML\ 16 | ML_file \logic_steps_test.ML\ 17 | 18 | ML_file \acdata_test.ML\ 19 | 20 | end 21 | -------------------------------------------------------------------------------- /HOL/HOL_Base.thy: -------------------------------------------------------------------------------- 1 | (* 2 | File: HOL_Base.thy 3 | Author: Bohua Zhan 4 | 5 | Extra theorems in logic used by auto2. 6 | *) 7 | 8 | theory HOL_Base 9 | imports Main 10 | begin 11 | 12 | theorem to_contra_form: "Trueprop A \ (\A \ False)" by (rule equal_intr_rule) auto 13 | theorem to_contra_form': "Trueprop (\A) \ (A \ False)" by (rule equal_intr_rule) auto 14 | 15 | theorem contra_triv: "\A \ A \ False" by simp 16 | theorem or_intro1: "\ (P \ Q) \ \ P" by simp 17 | theorem or_intro2: "\ (P \ Q) \ \ Q" by simp 18 | theorem or_cancel1: "\Q \ (P \ Q) = P" by auto 19 | theorem or_cancel2: "\P \ (P \ Q) = Q" by auto 20 | theorem exE': "(\x. P x \ Q) \ \x. P x \ Q" by auto 21 | theorem nn_create: "A \ \\A" by auto 22 | theorem iffD: "A \ B \ (A \ B) \ (B \ A)" by auto 23 | 24 | theorem obj_sym: "Trueprop (t = s) \ Trueprop (s = t)" by (rule equal_intr_rule) auto 25 | theorem to_meta_eq: "Trueprop (t = s) \ (t \ s)" by (rule equal_intr_rule) auto 26 | 27 | theorem inv_backward: "A \ B \ \A \ \B" by auto 28 | theorem backward_conv: "(A \ B) \ (\B \ \A)" by (rule equal_intr_rule) auto 29 | theorem backward1_conv: "(A \ B \ C) \ (\C \ B \ \A)" by (rule equal_intr_rule) auto 30 | theorem backward2_conv: "(A \ B \ C) \ (\C \ A \ \B)" by (rule equal_intr_rule) auto 31 | theorem resolve_conv: "(A \ B) \ (\B \ A \ False)" by (rule equal_intr_rule) auto 32 | 33 | (* Quantifiers: swapping out of ALL or EX *) 34 | theorem swap_ex_conj: "(P \ (\x. Q x)) \ (\x. P \ Q x)" by auto 35 | theorem swap_all_disj: "(P \ (\x. Q x)) \ (\x. P \ Q x)" by auto 36 | 37 | (* Use these instead of original versions to keep names in abstractions. *) 38 | theorem Bex_def': "(\x\S. P x) \ (\x. x \ S \ P x)" by auto 39 | theorem Ball_def': "(\x\S. P x) \ (\x. x \ S \ P x)" by auto 40 | 41 | (* Taking conjunction of assumptions *) 42 | lemma atomize_conjL: "(A \ B \ PROP C) \ (A \ B \ PROP C)" by (rule equal_intr_rule) auto 43 | 44 | end 45 | -------------------------------------------------------------------------------- /HOL/Logic_Thms.thy: -------------------------------------------------------------------------------- 1 | (* 2 | File: Logic_Thms.thy 3 | Author: Bohua Zhan 4 | 5 | Setup for proof steps related to logic. 6 | *) 7 | 8 | theory Logic_Thms 9 | imports Auto2_HOL 10 | begin 11 | 12 | (* Trivial contradictions. *) 13 | setup \add_resolve_prfstep @{thm HOL.refl}\ 14 | setup \add_forward_prfstep @{thm contra_triv}\ 15 | setup \add_resolve_prfstep @{thm TrueI}\ 16 | theorem FalseD [resolve]: "\False" by simp 17 | lemma exists_triv_eq [resolve]: "\x. x = x" by auto 18 | 19 | (* Not. *) 20 | setup \add_forward_prfstep_cond @{thm HOL.not_sym} [with_filt (not_type_filter "s" boolT)]\ 21 | 22 | (* Iff. *) 23 | setup \add_gen_prfstep ("iff_intro1", 24 | [WithGoal @{term_pat "(?A::bool) = ?B"}, 25 | CreateCase @{term_pat "?A::bool"}, 26 | WithScore 25])\ 27 | theorem iff_goal: 28 | "A \ B \ A \ \B" "A \ B \ B \ \A" 29 | "A \ B \ \A \ B" "A \ B \ \B \ A" 30 | "(\A) \ B \ A \ B" "A \ (\B) \ B \ A" by auto 31 | setup \fold (fn th => add_forward_prfstep_cond th [with_score 1]) @{thms iff_goal}\ 32 | 33 | (* Quantifiers: normalization *) 34 | theorem exists_split: "(\x y. P x \ Q y) = ((\x. P x) \ (\y. Q y))" by simp 35 | setup \add_backward_prfstep (equiv_backward_th @{thm exists_split})\ 36 | 37 | (* Case analysis. *) 38 | setup \add_gen_prfstep ("case_intro", 39 | [WithTerm @{term_pat "if ?cond then (?yes::?'a) else ?no"}, 40 | CreateCase @{term_pat "?cond::bool"}])\ 41 | setup \add_gen_prfstep ("case_intro_fact", 42 | [WithFact @{term_pat "if ?cond then (?yes::bool) else ?no"}, 43 | CreateCase @{term_pat "?cond::bool"}])\ 44 | setup \add_gen_prfstep ("case_intro_goal", 45 | [WithGoal @{term_pat "if ?cond then (?yes::bool) else ?no"}, 46 | CreateCase @{term_pat "?cond::bool"}])\ 47 | lemma if_eval': 48 | "P \ (if \P then x else y) = y" by auto 49 | lemma ifb_eval: 50 | "P \ (if P then (x::bool) else y) = x" 51 | "\P \ (if P then (x::bool) else y) = y" 52 | "P \ (if \P then (x::bool) else y) = y" by auto 53 | setup \fold (fn th => add_rewrite_rule_cond th [with_score 1]) 54 | ([@{thm HOL.if_P}, @{thm HOL.if_not_P}, @{thm if_eval'}] @ @{thms ifb_eval})\ 55 | 56 | (* THE and \! *) 57 | setup \add_forward_prfstep_cond @{thm theI'} [with_term "THE x. ?P x"]\ 58 | setup \add_gen_prfstep ("ex1_case", 59 | [WithGoal @{term_pat "\!x. ?P x"}, CreateConcl @{term_pat "\x. ?P x"}])\ 60 | theorem ex_ex1I' [backward1]: "\y. P y \ x = y \ P x \ \!x. P x" by auto 61 | theorem the1_equality': "P a \ \!x. P x \ (THE x. P x) = a" by (simp add: the1_equality) 62 | setup \add_forward_prfstep_cond @{thm the1_equality'} [with_term "THE x. ?P x"]\ 63 | 64 | (* Hilbert choice. *) 65 | setup \add_gen_prfstep ("SOME_case_intro", 66 | [WithTerm @{term_pat "SOME k. ?P k"}, CreateConcl @{term_pat "\k. ?P k"}])\ 67 | setup \add_forward_prfstep_cond @{thm someI} [with_term "SOME x. ?P x"]\ 68 | setup \add_forward_prfstep_cond @{thm someI_ex} [with_term "SOME x. ?P x"]\ 69 | 70 | (* Axiom of choice *) 71 | setup \add_prfstep_custom ("ex_choice", 72 | [WithGoal @{term_pat "EX f. !x. ?Q f x"}], 73 | (fn ((id, _), ths) => fn _ => fn _ => 74 | let 75 | val choice = @{thm choice} |> apply_to_thm (Conv.rewr_conv UtilBase.backward_conv_th) 76 | in 77 | [Update.thm_update (id, (ths MRS choice))] 78 | end 79 | handle THM _ => [])) 80 | \ 81 | 82 | (* Least operator. *) 83 | theorem Least_equality' [backward1]: 84 | "P (x::('a::order)) \ \y. P y \ x \ y \ Least P = x" by (simp add: Least_equality) 85 | 86 | (* Pairs. *) 87 | lemma pair_inj: "(a,b) = c \ a = fst c \ b = snd c" by auto 88 | setup \Normalizer.add_inj_struct_data @{thm pair_inj}\ 89 | 90 | setup \add_rewrite_rule @{thm fst_conv}\ 91 | setup \add_rewrite_rule @{thm snd_conv}\ 92 | setup \add_forward_prfstep (equiv_forward_th @{thm prod.simps(1)})\ 93 | setup \add_rewrite_rule_cond @{thm surjective_pairing} [with_cond "?t \ (?a, ?b)"]\ 94 | setup \Normalizer.add_rewr_normalizer ("rewr_case", (to_meta_eq @{thm case_prod_beta'}))\ 95 | 96 | (* Let. *) 97 | setup \Normalizer.add_rewr_normalizer ("rewr_let", @{thm Let_def})\ 98 | 99 | (* Equivalence relations *) 100 | setup \add_forward_prfstep @{thm Relation.symD}\ 101 | setup \add_backward_prfstep @{thm Relation.symI}\ 102 | setup \add_forward_prfstep @{thm Relation.transD}\ 103 | setup \add_backward_prfstep @{thm Relation.transI}\ 104 | 105 | (* Options *) 106 | setup \add_resolve_prfstep @{thm option.distinct(1)}\ 107 | setup \add_rewrite_rule @{thm Option.option.sel}\ 108 | setup \add_forward_prfstep @{thm option.collapse}\ 109 | setup \add_forward_prfstep (equiv_forward_th @{thm option.simps(1)})\ 110 | setup \fold (fn th => add_rewrite_rule_cond th [with_score 1]) @{thms Option.option.case}\ 111 | 112 | end 113 | -------------------------------------------------------------------------------- /HOL/Order_Thms.thy: -------------------------------------------------------------------------------- 1 | (* 2 | File: Order_Thms.thy 3 | Author: Bohua Zhan 4 | 5 | Setup for proof steps related to ordering. 6 | *) 7 | 8 | section \Setup for ordering\ 9 | 10 | theory Order_Thms 11 | imports Logic_Thms HOL.Rat 12 | begin 13 | 14 | ML_file \util_arith.ML\ 15 | setup \Consts.add_const_data ("NUMC", UtilArith.is_numc)\ 16 | 17 | subsection \Results in class order or preorder\ 18 | 19 | setup \add_forward_prfstep_cond @{thm order.trans} [with_filt (not_type_filter "a" natT)]\ 20 | setup \add_forward_prfstep_cond @{thm order.strict_trans} [with_filt (not_type_filter "a" natT)]\ 21 | setup \add_forward_prfstep_cond @{thm order_le_less_trans} [with_filt (not_type_filter "x" natT)]\ 22 | setup \add_forward_prfstep_cond @{thm order_less_le_trans} [with_filt (not_type_filter "x" natT)]\ 23 | setup \add_resolve_prfstep @{thm order.irrefl}\ 24 | setup \add_forward_prfstep_cond @{thm Orderings.le_neq_trans} [with_cond "?a \ ?b"]\ 25 | setup \add_forward_prfstep_cond @{thm Orderings.order_antisym} [with_filt (order_filter "x" "y"), with_cond "?x \ ?y"]\ 26 | 27 | subsection \Rewriting of negation, in linorder\ 28 | 29 | setup \fold add_gen_prfstep [ 30 | ("not_less", 31 | [WithProp @{term_pat "\ (?x::(?'a::linorder)) < ?y"}, 32 | GetFact (@{term_pat "?y \ (?x::(?'a::linorder))"}, equiv_forward_th @{thm linorder_not_less}), 33 | WithScore 1]), 34 | ("not_le", 35 | [WithProp @{term_pat "\ (?x::(?'a::linorder)) \ ?y"}, 36 | GetFact (@{term_pat "?y < (?x::(?'a::linorder))"}, equiv_forward_th @{thm linorder_not_le}), 37 | WithScore 1])] 38 | \ 39 | 40 | subsection \Properties of max and min (in linorder)\ 41 | 42 | setup \add_rewrite_rule @{thm min.commute}\ 43 | setup \add_rewrite_rule @{thm min.idem}\ 44 | setup \add_forward_prfstep_cond @{thm min.cobounded1} [with_term "min ?a ?b"]\ 45 | setup \add_forward_prfstep_cond @{thm min.cobounded2} [with_term "min ?a ?b"]\ 46 | setup \add_backward2_prfstep @{thm min.boundedI}\ 47 | setup \add_backward2_prfstep @{thm min.mono}\ 48 | setup \add_rewrite_rule @{thm min.absorb1}\ 49 | setup \add_rewrite_rule @{thm min.absorb2}\ 50 | 51 | setup \add_rewrite_rule @{thm max.commute}\ 52 | setup \add_rewrite_rule @{thm max.idem}\ 53 | setup \add_forward_prfstep_cond @{thm max.cobounded1} [with_term "max ?a ?b"]\ 54 | setup \add_forward_prfstep_cond @{thm max.cobounded2} [with_term "max ?a ?b"]\ 55 | setup \add_backward2_prfstep @{thm max.boundedI}\ 56 | setup \add_backward2_prfstep @{thm max.mono}\ 57 | setup \add_rewrite_rule @{thm max.absorb1}\ 58 | setup \add_rewrite_rule @{thm max.absorb2}\ 59 | 60 | subsection \Min\ 61 | 62 | setup \add_backward_prfstep @{thm Min_in}\ 63 | setup \add_backward_prfstep @{thm Min_le}\ 64 | setup \add_backward2_prfstep @{thm Min_eqI}\ 65 | 66 | subsection \Existence of numbers satisfying inequalities\ 67 | 68 | theorem exists_ge [resolve]: "\k. k \ (i::('a::order))" by auto 69 | setup \fold add_resolve_prfstep [@{thm lt_ex}, @{thm gt_ex}]\ 70 | setup \add_backward_prfstep @{thm dense}\ 71 | 72 | end 73 | -------------------------------------------------------------------------------- /HOL/Primes_Ex.thy: -------------------------------------------------------------------------------- 1 | (* 2 | File: Primes_Ex.thy 3 | Author: Bohua Zhan 4 | 5 | Elementary number theory of primes, up to the proof of infinitude 6 | of primes and the unique factorization theorem. 7 | 8 | Follows the development in HOL/Computational_Algebra/Primes.thy. 9 | *) 10 | 11 | section \Primes\ 12 | 13 | theory Primes_Ex 14 | imports Auto2_Main 15 | begin 16 | 17 | subsection \Basic definition\ 18 | 19 | definition prime :: "nat \ bool" where [rewrite]: 20 | "prime p = (1 < p \ (\m. m dvd p \ m = 1 \ m = p))" 21 | 22 | lemma primeD1 [forward]: "prime p \ 1 < p" by auto2 23 | lemma primeD2: "prime p \ m dvd p \ m = 1 \ m = p" by auto2 24 | setup \add_forward_prfstep_cond @{thm primeD2} [with_cond "?m \ 1", with_cond "?m \ ?p"]\ 25 | setup \del_prfstep_thm_eqforward @{thm prime_def}\ 26 | 27 | (* Exists a prime p. *) 28 | theorem exists_prime [resolve]: "\p. prime p" 29 | @proof @have "prime 2" @qed 30 | 31 | lemma prime_odd_nat: "prime p \ p > 2 \ odd p" by auto2 32 | 33 | lemma prime_imp_coprime_nat [backward2]: "prime p \ \ p dvd n \ coprime p n" by auto2 34 | 35 | lemma prime_dvd_mult_nat: "prime p \ p dvd m * n \ p dvd m \ p dvd n" by auto2 36 | setup \add_forward_prfstep_cond @{thm prime_dvd_mult_nat} 37 | (with_conds ["?m \ ?p", "?n \ ?p", "?m \ ?p * ?m'", "?n \ ?p * ?n'"])\ 38 | 39 | theorem prime_dvd_intro: "prime p \ p * q = m * n \ p dvd m \ p dvd n" 40 | @proof @have "p dvd m * n" @qed 41 | setup \add_forward_prfstep_cond @{thm prime_dvd_intro} 42 | (with_conds ["?m \ ?p", "?n \ ?p", "?m \ ?p * ?m'", "?n \ ?p * ?n'"])\ 43 | 44 | lemma prime_dvd_mult_eq_nat: "prime p \ p dvd m * n = (p dvd m \ p dvd n)" by auto2 45 | 46 | lemma not_prime_eq_prod_nat [backward1]: "n > 1 \ \ prime n \ 47 | \m k. n = m * k \ 1 < m \ m < n \ 1 < k \ k < n" 48 | @proof 49 | @obtain m where "m dvd n \ m \ 1 \ m \ n" 50 | @obtain k where "n = m * k" @have "m \ m * k" @have "k \ m * k" 51 | @qed 52 | 53 | lemma prime_dvd_power_nat: "prime p \ p dvd x^n \ p dvd x" by auto2 54 | setup \add_forward_prfstep_cond @{thm prime_dvd_power_nat} [with_cond "?p \ ?x"]\ 55 | 56 | lemma prime_dvd_power_nat_iff: "prime p \ n > 0 \ p dvd x^n \ p dvd x" by auto2 57 | 58 | lemma prime_nat_code: "prime p = (1 < p \ (\x. 1 < x \ x < p \ \ x dvd p))" by auto2 59 | 60 | lemma prime_factor_nat [backward]: "n \ 1 \ \p. p dvd n \ prime p" 61 | @proof 62 | @strong_induct n 63 | @case "prime n" @case "n = 0" 64 | @obtain k where "k \ 1" "k \ n" "k dvd n" 65 | @apply_induct_hyp k 66 | @qed 67 | 68 | lemma prime_divprod_pow_nat: 69 | "prime p \ coprime a b \ p^n dvd a * b \ p^n dvd a \ p^n dvd b" by auto2 70 | 71 | lemma prime_product [forward]: "prime (p * q) \ p = 1 \ q = 1" 72 | @proof @have "p dvd q * p" @qed 73 | 74 | lemma prime_exp: "prime (p ^ n) \ n = 1 \ prime p" by auto2 75 | 76 | lemma prime_power_mult: "prime p \ x * y = p ^ k \ \i j. x = p ^ i \ y = p ^ j" 77 | @proof 78 | @induct k arbitrary x y @with 79 | @subgoal "k = Suc k'" 80 | @case "p dvd x" @with 81 | @obtain x' where "x = p * x'" @have "x * y = p * (x' * y)" 82 | @obtain i j where "x' = p ^ i" "y = p ^ j" @have "x = p ^ Suc i" @end 83 | @case "p dvd y" @with 84 | @obtain y' where "y = p * y'" @have "x * y = p * (x * y')" 85 | @obtain i j where "x = p ^ i" "y' = p ^ j" @have "y = p ^ Suc j" @end 86 | @endgoal 87 | @end 88 | @qed 89 | 90 | subsection \Infinitude of primes\ 91 | 92 | theorem bigger_prime [resolve]: "\p. prime p \ n < p" 93 | @proof 94 | @obtain p where "prime p" "p dvd fact n + 1" 95 | @case "n \ p" @with @have "(p::nat) dvd fact n" @end 96 | @qed 97 | 98 | theorem primes_infinite: "\ finite {p. prime p}" 99 | @proof 100 | @obtain b where "prime b" "Max {p. prime p} < b" 101 | @qed 102 | 103 | subsection \Existence and uniqueness of prime factorization\ 104 | 105 | theorem factorization_exists: "n > 0 \ \M. (\p\#M. prime p) \ n = (\i\#M. i)" 106 | @proof 107 | @strong_induct n 108 | @case "n = 1" @with @have "n = (\i\# {#}. i)" @end 109 | @case "prime n" @with @have "n = (\i\# {#n#}. i)" @end 110 | @obtain m k where "n = m * k" "1 < m" "m < n" "1 < k" "k < n" 111 | @apply_induct_hyp m 112 | @obtain M where "(\p\#M. prime p)" "m = (\i\#M. i)" 113 | @apply_induct_hyp k 114 | @obtain K where "(\p\#K. prime p)" "k = (\i\#K. i)" 115 | @have "n = (\i\#(M+K). i)" 116 | @qed 117 | 118 | theorem prime_dvd_multiset [backward1]: "prime p \ p dvd (\i\#M. i) \ \n. n\#M \ p dvd n" 119 | @proof 120 | @strong_induct M 121 | @case "M = {#}" 122 | @obtain M' m where "M = M' + {#m#}" 123 | @contradiction @apply_induct_hyp M' 124 | @qed 125 | 126 | theorem factorization_unique_aux: 127 | "\p\#M. prime p \ \p\#N. prime p \ (\i\#M. i) dvd (\i\#N. i) \ M \# N" 128 | @proof 129 | @strong_induct M arbitrary N 130 | @case "M = {#}" 131 | @obtain M' m where "M = M' + {#m#}" 132 | @have "m dvd (\i\#M. i)" 133 | @obtain n where "n \# N" "m dvd n" 134 | @obtain N' where "N = N' + {#n#}" 135 | @have "m = n" 136 | @have "(\i\#M'. i) dvd (\i\#N'. i)" 137 | @apply_induct_hyp M' N' 138 | @qed 139 | setup \add_forward_prfstep_cond @{thm factorization_unique_aux} [with_cond "?M \ ?N"]\ 140 | 141 | theorem factorization_unique: 142 | "\p\#M. prime p \ \p\#N. prime p \ (\i\#M. i) = (\i\#N. i) \ M = N" 143 | @proof @have "M \# N" @qed 144 | setup \del_prfstep_thm @{thm factorization_unique_aux}\ 145 | 146 | end 147 | -------------------------------------------------------------------------------- /HOL/Program_Verification/Functional/Connectivity.thy: -------------------------------------------------------------------------------- 1 | (* 2 | File: Connectivity.thy 3 | Author: Bohua Zhan 4 | *) 5 | 6 | section \Connectedness for a set of undirected edges.\ 7 | 8 | theory Connectivity 9 | imports Union_Find 10 | begin 11 | 12 | text \A simple application of union-find for graph connectivity.\ 13 | 14 | fun is_path :: "nat \ (nat \ nat) set \ nat list \ bool" where 15 | "is_path n S [] = False" 16 | | "is_path n S (x # xs) = 17 | (if xs = [] then x < n else ((x, hd xs) \ S \ (hd xs, x) \ S) \ is_path n S xs)" 18 | setup \fold add_rewrite_rule @{thms is_path.simps}\ 19 | 20 | definition has_path :: "nat \ (nat \ nat) set \ nat \ nat \ bool" where [rewrite]: 21 | "has_path n S i j \ (\p. is_path n S p \ hd p = i \ last p = j)" 22 | 23 | lemma is_path_nonempty [forward]: "is_path n S p \ p \ []" by auto2 24 | lemma nonempty_is_not_path [resolve]: "\is_path n S []" by auto2 25 | 26 | lemma is_path_extend [forward]: 27 | "is_path n S p \ S \ T \ is_path n T p" 28 | @proof @induct p @qed 29 | 30 | lemma has_path_extend [forward]: 31 | "has_path n S i j \ S \ T \ has_path n T i j" by auto2 32 | 33 | definition joinable :: "nat list \ nat list \ bool" where [rewrite]: 34 | "joinable p q \ (last p = hd q)" 35 | 36 | definition path_join :: "nat list \ nat list \ nat list" where [rewrite]: 37 | "path_join p q = p @ tl q" 38 | setup \register_wellform_data ("path_join p q", ["joinable p q"])\ 39 | setup \add_prfstep_check_req ("path_join p q", "joinable p q")\ 40 | 41 | lemma path_join_hd [rewrite]: "p \ [] \ hd (path_join p q) = hd p" by auto2 42 | 43 | lemma path_join_last [rewrite]: "joinable p q \ q \ [] \ last (path_join p q) = last q" 44 | @proof @have "q = hd q # tl q" @case "tl q = []" @qed 45 | 46 | lemma path_join_is_path [backward]: 47 | "joinable p q \ is_path n S p \ is_path n S q \ is_path n S (path_join p q)" 48 | @proof @induct p @qed 49 | 50 | lemma has_path_trans [forward]: 51 | "has_path n S i j \ has_path n S j k \ has_path n S i k" 52 | @proof 53 | @obtain p where "is_path n S p" "hd p = i" "last p = j" 54 | @obtain q where "is_path n S q" "hd q = j" "last q = k" 55 | @have "is_path n S (path_join p q)" 56 | @qed 57 | 58 | definition is_valid_graph :: "nat \ (nat \ nat) set \ bool" where [rewrite]: 59 | "is_valid_graph n S \ (\p\S. fst p < n \ snd p < n)" 60 | 61 | lemma has_path_single1 [backward1]: 62 | "is_valid_graph n S \ (a, b) \ S \ has_path n S a b" 63 | @proof @have "is_path n S [a, b]" @qed 64 | 65 | lemma has_path_single2 [backward1]: 66 | "is_valid_graph n S \ (a, b) \ S \ has_path n S b a" 67 | @proof @have "is_path n S [b, a]" @qed 68 | 69 | lemma has_path_refl [backward2]: 70 | "is_valid_graph n S \ a < n \ has_path n S a a" 71 | @proof @have "is_path n S [a]" @qed 72 | 73 | definition connected_rel :: "nat \ (nat \ nat) set \ (nat \ nat) set" where 74 | "connected_rel n S = {(a,b). has_path n S a b}" 75 | 76 | lemma connected_rel_iff [rewrite]: 77 | "(a, b) \ connected_rel n S \ has_path n S a b" using connected_rel_def by simp 78 | 79 | lemma connected_rel_trans [forward]: 80 | "trans (connected_rel n S)" by auto2 81 | 82 | lemma connected_rel_refl [backward2]: 83 | "is_valid_graph n S \ a < n \ (a, a) \ connected_rel n S" by auto2 84 | 85 | lemma is_path_per_union [rewrite]: 86 | "is_valid_graph n (S \ {(a, b)}) \ 87 | has_path n (S \ {(a, b)}) i j \ (i, j) \ per_union (connected_rel n S) a b" 88 | @proof 89 | @let "R = connected_rel n S" 90 | @let "S' = S \ {(a, b)}" @have "S \ S'" 91 | @case "(i, j) \ per_union R a b" @with 92 | @case "(i, a) \ R \ (b, j) \ R" @with 93 | @have "has_path n S' i a" @have "has_path n S' a b" @have "has_path n S' b j" 94 | @end 95 | @case "(i, b) \ R \ (a, j) \ R" @with 96 | @have "has_path n S' i b" @have "has_path n S' b a" @have "has_path n S' a j" 97 | @end 98 | @end 99 | @case "has_path n S' i j" @with 100 | @have (@rule) "\p. is_path n S' p \ (hd p, last p) \ per_union R a b" @with 101 | @induct p @with 102 | @subgoal "p = x # xs" @case "xs = []" 103 | @have "(x, hd xs) \ per_union R a b" @with 104 | @have "is_valid_graph n S" 105 | @case "(x, hd xs) \ S'" @with @case "(x, hd xs) \ S" @end 106 | @case "(hd xs, x) \ S'" @with @case "(hd xs, x) \ S" @end 107 | @end 108 | @endgoal @end 109 | @end 110 | @obtain p where "is_path n S' p" "hd p = i" "last p = j" 111 | @end 112 | @qed 113 | 114 | lemma connected_rel_union [rewrite]: 115 | "is_valid_graph n (S \ {(a, b)}) \ 116 | connected_rel n (S \ {(a, b)}) = per_union (connected_rel n S) a b" by auto2 117 | 118 | lemma connected_rel_init [rewrite]: 119 | "connected_rel n {} = uf_init_rel n" 120 | @proof 121 | @have "is_valid_graph n {}" 122 | @have "\i j. has_path n {} i j \ (i, j) \ uf_init_rel n" @with 123 | @case "has_path n {} i j" @with 124 | @obtain p where "is_path n {} p" "hd p = i" "last p = j" 125 | @have "p = hd p # tl p" 126 | @end 127 | @end 128 | @qed 129 | 130 | fun connected_rel_ind :: "nat \ (nat \ nat) list \ nat \ (nat \ nat) set" where 131 | "connected_rel_ind n es 0 = uf_init_rel n" 132 | | "connected_rel_ind n es (Suc k) = 133 | (let R = connected_rel_ind n es k; p = es ! k in 134 | per_union R (fst p) (snd p))" 135 | setup \fold add_rewrite_rule @{thms connected_rel_ind.simps}\ 136 | 137 | lemma connected_rel_ind_rule [rewrite]: 138 | "is_valid_graph n (set es) \ k \ length es \ 139 | connected_rel_ind n es k = connected_rel n (set (take k es))" 140 | @proof @induct k @with 141 | @subgoal "k = Suc m" 142 | @have "is_valid_graph n (set (take (Suc m) es))" 143 | @endgoal @end 144 | @qed 145 | 146 | text \Correctness of the functional algorithm.\ 147 | theorem connected_rel_ind_compute [rewrite]: 148 | "is_valid_graph n (set es) \ 149 | connected_rel_ind n es (length es) = connected_rel n (set es)" by auto2 150 | 151 | end 152 | -------------------------------------------------------------------------------- /HOL/Program_Verification/Functional/Interval.thy: -------------------------------------------------------------------------------- 1 | (* 2 | File: Interval.thy 3 | Author: Bohua Zhan 4 | *) 5 | 6 | section \Intervals\ 7 | 8 | theory Interval 9 | imports "Auto2_HOL.Auto2_Main" 10 | begin 11 | 12 | text \Basic definition of intervals.\ 13 | 14 | subsection \Definition of interval\ 15 | 16 | datatype 'a interval = Interval (low: 'a) (high: 'a) 17 | setup \add_simple_datatype "interval"\ 18 | 19 | instantiation interval :: (linorder) linorder begin 20 | 21 | definition int_less: "(a < b) = (low a < low b | (low a = low b \ high a < high b))" 22 | definition int_less_eq: "(a \ b) = (low a < low b | (low a = low b \ high a \ high b))" 23 | 24 | instance proof 25 | fix x y z :: "'a interval" 26 | show a: "(x < y) = (x \ y \ \ y \ x)" 27 | using int_less int_less_eq by force 28 | show b: "x \ x" 29 | by (simp add: int_less_eq) 30 | show c: "x \ y \ y \ z \ x \ z" 31 | by (smt int_less_eq dual_order.trans less_trans) 32 | show d: "x \ y \ y \ x \ x = y" 33 | using int_less_eq a interval.expand int_less by fastforce 34 | show e: "x \ y \ y \ x" 35 | by (meson int_less_eq leI not_less_iff_gr_or_eq) 36 | qed end 37 | 38 | definition is_interval :: "('a::linorder) interval \ bool" where [rewrite]: 39 | "is_interval it \ (low it \ high it)" 40 | 41 | subsection \Definition of interval with an index\ 42 | 43 | datatype 'a idx_interval = IdxInterval (int: "'a interval") (idx: nat) 44 | setup \add_simple_datatype "idx_interval"\ 45 | 46 | instantiation idx_interval :: (linorder) linorder begin 47 | 48 | definition iint_less: "(a < b) = (int a < int b | (int a = int b \ idx a < idx b))" 49 | definition iint_less_eq: "(a \ b) = (int a < int b | (int a = int b \ idx a \ idx b))" 50 | 51 | instance proof 52 | fix x y z :: "'a idx_interval" 53 | show a: "(x < y) = (x \ y \ \ y \ x)" 54 | using iint_less iint_less_eq by force 55 | show b: "x \ x" 56 | by (simp add: iint_less_eq) 57 | show c: "x \ y \ y \ z \ x \ z" 58 | by (smt iint_less_eq dual_order.trans less_trans) 59 | show d: "x \ y \ y \ x \ x = y" 60 | using a idx_interval.expand iint_less iint_less_eq by auto 61 | show e: "x \ y \ y \ x" 62 | by (meson iint_less_eq leI not_less_iff_gr_or_eq) 63 | qed end 64 | 65 | lemma interval_less_to_le_low [forward]: 66 | "(a::('a::linorder idx_interval)) < b \ low (int a) \ low (int b)" 67 | by (metis eq_iff iint_less int_less less_imp_le) 68 | 69 | subsection \Overlapping intervals\ 70 | 71 | definition is_overlap :: "('a::linorder) interval \ 'a interval \ bool" where [rewrite]: 72 | "is_overlap x y \ (high x \ low y \ high y \ low x)" 73 | 74 | definition has_overlap :: "('a::linorder) idx_interval set \ 'a interval \ bool" where [rewrite]: 75 | "has_overlap xs y \ (\x\xs. is_overlap (int x) y)" 76 | 77 | end 78 | -------------------------------------------------------------------------------- /HOL/Program_Verification/Functional/Partial_Equiv_Rel.thy: -------------------------------------------------------------------------------- 1 | (* 2 | File: Partial_Equiv_Rel.thy 3 | Author: Bohua Zhan 4 | *) 5 | 6 | section \Partial equivalence relation\ 7 | 8 | theory Partial_Equiv_Rel 9 | imports "Auto2_HOL.Auto2_Main" 10 | begin 11 | 12 | text \ 13 | Partial equivalence relations, following theory 14 | Lib/Partial\_Equivalence\_Relation in \cite{Collections-AFP}. 15 | \ 16 | 17 | definition part_equiv :: "('a \ 'a) set \ bool" where [rewrite]: 18 | "part_equiv R \ sym R \ trans R" 19 | 20 | lemma part_equivI [forward]: "sym R \ trans R \ part_equiv R" by auto2 21 | lemma part_equivD1 [forward]: "part_equiv R \ sym R" by auto2 22 | lemma part_equivD2 [forward]: "part_equiv R \ trans R" by auto2 23 | setup \del_prfstep_thm_eqforward @{thm part_equiv_def}\ 24 | 25 | subsection \Combining two elements in a partial equivalence relation\ 26 | 27 | definition per_union :: "('a \ 'a) set \ 'a \ 'a \ ('a \ 'a) set" where [rewrite]: 28 | "per_union R a b = R \ { (x,y). (x,a)\R \ (b,y)\R } \ { (x,y). (x,b)\R \ (a,y)\R }" 29 | 30 | lemma per_union_memI1 [backward]: 31 | "(x, y) \ R \ (x, y) \ per_union R a b" by (simp add: per_union_def) 32 | setup \add_forward_prfstep_cond @{thm per_union_memI1} [with_term "per_union ?R ?a ?b"]\ 33 | 34 | lemma per_union_memI2 [backward]: 35 | "(x, a) \ R \ (b, y) \ R \ (x, y) \ per_union R a b" by (simp add: per_union_def) 36 | 37 | lemma per_union_memI3 [backward]: 38 | "(x, b) \ R \ (a, y) \ R \ (x, y) \ per_union R a b" by (simp add: per_union_def) 39 | 40 | lemma per_union_memD: 41 | "(x, y) \ per_union R a b \ (x, y) \ R \ ((x, a) \ R \ (b, y) \ R) \ ((x, b) \ R \ (a, y) \ R)" 42 | by (simp add: per_union_def) 43 | setup \add_forward_prfstep_cond @{thm per_union_memD} [with_cond "?x \ ?y", with_filt (order_filter "x" "y")]\ 44 | setup \del_prfstep_thm @{thm per_union_def}\ 45 | 46 | lemma per_union_is_trans [forward]: 47 | "trans R \ trans (per_union R a b)" by auto2 48 | 49 | lemma per_union_is_part_equiv [forward]: 50 | "part_equiv R \ part_equiv (per_union R a b)" by auto2 51 | 52 | end 53 | -------------------------------------------------------------------------------- /HOL/Program_Verification/Functional/Union_Find.thy: -------------------------------------------------------------------------------- 1 | (* 2 | File: Union_Find.thy 3 | Author: Bohua Zhan 4 | *) 5 | 6 | section \Union find\ 7 | 8 | theory Union_Find 9 | imports Partial_Equiv_Rel 10 | begin 11 | 12 | text \ 13 | Development follows theory Union\_Find in \cite{Separation_Logic_Imperative_HOL-AFP}. 14 | \ 15 | 16 | subsection \Representing a partial equivalence relation using rep\_of array\ 17 | 18 | function (domintros) rep_of where 19 | "rep_of l i = (if l ! i = i then i else rep_of l (l ! i))" by auto 20 | 21 | setup \register_wellform_data ("rep_of l i", ["i < length l"])\ 22 | setup \add_backward_prfstep @{thm rep_of.domintros}\ 23 | setup \add_rewrite_rule @{thm rep_of.psimps}\ 24 | setup \add_prop_induct_rule @{thm rep_of.pinduct}\ 25 | 26 | definition ufa_invar :: "nat list \ bool" where [rewrite]: 27 | "ufa_invar l = (\i l ! i < length l)" 28 | 29 | lemma ufa_invarD: 30 | "ufa_invar l \ i < length l \ rep_of_dom (l, i) \ l ! i < length l" by auto2 31 | setup \add_forward_prfstep_cond @{thm ufa_invarD} [with_term "?l ! ?i"]\ 32 | setup \del_prfstep_thm_eqforward @{thm ufa_invar_def}\ 33 | 34 | lemma rep_of_id [rewrite]: "ufa_invar l \ i < length l \ l ! i = i \ rep_of l i = i" by auto2 35 | 36 | lemma rep_of_iff [rewrite]: 37 | "ufa_invar l \ i < length l \ rep_of l i = (if l ! i = i then i else rep_of l (l ! i))" by auto2 38 | setup \del_prfstep_thm @{thm rep_of.psimps}\ 39 | 40 | lemma rep_of_min [rewrite]: 41 | "ufa_invar l \ i < length l \ l ! (rep_of l i) = rep_of l i" 42 | @proof @prop_induct "rep_of_dom (l, i)" @qed 43 | 44 | lemma rep_of_induct: 45 | "ufa_invar l \ i < length l \ 46 | \i P l i \ 47 | \i i \ P l (l ! i) \ P l i \ P l i" 48 | @proof @prop_induct "rep_of_dom (l, i)" @qed 49 | setup \add_prop_induct_rule @{thm rep_of_induct}\ 50 | 51 | lemma rep_of_bound [forward_arg1]: 52 | "ufa_invar l \ i < length l \ rep_of l i < length l" 53 | @proof @prop_induct "ufa_invar l \ i < length l" @qed 54 | 55 | lemma rep_of_idem [rewrite]: 56 | "ufa_invar l \ i < length l \ rep_of l (rep_of l i) = rep_of l i" by auto2 57 | 58 | lemma rep_of_idx [rewrite]: 59 | "ufa_invar l \ i < length l \ rep_of l (l ! i) = rep_of l i" by auto2 60 | 61 | definition ufa_\ :: "nat list \ (nat \ nat) set" where [rewrite]: 62 | "ufa_\ l = {(x, y). x < length l \ y < length l \ rep_of l x = rep_of l y}" 63 | 64 | lemma ufa_\_memI [backward, forward_arg]: 65 | "x < length l \ y < length l \ rep_of l x = rep_of l y \ (x, y) \ ufa_\ l" 66 | by (simp add: ufa_\_def) 67 | 68 | lemma ufa_\_memD [forward]: 69 | "(x, y) \ ufa_\ l \ x < length l \ y < length l \ rep_of l x = rep_of l y" 70 | by (simp add: ufa_\_def) 71 | setup \del_prfstep_thm @{thm ufa_\_def}\ 72 | 73 | lemma ufa_\_equiv [forward]: "part_equiv (ufa_\ l)" by auto2 74 | 75 | lemma ufa_\_refl [rewrite]: "(i, i) \ ufa_\ l \ i < length l" by auto2 76 | 77 | subsection \Operations on rep\_of array\ 78 | 79 | definition uf_init_rel :: "nat \ (nat \ nat) set" where [rewrite]: 80 | "uf_init_rel n = ufa_\ [0.. uf_init_rel n \ (x = y \ x < n)" 86 | @proof @have "ufa_invar [0.. nat \ nat \ nat list" where 89 | "ufa_union l x y \ l[rep_of l x := rep_of l y]" 90 | 91 | lemma ufa_union_invar [forward_arg]: 92 | "ufa_invar l \ x < length l \ y < length l \ l' = ufa_union l x y \ ufa_invar l'" 93 | @proof 94 | @have "\i l' ! i < length l'" @with 95 | @prop_induct "ufa_invar l \ i < length l" 96 | @end 97 | @qed 98 | 99 | lemma ufa_union_aux [rewrite]: 100 | "ufa_invar l \ x < length l \ y < length l \ l' = ufa_union l x y \ 101 | i < length l' \ rep_of l' i = (if rep_of l i = rep_of l x then rep_of l y else rep_of l i)" 102 | @proof @prop_induct "ufa_invar l \ i < length l" @qed 103 | 104 | text \Correctness of union operation.\ 105 | theorem ufa_union_correct [rewrite]: 106 | "ufa_invar l \ x < length l \ y < length l \ l' = ufa_union l x y \ 107 | ufa_\ l' = per_union (ufa_\ l) x y" 108 | @proof 109 | @have "\a b. (a,b) \ ufa_\ l' \ (a,b) \ per_union (ufa_\ l) x y" @with 110 | @case "(a,b) \ ufa_\ l'" @with 111 | @case "rep_of l a = rep_of l x" 112 | @case "rep_of l a = rep_of l y" 113 | @end 114 | @end 115 | @qed 116 | 117 | abbreviation ufa_compress :: "nat list \ nat \ nat list" where 118 | "ufa_compress l x \ l[x := rep_of l x]" 119 | 120 | lemma ufa_compress_invar [forward_arg]: 121 | "ufa_invar l \ x < length l \ l' = ufa_compress l x \ ufa_invar l'" 122 | @proof 123 | @have "\i l' ! i < length l'" @with 124 | @prop_induct "ufa_invar l \ i < length l" 125 | @end 126 | @qed 127 | 128 | lemma ufa_compress_aux [rewrite]: 129 | "ufa_invar l \ x < length l \ l' = ufa_compress l x \ i < length l' \ 130 | rep_of l' i = rep_of l i" 131 | @proof @prop_induct "ufa_invar l \ i < length l" @qed 132 | 133 | text \Correctness of compress operation.\ 134 | theorem ufa_compress_correct [rewrite]: 135 | "ufa_invar l \ x < length l \ ufa_\ (ufa_compress l x) = ufa_\ l" by auto2 136 | 137 | setup \del_prfstep_thm @{thm rep_of_iff}\ 138 | 139 | end 140 | -------------------------------------------------------------------------------- /HOL/Program_Verification/Imperative/Arrays_Impl.thy: -------------------------------------------------------------------------------- 1 | (* 2 | File: Arrays_Impl.thy 3 | Author: Bohua Zhan 4 | *) 5 | 6 | section \Implementation of arrays\ 7 | 8 | theory Arrays_Impl 9 | imports SepAuto "../Functional/Arrays_Ex" 10 | begin 11 | 12 | text \ 13 | Imperative implementations of common array operations. 14 | 15 | Imperative reverse on arrays is also verified in theory Imperative\_Reverse 16 | in Imperative\_HOL/ex in the Isabelle library. 17 | \ 18 | 19 | subsection \Array copy\ 20 | 21 | fun array_copy :: "'a::heap array \ 'a array \ nat \ unit Heap" where 22 | "array_copy a b 0 = (return ())" 23 | | "array_copy a b (Suc n) = do { 24 | array_copy a b n; 25 | x \ Array.nth a n; 26 | Array.upd n x b; 27 | return () }" 28 | 29 | lemma array_copy_rule [hoare_triple]: 30 | "n \ length as \ n \ length bs \ 31 | \<^sub>a as * b \\<^sub>a bs> 32 | array_copy a b n 33 | <\_. a \\<^sub>a as * b \\<^sub>a Arrays_Ex.array_copy as bs n>" 34 | @proof @induct n @qed 35 | 36 | subsection \Swap\ 37 | 38 | definition swap :: "'a::heap array \ nat \ nat \ unit Heap" where 39 | "swap a i j = do { 40 | x \ Array.nth a i; 41 | y \ Array.nth a j; 42 | Array.upd i y a; 43 | Array.upd j x a; 44 | return () 45 | }" 46 | 47 | lemma swap_rule [hoare_triple]: 48 | "i < length xs \ j < length xs \ 49 |

\<^sub>a xs> 50 | swap p i j 51 | <\_. p \\<^sub>a list_swap xs i j>" by auto2 52 | 53 | subsection \Reverse\ 54 | 55 | fun rev :: "'a::heap array \ nat \ nat \ unit Heap" where 56 | "rev a i j = (if i < j then do { 57 | swap a i j; 58 | rev a (i + 1) (j - 1) 59 | } 60 | else return ())" 61 | 62 | lemma rev_to_fun [hoare_triple]: 63 | "j < length xs \ 64 |

\<^sub>a xs> 65 | rev p i j 66 | <\_. p \\<^sub>a rev_swap xs i j>" 67 | @proof @fun_induct "rev_swap xs i j" @unfold "rev_swap xs i j" @qed 68 | 69 | text \Correctness of imperative reverse.\ 70 | theorem rev_is_rev [hoare_triple]: 71 | "xs \ [] \ 72 |

\<^sub>a xs> 73 | rev p 0 (length xs - 1) 74 | <\_. p \\<^sub>a List.rev xs>" by auto2 75 | 76 | end 77 | -------------------------------------------------------------------------------- /HOL/Program_Verification/Imperative/Connectivity_Impl.thy: -------------------------------------------------------------------------------- 1 | (* 2 | File: Connectivity_Impl.thy 3 | Author: Bohua Zhan 4 | *) 5 | 6 | section \Implementation of connectivity on graphs\ 7 | 8 | theory Connectivity_Impl 9 | imports Union_Find_Impl "../Functional/Connectivity" 10 | begin 11 | 12 | text \Imperative version of graph-connectivity example.\ 13 | 14 | subsection \Constructing the connected relation\ 15 | 16 | fun connected_rel_imp :: "nat \ (nat \ nat) list \ nat \ uf Heap" where 17 | "connected_rel_imp n es 0 = do { p \ uf_init n; return p }" 18 | | "connected_rel_imp n es (Suc k) = do { 19 | p \ connected_rel_imp n es k; 20 | p' \ uf_union p (fst (es ! k)) (snd (es ! k)); 21 | return p' }" 22 | 23 | lemma connected_rel_imp_to_fun [hoare_triple]: 24 | "is_valid_graph n (set es) \ k \ length es \ 25 | 26 | connected_rel_imp n es k 27 | " 28 | @proof @induct k @qed 29 | 30 | lemma connected_rel_imp_correct [hoare_triple]: 31 | "is_valid_graph n (set es) \ 32 | 33 | connected_rel_imp n es (length es) 34 | " by auto2 35 | 36 | subsection \Connectedness tests\ 37 | 38 | text \Correctness of the algorithm for detecting connectivity.\ 39 | theorem uf_cmp_correct [hoare_triple]: 40 | " 41 | uf_cmp p i j 42 | <\r. is_uf n (connected_rel n S) p * \(r \ has_path n S i j)>" by auto2 43 | 44 | end 45 | -------------------------------------------------------------------------------- /HOL/Program_Verification/Imperative/GCD_Impl.thy: -------------------------------------------------------------------------------- 1 | (* 2 | File: GCD_Impl.thy 3 | Author: Bohua Zhan 4 | *) 5 | 6 | theory GCD_Impl 7 | imports SepAuto 8 | begin 9 | 10 | text \A tutorial example for computation of GCD.\ 11 | 12 | text \Turn on auto2's trace\ 13 | declare [[print_trace]] 14 | 15 | text \Property of gcd that justifies the recursive computation. Add as a 16 | right-to-left rewrite rule.\ 17 | setup \add_rewrite_rule_back @{thm gcd_red_nat}\ 18 | 19 | text \Functional version of gcd.\ 20 | fun gcd_fun :: "nat \ nat \ nat" where 21 | "gcd_fun a b = (if b = 0 then a else gcd_fun b (a mod b))" 22 | 23 | text \The fun package automatically generates induction rule upon showing 24 | termination. This adds the induction rule for the @fun\_induct command.\ 25 | setup \add_fun_induct_rule (@{term gcd_fun}, @{thm gcd_fun.induct})\ 26 | 27 | lemma gcd_fun_correct: 28 | "gcd_fun a b = gcd a b" 29 | @proof 30 | @fun_induct "gcd_fun a b" 31 | @unfold "gcd_fun a b" 32 | @qed 33 | 34 | text \Imperative version of gcd.\ 35 | partial_function (heap) gcd_impl :: "nat \ nat \ nat Heap" where 36 | "gcd_impl a b = ( 37 | if b = 0 then return a 38 | else do { 39 | c \ return (a mod b); 40 | r \ gcd_impl b c; 41 | return r 42 | })" 43 | 44 | text \The program is sufficiently simple that we can prove the Hoare triple 45 | directly (without going through the functional program).\ 46 | theorem gcd_impl_correct: 47 | " gcd_impl a b <\r. \(r = gcd a b)>" 48 | @proof 49 | @fun_induct "gcd_fun a b" 50 | @qed 51 | 52 | text \Turn off trace.\ 53 | declare [[print_trace = false]] 54 | 55 | end 56 | -------------------------------------------------------------------------------- /HOL/Program_Verification/Imperative/Quicksort_Impl.thy: -------------------------------------------------------------------------------- 1 | (* 2 | File: Quicksort_Impl.thy 3 | Author: Bohua Zhan 4 | *) 5 | 6 | section \Implementation of quicksort\ 7 | 8 | theory Quicksort_Impl 9 | imports Arrays_Impl "../Functional/Quicksort" 10 | begin 11 | 12 | text \ 13 | Imperative implementation of quicksort. Also verified in 14 | theory Imperative\_Quicksort in HOL/Imperative\_HOL/ex 15 | in the Isabelle library. 16 | \ 17 | 18 | partial_function (heap) part1 :: "'a::{heap,linorder} array \ nat \ nat \ 'a \ nat Heap" where 19 | "part1 a l r p = ( 20 | if r \ l then return r 21 | else do { 22 | v \ Array.nth a l; 23 | if v \ p then 24 | part1 a (l + 1) r p 25 | else do { 26 | swap a l r; 27 | part1 a l (r - 1) p }})" 28 | 29 | lemma part1_to_fun [hoare_triple]: 30 | "r < length xs \

\<^sub>a xs> 31 | part1 p l r a 32 | <\rs. p \\<^sub>a snd (Quicksort.part1 xs l r a) * \(rs = fst (Quicksort.part1 xs l r a))>" 33 | @proof @fun_induct "Quicksort.part1 xs l r a" @unfold "Quicksort.part1 xs l r a" @qed 34 | 35 | text \Partition function\ 36 | definition partition :: "'a::{heap,linorder} array \ nat \ nat \ nat Heap" where 37 | "partition a l r = do { 38 | p \ Array.nth a r; 39 | m \ part1 a l (r - 1) p; 40 | v \ Array.nth a m; 41 | m' \ return (if v \ p then m + 1 else m); 42 | swap a m' r; 43 | return m' 44 | }" 45 | 46 | lemma partition_to_fun [hoare_triple]: 47 | "l < r \ r < length xs \ \<^sub>a xs> 48 | partition a l r 49 | <\rs. a \\<^sub>a snd (Quicksort.partition xs l r) * \(rs = fst (Quicksort.partition xs l r))>" 50 | @proof @unfold "Quicksort.partition xs l r" @qed 51 | 52 | text \Quicksort function\ 53 | partial_function (heap) quicksort :: "'a::{heap,linorder} array \ nat \ nat \ unit Heap" where 54 | "quicksort a l r = do { 55 | len \ Array.len a; 56 | if l \ r then return () 57 | else if r < len then do { 58 | p \ partition a l r; 59 | quicksort a l (p - 1); 60 | quicksort a (p + 1) r 61 | } 62 | else return () 63 | }" 64 | 65 | lemma quicksort_to_fun [hoare_triple]: 66 | "r < length xs \ \<^sub>a xs> 67 | quicksort a l r 68 | <\_. a \\<^sub>a Quicksort.quicksort xs l r>" 69 | @proof @fun_induct "Quicksort.quicksort xs l r" @unfold "Quicksort.quicksort xs l r" @qed 70 | 71 | definition quicksort_all :: "('a::{heap,linorder}) array \ unit Heap" where 72 | "quicksort_all a = do { 73 | n \ Array.len a; 74 | if n = 0 then return () 75 | else quicksort a 0 (n - 1) 76 | }" 77 | 78 | text \Correctness of quicksort.\ 79 | theorem quicksort_sorts_basic [hoare_triple]: 80 | "\<^sub>a xs> 81 | quicksort_all a 82 | <\_. a \\<^sub>a sort xs>" by auto2 83 | 84 | end 85 | -------------------------------------------------------------------------------- /HOL/Program_Verification/Imperative/Rect_Intersect_Impl.thy: -------------------------------------------------------------------------------- 1 | (* 2 | File: Rect_Intersect_Impl.thy 3 | Author: Bohua Zhan 4 | *) 5 | 6 | section \Implementation of rectangle intersection\ 7 | 8 | theory Rect_Intersect_Impl 9 | imports "../Functional/Rect_Intersect" IntervalTree_Impl Quicksort_Impl 10 | begin 11 | 12 | text \Imperative version of rectangle-intersection algorithm.\ 13 | 14 | subsection \Operations\ 15 | 16 | fun operation_encode :: "('a::heap) operation \ nat" where 17 | "operation_encode oper = 18 | (case oper of INS p i n \ to_nat (is_INS oper, p, i, n) 19 | | DEL p i n \ to_nat (is_INS oper, p, i, n))" 20 | 21 | instance operation :: (heap) heap 22 | apply (rule heap_class.intro) 23 | apply (rule countable_classI [of "operation_encode"]) 24 | apply (case_tac x, simp_all, case_tac y, simp_all) 25 | apply (simp add: operation.case_eq_if) 26 | .. 27 | 28 | subsection \Initial state\ 29 | 30 | definition rect_inter_init :: "nat rectangle list \ nat operation array Heap" where 31 | "rect_inter_init rects = do { 32 | p \ Array.of_list (ins_ops rects @ del_ops rects); 33 | quicksort_all p; 34 | return p }" 35 | 36 | setup \add_rewrite_rule @{thm all_ops_def}\ 37 | lemma rect_inter_init_rule [hoare_triple]: 38 | " rect_inter_init rects <\p. p \\<^sub>a all_ops rects>" by auto2 39 | setup \del_prfstep_thm @{thm all_ops_def}\ 40 | 41 | definition rect_inter_next :: "nat operation array \ int_tree \ nat \ int_tree Heap" where 42 | "rect_inter_next a b k = do { 43 | oper \ Array.nth a k; 44 | if is_INS oper then 45 | IntervalTree_Impl.insert_impl (IdxInterval (op_int oper) (op_idx oper)) b 46 | else 47 | IntervalTree_Impl.delete_impl (IdxInterval (op_int oper) (op_idx oper)) b }" 48 | 49 | lemma op_int_is_interval: 50 | "is_rect_list rects \ ops = all_ops rects \ k < length ops \ 51 | is_interval (op_int (ops ! k))" 52 | @proof @have "ops ! k \ set ops" @case "is_INS (ops ! k)" @qed 53 | setup \add_forward_prfstep_cond @{thm op_int_is_interval} [with_term "op_int (?ops ! ?k)"]\ 54 | 55 | lemma rect_inter_next_rule [hoare_triple]: 56 | "is_rect_list rects \ k < length (all_ops rects) \ 57 | \<^sub>a all_ops rects * int_tree_set S b> 58 | rect_inter_next a b k 59 | <\r. a \\<^sub>a all_ops rects * int_tree_set (apply_ops_k_next rects S k) r>\<^sub>t" by auto2 60 | 61 | partial_function (heap) rect_inter_impl :: 62 | "nat operation array \ int_tree \ nat \ bool Heap" where 63 | "rect_inter_impl a b k = do { 64 | n \ Array.len a; 65 | (if k \ n then return False 66 | else do { 67 | oper \ Array.nth a k; 68 | (if is_INS oper then do { 69 | overlap \ IntervalTree_Impl.search_impl (op_int oper) b; 70 | if overlap then return True 71 | else if k = n - 1 then return False 72 | else do { 73 | b' \ rect_inter_next a b k; 74 | rect_inter_impl a b' (k + 1)}} 75 | else 76 | if k = n - 1 then return False 77 | else do { 78 | b' \ rect_inter_next a b k; 79 | rect_inter_impl a b' (k + 1)})})}" 80 | 81 | lemma rect_inter_to_fun_ind [hoare_triple]: 82 | "is_rect_list rects \ k < length (all_ops rects) \ 83 | \<^sub>a all_ops rects * int_tree_set S b> 84 | rect_inter_impl a b k 85 | <\r. a \\<^sub>a all_ops rects * \(r \ rect_inter rects S k)>\<^sub>t" 86 | @proof 87 | @let "d = length (all_ops rects) - k" 88 | @strong_induct d arbitrary k S b 89 | @case "k \ length (all_ops rects)" 90 | @unfold "rect_inter rects S k" 91 | @case "is_INS (all_ops rects ! k)" @with 92 | @case "has_overlap S (op_int (all_ops rects ! k))" 93 | @case "k = length (all_ops rects) - 1" 94 | @apply_induct_hyp "length (all_ops rects) - (k + 1)" "k + 1" 95 | @have "length (all_ops rects) - (k + 1) < d" 96 | @end 97 | @case "k = length (all_ops rects) - 1" 98 | @apply_induct_hyp "length (all_ops rects) - (k + 1)" "k + 1" 99 | @have "length (all_ops rects) - (k + 1) < d" 100 | @qed 101 | 102 | definition rect_inter_all :: "nat rectangle list \ bool Heap" where 103 | "rect_inter_all rects = 104 | (if rects = [] then return False 105 | else do { 106 | a \ rect_inter_init rects; 107 | b \ int_tree_empty; 108 | rect_inter_impl a b 0 })" 109 | 110 | text \Correctness of rectangle intersection algorithm.\ 111 | theorem rect_inter_all_correct: 112 | "is_rect_list rects \ 113 | 114 | rect_inter_all rects 115 | <\r. \(r = has_rect_overlap rects)>\<^sub>t" by auto2 116 | 117 | end 118 | -------------------------------------------------------------------------------- /HOL/Program_Verification/Imperative/SepLogic_Base.thy: -------------------------------------------------------------------------------- 1 | (* 2 | File: SepLogic_Base.thy 3 | Author: Bohua Zhan 4 | *) 5 | 6 | theory SepLogic_Base 7 | imports "Auto2_HOL.Auto2_Main" 8 | begin 9 | 10 | text \ 11 | General auto2 setup for separation logic. The automation defined 12 | here can be instantiated for different variants of separation logic. 13 | \ 14 | 15 | ML_file "sep_util_base.ML" 16 | ML_file "assn_matcher.ML" 17 | ML_file "sep_steps.ML" 18 | 19 | end 20 | -------------------------------------------------------------------------------- /HOL/Program_Verification/Imperative/Sep_Examples.thy: -------------------------------------------------------------------------------- 1 | (* 2 | File: Sep_Examples.thy 3 | Author: Bohua Zhan 4 | 5 | Overall directory of examples in Imperative. 6 | *) 7 | 8 | theory Sep_Examples 9 | 10 | imports 11 | 12 | GCD_Impl \ \Tutorial\ 13 | 14 | \ \Inductive data structures\ 15 | 16 | LinkedList \ \Linked lists\ 17 | 18 | BST_Impl \ \Binary search tree\ 19 | 20 | RBTree_Impl \ \Red-black tree\ 21 | 22 | \ \Array algorithms\ 23 | 24 | Arrays_Impl \ \Standard procedure on arrays\ 25 | 26 | DynamicArray \ \Dynamic array\ 27 | 28 | Quicksort_Impl \ \Quicksort\ 29 | 30 | Indexed_PQueue_Impl \ \Indexed priority queue\ 31 | 32 | Union_Find_Impl \ \Union-find\ 33 | 34 | \ \Applications\ 35 | 36 | Connectivity_Impl \ \Connectivity on graphs\ 37 | 38 | Dijkstra_Impl \ \Dijkstra's algorithm\ 39 | 40 | Rect_Intersect_Impl \ \Rectangular intersection\ 41 | 42 | begin 43 | 44 | end 45 | -------------------------------------------------------------------------------- /HOL/Program_Verification/Imperative/Union_Find_Impl.thy: -------------------------------------------------------------------------------- 1 | (* 2 | File: Union_Find_Impl.thy 3 | Author: Bohua Zhan 4 | *) 5 | 6 | section \Implementation of union find\ 7 | 8 | theory Union_Find_Impl 9 | imports SepAuto "../Functional/Union_Find" 10 | begin 11 | 12 | text \ 13 | Development follows theory Union\_Find in 14 | \cite{Separation_Logic_Imperative_HOL-AFP} by Lammich and Meis. 15 | \ 16 | 17 | type_synonym uf = "nat array \ nat array" 18 | 19 | definition is_uf :: "nat \ (nat\nat) set \ uf \ assn" where [rewrite_ent]: 20 | "is_uf n R u = (\\<^sub>Al szl. snd u \\<^sub>a l * fst u \\<^sub>a szl * 21 | \(ufa_invar l) * \(ufa_\ l = R) * \(length l = n) * \(length szl = n))" 22 | 23 | definition uf_init :: "nat \ uf Heap" where 24 | "uf_init n = do { 25 | l \ Array.of_list [0.. Array.new n (1::nat); 27 | return (szl, l) 28 | }" 29 | 30 | text \Correctness of uf\_init.\ 31 | theorem uf_init_rule [hoare_triple]: 32 | " uf_init n " by auto2 33 | 34 | partial_function (heap) uf_rep_of :: "nat array \ nat \ nat Heap" where 35 | "uf_rep_of p i = do { 36 | n \ Array.nth p i; 37 | if n = i then return i else uf_rep_of p n 38 | }" 39 | 40 | lemma uf_rep_of_rule [hoare_triple]: 41 | "ufa_invar l \ i < length l \ 42 |

\<^sub>a l> 43 | uf_rep_of p i 44 | <\r. p \\<^sub>a l * \(r = rep_of l i)>" 45 | @proof @prop_induct "ufa_invar l \ i < length l" @qed 46 | 47 | partial_function (heap) uf_compress :: "nat \ nat \ nat array \ unit Heap" where 48 | "uf_compress i ci p = ( 49 | if i = ci then return () 50 | else do { 51 | ni \ Array.nth p i; 52 | uf_compress ni ci p; 53 | Array.upd i ci p; 54 | return () 55 | })" 56 | 57 | lemma uf_compress_rule [hoare_triple]: 58 | "ufa_invar l \ i < length l \ 59 |

\<^sub>a l> 60 | uf_compress i (rep_of l i) p 61 | <\_. \\<^sub>Al'. p \\<^sub>a l' * \(ufa_invar l' \ length l' = length l \ 62 | (\i" 63 | @proof @prop_induct "ufa_invar l \ i < length l" @qed 64 | 65 | definition uf_rep_of_c :: "nat array \ nat \ nat Heap" where 66 | "uf_rep_of_c p i = do { 67 | ci \ uf_rep_of p i; 68 | uf_compress i ci p; 69 | return ci 70 | }" 71 | 72 | lemma uf_rep_of_c_rule [hoare_triple]: 73 | "ufa_invar l \ i < length l \ 74 |

\<^sub>a l> 75 | uf_rep_of_c p i 76 | <\r. \\<^sub>Al'. p \\<^sub>a l' * \(r = rep_of l i \ ufa_invar l' \ length l' = length l \ 77 | (\i" 78 | by auto2 79 | 80 | definition uf_cmp :: "uf \ nat \ nat \ bool Heap" where 81 | "uf_cmp u i j = do { 82 | n \ Array.len (snd u); 83 | if (i\n \ j\n) then return False 84 | else do { 85 | ci \ uf_rep_of_c (snd u) i; 86 | cj \ uf_rep_of_c (snd u) j; 87 | return (ci = cj) 88 | } 89 | }" 90 | 91 | text \Correctness of compare.\ 92 | theorem uf_cmp_rule [hoare_triple]: 93 | " 94 | uf_cmp u i j 95 | <\r. is_uf n R u * \(r \ (i,j)\R)>" by auto2 96 | 97 | definition uf_union :: "uf \ nat \ nat \ uf Heap" where 98 | "uf_union u i j = do { 99 | ci \ uf_rep_of (snd u) i; 100 | cj \ uf_rep_of (snd u) j; 101 | if (ci = cj) then return u 102 | else do { 103 | si \ Array.nth (fst u) ci; 104 | sj \ Array.nth (fst u) cj; 105 | if si < sj then do { 106 | Array.upd ci cj (snd u); 107 | Array.upd cj (si+sj) (fst u); 108 | return u 109 | } else do { 110 | Array.upd cj ci (snd u); 111 | Array.upd ci (si+sj) (fst u); 112 | return u 113 | } 114 | } 115 | }" 116 | 117 | text \Correctness of union.\ 118 | theorem uf_union_rule [hoare_triple]: 119 | "i < n \ j < n \ 120 | 121 | uf_union u i j 122 | " by auto2 123 | 124 | setup \del_prfstep_thm @{thm is_uf_def}\ 125 | 126 | end 127 | -------------------------------------------------------------------------------- /HOL/Program_Verification/Imperative/list_matcher_test.ML: -------------------------------------------------------------------------------- 1 | (* 2 | File: list_matcher_test.ML 3 | Author: Bohua Zhan 4 | 5 | Unit test for matching of assertions on linked lists. 6 | *) 7 | 8 | local 9 | 10 | open SepUtil 11 | 12 | val ctxt = @{context} 13 | 14 | fun eq_info_list (l1, l2) = 15 | length l1 = length l2 andalso 16 | eq_set (eq_pair (op =) (op aconv)) (l1, l2) 17 | 18 | fun print_term_info ctxt (id, t) = 19 | "(" ^ (BoxID.string_of_box_id id) ^ ", " ^ (Syntax.string_of_term ctxt t) ^ ")" 20 | 21 | fun print_term_infos ctxt lst = 22 | commas (map (print_term_info ctxt) lst) 23 | 24 | fun add_rewrite id (str1, str2) ctxt = 25 | let 26 | val (t1, t2) = (Syntax.read_term ctxt str1, Syntax.read_term ctxt str2) 27 | val thy = Proof_Context.theory_of ctxt 28 | val th = assume_eq thy (t1, t2) 29 | in 30 | ctxt |> RewriteTable.add_rewrite (id, th) 31 | end 32 | 33 | val ts = [@{term "[p::nat node ref option, n1, s1, s2]"}, 34 | @{term "[pp::nat node ref, pp']"}, 35 | @{term "[x::nat]"}, 36 | @{term "[xs::nat list, ys, zs]"}] 37 | 38 | val ctxt' = ctxt |> fold Proof_Context.augment ts 39 | |> RewriteTable.add_term ([], Thm.cterm_of ctxt (Free ("P", assnT))) |> snd 40 | |> add_rewrite [] ("n1", "None::nat node ref option") |> snd 41 | |> add_rewrite [] ("s1", "Some pp") |> snd 42 | |> add_rewrite [] ("s2", "Some pp'") |> snd 43 | |> add_rewrite [] ("zs", "x # xs") |> snd 44 | in 45 | 46 | fun test test_fun str (pat_str, t_str, info_str) = 47 | let 48 | val pat = Proof_Context.read_term_pattern ctxt' pat_str 49 | val t = Syntax.read_term ctxt' t_str 50 | val ct = Thm.cterm_of ctxt t 51 | val info = map (apsnd (Syntax.read_term ctxt')) info_str 52 | val info' = (test_fun ctxt' (pat, ct) ([], fo_init)) |> map (apsnd prop_of') 53 | val infol = info' |> map snd |> map dest_arg1 54 | val infor = info' |> map (fn ((id, _), t) => (id, dest_arg t)) 55 | in 56 | if forall (fn t' => t' aconv t) infol andalso 57 | eq_info_list (info, infor) then () 58 | else let 59 | val _ = tracing ("Expected: " ^ print_term_infos ctxt' info) 60 | val _ = tracing ("Actual: " ^ print_term_infos ctxt' infor) 61 | in 62 | raise Fail str 63 | end 64 | end 65 | 66 | val test_assn_term_matcher = 67 | let 68 | val test_data = [ 69 | ("os_list ?xs n1", "emp", [([], "os_list [] n1 * emp")]), 70 | ("os_list ?xs n1", "sngr_assn a 1", 71 | [([], "os_list [] n1 * sngr_assn a 1")]), 72 | ("os_list ?xs s1", "sngr_assn pp (Node x r) * os_list xs r", 73 | [([], "os_list (x # xs) s1 * emp")]), 74 | ("os_list (?x # ?xs) s1", "sngr_assn pp (Node x r) * os_list xs r", 75 | [([], "os_list (x # xs) s1 * emp")]), 76 | ("os_list ys s1", "sngr_assn pp (Node x r) * os_list xs r", []), 77 | ("os_list zs s1", "sngr_assn pp (Node x r) * os_list xs r", 78 | [([], "os_list zs s1 * emp")]), 79 | ("os_list zs s1", 80 | "sngr_assn pp (Node x r) * os_list xs r * os_list ys p", 81 | [([], "os_list zs s1 * os_list ys p")]) 82 | ] 83 | in 84 | map (test AssnMatcher.assn_match_term "test_assn_term_matcher") test_data 85 | end 86 | 87 | val test_list_prop_matcher = 88 | let 89 | val test_data = [ 90 | ("os_list ?xs s1", "sngr_assn pp (Node x r) * os_list xs r", 91 | [([], "os_list (x # xs) s1")]), 92 | ("os_list zs s1", "sngr_assn pp (Node x r) * os_list xs r", 93 | [([], "os_list zs s1")]), 94 | ("os_list ?xs p * os_list ?ys q", "os_list ys q * os_list xs p", 95 | [([], "os_list xs p * os_list ys q")]), 96 | ("os_list ?xs p", "os_list xs p * os_list ys q", []), 97 | ("sngr_assn a 1", "sngr_assn a 1", [([], "sngr_assn a 1")]), 98 | ("sngr_assn ?a 1 * os_list ?ys q * os_list ?zs r", 99 | "os_list ys q * os_list zs r * sngr_assn a 1", 100 | [([], "sngr_assn a 1 * os_list ys q * os_list zs r")]) 101 | ] 102 | in 103 | map (test AssnMatcher.assn_match_strict "test_list_prop_matcher") test_data 104 | end 105 | 106 | end 107 | -------------------------------------------------------------------------------- /HOL/Program_Verification/Imperative/sep_steps_test.ML: -------------------------------------------------------------------------------- 1 | (* 2 | File: sep_steps_test.ML 3 | Author: Bohua Zhan 4 | 5 | Unit test for sep_steps.ML. 6 | *) 7 | 8 | local 9 | open SepUtil 10 | val ctxt = @{context} 11 | val ctxt' = ctxt |> fold Proof_Context.augment [ 12 | Free ("P", assnT), Free ("Q", assnT), Free ("R", assnT), 13 | Free ("S", natT --> assnT), Free ("T", natT --> assnT)] 14 | in 15 | 16 | val test_normalize_assn = 17 | let 18 | val test_data = [ 19 | ("P * (Q * R)", "P * Q * R"), 20 | ("P * \(b)", "P * \(b)"), 21 | ("\(b) * P", "P * \(b)"), 22 | ("P * \(b) * Q", "P * Q * \(b)"), 23 | ("\(b) * (P * \(c)) * Q", "P * Q * \(b) * \(c)"), 24 | ("EXA x. S x", "EXA x. S x"), 25 | ("(EXA x. S x) * P", "EXA x. P * S x"), 26 | ("P * (EXA x. S x)", "EXA x. P * S x"), 27 | ("(EXA x. S x) * (EXA y. T y)", "EXA x y. S x * T y"), 28 | ("EXA x. S x * \(B x) * T x", "EXA x. S x * T x * \(B x)"), 29 | ("P * true * true", "P * true"), 30 | ("true * P * true", "P * true"), 31 | ("true * P * true * \(b)", "P * true * \(b)"), 32 | ("(EXA x. S x) * P * Q", "EXA x. P * Q * S x"), 33 | ("\(b1 & b2)", "\b1 * \b2") 34 | ] 35 | in 36 | map (Util.test_conv ctxt' (SepUtil.normalize_assn_cv ctxt') 37 | "normalize_assn") 38 | test_data 39 | end 40 | 41 | val test_contract_hoare = 42 | let 43 | val test_data = [ 44 | ("

(b)> c ", "

(b)> c "), 45 | ("b -->

c ", "

(b)> c "), 46 | ("b1 --> b2 -->

c ", "

(b2) * \(b1)> c "), 47 | ("b1 -->

(b2)> c ", "

(b2) * \(b1)> c "), 48 | (" c ", "

c ") 49 | ] 50 | in 51 | map (Util.test_conv ctxt' (SepLogic.contract_hoare_cv ctxt') 52 | "contract_hoare") 53 | test_data 54 | end 55 | 56 | val test_normalize_hoare_goal = 57 | let 58 | val test_data = [ 59 | ("~

c ", "~

c "), 60 | ("~<\(b)> c ", "~ c & b"), 61 | ("~

(b)> c ", "~

c & b"), 62 | ("~<\(b1) * \(b2)> c ", "(~ c & b1) & b2"), 63 | ("~

c ", "~

c "), 64 | ("EX x. ~ c ", "EX x. ~ c "), 65 | ("EX x. ~<\(b x)> c ", "EX x. ~ c & b x") 66 | ] 67 | in 68 | map (Util.test_conv ctxt' (SepLogic.normalize_hoare_goal_cv ctxt') 69 | "normalize_hoare_goal") 70 | test_data 71 | end 72 | 73 | val test_normalize_entail_goal = 74 | let 75 | val test_data = [ 76 | ("~(entails P Q)", "~(entails P Q)"), 77 | ("~(entails (\b) Q)", "~(entails emp Q) & b"), 78 | ("~(entails (\b * P) Q)", "~(entails P Q) & b"), 79 | ("~(entails (EXA x. S x) Q)", "EX x. ~(entails (S x) Q)") 80 | ] 81 | in 82 | map (Util.test_conv ctxt' (SepLogic.normalize_entail_goal_cv ctxt') 83 | "normalize_entail_goal") 84 | test_data 85 | end 86 | 87 | end 88 | -------------------------------------------------------------------------------- /HOL/Program_Verification/Imperative/sep_util.ML: -------------------------------------------------------------------------------- 1 | (* 2 | File: sep_util.ML 3 | Author: Bohua Zhan 4 | 5 | Utility functions for separation logic. Implements the interface 6 | defined in sep_util_base.ML. 7 | *) 8 | 9 | structure SepUtil : SEP_UTIL = 10 | struct 11 | 12 | val assnT = @{typ assn} 13 | val emp = @{term emp} 14 | val assn_true = @{term true} 15 | val assn_ac_info = Nat_Util.times_ac_on_typ @{theory} assnT 16 | 17 | fun is_true_assn t = 18 | case t of 19 | Const (@{const_name top_assn}, _) => true 20 | | _ => false 21 | 22 | val entail_t = @{term entails} 23 | 24 | fun is_entail t = 25 | case t of 26 | Const (@{const_name entails}, _) $ _ $ _ => true 27 | | _ => false 28 | 29 | (* Deconstruct A ==>_A B into (A, B). *) 30 | fun dest_entail t = 31 | case t of 32 | Const (@{const_name entails}, _) $ A $ B => (A, B) 33 | | _ => raise Fail "dest_entail: unexpected t." 34 | 35 | fun cdest_entail ct = 36 | case Thm.term_of ct of 37 | Const (@{const_name entails}, _) $ _ $ _ => 38 | (Thm.dest_arg1 ct, Thm.dest_arg ct) 39 | | _ => raise Fail "dest_entail: unexpected t." 40 | 41 | fun is_ex_assn t = 42 | case t of 43 | Const (@{const_name ex_assn}, _) $ _ => true 44 | | _ => false 45 | 46 | (* Whether t is of the form \(b). *) 47 | fun is_pure_assn t = 48 | case t of 49 | Const (@{const_name pure_assn}, _) $ _ => true 50 | | _ => false 51 | 52 | (* Given t of form t1 * ... * tn, check whether any of them is of the 53 | form \(b). 54 | *) 55 | fun has_pure_assn t = 56 | exists is_pure_assn (ACUtil.dest_ac assn_ac_info t) 57 | 58 | (* Given t of form t1 * ... * tn, remove those ti that are pure 59 | assertions and return the product of the remaining terms. 60 | *) 61 | fun strip_pure_assn t = 62 | if UtilArith.is_times t andalso is_pure_assn (dest_arg t) then 63 | strip_pure_assn (dest_arg1 t) 64 | else if is_pure_assn t then emp 65 | else t 66 | 67 | val hoare_triple_pat = @{term_pat " ?c "} 68 | val heap_eq_pat = @{term_pat "(?c1::?'a Heap) = ?c2"} 69 | 70 | fun is_hoare_triple t = 71 | case t of 72 | Const (@{const_name hoare_triple}, _) $ _ $ _ $ _ => true 73 | | _ => false 74 | 75 | fun dest_hoare_triple t = 76 | case t of 77 | Const (@{const_name hoare_triple}, _) $ P $ c $ Q => (P, c, Q) 78 | | _ => raise Fail "dest_hoare_triple" 79 | 80 | fun is_bind_cmd c = 81 | case c of 82 | Const (@{const_name bind}, _) $ _ $ _ => true 83 | | _ => false 84 | 85 | (* Convert A to emp * A *) 86 | val mult_emp_left = rewr_obj_eq (obj_sym @{thm mult_1}) 87 | 88 | (* Convert A to A * emp *) 89 | val mult_emp_right = rewr_obj_eq (obj_sym @{thm mult_1_right}) 90 | 91 | (* Convert A * emp to A *) 92 | val reduce_emp_right = rewr_obj_eq @{thm mult_1_right} 93 | 94 | (* Given A of type assnT, return the theorem A ==> A. *) 95 | fun entail_triv_th ctxt A = 96 | let 97 | val thy = Proof_Context.theory_of ctxt 98 | val inst = Pattern.first_order_match thy (Var (("A", 0), assnT), A) fo_init 99 | in 100 | Util.subst_thm ctxt inst @{thm entails_triv} 101 | end 102 | 103 | (* Given A of type assnT, return the theorem A ==> true. *) 104 | fun entail_true_th ctxt A = 105 | let 106 | val thy = Proof_Context.theory_of ctxt 107 | val inst = Pattern.first_order_match thy (Var (("A", 0), assnT), A) fo_init 108 | in 109 | Util.subst_thm ctxt inst @{thm entails_true} 110 | end 111 | 112 | (* Given theorem A ==> B and a conversion cv, apply cv to B *) 113 | val apply_to_entail_r = apply_to_thm' o Conv.arg_conv 114 | 115 | val pre_pure_rule_th = @{thm pre_pure_rule} 116 | val pre_pure_rule_th' = @{thm pre_pure_rule'} 117 | val pre_ex_rule_th = @{thm pre_ex_rule} 118 | val entails_pure_th = @{thm entails_pure} 119 | val entails_pure_th' = @{thm entails_pure'} 120 | val entails_ex_th = @{thm entails_ex} 121 | val entails_frame_th' = @{thm entails_frame'} 122 | val entails_frame_th'' = @{thm entails_frame''} 123 | val pure_conj_th = @{thm pure_conj} 124 | val entails_ex_post_th = @{thm entails_ex_post} 125 | val entails_pure_post_th = @{thm entails_pure_post} 126 | val pre_rule_th' = @{thm pre_rule'} 127 | val pre_rule_th'' = @{thm pre_rule''} 128 | val bind_rule_th' = @{thm bind_rule'} 129 | val post_rule_th' = @{thm post_rule'} 130 | val entails_equiv_forward_th = @{thm entails_equiv_forward} 131 | val entails_equiv_backward_th = @{thm entails_equiv_backward} 132 | val norm_pre_pure_iff_th = @{thm norm_pre_pure_iff} 133 | val norm_pre_pure_iff2_th = @{thm norm_pre_pure_iff2} 134 | val entails_trans2_th = @{thm entails_trans2} 135 | 136 | (* Extra functions *) 137 | 138 | fun is_case_prod t = 139 | case t of 140 | Const (@{const_name case_prod}, _) $ _ $ _ => true 141 | | _ => false 142 | 143 | fun sort_by t = 144 | case t of 145 | Const (@{const_name pure_assn}, _) $ _ => 2 146 | | Const (@{const_name top_assn}, _) => 1 147 | | _ => 0 148 | 149 | fun pure_ord (t, s) = 150 | if sort_by t = 0 andalso sort_by s = 0 then 151 | Term_Ord.term_ord (t, s) = LESS 152 | else 153 | sort_by t < sort_by s 154 | 155 | fun normalize_times_cv ctxt ct = 156 | let 157 | val (A, B) = Util.dest_binop_args (Thm.term_of ct) 158 | in 159 | if is_ex_assn A then 160 | Conv.every_conv [rewr_obj_eq (obj_sym @{thm ex_distrib_star}), 161 | Conv.binder_conv (normalize_times_cv o snd) ctxt] ct 162 | else if is_ex_assn B then 163 | Conv.every_conv [ACUtil.comm_cv assn_ac_info, 164 | normalize_times_cv ctxt] ct 165 | else 166 | Conv.every_conv [ 167 | ACUtil.normalize_au assn_ac_info, 168 | ACUtil.normalize_comm_gen assn_ac_info pure_ord, 169 | ACUtil.norm_combine assn_ac_info is_true_assn 170 | (rewr_obj_eq @{thm top_assn_reduce})] ct 171 | end 172 | 173 | (* Normalization function for assertions. This function pulls all EX_A 174 | to the front, then apply AC-rules to the inside, putting all pure 175 | assertions on the right. 176 | *) 177 | fun normalize_assn_cv ctxt ct = 178 | let 179 | val t = Thm.term_of ct 180 | in 181 | if is_ex_assn t then 182 | Conv.binder_conv (normalize_assn_cv o snd) ctxt ct 183 | else if UtilArith.is_times t then 184 | Conv.every_conv [Conv.binop_conv (normalize_assn_cv ctxt), 185 | normalize_times_cv ctxt] ct 186 | else if is_pure_assn t andalso is_conj (dest_arg t) then 187 | Conv.every_conv [rewr_obj_eq @{thm pure_conj}, 188 | normalize_assn_cv ctxt] ct 189 | else if is_case_prod t then 190 | Conv.every_conv [rewr_obj_eq @{thm case_prod_beta}, 191 | normalize_assn_cv ctxt] ct 192 | else 193 | Conv.all_conv ct 194 | end 195 | 196 | (* Rewrite terms for an assertion *) 197 | fun assn_rewr_terms P = 198 | P |> ACUtil.dest_ac assn_ac_info 199 | |> filter_out is_pure_assn 200 | |> maps (snd o Term.strip_comb) 201 | |> distinct (op aconv) 202 | 203 | end (* structure SepUtil *) 204 | -------------------------------------------------------------------------------- /HOL/Program_Verification/Imperative/sep_util_base.ML: -------------------------------------------------------------------------------- 1 | (* 2 | File: sep_util_base.ML 3 | Author: Bohua Zhan 4 | 5 | Declares the interface for setting up auto2 for separation logic. 6 | *) 7 | 8 | signature SEP_UTIL = 9 | sig 10 | val assnT: typ 11 | val emp: term 12 | val assn_true: term 13 | val assn_ac_info: ac_info 14 | val is_true_assn: term -> bool 15 | val entail_t: term 16 | val is_entail: term -> bool 17 | val dest_entail: term -> term * term 18 | val cdest_entail: cterm -> cterm * cterm 19 | val is_ex_assn: term -> bool 20 | val is_pure_assn: term -> bool 21 | val has_pure_assn: term -> bool 22 | val strip_pure_assn: term -> term 23 | 24 | val hoare_triple_pat: term 25 | val heap_eq_pat: term 26 | val is_hoare_triple: term -> bool 27 | val dest_hoare_triple: term -> term * term * term 28 | 29 | val is_bind_cmd: term -> bool 30 | 31 | val mult_emp_left: conv 32 | val mult_emp_right: conv 33 | val reduce_emp_right: conv 34 | val entail_triv_th: Proof.context -> term -> thm 35 | val entail_true_th: Proof.context -> term -> thm 36 | val apply_to_entail_r: conv -> thm -> thm 37 | 38 | (* Basic theorems *) 39 | val pre_pure_rule_th: thm 40 | val pre_pure_rule_th': thm 41 | val pre_ex_rule_th: thm 42 | val entails_pure_th: thm 43 | val entails_pure_th': thm 44 | val entails_ex_th: thm 45 | val entails_frame_th': thm 46 | val entails_frame_th'': thm 47 | val pure_conj_th: thm 48 | val entails_ex_post_th: thm 49 | val entails_pure_post_th: thm 50 | val pre_rule_th': thm 51 | val pre_rule_th'': thm 52 | val bind_rule_th': thm 53 | val post_rule_th': thm 54 | val entails_equiv_forward_th: thm 55 | val entails_equiv_backward_th: thm 56 | val norm_pre_pure_iff_th: thm 57 | val norm_pre_pure_iff2_th: thm 58 | val entails_trans2_th: thm 59 | 60 | (* Extra functions *) 61 | val pure_ord: term * term -> bool 62 | val normalize_times_cv: Proof.context -> conv 63 | val normalize_assn_cv: Proof.context -> conv 64 | val assn_rewr_terms: term -> term list 65 | end; 66 | -------------------------------------------------------------------------------- /HOL/acdata_test.ML: -------------------------------------------------------------------------------- 1 | (* 2 | File: acdata_test.ML 3 | Author: Bohua Zhan 4 | 5 | Unit test for acdata.ML. 6 | *) 7 | 8 | local 9 | val thy = @{theory} 10 | val ctxt = @{context} 11 | in 12 | 13 | val test_comb_ac_equiv = 14 | let 15 | fun err n = "test_comb_ac_equiv: " ^ (string_of_int n) 16 | fun test n (t1, t2) = 17 | let 18 | val ac_info = the (ACUtil.get_head_ac_info thy t1) 19 | handle Option.Option => 20 | raise Fail "test_comb_ac_equiv: ac_info" 21 | val ts1 = ACUtil.dest_ac ac_info t1 22 | val ts2 = ACUtil.dest_ac ac_info t2 23 | fun eq (t1', t2') = 24 | Thm.assume (Thm.global_cterm_of thy (Logic.mk_equals (t1', t2'))) 25 | val eqs = map eq (ts1 ~~ ts2) 26 | val th = ACUtil.comb_ac_equiv ac_info eqs 27 | in 28 | if Thm.prop_of th aconv Logic.mk_equals (t1, t2) then () 29 | else raise Fail (err n) 30 | end 31 | val _ = test 0 (@{term "(a::nat) + b + c"}, @{term "(d::nat) + e + f"}) 32 | in () end 33 | 34 | (* Generic function for testing conv with ac_info argument. *) 35 | fun test_ac_conv ctxt cv err_str (str1, str2) = 36 | let 37 | val t1 = Proof_Context.read_term_pattern ctxt str1 38 | in 39 | case ACUtil.get_head_ac_info thy t1 of 40 | NONE => 41 | let 42 | val _ = trace_t ctxt "t1:" t1 43 | in 44 | raise Fail "test_ac_conv: ac_info" 45 | end 46 | | SOME ac_info => Util.test_conv ctxt (cv ac_info) err_str (str1, str2) 47 | end 48 | 49 | val test_normalize_assoc = 50 | let 51 | val test_data = [ 52 | ("(a::nat) + (b + d) + (c + e)", "(a::nat) + b + d + c + e"), 53 | ("((a::nat) + 0) + (b + 0)", "(a::nat) + 0 + b + 0") 54 | ] 55 | in 56 | map (test_ac_conv ctxt ACUtil.normalize_assoc "test_normalize_assoc") test_data 57 | end 58 | 59 | val test_move_outmost = 60 | let 61 | val err_str = "test_move_outmost" 62 | fun test (stru, (str1, str2)) = 63 | let 64 | val (t1, u) = (Proof_Context.read_term_pattern ctxt str1, 65 | Proof_Context.read_term_pattern ctxt stru) 66 | val ac_info = 67 | the (ACUtil.get_head_ac_info thy t1) 68 | handle Option.Option => raise Fail (err_str ^ ": ac_info") 69 | in 70 | Util.test_conv ctxt (ACUtil.move_outmost ac_info u) err_str (str1, str2) 71 | end 72 | val test_data = [ 73 | ("a::nat", ("(a::nat) + b", "(b::nat) + a")), 74 | ("a::nat", ("(a::nat) + b + c", "(b::nat) + c + a")), 75 | ("a::nat", ("(b::nat) + a", "(b::nat) + a")), 76 | ("a::nat", ("(b::nat) + a + c", "(b::nat) + c + a")) 77 | ] 78 | in 79 | map test test_data 80 | end 81 | 82 | end; (* local *) 83 | -------------------------------------------------------------------------------- /HOL/arith.ML: -------------------------------------------------------------------------------- 1 | (* 2 | File: arith.ML 3 | Author: Bohua Zhan 4 | 5 | Arithmetic proof steps. 6 | *) 7 | 8 | signature NAT_UTIL = 9 | sig 10 | val lookup_numc: Type.tyenv * Envir.tenv -> int -> int 11 | val lookup_numc0: Type.tyenv * Envir.tenv -> int 12 | val lookup_numc1: Type.tyenv * Envir.tenv -> int 13 | val lookup_numc2: Type.tyenv * Envir.tenv -> int 14 | val mk_nat: int -> term 15 | val mk_int: int -> term 16 | val nat0: term 17 | val cnat0: cterm 18 | 19 | val mk_less: term * term -> term 20 | val mk_le: term * term -> term 21 | val nat_le_th: int -> int -> thm 22 | val nat_less_th: int -> int -> thm 23 | val nat_neq_th: int -> int -> thm 24 | val nat_fold_reduce: term -> term 25 | val nat_fold_conv: conv 26 | 27 | val plus_ac_on_typ: theory -> typ -> ac_info 28 | val times_ac_on_typ: theory -> typ -> ac_info 29 | val add_arith_ac_data: theory -> theory 30 | val add_arith_proofsteps: theory -> theory 31 | end; 32 | 33 | structure Nat_Util : NAT_UTIL = 34 | struct 35 | 36 | fun lookup_numc inst n = UtilArith.dest_numc (lookup_instn inst ("NUMC", n)) 37 | fun lookup_numc0 inst = lookup_numc inst 0 38 | fun lookup_numc1 inst = lookup_numc inst 1 39 | fun lookup_numc2 inst = lookup_numc inst 2 40 | fun mk_nat n = HOLogic.mk_number natT n 41 | fun mk_int n = HOLogic.mk_number intT n 42 | val nat0 = mk_nat 0 43 | val cnat0 = @{cterm "0::nat"} 44 | 45 | local 46 | val ctxt = @{context} 47 | in 48 | 49 | fun mk_less (m, n) = 50 | Const (@{const_name less}, natT --> natT --> boolT) $ m $ n 51 | 52 | fun mk_le (m, n) = 53 | Const (@{const_name less_eq}, natT --> natT --> boolT) $ m $ n 54 | 55 | (* Obtain the theorem m <= n. *) 56 | fun nat_le_th m n = 57 | if m > n then raise Fail "nat_le_th: input" 58 | else UtilArith.prove_by_arith ctxt [] (mk_le (mk_nat m, mk_nat n)) 59 | 60 | (* Obtain the theorem m < n. *) 61 | fun nat_less_th m n = 62 | if m >= n then raise Fail "nat_less_th: input" 63 | else UtilArith.prove_by_arith ctxt [] (mk_less (mk_nat m, mk_nat n)) 64 | 65 | (* Obtain the theorem m ~= n. *) 66 | fun nat_neq_th m n = 67 | if m = n orelse m < 0 orelse n < 0 then raise Fail "nat_neq_th: input" 68 | else UtilArith.prove_by_arith ctxt [] (mk_not (mk_eq (mk_nat m, mk_nat n))) 69 | 70 | fun nat_fold_reduce t = 71 | if fastype_of t <> natT then t else 72 | let 73 | val (f, (n1, n2)) = t |> Util.dest_binop |> apsnd (apply2 UtilArith.dest_numc) 74 | in 75 | case f of 76 | Const (@{const_name plus}, _) => mk_nat (n1 + n2) 77 | | Const (@{const_name minus}, _) => mk_nat (Int.max (0, n1 - n2)) 78 | | Const (@{const_name times}, _) => mk_nat (n1 * n2) 79 | | _ => t 80 | end 81 | handle Fail "dest_binop" => t | Fail "dest_numc" => t 82 | 83 | fun nat_fold_conv ct = 84 | let 85 | val t = Thm.term_of ct 86 | val t' = nat_fold_reduce t 87 | in 88 | if t aconv t' then Conv.all_conv ct 89 | else to_meta_eq (UtilArith.prove_by_arith ctxt [] (mk_eq (t, t'))) 90 | end 91 | 92 | end (* local ctxt = @{context}. *) 93 | 94 | val plus_ac = 95 | {cfhead = @{cterm plus}, unit = SOME @{cterm 0}, 96 | assoc_th = @{thm add_ac(1)}, comm_th = @{thm add_ac(2)}, 97 | unitl_th = @{thm add_0}, unitr_th = @{thm add_0_right}} 98 | 99 | val times_ac = 100 | {cfhead = @{cterm times}, unit = SOME @{cterm 1}, 101 | assoc_th = @{thm mult_ac(1)}, comm_th = @{thm mult_ac(2)}, 102 | unitl_th = @{thm mult_1}, unitr_th = @{thm mult_1_right}} 103 | 104 | val gcd_ac = 105 | {cfhead = @{cterm gcd}, unit = SOME @{cterm 0}, 106 | assoc_th = @{thm gcd.assoc}, comm_th = @{thm gcd.commute}, 107 | unitl_th = @{thm gcd_0_left_nat}, unitr_th = @{thm gcd_0_nat}} 108 | 109 | val add_arith_ac_data = 110 | fold ACUtil.add_ac_data [plus_ac, times_ac, gcd_ac] 111 | 112 | fun plus_ac_on_typ thy T = 113 | the (ACUtil.inst_ac_info thy T plus_ac) 114 | handle Option.Option => raise Fail "plus_ac_on_typ: cannot inst ac_info." 115 | 116 | fun times_ac_on_typ thy T = 117 | the (ACUtil.inst_ac_info thy T times_ac) 118 | handle Option.Option => raise Fail "times_ac_on_typ: cannot inst ac_info." 119 | 120 | val add_arith_proofsteps = 121 | fold add_prfstep_custom [ 122 | (* Resolve equality facts with constants. *) 123 | ("compare_consts", 124 | [WithFact @{term_pat "(?NUMC1::nat) = ?NUMC2"}, 125 | Filter (fn _ => fn (_, inst) => 126 | lookup_numc1 inst <> lookup_numc2 inst)], 127 | fn ((id, _), ths) => fn _ => fn ctxt => 128 | [Update.thm_update (id, UtilArith.contra_by_arith ctxt ths)]), 129 | 130 | ("compare_consts_le", 131 | [WithFact @{term_pat "(?NUMC1::nat) <= ?NUMC2"}, 132 | Filter (fn _ => fn (_, inst) => 133 | lookup_numc1 inst > lookup_numc2 inst)], 134 | fn ((id, _), ths) => fn _ => fn ctxt => 135 | [Update.thm_update (id, UtilArith.contra_by_arith ctxt ths)]), 136 | 137 | ("compare_consts_less", 138 | [WithFact @{term_pat "(?NUMC1::nat) < ?NUMC2"}, 139 | Filter (fn _ => fn (_, inst) => 140 | lookup_numc1 inst >= lookup_numc2 inst)], 141 | fn ((id, _), ths) => fn _ => fn ctxt => 142 | [Update.thm_update (id, UtilArith.contra_by_arith ctxt ths)]) 143 | 144 | ] #> fold add_prfstep_conv [ 145 | ("eval_plus_consts", 146 | [WithTerm @{term_pat "(?NUMC1::nat) + ?NUMC2"}, 147 | Filter (fn _ => fn (_, inst) => 148 | lookup_numc1 inst > 0 andalso lookup_numc2 inst > 0)], 149 | nat_fold_conv), 150 | 151 | ("eval_mult_consts", 152 | [WithTerm @{term_pat "(?NUMC1::nat) * ?NUMC2"}, 153 | Filter (fn _ => fn (_, inst) => 154 | lookup_numc1 inst <> 1 andalso lookup_numc2 inst <> 1)], 155 | nat_fold_conv), 156 | 157 | ("eval_minus_consts", 158 | [WithTerm @{term_pat "(?NUMC1::nat) - ?NUMC2"}, 159 | Filter (fn _ => fn (_, inst) => lookup_numc2 inst >= 1)], 160 | nat_fold_conv)] 161 | 162 | end (* structure Nat_Util. *) 163 | 164 | val mk_nat = Nat_Util.mk_nat 165 | val mk_int = Nat_Util.mk_int 166 | val plus_ac_on_typ = Nat_Util.plus_ac_on_typ 167 | val times_ac_on_typ = Nat_Util.times_ac_on_typ 168 | val _ = Theory.setup Nat_Util.add_arith_ac_data 169 | val _ = Theory.setup Nat_Util.add_arith_proofsteps 170 | -------------------------------------------------------------------------------- /HOL/auto2_hol.ML: -------------------------------------------------------------------------------- 1 | (* 2 | File: auto2_hol.ML 3 | Author: Bohua Zhan 4 | 5 | Setup of auto2 for HOL. 6 | *) 7 | 8 | structure UtilBase : UTIL_BASE = 9 | struct 10 | 11 | (* Types *) 12 | 13 | val boolT = @{typ bool} 14 | val mk_setT = HOLogic.mk_setT 15 | 16 | (* Equality *) 17 | 18 | fun dest_eq t = 19 | case t of 20 | Const (@{const_name HOL.eq}, _) $ lhs $ rhs => (lhs, rhs) 21 | | _ => raise Fail "dest_eq" 22 | 23 | fun cdest_eq ct = 24 | case Thm.term_of ct of 25 | Const (@{const_name HOL.eq}, _) $ _ $ _ => (Thm.dest_arg1 ct, Thm.dest_arg ct) 26 | | _ => raise Fail "dest_eq" 27 | 28 | fun mk_eq (t, u) = 29 | let 30 | val T = fastype_of t 31 | in 32 | Const (@{const_name HOL.eq}, T --> T --> boolT) $ t $ u 33 | end 34 | 35 | fun is_eq_term t = 36 | let 37 | val _ = assert (fastype_of t = boolT) "is_eq_term: wrong type" 38 | in 39 | case t of Const (@{const_name HOL.eq}, _) $ _ $ _ => true 40 | | _ => false 41 | end 42 | 43 | (* Terms *) 44 | 45 | val bTrue = @{term True} 46 | val bFalse = @{term False} 47 | val Trueprop_name = @{const_name HOL.Trueprop} 48 | val Not_name = @{const_name HOL.Not} 49 | val Conj_name = @{const_name HOL.conj} 50 | val Disj_name = @{const_name HOL.disj} 51 | val Imp_name = @{const_name HOL.implies} 52 | val All_name = @{const_name HOL.All} 53 | val Ex_name = @{const_name HOL.Ex} 54 | 55 | (* If expressions are treated differently. In a term "if a then b else 56 | c", only terms in "a" are considered in the proof state. 57 | *) 58 | fun is_if t = 59 | case t of 60 | Const (@{const_name If}, _) $ _ $ _ $ _ => true 61 | | _ => false 62 | 63 | val cTrueprop = @{cterm Trueprop} 64 | val cNot = @{cterm Not} 65 | val cConj = @{cterm conj} 66 | val cDisj = @{cterm disj} 67 | 68 | (* Theorems for equality *) 69 | val to_meta_eq_cv = Conv.rewr_conv @{thm to_meta_eq} 70 | val to_obj_eq_cv = Conv.rewr_conv @{thm atomize_eq} 71 | val to_obj_eq_iff = apply_to_thm (Util.concl_conv to_obj_eq_cv) 72 | val obj_sym_cv = Conv.rewr_conv @{thm obj_sym} 73 | 74 | (* Theorems *) 75 | val true_th = @{thm TrueI} 76 | val iffD_th = @{thm iffD} 77 | val nn_create_th = @{thm nn_create} 78 | val nn_cancel_th = @{thm HOL.nnf_simps(6)} 79 | val to_contra_form_th = @{thm to_contra_form} 80 | val to_contra_form_th' = @{thm to_contra_form'} 81 | val atomize_imp_th = @{thm atomize_imp} 82 | val atomize_all_th = @{thm atomize_all} 83 | val conjunct1_th = @{thm conjunct1} 84 | val conjunct2_th = @{thm conjunct2} 85 | val conjI_th = @{thm conjI} 86 | val or_intro1_th = @{thm or_intro1} 87 | val or_intro2_th = @{thm or_intro2} 88 | val iffD1_th = @{thm iffD1} 89 | val iffD2_th = @{thm iffD2} 90 | val inv_back_th = @{thm inv_backward} 91 | val sym_th = @{thm sym} 92 | val exE_th' = @{thm exE'} 93 | val eq_True_th = @{thm HOL.eqTrueI} 94 | val eq_True_inv_th = @{thm HOL.eqTrueE} 95 | val disj_True1_th = @{thm HOL.simp_thms(30)} 96 | val disj_True2_th = @{thm HOL.simp_thms(29)} 97 | val ex_vardef_th = @{thm HOL.simp_thms(37)} 98 | val imp_conv_disj_th = @{thm imp_conv_disj} 99 | val de_Morgan_conj_th = @{thm de_Morgan_conj} 100 | val de_Morgan_disj_th = @{thm de_Morgan_disj} 101 | val not_ex_th = @{thm HOL.not_ex} 102 | val not_all_th = @{thm HOL.not_all} 103 | val not_imp_th = @{thm HOL.not_imp} 104 | val or_cancel1_th = @{thm or_cancel1} 105 | val or_cancel2_th = @{thm or_cancel2} 106 | val swap_all_disj_th = @{thm swap_all_disj} 107 | val swap_ex_conj_th = @{thm swap_ex_conj} 108 | val all_trivial_th = @{thm HOL.simp_thms(35)} 109 | val case_split_th = @{thm HOL.case_split} 110 | 111 | val atomize_conjL_th = @{thm HOL_Base.atomize_conjL} 112 | val backward_conv_th = @{thm backward_conv} 113 | val backward1_conv_th = @{thm backward1_conv} 114 | val backward2_conv_th = @{thm backward2_conv} 115 | val resolve_conv_th = @{thm resolve_conv} 116 | val contra_triv_th = @{thm contra_triv} 117 | 118 | val conj_assoc_th = @{thm conj_assoc} 119 | val conj_commute_th = @{thm conj_commute} 120 | val disj_assoc_th = @{thm disj_assoc} 121 | val disj_commute_th = @{thm disj_commute} 122 | 123 | val Mem_name = "Set.member" 124 | val Ball_name = "Set.Ball" 125 | val Bex_name = "Set.Bex" 126 | val Bex_def_th = @{thm Bex_def'} 127 | val Ball_def_th = @{thm Ball_def'} 128 | 129 | end (* structure Base *) 130 | 131 | structure Basic_UtilBase: BASIC_UTIL_BASE = UtilBase 132 | open Basic_UtilBase 133 | -------------------------------------------------------------------------------- /HOL/extra_hol.ML: -------------------------------------------------------------------------------- 1 | (* 2 | File: extra_hol.ML 3 | Author: Bohua Zhan 4 | 5 | Extra setup for HOL. 6 | *) 7 | 8 | signature EXTRA_HOL = 9 | sig 10 | val add_forward_arg1_prfstep_cond: 11 | thm -> pre_prfstep_descriptor list -> theory -> theory 12 | val add_forward_arg1_prfstep: thm -> theory -> theory 13 | val add_forward_arg_prfstep_cond: 14 | thm -> pre_prfstep_descriptor list -> theory -> theory 15 | val add_forward_arg_prfstep: thm -> theory -> theory 16 | val add_rewrite_arg_rule_cond: 17 | thm -> pre_prfstep_descriptor list -> theory -> theory 18 | val add_rewrite_arg_rule: thm -> theory -> theory 19 | 20 | val add_simple_datatype: string -> theory -> theory 21 | val del_simple_datatype: string -> theory -> theory 22 | end; 23 | 24 | structure Extra_HOL : EXTRA_HOL = 25 | struct 26 | 27 | fun add_forward_arg1_prfstep_cond th conds thy = 28 | let 29 | val concl = th |> concl_of' |> strip_conj |> hd 30 | in 31 | thy |> add_forward_prfstep_cond 32 | th ([K (WithTerm (dest_arg1 concl))] @ conds) 33 | end 34 | 35 | fun add_forward_arg1_prfstep th = add_forward_arg1_prfstep_cond th [] 36 | 37 | fun add_forward_arg_prfstep_cond th conds thy = 38 | let 39 | val concl = th |> concl_of' |> strip_conj |> hd 40 | in 41 | thy |> add_forward_prfstep_cond 42 | th ([K (WithTerm (dest_arg concl))] @ conds) 43 | end 44 | 45 | fun add_forward_arg_prfstep th = add_forward_arg_prfstep_cond th [] 46 | 47 | fun add_rewrite_arg_rule_cond th conds thy = 48 | let 49 | val concl = th |> concl_of' |> strip_conj |> hd 50 | val _ = assert (is_eq_term concl) "rewrite_arg" 51 | val (lhs, _) = dest_eq concl 52 | in 53 | thy |> add_forward_prfstep_cond 54 | th ([K (WithTerm (dest_arg lhs))] @ conds) 55 | end 56 | 57 | fun add_rewrite_arg_rule th = add_rewrite_arg_rule_cond th [] 58 | 59 | fun add_simple_datatype s thy = 60 | let 61 | val collapse_th = Global_Theory.get_thm thy (s ^ ".collapse") 62 | val case_th = Global_Theory.get_thm thy (s ^ ".case") 63 | val sel_th = Global_Theory.get_thms thy (s ^ ".sel") 64 | val simp_th = hd (Global_Theory.get_thms thy (s ^ ".simps")) 65 | val var = collapse_th |> prop_of' |> dest_arg 66 | val (f, args) = collapse_th |> prop_of' |> dest_arg1 |> Term.strip_comb 67 | val vars = map (fn (n, T) => Var (("x",n),T)) 68 | (tag_list 1 (map fastype_of args)) 69 | val rhs = Term.list_comb (f, vars) 70 | val neq = get_neg (mk_eq (var, rhs)) 71 | val filt = [with_filt (neq_filter neq)] 72 | in 73 | thy |> add_rewrite_rule_back_cond collapse_th filt 74 | |> add_rewrite_rule case_th 75 | |> fold add_rewrite_rule sel_th 76 | |> add_forward_prfstep (equiv_forward_th simp_th) 77 | end 78 | 79 | fun del_simple_datatype s thy = 80 | let 81 | val collapse_th = Global_Theory.get_thm thy (s ^ ".collapse") 82 | val case_th = Global_Theory.get_thm thy (s ^ ".case") 83 | val sel_th = Global_Theory.get_thms thy (s ^ ".sel") 84 | val simp_th = hd (Global_Theory.get_thms thy (s ^ ".simps")) 85 | in 86 | thy |> fold del_prfstep_thm (collapse_th :: case_th :: simp_th :: sel_th) 87 | end 88 | 89 | end (* structure Extra_HOL *) 90 | 91 | open Extra_HOL 92 | -------------------------------------------------------------------------------- /HOL/list_ac_test.ML: -------------------------------------------------------------------------------- 1 | (* 2 | File: list_ac_test.ML 3 | Author: Bohua Zhan 4 | 5 | Unit test for list_ac.ML. 6 | *) 7 | 8 | local 9 | 10 | val ts = map (fn x => Free (x, @{typ "nat list"})) ["xs"] 11 | val ctxt = fold Util.declare_free_term ts @{context} 12 | val T = @{typ nat} 13 | 14 | in 15 | 16 | fun test_norm_t err_str (str1, str2) = 17 | let 18 | val (t1, t2) = apply2 (Syntax.read_term ctxt) (str1, str2) 19 | val (ct1, ct2) = apply2 (Thm.cterm_of ctxt) (t1, t2) 20 | val ts1 = List_AC.dest_list_full ctxt T ct1 21 | val ts2 = List_AC.dest_list_full ctxt T ct2 22 | in 23 | if eq_list (op aconvc) (ts1, ts2) then () 24 | else let 25 | val _ = trace_tlist ctxt "Inputs" [t1, t2] 26 | val _ = trace_tlist ctxt "ts1" (map Thm.term_of ts1) 27 | val _ = trace_tlist ctxt "ts2" (map Thm.term_of ts2) 28 | in 29 | raise Fail err_str 30 | end 31 | end 32 | 33 | val test = 34 | let 35 | val test_data = [ 36 | ("xs @ ys", "xs @ ys"), 37 | ("a # xs", "[a] @ xs"), 38 | ("[] @ xs", "xs"), 39 | ("xs @ []", "xs"), 40 | ("xs @ ys @ zs @ []", "xs @ ys @ zs"), 41 | ("(xs @ ys @ zs) @ []", "xs @ ys @ zs") 42 | ] 43 | in 44 | map (Util.test_conv ctxt (List_AC.normalize_list T) "test") test_data @ 45 | map (test_norm_t "test_norm") test_data 46 | end 47 | 48 | end 49 | -------------------------------------------------------------------------------- /HOL/nat_sub_test.ML: -------------------------------------------------------------------------------- 1 | (* 2 | File: nat_sub_test.ML 3 | Author: Bohua Zhan 4 | 5 | Unit test for nat_sub.ML. 6 | *) 7 | 8 | local 9 | 10 | val ts = map (fn x => Free (x, natT)) ["a", "b", "c", "m", "n"] 11 | val ctxt = fold Util.declare_free_term ts @{context} 12 | 13 | in 14 | 15 | fun test_term ctxt f err_str (str1, str2) = 16 | let 17 | val (t1, t2) = (Proof_Context.read_term_pattern ctxt str1, 18 | Proof_Context.read_term_pattern ctxt str2) 19 | val t2' = f (Thm.cterm_of ctxt t1) 20 | in 21 | if t2 aconv t2' then () 22 | else let 23 | val _ = trace_t ctxt "Input:" t1 24 | val _ = trace_t ctxt "Expected:" t2 25 | val _ = trace_t ctxt "Actual:" t2' 26 | in 27 | raise Fail err_str 28 | end 29 | end 30 | 31 | val test = 32 | let 33 | val test_data = [ 34 | (* No repeated terms. *) 35 | ("a", "a"), 36 | ("a + b", "a + b"), 37 | ("a - b", "a - b"), 38 | ("a - b + c", "a + c - b"), 39 | ("a - b - c", "a - (b + c)"), 40 | ("a - b + (c - d)", "a + c - (b + d)"), 41 | ("a - b - (c - d)", "a + d - (b + c)"), 42 | ("a + b + c - d - e - f", "a + b + c - (d + e + f)"), 43 | ("a - b + c - d + e - f", "a + c + e - (b + d + f)"), 44 | 45 | (* Numerical constants (on one side only). *) 46 | ("0::nat", "0::nat"), 47 | ("2::nat", "2::nat"), 48 | ("a + 2 + 3", "a + 5"), 49 | ("a - b - 2 - 3", "a - (b + 5)"), 50 | ("2 + 3 + a", "a + 5"), 51 | ("a - 2 - b - 3", "a - (b + 5)"), 52 | ("0 + a - 0 - b", "a - b"), 53 | 54 | (* Cancellation needed. *) 55 | ("a - a", "(0::nat)"), 56 | ("a - 0", "a"), 57 | ("a + b - a", "b"), 58 | ("a - (a - a)", "a"), 59 | ("a + b - a - c", "b - c"), 60 | ("a + b - a - b", "0::nat"), 61 | ("a + b + c - a - b", "c"), 62 | ("c + (b + (b + a - b) - b)", "a + c"), 63 | 64 | (* Cancellation of constants needed. *) 65 | ("a + 5 - b - 3", "a + 2 - b"), 66 | ("a + 3 - b - 5", "a - (b + 2)"), 67 | ("a + 5 - b - 5", "a - b"), 68 | ("a - 5 - (b - 3)", "a - (b + 2)"), 69 | ("a - 3 - (b - 5)", "(a + 2) - b"), 70 | ("a + 5 - 3", "a + 2"), 71 | ("a - 5 + 3", "a - 2"), 72 | ("5 - a - 3", "2 - a"), 73 | ("3 - a - 3", "0 - a"), 74 | ("(5::nat) - 3", "2::nat"), 75 | ("(3::nat) - 3", "0::nat"), 76 | 77 | (* Monomial *) 78 | ("a * 3", "a * 3"), 79 | ("a * b + b * a", "a * b * 2"), 80 | 81 | (* Cancellation between terms *) 82 | ("a * 3 + a * 2", "a * 5"), 83 | ("a * 3 - a * 2", "a"), 84 | ("a * 3 + b - a * 2", "a + b"), 85 | ("a * 2 + b - a * 3", "b - a"), 86 | ("a * 2 + b * 3 - a * 3 - b * 2", "b - a"), 87 | ("a * 3 - a * 2 - a", "0::nat"), 88 | 89 | (* Distributivity *) 90 | ("(a + 2) * b", "b * 2 + a * b"), 91 | ("(a + 2) * 2", "a * 2 + 4"), 92 | ("(a - 2) * b", "a * b - b * 2"), 93 | ("(a - 2) * 2", "a * 2 - 4"), 94 | ("(a + 1) * (a - 1)", "a * a - 1"), 95 | ("(a + 3) * (a - 2)", "a + a * a - 6"), 96 | ("(a - 1) * (a - 1)", "a * a + 1 - a * 2") 97 | ] 98 | in 99 | map (WfTerm.test_wfconv ctxt NatSub.fheads NatSub.norm_minus "test") test_data @ 100 | map (test_term ctxt NatSub.norm_ring_term "test_t") test_data 101 | end 102 | 103 | end 104 | -------------------------------------------------------------------------------- /HOL/normalize_test.ML: -------------------------------------------------------------------------------- 1 | (* 2 | File: normalize_test.ML 3 | Author: Bohua Zhan 4 | 5 | Unit test for normalizer.ML. 6 | *) 7 | 8 | local 9 | 10 | val ts = map (fn x => Free (x, boolT)) ["A", "B", "C"] 11 | val ctxt = fold Util.declare_free_term ts @{context} 12 | 13 | in 14 | 15 | val test_normalize = 16 | let 17 | fun test (str, strs) = 18 | let 19 | val t = Syntax.read_term ctxt str 20 | val ts = map (Syntax.read_term ctxt) strs 21 | val ritem = 22 | Update.thm_to_ritem (Util.assume_thm ctxt (mk_Trueprop t)) 23 | val ritems' = Normalizer.normalize ctxt ritem 24 | val ts' = map (dest_Trueprop o Thm.prop_of o BoxItem.get_thm_raw) 25 | ritems' 26 | in 27 | if length ts = length ts' andalso 28 | eq_set (op aconv) (ts, ts') then () 29 | else let 30 | val _ = trace_t ctxt "Input:" t 31 | val _ = trace_tlist ctxt "Expected:" ts 32 | val _ = trace_tlist ctxt "Actual:" ts' 33 | in 34 | raise Fail "test_normalize" 35 | end 36 | end 37 | 38 | val test_data = [ 39 | ("A & B & C", ["A", "B", "C"]), 40 | ("~ (A | B | C)", ["~ A", "~ B", "~ C"]), 41 | ("~ ~ (~ A & (~ ~ B))", ["~ A", "B"]) 42 | ] 43 | in 44 | map test test_data 45 | end 46 | 47 | val test_use_vardefs = 48 | let 49 | fun test (s1, s2) = 50 | let 51 | val (t1, t2) = the_pair (Syntax.read_terms ctxt [s1, s2]) 52 | val t2 = if fastype_of t2 = propT then t2 else mk_Trueprop t2 53 | 54 | val th1 = t1 |> mk_Trueprop |> Thm.cterm_of ctxt |> Thm.assume 55 | |> apply_to_thm (UtilLogic.to_meta_conv ctxt) 56 | |> Util.forall_elim_sch 57 | val (_, th2) = Normalizer.meta_use_vardefs th1 58 | in 59 | if Thm.prop_of th2 aconv t2 then () 60 | else let 61 | val _ = trace_t ctxt "Input:" t1 62 | val _ = trace_t ctxt "Expected:" t2 63 | val _ = trace_t ctxt "Actual:" (Thm.prop_of th2) 64 | in 65 | raise Fail "test_use_vardefs" 66 | end 67 | end 68 | 69 | val test_data = [ 70 | ("!s. s = f x --> P s", "P (f x)"), 71 | ("!s t. s = f x --> t = g x --> P s t", "P (f x) (g x)"), 72 | ("!s t. x < y --> s = f x --> t = g y --> P s t", 73 | "x < y ==> P (f x) (g y)"), 74 | ("!s. ~s = f x | P s", "P (f x)"), 75 | ("!s t. ~s = f x | ~t = g x | P s t", "P (f x) (g x)"), 76 | ("!s t. ~x < y | ~s = f x | ~t = g y | P s t", "~x < y | P (f x) (g y)"), 77 | ("!s. P s | ~s = f x", "P (f x)"), 78 | 79 | ("!a b. (a,b) = c --> P a b", "P (fst c) (snd c)"), 80 | ("!a b. (a,b) ~= c | P a b", "P (fst c) (snd c)"), 81 | ("!a b c. (a,(b,c)) = d --> P a b c", 82 | "P (fst d) (fst (snd d)) (snd (snd d))"), 83 | ("!a b c. ((a,b),c) = d --> P a b c", 84 | "P (fst (fst d)) (snd (fst d)) (snd d)") 85 | ] 86 | in 87 | map test test_data 88 | end 89 | 90 | end (* local *) 91 | -------------------------------------------------------------------------------- /HOL/unfolding.ML: -------------------------------------------------------------------------------- 1 | (* 2 | File: unfolding.ML 3 | Author: Bohua Zhan 4 | 5 | Unfolding of functional definitions. 6 | *) 7 | 8 | signature UNFOLDING = 9 | sig 10 | val get_unfold_thms_by_name: theory -> string -> thm list 11 | val get_unfold_thms: theory -> term -> thm list 12 | val unfold: theory -> conv 13 | val unfold_cmd: string -> Proof.state -> Proof.state 14 | end; 15 | 16 | structure Unfolding : UNFOLDING = 17 | struct 18 | 19 | fun get_unfold_thms_by_name thy nm = 20 | let 21 | val simp_nm = nm ^ ".simps" 22 | val def_nm = nm ^ "_def" 23 | in 24 | Global_Theory.get_thms thy simp_nm 25 | handle ERROR _ => Global_Theory.get_thms thy def_nm 26 | handle ERROR _ => raise Fail "get_unfold_thms" 27 | end 28 | 29 | fun get_unfold_thms thy t = 30 | get_unfold_thms_by_name thy (Util.get_head_name t) 31 | 32 | (* Unfold the given term. *) 33 | fun unfold thy ct = 34 | let 35 | val ths = get_unfold_thms thy (Thm.term_of ct) 36 | in 37 | Conv.first_conv (map rewr_obj_eq ths) ct 38 | end 39 | 40 | fun unfold_cmd s state = 41 | let 42 | val {context = ctxt, ...} = Proof.goal state 43 | val thy = Proof_Context.theory_of ctxt 44 | 45 | val (_, (As, _)) = ctxt |> Auto2_State.get_subgoal 46 | |> Util.strip_meta_horn 47 | val cAs = map (Thm.cterm_of ctxt) As 48 | 49 | val t = Syntax.read_term ctxt s 50 | val eq_th = t |> Thm.cterm_of ctxt |> unfold thy 51 | |> to_obj_eq 52 | |> fold Thm.implies_intr (rev cAs) 53 | val _ = writeln ("Obtained " ^ (eq_th |> Thm.concl_of 54 | |> Syntax.string_of_term ctxt)) 55 | 56 | val after_qed = Auto2_Outer.have_after_qed ctxt eq_th 57 | in 58 | state |> Proof.map_contexts (Auto2_State.map_head_th after_qed) 59 | end 60 | 61 | val _ = 62 | Outer_Syntax.command @{command_keyword "@unfold"} "unfold a term" 63 | (Parse.term >> 64 | (fn s => 65 | Toplevel.proof (fn state => unfold_cmd s state))) 66 | 67 | end (* structure Unfolding *) 68 | -------------------------------------------------------------------------------- /HOL/util_arith.ML: -------------------------------------------------------------------------------- 1 | (* 2 | File: util_arith.ML 3 | Author: Bohua Zhan 4 | 5 | Utility functions related to arithmetic. 6 | *) 7 | 8 | signature UTIL_ARITH = 9 | sig 10 | (* Types. *) 11 | val natT: typ 12 | val intT: typ 13 | val ratT: typ 14 | val rat_zero: Rat.rat 15 | 16 | (* Terms. *) 17 | val is_numc: term -> bool 18 | val dest_numc: term -> int 19 | val dest_numc_rat: term -> Rat.rat 20 | val is_order: term -> bool 21 | val is_linorder: Proof.context -> term -> bool 22 | val is_plus: term -> bool 23 | val is_minus: term -> bool 24 | val is_times: term -> bool 25 | val is_divide: term -> bool 26 | val is_zero: term -> bool 27 | val is_one: term -> bool 28 | 29 | (* Theorems. *) 30 | val neg_ineq_cv: conv 31 | val neg_ineq_back_cv: conv 32 | 33 | (* Arith tactic. *) 34 | val prove_by_arith: Proof.context -> thm list -> term -> thm 35 | val contra_by_arith: Proof.context -> thm list -> thm 36 | end; 37 | 38 | structure UtilArith : UTIL_ARITH = 39 | struct 40 | 41 | val natT = HOLogic.natT 42 | val intT = @{typ int} 43 | val ratT = @{typ rat} 44 | val rat_zero = Rat.of_int 0 45 | 46 | (* Test if a term represents a numerical constant. In addition to use 47 | dest_number from HOLogic, test for inverse, uminus, of_rat, etc. 48 | *) 49 | fun is_numc t = 50 | case t of 51 | Const (@{const_name inverse}, _) $ t' => is_numc t' 52 | | Const (@{const_name uminus}, _) $ t' => is_numc t' 53 | | Const (@{const_name of_rat}, _) $ r => is_numc r 54 | | Const (@{const_name Fract}, _) $ n $ d => is_numc n andalso is_numc d 55 | | _ => let val _ = HOLogic.dest_number t in true end 56 | handle TERM ("dest_number", _) => false 57 | 58 | (* Deconstruct numerical constant. Discard type. *) 59 | fun dest_numc t = HOLogic.dest_number t |> snd 60 | handle TERM ("dest_number", _) => raise Fail "dest_numc" 61 | 62 | (* Rational numbers version of dest_numc. *) 63 | fun dest_numc_rat t = 64 | case t of 65 | Const (@{const_name inverse}, _) $ t' => 66 | let 67 | val r' = dest_numc_rat t' 68 | in 69 | if r' = rat_zero then rat_zero 70 | else Rat.inv r' 71 | end 72 | | Const (@{const_name uminus}, _) $ t' => Rat.neg (dest_numc_rat t') 73 | | Const (@{const_name of_rat}, _) $ r => dest_numc_rat r 74 | | Const (@{const_name Fract}, _) $ n $ d => 75 | Rat.make (dest_numc n, dest_numc d) 76 | | _ => Rat.of_int (dest_numc t) 77 | 78 | (* Whether the given term is a < b or a <= b. *) 79 | fun is_order t = 80 | let 81 | val _ = assert (fastype_of t = boolT) "is_order: wrong type" 82 | in 83 | case t of Const (@{const_name less}, _) $ _ $ _ => true 84 | | Const (@{const_name less_eq}, _) $ _ $ _ => true 85 | | _ => false 86 | end 87 | 88 | fun is_linorder ctxt t = 89 | let 90 | val T = fastype_of (dest_arg t) 91 | val thy = Proof_Context.theory_of ctxt 92 | in 93 | is_order t andalso Sign.of_sort thy (T, ["Orderings.linorder"]) 94 | end 95 | 96 | (* Check whether t is in the form a + b. *) 97 | fun is_plus t = 98 | case t of 99 | Const (@{const_name plus}, _) $ _ $ _ => true 100 | | _ => false 101 | 102 | (* Check whether t is in the form a - b. *) 103 | fun is_minus t = 104 | case t of 105 | Const (@{const_name minus}, _) $ _ $ _ => true 106 | | _ => false 107 | 108 | fun is_times t = 109 | case t of 110 | Const (@{const_name times}, _) $ _ $ _ => true 111 | | _ => false 112 | 113 | fun is_divide t = 114 | case t of 115 | Const (@{const_name divide}, _) $ _ $ _ => true 116 | | _ => false 117 | 118 | fun is_zero t = 119 | case t of 120 | Const (@{const_name zero_class.zero}, _) => true 121 | | _ => false 122 | 123 | fun is_one t = 124 | case t of 125 | Const (@{const_name one_class.one}, _) => true 126 | | _ => false 127 | 128 | (* Convert ~ x < y to y <= x, and ~ x <= y to y < x. *) 129 | val neg_ineq_cv = 130 | (Conv.try_conv o Conv.first_conv) 131 | (map rewr_obj_eq [@{thm Orderings.linorder_not_less}, 132 | @{thm Orderings.linorder_not_le}]) 133 | 134 | (* Convert x < y to ~ y <= x, and x <= y to ~ y < x. *) 135 | val neg_ineq_back_cv = 136 | (Conv.try_conv o Conv.first_conv) 137 | (map (rewr_obj_eq o obj_sym) [@{thm Orderings.linorder_not_less}, 138 | @{thm Orderings.linorder_not_le}]) 139 | 140 | val prove_by_arith = UtilLogic.prove_by_tac Arith_Data.arith_tac 141 | val contra_by_arith = UtilLogic.contra_by_tac Arith_Data.arith_tac 142 | 143 | end (* structure UtilArith *) 144 | 145 | val natT = UtilArith.natT 146 | val intT = UtilArith.intT 147 | -------------------------------------------------------------------------------- /HOL/util_test.ML: -------------------------------------------------------------------------------- 1 | (* 2 | File: util_test.ML 3 | Author: Bohua Zhan 4 | 5 | Unit test for util.ML. 6 | *) 7 | 8 | local 9 | 10 | val ctxt = @{context} 11 | 12 | in 13 | 14 | val test_normalize_meta_all_imp = 15 | let 16 | val test_data = [ 17 | ("!!x. (A ==> B x)", "A ==> (!!x. B x)") 18 | ] 19 | in 20 | map (Util.test_conv ctxt (Util.normalize_meta_all_imp ctxt) 21 | "normalize_meta_all_imp") test_data 22 | end 23 | 24 | val test_to_obj_conv = 25 | let 26 | fun err n = "test_to_obj_conv: " ^ (string_of_int n) 27 | fun assert_eq th ct txt = 28 | let val ct' = Thm.rhs_of th 29 | in if ct' aconvc ct then () else raise Fail txt end 30 | val ct1 = @{cprop "A ==> B ==> (!!(n::nat). C n) ==> D"} 31 | val ct2 = @{cprop "A --> B --> (!(n::nat). C n) --> D"} 32 | val ct3 = @{cprop "!(y::nat) (x::nat). P x y --> (!z. Q x y z)"} 33 | val _ = assert_eq (UtilLogic.to_obj_conv ctxt ct1) ct2 (err 0) 34 | val _ = assert_eq (UtilLogic.to_meta_conv ctxt ct2) 35 | @{cprop "A ==> B ==> (!(n::nat). C n) ==> D"} (err 1) 36 | val _ = assert_eq (UtilLogic.to_meta_conv ctxt ct3) 37 | @{cprop "!!(y::nat) (x::nat) z. P x y ==> Q x y z"} (err 2) 38 | val _ = assert_eq (UtilLogic.to_obj_conv_on_horn ctxt ct1) 39 | @{cprop "A ==> B ==> (!(n::nat). C n) ==> D"} (err 4) 40 | in () end 41 | 42 | val test_is_pattern = 43 | let 44 | fun test b str = 45 | let 46 | val t = Proof_Context.read_term_pattern ctxt str 47 | in 48 | if b = Util.is_pattern t then () 49 | else raise Fail "test_is_pattern" 50 | end 51 | 52 | val test_positive = ["?f", "!n. ?f n", "!m n. ?f m n", 53 | "!n. ?f n < ?f (n + 1)", 54 | "!n. ?f (n + 1) < ?f n", "!n. ?g (?f n) & ?g n"] 55 | val test_negative = ["?f ?n", "!n. ?f n n", "!n. ?f (?f n)", 56 | "!n. (?f n < ?g (n + 1)) & (?f (n + 1) < ?g n)"] 57 | in 58 | map (test true) test_positive @ map (test false) test_negative 59 | end 60 | 61 | end 62 | -------------------------------------------------------------------------------- /README: -------------------------------------------------------------------------------- 1 | AUTO2 - a best-first-search theorem prover implemented in Isabelle 2 | 3 | Please see doc.pdf for documentation. 4 | 5 | Current version of the program works with Isabelle2021-1. 6 | 7 | Papers: 8 | 9 | Efficient verification of imperative programs using auto2 (TACAS 10 | 2018): https://arxiv.org/abs/1610.06996. Code at v0.3 (0774b32). 11 | 12 | Formalization of the fundamental group in untyped set theory using 13 | auto2 (ITP 2017): https://arxiv.org/abs/1707.04757. Code at v0.2 14 | (60daebd). 15 | 16 | AUTO2, a saturation-based heuristic prover for higher-order logic (ITP 17 | 2016): http://arxiv.org/abs/1605.07577. Code at v0.1 (18b96cb). 18 | 19 | Description of the examples: 20 | 21 | - HOL/Functional: verification of functional programs. Include material 22 | on lists, trees, priority queue, Dijkstra's algorithm, and rectangle 23 | intersection. 24 | 25 | - HOL/Imperative: verification of imperative programs using separation 26 | logic. Foundation of separation logic, and several of the examples, 27 | follow "A Separation Logic Framework for Imperative HOL" in Isabelle 28 | AFP. 29 | 30 | - HOL/Primes_Ex: elementary number theory of primes, up to the proof 31 | of infinitude of primes and the unique factorization 32 | theorem. Follows theories Primes and UniqueFactorization in 33 | HOL/Number_Theory. 34 | 35 | - HOL/Hoare: development of Hoare logic. Follows chapters Imp, Equiv, 36 | Hoare, and Hoare2 in "Software Foundations". 37 | 38 | - FOL: axiomatic set theory based on Isabelle/FOL. Sources: 39 | 40 | - Basic set theory and construction of natural numbers: Isabelle/ZF. 41 | 42 | - More set theory: "Theory of Sets" by Bourbaki chapter II and part 43 | of chapter III. 44 | 45 | - Basic group theory and construction of real numbers: corresponding 46 | examples in HOL. 47 | 48 | - Arrow impossibility theorem: following Arrow_Order in 49 | AFP/ArrowImpossibilityGS. The original theory is one of seven test 50 | cases in "Sledgehammer: Judgement Day". 51 | 52 | - Point-set topology and construction of the fundamental group: 53 | "Topology" by Munkres. 54 | 55 | Copyright (C) 2015-2017 Bohua Zhan 56 | 57 | This program is free software; you can redistribute it and/or modify 58 | it under the terms of the GNU General Public License as published by 59 | the Free Software Foundation; either version 2 of the License, or (at 60 | your option) any later version. 61 | -------------------------------------------------------------------------------- /ROOT: -------------------------------------------------------------------------------- 1 | chapter AUTO2 2 | 3 | session Auto2_HOL in HOL = HOL + 4 | description \ 5 | Instantiation of Auto2 for Isabelle/HOL. 6 | \ 7 | sessions 8 | "HOL-Library" 9 | "HOL-Imperative_HOL" 10 | theories [document = false] 11 | (* Core setup *) 12 | "Auto2_Test" 13 | 14 | theories 15 | (* Simple examples *) 16 | "Pelletier" 17 | "Primes_Ex" 18 | 19 | session Auto2_Imperative_HOL in "HOL/Program_Verification" = Auto2_HOL + 20 | description \ 21 | Application of auto2 to verify functional and imperative programs. 22 | \ 23 | directories 24 | "Functional" 25 | "Imperative" 26 | theories 27 | (* Functional programs *) 28 | "Functional/BST" 29 | "Functional/Lists_Ex" 30 | "Functional/Connectivity" 31 | "Functional/Dijkstra" 32 | "Functional/Interval_Tree" 33 | "Functional/Quicksort" 34 | "Functional/Indexed_PQueue" 35 | "Functional/RBTree" 36 | "Functional/Rect_Intersect" 37 | 38 | (* Imperative programs *) 39 | "Imperative/GCD_Impl" 40 | "Imperative/LinkedList" 41 | "Imperative/BST_Impl" 42 | "Imperative/RBTree_Impl" 43 | "Imperative/Quicksort_Impl" 44 | "Imperative/Connectivity_Impl" 45 | "Imperative/Dijkstra_Impl" 46 | "Imperative/Rect_Intersect_Impl" 47 | 48 | theories [document = false] 49 | "Imperative/Sep_Examples" 50 | 51 | document_files (in "../../document") 52 | "root.tex" 53 | "root.bib" 54 | 55 | session Auto2_FOL in FOL = FOL + 56 | description \ 57 | Example in first order logic. 58 | \ 59 | theories 60 | "Pelletier" 61 | "BigProd" 62 | "Cardinal" 63 | "SetSum" 64 | "Coset" 65 | "Abs" 66 | "Divides" 67 | "Rat" 68 | "Lattice" 69 | "BigSet" 70 | "Module" 71 | "ArrowImpossibility" 72 | document_files (in "../document") 73 | "root.tex" 74 | 75 | session FOL_Topology in "FOL/Topology" = Auto2_FOL + 76 | description \ 77 | Real numbers and topology in first order logic. 78 | \ 79 | theories 80 | "Closure" 81 | "MetricSpaces" 82 | document_files (in "../../document") 83 | "root.tex" 84 | 85 | session FOL_Homotopy in "FOL/Homotopy" = FOL_Topology + 86 | description \ 87 | Homotopy theory. 88 | \ 89 | theories 90 | "FundamentalGroup" 91 | document_files (in "../../document") 92 | "root.tex" 93 | -------------------------------------------------------------------------------- /auto2_data.ML: -------------------------------------------------------------------------------- 1 | (* 2 | File: auto2_data.ML 3 | Author: Bohua Zhan 4 | 5 | Updating of all data maintained at proof time. 6 | *) 7 | 8 | signature AUTO2_DATA = 9 | sig 10 | val relevant_terms_single: box_item -> term list 11 | val add_terms: 12 | box_item list -> (box_id * cterm) list -> Proof.context -> Proof.context 13 | val get_incr_type: 14 | box_item list -> box_item list -> Proof.context -> Proof.context 15 | val get_single_type: Proof.context -> Proof.context 16 | end; 17 | 18 | structure Auto2Data : AUTO2_DATA = 19 | struct 20 | 21 | (* Procedure to add a new term. Here old_items is the list of existing 22 | items. term_infos is a list of (id, ct) pairs. 23 | *) 24 | fun add_terms old_items term_infos ctxt = 25 | let 26 | val ts = map (Thm.term_of o snd) term_infos 27 | val (edges, ctxt') = RewriteTable.add_term_list term_infos ctxt 28 | val new_ts = map (Thm.term_of o snd) 29 | (RewriteTable.get_new_terms (ctxt, ctxt')) 30 | val imm_properties = 31 | maps (PropertyData.apply_property_update_on_term ctxt' []) ts 32 | in 33 | ctxt' |> PropertyData.process_update_property imm_properties 34 | |> fold PropertyData.process_rewrite_property edges 35 | |> fold WellformData.initialize_wellform_data ts 36 | |> WellformData.complete_wellform_data_for_terms old_items new_ts 37 | end 38 | 39 | (* Helper function for the two functions below. *) 40 | fun relevant_terms_single item = 41 | let 42 | val {ty_str, tname, ...} = item 43 | in 44 | if ty_str = "EQ" then map Thm.term_of tname else [] 45 | end 46 | 47 | (* Use the given items to update the current context data, producing 48 | the incremental context. Here old_items is the list of existing 49 | items. items is the list of new items. Update the rewrite table, 50 | property table, wellform table, and the custom tables. 51 | *) 52 | fun get_incr_type old_items items ctxt = 53 | let 54 | (* List of relevant terms. *) 55 | val relevant_terms = 56 | items |> maps relevant_terms_single 57 | |> RewriteTable.get_reachable_terms true ctxt 58 | 59 | fun add_one_info item ctxt = 60 | let 61 | val {id, ty_str, prop, ...} = item 62 | in 63 | if ty_str = "EQ" then 64 | let 65 | val (edges, ctxt') = RewriteTable.add_rewrite (id, prop) ctxt 66 | in 67 | ctxt' |> fold PropertyData.process_rewrite_property edges 68 | end 69 | else if ty_str = "PROPERTY" then 70 | PropertyData.add_property (id, prop) ctxt 71 | else ctxt 72 | end 73 | 74 | val match_items = 75 | items @ 76 | filter (fn {tname, ...} => exists (Util.has_subterm relevant_terms) 77 | (map Thm.term_of tname)) old_items 78 | in 79 | ctxt |> fold add_one_info items 80 | |> WellformData.complete_wellform_data match_items 81 | end 82 | 83 | fun get_single_type ctxt = 84 | ctxt |> RewriteTable.clear_incr 85 | |> PropertyData.clear_incr 86 | |> WellformData.clear_incr 87 | 88 | end (* Auto2Data *) 89 | -------------------------------------------------------------------------------- /consts.ML: -------------------------------------------------------------------------------- 1 | (* 2 | File: consts.ML 3 | Author: Bohua Zhan 4 | 5 | Dealing with constants. 6 | *) 7 | 8 | signature CONSTS = 9 | sig 10 | val add_const_data: string * (term -> bool) -> theory -> theory 11 | val detect_const: theory -> term -> string option 12 | val detect_const_ctxt: Proof.context -> term -> string option 13 | val is_const: theory -> term -> bool 14 | val is_const_ctxt: Proof.context -> term -> bool 15 | val neq_const: theory -> term * term -> bool 16 | val neq_const_ctxt: Proof.context -> term * term -> bool 17 | end; 18 | 19 | structure Consts : CONSTS = 20 | struct 21 | 22 | (* Table of detectors for constants, each registered under a 23 | descriptive name. 24 | *) 25 | structure Data = Theory_Data 26 | ( 27 | type T = ((term -> bool) * serial) Symtab.table; 28 | val empty = Symtab.empty; 29 | val merge = Symtab.merge (eq_snd op =); 30 | ) 31 | 32 | fun add_const_data (str, f) = 33 | Data.map (Symtab.update_new (str, (f, serial ()))) 34 | 35 | fun detect_const thy t = 36 | let 37 | val data = Symtab.dest (Data.get thy) 38 | in 39 | get_first (fn (str, (f, _)) => if f t then SOME str else NONE) data 40 | end 41 | 42 | fun detect_const_ctxt ctxt t = 43 | detect_const (Proof_Context.theory_of ctxt) t 44 | 45 | fun is_const thy t = 46 | is_some (detect_const thy t) 47 | 48 | fun is_const_ctxt ctxt t = 49 | is_const (Proof_Context.theory_of ctxt) t 50 | 51 | (* Whether two constants are of the same type and not equal. If either 52 | input is not a constant, return false. 53 | *) 54 | fun neq_const thy (t1, t2) = 55 | let 56 | val ty1 = the (detect_const thy t1) 57 | val ty2 = the (detect_const thy t2) 58 | in 59 | ty1 = ty2 andalso not (t1 aconv t2) 60 | end 61 | handle Option.Option => false 62 | 63 | fun neq_const_ctxt ctxt (t1, t2) = 64 | neq_const (Proof_Context.theory_of ctxt) (t1, t2) 65 | 66 | end (* structure Consts. *) 67 | -------------------------------------------------------------------------------- /doc.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/bzhan/auto2/2e83c30b095f2ed9fa5257f79570eb354ed6e6a7/doc.pdf -------------------------------------------------------------------------------- /document/root.bib: -------------------------------------------------------------------------------- 1 | @inproceedings{zhan18a, 2 | author = {Bohua Zhan}, 3 | title = {Efficient verification of imperative programs using auto2}, 4 | booktitle = {{TACAS} 2018}, 5 | pages = "23--40", 6 | editor = "Beyer, Dirk and Huisman, Marieke", 7 | year = {2018} 8 | } 9 | 10 | @inproceedings{zhan16, 11 | author = {Bohua Zhan}, 12 | title = {AUTO2: a saturation-based heuristic prover for higher-order logic}, 13 | booktitle = {{ITP} 2016}, 14 | pages = "441--456", 15 | editor = "J. C. Blanchette and S. Merz", 16 | year = {2016} 17 | } 18 | 19 | @article{pelletier, 20 | author = {Francis Jeffry Pelletier}, 21 | title = {Seventy-Five Problems for Testing Automatic Theorem Provers}, 22 | journal = "Journal of Automated Reasoning", 23 | year = "1986", 24 | volume = "2", 25 | pages = "191--216" 26 | } 27 | 28 | @InProceedings{imphol, 29 | author="Bulwahn, Lukas 30 | and Krauss, Alexander 31 | and Haftmann, Florian 32 | and Erk{\"o}k, Levent 33 | and Matthews, John", 34 | editor="Mohamed, Otmane Ait 35 | and Mu{\~{n}}oz, C{\'e}sar 36 | and Tahar, Sofi{\`e}ne", 37 | title="Imperative Functional Programming with Isabelle/HOL", 38 | booktitle="Theorem Proving in Higher Order Logics", 39 | year="2008", 40 | publisher="Springer Berlin Heidelberg", 41 | address="Berlin, Heidelberg", 42 | pages="134--149", 43 | isbn="978-3-540-71067-7" 44 | } 45 | 46 | @article{Separation_Logic_Imperative_HOL-AFP, 47 | author = {Peter Lammich and Rene Meis}, 48 | title = {A Separation Logic Framework for Imperative HOL}, 49 | journal = {Archive of Formal Proofs}, 50 | month = nov, 51 | year = 2012, 52 | note = {\url{http://isa-afp.org/entries/Separation_Logic_Imperative_HOL.html}, 53 | Formal proof development}, 54 | ISSN = {2150-914x}, 55 | } 56 | 57 | @article{prog-prove, 58 | author = {Tobias Nipkow}, 59 | title = {Programming and Proving in Isabelle/HOL}, 60 | year = 2018, 61 | } 62 | 63 | @InProceedings{nipkow16, 64 | author="Nipkow, Tobias", 65 | editor="Blanchette, Jasmin Christian 66 | and Merz, Stephan", 67 | title="Automatic Functional Correctness Proofs for Functional Search Trees", 68 | booktitle="Interactive Theorem Proving", 69 | year="2016", 70 | publisher="Springer International Publishing", 71 | address="Cham", 72 | pages="307--322", 73 | isbn="978-3-319-43144-4" 74 | } 75 | 76 | @article{Collections-AFP, 77 | author = {Peter Lammich}, 78 | title = {Collections Framework}, 79 | journal = {Archive of Formal Proofs}, 80 | month = nov, 81 | year = 2009, 82 | note = {\url{http://isa-afp.org/entries/Collections.html}, 83 | Formal proof development}, 84 | ISSN = {2150-914x}, 85 | } 86 | 87 | @article{Dijkstra_Shortest_Path-AFP, 88 | author = {Benedikt Nordhoff and Peter Lammich}, 89 | title = {Dijkstra's Shortest Path Algorithm}, 90 | journal = {Archive of Formal Proofs}, 91 | month = jan, 92 | year = 2012, 93 | note = {\url{http://isa-afp.org/entries/Dijkstra_Shortest_Path.html}, 94 | Formal proof development}, 95 | ISSN = {2150-914x}, 96 | } 97 | 98 | @article{cormen2009introduction, 99 | title={Introduction to algorithms third edition}, 100 | author={Cormen, Thomas H and Leiserson, Charles E and Rivest, Ronald L and Stein, Clifford}, 101 | year={2009} 102 | } 103 | 104 | @article{Refine_Imperative_HOL-AFP, 105 | author = {Peter Lammich}, 106 | title = {The Imperative Refinement Framework}, 107 | journal = {Archive of Formal Proofs}, 108 | month = aug, 109 | year = 2016, 110 | note = {\url{http://isa-afp.org/entries/Refine_Imperative_HOL.html}, 111 | Formal proof development}, 112 | ISSN = {2150-914x}, 113 | } 114 | -------------------------------------------------------------------------------- /document/root.tex: -------------------------------------------------------------------------------- 1 | \documentclass[11pt,a4paper]{article} 2 | \usepackage{isabelle,isabellesym} 3 | \usepackage{amsfonts, amsmath, amssymb} 4 | 5 | % this should be the last package used 6 | \usepackage{pdfsetup} 7 | 8 | % urls in roman style, theory text in math-similar italics 9 | \urlstyle{rm} 10 | \isabellestyle{it} 11 | 12 | 13 | \begin{document} 14 | 15 | \title{Auto2 prover} 16 | \author{Bohua Zhan} 17 | \maketitle 18 | 19 | \begin{abstract} 20 | Auto2 is a saturation-based heuristic prover for higher-order logic, 21 | implemented as a tactic in Isabelle. 22 | 23 | This entry contains the instantiation of auto2 for Isabelle/HOL, 24 | along with several examples. This includes: solutions to some of the 25 | Pelletier's problems, elementary number theory of primes, functional 26 | algorithms and data structures, and verification of imperative 27 | programs using separation logic. 28 | \end{abstract} 29 | 30 | \newpage 31 | \tableofcontents 32 | \newpage 33 | \parindent 0pt\parskip 0.5ex 34 | 35 | \section{Introduction} 36 | 37 | Auto2 \cite{zhan16} is a proof automation tool implemented in 38 | Isabelle. It uses a saturation-based approach to proof search: 39 | starting with a list of initial assumptions, it iteratively adds facts 40 | that can be derived from these assumptions, with the aim of ultimately 41 | deriving a contradiction. Users can add their own proof procedures to 42 | auto2 in the form of \emph{proof steps}, in order to implement 43 | domain-specific knowledge. Auto2 can be instantiated to both 44 | Isabelle/HOL (for ordinary usage) and Isabelle/FOL (for formalization 45 | of mathematics based on set theory). 46 | 47 | This AFP entry contains the instantiation of auto2 to Isabelle/HOL, 48 | and several sample applications: 49 | 50 | \begin{itemize} 51 | \item Pelletier's problems: solutions to some of the problems in 52 | Pelletier's collection of problems for testing automatic theorem 53 | provers \cite{pelletier}. Auto2 is not intended to compete with 54 | ATPs. In our examples, we merely show how to use the prover to solve 55 | some of the problems, sometimes with hints. 56 | 57 | \item Elementary number theory: theory of prime numbers up to the 58 | infinitude of primes and unique factorization. This example follows 59 | the development in HOL/Computational\_Algebra/Primes.thy in the 60 | Isabelle distribution. 61 | 62 | \item Functional programs: we verify several functional algorithms and 63 | data structures, including: linked lists, binary search trees, 64 | red-black trees, interval trees, priority queue, quicksort, 65 | union-find, Dijkstra's algorithm, and a sweep-line algorithm for 66 | detecting rectangle intersection. 67 | 68 | \item Imperative programs: we verify imperative versions of the above 69 | algorithms and data structures, using Isabelle's Imperative HOL 70 | framework \cite{imphol}. We make use of separation logic, following 71 | the framework set up by Lammich and Reis 72 | \cite{Separation_Logic_Imperative_HOL-AFP}. The general outline of 73 | some of the examples also come from there. The program verification 74 | examples are described in \cite{zhan18a}. 75 | \end{itemize} 76 | 77 | \input{session} 78 | 79 | \bibliographystyle{abbrv} 80 | \bibliography{root} 81 | 82 | \end{document} 83 | 84 | %%% Local Variables: 85 | %%% mode: latex 86 | %%% TeX-master: t 87 | %%% End: 88 | -------------------------------------------------------------------------------- /util_base.ML: -------------------------------------------------------------------------------- 1 | (* 2 | File: util_base.ML 3 | Author: Bohua Zhan 4 | 5 | Defines the interface that an object logic has to meet to setup auto2. 6 | *) 7 | 8 | signature BASIC_UTIL_BASE = 9 | sig 10 | val boolT: typ 11 | 12 | val dest_eq: term -> term * term 13 | val cdest_eq: cterm -> cterm * cterm 14 | val mk_eq: term * term -> term 15 | val is_eq_term: term -> bool 16 | 17 | val bFalse: term 18 | val bTrue: term 19 | val true_th: thm 20 | end; 21 | 22 | signature UTIL_BASE = 23 | sig 24 | include BASIC_UTIL_BASE 25 | 26 | (* Types *) 27 | val mk_setT: typ -> typ 28 | 29 | (* Terms *) 30 | val Trueprop_name: string 31 | val Not_name: string 32 | val Conj_name: string 33 | val Disj_name: string 34 | val Imp_name: string 35 | val All_name: string 36 | val Ex_name: string 37 | val is_if: term -> bool 38 | 39 | (* Cterms *) 40 | val cTrueprop: cterm 41 | val cNot: cterm 42 | val cConj: cterm 43 | val cDisj: cterm 44 | 45 | (* Theorems for equality *) 46 | val to_meta_eq_cv: conv 47 | val to_obj_eq_cv: conv 48 | val to_obj_eq_iff: thm -> thm 49 | val obj_sym_cv: conv 50 | 51 | (* Theorems *) 52 | val iffD_th: thm 53 | val nn_create_th: thm 54 | val nn_cancel_th: thm 55 | val to_contra_form_th: thm 56 | val to_contra_form_th': thm 57 | val atomize_imp_th: thm 58 | val atomize_all_th: thm 59 | val conjunct1_th: thm 60 | val conjunct2_th: thm 61 | val conjI_th: thm 62 | val or_intro1_th: thm 63 | val or_intro2_th: thm 64 | val iffD1_th: thm 65 | val iffD2_th: thm 66 | val inv_back_th: thm 67 | val sym_th: thm 68 | val exE_th': thm 69 | val eq_True_th: thm 70 | val eq_True_inv_th: thm 71 | val disj_True1_th: thm 72 | val disj_True2_th: thm 73 | val ex_vardef_th: thm 74 | val imp_conv_disj_th: thm 75 | val de_Morgan_conj_th: thm 76 | val de_Morgan_disj_th: thm 77 | val not_ex_th: thm 78 | val not_all_th: thm 79 | val not_imp_th: thm 80 | val or_cancel1_th: thm 81 | val or_cancel2_th: thm 82 | val swap_all_disj_th: thm 83 | val swap_ex_conj_th: thm 84 | val all_trivial_th: thm 85 | val case_split_th: thm 86 | 87 | (* Theorems for proofstep module *) 88 | val atomize_conjL_th: thm 89 | val backward_conv_th: thm 90 | val backward1_conv_th: thm 91 | val backward2_conv_th: thm 92 | val resolve_conv_th: thm 93 | 94 | (* Other theorems *) 95 | val contra_triv_th: thm 96 | 97 | (* AC for conj and disj *) 98 | val conj_assoc_th: thm 99 | val conj_commute_th: thm 100 | val disj_assoc_th: thm 101 | val disj_commute_th: thm 102 | 103 | (* Member, Ball and Bex *) 104 | val Mem_name: string 105 | val Ball_name: string 106 | val Bex_name: string 107 | val Bex_def_th: thm 108 | val Ball_def_th: thm 109 | end 110 | -------------------------------------------------------------------------------- /wellform.ML: -------------------------------------------------------------------------------- 1 | (* 2 | File: wellform.ML 3 | Author: Bohua Zhan 4 | 5 | Wellformed-ness of terms. 6 | *) 7 | 8 | signature WELLFORM = 9 | sig 10 | val register_wellform_data: string * string list -> theory -> theory 11 | val lookup_wellform_data: theory -> term -> term list 12 | val is_subterm_wellform_data': 13 | theory -> term -> term -> (term * term) option 14 | val is_subterm_wellform_data: 15 | theory -> term -> term list -> (term * term) option 16 | val lookup_wellform_pattern: theory -> term * term -> (term * term) option 17 | end; 18 | 19 | structure WellForm : WELLFORM = 20 | struct 21 | 22 | (* Each entry in the table consists of a term of the form f ?a_1 23 | ... ?a_n, where f is a constant, and each ?a_i is a pure schematic 24 | variable, paired with a list of requirements for the term to be 25 | valid. It is indexed under the string of the constant f. 26 | *) 27 | structure Data = Theory_Data ( 28 | type T = (term * term list) Symtab.table 29 | val empty = Symtab.empty; 30 | val merge = Symtab.merge (op =) 31 | ) 32 | 33 | (* Add a term with its requirements to the table. *) 34 | fun register_wellform_data (t_str, req_strs) thy = 35 | let 36 | val ctxt = Proof_Context.init_global thy 37 | val t = Proof_Context.read_term_pattern ctxt t_str 38 | val ctxt' = Variable.declare_term t ctxt 39 | val reqs = map (Proof_Context.read_term_pattern ctxt') req_strs 40 | 41 | val (f, args) = Term.strip_comb t 42 | val _ = assert (Term.is_Const f) 43 | "add_wellform_data: head must be Const." 44 | val _ = assert (forall Term.is_Free args) 45 | "add_wellform_data: arguments must be Free." 46 | val (c, _) = Term.dest_Const f 47 | in 48 | thy |> Data.map (Symtab.update_new (c, (t, reqs))) 49 | end 50 | 51 | (* Lookup table for the given term t. If nothing is found, return the 52 | empty list by default. 53 | *) 54 | fun lookup_wellform_data thy t = 55 | let 56 | val (f, args) = Term.strip_comb t 57 | val data = Data.get thy 58 | in 59 | case f of 60 | Const (c, _) => 61 | (case Symtab.lookup data c of 62 | NONE => [] 63 | | SOME (t', reqs) => 64 | let 65 | val (_, vars) = Term.strip_comb t' 66 | in 67 | if length vars <> length args then [] else 68 | let 69 | val tys = map fastype_of vars ~~ map fastype_of args 70 | val tyinst = fold (Sign.typ_match thy) tys Vartab.empty 71 | val vars' = map (Envir.subst_term_types tyinst) vars 72 | fun subst_fun req = 73 | req |> Envir.subst_term_types tyinst 74 | |> Term.subst_atomic (vars' ~~ args) 75 | in 76 | distinct (op aconv) (map subst_fun reqs) 77 | end 78 | handle Type.TYPE_MATCH => [] 79 | end) 80 | | _ => [] 81 | end 82 | 83 | (* Check whether req is part of the wellformed-ness data of a subterm 84 | of t. If so, return the pair SOME (t', req), where t' is a subterm 85 | of t and req is a wellformed-ness data of t'. Otherwise return 86 | NONE. 87 | *) 88 | fun is_subterm_wellform_data' thy req t = 89 | if member (op aconv) (lookup_wellform_data thy t) req then 90 | SOME (t, req) 91 | else let 92 | val (_, args) = Term.strip_comb t 93 | in 94 | get_first (is_subterm_wellform_data' thy req) args 95 | end 96 | 97 | fun is_subterm_wellform_data thy req ts = 98 | get_first (is_subterm_wellform_data' thy req) ts 99 | 100 | (* Given a term t and wellform data for t, return the relevant 101 | wellform pattern. 102 | *) 103 | fun lookup_wellform_pattern thy (t, wf_t) = 104 | let 105 | val (f, args) = Term.strip_comb t 106 | val data = Data.get thy 107 | in 108 | case f of 109 | Const (c, _) => 110 | (case Symtab.lookup data c of 111 | NONE => NONE 112 | | SOME (t', reqs) => 113 | let 114 | val (_, vars) = Term.strip_comb t' 115 | in 116 | if length vars <> length args then NONE 117 | else let 118 | val tys = map fastype_of vars ~~ map fastype_of args 119 | val tyinst = fold (Sign.typ_match thy) tys Vartab.empty 120 | val vars' = map (Envir.subst_term_types tyinst) vars 121 | fun subst_fun t = 122 | t |> Envir.subst_term_types tyinst 123 | |> Term.subst_atomic (vars' ~~ args) 124 | val reqs' = filter (fn req => wf_t aconv subst_fun req) reqs 125 | in 126 | case reqs' of 127 | [] => NONE 128 | | req' :: _ => 129 | SOME (apply2 (Envir.subst_term_types tyinst) (t', req')) 130 | end 131 | end) 132 | | _ => NONE 133 | end 134 | 135 | end (* structure WellForm. *) 136 | 137 | val register_wellform_data = WellForm.register_wellform_data 138 | --------------------------------------------------------------------------------